From 24030c621fd48d990978998c9f99c0073d52a796 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 21 Apr 2022 00:42:09 -0700 Subject: [PATCH 001/814] (geopot) added J2 gravity term as external force from a central, oblate body tilted by an arbitrary angle --- build/Makefile | 3 +- src/main/extern_geopot.f90 | 134 ++++++++++++++++++++++++++++++++++++ src/main/externalforces.F90 | 40 ++++++----- src/main/physcon.f90 | 1 + src/setup/setup_binary.f90 | 11 ++- src/tests/test_externf.f90 | 2 + 6 files changed, 171 insertions(+), 20 deletions(-) create mode 100644 src/main/extern_geopot.f90 diff --git a/build/Makefile b/build/Makefile index 455c7a6c0..490b083bf 100644 --- a/build/Makefile +++ b/build/Makefile @@ -448,6 +448,7 @@ SRCPOTS= extern_corotate.f90 \ extern_densprofile.f90 \ extern_staticsine.f90 \ extern_gwinspiral.f90 \ + extern_geopot.f90 \ externalforces.F90 endif ifeq (X$(SRCPOT), X) @@ -1293,4 +1294,4 @@ cleandist: clean cleanall rm -f .make_lastsystem .make_lastsetup .make_lastfppflags .depends cleanmathflags: - rm -f .make_mathflags bin/getmathflags \ No newline at end of file + rm -f .make_mathflags bin/getmathflags diff --git a/src/main/extern_geopot.f90 b/src/main/extern_geopot.f90 new file mode 100644 index 000000000..8f5847314 --- /dev/null +++ b/src/main/extern_geopot.f90 @@ -0,0 +1,134 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.bitbucket.io/ ! +!--------------------------------------------------------------------------! +module extern_geopot +! +! Implementation of external forces from geopotential model +! +! Currently only implements J2, i.e. effect of oblateness +! but could be extended to deal with higher order terms +! +! Spin vector direction is arbitrary +! +! :References: https://en.wikipedia.org/wiki/Geopotential_model +! Hong et al. (2021), ApJ 920, 151 +! +! :Owner: Daniel Price +! +! :Runtime parameters: +! - J2 : *J2 parameter* +! +! :Dependencies: infile_utils, io, kernel, physcon +! + implicit none + ! + !--code input parameters: these are the default values + ! and can be changed in the input file + ! + real, public :: J2 = 0. + real, public :: tilt_angle = 0. + real, private :: sin_angle = 0. + real, private :: cos_angle = 1. + + public :: get_geopot_force + public :: write_options_geopot, read_options_geopot + private + +contains + +!------------------------------------------------ +!+ +! Compute higher order terms in the acceleration +! namely the J2 term caused by oblateness +!+ +!------------------------------------------------ +subroutine get_geopot_force(xi,yi,zi,dr,mdr3,Rp,fextxi,fextyi,fextzi,phi) + real, intent(in) :: xi,yi,zi + real, intent(in) :: dr ! 1/r + real, intent(in) :: mdr3 ! GM/r^3 + real, intent(in) :: Rp ! radius of bodys + real, intent(inout) :: fextxi,fextyi,fextzi + real, intent(inout) :: phi + real :: spinvec(3),r_dot_s,term,term1,term2 + + call get_spinvec(spinvec) + + ! Equation 1 of Hong et al. (2021) + r_dot_s = (xi*spinvec(1) + yi*spinvec(2) + zi*spinvec(3))*dr + term = 1.5*J2*(Rp*dr)**2*mdr3 + term1 = term*(5.*r_dot_s**2 - 1.) + term2 = term*(-2.*r_dot_s)/dr + + fextxi = fextxi + term1*xi + term2*spinvec(1) + fextyi = fextyi + term1*yi + term2*spinvec(2) + fextzi = fextzi + term1*zi + term2*spinvec(3) + + ! potential is as given in wikipedia except we replace z/r with r_dot_s + phi = phi + 0.5*J2*(Rp**2)*mdr3*(3.*r_dot_s**2 - 1.) + +end subroutine get_geopot_force + +!--------------------------------------------------------------- +!+ +! Define speed and direction of rotation +! At present direction is hard-wired to rotation in x-y plane +!+ +!--------------------------------------------------------------- +subroutine get_spinvec(spinvec) + real, intent(out) :: spinvec(3) + + spinvec = (/sin_angle,0.,cos_angle/) + +end subroutine get_spinvec + +!----------------------------------------------------------------------- +!+ +! writes input options to the input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_geopot(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + call write_inopt(J2,'J2','J2 value in code units',iunit) + call write_inopt(tilt_angle,'tilt_angle','tilt angle (obliquity) in degrees',iunit) + +end subroutine write_options_geopot + +!----------------------------------------------------------------------- +!+ +! reads input options from the input file +!+ +!----------------------------------------------------------------------- +subroutine read_options_geopot(name,valstring,imatch,igotall,ierr) + use io, only:fatal + use physcon, only:deg_to_rad + 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_geopot' + + igotall = .false. + imatch = .true. + select case(trim(name)) + case('J2') + read(valstring,*,iostat=ierr) J2 + ngot = ngot + 1 + case('tilt_angle') + read(valstring,*,iostat=ierr) tilt_angle + sin_angle = sin(tilt_angle*deg_to_rad) + cos_angle = cos(tilt_angle*deg_to_rad) + ngot = ngot + 1 + case default + imatch = .false. + end select + + igotall = (ngot >= 2) + +end subroutine read_options_geopot + +end module extern_geopot diff --git a/src/main/externalforces.F90 b/src/main/externalforces.F90 index 75aa7ffd4..bccf23f41 100644 --- a/src/main/externalforces.F90 +++ b/src/main/externalforces.F90 @@ -14,7 +14,6 @@ module externalforces ! ! :Runtime parameters: ! - accradius1 : *soft accretion radius of central object* -! - accradius1_hard : *hard accretion radius of central object* ! - eps_soft : *softening length (Plummer) for central potential in code units* ! - mass1 : *mass of central object in code units* ! @@ -44,7 +43,6 @@ module externalforces real, private :: eps2_soft = 0.d0 real, public :: Rdisc = 5. - real, public :: accradius1_hard = 0. logical, public :: extract_iextern_from_hdr = .false. ! @@ -66,12 +64,13 @@ module externalforces iext_staticsine = 13, & iext_gwinspiral = 14, & iext_discgravity = 15, & - iext_corot_binary = 16 + iext_corot_binary = 16, & + iext_geopot = 17 ! ! Human-readable labels for these ! - integer, parameter, public :: iexternalforce_max = 16 + integer, parameter, public :: iexternalforce_max = 17 character(len=*), parameter, public :: externalforcetype(iexternalforce_max) = (/ & 'star ', & 'corotate ', & @@ -88,7 +87,8 @@ module externalforces 'static sinusoid ', & 'grav. wave inspiral ', & 'disc gravity ', & - 'corotating binary '/) + 'corotating binary ', & + 'geopotential model '/) contains !----------------------------------------------------------------------- @@ -113,6 +113,7 @@ subroutine externalforce(iexternalforce,xi,yi,zi,hi,ti,fextxi,fextyi,fextzi,phi, use extern_Bfield, only:get_externalB_force use extern_staticsine, only:staticsine_force use extern_gwinspiral, only:get_gw_force_i + use extern_geopot, only:get_geopot_force use units, only:udist,umass,utime use physcon, only:pc,pi,gg use io, only:fatal @@ -139,7 +140,7 @@ subroutine externalforce(iexternalforce,xi,yi,zi,hi,ti,fextxi,fextyi,fextzi,phi, select case(iexternalforce) - case(iext_star, iext_lensethirring) + case(iext_star,iext_lensethirring,iext_geopot) ! !--1/r^2 force from central point mass ! @@ -158,6 +159,10 @@ subroutine externalforce(iexternalforce,xi,yi,zi,hi,ti,fextxi,fextyi,fextzi,phi, phi = -mass1*dr endif + if (iexternalforce==iext_geopot) then + call get_geopot_force(xi,yi,zi,dr,dr3,accradius1,fextxi,fextyi,fextzi,phi) + endif + case(iext_corotate) ! !--spatial part of forces in corotating frame, i.e. centrifugal force @@ -577,8 +582,6 @@ end subroutine update_externalforce !----------------------------------------------------------------------- subroutine accrete_particles(iexternalforce,xi,yi,zi,hi,mi,ti,accreted) use extern_binary, only:binary_accreted,accradius1 - use part, only:set_particle_type,iboundary,maxphase,maxp,igas - !use part, only:npartoftype integer, intent(in) :: iexternalforce real, intent(in) :: xi,yi,zi,mi,ti real, intent(inout) :: hi @@ -641,6 +644,7 @@ subroutine write_options_externalforces(iunit,iexternalforce) use extern_Bfield, only:write_options_externB use extern_staticsine, only:write_options_staticsine use extern_gwinspiral, only:write_options_gwinspiral + use extern_geopot, only:write_options_geopot integer, intent(in) :: iunit,iexternalforce character(len=80) :: string @@ -650,11 +654,9 @@ subroutine write_options_externalforces(iunit,iexternalforce) call write_inopt(iexternalforce,'iexternalforce',trim(string),iunit) select case(iexternalforce) - case(iext_star,iext_prdrag,iext_lensethirring,iext_einsteinprec,iext_gnewton) + case(iext_star,iext_prdrag,iext_lensethirring,iext_einsteinprec,iext_gnewton,iext_geopot) call write_inopt(mass1,'mass1','mass of central object in code units',iunit) - if (accradius1_hard < tiny(0.)) accradius1_hard = accradius1 call write_inopt(accradius1,'accradius1','soft accretion radius of central object',iunit) - call write_inopt(accradius1_hard,'accradius1_hard','hard accretion radius of central object',iunit) end select select case(iexternalforce) @@ -682,6 +684,8 @@ subroutine write_options_externalforces(iunit,iexternalforce) call write_options_staticsine(iunit) case(iext_gwinspiral) call write_options_gwinspiral(iunit) + case(iext_geopot) + call write_options_geopot(iunit) end select end subroutine write_options_externalforces @@ -747,6 +751,7 @@ subroutine read_options_externalforces(name,valstring,imatch,igotall,ierr,iexter use extern_Bfield, only:read_options_externB use extern_staticsine, only:read_options_staticsine use extern_gwinspiral, only:read_options_gwinspiral + use extern_geopot, only:read_options_geopot character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr @@ -754,7 +759,7 @@ subroutine read_options_externalforces(name,valstring,imatch,igotall,ierr,iexter integer, save :: ngot = 0 logical :: igotallcorotate,igotallbinary,igotallprdrag logical :: igotallltforce,igotallspiral,igotallexternB - logical :: igotallstaticsine,igotallgwinspiral + logical :: igotallstaticsine,igotallgwinspiral,igotallgeopot character(len=30), parameter :: tag = 'externalforces' imatch = .true. @@ -767,6 +772,7 @@ subroutine read_options_externalforces(name,valstring,imatch,igotall,ierr,iexter igotallltforce = .true. igotallstaticsine = .true. igotallgwinspiral = .true. + igotallgeopot = .true. !call read_inopt(db,'iexternalforce',iexternalforce,min=0,max=9,required=true) !if (imatch) ngot = ngot + 1 @@ -785,10 +791,6 @@ subroutine read_options_externalforces(name,valstring,imatch,igotall,ierr,iexter read(valstring,*,iostat=ierr) accradius1 if (iexternalforce <= 0) call warn(tag,'no external forces: ignoring accradius1 value') if (accradius1 < 0.) call fatal(tag,'negative accretion radius') - case('accradius1_hard') - read(valstring,*,iostat=ierr) accradius1_hard - if (iexternalforce <= 0) call warn(tag,'no external forces: ignoring accradius1_hard value') - if (accradius1_hard > accradius1) call fatal(tag,'hard accretion boundary must be within soft accretion boundary') case('eps_soft') read(valstring,*,iostat=ierr) eps_soft if (iexternalforce <= 0) call warn(tag,'no external forces: ignoring accradius1 value') @@ -816,17 +818,19 @@ subroutine read_options_externalforces(name,valstring,imatch,igotall,ierr,iexter call read_options_staticsine(name,valstring,imatch,igotallstaticsine,ierr) case(iext_gwinspiral) call read_options_gwinspiral(name,valstring,imatch,igotallgwinspiral,ierr) + case(iext_geopot) + call read_options_geopot(name,valstring,imatch,igotallgwinspiral,ierr) end select end select igotall = (ngot >= 1 .and. igotallcorotate .and. & igotallbinary .and. igotallprdrag .and. & igotallspiral .and. igotallltforce .and. & igotallexternB .and. igotallstaticsine .and. & - igotallgwinspiral) + igotallgwinspiral .and. igotallgeopot) !--make sure mass is read where relevant select case(iexternalforce) - case(iext_star,iext_lensethirring,iext_einsteinprec,iext_gnewton) + case(iext_star,iext_lensethirring,iext_einsteinprec,iext_gnewton,iext_geopot) igotall = igotall .and. (ngot >= 2) end select diff --git a/src/main/physcon.f90 b/src/main/physcon.f90 index 4d107fe0e..a8b5283ae 100644 --- a/src/main/physcon.f90 +++ b/src/main/physcon.f90 @@ -26,6 +26,7 @@ module physcon real(kind=8), parameter :: piontwo = 1.5707963268d0 real(kind=8), parameter :: rpiontwo = 1.2533141373d0 !square root of (Pi/2) real(kind=8), parameter :: roottwo = 1.4142135624d0 + real(kind=8), parameter :: deg_to_rad = pi/180d0 ! !--Physical constants ! diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 41bbb0636..3265e4817 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -43,7 +43,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use units, only:set_units use physcon, only:solarm,au,pi use options, only:iexternalforce - use externalforces, only:iext_corotate,omega_corotate + use externalforces, only:iext_corotate,iext_geopot,iext_star,omega_corotate,mass1,accradius1 use io, only:master integer, intent(in) :: id integer, intent(inout) :: npart @@ -105,6 +105,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_binary(m1,m2,a,ecc,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr) endif + if (iexternalforce==iext_geopot .or. iexternalforce==iext_star) then + ! delete first sink particle and copy its properties to the central potential + nptmass = nptmass - 1 + mass1 = m1 + accradius1 = hacc1 + xyzmh_ptmass(:,nptmass) = xyzmh_ptmass(:,nptmass+1) + vxyz_ptmass(:,nptmass) = vxyz_ptmass(:,nptmass+1) + endif + end subroutine setpart subroutine write_setupfile(filename) diff --git a/src/tests/test_externf.f90 b/src/tests/test_externf.f90 index 4374fc978..889fe1187 100644 --- a/src/tests/test_externf.f90 +++ b/src/tests/test_externf.f90 @@ -39,6 +39,7 @@ subroutine test_externf(ntests,npass) iext_lensethirring,iext_prdrag,iext_einsteinprec,iext_spiral,& iext_densprofile,iext_staticsine,iext_gwinspiral use extern_corotate, only:omega_corotate + use extern_geopot, only:J2 use unifdis, only:set_unifdis use units, only:set_units use physcon, only:pc,solarm @@ -85,6 +86,7 @@ subroutine test_externf(ntests,npass) nfailed(:) = 0 ncheck(:) = 0 omega_corotate = 0.5 + J2 = 0.01629 ! value of J2 for Saturn from Iess et al. (2019) do iextf=1,iexternalforce_max if (externalforcetype(iextf) /= 'none') then select case(iextf) From 56cd32d87bfd607f75500f33e2b9f8c68d05fd15 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 22 Apr 2022 16:25:46 -0700 Subject: [PATCH 002/814] (geopot) added J2 moments for sink particles; evolve spin vector due to reaction force --- src/main/checksetup.F90 | 45 +++++++++++++++--- src/main/config.F90 | 4 +- src/main/extern_geopot.f90 | 54 +++++++++------------ src/main/externalforces.F90 | 4 +- src/main/initial.F90 | 11 +++-- src/main/part.F90 | 7 ++- src/main/ptmass.F90 | 94 +++++++++++++++++++++++++++---------- src/main/step_leapfrog.F90 | 26 +++++----- src/main/utils_vectors.f90 | 52 ++++++++++++++++---- src/setup/setup_binary.f90 | 12 ++++- src/tests/test_gravity.F90 | 8 ++-- src/tests/test_ptmass.f90 | 54 +++++++++++++++------ 12 files changed, 260 insertions(+), 111 deletions(-) diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index 0030be78a..ac2ce453e 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.F90 @@ -491,12 +491,13 @@ end function in_range subroutine check_setup_ptmass(nerror,nwarn,hmin) use dim, only:maxptmass - use part, only:nptmass,xyzmh_ptmass,ihacc,ihsoft,gr,iTeff,sinks_have_luminosity + use part, only:nptmass,xyzmh_ptmass,ihacc,ihsoft,gr,iTeff,sinks_have_luminosity,& + iJ2,ispinx,ispinz,iReff integer, intent(inout) :: nerror,nwarn real, intent(in) :: hmin integer :: i,j,n real :: dx(3) - real :: r,hsink + real :: r,hsink,hsoft,J2 if (gr .and. nptmass > 0) then print*,' Warning! Error in setup: nptmass = ',nptmass, ' should be = 0 for GR' @@ -525,7 +526,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) dx = xyzmh_ptmass(1:3,j) - xyzmh_ptmass(1:3,i) r = sqrt(dot_product(dx,dx)) if (r <= tiny(r)) then - print*,'Error in setup: sink ',j,' on top of sink ',i,' at ',xyzmh_ptmass(1:3,i) + print*,'ERROR! sink ',j,' on top of sink ',i,' at ',xyzmh_ptmass(1:3,i) nerror = nerror + 1 elseif (r <= max(xyzmh_ptmass(ihacc,i),xyzmh_ptmass(ihacc,j))) then print*,'Warning: sinks ',i,' and ',j,' within each others accretion radii: sep =',& @@ -542,7 +543,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) do i=1,nptmass if (.not.in_range(xyzmh_ptmass(4,i))) then nerror = nerror + 1 - print*,' Error in setup: sink ',i,' mass = ',xyzmh_ptmass(4,i) + print*,' ERROR! sink ',i,' mass = ',xyzmh_ptmass(4,i) elseif (xyzmh_ptmass(4,i) < 0.) then print*,' Sink ',i,' has previously merged with another sink' n = n + 1 @@ -554,16 +555,46 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) ! do i=1,nptmass if (xyzmh_ptmass(4,i) < 0.) cycle - hsink = max(xyzmh_ptmass(ihacc,i),xyzmh_ptmass(ihsoft,i)) + hsoft = xyzmh_ptmass(ihsoft,i) + hsink = max(xyzmh_ptmass(ihacc,i),hsoft) if (hsink <= 0.) then nerror = nerror + 1 - print*,'Error in setup: sink ',i,' has accretion radius ',xyzmh_ptmass(ihacc,i),& + print*,'ERROR! sink ',i,' has accretion radius ',xyzmh_ptmass(ihacc,i),& ' and softening radius ',xyzmh_ptmass(ihsoft,i) elseif (hsink <= 0.5*hmin .and. hmin > 0.) then nwarn = nwarn + 1 print*,'Warning: sink ',i,' has unresolved accretion radius: hmin/racc = ',hmin/hsink print*,' (this makes the code run pointlessly slow)' endif + ! + ! check that softening and J2 are not used at the same time + ! + J2 = abs(xyzmh_ptmass(iJ2,i)) + if (hsoft > 0. .and. J2 > 0.) then + nerror = nerror + 1 + print*,'ERROR! sink ',i,' cannot have both J2 and softening length set' + endif + ! + ! check that J2 is a small number + ! + if (J2 > 0.1) then + nwarn = nwarn + 1 + print*,'WARNING! J2 (oblateness) is ridiculously large on sink particle ',i,': J2 = ',J2 + endif + ! + ! if J2 is set then the spin of a sink particle should be non-zero to begin with + ! in order to specify the rotation direction + ! + if (J2 > 0.) then + if (dot_product(xyzmh_ptmass(ispinx:ispinz,i),xyzmh_ptmass(ispinx:ispinz,i)) < tiny(0.)) then + nerror = nerror + 1 + print*,'ERROR! non-zero J2 requires non-zero spin on sink particle ',i + endif + if (xyzmh_ptmass(iReff,i) < tiny(0.)) then + nerror = nerror + 1 + print*,'ERROR! non-zero J2 requires radius (Reff) to be specified on sink particle',i + endif + endif enddo ! ! check that radiation properties are sensible @@ -597,7 +628,7 @@ subroutine check_setup_growth(npart,nerror) do j=1,2 if (nbad(j) > 0) then - print*,'ERROR: ',nbad,' of ',npart,' with '//trim(dustprop_label(j))//' < 0' + print*,'ERROR! ',nbad,' of ',npart,' with '//trim(dustprop_label(j))//' < 0' nerror = nerror + 1 endif enddo diff --git a/src/main/config.F90 b/src/main/config.F90 index 517ff5439..bf59519e3 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -28,7 +28,7 @@ module dim public character(len=80), parameter :: & - tagline='Phantom v'//phantom_version_string//' (c) 2007-2020 The Authors' + tagline='Phantom v'//phantom_version_string//' (c) 2007-2022 The Authors' ! maximum number of particles integer :: maxp = 0 ! memory not allocated initially @@ -44,7 +44,7 @@ module dim #else integer, parameter :: maxptmass = 1000 #endif - integer, parameter :: nsinkproperties = 18 + integer, parameter :: nsinkproperties = 19 ! storage of thermal energy or not #ifdef ISOTHERMAL diff --git a/src/main/extern_geopot.f90 b/src/main/extern_geopot.f90 index 8f5847314..6f23e6c70 100644 --- a/src/main/extern_geopot.f90 +++ b/src/main/extern_geopot.f90 @@ -28,10 +28,9 @@ module extern_geopot !--code input parameters: these are the default values ! and can be changed in the input file ! - real, public :: J2 = 0. - real, public :: tilt_angle = 0. - real, private :: sin_angle = 0. - real, private :: cos_angle = 1. + real, public :: J2 = 0. + real, public :: spinvec(3) = 0. + real, private :: tilt_angle = 0. public :: get_geopot_force public :: write_options_geopot, read_options_geopot @@ -45,45 +44,39 @@ module extern_geopot ! namely the J2 term caused by oblateness !+ !------------------------------------------------ -subroutine get_geopot_force(xi,yi,zi,dr,mdr3,Rp,fextxi,fextyi,fextzi,phi) +subroutine get_geopot_force(xi,yi,zi,dr,mdr3,Rp,J2i,si,fxi,fyi,fzi,phi,dsx,dsy,dsz) real, intent(in) :: xi,yi,zi real, intent(in) :: dr ! 1/r real, intent(in) :: mdr3 ! GM/r^3 - real, intent(in) :: Rp ! radius of bodys - real, intent(inout) :: fextxi,fextyi,fextzi + real, intent(in) :: Rp ! radius of body + real, intent(in) :: J2i ! J2 + real, intent(in) :: si(3) ! unit spin vector + real, intent(inout) :: fxi,fyi,fzi real, intent(inout) :: phi - real :: spinvec(3),r_dot_s,term,term1,term2 - - call get_spinvec(spinvec) + real, intent(inout), optional :: dsx,dsy,dsz + real :: r_dot_s,term,term1,term2 ! Equation 1 of Hong et al. (2021) - r_dot_s = (xi*spinvec(1) + yi*spinvec(2) + zi*spinvec(3))*dr - term = 1.5*J2*(Rp*dr)**2*mdr3 + r_dot_s = (xi*si(1) + yi*si(2) + zi*si(3))*dr + term = 1.5*J2i*(Rp*dr)**2*mdr3 term1 = term*(5.*r_dot_s**2 - 1.) term2 = term*(-2.*r_dot_s)/dr - fextxi = fextxi + term1*xi + term2*spinvec(1) - fextyi = fextyi + term1*yi + term2*spinvec(2) - fextzi = fextzi + term1*zi + term2*spinvec(3) + fxi = fxi + term1*xi + term2*si(1) + fyi = fyi + term1*yi + term2*si(2) + fzi = fzi + term1*zi + term2*si(3) + if (present(dsx)) then + ! reaction torque on extended body (time derivative of spin, r x F) + dsx = dsx - term2*(yi*si(3) - zi*si(2)) + dsy = dsy - term2*(zi*si(1) - xi*si(3)) + dsz = dsz - term2*(xi*si(2) - yi*si(1)) + endif ! potential is as given in wikipedia except we replace z/r with r_dot_s - phi = phi + 0.5*J2*(Rp**2)*mdr3*(3.*r_dot_s**2 - 1.) + phi = phi + 0.5*J2*(Rp**2)*mdr3*(3.*r_dot_s**2 - 1.) end subroutine get_geopot_force -!--------------------------------------------------------------- -!+ -! Define speed and direction of rotation -! At present direction is hard-wired to rotation in x-y plane -!+ -!--------------------------------------------------------------- -subroutine get_spinvec(spinvec) - real, intent(out) :: spinvec(3) - - spinvec = (/sin_angle,0.,cos_angle/) - -end subroutine get_spinvec - !----------------------------------------------------------------------- !+ ! writes input options to the input file @@ -120,8 +113,7 @@ subroutine read_options_geopot(name,valstring,imatch,igotall,ierr) ngot = ngot + 1 case('tilt_angle') read(valstring,*,iostat=ierr) tilt_angle - sin_angle = sin(tilt_angle*deg_to_rad) - cos_angle = cos(tilt_angle*deg_to_rad) + spinvec = (/sin(tilt_angle*deg_to_rad),0.,cos(tilt_angle*deg_to_rad)/) ngot = ngot + 1 case default imatch = .false. diff --git a/src/main/externalforces.F90 b/src/main/externalforces.F90 index bccf23f41..7b76b226e 100644 --- a/src/main/externalforces.F90 +++ b/src/main/externalforces.F90 @@ -113,7 +113,7 @@ subroutine externalforce(iexternalforce,xi,yi,zi,hi,ti,fextxi,fextyi,fextzi,phi, use extern_Bfield, only:get_externalB_force use extern_staticsine, only:staticsine_force use extern_gwinspiral, only:get_gw_force_i - use extern_geopot, only:get_geopot_force + use extern_geopot, only:get_geopot_force,J2,spinvec use units, only:udist,umass,utime use physcon, only:pc,pi,gg use io, only:fatal @@ -160,7 +160,7 @@ subroutine externalforce(iexternalforce,xi,yi,zi,hi,ti,fextxi,fextyi,fextzi,phi, endif if (iexternalforce==iext_geopot) then - call get_geopot_force(xi,yi,zi,dr,dr3,accradius1,fextxi,fextyi,fextzi,phi) + call get_geopot_force(xi,yi,zi,dr,dr3,accradius1,J2,spinvec,fextxi,fextyi,fextzi,phi) endif case(iext_corotate) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index cf334db92..bf2e9e65b 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -124,8 +124,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use readwrite_dumps, only:read_dump,write_fulldump use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,Bevol,dBevol,& npartoftype,maxtypes,ndusttypes,alphaind,ntot,ndim,update_npartoftypetot,& - maxphase,iphase,isetphase,iamtype, & - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,igas,idust,massoftype,& + maxphase,iphase,isetphase,iamtype,igas,idust,massoftype, & + nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& nden_nimhd,dustevol,rhoh,gradh, & Bevol,Bxyz,dustprop,ddustprop,ndustsmall,iboundary,eos_vars,dvdx @@ -226,7 +226,10 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) integer :: itype,iposinit,ipostmp,ntypes,nderivinit logical :: iexist,read_input_files integer :: ncount(maxtypes) - character(len=len(dumpfile)) :: dumpfileold,file1D + character(len=len(dumpfile)) :: dumpfileold +#ifdef INJECT_PARTICLES + character(len=len(dumpfile)) :: file1D +#endif character(len=7) :: dust_label(maxdusttypes) read_input_files = .true. @@ -479,7 +482,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) ! compute initial sink-sink forces and get timestep call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& - iexternalforce,time,merge_ij,merge_n) + iexternalforce,time,merge_ij,merge_n,dsdt_ptmass) dtsinksink = C_force*dtsinksink if (id==master) write(iprint,*) 'dt(sink-sink) = ',dtsinksink dtextforce = min(dtextforce,dtsinksink) diff --git a/src/main/part.F90 b/src/main/part.F90 index 8b2f91ace..4b0257c9d 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -167,16 +167,18 @@ module part integer, parameter :: imdotav = 16 ! accretion rate average integer, parameter :: i_mlast = 17 ! accreted mass of last time integer, parameter :: imassenc = 18 ! mass enclosed in sink softening radius + integer, parameter :: iJ2 = 19 ! 2nd gravity moment due to oblateness real, allocatable :: xyzmh_ptmass(:,:) real, allocatable :: vxyz_ptmass(:,:) real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:) + real, allocatable :: dsdt_ptmass(:,:) integer :: nptmass = 0 ! zero by default real :: epot_sinksink character(len=*), parameter :: xyzmh_ptmass_label(nsinkproperties) = & (/'x ','y ','z ','m ','h ',& 'hsoft ','maccreted','spinx ','spiny ','spinz ',& 'tlast ','lum ','Teff ','Reff ','mdotloss ',& - 'mdotav ','mprev ','massenc '/) + 'mdotav ','mprev ','massenc ','J2 '/) character(len=*), parameter :: vxyz_ptmass_label(3) = (/'vx','vy','vz'/) ! !--self-gravity @@ -454,6 +456,7 @@ subroutine allocate_part call allocate_array('vxyz_ptmass', vxyz_ptmass, 3, maxptmass) call allocate_array('fxyz_ptmass', fxyz_ptmass, 4, maxptmass) call allocate_array('fxyz_ptmass_sinksink', fxyz_ptmass_sinksink, 4, maxptmass) + call allocate_array('dsdt_ptmass', dsdt_ptmass, 3, maxptmass) call allocate_array('poten', poten, maxgrav) call allocate_array('nden_nimhd', nden_nimhd, n_nden_phantom, maxmhdni) call allocate_array('eta_nimhd', eta_nimhd, 4, maxmhdni) @@ -531,6 +534,7 @@ subroutine deallocate_part if (allocated(vxyz_ptmass)) deallocate(vxyz_ptmass) if (allocated(fxyz_ptmass)) deallocate(fxyz_ptmass) if (allocated(fxyz_ptmass_sinksink)) deallocate(fxyz_ptmass_sinksink) + if (allocated(dsdt_ptmass)) deallocate(dsdt_ptmass) if (allocated(poten)) deallocate(poten) if (allocated(nden_nimhd)) deallocate(nden_nimhd) if (allocated(eta_nimhd)) deallocate(eta_nimhd) @@ -586,6 +590,7 @@ subroutine init_part !--initialise point mass arrays to zero xyzmh_ptmass = 0. vxyz_ptmass = 0. + dsdt_ptmass = 0. ! initialise arrays not passed to setup routine to zero if (mhd) then diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index c4013ba81..1f451408c 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -36,7 +36,8 @@ module ptmass ! fastmath, infile_utils, io, io_summary, kdtree, kernel, linklist, ! mpidomain, mpiutils, options, part, units ! - use part, only:nsinkproperties,gravity,is_accretable + use part, only:nsinkproperties,gravity,is_accretable,& + ihsoft,ihacc,ispinx,ispiny,ispinz,imacc,iJ2,iReff use io, only:iscfile,iskfile,id,master implicit none character(len=80), parameter, public :: & ! module version @@ -118,10 +119,11 @@ module ptmass subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, & pmassi,fxyz_ptmass,fonrmax,dtphi2) #ifdef FINVSQRT - use fastmath, only:finvsqrt + use fastmath, only:finvsqrt #endif - use kernel, only:kernel_softening,radkern - use part, only:ihacc,ihsoft + use kernel, only:kernel_softening,radkern + use vectorutils, only:unitvec + use extern_geopot, only:get_geopot_force integer, intent(in) :: nptmass real, intent(in) :: xi,yi,zi,hi real, intent(inout) :: fxi,fyi,fzi,phi @@ -130,7 +132,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, real, optional, intent(inout) :: fxyz_ptmass(4,nptmass) real, optional, intent(out) :: fonrmax,dtphi2 real :: ftmpxi,ftmpyi,ftmpzi - real :: dx,dy,dz,rr2,ddr,dr3,f1,f2,pmassj + real :: dx,dy,dz,rr2,ddr,dr3,f1,f2,pmassj,J2,shat(3),Rsink real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft integer :: j logical :: tofrom @@ -156,6 +158,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, dz = zi - xyzmh_ptmass(3,j) pmassj = xyzmh_ptmass(4,j) hsoft = xyzmh_ptmass(ihsoft,j) + J2 = xyzmh_ptmass(iJ2,j) if (hsoft > 0.0) hsoft = max(hsoft,hi) if (pmassj < 0.0) cycle @@ -196,6 +199,13 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, ftmpzi = ftmpzi - dz*f1 phi = phi - pmassj*ddr ! potential (GM/r) + ! additional accelerations due to oblateness + if (abs(J2) > 0.) then + shat = unitvec(xyzmh_ptmass(ispinx:ispinz,j)) + Rsink = xyzmh_ptmass(iReff,j) + call get_geopot_force(dx,dy,dz,ddr,f1,Rsink,J2,shat,ftmpxi,ftmpyi,ftmpzi,phi) + endif + ! acceleration of sink from gas if (tofrom) f2 = pmassi*dr3 endif @@ -237,12 +247,14 @@ end subroutine get_accel_sink_gas !+ !---------------------------------------------------------------- subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,& - iexternalforce,ti,merge_ij,merge_n) + iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif use externalforces, only:externalforce + use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern + use vectorutils, only:unitvec integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(out) :: fxyz_ptmass(4,nptmass) @@ -250,15 +262,19 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin integer, intent(in) :: iexternalforce real, intent(in) :: ti integer, intent(out) :: merge_ij(:),merge_n + real, intent(out) :: dsdt_ptmass(3,nptmass) real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii real :: ddr,dx,dy,dz,rr2,rr2j,dr3,f1,f2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft real :: fextx,fexty,fextz,phiext !,hsofti - real :: fterm,pterm,potensoft0 + real :: fterm,pterm,potensoft0,dsx,dsy,dsz + real :: J2i,rsinki,shati(3) + real :: J2j,rsinkj,shatj(3) integer :: i,j dtsinksink = huge(dtsinksink) fxyz_ptmass(:,:) = 0. + dsdt_ptmass(:,:) = 0. phitot = 0. merge_n = 0 merge_ij = 0 @@ -278,14 +294,14 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !--compute N^2 forces on point mass particles due to each other ! !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & !$omp private(i,xi,yi,zi,pmassi,pmassj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & - !$omp private(fxi,fyi,fzi,phii) & + !$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) & + !$omp private(fterm,pterm,J2i,J2j,shati,shatj,rsinki,rsinkj) & !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) do i=1,nptmass @@ -295,10 +311,15 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin pmassi = xyzmh_ptmass(4,i) !hsofti = xyzmh_ptmass(5,i) if (pmassi < 0.) cycle + J2i = xyzmh_ptmass(iJ2,i) + fxi = 0. fyi = 0. fzi = 0. phii = 0. + dsx = 0. + dsy = 0. + dsz = 0. do j=1,nptmass if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) @@ -307,6 +328,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin pmassj = xyzmh_ptmass(4,j) !hsoftj = xyzmh_ptmass(5,j) if (pmassj < 0.) cycle + J2j = xyzmh_ptmass(iJ2,j) rr2 = dx*dx + dy*dy + dz*dz + epsilon(rr2) @@ -344,6 +366,18 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin fzi = fzi - dz*f1 pterm = -ddr phii = phii + pmassj*pterm ! potential (GM/r) + + ! additional acceleration due to oblateness of sink particles j and i + if (abs(J2j) > 0.) then + shatj = unitvec(xyzmh_ptmass(ispinx:ispinz,j)) + rsinkj = xyzmh_ptmass(iReff,j) + call get_geopot_force(dx,dy,dz,ddr,f1,rsinkj,J2j,shatj,fxi,fyi,fzi,phii) + endif + if (abs(J2i) > 0.) then + shati = unitvec(xyzmh_ptmass(ispinx:ispinz,i)) + rsinki = xyzmh_ptmass(iReff,i) + call get_geopot_force(dx,dy,dz,ddr,f1,rsinki,J2i,shati,fxi,fyi,fzi,phii,dsx,dsy,dsz) + endif endif if (rr2 < r_merge2) then if (merge_ij(i)==0) then @@ -358,8 +392,10 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin if (rr2 < rr2j) merge_ij(i) = j endif endif - phitot = phitot + 0.5*pmassi*pmassj*pterm ! total potential (G M_1 M_2/r) +! phitot = phitot + 0.5*pmassi*pmassj*pterm ! total potential (G M_1 M_2/r) enddo + phitot = phitot + 0.5*pmassi*phii ! total potential (G M_1 M_2/r) + ! !--apply external forces @@ -389,6 +425,9 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + fyi fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + fzi fxyz_ptmass(4,i) = fxyz_ptmass(4,i) + phii + dsdt_ptmass(1,i) = dsdt_ptmass(1,i) + pmassi*dsx + dsdt_ptmass(2,i) = dsdt_ptmass(2,i) + pmassi*dsy + dsdt_ptmass(3,i) = dsdt_ptmass(3,i) + pmassi*dsz enddo !$omp end parallel do @@ -440,17 +479,17 @@ end subroutine ptmass_boundary_crossing ! (called from inside a parallel section) !+ !---------------------------------------------------------------- -subroutine ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass) +subroutine ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) integer, intent(in) :: nptmass real, intent(in) :: dt real, intent(inout) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: vxyz_ptmass(3,nptmass) - real, intent(in) :: fxyz_ptmass(4,nptmass) + real, intent(in) :: fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) real :: vxhalfi,vyhalfi,vzhalfi integer :: i !$omp parallel do schedule(static) default(none) & - !$omp shared(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass) & + !$omp shared(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) & !$omp private(i,vxhalfi,vyhalfi,vzhalfi) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then @@ -463,6 +502,9 @@ subroutine ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass) vxyz_ptmass(1,i) = vxhalfi vxyz_ptmass(2,i) = vyhalfi vxyz_ptmass(3,i) = vzhalfi + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + 0.5*dt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + 0.5*dt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + 0.5*dt*dsdt_ptmass(3,i) endif enddo !$omp end parallel do @@ -475,12 +517,13 @@ end subroutine ptmass_predictor ! (called from inside a parallel section) !+ !---------------------------------------------------------------- -subroutine ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) +subroutine ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,iexternalforce) use externalforces, only:update_vdependent_extforce_leapfrog,is_velocity_dependent integer, intent(in) :: nptmass real, intent(in) :: dt - real, intent(inout) :: vxyz_ptmass(3,nptmass) - real, intent(in) :: fxyz_ptmass(4,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(in) :: fxyz_ptmass(4,nptmass) + real, intent(in) :: dsdt_ptmass(3,nptmass) integer, intent(in) :: iexternalforce real :: vxhalfi,vyhalfi,vzhalfi real :: fxi,fyi,fzi,fextv(3) @@ -492,7 +535,7 @@ subroutine ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iext ! if (is_velocity_dependent(iexternalforce)) then !$omp parallel do schedule(static) default(none) & - !$omp shared(vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dt,nptmass,iexternalforce) & + !$omp shared(vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,dt,nptmass,iexternalforce) & !$omp private(vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi,fextv) & !$omp private(i) do i=1,nptmass @@ -512,18 +555,24 @@ subroutine ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iext vxyz_ptmass(1,i) = vxhalfi + 0.5*dt*fxi vxyz_ptmass(2,i) = vyhalfi + 0.5*dt*fyi vxyz_ptmass(3,i) = vzhalfi + 0.5*dt*fzi + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + 0.5*dt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + 0.5*dt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + 0.5*dt*dsdt_ptmass(3,i) endif enddo !$omp end parallel do else !$omp parallel do schedule(static) default(none) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dt,nptmass) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,nptmass) & !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + 0.5*dt*fxyz_ptmass(1,i) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + 0.5*dt*fxyz_ptmass(2,i) vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + 0.5*dt*fxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + 0.5*dt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + 0.5*dt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + 0.5*dt*dsdt_ptmass(3,i) endif enddo !$omp end parallel do @@ -784,7 +833,6 @@ end subroutine ptmass_accrete !+ !----------------------------------------------------------------------- subroutine update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) - use part, only:ispinx,ispiny,ispinz,imacc real, intent(in) :: dptmass(:,:) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(inout) :: vxyz_ptmass(:,:) @@ -846,8 +894,8 @@ end subroutine update_ptmass !------------------------------------------------------------------------- subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,time) - use part, only:ihacc,ihsoft,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & - ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP + use part, only:igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & + fxyz_ptmass_sinksink,eos_vars,igasP use dim, only:maxp,maxneigh,maxvxyzu,maxptmass use kdtree, only:getneigh use kernel, only:kernel_softening,radkern @@ -1408,7 +1456,6 @@ end subroutine ptmass_create !----------------------------------------------------------------------- subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) use io, only:iprint,warning,iverbose,id,master - use part, only:ispinx,ispiny,ispinz,imacc real, intent(in) :: time integer, intent(in) :: nptmass,merge_ij(nptmass) real, intent(inout) :: xyzmh_ptmass(nsinkproperties,nptmass) @@ -1635,7 +1682,6 @@ end subroutine pt_close_sinkev !+ !----------------------------------------------------------------------- subroutine pt_write_sinkev(nptmass,time,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink) - use part, only:ispinx,ispiny,ispinz,imacc integer, intent(in) :: nptmass real, intent(in) :: time, xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:) integer :: i,iunit diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 7b3449278..4c4e96533 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -108,7 +108,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use deriv, only:derivs use timestep, only:dterr,bignumber,tolv use mpiutils, only:reduceall_mpi - use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,ibin_wake + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,ibin_wake use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc #ifdef KROME @@ -250,7 +250,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) #else if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_implicit .or. idamp > 0) then call step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nbinmax,ibin_wake) + nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) else call step_extern_sph(dtsph,npart,xyzh,vxyzu) endif @@ -1052,7 +1052,7 @@ end subroutine step_extern_sph !+ !---------------------------------------------------------------- subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time,nptmass, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nbinmax,ibin_wake) + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome use io, only:iverbose,id,master,iprint,warning,fatal use externalforces, only:externalforce,accrete_particles,update_externalforce, & @@ -1088,7 +1088,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:),fxyzu(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) integer(kind=1), intent(in) :: nbinmax integer(kind=1), intent(inout) :: ibin_wake(:) integer :: i,itype,nsubsteps,ichem,naccreted,nfail,nfaili,merge_n @@ -1157,16 +1157,18 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, ! if (nptmass > 0) then if (id==master) then - call ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass) + call ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! ! get sink-sink forces (and a new sink-sink timestep. Note: fxyz_ptmass is zeroed in this subroutine) ! pass sink-sink forces to variable fxyz_ptmass_sinksink for later writing. ! if (iexternalforce==14) call update_externalforce(iexternalforce,timei,dmdt) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtf,iexternalforce,timei,merge_ij,merge_n) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) if (merge_n > 0) then call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtf,iexternalforce,timei,merge_ij,merge_n) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) endif fxyz_ptmass_sinksink=fxyz_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf @@ -1208,7 +1210,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, !$omp reduction(+:accretedmass) & !$omp reduction(min:dtextforcenew,dtsinkgas,dtphi2) & !$omp reduction(max:fonrmax) & - !$omp reduction(+:fxyz_ptmass) + !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) !$omp do predictor: do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then @@ -1356,8 +1358,10 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, ! ! reduction of sink-gas forces from each MPI thread ! - if (nptmass > 0) call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - + if (nptmass > 0) then + call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) + call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + endif !--------------------------- ! corrector during substeps !--------------------------- @@ -1366,7 +1370,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, ! if (nptmass > 0) then if (id==master) then - call ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) + call ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,iexternalforce) endif call bcast_mpi(vxyz_ptmass(:,1:nptmass)) endif diff --git a/src/main/utils_vectors.f90 b/src/main/utils_vectors.f90 index 9b885a43c..6b4be4a40 100644 --- a/src/main/utils_vectors.f90 +++ b/src/main/utils_vectors.f90 @@ -19,13 +19,15 @@ module vectorutils ! implicit none public :: minmaxave,cross_product3D,curl3D_epsijk,det - public :: matrixinvert3D,rotatevec + public :: matrixinvert3D,rotatevec,unitvec private contains !------------------------------------------------------------------- -! simple routine to take min, max and average of a quantity +!+ +! find min, max and average of an array +!+ !------------------------------------------------------------------- subroutine minmaxave(x,xmin,xmax,xav,npts) integer :: i @@ -43,9 +45,13 @@ subroutine minmaxave(x,xmin,xmax,xav,npts) enddo xav = xav/real(npts) - return end subroutine minmaxave +!------------------------------------------------------------------- +!+ +! vector cross product +!+ +!------------------------------------------------------------------- pure subroutine cross_product3D(veca,vecb,vecc) real, intent(in) :: veca(3),vecb(3) real, intent(out) :: vecc(3) @@ -56,6 +62,11 @@ pure subroutine cross_product3D(veca,vecb,vecc) end subroutine cross_product3D +!------------------------------------------------------------------- +!+ +! curl from the 3 x 3 gradient matrix +!+ +!------------------------------------------------------------------- pure subroutine curl3D_epsijk(gradAvec,curlA) real, intent(in) :: gradAvec(3,3) real, intent(out) :: curlA(3) @@ -68,7 +79,7 @@ end subroutine curl3D_epsijk !---------------------------------------------------------------- !+ -! Internal subroutine that inverts a 3x3 matrix +! Inverts a 3x3 matrix !+ !---------------------------------------------------------------- subroutine matrixinvert3D(A,Ainv,ierr) @@ -102,9 +113,13 @@ subroutine matrixinvert3D(A,Ainv,ierr) call cross_product3D(x0,x1,result) Ainv(:,3) = result(:)*ddet - return end subroutine matrixinvert3D +!---------------------------------------------------------------- +!+ +! Determinant of a 3x3 matrix +!+ +!---------------------------------------------------------------- real function det(A) real, intent(in) :: A(3,3) real :: x0(3),x1(3),x2(3),result(3) @@ -116,14 +131,13 @@ real function det(A) call cross_product3D(x1,x2,result) det = dot_product(x0,result) - return end function det !------------------------------------------------------------------------ -! -! rotate a vector (u) around an axis defined by another vector (v) -! by an angle (theta) using the Rodrigues rotation formula -! +!+ +! rotate a vector (u) around an axis defined by another vector (v) +! by an angle (theta) using the Rodrigues rotation formula +!+ !------------------------------------------------------------------------ pure subroutine rotatevec(u,v,theta) real, dimension(3), intent(inout) :: u @@ -140,4 +154,22 @@ pure subroutine rotatevec(u,v,theta) end subroutine rotatevec +!------------------------------------------------------------------------ +!+ +! return unit vector given a vector +!+ +!------------------------------------------------------------------------ +pure function unitvec(u) result(uhat) + real, intent(in) :: u(3) + real :: uhat(3),u2 + + u2 = dot_product(u,u) + if (u2 > tiny(0.)) then + uhat = u/sqrt(u2) + else + uhat = (/0.,0.,1./) ! arbitrary if vector is zero + endif + +end function unitvec + end module vectorutils diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 3265e4817..ba115f216 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -38,10 +38,10 @@ module setup !+ !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) - use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,iJ2,ispinx,ispinz,iReff use setbinary, only:set_binary,get_a_from_period use units, only:set_units - use physcon, only:solarm,au,pi + use physcon, only:solarm,au,pi,deg_to_rad use options, only:iexternalforce use externalforces, only:iext_corotate,iext_geopot,iext_star,omega_corotate,mass1,accradius1 use io, only:master @@ -57,6 +57,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, character(len=120) :: filename integer :: ierr logical :: iexist + real :: angle ! !--units ! @@ -112,6 +113,13 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, accradius1 = hacc1 xyzmh_ptmass(:,nptmass) = xyzmh_ptmass(:,nptmass+1) vxyz_ptmass(:,nptmass) = vxyz_ptmass(:,nptmass+1) + else + ! set J2 for sink particle 1 to be equal to oblateness of Saturn + xyzmh_ptmass(iJ2,1) = 0.01629 + angle = 30.*deg_to_rad + xyzmh_ptmass(ispinx,1) = sin(angle) + xyzmh_ptmass(ispinz,1) = cos(angle) + xyzmh_ptmass(iReff,1) = xyzmh_ptmass(ihacc,1) endif end subroutine setpart diff --git a/src/tests/test_gravity.F90 b/src/tests/test_gravity.F90 index 98f7f7e42..ffaf6581a 100644 --- a/src/tests/test_gravity.F90 +++ b/src/tests/test_gravity.F90 @@ -237,7 +237,7 @@ subroutine test_directsum(ntests,npass) use dim, only:maxp,maxptmass,mpi use part, only:init_part,npart,npartoftype,massoftype,xyzh,hfact,vxyzu,fxyzu, & gradh,poten,iphase,isetphase,maxphase,labeltype,& - nptmass,xyzmh_ptmass,fxyz_ptmass,ibelong + nptmass,xyzmh_ptmass,fxyz_ptmass,dsdt_ptmass,ibelong use eos, only:polyk,gamma use options, only:ieos,alpha,alphau,alphaB,tolh use spherical, only:set_sphere @@ -425,7 +425,8 @@ subroutine test_directsum(ntests,npass) ! !--compute gravity on the sink particles ! - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epoti,dtsinksink,0,0.,merge_ij,merge_n) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epoti,& + dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) call bcast_mpi(epoti) ! !--compare the results @@ -458,7 +459,8 @@ subroutine test_directsum(ntests,npass) call get_derivs_global() epoti = 0.0 - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epoti,dtsinksink,0,0.,merge_ij,merge_n) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epoti,& + dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) ! !--prevent double counting of sink contribution to potential due to MPI ! diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 4030c9fe7..da6980fee 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -94,12 +94,12 @@ end subroutine test_ptmass subroutine test_binary(ntests,npass) use dim, only:periodic,gravity,ind_timesteps use io, only:id,master,iverbose - use physcon, only:pi + use physcon, only:pi,deg_to_rad use ptmass, only:get_accel_sink_sink,h_soft_sinksink, & get_accel_sink_gas,f_acc - use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fext,& + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fext,& npart,npartoftype,massoftype,xyzh,vxyzu,fxyzu,& - hfact,igas,epot_sinksink,init_part + hfact,igas,epot_sinksink,init_part,iJ2,ispinx,ispinz,iReff use energies, only:angtot,etot,totmom,compute_energies,hp,hx use timestep, only:dtmax,C_force,tolv use kdtree, only:tree_accuracy @@ -116,9 +116,10 @@ subroutine test_binary(ntests,npass) integer, intent(inout) :: ntests,npass integer :: i,ierr,itest,nfailed(3),nsteps,nerr,nwarn,norbits integer :: merge_ij(2),merge_n,nparttot,nfailgw(2),ncheckgw(2) - integer, parameter :: nbinary_tests = 3 + integer, parameter :: nbinary_tests = 4 real :: m1,m2,a,ecc,hacc1,hacc2,dt,dtext,t,dtnew,mred,tolen,hp_exact,hx_exact real :: angmomin,etotin,totmomin,dum,dum2,omega,errmax,dtsinksink,fac,errgw(2) + real :: angle real :: fxyz_sinksink(4,2) ! we only use 2 sink particles in the tests here character(len=20) :: dumpfile real, parameter :: tolgw = 1.2e-2 @@ -133,6 +134,8 @@ subroutine test_binary(ntests,npass) binary_tests: do itest = 1,nbinary_tests select case(itest) + case(4) + if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit with oblateness' case(2,3) if (periodic) then if (id==master) write(*,"(/,a)") '--> skipping circumbinary disc test (-DPERIODIC is set)' @@ -151,11 +154,13 @@ subroutine test_binary(ntests,npass) !--setup sink-sink binary (no gas particles) ! ! time = 0. + npart = 0 + npartoftype = 0 nptmass = 0 m1 = 1. m2 = 1. a = 1. - if (itest==3) then + if (itest==3 .or. itest==4) then ecc = 0.5 else ecc = 0. @@ -184,6 +189,19 @@ subroutine test_binary(ntests,npass) call checkval(nerr,0,0,nfailed(1),'no errors during disc setup') !call checkval(nwarn,0,0,nfailed(2),'no warnings during disc setup') call update_test_scores(ntests,nfailed,npass) + elseif (itest==4) then + ! set oblateness + xyzmh_ptmass(iJ2,1) = 0.01629 + angle = 10.*deg_to_rad + xyzmh_ptmass(ispinx,1) = 1e2*sin(angle) + xyzmh_ptmass(ispinz,1) = 1e2*cos(angle) + xyzmh_ptmass(iReff,1) = hacc1 + + ! make sure the tests pass + nfailed = 0 + call check_setup(nerr,nwarn) + call checkval(nerr,0,0,nfailed(1),'no errors during disc setup') + call update_test_scores(ntests,nfailed,npass) endif tolv = 1.e3 @@ -194,7 +212,8 @@ subroutine test_binary(ntests,npass) ! initialise forces ! if (id==master) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_sinksink,epot_sinksink,dtsinksink,0,0.,merge_ij,merge_n) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_sinksink,epot_sinksink,& + dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) endif fxyz_ptmass(:,:) = 0. call bcast_mpi(epot_sinksink) @@ -207,10 +226,11 @@ subroutine test_binary(ntests,npass) enddo if (id==master) fxyz_ptmass(:,1:nptmass) = fxyz_ptmass(:,1:nptmass) + fxyz_sinksink(:,1:nptmass) call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) + call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + ! !--take the sink-sink timestep specified by the get_forces routine ! - if (id==master) print*,' dt for sinks = ',C_force*dtsinksink dt = C_force*dtsinksink !2.0/(nsteps) dtmax = dt ! required prior to derivs call, as used to set ibin ! @@ -251,7 +271,7 @@ subroutine test_binary(ntests,npass) else norbits = 100 endif - if (id==master) print*,' nsteps per orbit = ',nsteps,' norbits = ',norbits + if (id==master) print*,'steps/orbit = ',nsteps,' norbits = ',norbits,' dt = ',dt nsteps = nsteps*norbits errmax = 0.; errgw = 0. nfailgw = 0; ncheckgw = 0 @@ -301,9 +321,13 @@ subroutine test_binary(ntests,npass) call checkvalbuf_end('grav. wave strain (+)',ncheckgw(2),nfailgw(2),errgw(2),tolgw) call update_test_scores(ntests,nfailgw(1:2),npass) endif - call checkval(angtot,angmomin,3.e-14,nfailed(3),'angular momentum') + call checkval(angtot,angmomin,3.1e-14,nfailed(3),'angular momentum') call checkval(totmom,totmomin,epsilon(0.),nfailed(2),'linear momentum') - call checkval(etotin+errmax,etotin,3.e-8,nfailed(1),'total energy') + if (itest==4) then ! energy conservation is ok but etot is small compared to ekin + call checkval(etotin+errmax,etotin,1.3e-2,nfailed(1),'total energy') + else + call checkval(etotin+errmax,etotin,3.e-8,nfailed(1),'total energy') + endif end select ! !--check energy conservation @@ -328,7 +352,7 @@ subroutine test_softening(ntests,npass) use ptmass, only:get_accel_sink_sink,h_soft_sinksink, & get_accel_sink_gas use part, only:npart,npartoftype,epot_sinksink,& - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass + nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass use energies, only:angtot,etot,totmom,compute_energies,epot use timestep, only:dtmax,C_force use setbinary, only:set_binary @@ -376,7 +400,8 @@ subroutine test_softening(ntests,npass) vxyz_ptmass(1,2) = 0. vxyz_ptmass(2,2) = -v_c2 vxyz_ptmass(3,2) = 0. - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,0,0.,merge_ij,merge_n) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) call compute_energies(t) etotin = etot totmomin = totmom @@ -704,7 +729,7 @@ subroutine test_merger(ntests,npass) use dim, only:periodic use io, only:id,master,iverbose use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & - npart,ihacc,epot_sinksink + npart,ihacc,epot_sinksink,dsdt_ptmass use ptmass, only:h_acc,h_soft_sinksink,get_accel_sink_sink, & r_merge_uncond,r_merge_cond,r_merge_uncond2,& r_merge_cond2,r_merge2 @@ -811,7 +836,8 @@ subroutine test_merger(ntests,npass) ! initialise forces ! if (id==master) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_sinksink,epot_sinksink,dtsinksink,0,0.,merge_ij,merge_n) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_sinksink,epot_sinksink,& + dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) endif fxyz_ptmass(:,:) = 0. call bcast_mpi(epot_sinksink) From b1a3bf4473d76e11f5c3ed7b76fa60155a917474 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 22 Apr 2022 17:24:11 -0700 Subject: [PATCH 003/814] (geopot) added feedback from gas onto sink particle spin --- src/main/extern_geopot.f90 | 13 ++++++++++--- src/main/initial.F90 | 2 +- src/main/ptmass.F90 | 31 ++++++++++++++++++++++--------- src/main/step_leapfrog.F90 | 2 +- src/tests/test_gravity.F90 | 2 +- src/tests/test_ptmass.f90 | 2 +- 6 files changed, 36 insertions(+), 16 deletions(-) diff --git a/src/main/extern_geopot.f90 b/src/main/extern_geopot.f90 index 6f23e6c70..54598885c 100644 --- a/src/main/extern_geopot.f90 +++ b/src/main/extern_geopot.f90 @@ -11,7 +11,7 @@ module extern_geopot ! Currently only implements J2, i.e. effect of oblateness ! but could be extended to deal with higher order terms ! -! Spin vector direction is arbitrary +! Spin vector direction is specified by tilt_angle ! ! :References: https://en.wikipedia.org/wiki/Geopotential_model ! Hong et al. (2021), ApJ 920, 151 @@ -44,7 +44,8 @@ module extern_geopot ! namely the J2 term caused by oblateness !+ !------------------------------------------------ -subroutine get_geopot_force(xi,yi,zi,dr,mdr3,Rp,J2i,si,fxi,fyi,fzi,phi,dsx,dsy,dsz) +subroutine get_geopot_force(xi,yi,zi,dr,mdr3,Rp,J2i,si,fxi,fyi,fzi,phi,& + dsx,dsy,dsz,fxj,fyj,fzj) real, intent(in) :: xi,yi,zi real, intent(in) :: dr ! 1/r real, intent(in) :: mdr3 ! GM/r^3 @@ -53,7 +54,7 @@ subroutine get_geopot_force(xi,yi,zi,dr,mdr3,Rp,J2i,si,fxi,fyi,fzi,phi,dsx,dsy,d real, intent(in) :: si(3) ! unit spin vector real, intent(inout) :: fxi,fyi,fzi real, intent(inout) :: phi - real, intent(inout), optional :: dsx,dsy,dsz + real, intent(inout), optional :: dsx,dsy,dsz,fxj,fyj,fzj real :: r_dot_s,term,term1,term2 ! Equation 1 of Hong et al. (2021) @@ -71,6 +72,12 @@ subroutine get_geopot_force(xi,yi,zi,dr,mdr3,Rp,J2i,si,fxi,fyi,fzi,phi,dsx,dsy,d dsy = dsy - term2*(zi*si(1) - xi*si(3)) dsz = dsz - term2*(xi*si(2) - yi*si(1)) endif + if (present(fxj)) then + ! acceleration on j due to i, needs to be multiplied by mi/mj later + fxj = fxj - term1*xi + term2*si(1) ! 2nd term does not change sign + fyj = fyj - term1*yi + term2*si(2) + fzj = fzj - term1*zi + term2*si(3) + endif ! potential is as given in wikipedia except we replace z/r with r_dot_s phi = phi + 0.5*J2*(Rp**2)*mdr3*(3.*r_dot_s**2 - 1.) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index bf2e9e65b..25ffc6c25 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -496,7 +496,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) pmassi = massoftype(iamtype(iphase(i))) 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,fonrmax,dtphi2) + fext(1,i),fext(2,i),fext(3,i),poti,pmassi,fxyz_ptmass,dsdt_ptmass,fonrmax,dtphi2) 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 1f451408c..0f42d643c 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -117,7 +117,7 @@ module ptmass !+ !---------------------------------------------------------------- subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, & - pmassi,fxyz_ptmass,fonrmax,dtphi2) + pmassi,fxyz_ptmass,dsdt_ptmass,fonrmax,dtphi2) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -129,11 +129,12 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, real, intent(inout) :: fxi,fyi,fzi,phi real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, optional, intent(in) :: pmassi - real, optional, intent(inout) :: fxyz_ptmass(4,nptmass) + real, optional, intent(inout) :: fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) real, optional, intent(out) :: fonrmax,dtphi2 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 integer :: j logical :: tofrom ! @@ -168,6 +169,12 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, #else ddr = 1./sqrt(rr2) #endif + dsx = 0. + dsy = 0. + dsz = 0. + fxj = 0. + fyj = 0. + fzj = 0. if (rr2 < (radkern*hsoft)**2) then ! ! if the sink particle is given a softening length, soften the @@ -199,22 +206,28 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, ftmpzi = ftmpzi - dz*f1 phi = phi - pmassj*ddr ! potential (GM/r) + ! acceleration of sink from gas + if (tofrom) f2 = pmassi*dr3 + ! additional accelerations due to oblateness if (abs(J2) > 0.) then shat = unitvec(xyzmh_ptmass(ispinx:ispinz,j)) Rsink = xyzmh_ptmass(iReff,j) - call get_geopot_force(dx,dy,dz,ddr,f1,Rsink,J2,shat,ftmpxi,ftmpyi,ftmpzi,phi) + call get_geopot_force(dx,dy,dz,ddr,f1,Rsink,J2,shat,ftmpxi,ftmpyi,ftmpzi,phi,dsx,dsy,dsz,fxj,fyj,fzj) endif - - ! acceleration of sink from gas - if (tofrom) f2 = pmassi*dr3 endif if (tofrom) then ! backreaction of gas onto sink - fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + dx*f2 - fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + dy*f2 - fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + dz*f2 + fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + dx*f2 + fxj*pmassi/pmassj + fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + dy*f2 + fyj*pmassi/pmassj + fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + dz*f2 + fzj*pmassi/pmassj + + ! backreaction torque of gas onto oblate sink + dsdt_ptmass(1,j) = dsdt_ptmass(1,j) + pmassi*dsx + dsdt_ptmass(2,j) = dsdt_ptmass(2,j) + pmassi*dsy + dsdt_ptmass(3,j) = dsdt_ptmass(3,j) + pmassi*dsz + ! timestep is sqrt(separation/force) fonrmax = max(f1,f2,fonrmax) endif diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index ab0aa9dbe..1bc328684 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -1241,7 +1241,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, fextz = 0. if (nptmass > 0) then call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,& - fextx,fexty,fextz,phii,pmassi,fxyz_ptmass,fonrmaxi,dtphi2i) + fextx,fexty,fextz,phii,pmassi,fxyz_ptmass,dsdt_ptmass,fonrmaxi,dtphi2i) fonrmax = max(fonrmax,fonrmaxi) dtphi2 = min(dtphi2,dtphi2i) endif diff --git a/src/tests/test_gravity.F90 b/src/tests/test_gravity.F90 index ffaf6581a..916388eb7 100644 --- a/src/tests/test_gravity.F90 +++ b/src/tests/test_gravity.F90 @@ -475,7 +475,7 @@ subroutine test_directsum(ntests,npass) do i=1,npart call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& xyzmh_ptmass,fxyzu(1,i),fxyzu(2,i),fxyzu(3,i),& - phii,pmassi,fxyz_ptmass_gas,fonrmax,dtsinksink) + phii,pmassi,fxyz_ptmass_gas,dsdt_ptmass,fonrmax,dtsinksink) epot_gas_sink = epot_gas_sink + pmassi*phii epoti = epoti + poten(i) enddo diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index da6980fee..af25d35ca 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -222,7 +222,7 @@ subroutine test_binary(ntests,npass) fext(:,:) = 0. do i=1,npart 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),dum,massoftype(igas),fxyz_ptmass,dum,dum2) + fext(1,i),fext(2,i),fext(3,i),dum,massoftype(igas),fxyz_ptmass,dsdt_ptmass,dum,dum2) enddo if (id==master) fxyz_ptmass(:,1:nptmass) = fxyz_ptmass(:,1:nptmass) + fxyz_sinksink(:,1:nptmass) call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) From 53b8299b7053022b4e11bcd22d31c97851976fb1 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 28 Apr 2022 23:27:23 -0700 Subject: [PATCH 004/814] (set_binary) handle case where m1 or m2 = 0 without floating point exception --- src/setup/set_binary.f90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/setup/set_binary.f90 b/src/setup/set_binary.f90 index f3027a4c7..9fae7ac19 100644 --- a/src/setup/set_binary.f90 +++ b/src/setup/set_binary.f90 @@ -584,10 +584,14 @@ real function Rochelobe_estimate(m1,m2,sep) real, intent(in) :: m1,m2,sep real :: q,q13,q23 - q = m2/m1 - q13 = q**(1./3.) - q23 = q13*q13 - Rochelobe_estimate = sep * 0.49*q23/(0.6*q23 + log(1. + q13)) + if (m1 > 0. .and. m2 > 0.) then + q = m2/m1 + q13 = q**(1./3.) + q23 = q13*q13 + Rochelobe_estimate = sep * 0.49*q23/(0.6*q23 + log(1. + q13)) + else + Rochelobe_estimate = sep + endif end function Rochelobe_estimate From 80f19affbfb476187f46a48ee0d58d721f6f23de Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 28 Apr 2022 23:28:35 -0700 Subject: [PATCH 005/814] (geopot) bug fix in linear momentum conservation in sink-gas interaction --- src/main/extern_geopot.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/extern_geopot.f90 b/src/main/extern_geopot.f90 index 54598885c..4f5994c38 100644 --- a/src/main/extern_geopot.f90 +++ b/src/main/extern_geopot.f90 @@ -74,9 +74,9 @@ subroutine get_geopot_force(xi,yi,zi,dr,mdr3,Rp,J2i,si,fxi,fyi,fzi,phi,& endif if (present(fxj)) then ! acceleration on j due to i, needs to be multiplied by mi/mj later - fxj = fxj - term1*xi + term2*si(1) ! 2nd term does not change sign - fyj = fyj - term1*yi + term2*si(2) - fzj = fzj - term1*zi + term2*si(3) + fxj = fxj - term1*xi - term2*si(1) + fyj = fyj - term1*yi - term2*si(2) + fzj = fzj - term1*zi - term2*si(3) endif ! potential is as given in wikipedia except we replace z/r with r_dot_s From 5f85f95d839d8ca3042e1bf1758ee703b9ddb77e Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 28 Apr 2022 23:29:16 -0700 Subject: [PATCH 006/814] (ptmass) minor cleanup; return immediately if nptmass == 1 from sink-sink forces --- src/main/ptmass.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 0f42d643c..e67c0131e 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -291,6 +291,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin phitot = 0. merge_n = 0 merge_ij = 0 + if (nptmass <= 1) return ! !--get self-contribution to the potential if sink-sink softening is used ! @@ -405,11 +406,9 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin if (rr2 < rr2j) merge_ij(i) = j endif endif -! phitot = phitot + 0.5*pmassi*pmassj*pterm ! total potential (G M_1 M_2/r) enddo phitot = phitot + 0.5*pmassi*phii ! total potential (G M_1 M_2/r) - ! !--apply external forces ! From 7e814d29e1ba15a491b9dc9511c23a8437d88cef Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 28 Apr 2022 23:43:02 -0700 Subject: [PATCH 007/814] (test_ptmass) added tests for sink particles with oblateness; various tweaks and bug fixes --- src/tests/test_ptmass.f90 | 82 ++++++++++++++++++++------------------- 1 file changed, 43 insertions(+), 39 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index af25d35ca..3ec20edde 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -31,7 +31,7 @@ subroutine test_ptmass(ntests,npass) use io, only:id,master,iskfile use eos, only:polyk,gamma use part, only:nptmass - use options, only:iexternalforce + use options, only:iexternalforce,alpha character(len=20) :: filename integer, intent(inout) :: ntests,npass integer :: itmp,ierr @@ -50,6 +50,7 @@ subroutine test_ptmass(ntests,npass) polyk = 0. gamma = 1. iexternalforce = 0 + alpha = 0.01 ! ! Tests of a sink particle binary ! @@ -99,7 +100,7 @@ subroutine test_binary(ntests,npass) get_accel_sink_gas,f_acc use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fext,& npart,npartoftype,massoftype,xyzh,vxyzu,fxyzu,& - hfact,igas,epot_sinksink,init_part,iJ2,ispinx,ispinz,iReff + hfact,igas,epot_sinksink,init_part,iJ2,ispinx,ispiny,ispinz,iReff,istar use energies, only:angtot,etot,totmom,compute_energies,hp,hx use timestep, only:dtmax,C_force,tolv use kdtree, only:tree_accuracy @@ -116,10 +117,10 @@ subroutine test_binary(ntests,npass) integer, intent(inout) :: ntests,npass integer :: i,ierr,itest,nfailed(3),nsteps,nerr,nwarn,norbits integer :: merge_ij(2),merge_n,nparttot,nfailgw(2),ncheckgw(2) - integer, parameter :: nbinary_tests = 4 - real :: m1,m2,a,ecc,hacc1,hacc2,dt,dtext,t,dtnew,mred,tolen,hp_exact,hx_exact + integer, parameter :: nbinary_tests = 5 + real :: m1,m2,a,ecc,hacc1,hacc2,dt,dtext,t,dtnew,tolen,hp_exact,hx_exact real :: angmomin,etotin,totmomin,dum,dum2,omega,errmax,dtsinksink,fac,errgw(2) - real :: angle + real :: angle,rin,rout real :: fxyz_sinksink(4,2) ! we only use 2 sink particles in the tests here character(len=20) :: dumpfile real, parameter :: tolgw = 1.2e-2 @@ -136,12 +137,14 @@ subroutine test_binary(ntests,npass) select case(itest) case(4) if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit with oblateness' - case(2,3) + case(2,3,5) if (periodic) then if (id==master) write(*,"(/,a)") '--> skipping circumbinary disc test (-DPERIODIC is set)' cycle binary_tests else - if (itest==3) then + if (itest==5) then + if (id==master) write(*,"(/,a)") '--> testing integration of disc around oblate star' + elseif (itest==3) then if (id==master) write(*,"(/,a)") '--> testing integration of disc around eccentric binary' else if (id==master) write(*,"(/,a)") '--> testing integration of circumbinary disc' @@ -160,6 +163,13 @@ subroutine test_binary(ntests,npass) m1 = 1. m2 = 1. a = 1. + rin = 1.5*a + rout = 15.*a + if (itest==5) then + m2 = 0.0 + rin = 1. + rout = 5. + endif if (itest==3 .or. itest==4) then ecc = 0.5 else @@ -168,41 +178,39 @@ subroutine test_binary(ntests,npass) hacc1 = 0.35 hacc2 = 0.35 C_force = 0.25 + omega = sqrt((m1+m2)/a**3) t = 0. call set_units(mass=1.d0,dist=1.d0,G=1.d0) call set_binary(m1,m2,a,ecc,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,verbose=.false.) if (ierr /= 0) nerr = nerr + 1 - if (itest==2 .or. itest==3) then + + if (itest==2 .or. itest==3 .or. itest==5) then ! add a circumbinary gas disc around it nparttot = 1000 - call set_disc(id,master,nparttot=nparttot,npart=npart,rmin=1.5*a,rmax=15.*a,p_index=1.5,q_index=0.75,& + call set_disc(id,master,nparttot=nparttot,npart=npart,rmin=rin,rmax=rout,p_index=1.0,q_index=0.75,& HoverR=0.1,disc_mass=0.01*m1,star_mass=m1+m2,gamma=gamma,& particle_mass=massoftype(igas),hfact=hfact,xyzh=xyzh,vxyzu=vxyzu,& polyk=polyk,verbose=.false.) - npartoftype(1) = npart + npartoftype(igas) = npart + endif - ! - ! check that no errors occurred when setting up disc - ! - nfailed = 0 - call check_setup(nerr,nwarn) - call checkval(nerr,0,0,nfailed(1),'no errors during disc setup') - !call checkval(nwarn,0,0,nfailed(2),'no warnings during disc setup') - call update_test_scores(ntests,nfailed,npass) - elseif (itest==4) then + if (itest==4 .or. itest==5) then + if (itest==5) nptmass = 1 ! set oblateness xyzmh_ptmass(iJ2,1) = 0.01629 - angle = 10.*deg_to_rad + angle = 45.*deg_to_rad xyzmh_ptmass(ispinx,1) = 1e2*sin(angle) + xyzmh_ptmass(ispiny,1) = 0. xyzmh_ptmass(ispinz,1) = 1e2*cos(angle) xyzmh_ptmass(iReff,1) = hacc1 - - ! make sure the tests pass - nfailed = 0 - call check_setup(nerr,nwarn) - call checkval(nerr,0,0,nfailed(1),'no errors during disc setup') - call update_test_scores(ntests,nfailed,npass) endif + ! + ! check that no errors occurred when setting up initial conditions + ! + nfailed = 0 + call check_setup(nerr,nwarn) + call checkval(nerr,0,0,nfailed(1),'no errors during disc setup') + call update_test_scores(ntests,nfailed,npass) tolv = 1.e3 iverbose = 0 @@ -231,12 +239,12 @@ subroutine test_binary(ntests,npass) ! !--take the sink-sink timestep specified by the get_forces routine ! - dt = C_force*dtsinksink !2.0/(nsteps) + dt = min(C_force*dtsinksink,4.e-3*sqrt(2.*pi/omega)) !2.0/(nsteps) dtmax = dt ! required prior to derivs call, as used to set ibin ! !--compute SPH forces ! - if (itest==2 .or. itest==3) then + if (npart > 0) then fxyzu(:,:) = 0. call get_derivs_global() endif @@ -263,10 +271,8 @@ subroutine test_binary(ntests,npass) ! !--determine number of steps per orbit for information ! - mred = m1*m2/(m1 + m2) - omega = sqrt(mred/a**3) nsteps = int(2.*pi/omega/dt) + 1 - if (itest==2 .or. itest==3) then + if (itest==2 .or. itest==3 .or. itest==5) then norbits = 10 else norbits = 100 @@ -308,30 +314,28 @@ subroutine test_binary(ntests,npass) call checkval(angtot,angmomin,1.2e-6,nfailed(3),'angular momentum') call checkval(totmom,totmomin,4.e-14,nfailed(2),'linear momentum') endif - call checkval(etotin+errmax,etotin,1.2e-2,nfailed(1),'total energy') + tolen = 1.2e-2 case(2) call checkval(angtot,angmomin,4.e-7,nfailed(3),'angular momentum') call checkval(totmom,totmomin,6.e-14,nfailed(2),'linear momentum') tolen = 2.e-3 if (gravity) tolen = 3.1e-3 - call checkval(etotin+errmax,etotin,tolen,nfailed(1),'total energy') case default - if (calc_gravitwaves) then + if (calc_gravitwaves .and. itest==1) then call checkvalbuf_end('grav. wave strain (x)',ncheckgw(1),nfailgw(1),errgw(1),tolgw) call checkvalbuf_end('grav. wave strain (+)',ncheckgw(2),nfailgw(2),errgw(2),tolgw) call update_test_scores(ntests,nfailgw(1:2),npass) endif call checkval(angtot,angmomin,3.1e-14,nfailed(3),'angular momentum') call checkval(totmom,totmomin,epsilon(0.),nfailed(2),'linear momentum') - if (itest==4) then ! energy conservation is ok but etot is small compared to ekin - call checkval(etotin+errmax,etotin,1.3e-2,nfailed(1),'total energy') - else - call checkval(etotin+errmax,etotin,3.e-8,nfailed(1),'total energy') - endif + tolen = 3.e-8 + if (itest==4) tolen = 1.6e-2 ! etot is small compared to ekin + if (itest==5) tolen = 5.7e-1 end select ! !--check energy conservation ! + call checkval(etotin+errmax,etotin,tolen,nfailed(1),'total energy') do i=1,3 call update_test_scores(ntests,nfailed(i:i),npass) enddo From befaaa648ed7c7f820034037bcc250f8b1403f57 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 3 May 2022 10:12:37 -0700 Subject: [PATCH 008/814] (geopot) added setup options for J2, planet spin period, size and obliquity --- src/main/physcon.f90 | 1 + src/main/units.f90 | 3 +- src/main/utils_vectors.f90 | 15 ++++++- src/setup/setup_disc.f90 | 84 +++++++++++++++++++++++++++++++------- 4 files changed, 87 insertions(+), 16 deletions(-) diff --git a/src/main/physcon.f90 b/src/main/physcon.f90 index a8b5283ae..0c6d4306d 100644 --- a/src/main/physcon.f90 +++ b/src/main/physcon.f90 @@ -66,6 +66,7 @@ module physcon real(kind=8), parameter :: earthm = 5.979d27 !Mass of the Earth g real(kind=8), parameter :: earthr = 6.371315d8 !Radius of the Earth cm real(kind=8), parameter :: jupiterm = 1.89813d30 !Mass of Jupiter g + real(kind=8), parameter :: jupiterr = 7.1492e9 !Equatorial radius Jupiter cm real(kind=8), parameter :: ceresm = 8.958d23 !Mass of Ceres g real(kind=8), parameter :: gram = 1.d0 ! diff --git a/src/main/units.f90 b/src/main/units.f90 index 6db02a8aa..b3c4314ee 100644 --- a/src/main/units.f90 +++ b/src/main/units.f90 @@ -26,7 +26,7 @@ module units ! real(kind=8), public :: udist = 1.d0, umass = 1.d0, utime = 1.d0 real(kind=8), public :: unit_velocity, unit_Bfield, unit_charge - real(kind=8), public :: unit_pressure, unit_density + real(kind=8), public :: unit_pressure, unit_density, unit_angmom real(kind=8), public :: unit_ergg, unit_energ, unit_opacity public :: set_units, set_units_extra, print_units @@ -138,6 +138,7 @@ subroutine set_units_extra() unit_ergg = unit_velocity**2 unit_energ = umass*unit_ergg unit_opacity = udist**2/umass + unit_angmom = umass*udist*unit_velocity ! mr x v end subroutine set_units_extra diff --git a/src/main/utils_vectors.f90 b/src/main/utils_vectors.f90 index 6b4be4a40..1d92ad191 100644 --- a/src/main/utils_vectors.f90 +++ b/src/main/utils_vectors.f90 @@ -19,7 +19,7 @@ module vectorutils ! implicit none public :: minmaxave,cross_product3D,curl3D_epsijk,det - public :: matrixinvert3D,rotatevec,unitvec + public :: matrixinvert3D,rotatevec,unitvec,mag private @@ -172,4 +172,17 @@ pure function unitvec(u) result(uhat) end function unitvec +!------------------------------------------------------------------------ +!+ +! magnitude of a vector +!+ +!------------------------------------------------------------------------ +pure function mag(u) result(umag) + real, intent(in) :: u(3) + real :: umag + + umag = sqrt(dot_product(u,u)) + +end function mag + end module vectorutils diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index b2b86ccbc..ee4230840 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -93,11 +93,12 @@ module setup use kernel, only:hfact_default use options, only:use_dustfrac,iexternalforce,use_hybrid use options, only:use_mcfost,use_mcfost_stellar_parameters,mcfost_computes_Lacc - use part, only:xyzmh_ptmass,maxvxyzu,vxyz_ptmass,ihacc,ihsoft,igas,& + use part, only:xyzmh_ptmass,maxvxyzu,vxyz_ptmass,ihacc,ihsoft,& + iJ2,ispinx,ispinz,iReff,igas,& idust,iphase,dustprop,dustfrac,ndusttypes,ndustsmall,& ndustlarge,grainsize,graindens,nptmass,iamtype,dustgasprop,& VrelVf,rad,radprop,ikappa,iradxi - use physcon, only:au,solarm,jupiterm,earthm,pi,years + use physcon, only:au,solarm,jupiterm,jupiterr,earthm,earthr,pi,twopi,years,hours,deg_to_rad use setdisc, only:scaled_sigma,get_disc_mass use set_dust_options, only:set_dust_default_options,dust_method,dust_to_gas,& ndusttypesinp,ndustlargeinp,ndustsmallinp,isetdust,& @@ -186,6 +187,8 @@ module setup integer :: nplanets,discstrat real :: mplanet(maxplanets),rplanet(maxplanets) real :: accrplanet(maxplanets),inclplan(maxplanets) + real :: J2planet(maxplanets),spin_period(maxplanets),obliquity(maxplanets) + real :: planet_size(maxplanets),kfac(maxplanets) real :: period_planet_longest !--planetary atmosphere @@ -432,6 +435,11 @@ subroutine set_default_options() rplanet = (/ (10.*i, i=1,maxplanets) /) accrplanet = 0.25 inclplan = 0. + J2planet = 0. + spin_period = 0. + obliquity = 0. + planet_size = 0. + kfac = 0.205 !--stratification istratify = .false. @@ -774,7 +782,7 @@ subroutine setup_central_objects() xyzmh_ptmass(1:3,nptmass) = 0. xyzmh_ptmass(4,nptmass) = m1 xyzmh_ptmass(ihacc,nptmass) = accr1 - xyzmh_ptmass(ihsoft,nptmass) = accr1 + xyzmh_ptmass(ihsoft,nptmass) = 0. vxyz_ptmass = 0. mcentral = m1 case (2) @@ -1531,7 +1539,8 @@ end subroutine print_dust ! !-------------------------------------------------------------------------- subroutine set_planets(npart,massoftype,xyzh) - use vectorutils, only:rotatevec + use vectorutils, only:rotatevec,unitvec,mag + use units, only:unit_angmom integer, intent(in) :: npart real, intent(in) :: massoftype(:) real, intent(in) :: xyzh(:,:) @@ -1539,14 +1548,13 @@ subroutine set_planets(npart,massoftype,xyzh) integer :: i,j,itype real :: dist_bt_sinks real :: phi,vphi,sinphi,cosphi,omega,r2,disc_m_within_r - real :: Hill(maxplanets) + real :: Hill(maxplanets),planet_radius,planet_spin_period,spin_am real :: u(3) period_planet_longest = 0. if (nplanets > 0) then print "(a,i2,a)",' --------- added ',nplanets,' planets ------------' do i=1,nplanets - nptmass = nptmass + 1 phi = 0. phi = phi*pi/180. @@ -1579,7 +1587,7 @@ subroutine set_planets(npart,massoftype,xyzh) xyzmh_ptmass(1:3,nptmass) = (/rplanet(i)*cosphi,rplanet(i)*sinphi,0./) xyzmh_ptmass(4,nptmass) = mplanet(i)*jupiterm/umass xyzmh_ptmass(ihacc,nptmass) = accrplanet(i)*Hill(i) - xyzmh_ptmass(ihsoft,nptmass) = accrplanet(i)*Hill(i) + xyzmh_ptmass(ihsoft,nptmass) = 0. vphi = sqrt((mcentral + disc_m_within_r)/rplanet(i)) if (nsinks == 2 .and. rplanet(i) < dist_bt_sinks) vphi = sqrt((m1 + disc_m_within_r)/rplanet(i)) vxyz_ptmass(1:3,nptmass) = (/-vphi*sinphi,vphi*cosphi,0./) @@ -1594,10 +1602,24 @@ subroutine set_planets(npart,massoftype,xyzh) call rotatevec(xyzmh_ptmass(1:3,nptmass),u,-inclplan(i)) call rotatevec(vxyz_ptmass(1:3,nptmass), u,-inclplan(i)) + !--compute obliquity and spin angular momentum + if (J2planet(i) > 0.) then + xyzmh_ptmass(iJ2,nptmass) = J2planet(i) + ! compute spin angular momentum of the planet + planet_radius = planet_size(i)*jupiterr/udist + planet_spin_period = spin_period(i)*hours/utime + spin_am = twopi*kfac(i)*(xyzmh_ptmass(4,nptmass)*planet_radius**2)/planet_spin_period + xyzmh_ptmass(ispinx,nptmass) = spin_am*sin(obliquity(i)*deg_to_rad) + xyzmh_ptmass(ispinz,nptmass) = spin_am*cos(obliquity(i)*deg_to_rad) + xyzmh_ptmass(iReff,nptmass) = planet_radius + else + planet_spin_period = 0. + endif + !--print planet information omega = vphi/rplanet(i) print "(a,i2,a)", ' >>> planet ',i,' <<<' - print "(a,g10.3,a)", ' orbital radius: ',rplanet(i)*udist/au,' AU' + print "(a,g10.3,a)", ' orbital radius: ',rplanet(i)*udist/au,' au' print "(a,g10.3,a,2pf7.3,a)", ' M( 0.) then + print "(a,g10.3)", ' J2 moment: ',xyzmh_ptmass(iJ2,nptmass) + print "(a,g10.3,a)", ' size: ',xyzmh_ptmass(iReff,nptmass)*udist/jupiterr,' Jupiter radii' + print "(a,g10.3,a)", ' size: ',xyzmh_ptmass(iReff,nptmass)*udist/earthr,' Earth radii' + print "(a,g10.3,a)", ' size: ',xyzmh_ptmass(iReff,nptmass)*udist/au,' au' + u = unitvec(xyzmh_ptmass(ispinx:ispinz,nptmass)) + print "(a,g10.3,a)", ' obliquity: ',acos(u(3))/deg_to_rad,' degrees to z=0 plane' + print "(a,g10.3,a)", ' period: ',planet_spin_period*utime/hours,' hrs' + print "(a,3(g10.3,1x))",' spin vec: ',u + print "(/,a,g10.3,a)", '# Planet total angular momentum = ',& + mag(xyzmh_ptmass(ispinx:ispinz,nptmass))*unit_angmom,' g cm^2 / s' + print "(/,a,'(',3(es10.2,1x),')')",' Planet specific angular momentum = ',& + xyzmh_ptmass(ispinx:ispinz,nptmass)/xyzmh_ptmass(4,nptmass) + endif !--check planet accretion radii if (accrplanet(i) < 0.05) then @@ -1622,6 +1658,12 @@ subroutine set_planets(npart,massoftype,xyzh) elseif (accrplanet(i)*Hill(i) > accr1) then call warning('setup_disc','accretion radius of planet > accretion radius of primary star: this is unphysical') endif + if (xyzmh_ptmass(iReff,nptmass) > 0.25*Hill(i)) then + call warning('setup_disc','planet size exceeds 1/4 of Hill radius: too large') + endif + if (xyzmh_ptmass(iReff,nptmass) > max(xyzmh_ptmass(ihacc,nptmass),xyzmh_ptmass(ihsoft,nptmass))) then + call warning('setup_disc','planet size exceeds accretion radius: too large') + endif print *, '' !--determine longest period @@ -2361,6 +2403,13 @@ subroutine write_setupfile(filename) call write_inopt(rplanet(i),'rplanet'//trim(planets(i)),'planet distance from star',iunit) call write_inopt(inclplan(i),'inclplanet'//trim(planets(i)),'planet orbital inclination (deg)',iunit) call write_inopt(accrplanet(i),'accrplanet'//trim(planets(i)),'planet accretion radius (in Hill radius)',iunit) + call write_inopt(J2planet(i),'J2planet'//trim(planets(i)),'planet J2 moment',iunit) + if (abs(J2planet(i)) > 0.) then + call write_inopt(planet_size(i),'size'//trim(planets(i)),'planet radius (Jupiter radii)',iunit) + call write_inopt(spin_period(i),'spin_period'//trim(planets(i)),'planet spin period (hrs)',iunit) + call write_inopt(kfac(i),'kfac'//trim(planets(i)),'planet concentration parameter',iunit) + call write_inopt(obliquity(i),'obliquity'//trim(planets(i)),'planet obliquity (degrees)',iunit) + endif enddo endif ! stratification @@ -2699,6 +2748,13 @@ subroutine read_setupfile(filename,ierr) call read_inopt(rplanet(i),'rplanet'//trim(planets(i)),db,min=0.,errcount=nerr) call read_inopt(inclplan(i),'inclplanet'//trim(planets(i)),db,min=0.,max=180.,errcount=nerr) call read_inopt(accrplanet(i),'accrplanet'//trim(planets(i)),db,min=0.,errcount=nerr) + call read_inopt(J2planet(i),'J2planet'//trim(planets(i)),db,min=-1.0,max=1.0) ! optional, no error if not read + if (abs(J2planet(i)) > 0.) then + call read_inopt(planet_size(i),'size'//trim(planets(i)),db,errcount=nerr) + call read_inopt(spin_period(i),'spin_period'//trim(planets(i)),db,errcount=nerr) + call read_inopt(kfac(i),'kfac'//trim(planets(i)),db,min=0.,max=1.,errcount=nerr) + call read_inopt(obliquity(i),'obliquity'//trim(planets(i)),db,min=0.,max=180.,errcount=nerr) + endif enddo !--timestepping ! following two are optional: not an error if not present From 3da1e0a977f977128daf98bf27ca7403a5523cd2 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 3 May 2022 10:17:02 -0700 Subject: [PATCH 009/814] (setup_disc) use deg_to_rad instead of pi/180; use unit_angmom instead of udist,umass,utime --- src/setup/set_disc.F90 | 4 ++-- src/setup/setup_disc.f90 | 13 ++++++------- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/setup/set_disc.F90 b/src/setup/set_disc.F90 index c0be1374b..336786547 100644 --- a/src/setup/set_disc.F90 +++ b/src/setup/set_disc.F90 @@ -53,7 +53,7 @@ module setdisc use mpiutils, only:reduceall_mpi use part, only:igas,labeltype use physcon, only:c,gg,pi - use units, only:umass,udist,utime + use units, only:umass,udist,utime,unit_angmom implicit none public :: set_disc,set_incline_or_warp,get_disc_mass,scaled_sigma @@ -423,7 +423,7 @@ subroutine set_disc(id,master,mixture,nparttot,npart,npart_start,rmin,rmax, & endif ! Calculate the total angular momentum of the disc only call get_total_angular_momentum(xyzh,vxyzu,npart,L_tot) - L_tot_mag = sqrt(dot_product(L_tot,L_tot))*umass*udist**2/utime + L_tot_mag = sqrt(dot_product(L_tot,L_tot))*unit_angmom ! !--print out disc parameters, to file and to the screen ! diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index ee4230840..d8f710ba0 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -766,7 +766,7 @@ subroutine setup_central_objects() mass1 = m1 accradius1 = accr1 blackhole_spin = bhspin - blackhole_spin_angle = bhspinangle*(pi/180.0) + blackhole_spin_angle = bhspinangle*deg_to_rad mcentral = m1 end select call update_externalforce(iexternalforce,tinitial,0.) @@ -1010,8 +1010,8 @@ subroutine setup_discs(id,fileprefix,hfact,gamma,npart,polyk,& character(len=100) :: dustprefix(maxdusttypes) hfact = hfact_default - incl = incl*(pi/180.0) - posangl = posangl*(pi/180.0) + incl = incl*deg_to_rad + posangl = posangl*deg_to_rad if (maxalpha==0) alpha = alphaSS npart = 0 npartoftype(:) = 0 @@ -1557,9 +1557,8 @@ subroutine set_planets(npart,massoftype,xyzh) do i=1,nplanets nptmass = nptmass + 1 phi = 0. - phi = phi*pi/180. - cosphi = cos(phi) - sinphi = sin(phi) + cosphi = cos(phi*deg_to_rad) + sinphi = sin(phi*deg_to_rad) disc_m_within_r = 0. !--disc mass correction @@ -1597,7 +1596,7 @@ subroutine set_planets(npart,massoftype,xyzh) endif !--incline positions and velocities - inclplan(i) = inclplan(i)*pi/180. + inclplan(i) = inclplan(i)*deg_to_rad u = (/-sin(phi),cos(phi),0./) call rotatevec(xyzmh_ptmass(1:3,nptmass),u,-inclplan(i)) call rotatevec(vxyz_ptmass(1:3,nptmass), u,-inclplan(i)) From 82e0528c2bf68665a6966f681c8e44293c917cfa Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 3 May 2022 18:56:20 -0700 Subject: [PATCH 010/814] (geopot) allow oblateness on central objects as well as planets in disc setup --- src/setup/setup_disc.f90 | 202 ++++++++++++++++++++++++++++----------- 1 file changed, 146 insertions(+), 56 deletions(-) diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index d8f710ba0..b5f4ada80 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -124,7 +124,8 @@ module setup real :: m1,m2,accr1,accr2,m2a,m2b,q2,accr2a,accr2b integer :: icentral,ipotential,ibinary integer :: nsinks,subst - real :: binary_a,binary_e,binary_i,binary_O,binary_w,binary_f,binary2_a,binary2_e,binary2_i,binary2_O,binary2_w,binary2_f + real :: binary_a,binary_e,binary_i,binary_O,binary_w,binary_f + real :: binary2_a,binary2_e,binary2_i,binary2_O,binary2_w,binary2_f real :: flyby_a,flyby_d,flyby_O,flyby_i real :: bhspin,bhspinangle logical :: einst_prec @@ -145,6 +146,8 @@ module setup real :: star_m(maxdiscs) real :: totmass_gas + real :: J2star(maxdiscs),spin_period_star(maxdiscs),obliquity_star(maxdiscs) + real :: size_star(maxdiscs),kfac_star(maxdiscs) integer :: ndiscs integer :: onlydisc @@ -180,7 +183,7 @@ module setup !--planets integer, parameter :: maxplanets = 9 - character(len=*), dimension(maxplanets), parameter :: planets = & + character(len=*), dimension(maxplanets), parameter :: num = & (/'1','2','3','4','5','6','7','8','9' /) logical :: istratify @@ -341,6 +344,13 @@ subroutine set_default_options() accr1 = 1. accr2 = 1. + !--oblateness of main objects + J2star = 0. + spin_period_star = 10. + obliquity_star = 0. + size_star = 1. + kfac_star = 0.205 + !--planetary atmosphere surface_force = .false. @@ -436,9 +446,9 @@ subroutine set_default_options() accrplanet = 0.25 inclplan = 0. J2planet = 0. - spin_period = 0. + spin_period = 10. obliquity = 0. - planet_size = 0. + planet_size = 1. kfac = 0.205 !--stratification @@ -856,6 +866,14 @@ subroutine setup_central_objects() if (.not.iuse_disc(i)) star_m(i) = 0. enddo + do i=1,nsinks + if (abs(J2star(i)) > 0.) then + call set_sink_oblateness(i,J2star(i),size_star(i),spin_period_star(i),kfac_star(i),obliquity_star(i)) + print "(a)",'# oblateness for object '//num(i) + call print_oblateness_info(i,spin_period_star(i)) + endif + enddo + end subroutine setup_central_objects !-------------------------------------------------------------------------- @@ -1539,8 +1557,7 @@ end subroutine print_dust ! !-------------------------------------------------------------------------- subroutine set_planets(npart,massoftype,xyzh) - use vectorutils, only:rotatevec,unitvec,mag - use units, only:unit_angmom + use vectorutils, only:rotatevec integer, intent(in) :: npart real, intent(in) :: massoftype(:) real, intent(in) :: xyzh(:,:) @@ -1548,7 +1565,7 @@ subroutine set_planets(npart,massoftype,xyzh) integer :: i,j,itype real :: dist_bt_sinks real :: phi,vphi,sinphi,cosphi,omega,r2,disc_m_within_r - real :: Hill(maxplanets),planet_radius,planet_spin_period,spin_am + real :: Hill(maxplanets) real :: u(3) period_planet_longest = 0. @@ -1602,17 +1619,8 @@ subroutine set_planets(npart,massoftype,xyzh) call rotatevec(vxyz_ptmass(1:3,nptmass), u,-inclplan(i)) !--compute obliquity and spin angular momentum - if (J2planet(i) > 0.) then - xyzmh_ptmass(iJ2,nptmass) = J2planet(i) - ! compute spin angular momentum of the planet - planet_radius = planet_size(i)*jupiterr/udist - planet_spin_period = spin_period(i)*hours/utime - spin_am = twopi*kfac(i)*(xyzmh_ptmass(4,nptmass)*planet_radius**2)/planet_spin_period - xyzmh_ptmass(ispinx,nptmass) = spin_am*sin(obliquity(i)*deg_to_rad) - xyzmh_ptmass(ispinz,nptmass) = spin_am*cos(obliquity(i)*deg_to_rad) - xyzmh_ptmass(iReff,nptmass) = planet_radius - else - planet_spin_period = 0. + if (abs(J2planet(i)) > 0.) then + call set_sink_oblateness(nptmass,J2planet(i),planet_size(i),spin_period(i),kfac(i),obliquity(i)) endif !--print planet information @@ -1634,20 +1642,7 @@ subroutine set_planets(npart,massoftype,xyzh) print "(a,g10.3,a)", ' 4:1 : ',(sqrt(mcentral)/(4.*omega))**(2./3.)*udist/au,' au' print "(a,g10.3,a)", ' 5:1 : ',(sqrt(mcentral)/(5.*omega))**(2./3.)*udist/au,' au' print "(a,g10.3,a)", ' 9:1 : ',(sqrt(mcentral)/(9.*omega))**(2./3.)*udist/au,' au' - if (abs(xyzmh_ptmass(iJ2,nptmass)) > 0.) then - print "(a,g10.3)", ' J2 moment: ',xyzmh_ptmass(iJ2,nptmass) - print "(a,g10.3,a)", ' size: ',xyzmh_ptmass(iReff,nptmass)*udist/jupiterr,' Jupiter radii' - print "(a,g10.3,a)", ' size: ',xyzmh_ptmass(iReff,nptmass)*udist/earthr,' Earth radii' - print "(a,g10.3,a)", ' size: ',xyzmh_ptmass(iReff,nptmass)*udist/au,' au' - u = unitvec(xyzmh_ptmass(ispinx:ispinz,nptmass)) - print "(a,g10.3,a)", ' obliquity: ',acos(u(3))/deg_to_rad,' degrees to z=0 plane' - print "(a,g10.3,a)", ' period: ',planet_spin_period*utime/hours,' hrs' - print "(a,3(g10.3,1x))",' spin vec: ',u - print "(/,a,g10.3,a)", '# Planet total angular momentum = ',& - mag(xyzmh_ptmass(ispinx:ispinz,nptmass))*unit_angmom,' g cm^2 / s' - print "(/,a,'(',3(es10.2,1x),')')",' Planet specific angular momentum = ',& - xyzmh_ptmass(ispinx:ispinz,nptmass)/xyzmh_ptmass(4,nptmass) - endif + call print_oblateness_info(nptmass,spin_period(i)) !--check planet accretion radii if (accrplanet(i) < 0.05) then @@ -1675,6 +1670,27 @@ subroutine set_planets(npart,massoftype,xyzh) end subroutine set_planets +!-------------------------------------------------------------------------- +! +! Set properties needed for geopotential forces from sink particles +! +!-------------------------------------------------------------------------- +subroutine set_sink_oblateness(isink,J2,planet_size,spin_period_hrs,kfac,obliquity) + integer, intent(in) :: isink + real, intent(in) :: J2,planet_size,spin_period_hrs,kfac,obliquity + real :: spin_am,planet_radius,planet_spin_period + + xyzmh_ptmass(iJ2,isink) = J2 + ! compute spin angular momentum of the body + planet_radius = planet_size*jupiterr/udist + planet_spin_period = spin_period_hrs*hours/utime + spin_am = twopi*kfac*(xyzmh_ptmass(4,isink)*planet_radius**2)/planet_spin_period + xyzmh_ptmass(ispinx,isink) = spin_am*sin(obliquity*deg_to_rad) + xyzmh_ptmass(ispinz,isink) = spin_am*cos(obliquity*deg_to_rad) + xyzmh_ptmass(iReff,isink) = planet_radius + +end subroutine set_sink_oblateness + !-------------------------------------------------------------------------- ! ! Reset centre of mass to origin @@ -2270,6 +2286,14 @@ subroutine write_setupfile(filename) call write_inopt(accr2b,'accr2b','tight binary secondary accretion radius',iunit) end select + + !--options for oblateness + write(iunit,"(/,a)") '# oblateness' + do i=1,nsinks + call write_oblateness_options(iunit,'_body'//trim(num(i)), & + J2star(i),size_star(i),spin_period_star(i),kfac_star(i),obliquity_star(i)) + enddo + end select !--multiple disc options if (n_possible_discs > 1) then @@ -2397,18 +2421,13 @@ subroutine write_setupfile(filename) call write_inopt(nplanets,'nplanets','number of planets',iunit) if (nplanets > 0) then do i=1,nplanets - write(iunit,"(/,a)") '# planet:'//trim(planets(i)) - call write_inopt(mplanet(i),'mplanet'//trim(planets(i)),'planet mass (in Jupiter mass)',iunit) - call write_inopt(rplanet(i),'rplanet'//trim(planets(i)),'planet distance from star',iunit) - call write_inopt(inclplan(i),'inclplanet'//trim(planets(i)),'planet orbital inclination (deg)',iunit) - call write_inopt(accrplanet(i),'accrplanet'//trim(planets(i)),'planet accretion radius (in Hill radius)',iunit) - call write_inopt(J2planet(i),'J2planet'//trim(planets(i)),'planet J2 moment',iunit) - if (abs(J2planet(i)) > 0.) then - call write_inopt(planet_size(i),'size'//trim(planets(i)),'planet radius (Jupiter radii)',iunit) - call write_inopt(spin_period(i),'spin_period'//trim(planets(i)),'planet spin period (hrs)',iunit) - call write_inopt(kfac(i),'kfac'//trim(planets(i)),'planet concentration parameter',iunit) - call write_inopt(obliquity(i),'obliquity'//trim(planets(i)),'planet obliquity (degrees)',iunit) - endif + write(iunit,"(/,a)") '# planet:'//trim(num(i)) + call write_inopt(mplanet(i),'mplanet'//trim(num(i)),'planet mass (in Jupiter mass)',iunit) + call write_inopt(rplanet(i),'rplanet'//trim(num(i)),'planet distance from star',iunit) + call write_inopt(inclplan(i),'inclplanet'//trim(num(i)),'planet orbital inclination (deg)',iunit) + call write_inopt(accrplanet(i),'accrplanet'//trim(num(i)),'planet accretion radius (in Hill radius)',iunit) + call write_oblateness_options(iunit,'_planet'//trim(num(i)), & + J2planet(i),planet_size(i),spin_period(i),kfac(i),obliquity(i)) enddo endif ! stratification @@ -2588,6 +2607,10 @@ subroutine read_setupfile(filename,ierr) call read_inopt(accr2b,'accr2b',db,errcount=nerr) end select + do i=1,nsinks + call read_oblateness_options(db,nerr,'_body'//trim(num(i)),& + J2star(i),size_star(i),spin_period_star(i),kfac_star(i),obliquity_star(i)) + enddo end select call read_inopt(discstrat,'discstrat',db,errcount=nerr) @@ -2739,21 +2762,16 @@ subroutine read_setupfile(filename,ierr) endif endif enddo - if (maxalpha==0) call read_inopt(alphaSS,'alphaSS',db,min=0.,errcount=nerr) + if (maxalpha==0 .and. any(iuse_disc)) call read_inopt(alphaSS,'alphaSS',db,min=0.,errcount=nerr) !--planets call read_inopt(nplanets,'nplanets',db,min=0,max=maxplanets,errcount=nerr) do i=1,nplanets - call read_inopt(mplanet(i),'mplanet'//trim(planets(i)),db,min=0.,errcount=nerr) - call read_inopt(rplanet(i),'rplanet'//trim(planets(i)),db,min=0.,errcount=nerr) - call read_inopt(inclplan(i),'inclplanet'//trim(planets(i)),db,min=0.,max=180.,errcount=nerr) - call read_inopt(accrplanet(i),'accrplanet'//trim(planets(i)),db,min=0.,errcount=nerr) - call read_inopt(J2planet(i),'J2planet'//trim(planets(i)),db,min=-1.0,max=1.0) ! optional, no error if not read - if (abs(J2planet(i)) > 0.) then - call read_inopt(planet_size(i),'size'//trim(planets(i)),db,errcount=nerr) - call read_inopt(spin_period(i),'spin_period'//trim(planets(i)),db,errcount=nerr) - call read_inopt(kfac(i),'kfac'//trim(planets(i)),db,min=0.,max=1.,errcount=nerr) - call read_inopt(obliquity(i),'obliquity'//trim(planets(i)),db,min=0.,max=180.,errcount=nerr) - endif + call read_inopt(mplanet(i),'mplanet'//trim(num(i)),db,min=0.,errcount=nerr) + call read_inopt(rplanet(i),'rplanet'//trim(num(i)),db,min=0.,errcount=nerr) + call read_inopt(inclplan(i),'inclplanet'//trim(num(i)),db,min=0.,max=180.,errcount=nerr) + call read_inopt(accrplanet(i),'accrplanet'//trim(num(i)),db,min=0.,errcount=nerr) + call read_oblateness_options(db,nerr,'_planet'//trim(num(i)),& + J2planet(i),planet_size(i),spin_period(i),kfac(i),obliquity(i)) enddo !--timestepping ! following two are optional: not an error if not present @@ -2778,6 +2796,78 @@ subroutine read_setupfile(filename,ierr) end subroutine read_setupfile +!-------------------------------------------------------------------------- +! +! write options needed for oblate sink particles +! +!-------------------------------------------------------------------------- +subroutine write_oblateness_options(iunit,label,J2i,sizei,spin_periodi,kfaci,obliquityi) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + character(len=*), intent(in) :: label + real, intent(in) :: J2i,sizei,spin_periodi,kfaci,obliquityi + + call write_inopt(J2i,'J2'//trim(label),'J2 moment (oblateness)',iunit) + if (abs(J2i) > 0.) then + call write_inopt(sizei,'size'//trim(label),'radius (Jupiter radii)',iunit) + call write_inopt(spin_periodi,'spin_period'//trim(label),'spin period (hrs)',iunit) + call write_inopt(kfaci,'kfac'//trim(label),'concentration parameter',iunit) + call write_inopt(obliquityi,'obliquity'//trim(label),'obliquity (degrees)',iunit) + endif + +end subroutine write_oblateness_options + +!-------------------------------------------------------------------------- +! +! read options needed for oblate sink particles +! +!-------------------------------------------------------------------------- +subroutine read_oblateness_options(db,nerr,label,J2i,sizei,spin_periodi,kfaci,obliquityi) + use infile_utils, only:inopts,read_inopt + type(inopts), allocatable, intent(inout) :: db(:) + integer, intent(inout) :: nerr + character(len=*), intent(in) :: label + real, intent(inout) :: J2i,sizei,spin_periodi,kfaci,obliquityi + + call read_inopt(J2i,'J2'//trim(label),db,min=-1.0,max=1.0) ! optional, no error if not read + if (abs(J2i) > 0.) then + call read_inopt(sizei,'size'//trim(label),db,errcount=nerr) + call read_inopt(spin_periodi,'spin_period'//trim(label),db,errcount=nerr) + call read_inopt(kfaci,'kfac'//trim(label),db,min=0.,max=1.,errcount=nerr) + call read_inopt(obliquityi,'obliquity'//trim(label),db,min=0.,max=180.,errcount=nerr) + endif + +end subroutine read_oblateness_options + +!-------------------------------------------------------------------------- +! +! print information about oblateness on sink particles +! +!-------------------------------------------------------------------------- +subroutine print_oblateness_info(isink,spin_period_hrs) + use vectorutils, only:unitvec,mag + use units, only:unit_angmom + integer, intent(in) :: isink + real, intent(in) :: spin_period_hrs + real :: u(3) + + if (abs(xyzmh_ptmass(iJ2,isink)) > 0.) then + print "(a,g10.3)", ' J2 moment: ',xyzmh_ptmass(iJ2,isink) + print "(a,g10.3,a)", ' size: ',xyzmh_ptmass(iReff,isink)*udist/jupiterr,' Jupiter radii' + print "(a,g10.3,a)", ' size: ',xyzmh_ptmass(iReff,isink)*udist/earthr,' Earth radii' + print "(a,g10.3,a)", ' size: ',xyzmh_ptmass(iReff,isink)*udist/au,' au' + u = unitvec(xyzmh_ptmass(ispinx:ispinz,isink)) + print "(a,g10.3,a)", ' obliquity: ',acos(u(3))/deg_to_rad,' degrees to z=0 plane' + print "(a,g10.3,a)", ' period: ',spin_period_hrs,' hrs' + print "(a,3(g10.3,1x))",' spin vec: ',u + print "(/,a,g10.3,a)", '# spin angular momentum = ',& + mag(xyzmh_ptmass(ispinx:ispinz,isink))*unit_angmom,' g cm^2 / s' + print "(/,a,'(',3(es10.2,1x),')')",' specific spin angular momentum = ',& + xyzmh_ptmass(ispinx:ispinz,isink)/xyzmh_ptmass(4,isink) + endif + +end subroutine print_oblateness_info + !-------------------------------------------------------------------------- ! ! Set dustfrac From 0dbad15453e8cefd1a29aa49902e6e3e796dcf01 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Mon, 20 Jun 2022 15:12:21 +1000 Subject: [PATCH 011/814] Added NRSPH code and ET interface --- build/Makefile | 6 +- build/Makefile_setups | 9 + src/main/cons2primsolver.f90 | 36 +- src/main/eos_shen.f90 | 2 +- src/main/evolve.F90 | 622 +++++++++++++++++++++++++++++-- src/main/extern_gr.F90 | 86 ++++- src/main/initial.F90 | 17 +- src/main/interp_metric.F90 | 43 +++ src/main/metric_et.f90 | 389 +++++++++++++++++++ src/main/metric_flrw.f90 | 239 ++++++++++++ src/main/part.F90 | 4 + src/main/step_leapfrog.F90 | 33 +- src/main/tmunu2grid.f90 | 135 +++++++ src/main/utils_gr.F90 | 52 ++- src/utils/einsteintk_utils.f90 | 65 ++++ src/utils/einsteintk_wrapper.f90 | 130 +++++++ src/utils/interpolate3D.F90 | 320 ++++++++++++++++ 17 files changed, 2131 insertions(+), 57 deletions(-) create mode 100644 src/main/interp_metric.F90 create mode 100644 src/main/metric_et.f90 create mode 100644 src/main/metric_flrw.f90 create mode 100644 src/main/tmunu2grid.f90 create mode 100644 src/utils/einsteintk_utils.f90 create mode 100644 src/utils/einsteintk_wrapper.f90 create mode 100644 src/utils/interpolate3D.F90 diff --git a/build/Makefile b/build/Makefile index f0ba0a5f5..0cbe0bc73 100644 --- a/build/Makefile +++ b/build/Makefile @@ -463,7 +463,7 @@ ifdef METRIC else SRCMETRIC= metric_minkowski.f90 endif -SRCGR=inverse4x4.f90 $(SRCMETRIC) metric_tools.f90 utils_gr.f90 +SRCGR=inverse4x4.f90 einsteintk_utils.f90 $(SRCMETRIC) metric_tools.f90 utils_gr.f90 interpolate3D.f90 tmunu2grid.f90 # # chemistry # @@ -506,6 +506,10 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 boundary.f90 \ mf_write.f90 evolve.F90 \ checksetup.F90 initial.F90 +# Needed as einsteintk_wrapper depends on initial +ifeq ($(GR),yes) + SOURCES+=einsteintk_wrapper.f90 +endif OBJECTS1 = $(SOURCES:.f90=.o) OBJECTS = $(OBJECTS1:.F90=.o) diff --git a/build/Makefile_setups b/build/Makefile_setups index 7405c81c3..6610ecb1a 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -925,6 +925,15 @@ ifeq ($(SETUP), testgr) SETUPFILE= setup_grdisc.f90 endif +ifeq ($(SETUP), flrw) + GR=yes + KNOWN_SETUP=yes + IND_TIMESTEPS=no + METRIC=et + SETUPFILE= setup_unifdis.f90 + PERIODIC=yes +endif + ifeq ($(SETUP), default) # default setup, uniform box KNOWN_SETUP=yes diff --git a/src/main/cons2primsolver.f90 b/src/main/cons2primsolver.f90 index eff587090..3894890f1 100644 --- a/src/main/cons2primsolver.f90 +++ b/src/main/cons2primsolver.f90 @@ -71,7 +71,7 @@ end subroutine get_u !+ !---------------------------------------------------------------- subroutine primitive2conservative(x,metrici,v,dens,u,P,rho,pmom,en,ien_type) - use utils_gr, only:get_u0 + use utils_gr, only:get_u0, get_sqrtg use metric_tools, only:unpack_metric use io, only:error real, intent(in) :: x(1:3),metrici(:,:,:) @@ -89,8 +89,10 @@ subroutine primitive2conservative(x,metrici,v,dens,u,P,rho,pmom,en,ien_type) enth = 1. + u + P/dens ! Hard coded sqrtg=1 since phantom is always in cartesian coordinates - sqrtg = 1. + ! NO BAD!! + !sqrtg = 1. call unpack_metric(metrici,gcov=gcov) + call get_sqrtg(gcov,sqrtg) call get_u0(gcov,v,U0,ierror) if (ierror > 0) call error('get_u0 in prim2cons','1/sqrt(-v_mu v^mu) ---> non-negative: v_mu v^mu') @@ -157,6 +159,7 @@ end subroutine conservative2primitive !+ !---------------------------------------------------------------- subroutine conservative2primitive_var_gamma(x,metrici,v,dens,u,P,rho,pmom,en,ierr,ien_type) + use utils_gr, only:get_sqrtg use metric_tools, only:unpack_metric use units, only:unit_ergg,unit_density,unit_pressure use eos, only:calc_temp_and_ene,ieos @@ -172,18 +175,19 @@ subroutine conservative2primitive_var_gamma(x,metrici,v,dens,u,P,rho,pmom,en,ier real :: u_in,P_in,dens_in,ucgs,Pcgs,denscgs,enth0,gamma0,enth_min,enth_max real :: enth_rad,enth_gas,gamma_rad,gamma_gas integer :: niter,i,ierr1,ierr2 - real, parameter :: tol = 1.e-12 - integer, parameter :: nitermax = 500 + real, parameter :: tol = 1.e-3 + integer, parameter :: nitermax = 100000 logical :: converged + real :: gcov(0:3,0:3) ierr = 0 - ! Hard coding sqrgt=1 since phantom is always in cartesian coordinates - sqrtg = 1. - sqrtg_inv = 1./sqrtg - ! Get metric components from metric array - call unpack_metric(metrici,gammaijUP=gammaijUP,alpha=alpha,betadown=betadown,betaUP=betaUP) + call unpack_metric(metrici,gcov=gcov,gammaijUP=gammaijUP,alpha=alpha,betadown=betadown,betaUP=betaUP) + ! Hard coding sqrgt=1 since phantom is always in cartesian coordinates + !sqrtg = 1. + call get_sqrtg(gcov,sqrtg) + sqrtg_inv = 1./sqrtg pmom2 = 0. do i=1,3 pmom2 = pmom2 + pmom(i)*dot_product(gammaijUP(:,i),pmom(:)) @@ -296,6 +300,7 @@ end subroutine conservative2primitive_var_gamma !+ !---------------------------------------------------------------- subroutine conservative2primitive_con_gamma(x,metrici,v,dens,u,P,gamma,enth,rho,pmom,en,ierr,ien_type) + use utils_gr, only:get_sqrtg use metric_tools, only:unpack_metric use eos, only:calc_temp_and_ene,ieos real, intent(in) :: x(1:3),metrici(:,:,:),gamma @@ -308,18 +313,19 @@ subroutine conservative2primitive_con_gamma(x,metrici,v,dens,u,P,gamma,enth,rho, real :: sqrtg,sqrtg_inv,lorentz_LEO,pmom2,alpha,betadown(1:3),betaUP(1:3),enth_old,v3d(1:3) real :: f,df,term,lorentz_LEO2,gamfac,pm_dot_b,sqrt_gamma_inv integer :: niter, i - real, parameter :: tol = 1.e-12 - integer, parameter :: nitermax = 100 + real, parameter :: tol = 1.e-3 + integer, parameter :: nitermax = 100000 logical :: converged + real :: gcov(0:3,0:3) ierr = 0 + ! Get metric components from metric array + call unpack_metric(metrici,gcov=gcov,gammaijUP=gammaijUP,alpha=alpha,betadown=betadown,betaUP=betaUP) + ! Hard coding sqrgt=1 since phantom is always in cartesian coordinates - sqrtg = 1. + call get_sqrtg(gcov, sqrtg) sqrtg_inv = 1./sqrtg - ! Get metric components from metric array - call unpack_metric(metrici,gammaijUP=gammaijUP,alpha=alpha,betadown=betadown,betaUP=betaUP) - pmom2 = 0. do i=1,3 pmom2 = pmom2 + pmom(i)*dot_product(gammaijUP(:,i),pmom(:)) diff --git a/src/main/eos_shen.f90 b/src/main/eos_shen.f90 index 1e7c1c557..32467c513 100644 --- a/src/main/eos_shen.f90 +++ b/src/main/eos_shen.f90 @@ -249,7 +249,7 @@ end subroutine CINT ! Interpolate between values using linear interpolation in 1D !+ !------------------------------------------------------------------------ -subroutine linear_interpolator_one_d(val0,val1,u,val) +pure subroutine linear_interpolator_one_d(val0,val1,u,val) real, intent(out) :: val real, intent(in) :: val0,val1,u diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 5bb34bb79..a7ee4c7b6 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -22,31 +22,614 @@ module evolve ! radiation_utils, readwrite_dumps, readwrite_infile, step_lf_global, ! supertimestep, timestep, timestep_ind, timestep_sts, timing ! + use externalforces, only:iext_spiral + use energies, only:etot,totmom,angtot,mdust,np_cs_eq_0,np_e_eq_0 + use io, only:iprint,iwritein,id,master,iverbose,& + flush_warnings,nprocs,fatal,warning + use timestep, only:time,tmax,dt,dtmax,nmax,nout,nsteps,dtextforce,rhomaxnow,& + dtmax_ifactor,dtmax_dratio,check_dtmax_for_decrease + use timestep, only:dtrad + use part, only:npart,nptmass,xyzh,vxyzu,fxyzu,fext,divcurlv,massoftype, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gravity,iboundary, & + fxyz_ptmass_sinksink,ntot,poten,ndustsmall,accrete_particles_outside_sphere,tmunus,dens,metrics,metricderivs + use options, only:nfulldump,twallmax,nmaxdumps,rhofinal1,iexternalforce,rkill + use timing, only:get_timings,print_time,timer,reset_timer,increment_timer,& + setup_timers,timers,reduce_timers,itimer_fromstart,itimer_lastdump,itimer_step,itimer_ev,& + itimer_dens,itimer_force,itimer_link,itimer_balance,itimer_extf,itimer_io + use checkconserved, only:etot_in,angtot_in,totmom_in,mdust_in,& + init_conservation_checks,check_conservation_error + implicit none - public :: evol + public :: evol, evol_init, evol_step private - + real(kind=4) :: t1,t2,tcpu1,tcpu2,tstart,tcpustart + real(kind=4) :: twalllast,tcpulast,twallperdump,twallused + integer :: noutput,noutput_dtmax,nsteplast,ncount_fulldumps + real :: dtnew,dtlast,timecheck,rhomaxold,dtmax_log_dratio + real :: tprint,tzero,dtmaxold,dtinject + logical :: should_conserve_energy,should_conserve_momentum,should_conserve_angmom + logical :: should_conserve_dustmass + logical :: use_global_dt contains +subroutine evol_init(infile,logfile,evfile,dumpfile,dt_et) + ! Initialises all the required variables/files required for a run + character(len=*), intent(in) :: infile + character(len=*), intent(inout) :: logfile,evfile,dumpfile + real, intent(in) :: dt_et + integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold +#ifdef IND_TIMESTEPS + integer :: nalive,inbin + integer(kind=1) :: nbinmaxprev + integer(kind=8) :: nmovedtot,nalivetot + real :: tlast,tcheck,dtau + real(kind=4) :: tall + real(kind=4) :: timeperbin(0:maxbins) + logical :: dt_changed +#else + real :: dtprint + integer :: nactive,istepfrac + integer(kind=1) :: nbinmax + logical, parameter :: dt_changed = .false. +#endif + + tprint = 0. + nsteps = 0 + nsteplast = 0 + tzero = time + dtlast = 0. + dtinject = huge(dtinject) + dtrad = huge(dtrad) + np_cs_eq_0 = 0 + np_e_eq_0 = 0 + + dtmax = dt_et + + call init_conservation_checks(should_conserve_energy,should_conserve_momentum,& + should_conserve_angmom,should_conserve_dustmass) + + noutput = 1 + noutput_dtmax = 1 + ncount_fulldumps = 0 + tprint = tzero + dtmax + rhomaxold = rhomaxnow + if (dtmax_dratio > 0.) then + dtmax_log_dratio = log10(dtmax_dratio) + else + dtmax_log_dratio = 0.0 + endif + +#ifdef IND_TIMESTEPS + use_global_dt = .false. + istepfrac = 0 + tlast = tzero + dt = dtmax/2**nbinmax + nmovedtot = 0 + tall = 0. + tcheck = time + timeperbin(:) = 0. + dt_changed = .false. + call init_step(npart,time,dtmax) + if (use_sts) then + call sts_get_dtau_next(dtau,dt,dtmax,dtdiff,nbinmax) + call sts_init_step(npart,time,dtmax,dtau) ! overwrite twas for particles requiring super-timestepping + endif +#else + use_global_dt = .true. + nskip = int(ntot) + nactive = npart + istepfrac = 0 ! dummy values + nbinmax = 0 + if (dt >= (tprint-time)) dt = tprint-time ! reach tprint exactly +#endif + ! + ! threshold for writing to .ev file, to avoid repeatedly computing energies + ! for all the particles which would add significantly to the cpu time + ! + + nskipped = 0 + if (iexternalforce==iext_spiral) then + nevwrite_threshold = int(4.99*ntot) ! every 5 full steps + else + nevwrite_threshold = int(1.99*ntot) ! every 2 full steps + endif + nskipped_sink = 0 + nsinkwrite_threshold = int(0.99*ntot) + ! + ! code timings + ! + call get_timings(twalllast,tcpulast) + tstart = twalllast + tcpustart = tcpulast + + call setup_timers + + call flush(iprint) +end subroutine evol_init + + +subroutine evol_step(infile,logfile,evfile,dumpfile,dt_et) + use evwrite, only:write_evfile,write_evlog + use dim, only:maxvxyzu,mhd,periodic + use fileutils, only:getnextfilename + + use readwrite_infile, only:write_infile + use readwrite_dumps, only:write_smalldump,write_fulldump + use step_lf_global, only:step + use mpiutils, only:reduce_mpi,reduceall_mpi,barrier_mpi,bcast_mpi +#ifdef IND_TIMESTEPS + use part, only:ibin,iphase + use timestep_ind, only:istepfrac,nbinmax,set_active_particles,update_time_per_bin,& + write_binsummary,change_nbinmax,nactive,nactivetot,maxbins,& + print_dtlog_ind,get_newbin,print_dtind_efficiency + use timestep, only:dtdiff + use timestep_sts, only:sts_get_dtau_next,sts_init_step + use step_lf_global, only:init_step +#else + use timestep, only:dtforce,dtcourant,dterr,print_dtlog +#endif + use timestep_sts, only: use_sts + use supertimestep, only: step_sts +#ifdef DRIVING + use forcing, only:write_forcingdump +#endif +#ifdef CORRECT_BULK_MOTION + use centreofmass, only:correct_bulk_motion +#endif + use part, only:ideadhead,shuffle_part +#ifdef INJECT_PARTICLES + use inject, only:inject_particles + use part, only:npartoftype + use partinject, only:update_injected_particles +#endif + use dim, only:do_radiation + use options, only:exchange_radiation_energy + use part, only:rad,radprop + use radiation_utils, only:update_radenergy + use timestep, only:dtrad +#ifdef LIVE_ANALYSIS + use analysis, only:do_analysis + use part, only:igas + use fileutils, only:numfromfile + use io, only:ianalysis +#endif + use quitdump, only:quit + use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot + use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow +#ifdef MFLOW + use mf_write, only:mflow_write +#endif +#ifdef VMFLOW + use mf_write, only:vmflow_write +#endif +#ifdef BINPOS + use mf_write, only:binpos_write +#endif +#ifdef GR + use extern_gr + use tmunu2grid +#endif + + character(len=*), intent(in) :: infile + character(len=*), intent(inout) :: logfile,evfile,dumpfile + real, intent(inout) :: dt_et + +#ifdef IND_TIMESTEPS + integer :: nalive,inbin + integer(kind=1) :: nbinmaxprev + integer(kind=8) :: nmovedtot,nalivetot + real :: tlast,tcheck,dtau + real(kind=4) :: tall + real(kind=4) :: timeperbin(0:maxbins) + logical :: dt_changed +#else + real :: dtprint + integer :: nactive,istepfrac + integer(kind=1) :: nbinmax + logical, parameter :: dt_changed = .false. +#endif +#ifdef INJECT_PARTICLES + integer :: npart_old +#endif + logical :: fulldump,abortrun,at_dump_time,writedump + + integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold + real, parameter :: xor(3)=0. + + ! set the dtmax to be et dt? + dtmax = dt_et + dt = dt_et + print*, "In evolve step!" + print*, "Time in phantom is: ", time +#ifdef INJECT_PARTICLES + ! + ! injection of new particles into simulation + ! + npart_old=npart + call inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,dtinject) + call update_injected_particles(npart_old,npart,istepfrac,nbinmax,time,dtmax,dt,dtinject) +#endif + + dtmaxold = dtmax +#ifdef IND_TIMESTEPS + istepfrac = istepfrac + 1 + nbinmaxprev = nbinmax + !--determine if dt needs to be decreased; if so, then this will be done + ! in step the next time it is called; + ! for global timestepping, this is called in the block where at_dump_time==.true. + if (istepfrac==2**nbinmax) then + twallperdump = reduceall_mpi('max', timers(itimer_lastdump)%wall) + call check_dtmax_for_decrease(iprint,dtmax,twallperdump,dtmax_ifactor,dtmax_log_dratio,& + rhomaxold,rhomaxnow,nfulldump,use_global_dt) + endif + + !--sanity check on istepfrac... + if (istepfrac > 2**nbinmax) then + write(iprint,*) 'ERROR: istepfrac = ',istepfrac,' / ',2**nbinmax + call fatal('evolve','error in individual timesteps') + endif + + print*, "before set active particles" + !--flag particles as active or not for this timestep + call set_active_particles(npart,nactive,nalive,iphase,ibin,xyzh) + nactivetot = reduceall_mpi('+', nactive) + nalivetot = reduceall_mpi('+', nalive) + nskip = int(nactivetot) + + !--print summary of timestep bins + if (iverbose >= 2) call write_binsummary(npart,nbinmax,dtmax,timeperbin,iphase,ibin,xyzh) +#else + !--If not using individual timestepping, set nskip to the total number of particles + ! across all nodes + nskip = int(ntot) +#endif + + if (gravity .and. icreate_sinks > 0 .and. ipart_rhomax /= 0) then + ! + ! creation of new sink particles + ! + call ptmass_create(nptmass,npart,ipart_rhomax,xyzh,vxyzu,fxyzu,fext,divcurlv,& + poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,time) + endif + ! + ! Strang splitting: implicit update for half step + ! + if (do_radiation.and.exchange_radiation_energy) then + call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) + endif + nsteps = nsteps + 1 +! +!--evolve data for one timestep +! for individual timesteps this is the shortest timestep +! + print*, "before get timings" + call get_timings(t1,tcpu1) + if ( use_sts ) then + print*, "before step indv" + call step_sts(npart,nactive,time,dt,dtextforce,dtnew,iprint) + else + print*, "before step" + call step(npart,nactive,time,dt,dtextforce,dtnew) + print*, "after step" + endif + ! Calculate the stress energy tensor + call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + ! Interpolate stress energy tensor from particles back + ! to grid + call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) + ! + ! Strang splitting: implicit update for another half step + ! + if (do_radiation.and.exchange_radiation_energy) then + call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) + endif + + dtlast = dt + + !--timings for step call + call get_timings(t2,tcpu2) + call increment_timer(itimer_step,t2-t1,tcpu2-tcpu1) + call summary_counter(iosum_nreal,t2-t1) + +#ifdef IND_TIMESTEPS + tcheck = tcheck + dt + + !--update time in way that is free of round-off errors + time = tlast + istepfrac/real(2**nbinmaxprev)*dtmaxold + + !--print efficiency of partial timestep + if (id==master) call print_dtind_efficiency(iverbose,nalivetot,nactivetot,tall,t2-t1,1) + + call update_time_per_bin(tcpu2-tcpu1,istepfrac,nbinmaxprev,timeperbin,inbin) + nmovedtot = nmovedtot + nactivetot + + !--check that time is as it should be, may indicate error in individual timestep routines + if (abs(tcheck-time) > 1.e-4) call warning('evolve','time out of sync',var='error',val=abs(tcheck-time)) + + if (id==master .and. (iverbose >= 1 .or. inbin <= 3)) & + call print_dtlog_ind(iprint,istepfrac,2**nbinmaxprev,time,dt,nactivetot,tcpu2-tcpu1,ntot) + + !--if total number of bins has changed, adjust istepfrac and dt accordingly + ! (ie., decrease or increase the timestep) + if (nbinmax /= nbinmaxprev .or. dtmax_ifactor /= 0) then + call change_nbinmax(nbinmax,nbinmaxprev,istepfrac,dtmax,dt) + dt_changed = .true. + endif + +#else + + ! advance time on master thread only + if (id == master) time = time + dt + call bcast_mpi(time) + +! +!--set new timestep from Courant/forces condition +! + ! constraint from time to next printout, must reach this exactly + ! Following redefinitions are to avoid crashing if dtprint = 0 & to reach next output while avoiding round-off errors + dtprint = min(tprint,tmax) - time + epsilon(dtmax) + if (dtprint <= epsilon(dtmax) .or. dtprint >= (1.0-1e-8)*dtmax ) dtprint = dtmax + epsilon(dtmax) + dt = min(dtforce,dtcourant,dterr,dtmax+epsilon(dtmax),dtprint,dtinject,dtrad) +! +!--write log every step (NB: must print after dt has been set in order to identify timestep constraint) +! + if (id==master) call print_dtlog(iprint,time,dt,dtforce,dtcourant,dterr,dtmax,dtrad,dtprint,dtinject,ntot) +#endif + +! check that MPI threads are synchronised in time + timecheck = reduceall_mpi('+',time) + if (abs(timecheck/nprocs - time) > 1.e-13) then + call fatal('evolve','time differs between MPI threads',var='time',val=timecheck/nprocs) + endif +! +!--Update timer from last dump to see if dtmax needs to be reduced +! + call get_timings(t2,tcpu2) + call increment_timer(itimer_lastdump,t2-t1,tcpu2-tcpu1) +! +!--Determine if this is the correct time to write to the data file +! + at_dump_time = (time >= tmax) & + .or.((nsteps >= nmax).and.(nmax >= 0)).or.(rhomaxnow*rhofinal1 >= 1.0) +#ifdef IND_TIMESTEPS + if (istepfrac==2**nbinmax) at_dump_time = .true. +#else + if (time >= tprint) at_dump_time = .true. +#endif +! +!--Calculate total energy etc and write to ev file +! For individual timesteps, we do not want to do this every step, but we want +! to do this as often as possible without a performance hit. The criteria +! here is that it is done once >10% of particles (cumulatively) have been evolved. +! That is, either >10% are being stepped, or e.g. 1% have moved 10 steps. +! Perform this prior to writing the dump files so that diagnostic values calculated +! in energies can be correctly included in the dumpfiles +! + nskipped = nskipped + nskip + if (nskipped >= nevwrite_threshold .or. at_dump_time .or. dt_changed .or. iverbose==5) then + nskipped = 0 + call get_timings(t1,tcpu1) + call write_evfile(time,dt) + if (should_conserve_momentum) call check_conservation_error(totmom,totmom_in,1.e-1,'linear momentum') + if (should_conserve_angmom) call check_conservation_error(angtot,angtot_in,1.e-1,'angular momentum') + if (should_conserve_energy) call check_conservation_error(etot,etot_in,1.e-1,'energy') + if (should_conserve_dustmass) then + do j = 1,ndustsmall + call check_conservation_error(mdust(j),mdust_in(j),1.e-1,'dust mass',decrease=.true.) + enddo + endif + 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)) + endif + + !--write with the same ev file frequency also mass flux and binary position +#ifdef MFLOW + call mflow_write(time,dt) +#endif +#ifdef VMFLOW + call vmflow_write(time,dt) +#endif +#ifdef BINPOS + call binpos_write(time,dt) +#endif + call get_timings(t2,tcpu2) + call increment_timer(itimer_ev,t2-t1,tcpu2-tcpu1) ! time taken for write_ev operation + endif +!-- Print out the sink particle properties & reset dt_changed. +!-- Added total force on sink particles and sink-sink forces to write statement (fxyz_ptmass,fxyz_ptmass_sinksink) + nskipped_sink = nskipped_sink + nskip + if (nskipped_sink >= nsinkwrite_threshold .or. at_dump_time .or. dt_changed) then + nskipped_sink = 0 + call pt_write_sinkev(nptmass,time,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink) +#ifdef IND_TIMESTEPS + dt_changed = .false. +#endif + endif +! +!--write to data file if time is right +! + if (at_dump_time) then + !--modify evfile and logfile names with new number + if ((nout <= 0) .or. (mod(noutput,nout)==0)) then + if (noutput==1) then + evfile = getnextfilename(evfile) + logfile = getnextfilename(logfile) + endif + dumpfile = getnextfilename(dumpfile) + writedump = .true. + else + writedump = .false. + endif + + !--do not dump dead particles into dump files + if (ideadhead > 0) call shuffle_part(npart) + +#ifndef IND_TIMESTEPS +! +!--Global timesteps: Decrease dtmax if requested (done in step for individual timesteps) + twallperdump = timers(itimer_lastdump)%wall + call check_dtmax_for_decrease(iprint,dtmax,twallperdump,dtmax_ifactor,dtmax_log_dratio,& + rhomaxold,rhomaxnow,nfulldump,use_global_dt) +#endif +! +!--get timings since last dump and overall code scaling +! (get these before writing the dump so we can check whether or not we +! need to write a full dump based on the wall time; +! move timer_lastdump outside at_dump_time block so that dtmax can +! be reduced it too long between dumps) +! + call increment_timer(itimer_fromstart,t2-tstart,tcpu2-tcpustart) + + fulldump = (nout <= 0 .and. mod(noutput,nfulldump)==0) .or. (mod(noutput,nout*nfulldump)==0) +! +!--if max wall time is set (> 1 sec) stop the run at the last full dump +! that will fit into the walltime constraint, based on the wall time between +! the last two dumps added to the current total walltime used. The factor of three for +! changing to full dumps is to account for the possibility that the next step will take longer. +! If we are about to write a small dump but it looks like we won't make the next dump, +! write a full dump instead and stop the run +! + abortrun = .false. + if (twallmax > 1.) then + twallused = timers(itimer_fromstart)%wall + twallperdump = timers(itimer_lastdump)%wall + if (fulldump) then + if ((twallused + abs(nfulldump)*twallperdump) > twallmax) then + abortrun = .true. + endif + else + if ((twallused + 3.0*twallperdump) > twallmax) then + fulldump = .true. + if (id==master) write(iprint,"(1x,a)") '>> PROMOTING DUMP TO FULL DUMP BASED ON WALL TIME CONSTRAINTS... ' + nfulldump = 1 ! also set all future dumps to be full dumps (otherwise gets confusing) + if ((twallused + twallperdump) > twallmax) abortrun = .true. + endif + endif + endif +! +!--Promote to full dump if this is the final dump +! + if ( (time >= tmax) .or. ( (nmax > 0) .and. (nsteps >= nmax) ) ) fulldump = .true. +! +!--flush any buffered warnings to the log file +! + if (id==master) call flush_warnings() +! +!--write dump file +! + if (rkill > 0) call accrete_particles_outside_sphere(rkill) +#ifndef INJECT_PARTICLES + call calculate_mdot(nptmass,time,xyzmh_ptmass) +#endif + call get_timings(t1,tcpu1) + if (writedump) then + if (fulldump) then + call write_fulldump(time,dumpfile) + if (id==master) then + call write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) +#ifdef DRIVING + call write_forcingdump(time,dumpfile) +#endif + endif + ncount_fulldumps = ncount_fulldumps + 1 + else + call write_smalldump(time,dumpfile) + endif + endif + call get_timings(t2,tcpu2) + call increment_timer(itimer_io,t2-t1,tcpu2-tcpu1) + +#ifdef LIVE_ANALYSIS + if (id==master) then + call do_analysis(dumpfile,numfromfile(dumpfile),xyzh,vxyzu, & + massoftype(igas),npart,time,ianalysis) + endif +#endif + call reduce_timers + if (id==master) then + call print_timinginfo(iprint,nsteps,nsteplast) + !--Write out summary to log file + call summary_printout(iprint,nptmass) + endif +#ifdef IND_TIMESTEPS + !--print summary of timestep bins + if (iverbose >= 0) then + call write_binsummary(npart,nbinmax,dtmax,timeperbin,iphase,ibin,xyzh) + timeperbin(:) = 0. + if (id==master) call print_dtind_efficiency(iverbose,nalivetot,nmovedtot,tall,timers(itimer_lastdump)%wall,2) + endif + tlast = tprint + istepfrac = 0 + nmovedtot = 0 +#endif + ! print summary of energies and other useful values to the log file + if (id==master) call write_evlog(iprint) + ! + !--if twallmax > 1s stop the run at the last full dump that will fit into the walltime constraint, + ! based on the wall time between the last two dumps added to the current total walltime used. + ! + if (abortrun) then + if (id==master) then + call print_time(t2-tstart,'>> WALL TIME = ',iprint) + call print_time(twallmax,'>> NEXT DUMP WILL TRIP OVER MAX WALL TIME: ',iprint) + write(iprint,"(1x,a)") '>> ABORTING... ' + endif + return + endif + + if (nmaxdumps > 0 .and. ncount_fulldumps >= nmaxdumps) then + if (id==master) write(iprint,"(a)") '>> reached maximum number of full dumps as specified in input file, stopping...' + return + endif + + twalllast = t2 + tcpulast = tcpu2 + call reset_timer(itimer_fromstart) + call reset_timer(itimer_lastdump ) + call reset_timer(itimer_step ) + call reset_timer(itimer_link ) + call reset_timer(itimer_balance ) + call reset_timer(itimer_dens ) + call reset_timer(itimer_force ) + call reset_timer(itimer_extf ) + call reset_timer(itimer_io ) + call reset_timer(itimer_ev ) + + noutput_dtmax = noutput_dtmax + 1 + noutput = noutput + 1 + tprint = tzero + noutput_dtmax*dtmaxold + nsteplast = nsteps + if (dtmax_ifactor/=0) then + tzero = tprint - dtmaxold + tprint = tzero + dtmax + noutput_dtmax = 1 + dtmax_ifactor = 0 + endif + endif + +#ifdef CORRECT_BULK_MOTION + call correct_bulk_motion() +#endif + + if (iverbose >= 1 .and. id==master) write(iprint,*) + call flush(iprint) + !--Write out log file prematurely (if requested based upon nstep, walltime) + if ( summary_printnow() ) call summary_printout(iprint,nptmass) +end subroutine evol_step + +subroutine finalize_step + +end subroutine finalize_step subroutine evol(infile,logfile,evfile,dumpfile) - use io, only:iprint,iwritein,id,master,iverbose,& - flush_warnings,nprocs,fatal,warning - use timestep, only:time,tmax,dt,dtmax,nmax,nout,nsteps,dtextforce,rhomaxnow,& - dtmax_ifactor,dtmax_dratio,check_dtmax_for_decrease use evwrite, only:write_evfile,write_evlog - use energies, only:etot,totmom,angtot,mdust,np_cs_eq_0,np_e_eq_0 - use checkconserved, only:etot_in,angtot_in,totmom_in,mdust_in,& - init_conservation_checks,check_conservation_error use dim, only:maxvxyzu,mhd,periodic use fileutils, only:getnextfilename - use options, only:nfulldump,twallmax,nmaxdumps,rhofinal1,iexternalforce,rkill + use readwrite_infile, only:write_infile use readwrite_dumps, only:write_smalldump,write_fulldump use step_lf_global, only:step - use timing, only:get_timings,print_time,timer,reset_timer,increment_timer,& - setup_timers,timers,reduce_timers,ntimers,& - itimer_fromstart,itimer_lastdump,itimer_step,itimer_io,itimer_ev use mpiutils, only:reduce_mpi,reduceall_mpi,barrier_mpi,bcast_mpi #ifdef IND_TIMESTEPS use part, only:ibin,iphase @@ -84,13 +667,9 @@ subroutine evol(infile,logfile,evfile,dumpfile) use fileutils, only:numfromfile use io, only:ianalysis #endif - use part, only:npart,nptmass,xyzh,vxyzu,fxyzu,fext,divcurlv,massoftype, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gravity,iboundary, & - fxyz_ptmass_sinksink,ntot,poten,ndustsmall,accrete_particles_outside_sphere use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow - use externalforces, only:iext_spiral #ifdef MFLOW use mf_write, only:mflow_write #endif @@ -103,11 +682,6 @@ subroutine evol(infile,logfile,evfile,dumpfile) character(len=*), intent(in) :: infile character(len=*), intent(inout) :: logfile,evfile,dumpfile - integer :: i,noutput,noutput_dtmax,nsteplast,ncount_fulldumps - real :: dtnew,dtlast,timecheck,rhomaxold,dtmax_log_dratio - real :: tprint,tzero,dtmaxold,dtinject - real(kind=4) :: t1,t2,tcpu1,tcpu2,tstart,tcpustart - real(kind=4) :: twalllast,tcpulast,twallperdump,twallused #ifdef IND_TIMESTEPS integer :: nalive,inbin integer(kind=1) :: nbinmaxprev @@ -126,9 +700,7 @@ subroutine evol(infile,logfile,evfile,dumpfile) integer :: npart_old #endif logical :: fulldump,abortrun,at_dump_time,writedump - logical :: should_conserve_energy,should_conserve_momentum,should_conserve_angmom - logical :: should_conserve_dustmass - logical :: use_global_dt + integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold real, parameter :: xor(3)=0. diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index f10c45c22..810cec2dd 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -19,7 +19,7 @@ module extern_gr ! implicit none - public :: get_grforce, get_grforce_all, update_grforce_leapfrog + public :: get_grforce, get_grforce_all, update_grforce_leapfrog, get_tmunu_all private @@ -223,4 +223,88 @@ subroutine update_grforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi, end subroutine update_grforce_leapfrog +subroutine get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + use eos, only:ieos,get_pressure + use part, only:isdead_or_accreted + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) + real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) + real :: pi + integer :: i + logical :: verbose + + verbose = .false. + ! TODO write openmp parallel code + do i=1, npart + !print*, "i: ", i + if (i==1) then + verbose = .true. + else + verbose = .false. + endif + if (.not.isdead_or_accreted(xyzh(4,i))) then + pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) + call get_tmunu(xyzh(:,i),metrics(:,:,:,i), metricderivs(:,:,:,i), & + vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i),verbose) + endif + enddo + !print*, "tmunu calc val is: ", tmunus(0,0,5) +end subroutine get_tmunu_all + +! Subroutine to calculate the covariant form of the stress energy tensor +! For a particle at position p +subroutine get_tmunu(x,metrici,metricderivsi,v,dens,u,p,tmunu,verbose) + use metric_tools, only:unpack_metric + real, intent(in) :: x(3),metrici(:,:,:),metricderivsi(0:3,0:3,3),v(3),dens,u,p + real, intent(out) :: tmunu(0:3,0:3) + logical, optional, intent(in) :: verbose + real :: w,v4(0:3),vcov(3),lorentz + real :: gcov(0:3,0:3), gcon(0:3,0:3) + real :: gammaijdown(1:3,1:3),betadown(3),alpha + real :: velshiftterm + integer :: i,j + + ! Calculate the enthalpy + w = 1 + u + p/dens + + ! Get cov and con versions of the metric + spatial metric and lapse and shift + ! Not entirely convinced that the lapse and shift calculations are acccurate for the general case!! + !print*, "Before unpack metric " + call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) + !print*, "After unpack metric" + if (present(verbose) .and. verbose) then + ! Do we get sensible values + print*, "Unpacked metric quantities..." + print*, "gcov: ", gcov + print*, "gcon: ", gcon + print*, "gammaijdown: ", gammaijdown + print* , "alpha: ", alpha + print*, "betadown: ", betadown + endif + + ! We need the covariant version of the 3 velocity + ! gamma_ij v^j = v_i where gamma_ij is the spatial metric + do i=1, 3 + vcov(i) = gammaijdown(i,1)*v4(1) + gammaijdown(i,2)*v4(2) + gammaijdown(i,3)*v4(3) + enddo + + ! Calculate the lorentz factor + lorentz = (1. - (vcov(1)*v(1) + vcov(2)*v(2) + vcov(3)*v(3)))**(-0.5) + + ! Calculate the 4-velocity + velshiftterm = vcov(1)*betadown(1) + vcov(2)*betadown(2) + vcov(3)*betadown(3) + v4(0) = lorentz*(-alpha + velshiftterm) + v4(1:3) = lorentz*v(1:3) + + ! Stress energy tensor + do j=0,3 + do i=0,3 + tmunu(i,j) = dens*w*v4(i)*v4(j) + p*gcov(i,j) + enddo + enddo + if (verbose) then + print*, "tmunu part: ", tmunu + endif +end subroutine get_tmunu + end module extern_gr diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 6183ade36..456436138 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -133,11 +133,13 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use densityforce, only:densityiterate use linklist, only:set_linklist #ifdef GR - use part, only:metricderivs + use part, only:metricderivs,tmunus use cons2prim, only:prim2consall use eos, only:ieos - use extern_gr, only:get_grforce_all + use extern_gr, only:get_grforce_all,get_tmunu_all use metric_tools, only:init_metric,imet_minkowski,imetric + use einsteintk_utils + use tmunu2grid #endif #ifdef PHOTO use photoevap, only:set_photoevap_grid @@ -416,13 +418,24 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif #ifndef PRIM2CONS_FIRST ! COMPUTE METRIC HERE + call print_etgrid + print*, "Before init metric!" call init_metric(npart,xyzh,metrics,metricderivs) + print*, "metric val is: ", metrics(:,:,:,1) + print*, "Before prims2consall" call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) #endif if (iexternalforce > 0 .and. imetric /= imet_minkowski) then call initialise_externalforces(iexternalforce,ierr) if (ierr /= 0) call fatal('initial','error in external force settings/initialisation') + print*, "Before get_grforce_all" call get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtextforce) + print*, "Before get_tmunu_all" + call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + print*, "get_tmunu_all finished!" + !print*, "tmunus: ", tmunus + !stop + call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) endif #else if (iexternalforce > 0) then diff --git a/src/main/interp_metric.F90 b/src/main/interp_metric.F90 new file mode 100644 index 000000000..d55547616 --- /dev/null +++ b/src/main/interp_metric.F90 @@ -0,0 +1,43 @@ +module metric_interp + + interface trilinear_interp + module procedure interp_g, interp_sqrtg, interp_gderiv + end interface trilinear_interp + contains + + subroutine interp_g() + end subroutine interp_g + + subroutine interp_sqrtg() + + end subroutine interp_sqrtg + + subroutine interp_gderiv() + + end subroutine interp_gderiv + + pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) + use einsteintk_utils, only:gridorigin + real, intent(in) :: position(3) + real, intent(in) :: dx(3) + integer, intent(out) :: xlower,ylower,zlower + + ! Get the lower grid neighbours of the position + ! If this is broken change from floor to int + ! How are we handling the edge case of a particle being + ! in exactly the same position as the grid? + ! Hopefully having different grid sizes in each direction + ! Doesn't break the lininterp + xlower = floor((position(1)-gridorigin(1))/dx(1)) + ylower = floor((position(2)-gridorigin(2))/dx(2)) + zlower = floor((position(3)-gridorigin(3))/dx(3)) + + ! +1 because fortran + xlower = xlower + 1 + ylower = ylower + 1 + zlower = zlower + 1 + + +end subroutine get_grid_neighbours + +end module metric_interp \ No newline at end of file diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 new file mode 100644 index 000000000..5392fc1de --- /dev/null +++ b/src/main/metric_et.f90 @@ -0,0 +1,389 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.bitbucket.io/ ! +!--------------------------------------------------------------------------! +module metric +! +! None +! +! :References: None +! +! :Owner: David Liptai +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils +! + implicit none + character(len=*), parameter :: metric_type = 'et' + integer, parameter :: imetric = 6 + +contains + +!---------------------------------------------------------------- +!+ +! Compute the metric tensor in both covariant (gcov) and +! contravariant (gcon) form +!+ +!---------------------------------------------------------------- +pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) + use einsteintk_utils, only:gridinit + real, intent(in) :: position(3) + real, intent(out) :: gcov(0:3,0:3) + real, intent(out), optional :: gcon(0:3,0:3) + real, intent(out), optional :: sqrtg + + ! The subroutine that computes the metric tensor for a given position + ! In this case it is interpolated from the global grid values + + ! Perform trilenar interpolation + if ( .not. gridinit) then + ! This is required for phantomsetup + ! As no grid information has been passed to phantom from ET + ! So interpolation cannot be performed + gcov = 0. + gcov(0,0) = -1. + gcov(1,1) = 1. + gcov(2,2) = 1. + gcov(3,3) = 1. + if (present(gcon)) then + gcon = 0. + gcon(0,0) = -1. + gcon(1,1) = 1. + gcon(2,2) = 1. + gcon(3,3) = 1. + endif + if (present(sqrtg)) sqrtg = -1. + else if (present(gcon) .and. present(sqrtg)) then + call interpolate_metric(position,gcov,gcon,sqrtg) + else + call interpolate_metric(position,gcov) + endif +end subroutine get_metric_cartesian + +pure subroutine get_metric_spherical(position,gcov,gcon,sqrtg) + real, intent(in) :: position(3) + real, intent(out) :: gcov(0:3,0:3) + real, intent(out), optional :: gcon(0:3,0:3) + real, intent(out), optional :: sqrtg + real :: r2,sintheta + + gcov = 0. + + r2 = position(1)**2 + sintheta = sin(position(2)) + + gcov(0,0) = -1. + gcov(1,1) = 1. + gcov(2,2) = r2 + gcov(3,3) = r2*sintheta**2 + + if (present(gcon)) then + gcon = 0. + gcon(0,0) = -1. + gcon(1,1) = 1. + gcon(2,2) = 1./r2 + gcov(3,3) = 1./gcov(3,3) + endif + + if (present(sqrtg)) sqrtg = r2*sintheta + +end subroutine get_metric_spherical + +pure subroutine metric_cartesian_derivatives(position,dgcovdx, dgcovdy, dgcovdz) + real, intent(in) :: position(3) + real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3), dgcovdz(0:3,0:3) + !dgcovdx = 0. + dgcovdy = 0. + dgcovdz = 0. +end subroutine metric_cartesian_derivatives + +pure subroutine metric_spherical_derivatives(position,dgcovdr, dgcovdtheta, dgcovdphi) + real, intent(in) :: position(3) + real, intent(out), dimension(0:3,0:3) :: dgcovdr,dgcovdtheta,dgcovdphi + real :: r, theta + + r = position(1) + theta = position(2) + + dgcovdr = 0. + dgcovdtheta = 0. + dgcovdphi = 0. + + dgcovdr(2,2) = 2*r + dgcovdr(3,3) = 2*r*sin(theta)**2 + + dgcovdtheta(3,3) = 2*r**2*cos(theta)*sin(theta) + +end subroutine metric_spherical_derivatives + +pure subroutine cartesian2spherical(xcart,xspher) + real, intent(in) :: xcart(3) + real, intent(out) :: xspher(3) + real :: x,y,z + real :: r,theta,phi + + x = xcart(1) + y = xcart(2) + z = xcart(3) + + r = sqrt(x**2+y**2+z**2) + theta = acos(z/r) + phi = atan2(y,x) + + xspher = (/r,theta,phi/) +end subroutine cartesian2spherical + +!----------------------------------------------------------------------- +!+ +! writes metric options to the input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_metric(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + write(iunit,"(/,a)") '# There are no options relating to the '//trim(metric_type)//' metric' + +end subroutine write_options_metric + +!----------------------------------------------------------------------- +!+ +! reads metric options from the input file +!+ +!----------------------------------------------------------------------- +subroutine read_options_metric(name,valstring,imatch,igotall,ierr) + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer, intent(out) :: ierr + + ! imatch = .true. + ! igotall = .true. + +end subroutine read_options_metric + +!----------------------------------------------------------------------- +!+ +! Interpolates value from grid to position +!+ +!----------------------------------------------------------------------- + +pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) + ! linear and cubic interpolators should be moved to their own subroutine + ! away from eos_shen + use eos_shen, only:linear_interpolator_one_d + use einsteintk_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid + real, intent(in) :: position(3) + real, intent(out) :: gcov(0:3,0:3) + real, intent(out), optional :: gcon(0:3,0:3), sqrtg + integer :: xlower,ylower,zlower,xupper,yupper,zupper + real :: xd,yd,zd + real :: interptmp(7) + integer :: i,j + + ! If the issue is that the metric vals are undefined on + ! Setup since we have not recieved anything about the metric + ! from ET during phantomsetup + ! Then simply set gcov and gcon to 0 + ! as these values will be overwritten during the run anyway + !print*, "Calling interp metric!" + ! Get neighbours + call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) + !print*,"Neighbours: ", xlower,ylower,zlower + xupper = xlower + 1 + yupper = yupper + 1 + zupper = zupper + 1 + xd = (position(1) - xlower)/(xupper - xlower) + yd = (position(2) - ylower)/(yupper - ylower) + zd = (position(3) - zlower)/(zupper - zlower) + + interptmp = 0. + ! All the interpolation should go into an interface, then you should just call trilinear_interp + ! interpolate for gcov + do i=0, 3 + do j=0, 3 + ! Interpolate along x + call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower,zlower), & + gcovgrid(i,j,xlower+1,ylower,zlower),xd,interptmp(1)) + call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower,zlower+1), & + gcovgrid(i,j,xlower+1,ylower,zlower+1),xd,interptmp(2)) + call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower+1,zlower), & + gcovgrid(i,j,xlower+1,ylower+1,zlower),xd,interptmp(3)) + call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower+1,zlower+1), & + gcovgrid(i,j,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + gcov(i,j) = interptmp(7) + enddo + enddo + + if (present(gcon)) then + ! interpolate for gcon + do i=0, 3 + do j=0, 3 + ! Interpolate along x + call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower,zlower), & + gcongrid(i,j,xlower+1,ylower,zlower),xd,interptmp(1)) + call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower,zlower+1), & + gcongrid(i,j,xlower+1,ylower,zlower+1),xd,interptmp(2)) + call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower+1,zlower), & + gcongrid(i,j,xlower+1,ylower+1,zlower),xd,interptmp(3)) + call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower+1,zlower+1), & + gcongrid(i,j,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + gcon(i,j) = interptmp(7) + enddo + enddo + endif + + if (present(sqrtg)) then + ! Interpolate for sqrtg + ! Interpolate along x + call linear_interpolator_one_d(sqrtggrid(xlower,ylower,zlower), & + sqrtggrid(xlower+1,ylower,zlower),xd,interptmp(1)) + call linear_interpolator_one_d(sqrtggrid(xlower,ylower,zlower+1), & + sqrtggrid(xlower+1,ylower,zlower+1),xd,interptmp(2)) + call linear_interpolator_one_d(sqrtggrid(xlower,ylower+1,zlower), & + sqrtggrid(xlower+1,ylower+1,zlower),xd,interptmp(3)) + call linear_interpolator_one_d(sqrtggrid(xlower,ylower+1,zlower+1), & + sqrtggrid(xlower+1,ylower+1,zlower+1),xd,interptmp(4)) + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + sqrtg = interptmp(7) + endif + + +end subroutine interpolate_metric + +subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) + use eos_shen, only:linear_interpolator_one_d + use einsteintk_utils, only:metricderivsgrid, dxgrid + real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3),dgcovdz(0:3,0:3) + real, intent(in) :: position(3) + integer :: xlower,ylower,zlower,xupper,yupper,zupper + real :: xd,yd,zd + real :: interptmp(7) + integer :: i,j + + call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) + !print*,"Neighbours: ", xlower,ylower,zlower + xupper = xlower + 1 + yupper = yupper + 1 + zupper = zupper + 1 + xd = (position(1) - xlower)/(xupper - xlower) + yd = (position(2) - ylower)/(yupper - ylower) + zd = (position(3) - zlower)/(zupper - zlower) + + interptmp = 0. + + ! Interpolate for dx + do i=0, 3 + do j=0, 3 + ! Interpolate along x + call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower,zlower), & + metricderivsgrid(i,j,1,xlower+1,ylower,zlower),xd,interptmp(1)) + call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower,zlower+1), & + metricderivsgrid(i,j,1,xlower+1,ylower,zlower+1),xd,interptmp(2)) + call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower+1,zlower), & + metricderivsgrid(i,j,1,xlower+1,ylower+1,zlower),xd,interptmp(3)) + call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower+1,zlower+1), & + metricderivsgrid(i,j,1,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + dgcovdx(i,j) = interptmp(7) + enddo + enddo + ! Interpolate for dy + do i=0, 3 + do j=0, 3 + ! Interpolate along x + call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower,zlower), & + metricderivsgrid(i,j,2,xlower+1,ylower,zlower),xd,interptmp(1)) + call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower,zlower+1), & + metricderivsgrid(i,j,2,xlower+1,ylower,zlower+1),xd,interptmp(2)) + call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower+1,zlower), & + metricderivsgrid(i,j,2,xlower+1,ylower+1,zlower),xd,interptmp(3)) + call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower+1,zlower+1), & + metricderivsgrid(i,j,2,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + dgcovdy(i,j) = interptmp(7) + enddo + enddo + + ! Interpolate for dz + do i=0, 3 + do j=0, 3 + ! Interpolate along x + call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower,zlower), & + metricderivsgrid(i,j,3,xlower+1,ylower,zlower),xd,interptmp(1)) + call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower,zlower+1), & + metricderivsgrid(i,j,3,xlower+1,ylower,zlower+1),xd,interptmp(2)) + call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower+1,zlower), & + metricderivsgrid(i,j,3,xlower+1,ylower+1,zlower),xd,interptmp(3)) + call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower+1,zlower+1), & + metricderivsgrid(i,j,3,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + dgcovdz(i,j) = interptmp(7) + enddo + enddo + + + + +end subroutine interpolate_metric_derivs + +pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) + use einsteintk_utils, only:gridorigin + real, intent(in) :: position(3) + real, intent(in) :: dx(3) + integer, intent(out) :: xlower,ylower,zlower + + ! Get the lower grid neighbours of the position + ! If this is broken change from floor to int + ! How are we handling the edge case of a particle being + ! in exactly the same position as the grid? + ! Hopefully having different grid sizes in each direction + ! Doesn't break the lininterp + xlower = floor((position(1)-gridorigin(1))/dx(1)) + ylower = floor((position(2)-gridorigin(2))/dx(2)) + zlower = floor((position(3)-gridorigin(3))/dx(3)) + + ! +1 because fortran + xlower = xlower + 1 + ylower = ylower + 1 + zlower = zlower + 1 + + +end subroutine get_grid_neighbours + + +end module metric diff --git a/src/main/metric_flrw.f90 b/src/main/metric_flrw.f90 new file mode 100644 index 000000000..bd3f4a6f1 --- /dev/null +++ b/src/main/metric_flrw.f90 @@ -0,0 +1,239 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.bitbucket.io/ ! +!--------------------------------------------------------------------------! +module metric +! +! None +! +! :References: None +! +! :Owner: David Liptai +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils +! + + +use timestep, only: time +implicit none + character(len=*), parameter :: metric_type = 'flrw' + integer, parameter :: imetric = 5 + +contains + +!---------------------------------------------------------------- +!+ +! Compute the metric tensor in both covariant (gcov) and +! contravariant (gcon) form +!+ +!---------------------------------------------------------------- +pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) + real, intent(in) :: position(3) + real, intent(out) :: gcov(0:3,0:3) + real, intent(out), optional :: gcon(0:3,0:3) + real, intent(out), optional :: sqrtg + real :: a,t + + t = time + gcov = 0. + ! Get the scale factor for the current time + call get_scale_factor(t,a) + gcov(0,0) = -1. + gcov(1,1) = a + gcov(2,2) = a + gcov(3,3) = a + + if (present(gcon)) then + gcon = 0. + gcon(0,0) = -1. + gcon(1,1) = 1./a + gcon(2,2) = 1./a + gcon(3,3) = 1./a + endif + if (present(sqrtg)) sqrtg = a*a*a + +end subroutine get_metric_cartesian + +pure subroutine get_metric_spherical(position,gcov,gcon,sqrtg) + real, intent(in) :: position(3) + real, intent(out) :: gcov(0:3,0:3) + real, intent(out), optional :: gcon(0:3,0:3) + real, intent(out), optional :: sqrtg + real :: r2,sintheta + real :: t,a + + t = time + ! Get the scale factor for the current time + call get_scale_factor(t,a) + + gcov = 0. + + r2 = position(1)**2 + sintheta = sin(position(2)) + + gcov(0,0) = -1. + gcov(1,1) = a + gcov(2,2) = r2*a + gcov(3,3) = a*r2*sintheta**2 + + if (present(gcon)) then + gcon = 0. + gcon(0,0) = -1. + gcon(1,1) = 1./a + gcon(2,2) = 1./(r2*a) + gcov(3,3) = 1./gcov(3,3) + endif + + if (present(sqrtg)) sqrtg = a*a*a + +end subroutine get_metric_spherical + +pure subroutine metric_cartesian_derivatives(position,dgcovdx, dgcovdy, dgcovdz) + real, intent(in) :: position(3) + real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3), dgcovdz(0:3,0:3) + dgcovdx = 1. + dgcovdy = 1. + dgcovdz = 1. +end subroutine metric_cartesian_derivatives + +pure subroutine metric_spherical_derivatives(position,dgcovdr, dgcovdtheta, dgcovdphi) + real, intent(in) :: position(3) + real, intent(out), dimension(0:3,0:3) :: dgcovdr,dgcovdtheta,dgcovdphi + real :: r, theta + real :: t, a + + t = time + ! Get the scale factor for the current time + call get_scale_factor(t,a) + + + r = position(1) + theta = position(2) + + dgcovdr = 0. + dgcovdtheta = 0. + dgcovdphi = 0. + + dgcovdr(2,2) = 2*r*a + dgcovdr(3,3) = 2*r*sin(theta)**2 + + dgcovdtheta(3,3) = 2*a**r**2*cos(theta)*sin(theta) + +end subroutine metric_spherical_derivatives + +pure subroutine cartesian2spherical(xcart,xspher) + real, intent(in) :: xcart(3) + real, intent(out) :: xspher(3) + real :: x,y,z + real :: r,theta,phi + + x = xcart(1) + y = xcart(2) + z = xcart(3) + + r = sqrt(x**2+y**2+z**2) + theta = acos(z/r) + phi = atan2(y,x) + + xspher = (/r,theta,phi/) +end subroutine cartesian2spherical + +pure subroutine spherical2cartesian(xspher,xcart) + real, intent(in) :: xspher(3) + real, intent(out) :: xcart(3) + real :: x,y,z,r,theta,phi + + r = xspher(1) + theta = xspher(2) + phi = xspher(3) + x = r*sin(theta)*cos(phi) + y = r*sin(theta)*sin(phi) + z = r*cos(theta) + + xcart = (/x,y,z/) + +end subroutine spherical2cartesian + +pure subroutine get_jacobian(position,dxdx) + real, intent(in), dimension(3) :: position + real, intent(out), dimension(0:3,0:3) :: dxdx + real, dimension(3) :: dSPHERICALdx,dSPHERICALdy,dSPHERICALdz + real :: drdx,drdy,drdz + real :: dthetadx,dthetady,dthetadz + real :: dphidx,dphidy,dphidz + real :: x,y,z,x2,y2,z2,r2,r,rcyl2,rcyl + x = position(1) + y = position(2) + z = position(3) + x2 = x**2 + y2 = y**2 + z2 = z**2 + r2 = x2+y2+z2 + r = sqrt(r2) + rcyl2 = x2+y2 + rcyl = sqrt(x2+y2) + + drdx = x/r + drdy = y/r + drdz = z/r + + dthetadx = x*z/(r2*rcyl) + dthetady = y*z/(r2*rcyl) + dthetadz = -rcyl/r2 + + dphidx = -y/(x2+y2) + dphidy = x/(x2+y2) + dphidz = 0. + + dSPHERICALdx=(/drdx,dthetadx,dphidx/) + dSPHERICALdy=(/drdy,dthetady,dphidy/) + dSPHERICALdz=(/drdz,dthetadz,dphidz/) + + dxdx = 0. + dxdx(0,0) = 1. + dxdx(1:3,1) = dSPHERICALdx + dxdx(1:3,2) = dSPHERICALdy + dxdx(1:3,3) = dSPHERICALdz +end subroutine get_jacobian + +!----------------------------------------------------------------------- +!+ +! writes metric options to the input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_metric(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + write(iunit,"(/,a)") '# There are no options relating to the '//trim(metric_type)//' metric' + +end subroutine write_options_metric + +!----------------------------------------------------------------------- +!+ +! reads metric options from the input file +!+ +!----------------------------------------------------------------------- +subroutine read_options_metric(name,valstring,imatch,igotall,ierr) + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer, intent(out) :: ierr + + ! imatch = .true. + ! igotall = .true. + +end subroutine read_options_metric + +pure subroutine get_scale_factor(t,a) + real, intent(in) :: t + real, intent(out) :: a + + a = t*(0.5) + 1 + +end subroutine get_scale_factor + +end module metric diff --git a/src/main/part.F90 b/src/main/part.F90 index 8b2f91ace..b2b998e9d 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -150,6 +150,8 @@ module part real, allocatable :: dens(:) !dens(maxgr) real, allocatable :: metrics(:,:,:,:) !metrics(0:3,0:3,2,maxgr) real, allocatable :: metricderivs(:,:,:,:) !metricderivs(0:3,0:3,3,maxgr) + real, allocatable :: tmunus(:,:,:) !tmunus(0:3,0:3,maxgr) + real, allocatable :: sqrtgs(:) ! sqrtg(maxgr) ! !--sink particles ! @@ -450,6 +452,8 @@ subroutine allocate_part call allocate_array('dens', dens, maxgr) call allocate_array('metrics', metrics, 4, 4, 2, maxgr) call allocate_array('metricderivs', metricderivs, 4, 4, 3, maxgr) + call allocate_array('tmunus', tmunus, 4, 4, maxgr) + call allocate_array('sqrtgs', sqrtgs, maxgr) call allocate_array('xyzmh_ptmass', xyzmh_ptmass, nsinkproperties, maxptmass) call allocate_array('vxyz_ptmass', vxyz_ptmass, 3, maxptmass) call allocate_array('fxyz_ptmass', fxyz_ptmass, 4, maxptmass) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 2a57987e0..7aae335fd 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -155,7 +155,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) timei = t hdtsph = 0.5*dtsph dterr = bignumber - + print*, "npart: ", npart ! determine twas for each ibin #ifdef IND_TIMESTEPS if (sts_it_n) then @@ -240,9 +240,13 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call get_timings(t1,tcpu1) #ifdef GR if ((iexternalforce > 0 .and. imetric /= imet_minkowski) .or. idamp > 0) then + print*, "before cons2prim" call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + print*, "after cons2prim" call get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtextforce) + print*, "after get_grforce" call step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,t) + print*, "after step extern" else call step_extern_sph_gr(dtsph,npart,xyzh,vxyzu,dens,pxyzu,metrics) endif @@ -368,6 +372,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif enddo predict_sph !$omp end parallel do + print*, "after predict_sph" if (use_dustgrowth) call check_dustprop(npart,dustproppred(1,:)) ! @@ -379,10 +384,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (npart > 0) then if (gr) vpred = vxyzu ! Need primitive utherm as a guess in cons2prim dt_too_small = .false. + print*, "before derivs" call derivs(1,npart,nactive,xyzh,vpred,fxyzu,fext,divcurlv,& divcurlB,Bpred,dBevol,radpred,drad,radprop,dustproppred,ddustprop,& dustpred,ddustevol,dustfrac,eos_vars,timei,dtsph,dtnew,& ppred,dens,metrics) + print*, "after derivs" if (gr) vxyzu = vpred ! May need primitive variables elsewhere? if (dt_too_small) then ! dt < dtmax/2**nbinmax and exit @@ -582,6 +589,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) enddo corrector !$omp enddo !$omp end parallel +print*, "after corrector" if (use_dustgrowth) call check_dustprop(npart,dustprop(1,:)) if (gr) then @@ -661,7 +669,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) vxyzu = vpred ! May need primitive variables elsewhere? endif enddo iterations - + print*, "after iterations" ! MPI reduce summary variables nwake = int(reduceall_mpi('+', nwake)) nvfloorp = int(reduceall_mpi('+', nvfloorp)) @@ -682,7 +690,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) #ifdef GR call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) #endif - +print*, "after second cons2primall" return end subroutine step @@ -788,7 +796,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me ! if (dtextforce < dtsph) then dt = dtextforce - last_step = .false. + last_step = .true. ! Just to check if things are working else dt = dtsph last_step = .true. @@ -801,7 +809,9 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me nsubsteps = 0 dtextforce_min = huge(dt) done = .false. - + print*, "t_end_step : ", t_end_step + print*, "dtextforce: ", dtextforce + print*, "dtsph: ", dtsph substeps: do while (timei <= t_end_step .and. .not.done) hdt = 0.5*dt timei = timei + dt @@ -813,7 +823,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me if (.not.last_step .and. iverbose > 1 .and. id==master) then write(iprint,"(a,f14.6)") '> external forces only : t=',timei endif - + print*, "before predictor" !--------------------------- ! predictor during substeps !--------------------------- @@ -922,7 +932,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me enddo predictor !$omp enddo !$omp end parallel - +print*, "after predictor" if (iverbose >= 2 .and. id==master) then write(iprint,*) '------ Iterations summary: -------------------------------' write(iprint,"(a,i2,a,f14.6)") 'Most pmom iterations = ',pitsmax,' | max error = ',perrmax @@ -936,7 +946,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me accretedmass = 0. naccreted = 0 dtextforce_min = bignumber - +print*, "before corrector" !$omp parallel default(none) & !$omp shared(npart,xyzh,metrics,metricderivs,vxyzu,fext,iphase,ntypes,massoftype,hdt,timei) & !$omp shared(maxphase,maxp) & @@ -983,7 +993,8 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me enddo accreteloop !$omp enddo !$omp end parallel - +print*, "after corrector" +print*, "time is: ", timei if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a)") & 'Step: at time ',timei,', ',naccreted,' particles were accreted. Mass accreted = ',accretedmass @@ -1001,7 +1012,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me endif enddo substeps - +print*, "outside of substeps" if (nsubsteps > 1) then if (iverbose>=1 .and. id==master) then write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & @@ -1010,7 +1021,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) endif - +print*, "step extern_gr done!" end subroutine step_extern_gr #endif diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 new file mode 100644 index 000000000..4aef9871b --- /dev/null +++ b/src/main/tmunu2grid.f90 @@ -0,0 +1,135 @@ +module tmunu2grid + implicit none + +contains + subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) + use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid + use interpolations3D, only: interpolate3D + use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax + use part, only: massoftype,igas,rhoh + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:), vxyzu(:,:), tmunus(:,:,:) + real :: weight,h,rho,pmass + real :: xmininterp(3) + integer :: ngrid(3) + real,allocatable :: datsmooth(:,:,:), dat(:) + integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper + logical :: normalise + + if (.not. allocated(datsmooth)) allocate (datsmooth(gridsize(1),gridsize(2),gridsize(3))) + if (.not. allocated(dat)) allocate (dat(npart)) + ! All particles have equal weighting in the interp + ! Here we calculate the weight for the first particle + ! Get the smoothing length + h = xyzh(4,1) + ! Get pmass + pmass = massoftype(igas) + ! Get density + rho = rhoh(h,pmass) + + call get_weight(pmass,h,rho,weight) + !print*, "Weighting for particle smoothing is: ", weight + !weight = 1. + ! For now we can set this to the origin, but it might need to be + ! set to the grid origin of the CCTK_grid since we have boundary points + ! TODO This should also be the proper phantom values and not a magic number + !xmin(:) = gridorigin(:) - 0.5*dxgrid(:) ! We move the origin back by 0.5*dx to make a pseudo cell-centered grid + xmininterp(1) = xmin + xmininterp(2) = ymin + xmininterp(3) = zmin + + !print*, "xmin: ", xmin + !print*, "xmax: ", xmax + call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) + call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) + call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) + !print*, "ivals: ", ilower, iupper + ! nnodes is just the size of the mesh + ! might not be needed + ! We note that this is not actually the size of the einstein toolkit grid + ! As we want our periodic boundary to be on the particle domain not the + ! ET grid domain + ngrid(1) = (iupper-ilower) + ngrid(2) = (jupper-jlower) + ngrid(3) = (kupper-klower) + nnodes = (iupper-ilower)*(jupper-jlower)*(kupper-klower) + ! Do we want to normalise interpolations? + normalise = .true. + + + !print*, "ngrid: ", ngrid + + !print*,"tmunu val: ", tmunus(:,:,1) + ! tt component + + tmunugrid = 0. + do k=1,4 + do j=1,4 + do i=1, npart + dat(i) = tmunus(k,j,i) + ! if (dat(i) < 1.0 .and. i > 4) then + ! print*, "dat: ", dat(i) + ! print*, "i is: ", i + ! stop + ! endif + enddo + !print*, "gcov: ", gcovgrid(:,:,1,1,1) + !print*, "tmunugrid: ", tmunugrid(:,:,1,1,1) + ! print*, "k,j :", k, j + ! print*, "Dat: ", dat(1:30) + + ! Get the position of the first grid cell x,y,z + ! print*, "x position of 1, 1, 1", gridorigin(:) + ! print*, "x position of 1,1,1 calculated (cell centered)", xmin(1) + (1.-0.5)*dxgrid(1) + ! Call to interpolate 3D + call interpolate3D(xyzh,weight,npart, & + xmininterp,tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper), & + nnodes,dxgrid,normalise,dat,ngrid) + + !print*, "Interpolated grid values are: ", datsmooth(4:38,4:38,4:38) + enddo + enddo + ! do i=4,35 + ! do j=4,35 + ! do k=4,35 + ! if (tmunugrid(0,0,i,j,k) > 1.0008253314232896) then + ! print*, "tmunugrid: ", tmunugrid(0,0,i,j,k) + ! print*, "i,j,k: ", i,j,k + ! print*, "grid position i : ", gridorigin(1) + i*dxgrid(1) + ! print*, "grid position j : ", gridorigin(2) + j*dxgrid(2) + ! print*, "grid position k : ", gridorigin(3) + k*dxgrid(3) + + ! !stop + ! endif + ! enddo + ! enddo + ! enddo + !print*, "tmunugrid: ", tmunugrid(0,0,5,5,5:35) + !stop + end subroutine get_tmunugrid_all + + subroutine get_weight(pmass,h,rhoi,weight) + real, intent(in) :: pmass,h,rhoi + real, intent(out) :: weight + + weight = (pmass*h**3.)/rhoi + + end subroutine get_weight + + subroutine get_dat(tmunus,dat) + real, intent(in) :: tmunus + real, intent(out) :: dat + + end subroutine get_dat + + subroutine get_particle_domain(gridorigin,xmin,xmax,dxgrid,ilower,iupper) + real, intent(in) :: gridorigin, xmin,xmax, dxgrid + integer, intent(out) :: ilower, iupper + + + ilower = int((xmin - gridorigin)/dxgrid) + 1 ! +1 since our arrays start at 1 not 0 + iupper = int((xmax - gridorigin)/dxgrid) + 1 + + end subroutine get_particle_domain + +end module tmunu2grid \ No newline at end of file diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index b1133194c..5139d3799 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.F90 @@ -18,7 +18,7 @@ module utils_gr ! implicit none - public :: dot_product_gr, get_u0, get_bigv, rho2dens, h2dens, get_geodesic_accel + public :: dot_product_gr, get_u0, get_bigv, rho2dens, h2dens, get_geodesic_accel, get_sqrtg private @@ -156,6 +156,56 @@ subroutine get_geodesic_accel(axyz,npart,vxyz,metrics,metricderivs) end subroutine get_geodesic_accel +subroutine get_sqrtg(gcov, sqrtg) + use metric, only: metric_type + real, intent(in) :: gcov(0:3,0:3) + real, intent(out) :: sqrtg + real :: det + real :: a11,a12,a13,a14 + real :: a21,a22,a23,a24 + real :: a31,a32,a33,a34 + real :: a41,a42,a43,a44 + + + if (metric_type == 'et') then + + a11 = gcov(0,0) + a21 = gcov(1,0) + a31 = gcov(2,0) + a41 = gcov(3,0) + a12 = gcov(0,1) + a22 = gcov(1,1) + a32 = gcov(2,1) + a42 = gcov(3,1) + a13 = gcov(0,2) + a23 = gcov(1,2) + a33 = gcov(2,2) + a43 = gcov(3,2) + a14 = gcov(0,3) + a24 = gcov(1,3) + a34 = gcov(2,3) + a44 = gcov(3,3) + + ! Calculate the determinant + det = a14*a23*a32*a41 - a13*a24*a32*a41 - a14*a22*a33*a41 + a12*a24*a33*a41 + & + a13*a22*a34*a41 - a12*a23*a34*a41 - a14*a23*a31*a42 + a13*a24*a31*a42 + & + a14*a21*a33*a42 - a11*a24*a33*a42 - a13*a21*a34*a42 + a11*a23*a34*a42 + & + a14*a22*a31*a43 - a12*a24*a31*a43 - a14*a21*a32*a43 + a11*a24*a32*a43 + & + a12*a21*a34*a43 - a11*a22*a34*a43 - a13*a22*a31*a44 + a12*a23*a31*a44 + & + a13*a21*a32*a44 - a11*a23*a32*a44 - a12*a21*a33*a44 + a11*a22*a33*a44 + + sqrtg = sqrt(-det) + !print*, "sqrtg: ", sqrtg + !stop + else + ! If we are not using an evolving metric then + ! Sqrtg = 1 + sqrtg = 1. + endif + + +end subroutine get_sqrtg + ! This is not being used at the moment. ! subroutine dens2rho(rho,dens,position,v) ! use metric_tools, only: get_metric diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 new file mode 100644 index 000000000..b6a8a44bf --- /dev/null +++ b/src/utils/einsteintk_utils.f90 @@ -0,0 +1,65 @@ +module einsteintk_utils + implicit none + real, allocatable :: gcovgrid(:,:,:,:,:) + real, allocatable :: gcongrid(:,:,:,:,:) + real, allocatable :: sqrtggrid(:,:,:) + real, allocatable :: tmunugrid(:,:,:,:,:) + real, allocatable :: metricderivsgrid(:,:,:,:,:,:) + real :: dxgrid(3), gridorigin(3), boundsize(3) + integer :: gridsize(3) + logical :: gridinit = .false. + character(len=128) :: logfilestor,evfilestor,dumpfilestor,infilestor +contains + subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) + integer, intent(in) :: nx,ny,nz + real, intent(in) :: dx,dy,dz,originx,originy,originz + !integer, intent(in) :: boundsizex, boundsizey, boundsizez + + gridsize(1) = nx + gridsize(2) = ny + gridsize(3) = nz + + dxgrid(1) = dx + dxgrid(2) = dy + dxgrid(3) = dz + + gridorigin(1) = originx + gridorigin(2) = originy + gridorigin(3) = originz + + ! How mmany grid points is the boundary? + ! boundsize(1) = boundsizex + ! boundsize(2) = boundsizey + ! boundsize(3) = boundsizez + + allocate(gcovgrid(0:3,0:3,nx,ny,nz)) + allocate(gcongrid(0:3,0:3,nx,ny,nz)) + allocate(sqrtggrid(nx,ny,nz)) + + ! Will need to delete this at somepoint + ! For now it is the simplest way + allocate(tmunugrid(0:3,0:3,nx,ny,nz)) + + ! metric derivs are stored in the form + ! mu comp, nu comp, deriv, gridx,gridy,gridz + ! Note that this is only the spatial derivs of + ! the metric and we will need an additional array + ! for time derivs + allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) + + gridinit = .true. + + end subroutine init_etgrid + + subroutine print_etgrid() + ! Subroutine for printing quantities of the ET grid + + print*, "Grid spacing (x,y,z) is : ", dxgrid + print*, "Grid origin (x,y,z) is: ", gridorigin + !print*, "Grid size is: ", sizeof(gcovgrid) + print*, "Covariant metric tensor of the grid is: ", gcovgrid(:,:,1,1,1) + !print*, "Contravariant metric tensor of the grid is: ", gcongrid + !print*, "Negative sqrtg of the grid is: ", sqrtggrid + + end subroutine print_etgrid +end module einsteintk_utils diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 new file mode 100644 index 000000000..fe494d54a --- /dev/null +++ b/src/utils/einsteintk_wrapper.f90 @@ -0,0 +1,130 @@ +module einsteintk_wrapper +! +! +! This module is a "wrapper" for the hydro evol + communication with ET +! Subroutines here should be called by ET rather than calling phantom subroutines +! directly +! + implicit none + contains + + subroutine init_et2phantom(infilestart,dt_et) + ! Wrapper that intialises phantom + ! Intended to hide all of the inner works of phantom from ET + ! Majority of the code from HelloHydro_init has been moved here + + use io, only:id,master,nprocs,set_io_unit_numbers,die + use mpiutils, only:init_mpi,finalise_mpi + use initial, only:initialise,finalise,startrun,endrun + use evolve, only:evol_init + use tmunu2grid + use einsteintk_utils + + + implicit none + character(len=*), intent(in) :: infilestart + real, intent(in) :: dt_et + !character(len=500) :: logfile,evfile,dumpfile,path + integer :: i,j,k,pathstringlength + + ! For now we just hardcode the infile, to see if startrun actually works! + ! I'm not sure what the best way to actually do this is? + ! Do we store the phantom.in file in par and have it read from there? + !infile = "/Users/spencer/phantomET/phantom/test/flrw.in" + !infile = trim(infile)//'.in' + !print*, "phantom_path: ", phantom_path + !infile = phantom_path // "flrw.in" + !infile = trim(path) // "flrw.in" + !infile = 'flrw.in' + !infile = trim(infile) + !print*, "Phantom path is: ", path + !print*, "Infile is: ", infile + ! Use system call to copy phantom files to simulation directory + ! This is a digusting temporary fix + !call SYSTEM('cp ~/phantomET/phantom/test/flrw* ./') + + ! The infile from ET + infilestor = infilestart + + ! We should do everything that is done in phantom.f90 + + ! Setup mpi + id=0 + call init_mpi(id,nprocs) + ! setup io + call set_io_unit_numbers + ! routine that starts a phantom run + print*, "Start run called!" + ! Do we want to pass dt in here?? + call startrun(infilestor,logfilestor,evfilestor,dumpfilestor) + print*, "Start run finished!" + print*, "tmunugrid: ", tmunugrid(1,1,6,6,6) + !stop + ! Intialises values for the evol routine: t, dt, etc.. + call evol_init(infilestor,logfilestor,evfilestor,dumpfilestor,dt_et) + print*, "Evolve init finished!" + ! Calculate the stress energy tensor for each particle + ! Might be better to do this in evolve init + !call get_tmunugrid_all + + + end subroutine init_et2phantom + + subroutine init_et2phantomgrid(nx,ny,nz,originx,originy,originz,dx,dy,dz) + use einsteintk_utils + integer, intent(in) :: nx,ny,nz ! The maximum values of the grid in each dimension + real(8), intent(in) :: originx, originy, originz ! The origin of grid + real(8), intent(in) :: dx, dy, dz ! Grid spacing in each dimension + !integer, intent(in) :: boundsizex, boundsizey, boundsizez + + ! Setup metric grid + call init_etgrid(nx,ny,nz,originx,originy,originz,dx,dy,dz) + + end subroutine init_et2phantomgrid + + subroutine init_phantom2et() + ! Subroutine + end subroutine init_phantom2et + + subroutine et2phantom(rho,nx,ny,nz) + integer, intent(in) :: nx, ny, nz + real, intent(in) :: rho(nx,ny,nz) + + print*, "Grid limits: ", nx, ny, nz + print*, "rho 1-10: ", rho(1:10,1,1) + ! get mpi thread number + ! send grid limits + end subroutine et2phantom + + subroutine step_et2phantom(infile,dt_et) + use einsteintk_utils + use evolve, only:evol_step + use tmunu2grid + character(len=*), intent(in) :: infile + real, intent(inout) :: dt_et + character(len=500) :: logfile,evfile,dumpfile,path + + + ! Print the values of logfile, evfile, dumpfile to check they are sensible + !print*, "logfile, evfile, dumpfile: ", logfile, evfile, dumpfile + print*, "stored values of logfile, evfile, dumpfile: ", logfilestor, evfilestor, dumpfilestor + + ! Interpolation stuff + ! Call et2phantom (construct global grid, metric, metric derivs, determinant) + ! Run phantom for a step + call evol_step(infile,logfilestor,evfilestor,dumpfilestor,dt_et) + ! Interpolation stuff back to et + !call get_tmunugrid_all() + ! call phantom2et (Tmunu_grid) + + end subroutine step_et2phantom + + subroutine phantom2et() + ! should take in the cctk_array for tmunu?? + ! Is it better if this routine is just + ! Calculate stress energy tensor for each particle + + ! Perform kernel interpolation from particles to grid positions + + end subroutine phantom2et +end module einsteintk_wrapper diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 new file mode 100644 index 000000000..b24cc8dab --- /dev/null +++ b/src/utils/interpolate3D.F90 @@ -0,0 +1,320 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.bitbucket.io/ ! +!--------------------------------------------------------------------------! +module interpolations3D +! +! Module containing routine for interpolation from PHANTOM data +! to 3D adaptive mesh +! +! Requires adaptivemesh.f90 module +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: adaptivemesh +! + + implicit none + real, parameter, private :: dpi = 1./3.1415926536d0 + public :: interpolate3D +!$ integer(kind=8), dimension(:), private, allocatable :: ilock + +contains +!-------------------------------------------------------------------------- +! subroutine to interpolate from particle data to even grid of pixels +! +! The data is interpolated according to the formula +! +! datsmooth(pixel) = sum_b weight_b dat_b W(r-r_b, h_b) +! +! where _b is the quantity at the neighbouring particle b and +! W is the smoothing kernel, for which we use the usual cubic spline. +! +! For a standard SPH smoothing the weight function for each particle should be +! +! weight = pmass/(rho*h^3) +! +! this version is written for slices through a rectangular volume, ie. +! assumes a uniform pixel size in x,y, whilst the number of pixels +! in the z direction can be set to the number of cross-section slices. +! +! Input: particle coordinates and h : xyzh(4,npart) +! weight for each particle : weight [ same on all parts in PHANTOM ] +! scalar data to smooth : dat (npart) +! +! Output: smoothed data : datsmooth (npixx,npixy,npixz) +! +! Daniel Price, Monash University 2010 +! daniel.price@monash.edu +!-------------------------------------------------------------------------- + +subroutine interpolate3D(xyzh,weight,npart, & + xmin,datsmooth,nnodes,dxgrid,normalise,dat,ngrid) + !use adaptivemesh, only:ifirstlevel,nsub,ndim,gridnodes + integer, intent(in) :: npart,nnodes,ngrid(3) + real, intent(in) :: xyzh(:,:)! ,vxyzu(:,:) + real, intent(in) :: weight !,pmass + real, intent(in) :: xmin(3),dxgrid(3) + real, intent(out) :: datsmooth(:,:,:) + logical, intent(in) :: normalise + real, intent(in), optional :: dat(:) + real, allocatable :: datnorm(:,:,:) +! real, dimension(nsub**ndim,nnodes) :: datnorm + integer, parameter :: ndim = 3, nsub=1 + integer :: i,ipix,jpix,kpix,isubmesh,imesh,level,icell + integer :: iprintinterval,iprintnext + integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax + integer :: ipixi,jpixi,kpixi,npixx,npixy,npixz + real :: xi,yi,zi,hi,hi1,hi21,radkern,qq,wab,q2,const,dyz2,dz2 + real :: xorigi,yorigi,zorigi,xpix,ypix,zpix,dx,dy,dz + real :: dxcell(ndim),xminnew(ndim), dxmax(ndim) + real :: t_start,t_end + real :: termnorm + real :: term + real :: dfac + logical :: iprintprogress +!$ integer :: omp_get_num_threads,j +#ifndef _OPENMP + integer(kind=8) :: iprogress +#endif + + datsmooth = 0. + dxmax(:) = dxgrid(:) + !datnorm = 0. + if (normalise) then + print "(1x,a)",'interpolating from particles to Einstein toolkit grid (normalised) ...' + else + print "(1x,a)",'interpolating from particles to Einstein toolkit grid (non-normalised) ...' + endif +! if (any(dxmax(:) <= 0.)) then +! print "(1x,a)",'interpolate3D: error: grid size <= 0' +! return +! endif +! if (ilendat /= 0) then +! print "(1x,a)",'interpolate3D: error in interface: dat has non-zero length but is not present' +! return +! endif + if (normalise) then + allocate(datnorm(ngrid(1),ngrid(2),ngrid(3))) + datnorm = 0. + endif + +!$ allocate(ilock(0:nnodes)) +!$ do i=0,nnodes +!$ call omp_init_lock(ilock(i)) +!$ enddo + + ! + !--print a progress report if it is going to take a long time + ! (a "long time" is, however, somewhat system dependent) + ! + iprintprogress = (npart >= 100000) .or. (nnodes > 10000) + ! + !--loop over particles + ! + iprintinterval = 25 + if (npart >= 1e6) iprintinterval = 10 + iprintnext = iprintinterval + ! + !--get starting CPU time + ! + call cpu_time(t_start) + + imesh = 1 + level = 1 + dxcell(:) = dxgrid(:)/real(nsub**level) +! xminpix(:) = xmin(:) - 0.5*dxcell(:) + npixx = ngrid(1) + npixy = ngrid(2) + npixz = ngrid(3) + print "(3(a,i4))",' root grid: ',npixx,' x ',npixy,' x ',npixz + print*, "position of i cell 4 is: ", 4*dxcell(1) + xmin(1) + + const = dpi ! kernel normalisation constant (3D) + ! + !--loop over particles + ! + !$omp parallel default(none) & + !$omp shared(npart,xyzh,dat,datsmooth,datnorm) & + !$omp firstprivate(const,weight) & + !$omp firstprivate(xmin,imesh,nnodes,level) & + !$omp firstprivate(npixx,npixy,npixz,dxmax,dxcell,normalise) & + !$omp private(i,j,hi,hi1,hi21,radkern,termnorm,term) & + !$omp private(xpix,ypix,zpix,dx,dy,dz,dz2,dyz2,qq,q2,wab) & + !$omp private(xi,yi,zi,xorigi,yorigi,zorigi,xminnew) & + !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi,icell,isubmesh) & + !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) + !$omp master +!$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' + !$omp end master + !$omp do schedule(guided,10) + over_parts: do i=1,npart + ! + !--report on progress + ! +#ifndef _OPENMP + if (iprintprogress) then + iprogress = nint(100.*i/npart) + if (iprogress >= iprintnext) then + write(*,"('(',i3,'% -',i12,' particles done)')") iprogress,i + iprintnext = iprintnext + iprintinterval + endif + endif +#endif + ! + !--set kernel related quantities + ! + xi = xyzh(1,i); xorigi = xi + yi = xyzh(2,i); yorigi = yi + zi = xyzh(3,i); zorigi = zi + hi = xyzh(4,i) + if (hi <= 0.) cycle over_parts + hi1 = 1./hi; hi21 = hi1*hi1 + termnorm = const*weight + + radkern = 2.*hi ! radius of the smoothing kernel + term = termnorm*dat(i) ! weight for density calculation + ! I don't understand why this doesnt involve any actual smoothing? + !dfac = hi**3/(dxcell(1)*dxcell(2)*dxcell(3)*const) + ! + !--for each particle work out which pixels it contributes to + ! + ipixmin = int((xi - radkern - xmin(1))/dxcell(1)) + jpixmin = int((yi - radkern - xmin(2))/dxcell(2)) + kpixmin = int((zi - radkern - xmin(3))/dxcell(3)) + + ipixmax = int((xi + radkern - xmin(1))/dxcell(1)) + 1 + jpixmax = int((yi + radkern - xmin(2))/dxcell(2)) + 1 + kpixmax = int((zi + radkern - xmin(3))/dxcell(3)) + 1 + !if (ipixmin == 4 .and. jpixmin == 30 .and. kpixmin == 33) print*, "particle (min): ", i + !if (ipixmax == 4 .and. jpixmax == 30 .and. kpixmax == 33) print*, "particle (max): ", i +#ifndef PERIODIC + if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute + if (jpixmin < 1) jpixmin = 1 ! to pixels in the image + if (kpixmin < 1) kpixmin = 1 + if (ipixmax > npixx) ipixmax = npixx + if (jpixmax > npixy) jpixmax = npixy + if (kpixmax > npixz) kpixmax = npixz +#endif + !print*,' part ',i,' lims = ',ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax + ! + !--loop over pixels, adding the contribution from this particle + ! (note that we handle the periodic boundary conditions + ! entirely on the root grid) + ! + do kpix = kpixmin,kpixmax + kpixi = kpix +#ifdef PERIODIC + if (kpixi < 1) then + kpixi = kpixi + npixz + zi = zorigi + dxmax(3) + elseif (kpixi > npixz) then + kpixi = kpixi - npixz + zi = zorigi - dxmax(3) + else + zi = zorigi + endif +#endif + zpix = xmin(3) + (kpixi-0.5)*dxcell(3) + dz = zpix - zi + dz2 = dz*dz*hi21 + + do jpix = jpixmin,jpixmax + jpixi = jpix +#ifdef PERIODIC + if (jpixi < 1) then + jpixi = jpixi + npixy + yi = yorigi + dxmax(2) + elseif (jpixi > npixy) then + jpixi = jpixi - npixy + yi = yorigi - dxmax(2) + else + yi = yorigi + endif +#endif + ypix = xmin(2) + (jpixi-0.5)*dxcell(2) + dy = ypix - yi + dyz2 = dy*dy*hi21 + dz2 + + do ipix = ipixmin,ipixmax + ipixi = ipix +#ifdef PERIODIC + if (ipixi < 1) then + ipixi = ipixi + npixx + xi = xorigi + dxmax(1) + elseif (ipixi > npixx) then + ipixi = ipixi - npixx + xi = xorigi - dxmax(1) + else + xi = xorigi + endif +#endif + icell = ((kpixi-1)*nsub + (jpixi-1))*nsub + ipixi + ! + !--particle interpolates directly onto the root grid + ! + !print*,'onto root grid ',ipixi,jpixi,kpixi + xpix = xmin(1) + (ipixi-0.5)*dxcell(1) + !xpix = xmin(1) + (ipixi-1)*dxcell(1) ! Since we are vertex centered from Et + dx = xpix - xi + q2 = dx*dx*hi21 + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 + ! + !--SPH kernel - standard cubic spline + ! + if (q2 < 4.0) then + if (q2 < 1.0) then + qq = sqrt(q2) + wab = 1.-1.5*q2 + 0.75*q2*qq + else + qq = sqrt(q2) + wab = 0.25*(2.-qq)**3 + endif + ! + !--calculate data value at this pixel using the summation interpolant + ! + ! Change this to the access the pixel coords x,y,z + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + + !if (ipixi==1 .and. jpixi==1 .and. kpixi==1) print*, "x position of 1,1,1", xi,yi,zi + if (normalise) then + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + endif + endif + enddo + enddo + enddo + enddo over_parts + !$omp enddo + !$omp end parallel + +!$ do i=0,nnodes +!$ call omp_destroy_lock(ilock(i)) +!$ enddo +!$ if (allocated(ilock)) deallocate(ilock) + + ! + !--normalise dat array + ! + if (normalise) then + where (datnorm > tiny(datnorm)) + datsmooth = datsmooth/datnorm + end where +endif + if (allocated(datnorm)) deallocate(datnorm) + ! + !--get ending CPU time + ! + call cpu_time(t_end) + print*,'completed in ',t_end-t_start,'s' + + return + +end subroutine interpolate3D + +end module interpolations3D From fdf8fd360f5740598073f9b3b6fb2e7cc6e75e75 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Mon, 20 Jun 2022 16:04:23 +1000 Subject: [PATCH 012/814] Fixed errors in evolve routine --- src/main/evolve.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index a7ee4c7b6..95862650a 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -35,7 +35,7 @@ module evolve use options, only:nfulldump,twallmax,nmaxdumps,rhofinal1,iexternalforce,rkill use timing, only:get_timings,print_time,timer,reset_timer,increment_timer,& setup_timers,timers,reduce_timers,itimer_fromstart,itimer_lastdump,itimer_step,itimer_ev,& - itimer_dens,itimer_force,itimer_link,itimer_balance,itimer_extf,itimer_io + itimer_dens,itimer_force,itimer_link,itimer_balance,itimer_extf,itimer_io, ntimers use checkconserved, only:etot_in,angtot_in,totmom_in,mdust_in,& init_conservation_checks,check_conservation_error @@ -701,9 +701,10 @@ subroutine evol(infile,logfile,evfile,dumpfile) #endif logical :: fulldump,abortrun,at_dump_time,writedump - integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold + integer :: i,j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold real, parameter :: xor(3)=0. + tprint = 0. nsteps = 0 nsteplast = 0 From 8ebd5b5825e1ffd13b38f3c037cec72e8ffb4653 Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Thu, 9 Feb 2023 15:03:13 +1100 Subject: [PATCH 013/814] porosity --- build/Makefile | 2 +- src/main/config.F90 | 2 +- src/main/deriv.F90 | 23 +- src/main/dust.F90 | 8 + src/main/force.F90 | 94 ++- src/main/growth.F90 | 172 +++- src/main/initial.F90 | 13 +- src/main/options.f90 | 2 +- src/main/part.F90 | 69 +- src/main/porosity.f90 | 790 +++++++++++++++++++ src/main/readwrite_dumps_common.F90 | 2 +- src/main/readwrite_dumps_fortran.F90 | 22 +- src/main/readwrite_infile.F90 | 18 +- src/main/step_leapfrog.F90 | 53 +- src/main/utils_dumpfiles_hdf5.f90 | 6 +- src/main/writeheader.F90 | 3 +- src/setup/set_dust_options.f90 | 15 +- src/setup/setup_disc.f90 | 12 +- src/tests/test_dust.F90 | 13 + src/tests/test_growth.F90 | 20 +- src/utils/moddump_dustadd.f90 | 101 ++- src/utils/moddump_removeparticles_radius.f90 | 34 +- 22 files changed, 1327 insertions(+), 147 deletions(-) create mode 100755 src/main/porosity.f90 diff --git a/build/Makefile b/build/Makefile index 455c7a6c0..93ac2073e 100644 --- a/build/Makefile +++ b/build/Makefile @@ -99,7 +99,7 @@ ifndef SRCNIMHD endif ifndef SRCDUST - SRCDUST = dust.F90 growth.F90 + SRCDUST = dust.F90 growth.F90 porosity.f90 endif ifdef SMOL diff --git a/src/main/config.F90 b/src/main/config.F90 index 517ff5439..9e3111f10 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -137,7 +137,7 @@ module dim ! xpartveci integer, parameter :: maxxpartvecidens = 14 + radenxpartvetden - integer, parameter :: maxxpartvecvars = 57 ! Number of scalars in xpartvec + integer, parameter :: maxxpartvecvars = 58 ! Number of scalars in xpartvec integer, parameter :: maxxpartvecarrs = 2 ! Number of arrays in xpartvec integer, parameter :: maxxpartvecGR = 33 ! Number of GR values in xpartvec (1 for dens, 16 for gcov, 16 for gcon) integer, parameter :: maxxpartveciforce = maxxpartvecvars + & ! Total number of values diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index b96d14808..8d87f535b 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -37,7 +37,7 @@ module deriv !------------------------------------------------------------- subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,& - dustevol,ddustevol,dustfrac,eos_vars,time,dt,dtnew,pxyzu,dens,metrics) + dustevol,ddustevol,filfac,dustfrac,eos_vars,time,dt,dtnew,pxyzu,dens,metrics) use dim, only:maxvxyzu,mhd,fast_divcurlB,gr use io, only:iprint,fatal use linklist, only:set_linklist @@ -61,7 +61,9 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& #endif #ifdef DUSTGROWTH use growth, only:get_growth_rate + use porosity, only:get_disruption,get_probastick use part, only:VrelVf + use options, only:use_porosity #endif #if defined(SINK_RADIATION) && !defined(ISOTHERMAL) use ptmass_radiation, only:get_dust_temperature_from_ptmass @@ -96,6 +98,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& real, intent(inout) :: dustprop(:,:) real, intent(out) :: dustfrac(:,:) real, intent(out) :: ddustevol(:,:),ddustprop(:,:) + real, intent(inout) :: filfac(:) real, intent(in) :: time,dt real, intent(out) :: dtnew real, intent(inout) :: pxyzu(:,:), dens(:) @@ -148,6 +151,14 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& ! call photo_ionize(vxyzu,npart) #endif + +#ifdef DUSTGROWTH + ! + ! compute disruption of dust particles + ! + if (use_porosity) call get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) +#endif + ! ! calculate density by direct summation ! @@ -188,7 +199,9 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& #ifdef DUSTGROWTH ! compute growth rate of dust particles - call get_growth_rate(npart,xyzh,vxyzu,dustgasprop,VrelVf,dustprop,ddustprop(1,:))!--we only get ds/dt (i.e 1st dimension of ddustprop) + call get_growth_rate(npart,xyzh,vxyzu,dustgasprop,VrelVf,dustprop,filfac,ddustprop(1,:))!--we only get dm/dt (i.e 1st dimension of ddustprop) + ! compute growth rate and probability of sticking/bouncing of porous dust + if (use_porosity) call get_probastick(npart,xyzh,ddustprop(1,:),dustprop,dustgasprop,filfac) #endif #if defined(SINK_RADIATION) && !defined(ISOTHERMAL) @@ -224,7 +237,7 @@ end subroutine derivs !-------------------------------------- subroutine get_derivs_global(tused,dt_new) use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& - Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,& + Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,filfac,& dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol use timing, only:printused,getused use io, only:id,master @@ -238,8 +251,8 @@ subroutine get_derivs_global(tused,dt_new) dt = 0. call getused(t1) call derivs(1,npart,npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,Bevol,dBevol,& - rad,drad,radprop,dustprop,ddustprop,dustevol,ddustevol,dustfrac,eos_vars,& - time,dt,dtnew,pxyzu,dens,metrics) + rad,drad,radprop,dustprop,ddustprop,dustevol,ddustevol,filfac,dustfrac,& + eos_vars,time,dt,dtnew,pxyzu,dens,metrics) call getused(t2) if (id==master .and. present(tused)) call printused(t1) if (present(tused)) tused = t2 - t1 diff --git a/src/main/dust.F90 b/src/main/dust.F90 index f0c05bcac..ef8822895 100644 --- a/src/main/dust.F90 +++ b/src/main/dust.F90 @@ -46,6 +46,7 @@ module dust public :: print_dustinfo public :: write_options_dust public :: read_options_dust + public :: get_viscmol_nu real, private :: cste_mu,coeff_gei_1,seff private @@ -415,4 +416,11 @@ subroutine read_options_dust(name,valstring,imatch,igotall,ierr) end subroutine read_options_dust +real function get_viscmol_nu(spsoundgas,rhogas) + real,intent(in) :: spsoundgas,rhogas + + get_viscmol_nu = cste_mu*seff*spsoundgas/rhogas + +end function get_viscmol_nu + end module dust diff --git a/src/main/force.F90 b/src/main/force.F90 index 3aba954a9..25fb81f3e 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -106,18 +106,19 @@ module forces icurlBxi = 42, & icurlByi = 43, & icurlBzi = 44, & - igrainsizei = 45, & + igrainmassi = 45, & igraindensi = 46, & - idvxdxi = 47, & - idvzdzi = 55, & + ifilfaci = 47, & + idvxdxi = 48, & + idvzdzi = 56, & !--dust arrays initial index - idustfraci = 56, & + idustfraci = 57, & !--dust arrays final index - idustfraciend = 56 + (maxdusttypes - 1), & - itstop = 57 + (maxdusttypes - 1), & - itstopend = 57 + 2*(maxdusttypes - 1), & + idustfraciend = 57 + (maxdusttypes - 1), & + itstop = 58 + (maxdusttypes - 1), & + itstopend = 58 + 2*(maxdusttypes - 1), & !--final dust index - lastxpvdust = 57 + 2*(maxdusttypes - 1), & + lastxpvdust = 58 + 2*(maxdusttypes - 1), & iradxii = lastxpvdust + 1, & iradfxi = lastxpvdust + 2, & iradfyi = lastxpvdust + 3, & @@ -184,7 +185,8 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& 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 + hrho,iphase,igas,maxgradh,dvdx,eta_nimhd,deltav,poten,iamtype,& + dragreg,filfac use timestep, only:dtcourant,dtforce,dtrad,bignumber,dtdiff use io_summary, only:summary_variable, & iosumdtf,iosumdtd,iosumdtv,iosumdtc,iosumdto,iosumdth,iosumdta, & @@ -372,6 +374,8 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& !$omp shared(ncells,ifirstincell) & !$omp shared(xyzh) & !$omp shared(dustprop) & +!$omp shared(dragreg) & +!$omp shared(filfac) & !$omp shared(dustgasprop) & !$omp shared(vxyzu) & !$omp shared(fxyzu) & @@ -479,7 +483,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& stack_waiting%cells(cell%waiting_index) = cell else call finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dvdx,& - divBsymm,divcurlv,dBevol,ddustevol,deltav,dustgasprop, & + divBsymm,divcurlv,dBevol,ddustevol,deltav,dustgasprop,dragreg,filfac,& dtcourant,dtforce,dtvisc,dtohm,dthall,dtambi,dtdiff,dtmini,dtmaxi, & #ifdef IND_TIMESTEPS nbinmaxnew,nbinmaxstsnew,ncheckbin, & @@ -554,7 +558,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& cell = stack_waiting%cells(i) call finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dvdx, & - divBsymm,divcurlv,dBevol,ddustevol,deltav,dustgasprop, & + divBsymm,divcurlv,dBevol,ddustevol,deltav,dustgasprop,dragreg,filfac,& dtcourant,dtforce,dtvisc,dtohm,dthall,dtambi,dtdiff,dtmini,dtmaxi, & #ifdef IND_TIMESTEPS nbinmaxnew,nbinmaxstsnew,ncheckbin, & @@ -842,6 +846,9 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g use dust, only:get_ts,idrag,icut_backreaction,ilimitdustflux,irecon use kernel, only:wkern_drag,cnormk_drag use part, only:ndustsmall,grainsize,graindens + use part, only:ndustsmall,grainsize,graindens,filfac + use options, only:use_porosity + use growth, only:get_size #ifdef DUSTGROWTH use growth, only:wbymass use kernel, only:wkern,cnormk @@ -940,7 +947,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g real :: pri,pro2i real :: etaohmi,etahalli,etaambii real :: jcbcbi(3),jcbi(3) - real :: alphai,grainsizei,graindensi + real :: alphai,grainmassi,graindensi,filfaci logical :: usej integer :: iamtypei real :: radFi(3),radFj(3),radRj,radDFWi,radDFWj,c_code,radkappai,radkappaj,& @@ -1003,8 +1010,9 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g endif if (use_dustgrowth) then - grainsizei = xpartveci(igrainsizei) + grainmassi = xpartveci(igrainmassi) graindensi = xpartveci(igraindensi) + filfaci = xpartveci(ifilfaci) endif dvdxi(1:9) = xpartveci(idvxdxi:idvzdzi) @@ -1673,7 +1681,13 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g do l=1,ndustsmall ! get stopping time - for one fluid dust we do not know deltav, but it is small by definition if (use_dustgrowth) then !- only work for ndustsmall=1 though - call get_ts(idrag,l,grainsizei,graindensi,rhogasj,rhoj*dustfracjsum,spsoundj,0.,tsj(l),iregime) + if (use_porosity) then + call get_ts(idrag,l,get_size(grainmassi,graindensi,filfaci),& + graindensi*filfaci,rhogasj,rhoj*dustfracjsum,spsoundj,0.,tsj(l),iregime) + else + call get_ts(idrag,l,get_size(grainmassi,graindensi),& + graindensi,rhogasj,rhoj*dustfracjsum,spsoundj,0.,tsj(l),iregime) + endif else call get_ts(idrag,l,grainsize(l),graindens(l),rhogasj,rhoj*dustfracjsum,spsoundj,0.,tsj(l),iregime) endif @@ -1742,7 +1756,13 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g wdrag = wkern_drag(q2j,qj)*hj21*hj1*cnormk_drag endif if (use_dustgrowth) then - call get_ts(idrag,1,dustprop(1,j),dustprop(2,j),rhoi,rhoj,spsoundi,dv2,tsijtmp,iregime) + if (use_porosity) then + call get_ts(idrag,1,get_size(dustprop(1,j),dustprop(2,j),filfac(j)),& + dustprop(2,j)*filfac(j),rhoi,rhoj,spsoundi,dv2,tsijtmp,iregime) + else + call get_ts(idrag,1,get_size(dustprop(1,j),dustprop(2,j)),& + dustprop(2,j),rhoi,rhoj,spsoundi,dv2,tsijtmp,iregime) + endif else !--the following works for large grains only (not hybrid large and small grains) idusttype = iamtypej - idust + 1 @@ -1771,7 +1791,12 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g wdrag = wkern_drag(q2j,qj)*hj21*hj1*cnormk_drag endif if (use_dustgrowth) then - call get_ts(idrag,1,grainsizei,graindensi,rhoj,rhoi,spsoundj,dv2,tsijtmp,iregime) + if (use_porosity) then + call get_ts(idrag,1,get_size(grainmassi,graindensi,filfaci),& + graindensi*filfaci,rhoj,rhoi,spsoundj,dv2,tsijtmp,iregime) + else + call get_ts(idrag,1,get_size(grainmassi,graindensi),graindensi,rhoj,rhoi,spsoundj,dv2,tsijtmp,iregime) + endif #ifdef DUSTGROWTH if (q2i < q2j) then winter = wkern(q2i,qi)*hi21*hi1*cnormk @@ -1959,7 +1984,9 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, use viscosity, only:irealvisc,bulkvisc #ifdef DUST use dust, only:get_ts,idrag - use part, only:grainsize,graindens + use options, only:use_porosity + use part, only:grainsize,graindens,filfac + use growth, only:get_size #endif use nicil, only:nimhd_get_jcbcb use radiation_utils, only:get_rad_R @@ -2106,7 +2133,13 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, tstopi = 0. do j=1,ndustsmall if (use_dustgrowth) then - call get_ts(idrag,j,dustprop(1,i),dustprop(2,i),rhogasi,rhoi*dustfracisum,spsoundi,0.,tstopi(j),iregime) + if (use_porosity) then + call get_ts(idrag,j,get_size(dustprop(1,i),dustprop(2,i),filfac(j)),& + dustprop(2,i)*filfac(j),rhogasi,rhoi*dustfracisum,spsoundi,0.,tstopi(j),iregime) + else + call get_ts(idrag,j,get_size(dustprop(1,i),dustprop(2,i)),& + dustprop(2,i),rhogasi,rhoi*dustfracisum,spsoundi,0.,tstopi(j),iregime) + endif else call get_ts(idrag,j,grainsize(j),graindens(j),rhogasi,rhoi*dustfracisum,spsoundi,0.,tstopi(j),iregime) endif @@ -2234,8 +2267,9 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, endif #ifdef DUSTGROWTH - cell%xpartvec(igrainsizei,cell%npcell) = dustprop(1,i) + cell%xpartvec(igrainmassi,cell%npcell) = dustprop(1,i) cell%xpartvec(igraindensi,cell%npcell) = dustprop(2,i) + cell%xpartvec(ifilfaci,cell%npcell) = filfac(i) #endif cell%xpartvec(idvxdxi:idvzdzi,cell%npcell) = dvdx(1:9,i) @@ -2354,7 +2388,7 @@ subroutine compute_cell(cell,listneigh,nneigh,Bevol,xyzh,vxyzu,fxyzu, & end subroutine compute_cell subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dvdx,& - divBsymm,divcurlv,dBevol,ddustevol,deltav,dustgasprop, & + divBsymm,divcurlv,dBevol,ddustevol,deltav,dustgasprop,dragreg,filfac,& dtcourant,dtforce,dtvisc,dtohm,dthall,dtambi,dtdiff,dtmini,dtmaxi, & #ifdef IND_TIMESTEPS nbinmaxnew,nbinmaxstsnew,ncheckbin, & @@ -2406,8 +2440,10 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv use utils_gr, only:get_u0 use io, only:error #ifdef DUSTGROWTH - use growth, only:wbymass + use growth, only:wbymass,get_size use dust, only:idrag,get_ts + use physcon, only:fourpi + use options, only:use_porosity use part, only:Omega_k #endif use io, only:warning @@ -2429,6 +2465,8 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv real, intent(out) :: ddustevol(:,:) real, intent(out) :: deltav(:,:,:) real, intent(out) :: dustgasprop(:,:) + real, intent(in) :: filfac(:) + integer, intent(out) :: dragreg(:) real, intent(inout) :: dtcourant,dtforce,dtvisc real, intent(inout) :: dtohm,dthall,dtambi,dtdiff,dtmini,dtmaxi #ifdef IND_TIMESTEPS @@ -2476,7 +2514,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv character(len=16) :: dtchar #endif #ifdef DUSTGROWTH - real :: tstopint,gsizei,gdensi + real :: tstopint,gmassi,gdensi integer :: ireg #endif integer :: ip,i @@ -2859,9 +2897,15 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv !- get the Stokes number with get_ts using the interpolated quantities rhoi = xpartveci(irhoi) gdensi = xpartveci(igraindensi) - gsizei = xpartveci(igrainsizei) - call get_ts(idrag,1,gsizei,gdensi,dustgasprop(2,i),rhoi,dustgasprop(1,i),& - dustgasprop(4,i)**2,tstopint,ireg) + gmassi = xpartveci(igrainmassi) + if (use_porosity) then + call get_ts(idrag,1,get_size(gmassi,gdensi,filfac(i)),gdensi*filfac(i),& + dustgasprop(2,i),rhoi,dustgasprop(1,i),dustgasprop(4,i)**2,tstopint,ireg) + dragreg(i) = ireg + else + call get_ts(idrag,1,get_size(gmassi,gdensi),gdensi,& + dustgasprop(2,i),rhoi,dustgasprop(1,i),dustgasprop(4,i)**2,tstopint,ireg) + endif dustgasprop(3,i) = tstopint * Omega_k(i) !- Stokes number endif #endif diff --git a/src/main/growth.F90 b/src/main/growth.F90 index f02a0c596..f6444202a 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -53,6 +53,7 @@ module growth real, public :: vfragin real, public :: vfragout real, public :: grainsizemin + real, public :: stmin logical, public :: wbymass = .true. @@ -65,7 +66,7 @@ module growth public :: get_growth_rate,get_vrelonvfrag,check_dustprop public :: write_options_growth,read_options_growth,print_growthinfo,init_growth public :: vrelative,read_growth_setup_options,write_growth_setup_options - public :: comp_snow_line,bin_to_multi,convert_to_twofluid + public :: comp_snow_line,bin_to_multi,convert_to_twofluid,get_size contains @@ -76,7 +77,9 @@ module growth !------------------------------------------------ subroutine init_growth(ierr) use io, only:error + use physcon, only:fourpi use viscosity, only:irealvisc,shearparam + use dust, only:grainsizecgs integer, intent(out) :: ierr ierr = 0 @@ -88,12 +91,17 @@ subroutine init_growth(ierr) vfragout = vfragoutSI * 100 / unit_velocity rsnow = rsnow * au / udist grainsizemin = gsizemincgs / udist + stmin = gsizemincgs if (ifrag > 0) then if (grainsizemin < 0.) then call error('init_growth','grainsizemin < 0',var='grainsizemin',val=grainsizemin) ierr = 1 endif + if (gsizemincgs > grainsizecgs) then + call error('init_growth','grainsizemin > grainsize',var='grainsizemin',val=grainsizemin) + ierr = 1 + endif select case(isnow) case(0) !-- uniform vfrag if (vfrag <= 0.) then @@ -145,8 +153,8 @@ subroutine print_growthinfo(iprint) integer, intent(in) :: iprint - if (ifrag == 0) write(iprint,"(a)") ' Using pure growth model where ds = + vrel*rhod/graindens*dt ' - if (ifrag == 1) write(iprint,"(a)") ' Using growth/frag where ds = (+ or -) vrel*rhod/graindens*dt ' + if (ifrag == 0) write(iprint,"(a)") ' Using pure growth model where dm/dt = + 4pi*rhod*s**2*vrel*dt ' + if (ifrag == 1) write(iprint,"(a)") ' Using growth/frag where dm/dt = (+ or -) 4pi*rhod*s**2*vrel*dt ' if (ifrag == 2) write(iprint,"(a)") ' Using growth/frag with Kobayashi fragmentation model ' if (ifrag > -1) write(iprint,"((a,1pg10.3))")' Computing Vrel with alphaSS = ',shearparam if (ifrag > 0) then @@ -171,31 +179,33 @@ end subroutine print_growthinfo !----------------------------------------------------------------------- !+ -! Main routine that returns ds/dt and calculate Vrel/Vfrag. +! Main routine that returns dm/dt and calculate Vrel/Vfrag. ! This growth model is currently only available for the ! two-fluid dust method. !+ !----------------------------------------------------------------------- -subroutine get_growth_rate(npart,xyzh,vxyzu,dustgasprop,VrelVf,dustprop,dsdt) +subroutine get_growth_rate(npart,xyzh,vxyzu,dustgasprop,VrelVf,dustprop,filfac,dmdt) use part, only:rhoh,idust,igas,iamtype,iphase,isdead_or_accreted,& massoftype,Omega_k,dustfrac,tstop,deltav - use options, only:use_dustfrac + use options, only:use_dustfrac,use_porosity + use physcon, only:fourpi use eos, only:ieos,get_spsound real, intent(in) :: dustprop(:,:) real, intent(inout) :: dustgasprop(:,:) real, intent(in) :: xyzh(:,:) + real, intent(in) :: filfac(:) real, intent(inout) :: VrelVf(:),vxyzu(:,:) - real, intent(out) :: dsdt(:) + real, intent(out) :: dmdt(:) integer, intent(in) :: npart ! - real :: rhog,rhod,vrel,rho + real :: rhog,rhod,vrel,rho,sdust integer :: i,iam vrel = 0. rhod = 0. rho = 0. - !--get ds/dt over all particles + !--get dm/dt over all particles do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then iam = iamtype(iphase(i)) @@ -215,27 +225,34 @@ subroutine get_growth_rate(npart,xyzh,vxyzu,dustgasprop,VrelVf,dustprop,dsdt) rhod = rhoh(xyzh(4,i),massoftype(idust)) endif + !--dust size from mass and filling factor + if (use_porosity) then + sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) + else + sdust = get_size(dustprop(1,i),dustprop(2,i)) + endif + call get_vrelonvfrag(xyzh(:,i),vxyzu(:,i),vrel,VrelVf(i),dustgasprop(:,i)) ! - !--dustprop(1)= size, dustprop(2) = intrinsic density, + !--dustprop(1) = mass, dustprop(2) = intrinsic density, ! - !--if statements to compute ds/dt + !--if statements to compute dm/dt ! - if (ifrag == -1) dsdt(i) = 0. + if (ifrag == -1) dmdt(i) = 0. if ((VrelVf(i) < 1. .or. ifrag == 0) .and. ifrag /= -1) then ! vrel/vfrag < 1 or pure growth --> growth - dsdt(i) = rhod/dustprop(2,i)*vrel + dmdt(i) = fourpi*sdust**2*rhod*vrel elseif (VrelVf(i) >= 1. .and. ifrag > 0) then ! vrel/vfrag > 1 --> fragmentation select case(ifrag) case(1) - dsdt(i) = -rhod/dustprop(2,i)*vrel ! Symmetrical of Stepinski & Valageas + dmdt(i) = -fourpi*sdust**2*rhod*vrel ! Symmetrical of Stepinski & Valageas case(2) - dsdt(i) = -rhod/dustprop(2,i)*vrel*(VrelVf(i)**2)/(1+VrelVf(i)**2) ! Kobayashi model + dmdt(i) = -fourpi*sdust**2*rhod*vrel*(VrelVf(i)**2)/(1+VrelVf(i)**2) ! Kobayashi model end select endif endif else - dsdt(i) = 0. + dmdt(i) = 0. endif enddo @@ -325,7 +342,7 @@ subroutine write_options_growth(iunit) if (nptmass > 1) call write_inopt(this_is_a_flyby,'flyby','use primary for keplerian freq. calculation',iunit) call write_inopt(ifrag,'ifrag','dust fragmentation (0=off,1=on,2=Kobayashi)',iunit) if (ifrag /= 0) then - call write_inopt(gsizemincgs,'grainsizemin','minimum grain size in cm',iunit) + call write_inopt(gsizemincgs,'grainsizemin','minimum grain size in cm (min St if porosity)',iunit) call write_inopt(isnow,'isnow','snow line (0=off,1=position based,2=temperature based)',iunit) if (isnow == 1) call write_inopt(rsnow,'rsnow','position of the snow line in AU',iunit) if (isnow == 2) call write_inopt(Tsnow,'Tsnow','snow line condensation temperature in K',iunit) @@ -487,20 +504,35 @@ end subroutine read_growth_setup_options !----------------------------------------------------------------------- !+ -! In case of fragmentation, limit sizes to a minimum value +! In case of fragmentation, limit masses to a minimum value !+ !----------------------------------------------------------------------- -subroutine check_dustprop(npart,size) - use part, only:iamtype,iphase,idust,igas - use options, only:use_dustfrac - real,intent(inout) :: size(:) +subroutine check_dustprop(npart,dustprop,filfac,mprev,filfacprev) + use part, only:iamtype,iphase,idust,igas,dustgasprop + use options, only:use_dustfrac,use_porosity + real,intent(inout) :: dustprop(:,:) integer,intent(in) :: npart + real, intent(in) :: filfac(:),mprev(:),filfacprev(:) integer :: i,iam + real :: stnew,sdustprev,sdustmin,sdust do i=1,npart iam = iamtype(iphase(i)) - if (iam==idust .or. (use_dustfrac .and. iam==igas)) then - if (ifrag > 0 .and. size(i) < grainsizemin) size(i) = grainsizemin + if ((iam == idust .or. (use_dustfrac .and. iam == igas)) .and. ifrag > 0 .and. dustprop(1,i) <= mprev(i)) then + if (use_porosity) then + sdustprev = get_size(mprev(i),dustprop(2,i),filfacprev(i)) + sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) + stnew = dustgasprop(3,i)*sdustprev*filfacprev(i)/sdust/filfac(i) + if (stnew < stmin) then + sdustmin = stmin*sdustprev*filfacprev(i)/filfac(i)/dustgasprop(3,i) + dustprop(1,i) = dustprop(1,i) * (sdustmin/sdust)**3. + endif + else + sdust = get_size(dustprop(1,i),dustprop(2,i)) + if (sdust < grainsizemin) then + dustprop(1,i) = dustprop(1,i) * (grainsizemin/sdust)**3. ! fragmentation at constant density and filling factor + endif + endif endif enddo @@ -511,15 +543,35 @@ end subroutine check_dustprop ! Set dustprop (used by moddump) !+ !----------------------------------------------------------------------- -subroutine set_dustprop(npart) - use dust, only:grainsizecgs,graindenscgs - use part, only:dustprop - integer,intent(in) :: npart - integer :: i +subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_index) + use dust, only:grainsizecgs,graindenscgs + use part, only:iamtype,iphase,idust,igas,dustprop,filfac,probastick + use physcon, only:fourpi + use options, only:use_dustfrac + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:) + integer :: i,iam + real :: r,z,h + logical, optional, intent(in) :: sizedistrib + real, optional, intent(in) :: pwl_sizedistrib,R_ref,H_R_ref,q_index do i=1,npart - dustprop(1,i) = grainsizecgs / udist - dustprop(2,i) = graindenscgs / unit_density + iam = iamtype(iphase(i)) + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then + dustprop(2,i) = graindenscgs / unit_density + r = sqrt(xyzh(1,i)**2 + xyzh(2,i)**2) + h = H_R_ref * R_ref * au / udist * (r * udist / au / R_ref)**(1.5-q_index) + if (sizedistrib) then + dustprop(1,i) = grainsizecgs/udist * (r * udist / au / R_ref)**pwl_sizedistrib * exp(-0.5*xyzh(3,i)**2/h**2) + dustprop(1,i) = fourpi/3. * dustprop(2,i) * (dustprop(1,i))**3 + else + dustprop(1,i) = fourpi/3. * dustprop(2,i) * (grainsizecgs / udist)**3 + endif + else + dustprop(:,i) = 0. + endif + filfac(i) = 0. + probastick(i) = 1. enddo end subroutine set_dustprop @@ -532,7 +584,8 @@ end subroutine set_dustprop subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) use part, only:npart,npartoftype,massoftype,ndusttypes,& ndustlarge,grainsize,dustprop,graindens,& - iamtype,iphase,set_particle_type,idust + iamtype,iphase,set_particle_type,idust,filfac + use options, only:use_porosity use units, only:udist use table_utils, only:logspace use io, only:fatal @@ -545,7 +598,7 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) mdustold,mdustnew,code_to_mum logical :: init integer :: nbins,nbinmax,i,j,itype,ndustold,ndustnew,npartmin,imerge,iu - real, allocatable, dimension(:) :: grid + real, allocatable, dimension(:) :: grid, sdust character(len=20) :: outfile = "bin_distrib.dat" !- initialise @@ -566,13 +619,18 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) do i = 1,npart itype = iamtype(iphase(i)) if (itype==idust) then - if (dustprop(1,i) < smintmp) smintmp = dustprop(1,i) - if (dustprop(1,i) > smaxtmp) smaxtmp = dustprop(1,i) + if (use_porosity) then + sdust(i) = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) + else + sdust(i) = get_size(dustprop(1,i),dustprop(2,i)) + endif + if (sdust(i) < smintmp) smintmp = sdust(i) + if (sdust(i) > smaxtmp) smaxtmp = sdust(i) endif enddo !- overrule force_smax if particles are small, avoid empty bins - if ((maxval(dustprop(1,:))*udist < smax_user) .and. force_smax) then + if ((maxval(sdust(:))*udist < smax_user) .and. force_smax) then force_smax = .false. write(*,*) "Overruled force_smax from T to F" endif @@ -617,7 +675,7 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) if (itype==idust) then !- figure out which bin do j=1,ndusttypes - if ((dustprop(1,i) >= grid(j)) .and. (dustprop(1,i) < grid(j+1))) then + if ((sdust(i) >= grid(j)) .and. (sdust(i) < grid(j+1))) then if (j > 1) then npartoftype(idust+j-1) = npartoftype(idust+j-1) + 1 npartoftype(idust) = npartoftype(idust) - 1 @@ -625,7 +683,7 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) endif endif !- if smax has been forced, put larger grains inside last bin - if ((j==ndusttypes) .and. force_smax .and. (dustprop(1,i) >= grid(j+1))) then + if ((j==ndusttypes) .and. force_smax .and. (sdust(i) >= grid(j+1))) then npartoftype(idust+j-1) = npartoftype(idust+j-1) + 1 npartoftype(idust) = npartoftype(idust) - 1 call set_particle_type(i,idust+j-1) @@ -776,8 +834,8 @@ end subroutine merge_bins !----------------------------------------------------------------------- subroutine convert_to_twofluid(npart,xyzh,vxyzu,massoftype,npartoftype,np_ratio,dust_to_gas) use part, only: dustprop,dustgasprop,ndustlarge,ndustsmall,igas,idust,VrelVf,& - dustfrac,iamtype,iphase,deltav,set_particle_type - use options, only: use_dustfrac + dustfrac,iamtype,iphase,deltav,set_particle_type,filfac + use options, only: use_dustfrac,use_porosity use dim, only: update_max_sizes integer, intent(inout) :: npart,npartoftype(:) real, intent(inout) :: xyzh(:,:),vxyzu(:,:),massoftype(:) @@ -816,6 +874,9 @@ subroutine convert_to_twofluid(npart,xyzh,vxyzu,massoftype,npartoftype,np_ratio, dustgasprop(3,ipart) = dustgasprop(3,iloc) dustgasprop(4,ipart) = dustgasprop(4,iloc) VrelVf(ipart) = VrelVf(iloc) + if (use_porosity) then + filfac(ipart) = filfac(iloc) + endif call set_particle_type(ipart,idust) enddo @@ -830,6 +891,19 @@ subroutine convert_to_twofluid(npart,xyzh,vxyzu,massoftype,npartoftype,np_ratio, vxyzu(1,j) = vxyzu(1,j) - dustfrac(1,j) * deltav(1,1,j) vxyzu(2,j) = vxyzu(2,j) - dustfrac(1,j) * deltav(2,1,j) vxyzu(3,j) = vxyzu(3,j) - dustfrac(1,j) * deltav(3,1,j) + + !- reset dust quantities of the mixture + dustprop(1,j) = 0. + dustprop(2,j) = 0. + dustgasprop(1,j) = 0. + dustgasprop(2,j) = 0. + dustgasprop(3,j) = 0. + dustgasprop(4,j) = 0. + VrelVf(j) = 0. + if (use_porosity) then + filfac(j) = 0. + endif + endif enddo @@ -840,6 +914,7 @@ subroutine convert_to_twofluid(npart,xyzh,vxyzu,massoftype,npartoftype,np_ratio, use_dustfrac = .false. end subroutine convert_to_twofluid + !--Compute the relative velocity following Stepinski & Valageas (1997) real function vrelative(dustgasprop,Vt) use physcon, only:roottwo @@ -859,4 +934,21 @@ real function vrelative(dustgasprop,Vt) end function vrelative +!--Compute size from mass and filling factor +real function get_size(mass,dens,filfac) + use physcon, only:fourpi + real, intent(in) :: mass,dens + real, optional, intent(in) :: filfac + real :: f + + if (present(filfac)) then + f = filfac + else + f = 1.0 + endif + + get_size = ( 3.*mass / (fourpi*dens*f) )**(1./3.) + +end function get_size + end module growth diff --git a/src/main/initial.F90 b/src/main/initial.F90 index cf334db92..38191bbcb 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -128,7 +128,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,igas,idust,massoftype,& epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& nden_nimhd,dustevol,rhoh,gradh, & - Bevol,Bxyz,dustprop,ddustprop,ndustsmall,iboundary,eos_vars,dvdx + Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx use part, only:pxyzu,dens,metrics,rad,radprop,drad,ithick use densityforce, only:densityiterate use linklist, only:set_linklist @@ -172,6 +172,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use dust, only:init_drag #ifdef DUSTGROWTH use growth, only:init_growth + use porosity, only:init_porosity,init_filfac + use options, only:use_porosity #endif #endif #ifdef MFLOW @@ -314,6 +316,11 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) #ifdef DUSTGROWTH call init_growth(ierr) if (ierr /= 0) call fatal('initial','error initialising growth variables') + if (use_porosity) then + call init_porosity(ierr) + if (ierr /= 0) call fatal('initial','error initialising porosity variables') + call init_filfac(npart,xyzh,vxyzu) + endif #endif #endif ! @@ -567,8 +574,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) eos_vars(3,:) = -1.0 ! initial guess for temperature overridden in eos 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,dustfrac,& - eos_vars,time,0.,dtnew_first,pxyzu,dens,metrics) + rad,drad,radprop,dustprop,ddustprop,dustevol,ddustevol,filfac,& + dustfrac,eos_vars,time,0.,dtnew_first,pxyzu,dens,metrics) #ifdef LIVE_ANALYSIS call do_analysis(dumpfile,numfromfile(dumpfile),xyzh,vxyzu, & massoftype(igas),npart,time,ianalysis) diff --git a/src/main/options.f90 b/src/main/options.f90 index 4631c55e8..a7f2e8c2d 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -44,7 +44,7 @@ module options real, public :: rhofinal_cgs,rhofinal1 ! dust method - logical, public :: use_dustfrac, use_hybrid + logical, public :: use_dustfrac, use_hybrid, use_porosity ! mcfost logical, public :: use_mcfost, use_Voronoi_limits_file, use_mcfost_stellar_parameters, mcfost_computes_Lacc diff --git a/src/main/part.F90 b/src/main/part.F90 index 8b2f91ace..a734e5bba 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -69,12 +69,20 @@ module part ! !--storage of dust growth properties ! - real, allocatable :: dustprop(:,:) !- size and intrinsic density + real, allocatable :: dustprop(:,:) !- mass and intrinsic density real, allocatable :: dustgasprop(:,:) !- gas related quantites interpolated on dust particles (see Force.F90) real, allocatable :: VrelVf(:) - character(len=*), parameter :: dustprop_label(2) = (/'grainsize','graindens'/) + character(len=*), parameter :: dustprop_label(2) = (/'grainmass','graindens'/) character(len=*), parameter :: dustgasprop_label(4) = (/'csound','rhogas','St ','dv '/) character(len=*), parameter :: VrelVf_label = 'Vrel/Vfrag' + + !- porosity + integer, allocatable :: dragreg(:) !- drag regime + real, allocatable :: mprev(:) !- previous mass + real, allocatable :: filfacprev(:) !- previous filling factor needed for minimum St condition + real, allocatable :: filfac(:) !- filling factor + real, allocatable :: probastick(:) !-probabily of sticking, when bounce is on + character(len=*), parameter :: filfac_label = 'filfac' !- options logical, public :: this_is_a_test = .false. logical, public :: this_is_a_flyby = .false. @@ -255,9 +263,9 @@ module part real(kind=4), allocatable :: divBsymm(:) real, allocatable :: fext(:,:) real, allocatable :: ddustevol(:,:) - real, allocatable :: ddustprop(:,:) !--grainsize is the only prop that evolves for now + real, allocatable :: ddustprop(:,:) !--grainmass is the only prop that evolves for now real, allocatable :: drad(:,:) - character(len=*), parameter :: ddustprop_label(2) = (/' ds/dt ','drho/dt'/) + character(len=*), parameter :: ddustprop_label(2) = (/' dm/dt ','drho/dt'/) ! !--storage associated with/dependent on timestepping ! @@ -266,6 +274,7 @@ module part real, allocatable :: dustpred(:,:) real, allocatable :: Bpred(:,:) real, allocatable :: dustproppred(:,:) + real, allocatable :: filfacpred(:) real, allocatable :: radpred(:,:) #ifdef IND_TIMESTEPS integer(kind=1), allocatable :: ibin(:) @@ -338,6 +347,7 @@ module part +2 & ! dustprop +2 & ! dustproppred +4 & ! dustgasprop + +1 & ! filfacpred #endif #endif #ifdef H2CHEM @@ -445,6 +455,11 @@ subroutine allocate_part call allocate_array('dustevol', dustevol, maxdustsmall, maxp_dustfrac) call allocate_array('ddustevol', ddustevol, maxdustsmall, maxdustan) call allocate_array('ddustprop', ddustprop, 2, maxp_growth) + call allocate_array('dragreg', dragreg, maxp_growth) + call allocate_array('filfac', filfac, maxp_growth) + call allocate_array('mprev', mprev, maxp_growth) + call allocate_array('filfacprev', filfacprev, maxp_growth) + call allocate_array('probastick', probastick, maxp_growth) call allocate_array('deltav', deltav, 3, maxdustsmall, maxp_dustfrac) call allocate_array('pxyzu', pxyzu, maxvxyzu, maxgr) call allocate_array('dens', dens, maxgr) @@ -467,6 +482,7 @@ subroutine allocate_part call allocate_array('dustpred', dustpred, maxdustsmall, maxdustan) call allocate_array('Bpred', Bpred, maxBevol, maxmhdan) call allocate_array('dustproppred', dustproppred, 2, maxp_growth) + call allocate_array('filfacpred', filfacpred, maxp_growth) call allocate_array('dust_temp',dust_temp,maxTdust) call allocate_array('rad', rad, maxirad, maxprad) call allocate_array('radpred', radpred, maxirad, maxprad) @@ -522,6 +538,11 @@ subroutine deallocate_part if (allocated(dustevol)) deallocate(dustevol) if (allocated(ddustevol)) deallocate(ddustevol) if (allocated(ddustprop)) deallocate(ddustprop) + if (allocated(dragreg)) deallocate(dragreg) + if (allocated(filfac)) deallocate(filfac) + if (allocated(mprev)) deallocate(mprev) + if (allocated(filfacprev)) deallocate(filfacprev) + if (allocated(probastick)) deallocate(probastick) if (allocated(deltav)) deallocate(deltav) if (allocated(pxyzu)) deallocate(pxyzu) if (allocated(dens)) deallocate(dens) @@ -544,6 +565,7 @@ subroutine deallocate_part if (allocated(dustpred)) deallocate(dustpred) if (allocated(Bpred)) deallocate(Bpred) if (allocated(dustproppred)) deallocate(dustproppred) + if (allocated(filfacpred)) deallocate(filfacpred) #ifdef IND_TIMESTEPS if (allocated(ibin)) deallocate(ibin) if (allocated(ibin_old)) deallocate(ibin_old) @@ -1255,6 +1277,7 @@ subroutine copy_particle_all(src,dst,new_part) dustgasprop(:,dst) = dustgasprop(:,src) VrelVf(dst) = VrelVf(src) dustproppred(:,dst) = dustproppred(:,src) + filfacpred(dst) = filfacpred(src) endif endif if (maxp_h2==maxp .or. maxp_krome==maxp) abundance(:,dst) = abundance(:,src) @@ -1694,18 +1717,44 @@ end subroutine delete_particles_outside_box ! Delete particles outside (or inside) of a defined sphere !+ !---------------------------------------------------------------- -subroutine delete_particles_outside_sphere(center,radius,np) +subroutine delete_particles_outside_sphere(center,radius,np,revert,mytype) use io, only:fatal real, intent(in) :: center(3), radius integer, intent(inout) :: np + logical, intent(in), optional :: revert + integer, intent(in), optional :: mytype + integer :: i - real :: r(3), radius_squared + real :: r(3), radius_squared + logical :: use_revert + + if (present(revert)) then + use_revert = revert + else + use_revert = .false. + endif radius_squared = radius**2 - do i=1,np - r = xyzh(1:3,i) - center - if (dot_product(r,r) > radius_squared) call kill_particle(i,npartoftype) - enddo + + if (present(mytype)) then + do i=1,np + r = xyzh(1:3,i) - center + if (use_revert) then + if (dot_product(r,r) < radius_squared .and. iamtype(iphase(i)) == mytype) call kill_particle(i,npartoftype) + else + if (dot_product(r,r) > radius_squared .and. iamtype(iphase(i)) == mytype) call kill_particle(i,npartoftype) + endif + enddo + else + do i=1,np + r = xyzh(1:3,i) - center + if (use_revert) then + if (dot_product(r,r) < radius_squared) call kill_particle(i,npartoftype) + else + if (dot_product(r,r) > radius_squared) call kill_particle(i,npartoftype) + endif + enddo + endif call shuffle_part(np) if (np /= sum(npartoftype)) call fatal('del_part_outside_sphere','particles not conserved') diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 new file mode 100755 index 000000000..a5e7a96f3 --- /dev/null +++ b/src/main/porosity.f90 @@ -0,0 +1,790 @@ +module porosity + use units, only:umass,udist,unit_energ,unit_pressure,unit_density + use physcon, only:Ro,pi,fourpi,roottwo + implicit none + + !--Default values + + integer, public :: iporosity = 0 !--0=Off 1=On (-1=On for checkup, filfac is initialized but does not evolve) + integer, public :: icompact = 1 !--0=off 1=on (Compaction of dust grain during fragmentation) + integer, public :: ibounce = 0 !--0=off 1=on (Allow dust grains to bounce) + integer, public :: idisrupt = 0 !--0=off 1=on (Rotational disruption by gas flow: Tatsuuma et al. 2021) + real, public :: smonocgs = 1e-4 !--monomer size in cm + real, public :: surfenergSI = 0.20 !--surface energy of monomers in SI: J/m**2 (here for Si: Kimura et al. 2020) + real, public :: youngmodSI = 72e9 !--young modulus of monomers in SI: Pa (here for Si: Yamamoto et al. 2014) + real, public :: gammaft = 0.1 !--force-to-torque efficiency (Tatsuuma et al. 2021) + real, private :: cratio = -0.5801454844 !--common ratio for a power + real, private :: b_oku = 0.15 !--parameter b (Okuzumi et al. 2012) + real, private :: maxpacking = 0.74048 !--max sphere packing for hexagonal close packing + + real, public :: smono !--monomer size + real, public :: mmono !--monomer mass + real, public :: surfenerg + real, public :: youngmod + real, private :: eroll !--rolling + real, private :: grainmassmin = 1e-09 !--minimum grain mass for disruption (~100µm) + real, private :: grainmassminlog + real, private :: Yd0 !test for compaction + real, private :: Ydpow !test for compaction + + public :: get_filfac,init_filfac,get_disruption + public :: init_porosity,print_porosity_info,write_options_porosity,read_options_porosity + public :: write_porosity_setup_options,read_porosity_setup_options + + contains + +!------------------------------------------------ +!+ +! Initialise variables for computing porosity +!+ +!------------------------------------------------ +subroutine init_porosity(ierr) + use io, only:error + use dust, only:idrag,grainsizecgs,graindenscgs + use growth , only:ifrag,gsizemincgs + integer, intent(out) :: ierr + + ierr = 0 + + !--initialise variables in code units + smono = smonocgs / udist + mmono = fourpi/3 * (graindenscgs / unit_density) * smono**3 + surfenerg = surfenergSI * udist * udist * 1000 / unit_energ + youngmod = youngmodSI * 10 / unit_pressure + eroll = 302.455974078*(surfenerg**5 * smono**4 / youngmod**2)**(1./3.) + + Yd0 = 9.5e6 *10/unit_pressure ! for water+silicate; 9.8e6 for water only + Ydpow = 6.4 !for silicate+water, 4 for water only + + grainmassminlog = log10(grainmassmin/umass) + + if (smono <= 0.) then + call error('init_porosity','smonocgs <= 0',var='smonocgs',val=smonocgs) + ierr = 1 + endif + + if (grainsizecgs < smonocgs) then + call error('init_porosity','grainsizecgs < smonocgs',var='smonocgs',val=smonocgs) + ierr = 1 + endif + + if (surfenerg <= 0.) then + call error('init_porosity','surfenerg <= 0',var='surfenerg',val=surfenerg) + ierr = 2 + endif + + if (youngmod <= 0.) then + call error('init_porosity','youngmod <= 0',var='youngmod',val=youngmod) + ierr = 3 + endif + + if (idrag /= 1) then + call error('init_porosity','idrag = 1 should be used for porosity',var='idrag',val=real(idrag)) + ierr = 4 + endif + +end subroutine init_porosity + +!----------------------------------------------------------------------- +!+ +! Compute the initial filling factor +!+ +!----------------------------------------------------------------------- +subroutine init_filfac(npart,xyzh,vxyzu) + use options, only:use_dustfrac + use viscosity, only:shearparam + use part, only:idust,igas,iamtype,iphase,massoftype,& + rhoh,dustfrac,dustprop,filfac,Omega_k + use dust, only:get_viscmol_nu,grainsizecgs + use eos, only:gamma,get_spsound + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:) + real, intent(inout) :: vxyzu(:,:) + + integer :: i,iam + real :: rho,rhogas,cs,cparam,coeff_gei,nu + real :: sfrac,s1,s2,s3,filfacmax + real :: mfrac,m1,m2,m3 + + + select case (iporosity) ! add other case for other models here + case (-1,1) + + !--initialize filling factor (Garcia & Gonzalez 2020, Suyama et al. 2008, Okuzumi et al. 2012) + + if (all(filfac(:) == 0.)) then ! check if filfac(i) was already initialize by init_filfac or not + coeff_gei = sqrt(8./(pi*gamma)) + do i=1,npart + iam = iamtype(iphase(i)) + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then + sfrac = (dustprop(1,i)/mmono)**(1./3.) + if (sfrac > 1.) then ! if grainsize > monomer size, compute filling factor + !- compute rho, rhogas and cs + if (iam == igas .and. use_dustfrac) then + rho = rhoh(xyzh(4,i),massoftype(igas)) + rhogas = rho*(1-dustfrac(1,i)) + cs = get_spsound(3,xyzh(:,i),rhogas,vxyzu(:,i)) + else + rhogas = rhoh(xyzh(4,i),massoftype(igas)) + cs = get_spsound(3,xyzh(:,i),rhogas,vxyzu(:,i)) + rho = rhogas + rhoh(xyzh(4,i),massoftype(idust)) + endif + + !- molecular viscosity + nu = get_viscmol_nu(cs,rhogas) + + !- shared parameter for the following filling factors + cparam = (243.*pi*roottwo/15625.)*(Ro*shearparam*smono**4*dustprop(2,i)*dustprop(2,i)*cs & + *Omega_k(i))/(rho*b_oku*eroll) + + !--transition masses m1/mmono and m2/mmono between hit&stick and Epstein/Stokes regimes with St < 1 + s1 = (cparam/(2.*(2.**0.075 - 1.)*coeff_gei))**((1.-cratio)/(1.+8.*cratio)) + s2 = (cparam*cs*smono/(9.*nu*(2.**0.2 - 1.)))**((1.-cratio)/(9.*cratio)) + + !--we assume St < 1 here (grainsizecgs < 100-1000 cm) + if (s1 < s2) then + if (sfrac < s1) then ! filling factor: hit&stick regime + filfac(i) = sfrac**(3.*cratio/(1.-cratio)) + else + !- transition masses m3/mmono between Epstein and Stokes regimes with St < 1 + s3 = s1**((1.+8.*cratio)/(1.-cratio)) / s2**(9.*cratio/(1.-cratio)) + + if (sfrac < s3) then ! filling factor: Epstein regime - St<1 + filfac(i) = s1**((1.+8.*cratio)/(3.-3.*cratio))/sfrac**(1./3.) + else ! filling factor: Stokes regime - St<1 + filfac(i) = s2**(3.*cratio/(1.-cratio)) + endif + endif + else + if (sfrac < s2) then ! filling factor: hit&stick regime + filfac(i) = sfrac**(3.*cratio/(1.-cratio)) + else ! filling factor: Stokes regime - St<1 + filfac(i) = s2**(3.*cratio/(1.-cratio)) + endif + endif + + !- max value of filfac is maxpacking == max compaction + filfacmax = 0.5*maxpacking *(1+ sqrt(1 + 4*(1.-maxpacking)/maxpacking/maxpacking*sfrac**(-3))) + if (filfac(i) > filfacmax) filfac(i) = filfacmax + + !- Compute grain mass of the grain using grain size and filfac + dustprop(1,i) = filfac(i) * dustprop(1,i) + else + filfac(i) = 1. + dustprop(1,i) = mmono + endif + endif + enddo + endif + end select + +end subroutine init_filfac + +!---------------------------------------------------------- +!+ +! print information about porosity +!+ +!---------------------------------------------------------- +subroutine print_porosity_info(iprint) + integer, intent(in) :: iprint + + if (iporosity == 1) then + write(iprint,"(a)") ' Using porosity ' + if (icompact == 1) then + write(iprint,"(a)") ' Using compaction during fragmentation ' + endif + write(iprint,"(2(a,1pg10.3),a)")' Monomer size = ',smonocgs,' cm = ',smono,' (code units)' + write(iprint,"(2(a,1pg10.3),a)")' Surface energy = ',surfenergSI,' J/m**2 = ',surfenerg,' (code units)' + write(iprint,"(2(a,1pg10.3),a)")' Young modulus = ',youngmodSI,' Pa = ',youngmod,' (code units)' + endif + +end subroutine print_porosity_info + +!----------------------------------------------------------------------- +!+ +! Compute the final filling factor +!+ +!----------------------------------------------------------------------- +subroutine get_filfac(npart,xyzh,mprev,filfac,dustprop,dt) + use dim, only:use_dustgrowth + use options, only:use_dustfrac + use part, only:rhoh,idust,igas,iamtype,iphase,isdead_or_accreted,& + massoftype,dustfrac,dustgasprop,VrelVf,probastick + integer, intent(in) :: npart + real, intent(in) :: dt + real, intent(inout) :: filfac(:),dustprop(:,:) + real, intent(in) :: xyzh(:,:),mprev(:) + integer :: i,iam + real :: filfacevol,filfacmin,filfacmax + real :: rho,rhod + + select case (iporosity) ! add other cases for other models here + case (1) + !$omp parallel do default(none) & + !$omp shared(xyzh,npart,iphase,massoftype,use_dustfrac,dustfrac,icompact) & + !$omp shared(mprev,filfac,dustprop,dustgasprop,VrelVf,probastick,mmono,maxpacking,dt,ibounce) & + !$omp private(i,iam,rho,rhod,filfacevol,filfacmin,filfacmax) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + iam = iamtype(iphase(i)) + + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then + if (dustprop(1,i) > mmono) then + !- compute rho = rho_gas + rho_dust + + if (use_dustfrac .and. iam == igas) then + rho = rhoh(xyzh(4,i),massoftype(igas)) + rhod = rho*dustfrac(1,i) + else + rhod = rhoh(xyzh(4,i),massoftype(idust)) + rho = dustgasprop(2,i) + rhod + endif + + call get_filfac_min(i,rho,dustprop(1,i)/mmono,dustprop(2,i),dustgasprop(:,i),filfacmin) + !--if new mass > previous mass, compute the new filling factor due to growth + if (dustprop(1,i) > mprev(i)) then + call get_filfac_growth(mprev(i),dustprop(1,i),filfac(i),dustgasprop(:,i),filfacevol) + if (ibounce == 1) call get_filfac_bounce(mprev(i),dustprop(2,i),filfac(i),& + dustgasprop(:,i),probastick(i),rhod,dt,filfacevol,filfacmin) + !--if new mass < previous mass, compute the new filling factor due to fragmentation + else + call get_filfac_frag(mprev(i),dustprop(:,i),filfac(i),dustgasprop(:,i),rhod,VrelVf(i),dt,filfacevol) + endif + filfac(i) = filfacevol + + !--check if the filling factor is smaller than the minimum filling factor + filfac(i) = max(filfac(i),filfacmin) + !-- max value of filfac is maxpacking == max compaction + filfacmax = maxpacking + (1.-maxpacking)*mmono/dustprop(1,i) + filfac(i) = min(filfac(i),filfacmax) + else + filfac(i) = 1. + dustprop(1,i) = mmono + endif + endif + else + filfac(i) = 0. + endif + enddo + !$omp end parallel do + end select + +end subroutine get_filfac + +!----------------------------------------------------------------------- +!+ +! Compute the filling factor during growth +!+ +!----------------------------------------------------------------------- +subroutine get_filfac_growth(mprev,mass,filfac,dustgasprop,filfacgrowth) + use viscosity, only:shearparam + use growth, only:vrelative + real, intent(in) :: mprev,mass,filfac + real, intent(in) :: dustgasprop(:) + real, intent(out) :: filfacgrowth + real :: ekincdt,vrel + real :: j ! Power of the filling factor dependency in mass + + vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + + !- kinetic energy condition Ekin/(3*b_oku/eroll) + ekincdt = mprev*vrel*vrel/(12.*b_oku*eroll) + + !-choose power according to the value of ekincdt + if (ekincdt <= 1.) then + j = cratio + else + j = -0.2 + endif + + !- filling factor due to growth + filfacgrowth = filfac*(mass/mprev)**j + +end subroutine get_filfac_growth + +!----------------------------------------------------------------------- +!+ +! Compute the filling factor during bounce +!+ +!----------------------------------------------------------------------- +subroutine get_filfac_bounce(mprev,graindens,filfac,dustgasprop,probastick,rhod,dt,filfacevol,filfacmin) + use viscosity, only:shearparam + use growth, only:vrelative,get_size + use physcon, only:fourpi + real, intent(in) :: mprev,graindens,filfac,probastick,rhod,dt + real, intent(in) :: dustgasprop(:),filfacmin + real, intent(inout) :: filfacevol + real :: sdust,vrel,ncoll,vol,deltavol + real :: ekin,pdyn,coeffrest,filfacbnc + real :: vstick,vyield,vend + + if (probastick < 1.) then + vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + sdust = get_size(mprev,graindens,filfac) + vstick = compute_vstick(mprev,sdust) !-compute vstick, i.e. max velocity before bouncing appears + + if (vrel >= vstick) then !-if vrel>=vstick -> bouncing + vyield = compute_vyield(vstick) !-compute vyield, i.e. max velocity before inelastic collisions appear + vend = compute_vend(vstick) !-compute vend, i.e. max velocity before there is only bouncing => no growth + + if (vrel < vyield) then !-elastic collision, no compaction + filfacbnc = filfac + else !-inelastic collision, compaction + vol = fourpi/3. * sdust**3 + ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !-number of collision in dt + ekin = mprev*vrel*vrel/4. + coeffrest = get_coeffrest(vstick/vrel,vyield/vrel) !-coefficient of restitution + pdyn = eroll * (filfac/(maxpacking - filfac)/smono)**3 + deltavol = (1.-coeffrest*coeffrest)*ekin/pdyn + if (deltavol > vol) deltavol = vol + + filfacbnc = filfac *(1./(1.-0.5*(deltavol/vol)))**ncoll + if (filfacbnc > maxpacking) filfacbnc = maxpacking + endif + + if (vrel < vend) then !-final filfac is a combination of filfac due to growth + bouncing + if (filfacevol < filfacmin) filfacevol = filfacmin + filfacevol = filfacevol*probastick + (1-probastick)*filfacbnc + else + filfacevol = filfacbnc + endif + endif + endif + + end subroutine get_filfac_bounce + +!----------------------------------------------------------------------- +!+ +! Compute the filling factor during fragmentation +!+ +!----------------------------------------------------------------------- +subroutine get_filfac_frag(mprev,dustprop,filfac,dustgasprop,rhod,VrelVf,dt,filfacfrag) + use viscosity, only:shearparam + use growth, only:vrelative,get_size + use physcon, only:fourpi + real, intent(in) :: mprev,filfac,rhod,VrelVf,dt + real, intent(in) :: dustprop(:),dustgasprop(:) + real, intent(out) :: filfacfrag + real :: sdust,vrel,ncoll,compfactor,vol,deltavol + real :: ekin,pdyn + + select case (icompact) + case (0) + ! Fragmentation at constant filling factor + filfacfrag = filfac + case (1) + ! model Fit1ncoll + sdust = get_size(mprev,dustprop(2),filfac) + vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev + + compfactor = (3.*0.3*filfac**(-0.2))*exp(1.5*(0.3-VrelVf)) + 1. + filfacfrag = filfac*compfactor**ncoll + case (2) + ! model Fit2ncoll + sdust = get_size(mprev,dustprop(2),filfac) + vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev + + compfactor = 27.*filfac**(-0.2)*VrelVf**(1.5)/(2.*exp(4.*VrelVf)-1.) + 1. + filfacfrag = filfac*compfactor**ncoll + case (3) + ! model Garcia + sdust = get_size(mprev,dustprop(2),filfac) + vol = fourpi/3. * sdust**3 + vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev + + ekin = mprev*vrel*vrel/4. + + if (filfac >= 0.01) then + pdyn = Yd0*filfac**Ydpow + else + pdyn = Yd0*0.01**Ydpow + endif + + deltavol = ekin/pdyn + + if (deltavol >= vol) deltavol = vol + + filfacfrag = filfac *(1./(1.-0.5*deltavol/vol))**ncoll + case (4) + !model Fit1 + garcia + sdust = get_size(mprev,dustprop(2),filfac) + vol = fourpi/3. * sdust**3 + vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev + + compfactor = (3.*0.3*filfac**(-0.2))*exp(1.5*(0.3-VrelVf)) + 1. + deltavol = vol - dustprop(1)*vol/mprev/compfactor + filfacfrag = filfac *(1./(1.-deltavol/vol))**ncoll + + case (5) + ! model Garcia + Kataoka mod + sdust = get_size(mprev,dustprop(2),filfac) + vol = fourpi/3. * sdust**3 + vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !number of collisions in dt + + ekin = mprev*vrel*vrel/4. - (2.*mprev - dustprop(1))*0.23805*eroll/mmono !0.23805 = 1.5 * 48/302.46 + pdyn = eroll * (filfac/(maxpacking - filfac)/smono)**3 + deltavol = ekin/pdyn !-ekin is kinetic energy - all energy needed to break monomers + + if (deltavol < 0) deltavol = 0. + if (deltavol > vol) deltavol = vol + + filfacfrag = filfac *(1./(1.-0.5*exp(1-VrelVf**2.)*deltavol/vol))**ncoll + + end select + + end subroutine get_filfac_frag + +!----------------------------------------------------------------------- +!+ +! Compute the filling factor in the collisional compression regime +!+ +!----------------------------------------------------------------------- +subroutine get_filfac_col(i,rho,mfrac,graindens,dustgasprop,filfaccol) + use part, only:Omega_k,dragreg + use viscosity, only:shearparam + use dust, only:get_viscmol_nu + use eos, only:gamma + integer, intent(in) :: i + real, intent(in) :: rho,mfrac,graindens + real, intent(in) :: dustgasprop(:) + real, intent(out) :: filfaccol + real :: cparam,coeff_gei,nu,kwok + real :: m1,m2,m3,m4,m5 + + !--compute filling factor due to collisions (Garcia & Gonzalez 2020, Suyama et al. 2008, Okuzumi et al. 2012) + + !- shared parameter for the following filling factors + cparam = (243.*pi*roottwo/15625.)*(Ro*shearparam*smono**4*graindens*graindens*dustgasprop(1) & + *Omega_k(i))/(rho*b_oku*eroll) + + coeff_gei = sqrt(8./(pi*gamma)) + + !- molecular viscosity + nu = get_viscmol_nu(dustgasprop(1),dustgasprop(2)) + + !- Kwok (1975) correction for supersonic drag is important + if (dragreg(i) == 2) then + kwok = sqrt(1.+9.*pi/128.*dustgasprop(4)*dustgasprop(4)/(dustgasprop(1)*dustgasprop(1))) + else + kwok = 1. + endif + + !--transition sizes m1/mmono and m2/mmono between hit&stick and Epstein/Stokes regimes with St < 1 + m1 = (cparam/(2.*(2.**0.075 - 1.)*coeff_gei*kwok))**(0.375/(cratio+0.125)) + m2 = (cparam*dustgasprop(1)*smono/(9.*nu*(2.**0.2 - 1.)))**(1./(3.*cratio)) + + if (dustgasprop(3) <= 1) then !- Stokes < 1 + if (m1 < m2) then + if (mfrac < m1) then !- filling factor: hit&stick regime + filfaccol = mfrac**cratio + else + !- transition masses m3/mmono between Epstein and Stokes regimes with St < 1 + m3 = m1**(8.*cratio+1.) / m2**(8*cratio) + if (mfrac < m3) then !- filling factor: Epstein regime - St<1 + filfaccol = m1**(cratio+0.125)/mfrac**(0.125) + else !- filling factor: Stokes regime - St<1 + filfaccol = m2**cratio + endif + endif + else + if (mfrac < m2) then !- filling factor: hit&stick regime + filfaccol = mfrac**cratio + else !- filling factor: Stokes regime - St<1 + filfaccol = m2**cratio + endif + endif + else !- Stokes > 1 + !--transition masses m4/mmono and m5/mmono between hit&stick and Epstein/Stokes regimes with St > 1 + m4 = (rho*coeff_gei*kwok*dustgasprop(1)/(graindens*smono*Omega_k(i)))**4 / m1**((cratio+0.125)/0.375) + m5 = (9.*nu*rho/(2.*graindens*smono**2*Omega_k(i)))**1.5 / m2**(0.5*cratio) + + if (m4 < m5) then !- filling factor: Epstein regime - St>1 + filfaccol = 0.5*m1**(cratio+0.125) * m4**0.075 / mfrac**0.2 + else !- filling factor: Stokes regime - St>1 + filfaccol = 0.5*m2**cratio * (m5/mfrac)**0.2 + endif + endif + +end subroutine get_filfac_col + +!----------------------------------------------------------------------- +!+ +! Compute the minimum filling factor +!+ +!----------------------------------------------------------------------- +subroutine get_filfac_min(i,rho,mfrac,graindens,dustgasprop,filfacmin) + use part, only:Omega_k + integer, intent(in) :: i + real, intent(in) :: rho,mfrac,graindens + real, intent(in) :: dustgasprop(:) + real, intent(out) :: filfacmin + real :: filfaccol,filfacgas,filfacgrav + + call get_filfac_col(i,rho,mfrac,graindens,dustgasprop,filfaccol) + + !--compute filling factor due to gas drag compression (Garcia & Gonzalez 2020, Kataoka et al. 2013a) + filfacgas = ((mmono*smono*dustgasprop(4)*Omega_k(i))/(pi*eroll*dustgasprop(3)))**(3./7.) * mfrac**(1./7.) + + !--compute filling factor due to self-gravity (Garcia & Gonzalez 2020, Kataoka et al. 2013b) + filfacgrav = (mmono*mmono/(pi*smono*eroll))**0.6 * mfrac**0.4 + + !--return the maximum filling factor between filfaccol, filfacgas and filfacgrav + filfacmin = max(filfaccol,filfacgas,filfacgrav) + +end subroutine get_filfac_min + + +subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) + use options, only:use_dustfrac + use part, only:idust,igas,iamtype,iphase,massoftype,isdead_or_accreted,rhoh + use growth, only:check_dustprop,get_size + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:),dustgasprop(:,:) + real, intent(inout) :: dustprop(:,:),filfac(:) + integer :: i,iam + real :: stress,strength,filfacmin,rho + real :: grainmasscurlog,grainmassmaxlog,randmass + + select case (idisrupt) + case(1) + do i=1, npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + iam = iamtype(iphase(i)) + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then + + stress = 25./36. * dustprop(2,i) * filfac(i) * gammaft**2 * dustgasprop(4,i)**2 + strength = 0.6*filfac(i)**(1.8)*surfenerg/smono + + if (stress >= strength) then !-grain is rotationnaly disrupted + !-compute rho to compute filfacmin + if (use_dustfrac .and. iam == igas) then + rho = rhoh(xyzh(4,i),massoftype(igas)) + else + rho = dustgasprop(2,i) + rhoh(xyzh(4,i),massoftype(idust)) + endif + + !-compute current, current/2 and min mass in log10 + grainmasscurlog = log10(dustprop(1,i)) + grainmassmaxlog = log10(dustprop(1,i)/(2.)) + + !--call random number between 2 float values to assign a random mass to dustprop(1) + if (grainmassmaxlog > grainmassminlog) then + randmass = (grainmassmaxlog - grainmassminlog) * rand() + grainmassminlog + else + if (grainmasscurlog > grainmassminlog) then + randmass = grainmassminlog + else + randmass = grainmasscurlog + endif + endif + + dustprop(1,i) = 10.**randmass + + !-compute filfacmin and compare it to filfac(i) + call get_filfac_min(i,rho,dustprop(1,i)/mmono,dustprop(2,i),dustgasprop(:,i),filfacmin) + filfac(i) = max(filfac(i),filfacmin) + + endif + endif + endif + enddo + end select + +end subroutine get_disruption + +!----------------------------------------------------------------------- +!+ +! Compute the probability of bounce and associated growth rate +!+ +!----------------------------------------------------------------------- + +subroutine get_probastick(npart,xyzh,dmdt,dustprop,dustgasprop,filfac) + use options, only:use_dustfrac + use part, only:idust,igas,iamtype,iphase,isdead_or_accreted,rhoh,probastick + use viscosity, only:shearparam + use growth, only:vrelative,get_size + integer, intent(in) :: npart + real, intent(in) :: filfac(:) + real, intent(in) :: xyzh(:,:),dustprop(:,:),dustgasprop(:,:) + real, intent(inout) :: dmdt(:) + integer :: i,iam + real :: vrel,vstick,vend,sdust + + if (ibounce == 1) then + do i=1, npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + iam = iamtype(iphase(i)) + if ((iam == idust .or. (iam == igas .and. use_dustfrac))) then + if (filfac(i) >= 0.3 .and. dmdt(i) >= 0.) then + vrel = vrelative(dustgasprop(:,i),sqrt(roottwo*Ro*shearparam)*dustgasprop(1,i)) + sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) + vstick = compute_vstick(dustprop(1,i),sdust) + vend = compute_vend(vstick) + + !compute the probability of bounce depending on the velocity + if (vrel >= vstick) then + if(vrel < vend) then + probastick(i) = (log(vrel)-log(vend))/(log(vstick)-log(vend)) + else + probastick(i) = 0. !full bounce -> no growth + endif + else + probastick(i) = 1. + endif + else + probastick(i) = 1. + endif + !compute new growth rate + dmdt(i) = dmdt(i)*probastick(i) + endif + endif + enddo + endif + +end subroutine get_probastick + +!----------------------------------------------------------------------- +!+ +! Write porosity options in the input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_porosity(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + write(iunit,"(/,a)") '# options controlling porosity (require idrag=1)' + call write_inopt(iporosity,'iporosity','porosity (0=off,1=on) ',iunit) + if (iporosity == 1 .or. iporosity == -1) then + call write_inopt(icompact, 'icompact', 'Compaction during fragmentation (ifrag > 0) (0=off,1=on)', iunit) + call write_inopt(ibounce, 'ibounce', 'Dust bouncing (0=off,1=on)', iunit) + call write_inopt(idisrupt, 'idisrupt', 'Rotational disruption (0=off,1=on)', iunit) + call write_inopt(smonocgs,'smonocgs','Monomer size in cm (smaller or equal to 1.e-4 cm)',iunit) + call write_inopt(surfenergSI,'surfenergSI','Monomer surface energy in J/m**2',iunit) + call write_inopt(youngmodSI,'youngmodSI','Monomer young modulus in Pa',iunit) + call write_inopt(gammaft,'gammaft','Force to torque efficient of gas flow on dust',iunit) + endif + +end subroutine write_options_porosity + +!----------------------------------------------------------------------- +!+ +! Read porosity options from the input file +!+ +!----------------------------------------------------------------------- +subroutine read_options_porosity(name,valstring,imatch,igotall,ierr) + use options, only: use_porosity + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer, intent(out) :: ierr + + integer, save :: ngot = 0 + + imatch = .true. + igotall = .false. + + select case(trim(name)) + case('iporosity') + read(valstring,*,iostat=ierr) iporosity + ngot = ngot + 1 + if (iporosity == 1 .or. iporosity == -1) use_porosity = .true. + case('icompact') + read(valstring,*,iostat=ierr) icompact + ngot = ngot + 1 + case('ibounce') + read(valstring,*,iostat=ierr) ibounce + ngot = ngot + 1 + case('idisrupt') + read(valstring,*,iostat=ierr) idisrupt + ngot = ngot + 1 + case('smonocgs') + read(valstring,*,iostat=ierr) smonocgs + ngot = ngot + 1 + case('surfenergSI') + read(valstring,*,iostat=ierr) surfenergSI + ngot = ngot + 1 + case('youngmodSI') + read(valstring,*,iostat=ierr) youngmodSI + ngot = ngot + 1 + case('gammaft') + read(valstring,*,iostat=ierr) gammaft + ngot = ngot + 1 + case default + imatch = .false. + end select + + if ((iporosity == 0) .and. ngot == 1) igotall = .true. + if ((iporosity /= 0) .and. ngot == 8) igotall = .true. + +end subroutine read_options_porosity + +!----------------------------------------------------------------------- +!+ +! Write porosity options to the .setup file +!+ +!----------------------------------------------------------------------- +subroutine write_porosity_setup_options(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + write(iunit,"(/,a)") '# options for porosity' + call write_inopt(iporosity,'iporosity','porosity (0=Off,1=On)',iunit) + call write_inopt(ibounce,'ibounce','bouncing (0=Off,1=On)',iunit) + call write_inopt(idisrupt,'idisrupt','disruption (0=Off,1=On)',iunit) + +end subroutine write_porosity_setup_options + +!----------------------------------------------------------------------- +!+ +! Read growth options from the .setup file +!+ +!----------------------------------------------------------------------- +subroutine read_porosity_setup_options(db,nerr) + use options, only:use_porosity + use infile_utils, only:read_inopt,inopts + type(inopts), allocatable, intent(inout) :: db(:) + integer, intent(inout) :: nerr + + call read_inopt(iporosity,'iporosity',db,min=-1,max=1,errcount=nerr) + if (iporosity == 1 .or. iporosity == -1) use_porosity = .true. + call read_inopt(ibounce,'ibounce',db,min=0,max=1,errcount=nerr) + call read_inopt(idisrupt,'idisrupt',db,min=0,max=1,errcount=nerr) + +end subroutine read_porosity_setup_options + +real function get_coeffrest(vstickvrel,vyieldvrel) + real, intent(in) :: vstickvrel,vyieldvrel + + if (vyieldvrel >= 1.) then + get_coeffrest = sqrt(1.-vstickvrel*vstickvrel) + else + get_coeffrest = sqrt(1.2*sqrt(3.)*(1.-(vyieldvrel*vyieldvrel/6.))*& + sqrt(1./(1.+2.*sqrt((1.2/(vyieldvrel*vyieldvrel))-0.2)))-(vstickvrel*vstickvrel)) + endif + +end function get_coeffrest + +!--velocity limit between full sticking regime and partial sticking + bouncing regime +real function compute_vstick(mass,size) + real, intent(in) ::mass,size + compute_vstick = 8.76*((surfenerg**5 * size**4)/(mass**3*youngmod**2))**(1./6.) +end function + +!--velocity limit between elastic and inelastic bouncing regime +real function compute_vyield(vstick) + real, intent(in) ::vstick + compute_vyield = 10.*vstick +end function + +!--velocity limit between partial sticking + bouncing regime and full bouncing regime +real function compute_vend(vstick) + real, intent(in) ::vstick + compute_vend = 24343220.*vstick +end function + + +end module porosity \ No newline at end of file diff --git a/src/main/readwrite_dumps_common.F90 b/src/main/readwrite_dumps_common.F90 index 5c806bc7b..70c177eb6 100644 --- a/src/main/readwrite_dumps_common.F90 +++ b/src/main/readwrite_dumps_common.F90 @@ -283,7 +283,7 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert return endif if (use_dustgrowth .and. .not.got_dustprop(1)) then - write(*,*) 'ERROR! using dustgrowth, but no grain size found in dump file' + write(*,*) 'ERROR! using dustgrowth, but no grain mass found in dump file' return endif if (use_dustgrowth .and. .not.got_dustprop(1)) then diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 59b870d07..fc03f3162 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -218,10 +218,10 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) maxptmass,get_pmass,h2chemistry,nabundances,abundance,abundance_label,mhd,& divcurlv,divcurlv_label,divcurlB,divcurlB_label,poten,dustfrac,deltav,deltav_label,tstop,& dustfrac_label,tstop_label,dustprop,dustprop_label,eos_vars,eos_vars_label,ndusttypes,ndustsmall,VrelVf,& - VrelVf_label,dustgasprop,dustgasprop_label,dust_temp,pxyzu,pxyzu_label,dens,& !,dvdx,dvdx_label + 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,& iorig,iX,iZ,imu,nucleation,nucleation_label,n_nucleation - use options, only:use_dustfrac,use_var_comp + use options, only:use_dustfrac,use_porosity,use_var_comp use dump_utils, only:tag,open_dumpfile_w,allocate_header,& free_header,write_header,write_array,write_block_header use mpiutils, only:reduce_mpi,reduceall_mpi @@ -360,6 +360,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) call write_array(1,dustprop,dustprop_label,2,npart,k,ipass,idump,nums,ierrs(3)) call write_array(1,VrelVf,VrelVf_label,npart,k,ipass,idump,nums,ierrs(3)) call write_array(1,dustgasprop,dustgasprop_label,4,npart,k,ipass,idump,nums,ierrs(3)) + if (use_porosity) call write_array(1,filfac,filfac_label,npart,k,ipass,idump,nums,ierrs(3)) endif if (h2chemistry) call write_array(1,abundance,abundance_label,nabundances,npart,k,ipass,idump,nums,ierrs(5)) if (use_dust) call write_array(1,dustfrac,dustfrac_label,ndusttypes,npart,k,ipass,idump,nums,ierrs(7)) @@ -498,13 +499,15 @@ end subroutine write_fulldump_fortran subroutine write_smalldump_fortran(t,dumpfile) use dim, only:maxp,maxtypes,use_dust,lightcurve,use_dustgrowth + 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,& npartoftypetot,update_npartoftypetot,& maxphase,iphase,h2chemistry,nabundances,& nptmass,nsinkproperties,xyzmh_ptmass,xyzmh_ptmass_label,& abundance,abundance_label,mhd,dustfrac,iamtype_int11,& - dustprop,dustprop_label,dustfrac_label,ndusttypes,& + dustprop,dustprop_label,dustfrac_label,& + filfac,filfac_label,ndusttypes,& rad,rad_label,do_radiation,maxirad use dump_utils, only:open_dumpfile_w,dump_h,allocate_header,free_header,& write_header,write_array,write_block_header @@ -580,6 +583,7 @@ subroutine write_smalldump_fortran(t,dumpfile) call write_array(1,xyzh,xyzh_label,3,npart,k,ipass,idump,nums,ierr,singleprec=.true.) if (use_dustgrowth) then call write_array(1,dustprop,dustprop_label,2,npart,k,ipass,idump,nums,ierr,singleprec=.true.) + if (use_porosity) call write_array(1,filfac,filfac_label,npart,k,ipass,idump,nums,ierr,singleprec=.true.) endif if (h2chemistry .and. nabundances >= 1) & call write_array(1,abundance,abundance_label,1,npart,k,ipass,idump,nums,ierr,singleprec=.true.) @@ -1108,10 +1112,12 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto alphaind,poten,xyzmh_ptmass,xyzmh_ptmass_label,vxyz_ptmass,vxyz_ptmass_label, & Bevol,Bxyz,Bxyz_label,nabundances,iphase,idust,dustfrac_label, & eos_vars,eos_vars_label,dustprop,dustprop_label,divcurlv,divcurlv_label,iX,iZ,imu, & - VrelVf,VrelVf_label,dustgasprop,dustgasprop_label,pxyzu,pxyzu_label,dust_temp, & - rad,rad_label,radprop,radprop_label,do_radiation,maxirad,maxradprop, & - nucleation,nucleation_label,n_nucleation,ikappa,ithick,itemp,igasP,iorig + VrelVf,VrelVf_label,dustgasprop,dustgasprop_label,filfac,filfac_label, & + pxyzu,pxyzu_label,dust_temp,rad,rad_label,radprop,radprop_label, & + do_radiation,maxirad,maxradprop,nucleation,nucleation_label,n_nucleation, & + ikappa,ithick,itemp,igasP,iorig use eos, only:ieos,eos_is_non_ideal,eos_outputs_gasP + use options, only:use_porosity #ifdef IND_TIMESTEPS use part, only:dt_in #endif @@ -1135,7 +1141,7 @@ 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,got_x,got_z,got_mu logical :: got_nucleation(n_nucleation) logical :: got_psi,got_gasP,got_temp,got_Tdust,got_dustprop(2),got_VrelVf,got_dustgasprop(4), & - got_divcurlv(4),got_raden(maxirad),got_kappa,got_pxyzu(4),got_iorig + got_filfac,got_divcurlv(4),got_raden(maxirad),got_kappa,got_pxyzu(4),got_iorig character(len=lentag) :: tag,tagarr(64) integer :: k,i,iarr,ik,ndustfraci @@ -1157,6 +1163,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto got_temp = .false. got_dustprop = .false. got_VrelVf = .false. + got_filfac = .false. got_dustgasprop = .false. got_divcurlv = .false. got_Tdust = .false. @@ -1198,6 +1205,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto call read_array(dustprop,dustprop_label,got_dustprop,ik,i1,i2,noffset,idisk1,tag,match,ierr) call read_array(VrelVf,VrelVf_label,got_VrelVf,ik,i1,i2,noffset,idisk1,tag,match,ierr) call read_array(dustgasprop,dustgasprop_label,got_dustgasprop,ik,i1,i2,noffset,idisk1,tag,match,ierr) + if (use_porosity) call read_array(filfac,filfac_label,got_filfac,ik,i1,i2,noffset,idisk1,tag,match,ierr) endif if (use_dust) then if (any(tag == dustfrac_label)) then diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 2b27313c1..5feae25c3 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -100,6 +100,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) use dust, only:write_options_dust #ifdef DUSTGROWTH use growth, only:write_options_growth + use porosity, only:write_options_porosity #endif #endif #ifdef PHOTO @@ -249,6 +250,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) call write_options_dust(iwritein) #ifdef DUSTGROWTH call write_options_growth(iwritein) + call write_options_porosity(iwritein) #endif #endif @@ -311,6 +313,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) use dust, only:read_options_dust #ifdef DUSTGROWTH use growth, only:read_options_growth + use porosity, only:read_options_porosity #endif #endif #ifdef GR @@ -347,7 +350,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) integer :: ierr,ireaderr,line,idot,ngot,nlinesread real :: ratio logical :: imatch,igotallrequired,igotallturb,igotalllink,igotloops - logical :: igotallbowen,igotallcooling,igotalldust,igotallextern,igotallinject,igotallgrowth + logical :: igotallbowen,igotallcooling,igotalldust,igotallextern,igotallinject,igotallgrowth,igotallporosity logical :: igotallionise,igotallnonideal,igotalleos,igotallptmass,igotallphoto,igotalldamping logical :: igotallprad,igotalldustform,igotallgw integer, parameter :: nrequired = 1 @@ -363,6 +366,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) igotallturb = .true. igotalldust = .true. igotallgrowth = .true. + igotallporosity = .true. igotallphoto = .true. igotalllink = .true. igotallextern = .true. @@ -513,6 +517,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (.not.imatch) call read_options_dust(name,valstring,imatch,igotalldust,ierr) #ifdef DUSTGROWTH if (.not.imatch) call read_options_growth(name,valstring,imatch,igotallgrowth,ierr) + if (.not.imatch) call read_options_porosity(name,valstring,imatch,igotallporosity,ierr) #endif #endif #ifdef GR @@ -556,11 +561,11 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) enddo close(unit=ireadin) - igotallrequired = (ngot >= nrequired) .and. igotalllink .and. igotallbowen .and. igotalldust & - .and. igotalleos .and. igotallcooling .and. igotallextern .and. igotallturb & - .and. igotallptmass .and. igotallinject .and. igotallionise .and. igotallnonideal & - .and. igotallphoto .and. igotallgrowth .and. igotalldamping .and. igotallprad & - .and. igotalldustform .and. igotallgw + igotallrequired = (ngot >= nrequired) .and. igotalllink .and. igotallbowen .and. igotalldust & + .and. igotalleos .and. igotallcooling .and. igotallextern .and. igotallturb & + .and. igotallptmass .and. igotallinject .and. igotallionise .and. igotallnonideal & + .and. igotallphoto .and. igotallgrowth .and. igotalldamping .and. igotallporosity & + .and. igotallprad .and. igotalldustform .and. igotallgw if (ierr /= 0 .or. ireaderr > 0 .or. .not.igotallrequired) then ierr = 1 @@ -578,6 +583,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (.not.igotallbowen) write(*,*) 'missing Bowen dust options' if (.not.igotalldust) write(*,*) 'missing dust options' if (.not.igotallgrowth) write(*,*) 'missing growth options' + if (.not.igotallporosity) write(*,*) 'missing porosity options' if (.not.igotallphoto) write(*,*) 'missing photoevaporation options' if (.not.igotallextern) write(*,*) 'missing external force options' if (.not.igotallinject) write(*,*) 'missing inject-particle options' diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 7b3449278..b8b5c2432 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -102,7 +102,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) iphase,iamtype,massoftype,maxphase,igas,idust,mhd,& iamboundary,get_ntypes,npartoftypetot,& dustfrac,dustevol,ddustevol,eos_vars,alphaind,nptmass,& - dustprop,ddustprop,dustproppred,ndustsmall,pxyzu,dens,metrics,ics + dustprop,ddustprop,dustproppred,ndustsmall,pxyzu,dens,metrics,ics,& + filfac,filfacpred,mprev,filfacprev use cooling, only:cooling_implicit,ufloor use options, only:avdecayconst,alpha,ieos,alphamax use deriv, only:derivs @@ -129,6 +130,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) #endif use timing, only:increment_timer,get_timings,itimer_extf use growth, only:check_dustprop + use options, only:use_porosity + use porosity, only:get_filfac integer, intent(inout) :: npart integer, intent(in) :: nactive real, intent(in) :: t,dtsph @@ -181,6 +184,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp shared(rad,drad,pxyzu)& !$omp shared(Bevol,dBevol,dustevol,ddustevol,use_dustfrac) & !$omp shared(dustprop,ddustprop,dustproppred,ufloor) & + !$omp shared(mprev,filfacprev,filfac,use_porosity) & #ifdef IND_TIMESTEPS !$omp shared(ibin,ibin_old,twas,timei) & #endif @@ -216,7 +220,10 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) nvfloorp = nvfloorp + 1 endif endif - + if (use_porosity) then + mprev(i) = dustprop(1,i) + filfacprev(i) = filfac(i) + endif if (itype==idust .and. use_dustgrowth) then dustprop(:,i) = dustprop(:,i) + hdti*ddustprop(:,i) endif @@ -231,7 +238,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif enddo predictor !omp end parallel do - if (use_dustgrowth) call check_dustprop(npart,dustprop(1,:)) + if (use_dustgrowth) then + if (use_porosity) then + call get_filfac(npart,xyzh,mprev,filfac,dustprop,hdti) + endif + call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) + endif !---------------------------------------------------------------------- ! substepping with external and sink particle forces, using dtextforce @@ -270,6 +282,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp shared(pxyzu,ppred) & !$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) & !$omp shared(alphaind,ieos,alphamax,ndustsmall,ialphaloc) & !$omp shared(eos_vars,ufloor) & #ifdef IND_TIMESTEPS @@ -328,7 +341,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) nvfloorps = nvfloorps + 1 endif endif - + if (use_porosity) filfacpred(i) = filfac(i) if (use_dustgrowth .and. itype==idust) then dustproppred(:,i) = dustprop(:,i) + hdti*ddustprop(:,i) endif @@ -368,8 +381,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif enddo predict_sph !$omp end parallel do - if (use_dustgrowth) call check_dustprop(npart,dustproppred(1,:)) - + if (use_dustgrowth) then + if (use_porosity) then + call get_filfac(npart,xyzh,dustprop(1,:),filfacpred,dustproppred,hdti) + endif + call check_dustprop(npart,dustproppred(:,:),filfacpred,dustprop(1,:),filfac) + endif ! ! recalculate all SPH forces, and new timestep ! @@ -381,7 +398,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) dt_too_small = .false. call derivs(1,npart,nactive,xyzh,vpred,fxyzu,fext,divcurlv,& divcurlB,Bpred,dBevol,radpred,drad,radprop,dustproppred,ddustprop,& - dustpred,ddustevol,dustfrac,eos_vars,timei,dtsph,dtnew,& + dustpred,ddustevol,filfacpred,dustfrac,eos_vars,timei,dtsph,dtnew,& ppred,dens,metrics) if (gr) vxyzu = vpred ! May need primitive variables elsewhere? if (dt_too_small) then @@ -582,7 +599,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) enddo corrector !$omp enddo !$omp end parallel - if (use_dustgrowth) call check_dustprop(npart,dustprop(1,:)) + if (use_dustgrowth) then + if (use_porosity) then + call get_filfac(npart,xyzh,mprev,filfac,dustprop,dtsph) + endif + call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) + endif if (gr) then call check_velocity_error(errmax,p2mean,np,its,tolv,dtsph,timei,idamp,dterr,errmaxmean,converged) @@ -597,6 +619,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp shared(store_itype,vxyzu,fxyzu,vpred,iphase) & !$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) & !$omp firstprivate(itype) & !$omp schedule(static) @@ -613,6 +636,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vpred(:,i) = vxyzu(:,i) endif if (use_dustgrowth) dustproppred(:,i) = dustprop(:,i) + if (use_porosity) filfacpred(i) = filfac(i) if (mhd) Bpred(:,i) = Bevol(:,i) if (use_dustfrac) dustpred(:,i) = dustevol(:,i) if (do_radiation) radpred(:,i) = rad(:,i) @@ -624,6 +648,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vpred(:,i) = vxyzu(:,i) endif if (use_dustgrowth) dustproppred(:,i) = dustprop(:,i) + if (use_porosity) filfacpred(i) = filfac(i) if (mhd) Bpred(:,i) = Bevol(:,i) if (use_dustfrac) dustpred(:,i) = dustevol(:,i) if (do_radiation) radpred(:,i) = rad(:,i) @@ -649,15 +674,19 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) enddo until_converged !$omp end parallel do - if (use_dustgrowth) call check_dustprop(npart,dustprop(1,:)) - + if (use_dustgrowth) then + if (use_porosity) then + call get_filfac(npart,xyzh,mprev,filfac,dustprop,dtsph) + endif + call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) + endif ! ! get new force using updated velocity: no need to recalculate density etc. ! 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,dustfrac,& - eos_vars,timei,dtsph,dtnew,ppred,dens,metrics) + Bpred,dBevol,radpred,drad,radprop,dustproppred,ddustprop,dustpred,ddustevol,filfacpred,& + dustfrac,eos_vars,timei,dtsph,dtnew,ppred,dens,metrics) if (gr) vxyzu = vpred ! May need primitive variables elsewhere? endif enddo iterations diff --git a/src/main/utils_dumpfiles_hdf5.f90 b/src/main/utils_dumpfiles_hdf5.f90 index d17adf9fc..2aaba3070 100644 --- a/src/main/utils_dumpfiles_hdf5.f90 +++ b/src/main/utils_dumpfiles_hdf5.f90 @@ -464,7 +464,7 @@ subroutine write_hdf5_arrays( & ! Dust growth if (array_options%use_dustgrowth) then - call write_to_hdf5(dustprop(1,1:npart), 'grainsize', group_id, error) + call write_to_hdf5(dustprop(1,1:npart), 'grainmass', group_id, error) call write_to_hdf5(dustprop(2,1:npart), 'graindens', group_id, error) call write_to_hdf5(VrelVf(1:npart), 'vrel_on_vfrag', group_id, error) call write_to_hdf5(dustgasprop(3,1:npart), 'St', group_id, error) @@ -612,7 +612,7 @@ subroutine write_hdf5_arrays_small( & ! Dustgrowth if (array_options%use_dustgrowth) then - call write_to_hdf5(real(dustprop(1,1:npart), kind=4), 'grainsize', group_id, error) + call write_to_hdf5(real(dustprop(1,1:npart), kind=4), 'grainmass', group_id, error) call write_to_hdf5(real(dustprop(2,1:npart), kind=4), 'graindens', group_id, error) endif @@ -927,7 +927,7 @@ subroutine read_hdf5_arrays( & ! Dust growth if (array_options%use_dustgrowth) then - call read_from_hdf5(dustprop(1,:), 'grainsize', group_id, got_arrays%got_dustprop(1), error) + call read_from_hdf5(dustprop(1,:), 'grainmass', group_id, got_arrays%got_dustprop(1), error) call read_from_hdf5(dustprop(2,:), 'graindens', group_id, got_arrays%got_dustprop(2), error) call read_from_hdf5(VrelVf(:), 'vrel_on_vfrag', group_id, got_arrays%got_VrelVf, error) call read_from_hdf5(dustgasprop(3,:), 'St', group_id, got_arrays%got_St, error) diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index 11ebbdc7d..8698af14f 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -78,7 +78,7 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) use dim, only:maxp,maxvxyzu,maxalpha,ndivcurlv,mhd_nonideal,nalpha,use_dust,use_dustgrowth,gr use io, only:iprint use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax - use options, only:tolh,alpha,alphau,alphaB,ieos,alphamax,use_dustfrac + use options, only:tolh,alpha,alphau,alphaB,ieos,alphamax,use_dustfrac,use_porosity use part, only:hfact,massoftype,mhd,& gravity,h2chemistry,periodic,massoftype,npartoftypetot,& labeltype,maxtypes @@ -170,6 +170,7 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) if (h2chemistry) write(iprint,"(1x,a)") 'H2 Chemistry is ON' if (use_dustfrac) write(iprint,"(1x,a)") 'One-fluid dust is ON' if (use_dustgrowth) write(iprint,"(1x,a)") 'Dust growth is ON' + if (use_porosity) write(iprint,"(1x,a)") 'Dust porosity is ON' if (cooling_explicit) write(iprint,"(1x,a)") 'Cooling is explicitly calculated in force' if (cooling_implicit) write(iprint,"(1x,a)") 'Cooling is implicitly calculated in step' if (ufloor > 0.) then diff --git a/src/setup/set_dust_options.f90 b/src/setup/set_dust_options.f90 index c28fe2a78..aaeb663f5 100644 --- a/src/setup/set_dust_options.f90 +++ b/src/setup/set_dust_options.f90 @@ -245,6 +245,7 @@ end subroutine set_log_dist_options !-------------------------------------------------------------------------- subroutine read_dust_setup_options(db,nerr) use growth, only:read_growth_setup_options + use porosity, only:read_porosity_setup_options use infile_utils, only:inopts,read_inopt use io, only:error use fileutils, only:make_tags_unique @@ -441,8 +442,10 @@ subroutine read_dust_setup_options(db,nerr) call read_inopt(graindensinp(1),'graindensinp',db,min=0.,errcount=nerr) endif - if (use_dustgrowth) call read_growth_setup_options(db,nerr) - + if (use_dustgrowth) then + call read_growth_setup_options(db,nerr) + call read_porosity_setup_options(db,nerr) + endif end subroutine read_dust_setup_options !-------------------------------------------------------------------------- @@ -526,6 +529,7 @@ end subroutine read_log_dist_options !-------------------------------------------------------------------------- subroutine write_dust_setup_options(iunit) use growth, only:write_growth_setup_options + use porosity, only:write_porosity_setup_options use infile_utils, only:write_inopt use fileutils, only:make_tags_unique @@ -723,8 +727,11 @@ subroutine write_dust_setup_options(iunit) call write_inopt(isetdust,'isetdust', & 'how to set dust density profile (0=equal to gas,1=custom,2=equal to gas with cutoffs)',iunit) - if (use_dustgrowth) call write_growth_setup_options(iunit) - + if (use_dustgrowth) then + call write_growth_setup_options(iunit) + call write_porosity_setup_options(iunit) + endif + end subroutine write_dust_setup_options !-------------------------------------------------------------------------- diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index a5026ebaf..56c844f4d 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -90,14 +90,15 @@ module setup use extern_binary, only:binarymassr,accradius1,accradius2,ramp,surface_force,eps_soft1 use fileutils, only:make_tags_unique use growth, only:ifrag,isnow,rsnow,Tsnow,vfragSI,vfraginSI,vfragoutSI,gsizemincgs + use porosity, only:iporosity use io, only:master,warning,error,fatal use kernel, only:hfact_default - use options, only:use_dustfrac,iexternalforce,use_hybrid + use options, only:use_dustfrac,iexternalforce,use_hybrid,use_porosity use options, only:use_mcfost,use_mcfost_stellar_parameters,mcfost_computes_Lacc use part, only:xyzmh_ptmass,maxvxyzu,vxyz_ptmass,ihacc,ihsoft,igas,& idust,iphase,dustprop,dustfrac,ndusttypes,ndustsmall,& ndustlarge,grainsize,graindens,nptmass,iamtype,dustgasprop,& - VrelVf,rad,radprop,ikappa,iradxi + VrelVf,filfac,probastick,rad,radprop,ikappa,iradxi use physcon, only:au,solarm,jupiterm,earthm,pi,years use setdisc, only:scaled_sigma,get_disc_mass use set_dust_options, only:set_dust_default_options,dust_method,dust_to_gas,& @@ -1417,6 +1418,7 @@ end subroutine set_planet_atm ! !-------------------------------------------------------------------------- subroutine initialise_dustprop(npart) + use physcon, only:fourpi integer, intent(in) :: npart integer :: i,iam @@ -1425,11 +1427,13 @@ subroutine initialise_dustprop(npart) do i=1,npart iam = iamtype(iphase(i)) if (iam==idust .or. (use_dustfrac .and. iam==igas)) then - dustprop(1,i) = grainsize(1) + dustprop(1,i) = fourpi/3.*graindens(1)*grainsize(1)**3 dustprop(2,i) = graindens(1) else dustprop(:,i) = 0. endif + filfac(i) = 0. + probastick(i) = 1. dustgasprop(:,i) = 0. VrelVf(i) = 0. enddo @@ -2025,6 +2029,8 @@ subroutine setup_interactive() call prompt('Enter outward vfragout in m/s',vfragoutSI,1.) endif endif + call prompt('Enter porosity switch (0=off,1=on)',iporosity,0,1) + if (iporosity == 1) use_porosity = .true. endif endif diff --git a/src/tests/test_dust.F90 b/src/tests/test_dust.F90 index 967a361d5..4baf41db7 100644 --- a/src/tests/test_dust.F90 +++ b/src/tests/test_dust.F90 @@ -171,6 +171,9 @@ subroutine test_dustybox(ntests,npass) real :: t, dt, dtext, dtnew real :: vg, vd, deltav, ekin_exact, fd real :: tol,tolvg,tolfg,tolfd + logical :: write_output = .false. + character(len=60) :: filename + integer, parameter :: lu = 36 if (index(kernelname,'quintic') /= 0) then tol = 1.e-5; tolvg = 2.5e-5; tolfg = 3.3e-4; tolfd = 3.3e-4 @@ -274,18 +277,28 @@ subroutine test_dustybox(ntests,npass) vg = 0.5*(1. - deltav) vd = 0.5*(1. + deltav) fd = K_code(1)*(vg - vd) + if (write_output) then + write(filename,"(a,1pe8.2,a)") 'dustybox_t',t,'.out' + open(unit=lu,file=filename,status='replace') + print "(a)",' writing '//trim(filename) + endif + do j=1,npart if (iamdust(iphase(j))) then call checkvalbuf(vxyzu(1,j),vd,tol,'vd',nerr(1),ncheck(1),errmax(1)) call checkvalbuf(fxyzu(1,j),fd,tolfd,'fd',nerr(2),ncheck(2),errmax(2)) + if (write_output) write(lu,*) vxyzu(1,j),fxyzu(1,j),vd,fd #ifdef DUSTGROWTH call checkvalbuf(dustgasprop(4,j),deltav,toldv,'dv',nerr(6),ncheck(6),errmax(6)) #endif else call checkvalbuf(vxyzu(1,j),vg,tolvg,'vg',nerr(3),ncheck(3),errmax(3)) call checkvalbuf(fxyzu(1,j),-fd,tolfg,'fg',nerr(4),ncheck(4),errmax(4)) + if (write_output) write(lu,*) vxyzu(1,j),fxyzu(1,j),vg,-fd endif enddo + if (write_output) close(lu) + !call checkval(npart/2-1,vxyzu(1,1:npart),vg,tolvg,nerr(2),'vg') ekin_exact = 0.5*totmass*(vd**2 + vg**2) !print*,' step ',i,'t = ',t,' ekin should be ',ekin_exact, ' got ',ekin,(ekin-ekin_exact)/ekin_exact diff --git a/src/tests/test_growth.F90 b/src/tests/test_growth.F90 index 721715b51..41a2ccdbb 100644 --- a/src/tests/test_growth.F90 +++ b/src/tests/test_growth.F90 @@ -115,14 +115,14 @@ subroutine test_farmingbox(ntests,npass,frag,onefluid) use testutils, only:checkvalbuf,checkvalbuf_end use eos, only:ieos,polyk,gamma,get_spsound use dust, only:idrag,init_drag - use growth, only:ifrag,init_growth,isnow,vfrag,wbymass,gsizemincgs + use growth, only:ifrag,init_growth,isnow,vfrag,wbymass,gsizemincgs,get_size use options, only:alpha,alphamax,use_dustfrac use unifdis, only:set_unifdis use dim, only:periodic,mhd,use_dust,maxp,maxalpha use timestep, only:dtmax use io, only:iverbose use mpiutils, only:reduceall_mpi - use physcon, only:au,solarm,Ro,pi + use physcon, only:au,solarm,Ro,pi,fourpi use viscosity, only:shearparam use units, only:set_units,udist,unit_density!,unit_velocity use mpidomain, only:i_belong @@ -161,7 +161,7 @@ subroutine test_farmingbox(ntests,npass,frag,onefluid) dtgratio = 0.5 stringfrag = "fragmentation" else - sinit = 1.e-2/udist + sinit = 3.e-2/udist dtgratio = 1. stringfrag = "growth" endif @@ -231,7 +231,7 @@ subroutine test_farmingbox(ntests,npass,frag,onefluid) VrelVf(i) = 0. if (use_dustfrac) then dustfrac(1,i) = dtgratio - dustprop(1,i) = sinit + dustprop(1,i) = fourpi/3.*dens*sinit**3 dustprop(2,i) = dens else dustprop(:,i) = 0. @@ -257,7 +257,7 @@ subroutine test_farmingbox(ntests,npass,frag,onefluid) if (use_dust) then dustevol(:,i) = 0. dustfrac(:,i) = 0. - dustprop(1,i) = sinit + dustprop(1,i) = fourpi/3.*dens*sinit**3 dustprop(2,i) = dens dustgasprop(:,i) = 0. VrelVf(i) = 0. @@ -355,10 +355,10 @@ subroutine test_farmingbox(ntests,npass,frag,onefluid) s(j) = Stcomp(j)/(sqrt(pi*gamma/8)*dens/((rhog+rhod)*cscomp(j))*Omega_k(j)) if (onefluid) then call checkvalbuf(dustgasprop(3,j)/Stcomp(j),1.,tolst,'St',nerr(1),ncheck(1),errmax(1)) - call checkvalbuf(dustprop(1,j)/s(j),1.,tols,'size',nerr(2),ncheck(2),errmax(2)) + call checkvalbuf(get_size(dustprop(1,j),dustprop(2,j))/s(j),1.,tols,'size',nerr(2),ncheck(2),errmax(2)) else call checkvalbuf(dustgasprop(3,j)/Stcomp(j),1.,tolst,'St',nerr(1),ncheck(1),errmax(1)) - call checkvalbuf(dustprop(1,j)/s(j),1.,tols,'size',nerr(2),ncheck(2),errmax(2)) + call checkvalbuf(get_size(dustprop(1,j),dustprop(2,j))/s(j),1.,tols,'size',nerr(2),ncheck(2),errmax(2)) call checkvalbuf(dustgasprop(1,j)/cscomp(j),1.,tolcs,'csound',nerr(3),ncheck(3),errmax(3)) call checkvalbuf(dustgasprop(2,j)/rhozero,1.,tolrho,'rhogas',nerr(4),ncheck(4),errmax(4)) endif @@ -367,11 +367,11 @@ subroutine test_farmingbox(ntests,npass,frag,onefluid) enddo if (onefluid) then call checkvalbuf_end('Stokes number evaluation matches exact solution',ncheck(1),nerr(1),errmax(1),tolst) - call checkvalbuf_end('size evaluation matches exact solution',ncheck(2),nerr(2),errmax(2),tolcs) + call checkvalbuf_end('size evaluation matches exact solution',ncheck(2),nerr(2),errmax(2),tols) else call checkvalbuf_end('Stokes number interpolation matches exact solution',ncheck(1),nerr(1),errmax(1),tolst) - call checkvalbuf_end('size evaluation matches exact solution',ncheck(2),nerr(2),errmax(2),tolcs) - call checkvalbuf_end('sound speed interpolation matches exact number',ncheck(3),nerr(3),errmax(3),tols) + call checkvalbuf_end('size evaluation matches exact solution',ncheck(2),nerr(2),errmax(2),tols) + call checkvalbuf_end('sound speed interpolation matches exact number',ncheck(3),nerr(3),errmax(3),tolcs) call checkvalbuf_end('rhogas interpolation matches exact number',ncheck(4),nerr(4),errmax(4),tolrho) endif diff --git a/src/utils/moddump_dustadd.f90 b/src/utils/moddump_dustadd.f90 index 0e9f2676d..ff5c872e0 100644 --- a/src/utils/moddump_dustadd.f90 +++ b/src/utils/moddump_dustadd.f90 @@ -17,6 +17,10 @@ module moddump ! :Dependencies: dim, dust, growth, options, part, prompting, set_dust, ! table_utils, units ! + + use part, only:delete_particles_outside_sphere,igas,idust + use prompting, only:prompt + implicit none contains @@ -27,8 +31,9 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) use part, only:igas,idust,set_particle_type,ndusttypes,ndustsmall,ndustlarge,& grainsize,graindens,dustfrac use set_dust, only:set_dustfrac,set_dustbinfrac - use options, only:use_dustfrac + use options, only:use_dustfrac,use_porosity use growth, only:set_dustprop,convert_to_twofluid + use porosity, only:iporosity use prompting, only:prompt use dust, only:grainsizecgs,graindenscgs use table_utils, only:logspace @@ -37,8 +42,13 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) integer, intent(inout) :: npartoftype(:) real, intent(inout) :: massoftype(:) real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real, dimension(3) :: incenter,outcenter integer :: i,j,itype,ipart,iloc,dust_method,np_ratio,np_gas,np_dust,maxdust real :: dust_to_gas,smincgs,smaxcgs,sindex,dustbinfrac(maxdusttypes),udens + integer :: iremoveparttype + real :: inradius,outradius,pwl_sizedistrib,R_ref,H_R_ref,q_index + logical :: icutinside,icutoutside,sizedistrib + if (.not. use_dust) then print*,' DOING NOTHING: COMPILE WITH DUST=yes' @@ -53,6 +63,19 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) smaxcgs = 1. sindex = 3.5 dustbinfrac = 0. + pwl_sizedistrib = -1.55 + R_ref = 100 + H_R_ref = 0.0895 + q_index = 0.25 + + icutinside = .false. + icutoutside = .false. + iremoveparttype = 0 + incenter(:) = 0. + outcenter(:) = 0. + inradius = 10. + outradius = 200. + !- grainsize and graindens already set if convert from one fluid to two fluid with growth if (.not. (use_dustfrac .and. use_dustgrowth)) then grainsize = 1. @@ -95,7 +118,22 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) graindens = graindens(1)/udens else if (use_dustgrowth) then - call prompt('Enter initial grain size in cm',grainsizecgs,0.) + call prompt('Use porosity ? (0=no,1=yes)',iporosity,0,1) + if (iporosity == 1) then + use_porosity = .true. + call prompt('Set dust size via size distribution ?',sizedistrib) + if (sizedistrib) then + call prompt('Enter grain size in cm at Rref',grainsizecgs,0.) + call prompt('Enter power-law index ',pwl_sizedistrib) + call prompt('Enter R_ref ',R_ref,0.) + call prompt('Enter H/R at R_ref',H_R_ref,0.) + call prompt('Enter q index',q_index) + else + call prompt('Enter initial grain size in cm',grainsizecgs,0.) + endif + else + call prompt('Enter initial grain size in cm',grainsizecgs,0.) + endif else call prompt('Enter grain size in cm',grainsizecgs,0.) endif @@ -154,10 +192,63 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) enddo enddo + endif + if (use_dustgrowth) then + call set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_index) + endif + endif + !Delete particles if necessary - if (use_dustgrowth) then - call set_dustprop(npart) - endif + ! + !--set the centers and the radius + ! + 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 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 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)) + endif + + if (icutinside .or. icutoutside) then + call prompt('Deleting which particles (0=all, 1=gas only, 2=dust only)?', iremoveparttype) + ! add other types of particles here if needed + select case (iremoveparttype) + case (1) + iremoveparttype = igas + case (2) + iremoveparttype = idust + case default + iremoveparttype = 0 + end select + endif + + if (icutinside) then + print*,'Phantommoddump: Remove particles inside a particular radius' + print*,'Removing particles inside radius ',inradius + if (iremoveparttype > 0) then + print*,'Removing particles type ',iremoveparttype + call delete_particles_outside_sphere(incenter,inradius,npart,revert=.true.,mytype=iremoveparttype) + else + call delete_particles_outside_sphere(incenter,inradius,npart,revert=.true.) + endif + endif + + if (icutoutside) then + print*,'Phantommoddump: Remove particles outside a particular radius' + print*,'Removing particles outside radius ',outradius + if (iremoveparttype > 0) then + print*,'Removing particles type ',iremoveparttype + call delete_particles_outside_sphere(outcenter,outradius,npart,mytype=iremoveparttype) + else + call delete_particles_outside_sphere(outcenter,outradius,npart) endif endif diff --git a/src/utils/moddump_removeparticles_radius.f90 b/src/utils/moddump_removeparticles_radius.f90 index 754ae678c..f5b0676ba 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,igas,idust use prompting, only:prompt implicit none @@ -31,15 +31,10 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) real, dimension(:), intent(inout) :: massoftype real, dimension(:,:), intent(inout) :: xyzh,vxyzu real, dimension(3) :: incenter,outcenter + integer :: iremoveparttype real :: inradius,outradius logical :: icutinside,icutoutside - icutinside = .false. - icutoutside = .false. - incenter(:) = 0. - outcenter(:) = 0. - inradius = 10. - outradius = 200. ! !--set the centers and the radius @@ -59,16 +54,37 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call prompt('Enter z coordinate of the center of that sphere',outcenter(3)) endif + call prompt('Deleting which particles (0=all, 1=gas only, 2=dust only)?', iremoveparttype) + ! add other types of particles here if needed + select case (iremoveparttype) + case (1) + iremoveparttype = igas + case (2) + iremoveparttype = idust + case default + iremoveparttype = 0 + end select + 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.) + if (iremoveparttype > 0) then + print*,'Removing particles type ',iremoveparttype + call delete_particles_outside_sphere(incenter,inradius,npart,revert=.true.,mytype=iremoveparttype) + else + call delete_particles_outside_sphere(incenter,inradius,npart,revert=.true.) + endif 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) + if (iremoveparttype > 0) then + print*,'Removing particles type ',iremoveparttype + call delete_particles_outside_sphere(outcenter,outradius,npart,mytype=iremoveparttype) + else + call delete_particles_outside_sphere(outcenter,outradius,npart) + endif endif end subroutine modify_dump From 29ec1fd65449f594adfe5f3e8a34ab0b95a60cef Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Tue, 14 Feb 2023 14:21:07 +1100 Subject: [PATCH 014/814] bug --- 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 1a90b6c88..25f2e3ea5 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -1128,7 +1128,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto eos_vars,eos_vars_label,dustprop,dustprop_label,divcurlv,divcurlv_label,iX,iZ,imu, & VrelVf,VrelVf_label,dustgasprop,dustgasprop_label,filfac,filfac_label, & pxyzu,pxyzu_label,dust_temp, rad,rad_label,radprop,radprop_label,do_radiation, & - maxirad,maxradprop,nucleation,nucleation_label,n_nucleation,ikappa,,tau,itau_alloc, & + maxirad,maxradprop,nucleation,nucleation_label,n_nucleation,ikappa,tau,itau_alloc, & ithick,itemp,igasP,iorig use sphNGutils, only:mass_sphng,got_mass,set_gas_particle_mass use eos, only:ieos,eos_is_non_ideal,eos_outputs_gasP From 06639110f7a14d2418ac7b5c56a23ab912764691 Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Tue, 21 Feb 2023 12:34:33 +1100 Subject: [PATCH 015/814] added erosion with mass rate loss --- src/main/growth.F90 | 102 +++++++++++++++++++++++++++++++++++--------- 1 file changed, 83 insertions(+), 19 deletions(-) diff --git a/src/main/growth.F90 b/src/main/growth.F90 index 3aa5a8cd9..59fba4348 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.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-2022 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.bitbucket.io/ ! !--------------------------------------------------------------------------! @@ -20,13 +20,17 @@ module growth ! - flyby : *use primary for keplerian freq. calculation* ! - force_smax : *(mcfost) set manually maximum size for binning* ! - grainsizemin : *minimum allowed grain size in cm* +! - stokesmin : *minimum allowed Stokes number when porosity is on* ! - ifrag : *fragmentation of dust (0=off,1=on,2=Kobayashi)* +! - ieros : *erosion of dust (0=off,1=on) ! - isnow : *snow line (0=off,1=position based,2=temperature based)* ! - rsnow : *snow line position in AU* ! - size_max_user : *(mcfost) maximum size for binning in cm* ! - vfrag : *uniform fragmentation threshold in m/s* ! - vfragin : *inward fragmentation threshold in m/s* ! - vfragout : *inward fragmentation threshold in m/s* +! - cohacc : *strength of the cohesive acceleration in g/s^2* +! - dsize : *size of ejected grain during erosion in cm* ! - wbymass : *weight dustgasprops by mass rather than mass/density* ! ! :Dependencies: checkconserved, dim, dust, eos, infile_utils, io, options, @@ -40,20 +44,25 @@ module growth !--Default values for the growth and fragmentation of dust in the input file integer, public :: ifrag = 1 integer, public :: isnow = 0 + integer, public :: ieros = 0 real, public :: gsizemincgs = 5.e-3 + real, public :: stokesmin = 1.e-4 real, public :: rsnow = 100. real, public :: Tsnow = 150. real, public :: vfragSI = 15. real, public :: vfraginSI = 5. real, public :: vfragoutSI = 15. + real, public :: cohacccgs = 100 + real, public :: dsizecgs = 1.0e-3 real, public :: vfrag real, public :: vref real, public :: vfragin real, public :: vfragout real, public :: grainsizemin - real, public :: stmin + real, public :: cohacc + real, public :: dsize logical, public :: wbymass = .true. @@ -91,7 +100,8 @@ subroutine init_growth(ierr) vfragout = vfragoutSI * 100 / unit_velocity rsnow = rsnow * au / udist grainsizemin = gsizemincgs / udist - stmin = gsizemincgs + cohacc = cohacccgs * utime * utime / umass + dsize = dsizecgs / udist if (ifrag > 0) then if (grainsizemin < 0.) then @@ -141,6 +151,17 @@ subroutine init_growth(ierr) endif endif + if (ieros == 1) then + if (cohacc < 0) then + call error('init_growth','cohacc < 0',var='cohacc',val=cohacc) + ierr = 5 + endif + if (dsize < 0) then + call error('init_growth','dsize < 0',var='dsize',val=dsize) + ierr = 5 + endif + endif + end subroutine init_growth !---------------------------------------------------------- @@ -174,6 +195,10 @@ subroutine print_growthinfo(iprint) write(iprint,"(2(a,1pg10.3),a)") ' vfragin = ',vfragoutSI,' m/s = ',vfragout,' (code units)' endif endif + if (ieros == 1) then + write(iprint,"(a)") ' Using aeolian-erosion model where ds = -fourpi*rhos*rhog*s*(deltav**3)*(dsize**2)/(3*cohacc)*dt ' + write(iprint,"(2(a,1pg10.3),a)")' dsize = ',dsizecgs,' cm = ',dsize,' (code units)' + endif end subroutine print_growthinfo @@ -250,6 +275,7 @@ subroutine get_growth_rate(npart,xyzh,vxyzu,dustgasprop,VrelVf,dustprop,filfac,d dmdt(i) = -fourpi*sdust**2*rhod*vrel*(VrelVf(i)**2)/(1+VrelVf(i)**2) ! Kobayashi model end select endif + if (ieros == 1) dsdt(i) = dsdt(i) - fourpi*sdust*dustprop(2,i)*dustgasprop(2,i)*(dustgasprop(4,i)**3)*(dsize**2)/(3.*cohacc) ! Erosion model endif else dmdt(i) = 0. @@ -335,14 +361,20 @@ end subroutine comp_snow_line !----------------------------------------------------------------------- subroutine write_options_growth(iunit) use infile_utils, only:write_inopt + use options, only:use_porosity integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling growth' call write_inopt(wbymass,'wbymass','weight dustgasprops by mass rather than mass/density',iunit) if (nptmass > 1) call write_inopt(this_is_a_flyby,'flyby','use primary for keplerian freq. calculation',iunit) call write_inopt(ifrag,'ifrag','dust fragmentation (0=off,1=on,2=Kobayashi)',iunit) + call write_inopt(ieros,'ieros','erosion of dust (0=off,1=on)',iunit) if (ifrag /= 0) then - call write_inopt(gsizemincgs,'grainsizemin','minimum grain size in cm (min St if porosity)',iunit) + if (use_porosity) then + call write_inopt(stokesmin,'stokesmin','minimum allowed stokes number',iunit) + else + call write_inopt(gsizemincgs,'grainsizemin','minimum grain size in cm',iunit) + endif call write_inopt(isnow,'isnow','snow line (0=off,1=position based,2=temperature based)',iunit) if (isnow == 1) call write_inopt(rsnow,'rsnow','position of the snow line in AU',iunit) if (isnow == 2) call write_inopt(Tsnow,'Tsnow','snow line condensation temperature in K',iunit) @@ -352,6 +384,11 @@ subroutine write_options_growth(iunit) call write_inopt(vfragoutSI,'vfragout','outward fragmentation threshold in m/s',iunit) endif endif + if (ieros == 1) then + call write_inopt(cohacccgs,'cohacc','strength of the cohesive acceleration in g/s^2',iunit) + call write_inopt(dsizecgs,'dsize','size of ejected grain during erosion in cm',iunit) + endif + #ifdef MCFOST call write_inopt(f_smax,'force_smax','(mcfost) set manually maximum size for binning',iunit) call write_inopt(size_max,'size_max_user','(mcfost) maximum size for binning in cm',iunit) @@ -372,6 +409,7 @@ subroutine read_options_growth(name,valstring,imatch,igotall,ierr) integer,save :: ngot = 0 integer :: imcf = 0 + integer :: goteros = 1 logical :: tmp = .false. imatch = .true. @@ -381,9 +419,15 @@ subroutine read_options_growth(name,valstring,imatch,igotall,ierr) case('ifrag') read(valstring,*,iostat=ierr) ifrag ngot = ngot + 1 + case('ieros') + read(valstring,*,iostat=ierr) ieros + ngot = ngot + 1 case('grainsizemin') read(valstring,*,iostat=ierr) gsizemincgs ngot = ngot + 1 + case('stokesmin') + read(valstring,*,iostat=ierr) stokes + ngot = ngot + 1 case('isnow') read(valstring,*,iostat=ierr) isnow ngot = ngot + 1 @@ -402,6 +446,12 @@ subroutine read_options_growth(name,valstring,imatch,igotall,ierr) case('vfragout') read(valstring,*,iostat=ierr) vfragoutSI ngot = ngot + 1 + case('cohacc') + read(valstring,*,iostat=ierr) cohacccgs + ngot = ngot + 1 + case('dsize') + read(valstring,*,iostat=ierr) dsizecgs + ngot = ngot + 1 case('flyby') read(valstring,*,iostat=ierr) this_is_a_flyby ngot = ngot + 1 @@ -428,21 +478,23 @@ subroutine read_options_growth(name,valstring,imatch,igotall,ierr) imcf = 3 #endif + if (ieros == 1) goteros = 2 + if (nptmass > 1 .or. tmp) then - if ((ifrag <= 0) .and. ngot == 3+imcf) igotall = .true. + if ((ifrag <= 0) .and. ngot == 3+imcf+goteros) igotall = .true. if (isnow == 0) then - if (ngot == 6+imcf) igotall = .true. + if (ngot == 6+imcf+goteros) igotall = .true. elseif (isnow > 0) then - if (ngot == 8+imcf) igotall = .true. + if (ngot == 8+imcf+goteros) igotall = .true. else igotall = .false. endif else - if ((ifrag <= 0) .and. ngot == 2+imcf) igotall = .true. + if ((ifrag <= 0) .and. ngot == 2+imcf+goteros) igotall = .true. if (isnow == 0) then - if (ngot == 5+imcf) igotall = .true. + if (ngot == 5+imcf+goteros) igotall = .true. elseif (isnow > 0) then - if (ngot == 7+imcf) igotall = .true. + if (ngot == 7+imcf+goteros) igotall = .true. else igotall = .false. endif @@ -457,18 +509,24 @@ end subroutine read_options_growth !----------------------------------------------------------------------- subroutine write_growth_setup_options(iunit) use infile_utils, only:write_inopt + use options, only:use_porosity integer, intent(in) :: iunit write(iunit,"(/,a)") '# options for growth and fragmentation of dust' call write_inopt(ifrag,'ifrag','fragmentation of dust (0=off,1=on,2=Kobayashi)',iunit) + call write_inopt(ieros,'ieros','erosion of dust (0=off,1=on)',iunit) call write_inopt(isnow,'isnow','snow line (0=off,1=position based,2=temperature based)',iunit) call write_inopt(rsnow,'rsnow','snow line position in AU',iunit) call write_inopt(Tsnow,'Tsnow','snow line condensation temperature in K',iunit) call write_inopt(vfragSI,'vfrag','uniform fragmentation threshold in m/s',iunit) call write_inopt(vfraginSI,'vfragin','inward fragmentation threshold in m/s',iunit) call write_inopt(vfragoutSI,'vfragout','inward fragmentation threshold in m/s',iunit) - call write_inopt(gsizemincgs,'grainsizemin','minimum allowed grain size in cm',iunit) + if (use_porosity) then + call write_inopt(stokesmin,'stokesmin','minimum allowed stokes number',iunit) + else + call write_inopt(gsizemincgs,'grainsizemin','minimum allowed grain size in cm',iunit) + endif end subroutine write_growth_setup_options @@ -479,13 +537,19 @@ end subroutine write_growth_setup_options !----------------------------------------------------------------------- subroutine read_growth_setup_options(db,nerr) use infile_utils, only:read_inopt,inopts + use options, only:use_porosity type(inopts), allocatable, intent(inout) :: db(:) integer, intent(inout) :: nerr call read_inopt(ifrag,'ifrag',db,min=-1,max=2,errcount=nerr) + call read_inopt(ieros,'ieros',db,min=0,max=1,errcount=nerr) if (ifrag > 0) then call read_inopt(isnow,'isnow',db,min=0,max=2,errcount=nerr) - call read_inopt(gsizemincgs,'grainsizemin',db,min=1.e-5,errcount=nerr) + if (use_porosity) then + call read_inopt(stokesmin,'stokesmin',db,min=1.e-5,errcount=nerr) + else + call read_inopt(gsizemincgs,'grainsizemin',db,min=1.e-5,errcount=nerr) + endif select case(isnow) case(0) call read_inopt(vfragSI,'vfrag',db,min=0.,errcount=nerr) @@ -514,7 +578,7 @@ subroutine check_dustprop(npart,dustprop,filfac,mprev,filfacprev) integer,intent(in) :: npart real, intent(in) :: filfac(:),mprev(:),filfacprev(:) integer :: i,iam - real :: stnew,sdustprev,sdustmin,sdust + real :: stokesnew,sdustprev,sdustmin,sdust do i=1,npart iam = iamtype(iphase(i)) @@ -522,9 +586,9 @@ subroutine check_dustprop(npart,dustprop,filfac,mprev,filfacprev) if (use_porosity) then sdustprev = get_size(mprev(i),dustprop(2,i),filfacprev(i)) sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) - stnew = dustgasprop(3,i)*sdustprev*filfacprev(i)/sdust/filfac(i) - if (stnew < stmin) then - sdustmin = stmin*sdustprev*filfacprev(i)/filfac(i)/dustgasprop(3,i) + stokesnew = dustgasprop(3,i)*sdustprev*filfacprev(i)/sdust/filfac(i) + if (stokesnew < stokesmin) then + sdustmin = stokesmin*sdustprev*filfacprev(i)/filfac(i)/dustgasprop(3,i) dustprop(1,i) = dustprop(1,i) * (sdustmin/sdust)**3. endif else @@ -551,7 +615,7 @@ subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_i integer, intent(in) :: npart real, intent(in) :: xyzh(:,:) integer :: i,iam - real :: r,z,h + real :: r,h logical, optional, intent(in) :: sizedistrib real, optional, intent(in) :: pwl_sizedistrib,R_ref,H_R_ref,q_index @@ -559,9 +623,9 @@ subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_i iam = iamtype(iphase(i)) if (iam == idust .or. (iam == igas .and. use_dustfrac)) then dustprop(2,i) = graindenscgs / unit_density - r = sqrt(xyzh(1,i)**2 + xyzh(2,i)**2) - h = H_R_ref * R_ref * au / udist * (r * udist / au / R_ref)**(1.5-q_index) if (sizedistrib) then + r = sqrt(xyzh(1,i)**2 + xyzh(2,i)**2) + h = H_R_ref * R_ref * au / udist * (r * udist / au / R_ref)**(1.5-q_index) dustprop(1,i) = grainsizecgs/udist * (r * udist / au / R_ref)**pwl_sizedistrib * exp(-0.5*xyzh(3,i)**2/h**2) dustprop(1,i) = fourpi/3. * dustprop(2,i) * (dustprop(1,i))**3 else From 82360436bc0a6d04749374ff564af02449b074a4 Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Fri, 3 Mar 2023 10:39:57 +1100 Subject: [PATCH 016/814] added threshold for erosion --- src/main/growth.F90 | 78 ++++++++++++++++++++++++++------------------- 1 file changed, 45 insertions(+), 33 deletions(-) diff --git a/src/main/growth.F90 b/src/main/growth.F90 index 59fba4348..6702aee4c 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -36,7 +36,7 @@ module growth ! :Dependencies: checkconserved, dim, dust, eos, infile_utils, io, options, ! part, physcon, table_utils, units, viscosity ! - use units, only:udist,unit_density,unit_velocity + use units, only:udist,umass,utime,unit_density,unit_velocity use physcon, only:au,Ro use part, only:xyzmh_ptmass,nptmass,this_is_a_flyby implicit none @@ -275,7 +275,9 @@ subroutine get_growth_rate(npart,xyzh,vxyzu,dustgasprop,VrelVf,dustprop,filfac,d dmdt(i) = -fourpi*sdust**2*rhod*vrel*(VrelVf(i)**2)/(1+VrelVf(i)**2) ! Kobayashi model end select endif - if (ieros == 1) dsdt(i) = dsdt(i) - fourpi*sdust*dustprop(2,i)*dustgasprop(2,i)*(dustgasprop(4,i)**3)*(dsize**2)/(3.*cohacc) ! Erosion model + if (ieros == 1 .and. (dustgasprop(4,i) >= 0.110905*sqrt(1.65*utime*utime/umass/dustprop(2,i)/dsize))) then + dmdt(i) = dmdt(i) - fourpi*sdust*dustprop(2,i)*dustgasprop(2,i)*(dustgasprop(4,i)**3)*(dsize**2)/(3.*cohacc) ! Erosion model + endif endif else dmdt(i) = 0. @@ -426,7 +428,7 @@ subroutine read_options_growth(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) gsizemincgs ngot = ngot + 1 case('stokesmin') - read(valstring,*,iostat=ierr) stokes + read(valstring,*,iostat=ierr) stokesmin ngot = ngot + 1 case('isnow') read(valstring,*,iostat=ierr) isnow @@ -658,43 +660,50 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) real, intent(in) :: smax_user logical, intent(inout) :: force_smax logical, intent(in) :: verbose - real :: smaxtmp,smintmp,smax,smin,tolm,& + real :: smaxtmp,smintmp,smax,smin,tolm,fmintmp,fmaxtmp,fmin,fmax,& mdustold,mdustnew,code_to_mum logical :: init - integer :: nbins,nbinmax,i,j,itype,ndustold,ndustnew,npartmin,imerge,iu - real, allocatable, dimension(:) :: grid, sdust - character(len=20) :: outfile = "bin_distrib.dat" + integer :: nbinsize,nbinsizemax,i,j,itype,ndustold,ndustnew,npartmin,imerge,iu + integer :: nbinfilfac,nbinfilfacmax,ndustsizetypes,ndustfilfactypes + real, allocatable, dimension(: ) :: grid + real, allocatable, dimension(:,:) :: dustpropmcfost !dustpropmcfost(1=size,2=filfac) + character(len=20) :: outfile = "bin_distrib.dat" !- initialise - code_to_mum = udist*1.e4 - tolm = 1.e-5 - smaxtmp = 0. - smintmp = 1.e26 - ndustold = 0 - ndustnew = 0 - mdustold = 0. - mdustnew = 0. - nbinmax = 25 - npartmin = 50 !- limit to find neighbours - init = .false. - graindens = maxval(dustprop(2,:)) + code_to_mum = udist*1.e4 + tolm = 1.e-5 + smaxtmp = 0. + smintmp = 1.e26 + ndustold = 0 + ndustnew = 0 + mdustold = 0. + mdustnew = 0. + nbinsizemax = 25 + nbinfilfacmax = 10 + npartmin = 50 !- limit to find neighbours + init = .false. + !graindens = maxval(dustprop(2,:)) !- loop over particles, find min and max on non-accreted dust particles do i = 1,npart itype = iamtype(iphase(i)) if (itype==idust) then if (use_porosity) then - sdust(i) = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) + dustpropmcfost(1,i) = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) + dustpropmcfost(2,i) = filfac(i) else - sdust(i) = get_size(dustprop(1,i),dustprop(2,i)) + dustpropmcfost(1,i) = get_size(dustprop(1,i),dustprop(2,i)) + dustpropmcfost(2,i) = 1 endif - if (sdust(i) < smintmp) smintmp = sdust(i) - if (sdust(i) > smaxtmp) smaxtmp = sdust(i) + if (dustpropmcfost(1,i) < smintmp) smintmp = dustpropmcfost(1,i) + if (dustpropmcfost(1,i) > smaxtmp) smaxtmp = dustpropmcfost(1,i) + !if (dustpropmcfost(2,i) < fmintmp) fmintmp = dustpropmcfost(2,i) + !if (dustpropmcfost(2,i) > fmaxtmp) fmaxtmp = dustpropmcfost(2,i) endif enddo !- overrule force_smax if particles are small, avoid empty bins - if ((maxval(sdust(:))*udist < smax_user) .and. force_smax) then + if ((maxval(dustpropmcfost(1,:))*udist < smax_user) .and. force_smax) then force_smax = .false. write(*,*) "Overruled force_smax from T to F" endif @@ -706,28 +715,31 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) smax = smaxtmp else init = .true. - write(*,*) "Detected initial condition, restraining nbins = 1" + write(*,*) "Detected initial condition, restraining nbinsize = 1" endif if (.not. init) then smin = smintmp !- set ndusttypes based on desired log size spacing - nbins = int((log10(smax)-log10(smin))*bins_per_dex + 1.) - ndusttypes = min(nbins, nbinmax) !- prevent memory allocation errors - ndustlarge = ndusttypes !- this is written to the header + nbinsize = int((log10(smax)-log10(smin))*bins_per_dex + 1.) + !nbinfilfac = int((log10(smax)-log10(smin))*bins_per_dex + 1.) + ndustsizetypes = min(nbinsize, nbinsizemax) !- prevent memory allocation errors + !ndustfilfactypes = min(nbinfilfac,nbinfilfacmax) + ndustlarge = ndustsizetypes!*ndustfilfactypes !- this is written to the header !- allocate memory for a grid of ndusttypes+1 elements - allocate(grid(ndusttypes+1)) + allocate(grid(ndustsizetypes+1))!,ndustfilfactypes)) !- bin sizes in ndusttypes bins write(*,"(a,f10.1,a,f10.1,a,i3,a)") "Binning sizes between ",smin*code_to_mum, " (µm) and ",& smax*code_to_mum," (µm) in ",ndusttypes, " bins" - call logspace(grid(1:ndusttypes+1),smin,smax) !- bad for live mcfost, need to compile it before growth.F90 + call logspace(grid(1:ndustsizetypes+1),smin,smax) !- bad for live mcfost, need to compile it before growth.F90 + !call logspace(grid(2,1:ndustfilfactypes),fmin,fmax) !- find representative size for each bin - do i = 1,ndusttypes + do i = 1,ndustsizetypes grainsize(i) = sqrt(grid(i)*grid(i+1)) enddo @@ -739,7 +751,7 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) if (itype==idust) then !- figure out which bin do j=1,ndusttypes - if ((sdust(i) >= grid(j)) .and. (sdust(i) < grid(j+1))) then + if ((dustpropmcfost(1,i) >= grid(j)) .and. (dustpropmcfost(1,i) < grid(j+1))) then if (j > 1) then npartoftype(idust+j-1) = npartoftype(idust+j-1) + 1 npartoftype(idust) = npartoftype(idust) - 1 @@ -747,7 +759,7 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) endif endif !- if smax has been forced, put larger grains inside last bin - if ((j==ndusttypes) .and. force_smax .and. (sdust(i) >= grid(j+1))) then + if ((j==ndusttypes) .and. force_smax .and. (dustpropmcfost(1,i) >= grid(j+1))) then npartoftype(idust+j-1) = npartoftype(idust+j-1) + 1 npartoftype(idust) = npartoftype(idust) - 1 call set_particle_type(i,idust+j-1) From 09e337c1b2d566cdadef5abb93104e5ce1cf9996 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Fri, 17 Mar 2023 15:12:19 +1100 Subject: [PATCH 017/814] Major update with shell-crossing,exact interp, etc. --- build/Makefile_setups | 2 +- src/main/cons2primsolver.f90 | 22 +- src/main/deriv.F90 | 5 +- src/main/evolve.F90 | 27 +- src/main/extern_gr.F90 | 180 +++- src/main/initial.F90 | 25 +- src/main/metric_et.f90 | 58 +- src/main/metric_tools.F90 | 9 +- src/main/readwrite_dumps_fortran.F90 | 23 +- src/main/tmunu2grid.f90 | 362 ++++++-- src/main/utils_gr.F90 | 67 +- src/main/utils_infiles.f90 | 24 +- src/setup/phantomsetup.F90 | 3 +- src/setup/set_unifdis.f90 | 7 +- src/setup/setup_flrw.f90 | 558 ++++++++++++ src/setup/stretchmap.f90 | 34 +- src/utils/einsteintk_utils.f90 | 141 ++- src/utils/einsteintk_wrapper.f90 | 332 ++++++- src/utils/interpolate3D.F90 | 1192 +++++++++++++++++++------- src/utils/interpolate3Dold.F90 | 367 ++++++++ 20 files changed, 2984 insertions(+), 454 deletions(-) create mode 100644 src/setup/setup_flrw.f90 create mode 100644 src/utils/interpolate3Dold.F90 diff --git a/build/Makefile_setups b/build/Makefile_setups index 6610ecb1a..db1eba5af 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -930,7 +930,7 @@ ifeq ($(SETUP), flrw) KNOWN_SETUP=yes IND_TIMESTEPS=no METRIC=et - SETUPFILE= setup_unifdis.f90 + SETUPFILE= setup_flrw.f90 PERIODIC=yes endif diff --git a/src/main/cons2primsolver.f90 b/src/main/cons2primsolver.f90 index 3894890f1..d6305f19a 100644 --- a/src/main/cons2primsolver.f90 +++ b/src/main/cons2primsolver.f90 @@ -149,7 +149,6 @@ subroutine conservative2primitive(x,metrici,v,dens,u,P,rho,pmom,en,ierr,ien_type case default call conservative2primitive_con_gamma(x,metrici,v,dens,u,P,gamma,enth,rho,pmom,en,ierr,ien_type) end select - end subroutine conservative2primitive !---------------------------------------------------------------- @@ -159,7 +158,7 @@ end subroutine conservative2primitive !+ !---------------------------------------------------------------- subroutine conservative2primitive_var_gamma(x,metrici,v,dens,u,P,rho,pmom,en,ierr,ien_type) - use utils_gr, only:get_sqrtg + use utils_gr, only:get_sqrtg, get_sqrt_gamma use metric_tools, only:unpack_metric use units, only:unit_ergg,unit_density,unit_pressure use eos, only:calc_temp_and_ene,ieos @@ -171,7 +170,7 @@ subroutine conservative2primitive_var_gamma(x,metrici,v,dens,u,P,rho,pmom,en,ier integer, intent(in) :: ien_type real, dimension(1:3,1:3) :: gammaijUP real :: sqrtg,sqrtg_inv,enth,lorentz_LEO,pmom2,alpha,betadown(1:3),betaUP(1:3),enth_old,v3d(1:3) - real :: f,term,lorentz_LEO2,gamfac,pm_dot_b,gamma,gamma_old,temp,sqrt_gamma_inv + real :: f,term,lorentz_LEO2,gamfac,pm_dot_b,gamma,gamma_old,temp,sqrt_gamma_inv,sqrt_gamma real :: u_in,P_in,dens_in,ucgs,Pcgs,denscgs,enth0,gamma0,enth_min,enth_max real :: enth_rad,enth_gas,gamma_rad,gamma_gas integer :: niter,i,ierr1,ierr2 @@ -180,7 +179,7 @@ subroutine conservative2primitive_var_gamma(x,metrici,v,dens,u,P,rho,pmom,en,ier logical :: converged real :: gcov(0:3,0:3) ierr = 0 - + ! Get metric components from metric array call unpack_metric(metrici,gcov=gcov,gammaijUP=gammaijUP,alpha=alpha,betadown=betadown,betaUP=betaUP) @@ -195,7 +194,10 @@ subroutine conservative2primitive_var_gamma(x,metrici,v,dens,u,P,rho,pmom,en,ier niter = 0 converged = .false. - sqrt_gamma_inv = alpha*sqrtg_inv ! get determinant of 3 spatial metric + + !sqrt_gamma_inv = alpha*sqrtg_inv ! get determinant of 3 spatial metric + call get_sqrt_gamma(gcov,sqrt_gamma) + sqrt_gamma_inv = 1./sqrt_gamma term = rho*sqrt_gamma_inv pm_dot_b = dot_product(pmom,betaUP) @@ -300,7 +302,7 @@ end subroutine conservative2primitive_var_gamma !+ !---------------------------------------------------------------- subroutine conservative2primitive_con_gamma(x,metrici,v,dens,u,P,gamma,enth,rho,pmom,en,ierr,ien_type) - use utils_gr, only:get_sqrtg + use utils_gr, only:get_sqrtg,get_sqrt_gamma use metric_tools, only:unpack_metric use eos, only:calc_temp_and_ene,ieos real, intent(in) :: x(1:3),metrici(:,:,:),gamma @@ -311,7 +313,7 @@ subroutine conservative2primitive_con_gamma(x,metrici,v,dens,u,P,gamma,enth,rho, integer, intent(in) :: ien_type real, dimension(1:3,1:3) :: gammaijUP real :: sqrtg,sqrtg_inv,lorentz_LEO,pmom2,alpha,betadown(1:3),betaUP(1:3),enth_old,v3d(1:3) - real :: f,df,term,lorentz_LEO2,gamfac,pm_dot_b,sqrt_gamma_inv + real :: f,df,term,lorentz_LEO2,gamfac,pm_dot_b,sqrt_gamma_inv,sqrt_gamma integer :: niter, i real, parameter :: tol = 1.e-3 integer, parameter :: nitermax = 100000 @@ -332,11 +334,15 @@ subroutine conservative2primitive_con_gamma(x,metrici,v,dens,u,P,gamma,enth,rho, enddo ! Guess enthalpy (using previous values of dens and pressure) + ! Use a better guess for dens; dens = dens_old/a^3 + !enth = 1 + gamma/(gamma-1.)*P/(dens*sqrtg_inv) enth = 1 + gamma/(gamma-1.)*P/dens niter = 0 converged = .false. + call get_sqrt_gamma(gcov,sqrt_gamma) sqrt_gamma_inv = alpha*sqrtg_inv ! get determinant of 3 spatial metric + !sqrt_gamma_inv = 1./sqrt_gamma term = rho*sqrt_gamma_inv gamfac = gamma/(gamma-1.) pm_dot_b = dot_product(pmom,betaUP) @@ -378,6 +384,7 @@ subroutine conservative2primitive_con_gamma(x,metrici,v,dens,u,P,gamma,enth,rho, if (.not.converged) ierr = 1 + lorentz_LEO = sqrt(1.+pmom2/enth**2) dens = term/lorentz_LEO @@ -398,6 +405,7 @@ subroutine conservative2primitive_con_gamma(x,metrici,v,dens,u,P,gamma,enth,rho, call get_u(u,P,dens,gamma) + end subroutine conservative2primitive_con_gamma end module cons2primsolver diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index fa47baef9..b19f39725 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -128,7 +128,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& if (gr) then ! Recalculate the metric after moving particles to their new tasks call init_metric(npart,xyzh,metrics) - call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) + !call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) endif #ifdef PERIODIC @@ -225,7 +225,7 @@ end subroutine derivs subroutine get_derivs_global(tused,dt_new) use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,& - dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol + dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol,tmunus,metricderivs use timing, only:printused,getused use io, only:id,master real(kind=4), intent(out), optional :: tused @@ -233,6 +233,7 @@ subroutine get_derivs_global(tused,dt_new) real(kind=4) :: t1,t2 real :: dtnew real :: time,dt + integer :: i time = 0. dt = 0. diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 95862650a..08cce8446 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -53,11 +53,12 @@ module evolve logical :: use_global_dt contains -subroutine evol_init(infile,logfile,evfile,dumpfile,dt_et) +subroutine evol_init(infile,logfile,evfile,dumpfile,dt_et,numpart) ! Initialises all the required variables/files required for a run character(len=*), intent(in) :: infile character(len=*), intent(inout) :: logfile,evfile,dumpfile real, intent(in) :: dt_et + integer, intent(out) :: numpart integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold #ifdef IND_TIMESTEPS integer :: nalive,inbin @@ -146,12 +147,13 @@ subroutine evol_init(infile,logfile,evfile,dumpfile,dt_et) call setup_timers call flush(iprint) + numpart = npart end subroutine evol_init subroutine evol_step(infile,logfile,evfile,dumpfile,dt_et) use evwrite, only:write_evfile,write_evlog - use dim, only:maxvxyzu,mhd,periodic + use dim, only:maxvxyzu,mhd,periodic,gr use fileutils, only:getnextfilename use readwrite_infile, only:write_infile @@ -206,10 +208,10 @@ subroutine evol_step(infile,logfile,evfile,dumpfile,dt_et) #ifdef BINPOS use mf_write, only:binpos_write #endif -#ifdef GR - use extern_gr - use tmunu2grid -#endif +! #ifdef GR +! use extern_gr +! use tmunu2grid +! #endif character(len=*), intent(in) :: infile character(len=*), intent(inout) :: logfile,evfile,dumpfile @@ -240,8 +242,6 @@ subroutine evol_step(infile,logfile,evfile,dumpfile,dt_et) ! set the dtmax to be et dt? dtmax = dt_et dt = dt_et - print*, "In evolve step!" - print*, "Time in phantom is: ", time #ifdef INJECT_PARTICLES ! ! injection of new particles into simulation @@ -270,7 +270,6 @@ subroutine evol_step(infile,logfile,evfile,dumpfile,dt_et) call fatal('evolve','error in individual timesteps') endif - print*, "before set active particles" !--flag particles as active or not for this timestep call set_active_particles(npart,nactive,nalive,iphase,ibin,xyzh) nactivetot = reduceall_mpi('+', nactive) @@ -303,21 +302,13 @@ subroutine evol_step(infile,logfile,evfile,dumpfile,dt_et) !--evolve data for one timestep ! for individual timesteps this is the shortest timestep ! - print*, "before get timings" call get_timings(t1,tcpu1) if ( use_sts ) then - print*, "before step indv" call step_sts(npart,nactive,time,dt,dtextforce,dtnew,iprint) else - print*, "before step" call step(npart,nactive,time,dt,dtextforce,dtnew) - print*, "after step" endif - ! Calculate the stress energy tensor - call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - ! Interpolate stress energy tensor from particles back - ! to grid - call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) + ! ! Strang splitting: implicit update for another half step ! diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 810cec2dd..358e40159 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -19,7 +19,7 @@ module extern_gr ! implicit none - public :: get_grforce, get_grforce_all, update_grforce_leapfrog, get_tmunu_all + public :: get_grforce, get_grforce_all, update_grforce_leapfrog, get_tmunu_all, get_tmunu_all_exact, get_tmunu private @@ -244,25 +244,75 @@ subroutine get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) endif if (.not.isdead_or_accreted(xyzh(4,i))) then pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) - call get_tmunu(xyzh(:,i),metrics(:,:,:,i), metricderivs(:,:,:,i), & + call get_tmunu(xyzh(:,i),metrics(:,:,:,i),& vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i),verbose) endif enddo !print*, "tmunu calc val is: ", tmunus(0,0,5) end subroutine get_tmunu_all +subroutine get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + use eos, only:ieos,get_pressure + use part, only:isdead_or_accreted + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) + real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) + real :: pi + integer :: i + logical :: firstpart + real :: tmunu(4,4) + !print*, "entered get tmunu_all_exact" + tmunu = 0. + firstpart = .true. + ! TODO write openmp parallel code + do i=1, npart + if (.not.isdead_or_accreted(xyzh(4,i)) .and. firstpart) then + pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) + call get_tmunu_exact(xyzh(:,i),metrics(:,:,:,i), metricderivs(:,:,:,i), & + vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i)) + !print*, "finished get_tmunu call!" + firstpart = .false. + !print*, "tmunu: ", tmunu + !print*, "tmunus: ", tmunus(:,:,i) + tmunu(:,:) = tmunus(:,:,i) + !print*, "Got tmunu val: ", tmunu + !stop + else + !print*, "setting tmunu for part: ", i + tmunus(:,:,i) = tmunu(:,:) + endif + + enddo + !print*, "tmunu calc val is: ", tmunus(0,0,5) +end subroutine get_tmunu_all_exact + + ! Subroutine to calculate the covariant form of the stress energy tensor ! For a particle at position p -subroutine get_tmunu(x,metrici,metricderivsi,v,dens,u,p,tmunu,verbose) +subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) use metric_tools, only:unpack_metric - real, intent(in) :: x(3),metrici(:,:,:),metricderivsi(0:3,0:3,3),v(3),dens,u,p + use utils_gr, only:get_u0 + real, intent(in) :: x(3),metrici(:,:,:),v(3),dens,u,p real, intent(out) :: tmunu(0:3,0:3) + real :: tmunucon(0:3,0:3) logical, optional, intent(in) :: verbose - real :: w,v4(0:3),vcov(3),lorentz + real :: w,v4(0:3),vcov(3),lorentz,bigV(3),uzero real :: gcov(0:3,0:3), gcon(0:3,0:3) real :: gammaijdown(1:3,1:3),betadown(3),alpha real :: velshiftterm - integer :: i,j + integer :: i,j,ierr + + ! Reference for all the variables used in this routine: + ! w - the enthalpy + ! gcov - the covariant form of the metric tensor + ! gcon - the contravariant form of the metric tensor + ! gammaijdown - the covariant form of the spatial metric + ! alpha - the lapse + ! betadown - the covariant component of the shift + ! v4 - the uppercase 4 velocity in covariant form + ! v - the fluid velocity v^x + ! vcov - the covariant form of big V_i + ! bigV - the uppercase contravariant V^i ! Calculate the enthalpy w = 1 + u + p/dens @@ -272,6 +322,7 @@ subroutine get_tmunu(x,metrici,metricderivsi,v,dens,u,p,tmunu,verbose) !print*, "Before unpack metric " call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) !print*, "After unpack metric" + if (present(verbose) .and. verbose) then ! Do we get sensible values print*, "Unpacked metric quantities..." @@ -280,12 +331,111 @@ subroutine get_tmunu(x,metrici,metricderivsi,v,dens,u,p,tmunu,verbose) print*, "gammaijdown: ", gammaijdown print* , "alpha: ", alpha print*, "betadown: ", betadown + print*, "v4: ", v4 endif + + ! ! Need to change Betadown to betaup + ! ! Won't matter at this point as it is allways zero + ! ! get big V + ! bigV(:) = (v(:) + betadown)/alpha + + ! ! We need the covariant version of the 3 velocity + ! ! gamma_ij v^j = v_i where gamma_ij is the spatial metric + ! do i=1, 3 + ! vcov(i) = gammaijdown(i,1)*bigv(1) + gammaijdown(i,2)*bigv(2) + gammaijdown(i,3)*bigv(3) + ! enddo + + + ! ! Calculate the lorentz factor + ! lorentz = (1. - (vcov(1)*bigv(1) + vcov(2)*bigv(2) + vcov(3)*bigv(3)))**(-0.5) + + ! ! Calculate the 4-velocity + ! velshiftterm = vcov(1)*betadown(1) + vcov(2)*betadown(2) + vcov(3)*betadown(3) + ! v4(0) = lorentz*(-alpha + velshiftterm) + ! ! This should be vcov not v + ! v4(1:3) = lorentz*vcov(1:3) + + + ! We are going to use the same Tmunu calc as force GR + ! And then lower it using the metric + ! i.e calc T^{\mu\nu} and then lower it using the metric + ! tensor + ! lower-case 4-velocity (contravariant) + v4(0) = 1. + v4(1:3) = v(:) + + ! first component of the upper-case 4-velocity (contravariant) + call get_u0(gcov,v,uzero,ierr) + + ! Stress energy tensor in contravariant form + do j=0,3 + do i=0,3 + tmunucon(i,j) = dens*w*uzero*uzero*v4(i)*v4(j) + p*gcon(i,j) + enddo + enddo + + ! Lower the stress energy tensor using the metric + ! This gives you T^{\mu}_nu + do j=0,3 + do i=0,3 + tmunu(i,j) = gcov(j,0)*tmunucon(i,0) & + + gcov(j,1)*tmunucon(i,1) + gcov(j,2)*tmunucon(i,2) + gcov(j,3)*tmunucon(i,3) + enddo + enddo + + ! Repeating it again gives T_{\mu\nu} + do j=0,3 + do i=0,3 + tmunu(i,j) = gcov(i,0)*tmunu(0,j) & + + gcov(i,1)*tmunu(1,j) + gcov(i,2)*tmunu(2,j) + gcov(i,3)*tmunu(3,j) + enddo + enddo + ! Check that the calculated diagonials are equal to 1/tmuncon + + if (present(verbose) .and. verbose) then + ! Do we get sensible values + print*, "Unpacked metric quantities..." + print*, "gcov: ", gcov + print*, "gcon: ", gcon + print*, "gammaijdown: ", gammaijdown + print* , "alpha: ", alpha + print*, "betadown: ", betadown + print*, "v4: ", v4 + endif + + if (verbose) then + print*, "tmunu part: ", tmunu + print*, "dens: ", dens + print*, "w: ", w + print*, "p: ", p + print*, "gcov: ", gcov + endif +end subroutine get_tmunu + +subroutine get_tmunu_exact(x,metrici,metricderivsi,v,dens,u,p,tmunu) + use metric_tools, only:unpack_metric + use utils_gr, only:get_sqrtg + real, intent(in) :: x(3),metrici(:,:,:),metricderivsi(0:3,0:3,3),v(3),dens,u,p + real, intent(out) :: tmunu(0:3,0:3) + real :: w,v4(0:3),vcov(3),lorentz + real :: gcov(0:3,0:3), gcon(0:3,0:3) + real :: gammaijdown(1:3,1:3),betadown(3),alpha + real :: velshiftterm + real :: rhostar,rhoprim,negsqrtg + integer :: i,j + + ! Calculate the enthalpy + ! enthalpy should be 1 as we have zero pressure + ! or should have zero pressure + w = 1 + ! Calculate the exact value of density from conserved density + + call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) ! We need the covariant version of the 3 velocity ! gamma_ij v^j = v_i where gamma_ij is the spatial metric do i=1, 3 - vcov(i) = gammaijdown(i,1)*v4(1) + gammaijdown(i,2)*v4(2) + gammaijdown(i,3)*v4(3) + vcov(i) = gammaijdown(i,1)*v(1) + gammaijdown(i,2)*v(2) + gammaijdown(i,3)*v(3) enddo ! Calculate the lorentz factor @@ -296,15 +446,21 @@ subroutine get_tmunu(x,metrici,metricderivsi,v,dens,u,p,tmunu,verbose) v4(0) = lorentz*(-alpha + velshiftterm) v4(1:3) = lorentz*v(1:3) + rhostar = 13.294563008157013D0 + call get_sqrtg(gcov,negsqrtg) + ! Set/Calculate primitive density using rhostar exactly + rhoprim = rhostar/(negsqrtg/alpha) + + ! Stress energy tensor do j=0,3 do i=0,3 - tmunu(i,j) = dens*w*v4(i)*v4(j) + p*gcov(i,j) + tmunu(i,j) = rhoprim*w*v4(i)*v4(j) ! + p*gcov(i,j) neglect the pressure term as we don't care enddo enddo - if (verbose) then - print*, "tmunu part: ", tmunu - endif -end subroutine get_tmunu + + + +end subroutine get_tmunu_exact end module extern_gr diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 456436138..b958bf4dd 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -136,7 +136,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use part, only:metricderivs,tmunus use cons2prim, only:prim2consall use eos, only:ieos - use extern_gr, only:get_grforce_all,get_tmunu_all + use extern_gr, only:get_grforce_all,get_tmunu_all,get_tmunu_all_exact use metric_tools, only:init_metric,imet_minkowski,imetric use einsteintk_utils use tmunu2grid @@ -417,25 +417,24 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) endif #ifndef PRIM2CONS_FIRST -! COMPUTE METRIC HERE - call print_etgrid - print*, "Before init metric!" + !print*, "Before init metric!" call init_metric(npart,xyzh,metrics,metricderivs) - print*, "metric val is: ", metrics(:,:,:,1) - print*, "Before prims2consall" + !print*, "metric val is: ", metrics(:,:,:,1) + !print*, "Before prims2consall" + !print*, "Density value before prims2cons: ", dens(1) call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) + !print*, "Density value after prims2cons: ", dens(1) #endif if (iexternalforce > 0 .and. imetric /= imet_minkowski) then call initialise_externalforces(iexternalforce,ierr) if (ierr /= 0) call fatal('initial','error in external force settings/initialisation') - print*, "Before get_grforce_all" + !print*, "Before get_grforce_all" call get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtextforce) - print*, "Before get_tmunu_all" - call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - print*, "get_tmunu_all finished!" - !print*, "tmunus: ", tmunus - !stop - call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) + !print*, "Before get_tmunu_all" + !call get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + !call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + !print*, "get_tmunu_all finished!" + !call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac=.true.) endif #else if (iexternalforce > 0) then diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index 5392fc1de..d3d8ceda4 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -93,11 +93,16 @@ pure subroutine get_metric_spherical(position,gcov,gcon,sqrtg) end subroutine get_metric_spherical pure subroutine metric_cartesian_derivatives(position,dgcovdx, dgcovdy, dgcovdz) + use einsteintk_utils, only:gridinit real, intent(in) :: position(3) real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3), dgcovdz(0:3,0:3) - !dgcovdx = 0. - dgcovdy = 0. - dgcovdz = 0. + if (.not. gridinit) then + dgcovdx = 0. + dgcovdy = 0. + dgcovdz = 0. + else + call interpolate_metric_derivs(position,dgcovdx,dgcovdy,dgcovdz) + endif end subroutine metric_cartesian_derivatives pure subroutine metric_spherical_derivatives(position,dgcovdr, dgcovdtheta, dgcovdphi) @@ -174,11 +179,12 @@ pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) ! linear and cubic interpolators should be moved to their own subroutine ! away from eos_shen use eos_shen, only:linear_interpolator_one_d - use einsteintk_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid + use einsteintk_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid,gridsize,gridorigin real, intent(in) :: position(3) real, intent(out) :: gcov(0:3,0:3) real, intent(out), optional :: gcon(0:3,0:3), sqrtg - integer :: xlower,ylower,zlower,xupper,yupper,zupper + integer :: xlower,ylower,zlower,xupper,yupper,zupper + real :: xlowerpos,ylowerpos,zlowerpos real :: xd,yd,zd real :: interptmp(7) integer :: i,j @@ -192,12 +198,22 @@ pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) ! Get neighbours call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) !print*,"Neighbours: ", xlower,ylower,zlower - xupper = xlower + 1 - yupper = yupper + 1 - zupper = zupper + 1 - xd = (position(1) - xlower)/(xupper - xlower) - yd = (position(2) - ylower)/(yupper - ylower) - zd = (position(3) - zlower)/(zupper - zlower) + ! This is not true as upper neighbours on the boundary will be on the side + ! take a mod of grid size + xupper = mod(xlower + 1, gridsize(1)) + yupper = mod(ylower + 1, gridsize(2)) + zupper = mod(zlower + 1, gridsize(3)) + ! xupper - xlower should always just be dx provided we are using a uniform grid + ! xd = (position(1) - xlower)/(xupper - xlower) + ! yd = (position(2) - ylower)/(yupper - ylower) + ! zd = (position(3) - zlower)/(zupper - zlower) + xlowerpos = gridorigin(1) + (xlower-1)*dxgrid(1) + ylowerpos = gridorigin(2) + (ylower-1)*dxgrid(2) + zlowerpos = gridorigin(3) + (zlower-1)*dxgrid(3) + + xd = (position(1) - xlowerpos)/(dxgrid(1)) + yd = (position(2) - ylowerpos)/(dxgrid(2)) + zd = (position(3) - zlowerpos)/(dxgrid(3)) interptmp = 0. ! All the interpolation should go into an interface, then you should just call trilinear_interp @@ -270,13 +286,13 @@ pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) end subroutine interpolate_metric -subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) +pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) use eos_shen, only:linear_interpolator_one_d - use einsteintk_utils, only:metricderivsgrid, dxgrid + use einsteintk_utils, only:metricderivsgrid, dxgrid,gridorigin real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3),dgcovdz(0:3,0:3) real, intent(in) :: position(3) integer :: xlower,ylower,zlower,xupper,yupper,zupper - real :: xd,yd,zd + real :: xd,yd,zd,xlowerpos, ylowerpos,zlowerpos real :: interptmp(7) integer :: i,j @@ -285,9 +301,17 @@ subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) xupper = xlower + 1 yupper = yupper + 1 zupper = zupper + 1 - xd = (position(1) - xlower)/(xupper - xlower) - yd = (position(2) - ylower)/(yupper - ylower) - zd = (position(3) - zlower)/(zupper - zlower) + ! xd = (position(1) - xlower)/(xupper - xlower) + ! yd = (position(2) - ylower)/(yupper - ylower) + ! zd = (position(3) - zlower)/(zupper - zlower) + + xlowerpos = gridorigin(1) + (xlower-1)*dxgrid(1) + ylowerpos = gridorigin(2) + (ylower-1)*dxgrid(2) + zlowerpos = gridorigin(3) + (zlower-1)*dxgrid(3) + + xd = (position(1) - xlowerpos)/(dxgrid(1)) + yd = (position(2) - ylowerpos)/(dxgrid(2)) + zd = (position(3) - zlowerpos)/(dxgrid(3)) interptmp = 0. diff --git a/src/main/metric_tools.F90 b/src/main/metric_tools.F90 index 93ab7b46b..1ccdac0bc 100644 --- a/src/main/metric_tools.F90 +++ b/src/main/metric_tools.F90 @@ -186,7 +186,8 @@ subroutine init_metric(npart,xyzh,metrics,metricderivs) real, intent(out) :: metrics(:,:,:,:) real, optional, intent(out) :: metricderivs(:,:,:,:) integer :: i - + + !$omp parallel do default(none) & !$omp shared(npart,xyzh,metrics) & !$omp private(i) @@ -194,7 +195,7 @@ subroutine init_metric(npart,xyzh,metrics,metricderivs) call pack_metric(xyzh(1:3,i),metrics(:,:,:,i)) enddo !omp end parallel do - + if (present(metricderivs)) then !$omp parallel do default(none) & !$omp shared(npart,xyzh,metricderivs) & @@ -204,7 +205,7 @@ subroutine init_metric(npart,xyzh,metrics,metricderivs) enddo !omp end parallel do endif - + end subroutine init_metric ! @@ -262,4 +263,6 @@ pure subroutine unpack_metric(metrici,gcov,gcon,gammaijdown,gammaijUP,alpha,beta end subroutine unpack_metric + + end module metric_tools diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 59b870d07..807881f67 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -220,7 +220,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) dustfrac_label,tstop_label,dustprop,dustprop_label,eos_vars,eos_vars_label,ndusttypes,ndustsmall,VrelVf,& VrelVf_label,dustgasprop,dustgasprop_label,dust_temp,pxyzu,pxyzu_label,dens,& !,dvdx,dvdx_label rad,rad_label,radprop,radprop_label,do_radiation,maxirad,maxradprop,itemp,igasP,& - iorig,iX,iZ,imu,nucleation,nucleation_label,n_nucleation + iorig,iX,iZ,imu,nucleation,nucleation_label,n_nucleation,metrics,metricderivs,tmunus use options, only:use_dustfrac,use_var_comp use dump_utils, only:tag,open_dumpfile_w,allocate_header,& free_header,write_header,write_array,write_block_header @@ -370,8 +370,27 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) enddo endif if (gr) then + ! TODO these should only be outputed ifmetric==ET call write_array(1,pxyzu,pxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,ierrs(8)) call write_array(1,dens,'dens prim',npart,k,ipass,idump,nums,ierrs(8)) + ! Should include a metrics label somewhere to clean this up + call write_array(1,metrics(1,1,1,:), 'gtt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + ! call write_array(1,metrics(1,2,1,:), 'gtx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + ! call write_array(1,metrics(1,3,1,:), 'gty (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + ! call write_array(1,metrics(1,2,1,:), 'gtz (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + ! call write_array(1,metrics(1,2,1,:), 'gtx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metrics(2,2,1,:), 'gxx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metrics(3,3,1,:), 'gyy (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metrics(4,4,1,:), 'gzz (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + + call write_array(1,metricderivs(1,1,1,:), 'dxgtt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metricderivs(2,2,1,:), 'dxgxx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metricderivs(3,3,1,:), 'dxgyy (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metricderivs(4,4,1,:), 'dxgzz (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + + + call write_array(1,tmunus(1,1,:), 'tmunutt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,1/tmunus(1,1,:), 'tmunutt (contravariant)',npart,k,ipass,idump,nums,ierrs(8)) endif if (eos_is_non_ideal(ieos) .and. .not.store_dust_temperature) then call write_array(1,eos_vars(itemp,:),eos_vars_label(itemp),npart,k,ipass,idump,nums,ierrs(12)) @@ -391,7 +410,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) 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) + call write_array(1,xyzh,xyzh_label,1,npart,k,ipass,idump,nums,ierrs(14),use_kind=8,index=4) if (maxalpha==maxp) call write_array(1,alphaind,(/'alpha'/),1,npart,k,ipass,idump,nums,ierrs(15)) !if (maxalpha==maxp) then ! (uncomment this to write alphaloc to the full dumps) ! call write_array(1,alphaind,(/'alpha ','alphaloc'/),2,npart,k,ipass,idump,nums,ierrs(10)) diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index 4aef9871b..dd4197484 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -2,20 +2,35 @@ module tmunu2grid implicit none contains - subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) - use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid + subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) + use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid use interpolations3D, only: interpolate3D use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax - use part, only: massoftype,igas,rhoh + use part, only: massoftype,igas,rhoh,dens,hfact integer, intent(in) :: npart - real, intent(in) :: xyzh(:,:), vxyzu(:,:), tmunus(:,:,:) - real :: weight,h,rho,pmass + real, intent(in) :: vxyzu(:,:), tmunus(:,:,:) + real, intent(inout) :: xyzh(:,:) + logical, intent(in), optional :: calc_cfac + real :: weight,h,rho,pmass,rhoexact + real :: weights(npart) + real, save :: cfac + integer, save :: iteration = 0 real :: xmininterp(3) integer :: ngrid(3) real,allocatable :: datsmooth(:,:,:), dat(:) integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper - logical :: normalise + logical :: normalise, vertexcen,periodicx,periodicy,periodicz,exact_rendering + real :: totalmass, totalmassgrid + integer :: itype(npart) + + ! total mass of the particles + totalmass = npart*massoftype(igas) + + !print*, "totalmass(part): ", totalmass + + ! Density interpolated to the grid + rhostargrid = 0. if (.not. allocated(datsmooth)) allocate (datsmooth(gridsize(1),gridsize(2),gridsize(3))) if (.not. allocated(dat)) allocate (dat(npart)) ! All particles have equal weighting in the interp @@ -26,93 +41,156 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) pmass = massoftype(igas) ! Get density rho = rhoh(h,pmass) - call get_weight(pmass,h,rho,weight) + ! Correct for Kernel Bias, find correction factor + ! Wrap this into it's own subroutine + if (present(calc_cfac)) then + if (calc_cfac) call get_cfac(cfac,rho) + endif + + weights = weight + itype = 1 + !call get_cfac(cfac,rho) !print*, "Weighting for particle smoothing is: ", weight !weight = 1. ! For now we can set this to the origin, but it might need to be ! set to the grid origin of the CCTK_grid since we have boundary points ! TODO This should also be the proper phantom values and not a magic number !xmin(:) = gridorigin(:) - 0.5*dxgrid(:) ! We move the origin back by 0.5*dx to make a pseudo cell-centered grid - xmininterp(1) = xmin - xmininterp(2) = ymin - xmininterp(3) = zmin + xmininterp(1) = xmin -dxgrid(1) !- 0.5*dxgrid(1) + xmininterp(2) = ymin -dxgrid(2) !- 0.5*dxgrid(2) + xmininterp(3) = zmin-dxgrid(3) !- 0.5*dxgrid(3) - !print*, "xmin: ", xmin - !print*, "xmax: ", xmax call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) - !print*, "ivals: ", ilower, iupper ! nnodes is just the size of the mesh ! might not be needed ! We note that this is not actually the size of the einstein toolkit grid ! As we want our periodic boundary to be on the particle domain not the ! ET grid domain - ngrid(1) = (iupper-ilower) - ngrid(2) = (jupper-jlower) - ngrid(3) = (kupper-klower) + ngrid(1) = (iupper-ilower) + 1 + ngrid(2) = (jupper-jlower) + 1 + ngrid(3) = (kupper-klower) + 1 nnodes = (iupper-ilower)*(jupper-jlower)*(kupper-klower) ! Do we want to normalise interpolations? normalise = .true. + ! Is our NR GRID vertex centered? + vertexcen = .false. + periodicx = .true. + periodicy = .true. + periodicz = .true. - !print*, "ngrid: ", ngrid - !print*,"tmunu val: ", tmunus(:,:,1) ! tt component tmunugrid = 0. + datsmooth = 0. + ! TODO Unroll this loop for speed + using symmetries + ! Possiblly cleanup the messy indexing do k=1,4 do j=1,4 do i=1, npart dat(i) = tmunus(k,j,i) - ! if (dat(i) < 1.0 .and. i > 4) then - ! print*, "dat: ", dat(i) - ! print*, "i is: ", i - ! stop - ! endif enddo - !print*, "gcov: ", gcovgrid(:,:,1,1,1) - !print*, "tmunugrid: ", tmunugrid(:,:,1,1,1) - ! print*, "k,j :", k, j - ! print*, "Dat: ", dat(1:30) ! Get the position of the first grid cell x,y,z - ! print*, "x position of 1, 1, 1", gridorigin(:) - ! print*, "x position of 1,1,1 calculated (cell centered)", xmin(1) + (1.-0.5)*dxgrid(1) ! Call to interpolate 3D - call interpolate3D(xyzh,weight,npart, & - xmininterp,tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper), & - nnodes,dxgrid,normalise,dat,ngrid) + ! COMMENTED OUT AS NOT USED BY NEW INTERPOLATE ROUTINE + ! call interpolate3D(xyzh,weight,npart, & + ! xmininterp,tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper), & + ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) !print*, "Interpolated grid values are: ", datsmooth(4:38,4:38,4:38) + !stop + ! NEW INTERPOLATION ROUTINE + call interpolate3D(xyzh,weights,dat,itype,npart,& + xmininterp(1),xmininterp(2),xmininterp(3), & + tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper),& + ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& + normalise,periodicx,periodicy,periodicz) enddo - enddo - ! do i=4,35 - ! do j=4,35 - ! do k=4,35 - ! if (tmunugrid(0,0,i,j,k) > 1.0008253314232896) then - ! print*, "tmunugrid: ", tmunugrid(0,0,i,j,k) - ! print*, "i,j,k: ", i,j,k - ! print*, "grid position i : ", gridorigin(1) + i*dxgrid(1) - ! print*, "grid position j : ", gridorigin(2) + j*dxgrid(2) - ! print*, "grid position k : ", gridorigin(3) + k*dxgrid(3) - - ! !stop - ! endif + enddo + + ! RHOSTARGRID CALCULATION IS NOW HANDLED BY AN EXTERNAL ROUTINE + ! THIS IS COMMENTED OUT IN CASE I BREAK EVERYTHING AND NEED TO GO BACK + ! Get the conserved density on the particles + ! dat = 0. + ! do i=1, npart + ! ! Get the smoothing length + ! h = xyzh(4,i) + ! ! Get pmass + ! pmass = massoftype(igas) + ! rho = rhoh(h,pmass) + ! dat(i) = rho + ! enddo + + ! Commented out as not used by new interpolate routine + ! call interpolate3D(xyzh,weight,npart, & + ! xmininterp,rhostargrid(ilower:iupper,jlower:jupper,klower:kupper), & + ! nnodes,dxgrid,.true.,dat,ngrid,vertexcen) + + + ! Calculate the total mass on the grid + !totalmassgrid = 0. + ! do i=ilower,iupper + ! do j=jlower,jupper + ! do k=klower, kupper + ! totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) + ! enddo ! enddo - ! enddo - !print*, "tmunugrid: ", tmunugrid(0,0,5,5,5:35) - !stop + ! enddo + ! Explicitly set pressure to be 0 + ! Need to do this in the phantom setup file later + ! tmunugrid(1,0:3,:,:,:) = 0. + ! tmunugrid(2,0:3,:,:,:) = 0. + ! tmunugrid(3,0:3,:,:,:) = 0. + !tmunugrid(0,0,:,:,:) = tmunus(1,1,1) + ! Correction for kernel bias code + ! Hardcoded values for the cubic spline computed using + ! a constant density flrw universe. + ! Ideally this should be in a more general form + ! cfac = totalmass/totalmassgrid + ! ! Output total mass on grid, total mass on particles + ! ! and the residuals + ! !cfac = 0.99917535781746514D0 + ! tmunugrid = tmunugrid*cfac + ! if (iteration==0) then + ! write(666,*) "iteration ", "Mass(Grid) ", "Mass(Particles) ", "Mass(Grid-Particles)" + ! endif + ! write(666,*) iteration, totalmassgrid, totalmass, abs(totalmassgrid-totalmass) + ! close(unit=666) + ! iteration = iteration + 1 + + ! New rho/smoothing length calc based on correction?? + ! not sure that this is a valid thing to do + ! do i=1, npart + ! rho = rhoh(xyzh(i,4),pmass) + ! rho = rho*cfac + ! xyzh(i,4) = hfact*(pmass/rho)**(1./3.) + + ! enddo + + ! Correct rhostargrid using cfac + !rhostargrid = cfac*rhostargrid + + ! Calculate rho(prim), P and e on the grid + ! Apply kernel correction to primatives?? + ! Then calculate a stress energy tensor per grid and fill tmunu + ! A good consistency check would be to do it both ways and compare values + + ! Primative density + + end subroutine get_tmunugrid_all subroutine get_weight(pmass,h,rhoi,weight) real, intent(in) :: pmass,h,rhoi real, intent(out) :: weight - weight = (pmass*h**3.)/rhoi + weight = (pmass)/(rhoi*h**3) end subroutine get_weight @@ -122,14 +200,194 @@ subroutine get_dat(tmunus,dat) end subroutine get_dat + ! subroutine get_primdens(dens,dat) + ! real, intent(in) :: dens + ! real, intent(out) :: dat + ! integer :: i, npart + + ! ! Get the primative density on the particles + ! dat = 0. + ! do i=1, npart + ! dat(i) = dens(i) + ! enddo + + ! end subroutine get_primdens + + ! subroutine get_4velocity(vxyzu,dat) + ! real, intent(in) :: vxyzu(:,:) + ! real, intent(out) :: dat(:,:) + ! integer :: i,npart + + ! ! Get the primative density on the particles + ! dat = 0. + ! do i=1, npart + ! dat(:,i) = vxyzu(1:3,i) + ! enddo + + ! end subroutine get_4velocity + subroutine get_particle_domain(gridorigin,xmin,xmax,dxgrid,ilower,iupper) real, intent(in) :: gridorigin, xmin,xmax, dxgrid integer, intent(out) :: ilower, iupper + ! Changed from int to nint + ! to fix a bug + ilower = nint((xmin - gridorigin)/dxgrid) + 1 ! +1 since our arrays start at 1 not 0 + iupper = nint((xmax - gridorigin)/dxgrid) ! Removed the +1 as this was also a bug + ! The lower boundary is in the physical + ! domain but the upper is not; can't have both? + end subroutine get_particle_domain - ilower = int((xmin - gridorigin)/dxgrid) + 1 ! +1 since our arrays start at 1 not 0 - iupper = int((xmax - gridorigin)/dxgrid) + 1 + subroutine get_cfac(cfac,rho) + real, intent(in) :: rho + real, intent(out) :: cfac + real :: rhoexact + rhoexact = 13.294563008157013D0 + cfac = rhoexact/rho - end subroutine get_particle_domain + end subroutine get_cfac + + subroutine interpolate_to_grid(gridarray,dat) + use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid + use interpolations3D, only: interpolate3D + use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax + use part, only:npart,xyzh,massoftype,igas,rhoh,dens,hfact + real :: weight,h,rho,pmass,rhoexact + real, save :: cfac + integer, save :: iteration = 0 + real :: xmininterp(3) + integer :: ngrid(3) + integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper + logical :: normalise, vertexcen,periodicx, periodicy, periodicz + real :: totalmass, totalmassgrid + real, dimension(npart) :: weights + integer, dimension(npart) :: itype + real, intent(out) :: gridarray(:,:,:) ! Grid array to interpolate a quantity to + ! GRID MUST BE RESTRICTED WITH UPPER AND LOWER INDICIES + real, intent(in) :: dat(:) ! The particle data to interpolate to grid + real, allocatable :: interparray(:,:,:) + + + xmininterp(1) = xmin - dxgrid(1)!- 0.5*dxgrid(1) + xmininterp(2) = ymin - dxgrid(2) !- 0.5*dxgrid(2) + xmininterp(3) = zmin - dxgrid(3) !- 0.5*dxgrid(3) + !print*, "xminiterp: ", xmininterp + call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) + call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) + call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) + + ! We note that this is not actually the size of the einstein toolkit grid + ! As we want our periodic boundary to be on the particle domain not the + ! ET grid domain + ngrid(1) = (iupper-ilower) + 1 + ngrid(2) = (jupper-jlower) + 1 + ngrid(3) = (kupper-klower) + 1 + allocate(interparray(ngrid(1),ngrid(2),ngrid(3))) + interparray = 0. + nnodes = (iupper-ilower)*(jupper-jlower)*(kupper-klower) + ! Do we want to normalise interpolations? + normalise = .true. + ! Is our NR GRID vertex centered? + vertexcen = .false. + periodicx = .true. + periodicy = .true. + periodicz = .true. + + + + do i=1, npart + h = xyzh(4,i) + ! Get pmass + pmass = massoftype(igas) + ! Get density + rho = rhoh(h,pmass) + call get_weight(pmass,h,rho,weight) + weights(i) = weight + enddo + itype = igas + ! call interpolate3D(xyzh,weight,npart, & + ! xmininterp,gridarray(ilower:iupper,jlower:jupper,klower:kupper), & + ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) + call interpolate3D(xyzh,weights,dat,itype,npart,& + xmininterp(1),xmininterp(2),xmininterp(3), & + !interparray, & + gridarray(ilower:iupper,jlower:jupper,klower:kupper),& + ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& + normalise,periodicx,periodicy,periodicz) + + + + + end subroutine interpolate_to_grid + + subroutine check_conserved_dens(rhostargrid,cfac) + use part, only:npart,massoftype,igas + use einsteintk_utils, only: dxgrid, gridorigin + use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax + real, intent(in) :: rhostargrid(:,:,:) + real(kind=16), intent(out) :: cfac + real :: totalmassgrid,totalmasspart + integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper + + + call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) + call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) + call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) + + totalmassgrid = 0. + do i=ilower,iupper + do j=jlower,jupper + do k=klower, kupper + totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) + + enddo + enddo + enddo + + ! total mass of the particles + totalmasspart = npart*massoftype(igas) + + !print*, "Total mass grid: ", totalmassgrid + !print*, "Total mass part: ", totalmasspart + ! Calculate cfac + cfac = totalmasspart/totalmassgrid + + !print*, "cfac mass: ", cfac + + end subroutine check_conserved_dens + + subroutine check_conserved_p(pgrid,cfac) + use part, only:npart,massoftype,igas,pxyzu + use einsteintk_utils, only: dxgrid, gridorigin + use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax + real, intent(in) :: pgrid(:,:,:) + real(kind=16), intent(out) :: cfac + real :: totalmomentumgrid,totalmomentumpart + integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper + + call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) + call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) + call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) + + ! I'm still a bit unsure what this conserved quantity is actually meant to be?? + totalmomentumgrid = 0. + do i=ilower,iupper + do j=jlower,jupper + do k=klower, kupper + !totalmomentumgrid = totalmomentumgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) + + enddo + enddo + enddo + + ! total cons(momentum) of the particles + totalmomentumpart = npart*massoftype(igas) + + ! Calculate cfac + cfac = totalmomentumpart/totalmomentumgrid + + !print*, "cfac mass: ", cfac + + end subroutine check_conserved_p end module tmunu2grid \ No newline at end of file diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index 5139d3799..6fd412afb 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.F90 @@ -18,7 +18,8 @@ module utils_gr ! implicit none - public :: dot_product_gr, get_u0, get_bigv, rho2dens, h2dens, get_geodesic_accel, get_sqrtg + public :: dot_product_gr, get_u0, get_bigv, rho2dens, h2dens, get_geodesic_accel, get_sqrtg, get_sqrt_gamma + public :: perturb_metric private @@ -116,8 +117,9 @@ subroutine rho2dens(dens,rho,position,metrici,v) real :: gcov(0:3,0:3), sqrtg, U0 ! Hard coded sqrtg=1 since phantom is always in cartesian coordinates - sqrtg = 1. + !sqrtg = 1. call unpack_metric(metrici,gcov=gcov) + call get_sqrtg(gcov, sqrtg) call get_u0(gcov,v,U0,ierror) dens = rho/(sqrtg*U0) @@ -206,6 +208,67 @@ subroutine get_sqrtg(gcov, sqrtg) end subroutine get_sqrtg +subroutine get_sqrt_gamma(gcov,sqrt_gamma) + use metric, only: metric_type + real, intent(in) :: gcov(0:3,0:3) + real, intent(out) :: sqrt_gamma + real :: a11,a12,a13 + real :: a21,a22,a23 + real :: a31,a32,a33 + real :: a41,a42,a43 + real :: det + + if (metric_type == 'et') then + ! Calculate the determinant of a 3x3 matrix + ! Spatial metric is just the physical metric + ! without the tt component + + a11 = gcov(1,1) + a12 = gcov(1,2) + a13 = gcov(1,3) + a21 = gcov(2,1) + a22 = gcov(2,2) + a23 = gcov(2,3) + a31 = gcov(3,1) + a32 = gcov(3,2) + a33 = gcov(3,3) + + det = a11*(a22*a33 - a23*a32) - a12*(a21*a33 - a23*a31) + a13*(a21*a32-a22*a31) + sqrt_gamma = sqrt(det) + + else + sqrt_gamma = -1. + + endif + + +end subroutine get_sqrt_gamma + +subroutine perturb_metric(phi,gcovper,gcov) + real, intent(in) :: phi + real, intent(out) :: gcovper(0:3,0:3) + real, optional, intent(in) :: gcov(0:3,0:3) + + + if (present(gcov)) then + gcovper = gcov + else + gcovper = 0. + gcovper(0,0) = -1. + gcovper(1,1) = 1. + gcovper(2,2) = 1. + gcovper(3,3) = 1. + endif + + ! Set the pertubed metric based on the Bardeen formulation + gcovper(0,0) = gcovper(0,0) - 2.*phi + gcovper(1,1) = gcovper(1,1) - 2.*phi + gcovper(2,2) = gcovper(2,2) - 2.*phi + gcovper(3,3) = gcovper(3,3) - 2.*phi + + +end subroutine perturb_metric + ! This is not being used at the moment. ! subroutine dens2rho(rho,dens,position,v) ! use metric_tools, only: get_metric diff --git a/src/main/utils_infiles.f90 b/src/main/utils_infiles.f90 index 2609282af..2bc29ef65 100644 --- a/src/main/utils_infiles.f90 +++ b/src/main/utils_infiles.f90 @@ -44,7 +44,7 @@ module infile_utils ! maximum length for input strings ! (if you change this, must also change format statements below) ! - integer, parameter, private :: maxlen = 20 ! max length of string containing variable + integer, parameter, private :: maxlen = 100 ! max length of string containing variable integer, parameter, private :: maxlenval = 100 ! max length of string containing value integer, parameter, private :: maxlenstring = 120 ! max length of string variable integer, parameter, private :: maxlenline = 120 ! maximum line length @@ -177,6 +177,7 @@ subroutine write_inopt_real8(rval,name,descript,iunit,ierr,exp,time) logical :: doexp,dotime integer :: nhr,nmin !,nsec character(len=16) :: tmpstring + character(len=3) :: fmts real(kind=8) :: trem integer :: ierror @@ -189,6 +190,9 @@ subroutine write_inopt_real8(rval,name,descript,iunit,ierr,exp,time) if (time) dotime = .true. endif + fmts = "a20" + if (len_trim(name) > 20) fmts = "a" + if (dotime) then trem = rval nhr = int(trem/3600.d0) @@ -197,12 +201,12 @@ subroutine write_inopt_real8(rval,name,descript,iunit,ierr,exp,time) if (nmin > 0) trem = trem - nmin*60.d0 !nsec = int(trem) - write(iunit,"(a20,' = ',5x,i3.3,':',i2.2,4x,'! ',a)",iostat=ierror) & + write(iunit,"("//trim(fmts)//",' = ',5x,i3.3,':',i2.2,4x,'! ',a)",iostat=ierror) & name,nhr,nmin,descript else if (doexp .or. (abs(rval) < 1.e-3 .and. abs(rval) > tiny(rval)) & .or. (abs(rval) >= 1.e4)) then - write(iunit,"(a20,' = ',1x,es10.3,4x,'! ',a)",iostat=ierror) & + write(iunit,"("//trim(fmts)//",' = ',1x,es10.3,4x,'! ',a)",iostat=ierror) & name,rval,descript else if (abs(rval) <= 1.e-1) then @@ -215,10 +219,11 @@ subroutine write_inopt_real8(rval,name,descript,iunit,ierr,exp,time) write(tmpstring,"(g16.9)",iostat=ierror) rval tmpstring = adjustl(strip_zeros(tmpstring,3)) endif + if (len_trim(tmpstring) > 10) then - write(iunit,"(a20,' = ',1x,a,2x,'! ',a)",iostat=ierror) name,adjustr(trim(tmpstring)),descript + write(iunit,"("//trim(fmts)//",' = ',1x,a,2x,'! ',a)",iostat=ierror) name,adjustr(trim(tmpstring)),descript else - write(iunit,"(a20,' = ',1x,a10,4x,'! ',a)",iostat=ierror) name,adjustr(trim(tmpstring)),descript + write(iunit,"("//trim(fmts)//",' = ',1x,a10,4x,'! ',a)",iostat=ierror) name,adjustr(trim(tmpstring)),descript endif endif endif @@ -268,12 +273,16 @@ subroutine write_inopt_string(sval,name,descript,iunit,ierr) integer, intent(in) :: iunit integer, intent(out), optional :: ierr character(len=40) :: fmtstring + character(len=3) :: fmts integer :: ierror + fmts = "a20" + if (len_trim(name) > 20) fmts = "a" + if (len_trim(sval) > 10) then - fmtstring = '(a20,'' = '',1x,a,3x,''! '',a)' + fmtstring = '('//fmts//','' = '',1x,a,3x,''! '',a)' else - fmtstring = '(a20,'' = '',1x,a10,4x,''! '',a)' + fmtstring = '('//fmts//','' = '',1x,a10,4x,''! '',a)' endif write(iunit,fmtstring,iostat=ierror) name,trim(sval),trim(descript) @@ -517,7 +526,6 @@ subroutine read_inopt_string(valstring,tag,db,err,errcount) ierr = 0 if (.not.match_inopt_in_db(db,tag,valstring)) ierr = -1 - if (present(err)) then err = ierr elseif (ierr /= 0) then diff --git a/src/setup/phantomsetup.F90 b/src/setup/phantomsetup.F90 index 9ec6e7052..0d09b33a1 100644 --- a/src/setup/phantomsetup.F90 +++ b/src/setup/phantomsetup.F90 @@ -124,13 +124,12 @@ program phantomsetup call init_domains(nprocs) id = 0 endif - do myid=0,nprocsfake-1 myid1 = myid if (mpi) myid1 = id call setpart(myid1,npart,npartoftype(:),xyzh,massoftype(:),vxyzu,polyk,gamma,hfact,time,fileprefix) -! +! !--setup magnetic field if code compiled with MHD ! if (mhd .and. .not.ihavesetupB) then diff --git a/src/setup/set_unifdis.f90 b/src/setup/set_unifdis.f90 index 2d4d9afa4..7e8211b5f 100644 --- a/src/setup/set_unifdis.f90 +++ b/src/setup/set_unifdis.f90 @@ -16,7 +16,7 @@ module unifdis ! ! :Dependencies: random, stretchmap ! - use stretchmap, only:rho_func + use stretchmap, only:rho_func, mass_func implicit none public :: set_unifdis, get_ny_nz_closepacked, get_xyzmin_xyzmax_exact public :: is_valid_lattice, is_closepacked @@ -29,7 +29,7 @@ logical function mask_prototype(ip) end function mask_prototype end interface - public :: mask_prototype, mask_true, rho_func + public :: mask_prototype, mask_true, rho_func,mass_func private @@ -48,7 +48,7 @@ end function mask_prototype subroutine set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax, & zmin,zmax,delta,hfact,np,xyzh,periodic, & rmin,rmax,rcylmin,rcylmax,rellipsoid,in_ellipsoid, & - nptot,npy,npz,npnew_in,rhofunc,inputiseed,verbose,centre,dir,geom,mask,err) + nptot,npy,npz,npnew_in,rhofunc,massfunc,inputiseed,verbose,centre,dir,geom,mask,err) use random, only:ran2 use stretchmap, only:set_density_profile !use mpidomain, only:i_belong @@ -65,6 +65,7 @@ subroutine set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax, & integer(kind=8), intent(inout), optional :: nptot integer, intent(in), optional :: npy,npz,npnew_in,dir,geom procedure(rho_func), pointer, optional :: rhofunc + procedure(mass_func), pointer, optional :: massfunc integer, intent(in), optional :: inputiseed logical, intent(in), optional :: verbose,centre,in_ellipsoid integer, intent(out), optional :: err diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 new file mode 100644 index 000000000..6145b111f --- /dev/null +++ b/src/setup/setup_flrw.f90 @@ -0,0 +1,558 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.bitbucket.io/ ! +!--------------------------------------------------------------------------! +module setup +! +! Setup routine for uniform distribution +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: +! - Bzero : *magnetic field strength in code units* +! - cs0 : *initial sound speed in code units* +! - dist_unit : *distance unit (e.g. au)* +! - dust_to_gas : *dust-to-gas ratio* +! - ilattice : *lattice type (1=cubic, 2=closepacked)* +! - mass_unit : *mass unit (e.g. solarm)* +! - nx : *number of particles in x direction* +! - rhozero : *initial density in code units* +! - xmax : *xmax boundary* +! - xmin : *xmin boundary* +! - ymax : *ymax boundary* +! - ymin : *ymin boundary* +! - zmax : *zmax boundary* +! - zmin : *zmin boundary* +! +! :Dependencies: boundary, cooling, dim, eos, h2cooling, infile_utils, io, +! mpidomain, mpiutils, options, part, physcon, prompting, set_dust, +! setup_params, timestep, unifdis, units +! + use dim, only:use_dust,mhd + use options, only:use_dustfrac + use setup_params, only:rhozero + implicit none + public :: setpart + + integer :: npartx,ilattice + real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,Bzero,ampl,phaseoffset + character(len=20) :: dist_unit,mass_unit,perturb_direction,perturb + real(kind=8) :: udist,umass + + !--change default defaults to reproduce the test from Section 5.6.7 of Price+(2018) + logical :: BalsaraKim = .false. + + !--dust + real :: dust_to_gas + + private + +contains + +!---------------------------------------------------------------- +!+ +! setup for uniform particle distributions +!+ +!---------------------------------------------------------------- +subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) + use dim, only:maxvxyzu,gr + use setup_params, only:npart_total + use io, only:master + use unifdis, only:set_unifdis,rho_func,mass_func + use boundary, only:xmin,ymin,zmin,xmax,ymax,zmax,dxbound,dybound,dzbound,set_boundary + use part, only:periodic + use physcon, only:years,pc,solarm + use units, only:set_units + use mpidomain, only:i_belong + use stretchmap, only:set_density_profile + use utils_gr, only:perturb_metric, get_u0, get_sqrtg + !use cons2primsolver, only:primative2conservative + + integer, intent(in) :: id + integer, intent(inout) :: npart + integer, intent(out) :: npartoftype(:) + real, intent(out) :: xyzh(:,:) + real, intent(out) :: massoftype(:) + real, intent(out) :: polyk,gamma + real, intent(inout) :: hfact + real, intent(inout) :: time + character(len=20), intent(in) :: fileprefix + real, intent(out) :: vxyzu(:,:) + character(len=40) :: filename,lattice + real :: totmass,deltax,pi + integer :: i,ierr + logical :: iexist + real :: kwave,denom,length, c1,c3,lambda + real :: perturb_rho0,xval + real :: Vup(0:3),v(0:3),const,phi,rhoprim,sqrtg,u0,x,gcov(0:3,0:3),alpha,hub + real :: perturb_wavelength + procedure(rho_func), pointer :: density_func + procedure(mass_func), pointer :: mass_function + + density_func => rhofunc ! desired density function + mass_function => massfunc ! desired mass funciton + + ! + !--general parameters + ! + perturb_wavelength = 1. + time = 0. + if (maxvxyzu < 4) then + gamma = 1. + else + gamma = 5./3. + endif + ! Redefinition of pi to fix numerical error + pi = 4.D0*DATAN(1.0D0) + ! + ! default units + ! + mass_unit = 'solarm' + dist_unit = 'mpc' + ! + ! set boundaries to default values + ! + xmini = xmin; xmaxi = xmax + ymini = ymin; ymaxi = ymax + zmini = zmin; zmaxi = zmax + ! + ! set default values for input parameters + ! + npartx = 64 + ilattice = 1 + perturb = '"no"' + ! Ideally this should read the values of the box length + ! and initial Hubble parameter from the par file. + ! Then it should be set using the Friedmann equation: + !!!!!! rhozero = (3H^2)/(8*pi*a*a) + hub = 10.553495658357338 + rhozero = 3.d0 * hub**2 / (8.d0 * pi) + + ! Define some parameters for Linear pertubations + ! We assume ainit = 1, but this may not always be the case + c1 = 1.d0/(4.d0*PI*rhozero) + !c2 = We set g(x^i) = 0 as we only want to extract the growing mode + c3 = - sqrt(1.d0/(6.d0*PI*rhozero)) + + + if (gr) then + !cs0 = 1.e-4 + !cs0 = 1. + ! 0 Because dust? + cs0 = 0. + else + cs0 = 1. + endif + ! get disc setup parameters from file or interactive setup + ! + filename=trim(fileprefix)//'.setup' + inquire(file=filename,exist=iexist) + if (iexist) then + !--read from setup file + call read_setupfile(filename,ierr) + if (id==master) call write_setupfile(filename) + if (ierr /= 0) then + stop + endif + elseif (id==master) then + call setup_interactive(id,polyk) + call write_setupfile(filename) + stop 'rerun phantomsetup after editing .setup file' + else + stop + endif + ! + ! set units and boundaries + ! + if (gr) then + call set_units(dist=udist,c=1.d0,G=1.d0) + else + call set_units(dist=udist,mass=umass,G=1.d0) + endif + call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) + ! + ! setup particles + ! + + npart = 0 + npart_total = 0 + length = xmaxi - xmini + deltax = length/npartx +! +! general parameters +! +! time should be read in from the par file + time = 0.18951066686763596 ! z~1000 + lambda = perturb_wavelength*length + kwave = (2.d0*pi)/lambda + denom = length - ampl/kwave*(cos(kwave*length)-1.0) + ! Hardcode to ensure double precision, that is requried + !rhozero = 13.294563008157013D0 + rhozero = 3.d0 * hub**2 / (8.d0 * pi) + xval = density_func(0.75) + xval = density_func(0.0) + !print*, "rhofunc 0.: ", xval + print*, "ampl :", ampl + !stop + print*, "phase offset is: ", phaseoffset + print*, "perturb direction is: ", perturb_direction + + select case(ilattice) + case(2) + lattice = 'closepacked' + case default + if (ilattice /= 1) print*,' error: chosen lattice not available, using cubic' + lattice = 'cubic' + end select + + select case(perturb) + case('"yes"') + select case(perturb_direction) + !TODO Z AND Y LINEAR PERTURBATIONS + case('"x"') + call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& + npart,xyzh,periodic,nptot=npart_total,mask=i_belong,rhofunc=density_func) + case('"all"') + call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& + npart,xyzh,periodic,nptot=npart_total,mask=i_belong,rhofunc=density_func) + call set_density_profile(npart,xyzh,min=ymin,max=ymax,rhofunc=density_func,& + geom=1,coord=2) + call set_density_profile(npart,xyzh,min=zmin,max=zmax,rhofunc=density_func,& + geom=1,coord=3) + end select + case('"no"') + call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& + npart,xyzh,periodic,nptot=npart_total,mask=i_belong) + end select + + npartoftype(:) = 0 + npartoftype(1) = npart + print*,' npart = ',npart,npart_total + + ! What should this be set as always 1? + !totmass = 1. + ! Setting it as this gives errors + totmass = rhozero*dxbound*dybound*dzbound + massoftype = totmass/npart_total + if (id==master) print*,' particle mass = ',massoftype(1) + if (id==master) print*,' initial sound speed = ',cs0,' pressure = ',cs0**2/gamma + + + + if (maxvxyzu < 4 .or. gamma <= 1.) then + polyk = cs0**2 + else + polyk = 0. + endif + do i=1,npart + + select case(perturb_direction) + case ('"x"') + ! should not be zero, for a pertrubed wave + !vxyzu(1,i) = ampl*sin(kwave*(xyzh(1,i)-xmin)) + vxyzu(1,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(1,i))/lambda - phaseoffset) + phi = ampl*sin(kwave*xyzh(1,i)-phaseoffset) + Vup(1) = kwave*c3*ampl*cos(2.d0*pi*xyzh(1,i) - phaseoffset) + Vup(2:3) = 0. + call perturb_metric(phi,gcov) + call get_sqrtg(gcov,sqrtg) + + alpha = sqrt(-gcov(0,0)) + vxyzu(1,i) = Vup(1)*alpha + vxyzu(2:3,i) = 0. + case ('"all"') + ! perturb the y and z velocities + vxyzu(2,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) + vxyzu(3,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(3,i))/lambda - phaseoffset) + end select + + if (maxvxyzu >= 4 .and. gamma > 1.) vxyzu(4,i) = cs0**2/(gamma*(gamma-1.)) + enddo + + + contains +!---------------------------------------------------- +!+ +! callback function giving desired density profile +!+ +!---------------------------------------------------- +real function rhofunc(x) + use utils_gr, only:perturb_metric, get_u0, get_sqrtg + !use metric_tools, only:unpack_metric + real, intent(in) :: x + real :: const, phi, rhoprim, gcov(0:3,0:3), sqrtg,u0,v(3),Vup(3) + real :: alpha + integer :: ierr + + !rhofunc = 1.d0 + ampl*sin(kwave*(x-xmin)) + !rhofunc = ampl*sin(kwave*(x-xmin)) + ! Eq 28. in Macpherson+ 2017 + ! Although it is missing a negative sign + const = -kwave*kwave*c1 - 2.d0 + phi = ampl*sin(kwave*x-phaseoffset) + !rhofunc = rhozero*(1.d0 + const*ampl*sin(kwave*x)) + ! Get the primative density from the linear perb + rhoprim = rhozero*(1.d0+const*phi) + + ! Get the perturbed 4-metric + call perturb_metric(phi,gcov) + ! Get sqrt(-det(g)) + call get_sqrtg(gcov,sqrtg) + ! Define the 3 velocities to calculate u0 + ! Three velocity will need to be converted from big V to small v + ! + Vup(1) = kwave*c3*ampl*cos((2.d0*pi*x)/lambda-phaseoffset) + Vup(2:3) = 0. + alpha = sqrt(-gcov(0,0)) + v(1) = Vup(1)*alpha + v(2:3) = 0. + ! calculate u0 + ! TODO Should probably handle this error at some point + call get_u0(gcov,v,u0,ierr) + ! Perform a prim2cons + rhofunc = rhoprim*sqrtg*u0 + +end function rhofunc + +real function massfunc(x,xmin) + use utils_gr, only:perturb_metric, get_u0, get_sqrtg + real, intent(in) :: x,xmin + real :: const, expr, exprmin, rhoprim, gcov(0:3,0:3), sqrtg,u0,v(3),Vup(3) + real :: massprimx,massprimmin,massprim + + ! The value inside the bracket + const = -kwave*kwave*c1 - 2.d0 + expr = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*x)/lambda) + exprmin = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*xmin)/lambda) + massprimx = (x-const*expr) + massprimmin = (xmin-const*exprmin) + ! Evalutation of the integral + ! rho0[x-Acos(kx)]^x_0 + massprim = rhozero*(massprimx - massprimmin) + + ! Get the perturbed 4-metric + call perturb_metric(phi,gcov) + ! Get sqrt(-det(g)) + call get_sqrtg(gcov,sqrtg) + ! Define the 3 velocities to calculate u0 + ! Three velocity will need to be converted from big V to small v + ! + Vup(1) = kwave*c3*ampl*cos((2.d0*pi*x)/lambda-phaseoffset) + Vup(2:3) = 0. + alpha = sqrt(-gcov(0,0)) + v(1) = Vup(1)*alpha + v(2:3) = 0. + + call get_u0(gcov,v,u0,ierr) + massfunc = massprim*sqrtg*u0 + + +end function massfunc + +end subroutine setpart + +!------------------------------------------------------------------------ +! +! interactive setup +! +!------------------------------------------------------------------------ +subroutine setup_interactive(id,polyk) + use io, only:master + use mpiutils, only:bcast_mpi + use dim, only:maxp,maxvxyzu + use prompting, only:prompt + use units, only:select_unit + integer, intent(in) :: id + real, intent(out) :: polyk + integer :: ierr + + if (id==master) then + 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 + + call prompt('enter xmin boundary',xmini) + call prompt('enter xmax boundary',xmaxi,xmini) + call prompt('enter ymin boundary',ymini) + call prompt('enter ymax boundary',ymaxi,ymini) + call prompt('enter zmin boundary',zmini) + call prompt('enter zmax boundary',zmaxi,zmini) + endif + ! + ! number of particles + ! + if (id==master) then + print*,' uniform setup... (max = ',nint((maxp)**(1/3.)),')' + call prompt('enter number of particles in x direction ',npartx,1) + endif + call bcast_mpi(npartx) + ! + ! mean density + ! + if (id==master) call prompt(' enter density (gives particle mass)',rhozero,0.) + call bcast_mpi(rhozero) + ! + ! sound speed in code units + ! + if (id==master) then + call prompt(' enter sound speed in code units (sets polyk)',cs0,0.) + endif + call bcast_mpi(cs0) + ! + ! dust to gas ratio + ! + if (use_dustfrac) then + call prompt('Enter dust to gas ratio',dust_to_gas,0.) + call bcast_mpi(dust_to_gas) + endif + ! + ! magnetic field strength + if (mhd .and. balsarakim) then + call prompt('Enter magnetic field strength in code units ',Bzero,0.) + call bcast_mpi(Bzero) + endif + ! + ! type of lattice + ! + if (id==master) then + call prompt(' select lattice type (1=cubic, 2=closepacked)',ilattice,1) + endif + call bcast_mpi(ilattice) +end subroutine setup_interactive + +!------------------------------------------------------------------------ +! +! write setup file +! +!------------------------------------------------------------------------ +subroutine write_setupfile(filename) + use infile_utils, only:write_inopt + 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 uniform setup routine' + + 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) + ! + ! boundaries + ! + write(iunit,"(/,a)") '# boundaries' + call write_inopt(xmini,'CoordBase::xmin','xmin boundary',iunit) + call write_inopt(xmaxi,'CoordBase::xmax','xmax boundary',iunit) + call write_inopt(ymini,'CoordBase::ymin','ymin boundary',iunit) + call write_inopt(ymaxi,'CoordBase::ymax','ymax boundary',iunit) + call write_inopt(zmini,'CoordBase::zmin','zmin boundary',iunit) + call write_inopt(zmaxi,'CoordBase::zmax','zmax boundary',iunit) + + + + ! + ! other parameters + ! + write(iunit,"(/,a)") '# setup' + call write_inopt(npartx,'nx','number of particles in x direction',iunit) + call write_inopt(rhozero,'rhozero','initial density in code units',iunit) + call write_inopt(cs0,'cs0','initial sound speed in code units',iunit) + call write_inopt(perturb,'FLRWSolver::FLRW_perturb','Pertrubations of FLRW?',iunit) + call write_inopt(ampl,'FLRWSolver::phi_amplitude','Pertubation amplitude',iunit) + call write_inopt(phaseoffset,'FLRWSolver::phi_phase_offset','Pertubation phase offset',iunit) + call write_inopt(perturb_direction, 'FLRWSolver::FLRW_perturb_direction','Pertubation direction',iunit) + if (use_dustfrac) then + call write_inopt(dust_to_gas,'dust_to_gas','dust-to-gas ratio',iunit) + endif + if (mhd .and. balsarakim) then + call write_inopt(Bzero,'Bzero','magnetic field strength in code units',iunit) + endif + call write_inopt(ilattice,'ilattice','lattice type (1=cubic, 2=closepacked)',iunit) + close(iunit) + +end subroutine write_setupfile + +!------------------------------------------------------------------------ +! +! read setup file +! +!------------------------------------------------------------------------ +subroutine read_setupfile(filename,ierr) + use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db + use units, only:select_unit + use io, only:error + character(len=*), intent(in) :: filename + integer, intent(out) :: ierr + integer, parameter :: iunit = 21 + integer :: nerr + type(inopts), allocatable :: db(:) + + print "(a)",' reading setup options from '//trim(filename) + nerr = 0 + ierr = 0 + call open_db_from_file(db,filename,iunit,ierr) + ! + ! units + ! + call read_inopt(mass_unit,'mass_unit',db,errcount=nerr) + call read_inopt(dist_unit,'dist_unit',db,errcount=nerr) + ! + ! boundaries + ! + call read_inopt(xmini,'CoordBase::xmin',db,errcount=nerr) + call read_inopt(xmaxi,'CoordBase::xmax',db,min=xmini,errcount=nerr) + call read_inopt(ymini,'CoordBase::ymin',db,errcount=nerr) + call read_inopt(ymaxi,'CoordBase::ymax',db,min=ymini,errcount=nerr) + call read_inopt(zmini,'CoordBase::zmin',db,errcount=nerr) + call read_inopt(zmaxi,'CoordBase::zmax',db,min=zmini,errcount=nerr) + ! + ! other parameters + ! + call read_inopt(npartx,'nx',db,min=8,errcount=nerr) + call read_inopt(rhozero,'rhozero',db,min=0.,errcount=nerr) + call read_inopt(cs0,'cs0',db,min=0.,errcount=nerr) + + call read_inopt(perturb_direction,'FLRWSolver::FLRW_perturb_direction',db,errcount=nerr) + call read_inopt(ampl, 'FLRWSolver::phi_amplitude',db,errcount=nerr) + call read_inopt(phaseoffset,'FLRWSolver::phi_phase_offset',db,errcount=nerr) + call read_inopt(ilattice,'ilattice',db,min=1,max=2,errcount=nerr) + ! TODO Work out why this doesn't read in correctly + call read_inopt(perturb,'FLRWSolver::FLRW_perturb',db,errcount=nerr) + !print*, db + call close_db(db) + + if (nerr > 0) then + print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' + ierr = nerr +endif + ! + ! parse units + ! + call select_unit(mass_unit,umass,nerr) + if (nerr /= 0) then + call error('setup_unifdis','mass unit not recognised') + ierr = ierr + 1 + endif + call select_unit(dist_unit,udist,nerr) + if (nerr /= 0) then + call error('setup_unifdis','length unit not recognised') + ierr = ierr + 1 + endif + + +end subroutine read_setupfile + +end module setup diff --git a/src/setup/stretchmap.f90 b/src/setup/stretchmap.f90 index 3c3d922bd..179dc0e08 100644 --- a/src/setup/stretchmap.f90 +++ b/src/setup/stretchmap.f90 @@ -30,11 +30,12 @@ module stretchmap public :: set_density_profile public :: get_mass_r public :: rho_func + public :: mass_func - integer, private :: ngrid = 1024 ! number of points used when integrating rho to get mass + integer, private :: ngrid = 2048 ! number of points used when integrating rho to get mass integer, parameter, private :: maxits = 100 ! max number of iterations integer, parameter, private :: maxits_nr = 30 ! max iterations with Newton-Raphson - real, parameter, private :: tol = 1.e-9 ! tolerance on iterations + real, parameter, private :: tol = 1.e-10 ! tolerance on iterations integer, parameter, public :: ierr_zero_size_density_table = 1, & ! error code ierr_memory_allocation = 2, & ! error code ierr_table_size_differs = 3, & ! error code @@ -45,11 +46,17 @@ real function rho_func(x) end function rho_func end interface + abstract interface + real function mass_func(x,xmin) + real, intent(in) :: x, xmin + end function mass_func + end interface + private contains -subroutine set_density_profile(np,xyzh,min,max,rhofunc,rhotab,xtab,start,geom,coord,verbose,err) +subroutine set_density_profile(np,xyzh,min,max,rhofunc,massfunc,rhotab,xtab,start,geom,coord,verbose,err) ! ! Subroutine to implement the stretch mapping procedure ! @@ -91,6 +98,7 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,rhotab,xtab,start,geom,co real, intent(inout) :: xyzh(:,:) real, intent(in) :: min,max procedure(rho_func), pointer, optional :: rhofunc + procedure(mass_func), pointer, optional :: massfunc real, intent(in), optional :: rhotab(:),xtab(:) integer, intent(in), optional :: start, geom, coord logical, intent(in), optional :: verbose @@ -101,13 +109,16 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,rhotab,xtab,start,geom,co real, allocatable :: xtable(:),masstab(:) integer :: i,its,igeom,icoord,istart,nt,nerr,ierr logical :: is_r, is_rcyl, bisect, isverbose - logical :: use_rhotab + logical :: use_rhotab, use_massfunc isverbose = .true. use_rhotab = .false. + use_massfunc = .false. + if (present(verbose)) isverbose = verbose if (present(rhotab)) use_rhotab = .true. - + if (present(massfunc)) use_massfunc = .true. + print*,"Use mass func?: ", use_massfunc if (present(rhofunc) .or. present(rhotab)) then if (isverbose) print "(a)",' >>>>>> s t r e t c h m a p p i n g <<<<<<' ! @@ -176,6 +187,8 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,rhotab,xtab,start,geom,co totmass = get_mass_r(rhofunc,xmax,xmin) elseif (is_rcyl) then totmass = get_mass_rcyl(rhofunc,xmax,xmin) + elseif (use_massfunc) then + totmass = massfunc(xmax,min) else totmass = get_mass(rhofunc,xmax,xmin) endif @@ -203,8 +216,8 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,rhotab,xtab,start,geom,co nerr = 0 !$omp parallel do default(none) & - !$omp shared(np,xyzh,rhozero,igeom,use_rhotab,rhotab,xtable,masstab,nt) & - !$omp shared(xmin,xmax,totmass,icoord,is_r,is_rcyl,istart,rhofunc) & + !$omp shared(np,xyzh,rhozero,igeom,use_rhotab,use_massfunc,rhotab,xtable,masstab,nt) & + !$omp shared(xmin,xmax,totmass,icoord,is_r,is_rcyl,istart,rhofunc,massfunc) & !$omp private(x,xold,xt,fracmassold,its,xprev,xi,hi,rhoi) & !$omp private(func,dfunc,xminbisect,xmaxbisect,bisect) & !$omp reduction(+:nerr) @@ -239,6 +252,8 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,rhotab,xtab,start,geom,co func = get_mass_r(rhofunc,xi,xmin) elseif (is_rcyl) then func = get_mass_rcyl(rhofunc,xi,xmin) + elseif (use_massfunc) then + func = massfunc(xi,xmin) else func = get_mass(rhofunc,xi,xmin) endif @@ -266,6 +281,9 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,rhotab,xtab,start,geom,co elseif (is_rcyl) then func = get_mass_rcyl(rhofunc,xi,xmin) - fracmassold dfunc = 2.*pi*xi*rhofunc(xi) + elseif (use_massfunc) then + func = massfunc(xi,xmin) - fracmassold + dfunc = rhofunc(xi) else func = get_mass(rhofunc,xi,xmin) - fracmassold dfunc = rhofunc(xi) @@ -309,6 +327,8 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,rhotab,xtab,start,geom,co xyzh(2,i) = x(2) xyzh(3,i) = x(3) xyzh(4,i) = hi*(rhozero/rhoi)**(1./3.) + !print*, "Rho value for particle is: ", rhoi + !print*, "Smoothing length for particle is: ", xyzh(4,i) if (its >= maxits) nerr = nerr + 1 endif enddo diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index b6a8a44bf..d2999e9f8 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -4,16 +4,18 @@ module einsteintk_utils real, allocatable :: gcongrid(:,:,:,:,:) real, allocatable :: sqrtggrid(:,:,:) real, allocatable :: tmunugrid(:,:,:,:,:) + real, allocatable :: rhostargrid(:,:,:) + real, allocatable :: pxgrid(:,:,:,:) real, allocatable :: metricderivsgrid(:,:,:,:,:,:) real :: dxgrid(3), gridorigin(3), boundsize(3) integer :: gridsize(3) logical :: gridinit = .false. + logical :: exact_rendering character(len=128) :: logfilestor,evfilestor,dumpfilestor,infilestor contains subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) integer, intent(in) :: nx,ny,nz real, intent(in) :: dx,dy,dz,originx,originy,originz - !integer, intent(in) :: boundsizex, boundsizey, boundsizez gridsize(1) = nx gridsize(2) = ny @@ -27,10 +29,6 @@ subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) gridorigin(2) = originy gridorigin(3) = originz - ! How mmany grid points is the boundary? - ! boundsize(1) = boundsizex - ! boundsize(2) = boundsizey - ! boundsize(3) = boundsizez allocate(gcovgrid(0:3,0:3,nx,ny,nz)) allocate(gcongrid(0:3,0:3,nx,ny,nz)) @@ -40,6 +38,10 @@ subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) ! For now it is the simplest way allocate(tmunugrid(0:3,0:3,nx,ny,nz)) + allocate(pxgrid(3,nx,ny,nz)) + + allocate(rhostargrid(nx,ny,nz)) + ! metric derivs are stored in the form ! mu comp, nu comp, deriv, gridx,gridy,gridz ! Note that this is only the spatial derivs of @@ -48,6 +50,7 @@ subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) gridinit = .true. + !exact_rendering = exact end subroutine init_etgrid @@ -56,10 +59,132 @@ subroutine print_etgrid() print*, "Grid spacing (x,y,z) is : ", dxgrid print*, "Grid origin (x,y,z) is: ", gridorigin - !print*, "Grid size is: ", sizeof(gcovgrid) print*, "Covariant metric tensor of the grid is: ", gcovgrid(:,:,1,1,1) - !print*, "Contravariant metric tensor of the grid is: ", gcongrid - !print*, "Negative sqrtg of the grid is: ", sqrtggrid end subroutine print_etgrid + + subroutine get_particle_rhs(i,vx,vy,vz,fx,fy,fz,e_rhs) + use part, only: vxyzu,fxyzu,fext + integer, intent(in) :: i + real, intent(out) :: vx,vy,vz,fx,fy,fz,e_rhs + + !vxyz + vx = vxyzu(1,i) + vy = vxyzu(2,i) + vz = vxyzu(3,i) + + ! dp/dt + !print*, "fext: ", fext(:,i) + !print*, "fxyzu: ", fxyzu(:,i) + !fx = fxyzu(1,i) + fext(1,i) + !print*, "fx: ", fx + !fy = fxyzu(2,i) + fext(2,i) + !fz = fxyzu(3,i) + fext(3,i) + fx = fext(1,i) + fy = fext(2,i) + fz = fext(3,i) + + + ! de/dt + e_rhs = 0. + + end subroutine get_particle_rhs + + subroutine get_particle_val(i,x,y,z,px,py,pz,e) + use part, only: xyzh, pxyzu + integer, intent(in) :: i + real, intent(out) :: x,y,z,px,py,pz,e + + !xyz + x = xyzh(1,i) + y = xyzh(2,i) + z = xyzh(3,i) + + ! p + px = pxyzu(1,i) + py = pxyzu(2,i) + pz = pxyzu(3,i) + + ! e + ! ??? + e = pxyzu(4,i) + + end subroutine get_particle_val + + subroutine set_particle_val(i,x,y,z,px,py,pz,e) + use part, only: xyzh, pxyzu + integer, intent(in) :: i + real, intent(in) :: x,y,z,px,py,pz,e + ! Subroutine for setting the particle values in phantom + ! using the values stored in einstein toolkit before a dump + + !xyz + xyzh(1,i) = x + xyzh(2,i) = y + xyzh(3,i) = z + + ! p + pxyzu(1,i) = px + pxyzu(2,i) = py + pxyzu(3,i) = pz + pxyzu(4,i) = e + + + end subroutine set_particle_val + + subroutine get_phantom_dt(dtout) + use part, only:xyzh + real, intent(out) :: dtout + real, parameter :: safety_fac = 0.2 + real :: minh + + ! Get the smallest smoothing length + minh = minval(xyzh(4,:)) + + ! Courant esque condition from Rosswog 2021+ + ! Since c is allways one in our units + dtout = safety_fac*minh + print*, "dtout phantom: ", dtout + + + end subroutine get_phantom_dt + + subroutine set_rendering(flag) + logical, intent(in) :: flag + + exact_rendering = flag + + end subroutine set_rendering + + ! Do I move this to tmunu2grid?? + ! I think yes + + + ! Moved to einsteintk_wrapper.f90 to fix dependency issues + + ! subroutine get_metricderivs_all(dtextforce_min) + ! use part, only:npart, xyzh,vxyzu,metrics,metricderivs,dens,fext + ! use timestep, only:bignumber,C_force + ! use extern_gr, only:get_grforce + ! use metric_tools, only:pack_metricderivs + ! real, intent(out) :: dtextforce_min + ! integer :: i + ! real :: pri,dtf + + ! pri = 0. + ! dtextforce_min = bignumber + + ! !$omp parallel do default(none) & + ! !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & + ! !$omp firstprivate(pri) & + ! !$omp private(i,dtf) & + ! !$omp reduction(min:dtextforce_min) + ! do i=1, npart + ! call pack_metricderivs(xyzh(1:3,i),metricderivs(:,:,:,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) + ! dtextforce_min = min(dtextforce_min,C_force*dtf) + ! enddo + ! !$omp end parallel do + ! end subroutine get_metricderivs_all end module einsteintk_utils diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index fe494d54a..f1caf9838 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -8,7 +8,7 @@ module einsteintk_wrapper implicit none contains - subroutine init_et2phantom(infilestart,dt_et) + subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) ! Wrapper that intialises phantom ! Intended to hide all of the inner works of phantom from ET ! Majority of the code from HelloHydro_init has been moved here @@ -19,13 +19,21 @@ subroutine init_et2phantom(infilestart,dt_et) use evolve, only:evol_init use tmunu2grid use einsteintk_utils + use extern_gr + use metric + use part, only:xyzh,vxyzu,dens,metricderivs, metrics, npart, tmunus implicit none character(len=*), intent(in) :: infilestart real, intent(in) :: dt_et + integer, intent(inout) :: nophantompart + real, intent(out) :: dtout !character(len=500) :: logfile,evfile,dumpfile,path integer :: i,j,k,pathstringlength + integer :: xlower,ylower,zlower,xupper,yupper,zupper + real :: pos(3), gcovpart(0:3,0:3) + !real :: dtout ! For now we just hardcode the infile, to see if startrun actually works! ! I'm not sure what the best way to actually do this is? @@ -58,15 +66,24 @@ subroutine init_et2phantom(infilestart,dt_et) ! Do we want to pass dt in here?? call startrun(infilestor,logfilestor,evfilestor,dumpfilestor) print*, "Start run finished!" - print*, "tmunugrid: ", tmunugrid(1,1,6,6,6) + !print*, "tmunugrid: ", tmunugrid(1,1,6,6,6) !stop ! Intialises values for the evol routine: t, dt, etc.. - call evol_init(infilestor,logfilestor,evfilestor,dumpfilestor,dt_et) + call evol_init(infilestor,logfilestor,evfilestor,dumpfilestor,dt_et,nophantompart) print*, "Evolve init finished!" ! Calculate the stress energy tensor for each particle ! Might be better to do this in evolve init !call get_tmunugrid_all + ! Calculate the stress energy tensor + call get_metricderivs_all(dtout,dt_et) ! commented out to try and fix prim2cons + !call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) ! commented out to try and fix prim2cons + !call get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + ! Interpolate stress energy tensor from particles back + ! to grid + !call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac=.true.) ! commented out to try and fix cons2prim + call get_phantom_dt(dtout) + end subroutine init_et2phantom @@ -91,7 +108,6 @@ subroutine et2phantom(rho,nx,ny,nz) real, intent(in) :: rho(nx,ny,nz) print*, "Grid limits: ", nx, ny, nz - print*, "rho 1-10: ", rho(1:10,1,1) ! get mpi thread number ! send grid limits end subroutine et2phantom @@ -127,4 +143,312 @@ subroutine phantom2et() ! Perform kernel interpolation from particles to grid positions end subroutine phantom2et + + subroutine step_et2phantom_MoL(infile,dt_et,dtout) + use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars + use cons2prim, only: cons2primall + use deriv + use extern_gr + use tmunu2grid + use einsteintk_utils, only: get_phantom_dt,gcovgrid + character(len=*), intent(in) :: infile + real, intent(inout) :: dt_et + real, intent(out) :: dtout + real :: vbefore,vafter + + ! Metric should have already been passed in + ! and interpolated + ! Call get_derivs global + call get_derivs_global + + ! Get metric derivs + call get_metricderivs_all(dtout,dt_et) + ! Store our particle quantities somewhere / send them to ET + ! Cons2prim after moving the particles with the external force + vbefore = vxyzu(1,1) + call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + vafter = vxyzu(1,1) + + ! Does get_derivs_global perform a stress energy calc?? + ! If not do that here + + ! Perform the calculation of the stress energy tensor + ! Interpolate the stress energy tensor back to the ET grid! + ! Calculate the stress energy tensor + call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + ! Interpolate stress energy tensor from particles back + ! to grid + call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) + call get_phantom_dt(dtout) + + + end subroutine step_et2phantom_MoL + + subroutine et2phantom_tmunu() + use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& + Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,& + dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol,tmunus,metricderivs,& + massoftype,igas,rhoh,alphaind,dvdx,gradh + !use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars + use cons2prim, only: cons2primall + use deriv + use extern_gr + use tmunu2grid + use einsteintk_utils, only: get_phantom_dt,gcovgrid,rhostargrid,tmunugrid + use metric_tools, only:init_metric + use densityforce, only:densityiterate + use linklist, only:set_linklist + + real :: stressmax + real(kind=16) :: cfac + + stressmax = 0. + + ! Also probably need to pack the metric before I call things + call init_metric(npart,xyzh,metrics) + ! Might be better to just do this in get derivs global with a number 2 call? + ! Rebuild the tree + call set_linklist(npart,npart,xyzh,vxyzu) + ! Apparently init metric needs to be called again??? + !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) + ! Get primative variables for tmunu + call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + + call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + ! Interpolate stress energy tensor from particles back + ! to grid + call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) + + ! Interpolate density to grid + call phantom2et_rhostar + + ! Density check vs particles + call check_conserved_dens(rhostargrid,cfac) + + ! Correct Tmunu + tmunugrid = cfac*tmunugrid + + + end subroutine et2phantom_tmunu + + subroutine phantom2et_consvar() + use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& + Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,& + dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol,tmunus,metricderivs,& + massoftype,igas,rhoh,alphaind,dvdx,gradh + use densityforce, only:densityiterate + use metric_tools, only:init_metric + use linklist, only:set_linklist + use einsteintk_utils, only:rhostargrid,pxgrid + use tmunu2grid, only:check_conserved_dens + + real :: stressmax + real(kind=16) :: cfac + + ! Init metric + call init_metric(npart,xyzh,metrics) + + ! Might be better to just do this in get derivs global with a number 2 call? + ! Rebuild the tree + call set_linklist(npart,npart,xyzh,vxyzu) + ! Apparently init metric needs to be called again??? + 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) + + ! Interpolate density to grid + call phantom2et_rhostar + + ! Interpolate momentum to grid + call phantom2et_momentum + + + ! Conserved quantity checks + corrections + + ! Density check vs particles + call check_conserved_dens(rhostargrid,cfac) + + ! Momentum check vs particles + + ! Correct momentum and Density + rhostargrid = cfac*rhostargrid + pxgrid = cfac*pxgrid + !entropygrid = cfac*entropygrid + + + end subroutine phantom2et_consvar + + subroutine phantom2et_rhostar() + use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& + igas, massoftype,rhoh + use cons2prim, only: cons2primall + use deriv + use extern_gr + use tmunu2grid + use einsteintk_utils, only: get_phantom_dt,rhostargrid + use metric_tools, only:init_metric + real :: dat(npart), h, pmass,rho + integer :: i + + + ! Get new cons density from new particle positions somehow (maybe)? + ! Set linklist to update the tree for neighbour finding + ! Calculate the density for the new particle positions + ! Call density iterate + + ! Interpolate from particles to grid + ! This can all go into its own function as it will essentially + ! be the same thing for all quantites + ! get particle data + ! get rho from xyzh and rhoh + ! Get the conserved density on the particles + dat = 0. + do i=1, npart + ! Get the smoothing length + h = xyzh(4,i) + ! Get pmass + pmass = massoftype(igas) + rho = rhoh(h,pmass) + dat(i) = rho + enddo + rhostargrid = 0. + call interpolate_to_grid(rhostargrid,dat) + + end subroutine phantom2et_rhostar + + subroutine phantom2et_momentum() + use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& + igas,massoftype,alphaind,dvdx,gradh + use cons2prim, only: cons2primall + use deriv + use extern_gr + use tmunu2grid + use einsteintk_utils, only: get_phantom_dt,gcovgrid,pxgrid + use metric_tools, only:init_metric + real :: dat(3,npart) + integer :: i + + + ! Pi is directly updated at the end of each MoL add + + ! Interpolate from particles to grid + ! get particle data for the x component of momentum + dat = 0. + do i=1, npart + dat(1,i) = pxyzu(1,i) + dat(2,i) = pxyzu(2,i) + dat(3,i) = pxyzu(3,i) + enddo + + pxgrid = 0. + ! call interpolate 3d + ! In this case call it 3 times one for each vector component + ! px component + call interpolate_to_grid(pxgrid(1,:,:,:), dat(1,:)) + ! py component + call interpolate_to_grid(pxgrid(2,:,:,:), dat(2,:)) + ! pz component + call interpolate_to_grid(pxgrid(3,:,:,:),dat(3,:)) + + + + end subroutine phantom2et_momentum + + + + ! Subroutine for performing a phantom dump from einstein toolkit + subroutine et2phantom_dumphydro(time,dt_et) + use cons2prim, only:cons2primall + use part, only:npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars + use einsteintk_utils + use evwrite, only:write_evfile,write_evlog + use readwrite_dumps, only:write_smalldump,write_fulldump + use fileutils, only:getnextfilename + real, intent(in) :: time, dt_et + !character(len=20) :: logfile,evfile,dumpfile + + ! Call cons2prim since values are updated with MoL + !call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + ! Write EV_file + call write_evfile(time,dt_et) + + evfilestor = getnextfilename(evfilestor) + logfilestor = getnextfilename(logfilestor) + dumpfilestor = getnextfilename(dumpfilestor) + + !print*, "Evfile: ", evfilestor + !print*, "logfile: ", logfilestor + !print*, "dumpfle: ", dumpfilestor + ! Write full dump + call write_fulldump(time,dumpfilestor) + + end subroutine et2phantom_dumphydro + + ! Provides the RHS derivs for a particle at index i + subroutine phantom2et_rhs(index, vx,vy,vz,fx,fy,fz,e_rhs) + use einsteintk_utils + real, intent(inout) :: vx,vy,vz,fx,fy,fz, e_rhs + integer, intent(in) :: index + + call get_particle_rhs(index,vx,vy,vz,fx,fy,fz,e_rhs) + + end subroutine phantom2et_rhs + + subroutine phantom2et_initial(index,x,y,z,px,py,pz,e) + use einsteintk_utils + real, intent(inout) :: x,y,z,px,py,pz,e + integer, intent(in) :: index + + call get_particle_val(index,x,y,z,px,py,pz,e) + + end subroutine phantom2et_initial + + subroutine et2phantom_setparticlevars(index,x,y,z,px,py,pz,e) + use einsteintk_utils + real, intent(inout) :: x,y,z,px,py,pz,e + integer, intent(in) :: index + + call set_particle_val(index,x,y,z,px,py,pz,e) + + end subroutine et2phantom_setparticlevars + + ! I really HATE this routine being here but it needs to be to fix dependency issues. + subroutine get_metricderivs_all(dtextforce_min,dt_et) + use einsteintk_utils, only: metricderivsgrid + use part, only:npart, xyzh,vxyzu,fxyzu,metrics,metricderivs,dens,fext + use timestep, only:bignumber,C_force + use extern_gr, only:get_grforce + use metric_tools, only:pack_metricderivs + real, intent(out) :: dtextforce_min + real, intent(in) :: dt_et + integer :: i + real :: pri,dtf + + pri = 0. + dtextforce_min = bignumber + + !$omp parallel do default(none) & + !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & + !$omp firstprivate(pri) & + !$omp private(i,dtf) & + !$omp reduction(min:dtextforce_min) + do i=1, npart + call pack_metricderivs(xyzh(1:3,i),metricderivs(:,:,:,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) + dtextforce_min = min(dtextforce_min,C_force*dtf) + enddo + !$omp end parallel do + ! manually add v contribution from gr + ! do i=1, npart + ! !fxyzu(:,i) = fxyzu(:,i) + fext(:,i) + ! vxyzu(1:3,i) = vxyzu(1:3,i) + fext(:,i)*dt_et + ! enddo + end subroutine get_metricderivs_all + + end module einsteintk_wrapper diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index b24cc8dab..f614b4c9f 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -1,320 +1,926 @@ -!--------------------------------------------------------------------------! -! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! -! See LICENCE file for usage and distribution conditions ! -! http://phantomsph.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module interpolations3D -! -! Module containing routine for interpolation from PHANTOM data -! to 3D adaptive mesh +!----------------------------------------------------------------- ! -! Requires adaptivemesh.f90 module +! This file is (or was) part of SPLASH, a visualisation tool +! for Smoothed Particle Hydrodynamics written by Daniel Price: ! -! :References: None +! http://users.monash.edu.au/~dprice/splash ! -! :Owner: Daniel Price +! SPLASH comes with ABSOLUTELY NO WARRANTY. +! This is free software; and you are welcome to redistribute +! it under the terms of the GNU General Public License +! (see LICENSE file for details) and the provision that +! this notice remains intact. If you modify this file, please +! note section 2a) of the GPLv2 states that: ! -! :Runtime parameters: None +! a) You must cause the modified files to carry prominent notices +! stating that you changed the files and the date of any change. ! -! :Dependencies: adaptivemesh +! Copyright (C) 2005-2019 Daniel Price. All rights reserved. +! Contact: daniel.price@monash.edu ! +!----------------------------------------------------------------- - implicit none - real, parameter, private :: dpi = 1./3.1415926536d0 - public :: interpolate3D -!$ integer(kind=8), dimension(:), private, allocatable :: ilock - -contains -!-------------------------------------------------------------------------- -! subroutine to interpolate from particle data to even grid of pixels -! -! The data is interpolated according to the formula -! -! datsmooth(pixel) = sum_b weight_b dat_b W(r-r_b, h_b) -! -! where _b is the quantity at the neighbouring particle b and -! W is the smoothing kernel, for which we use the usual cubic spline. +!---------------------------------------------------------------------- ! -! For a standard SPH smoothing the weight function for each particle should be +! Module containing all of the routines required for interpolation +! from 3D data to a 3D grid (SLOW!) ! -! weight = pmass/(rho*h^3) -! -! this version is written for slices through a rectangular volume, ie. -! assumes a uniform pixel size in x,y, whilst the number of pixels -! in the z direction can be set to the number of cross-section slices. -! -! Input: particle coordinates and h : xyzh(4,npart) -! weight for each particle : weight [ same on all parts in PHANTOM ] -! scalar data to smooth : dat (npart) -! -! Output: smoothed data : datsmooth (npixx,npixy,npixz) -! -! Daniel Price, Monash University 2010 -! daniel.price@monash.edu -!-------------------------------------------------------------------------- - -subroutine interpolate3D(xyzh,weight,npart, & - xmin,datsmooth,nnodes,dxgrid,normalise,dat,ngrid) - !use adaptivemesh, only:ifirstlevel,nsub,ndim,gridnodes - integer, intent(in) :: npart,nnodes,ngrid(3) - real, intent(in) :: xyzh(:,:)! ,vxyzu(:,:) - real, intent(in) :: weight !,pmass - real, intent(in) :: xmin(3),dxgrid(3) - real, intent(out) :: datsmooth(:,:,:) - logical, intent(in) :: normalise - real, intent(in), optional :: dat(:) - real, allocatable :: datnorm(:,:,:) -! real, dimension(nsub**ndim,nnodes) :: datnorm - integer, parameter :: ndim = 3, nsub=1 - integer :: i,ipix,jpix,kpix,isubmesh,imesh,level,icell - integer :: iprintinterval,iprintnext - integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax - integer :: ipixi,jpixi,kpixi,npixx,npixy,npixz - real :: xi,yi,zi,hi,hi1,hi21,radkern,qq,wab,q2,const,dyz2,dz2 - real :: xorigi,yorigi,zorigi,xpix,ypix,zpix,dx,dy,dz - real :: dxcell(ndim),xminnew(ndim), dxmax(ndim) - real :: t_start,t_end - real :: termnorm - real :: term - real :: dfac - logical :: iprintprogress -!$ integer :: omp_get_num_threads,j -#ifndef _OPENMP - integer(kind=8) :: iprogress -#endif - - datsmooth = 0. - dxmax(:) = dxgrid(:) - !datnorm = 0. - if (normalise) then - print "(1x,a)",'interpolating from particles to Einstein toolkit grid (normalised) ...' - else - print "(1x,a)",'interpolating from particles to Einstein toolkit grid (non-normalised) ...' - endif -! if (any(dxmax(:) <= 0.)) then -! print "(1x,a)",'interpolate3D: error: grid size <= 0' -! return -! endif -! if (ilendat /= 0) then -! print "(1x,a)",'interpolate3D: error in interface: dat has non-zero length but is not present' -! return -! endif - if (normalise) then - allocate(datnorm(ngrid(1),ngrid(2),ngrid(3))) - datnorm = 0. - endif - -!$ allocate(ilock(0:nnodes)) -!$ do i=0,nnodes -!$ call omp_init_lock(ilock(i)) -!$ enddo - - ! - !--print a progress report if it is going to take a long time - ! (a "long time" is, however, somewhat system dependent) - ! - iprintprogress = (npart >= 100000) .or. (nnodes > 10000) - ! - !--loop over particles - ! - iprintinterval = 25 - if (npart >= 1e6) iprintinterval = 10 - iprintnext = iprintinterval - ! - !--get starting CPU time - ! - call cpu_time(t_start) - - imesh = 1 - level = 1 - dxcell(:) = dxgrid(:)/real(nsub**level) -! xminpix(:) = xmin(:) - 0.5*dxcell(:) - npixx = ngrid(1) - npixy = ngrid(2) - npixz = ngrid(3) - print "(3(a,i4))",' root grid: ',npixx,' x ',npixy,' x ',npixz - print*, "position of i cell 4 is: ", 4*dxcell(1) + xmin(1) - - const = dpi ! kernel normalisation constant (3D) - ! - !--loop over particles - ! - !$omp parallel default(none) & - !$omp shared(npart,xyzh,dat,datsmooth,datnorm) & - !$omp firstprivate(const,weight) & - !$omp firstprivate(xmin,imesh,nnodes,level) & - !$omp firstprivate(npixx,npixy,npixz,dxmax,dxcell,normalise) & - !$omp private(i,j,hi,hi1,hi21,radkern,termnorm,term) & - !$omp private(xpix,ypix,zpix,dx,dy,dz,dz2,dyz2,qq,q2,wab) & - !$omp private(xi,yi,zi,xorigi,yorigi,zorigi,xminnew) & - !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi,icell,isubmesh) & - !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) - !$omp master -!$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' - !$omp end master - !$omp do schedule(guided,10) - over_parts: do i=1,npart +!---------------------------------------------------------------------- + +module interpolations3D + use einsteintk_utils, only:exact_rendering + use kernel, only:radkern2,radkern,cnormk,wkern!,wallint ! Moved to this module + !use interpolation, only:iroll ! Moved to this module + + !use timing, only:wall_time,print_time ! Using cpu_time for now + implicit none + integer, parameter :: doub_prec = kind(0.d0) + real :: cnormk3D = cnormk + public :: interpolate3D!,interpolate3D_vec not needed + + contains + !-------------------------------------------------------------------------- + ! subroutine to interpolate from particle data to even grid of pixels + ! + ! The data is interpolated according to the formula + ! + ! datsmooth(pixel) = sum_b weight_b dat_b W(r-r_b, h_b) + ! + ! where _b is the quantity at the neighbouring particle b and + ! W is the smoothing kernel, for which we use the usual cubic spline. + ! + ! For a standard SPH smoothing the weight function for each particle should be + ! + ! weight = pmass/(rho*h^3) + ! + ! this version is written for slices through a rectangular volume, ie. + ! assumes a uniform pixel size in x,y, whilst the number of pixels + ! in the z direction can be set to the number of cross-section slices. + ! + ! Input: particle coordinates : x,y,z (npart) + ! smoothing lengths : hh (npart) + ! weight for each particle : weight (npart) + ! scalar data to smooth : dat (npart) + ! + ! Output: smoothed data : datsmooth (npixx,npixy,npixz) + ! + ! Daniel Price, Institute of Astronomy, Cambridge 16/7/03 + ! Revised for "splash to grid", Monash University 02/11/09 + ! Maya Petkova contributed exact subgrid interpolation, April 2019 + !-------------------------------------------------------------------------- + + subroutine interpolate3D(xyzh,weight,dat,itype,npart,& + xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& + normalise,periodicx,periodicy,periodicz) + + integer, intent(in) :: npart,npixx,npixy,npixz + real, intent(in) :: xyzh(4,npart) + !real, intent(in), dimension(npart) :: x,y,z,hh ! change to xyzh() + real, intent(in), dimension(npart) :: weight,dat + integer, intent(in), dimension(npart) :: itype + real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz + real(doub_prec), intent(out), dimension(npixx,npixy,npixz) :: datsmooth + logical, intent(in) :: normalise,periodicx,periodicy,periodicz + !logical, intent(in), exact_rendering + real(doub_prec), allocatable :: datnorm(:,:,:) + + integer :: i,ipix,jpix,kpix + integer :: iprintinterval,iprintnext + integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax + integer :: ipixi,jpixi,kpixi,nxpix,nwarn,threadid + real :: xminpix,yminpix,zminpix,hmin !,dhmin3 + real, dimension(npixx) :: dx2i + real :: xi,yi,zi,hi,hi1,hi21,wab,q2,const,dyz2,dz2 + real :: term,termnorm,dy,dz,ypix,zpix,xpixi,pixwidthmax,dfac + real :: t_start,t_end,t_used + logical :: iprintprogress + real, dimension(npart) :: x,y,z,hh + real :: radkernel, radkernel2, radkernh + + ! Exact rendering + real :: pixint, wint + !logical, parameter :: exact_rendering = .true. ! use exact rendering y/n + integer :: usedpart, negflag + + + !$ integer :: omp_get_num_threads,omp_get_thread_num + integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits + + ! Fill the particle data with xyzh + x(:) = xyzh(1,:) + y(:) = xyzh(2,:) + z(:) = xyzh(3,:) + hh(:) = xyzh(4,:) + print*, "smoothing length: ", hh(1:10) + ! cnormk3D set the value from the kernel routine + cnormk3D = cnormk + radkernel = radkern + radkernel2 = radkern2 + print*, "radkern: ", radkern + print*, "radkernel: ",radkernel + print*, "radkern2: ", radkern2 + + print*, "npix: ", npixx, npixy,npixz + + if (exact_rendering) then + print "(1x,a)",'interpolating to 3D grid (exact/Petkova+2018 on subgrid) ...' + elseif (normalise) then + print "(1x,a)",'interpolating to 3D grid (normalised) ...' + else + print "(1x,a)",'interpolating to 3D grid (non-normalised) ...' + endif + if (pixwidthx <= 0. .or. pixwidthy <= 0 .or. pixwidthz <= 0) then + print "(1x,a)",'interpolate3D: error: pixel width <= 0' + return + endif + if (any(hh(1:npart) <= tiny(hh))) then + print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' + endif + + !call wall_time(t_start) + + datsmooth = 0. + if (normalise) then + allocate(datnorm(npixx,npixy,npixz)) + datnorm = 0. + endif ! - !--report on progress + !--print a progress report if it is going to take a long time + ! (a "long time" is, however, somewhat system dependent) ! -#ifndef _OPENMP - if (iprintprogress) then - iprogress = nint(100.*i/npart) - if (iprogress >= iprintnext) then - write(*,"('(',i3,'% -',i12,' particles done)')") iprogress,i - iprintnext = iprintnext + iprintinterval - endif - endif -#endif + iprintprogress = (npart >= 100000) .or. (npixx*npixy > 100000) !.or. exact_rendering + ! + !--loop over particles + ! + iprintinterval = 25 + if (npart >= 1e6) iprintinterval = 10 + iprintnext = iprintinterval ! - !--set kernel related quantities + !--get starting CPU time ! - xi = xyzh(1,i); xorigi = xi - yi = xyzh(2,i); yorigi = yi - zi = xyzh(3,i); zorigi = zi - hi = xyzh(4,i) - if (hi <= 0.) cycle over_parts - hi1 = 1./hi; hi21 = hi1*hi1 - termnorm = const*weight - - radkern = 2.*hi ! radius of the smoothing kernel - term = termnorm*dat(i) ! weight for density calculation - ! I don't understand why this doesnt involve any actual smoothing? - !dfac = hi**3/(dxcell(1)*dxcell(2)*dxcell(3)*const) + call cpu_time(t_start) + + usedpart = 0 + + xminpix = xmin !- 0.5*pixwidthx + yminpix = ymin !- 0.5*pixwidthy + zminpix = zmin !- 0.5*pixwidthz + print*, "xminpix: ", xminpix + print*, "yminpix: ", yminpix + print*, "zminpix: ", zminpix + print*, "dat: ", dat(1:10) + print*, "weights: ", weight(1:10) + pixwidthmax = max(pixwidthx,pixwidthy,pixwidthz) ! - !--for each particle work out which pixels it contributes to + !--use a minimum smoothing length on the grid to make + ! sure that particles contribute to at least one pixel ! - ipixmin = int((xi - radkern - xmin(1))/dxcell(1)) - jpixmin = int((yi - radkern - xmin(2))/dxcell(2)) - kpixmin = int((zi - radkern - xmin(3))/dxcell(3)) - - ipixmax = int((xi + radkern - xmin(1))/dxcell(1)) + 1 - jpixmax = int((yi + radkern - xmin(2))/dxcell(2)) + 1 - kpixmax = int((zi + radkern - xmin(3))/dxcell(3)) + 1 - !if (ipixmin == 4 .and. jpixmin == 30 .and. kpixmin == 33) print*, "particle (min): ", i - !if (ipixmax == 4 .and. jpixmax == 30 .and. kpixmax == 33) print*, "particle (max): ", i -#ifndef PERIODIC - if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute - if (jpixmin < 1) jpixmin = 1 ! to pixels in the image - if (kpixmin < 1) kpixmin = 1 - if (ipixmax > npixx) ipixmax = npixx - if (jpixmax > npixy) jpixmax = npixy - if (kpixmax > npixz) kpixmax = npixz -#endif - !print*,' part ',i,' lims = ',ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax + hmin = 0.5*pixwidthmax + !dhmin3 = 1./(hmin*hmin*hmin) + + const = cnormk3D ! normalisation constant (3D) + print*, "const: ", const + nwarn = 0 + j = 0_8 + threadid = 1 ! - !--loop over pixels, adding the contribution from this particle - ! (note that we handle the periodic boundary conditions - ! entirely on the root grid) + !--loop over particles ! - do kpix = kpixmin,kpixmax - kpixi = kpix -#ifdef PERIODIC - if (kpixi < 1) then - kpixi = kpixi + npixz - zi = zorigi + dxmax(3) - elseif (kpixi > npixz) then - kpixi = kpixi - npixz - zi = zorigi - dxmax(3) + !$omp parallel default(none) & + !$omp shared(hh,z,x,y,weight,dat,itype,datsmooth,npart) & + !$omp shared(xmin,ymin,zmin,radkernel,radkernel2) & + !$omp shared(xminpix,yminpix,zminpix,pixwidthx,pixwidthy,pixwidthz) & + !$omp shared(npixx,npixy,npixz,const) & + !$omp shared(datnorm,normalise,periodicx,periodicy,periodicz,exact_rendering) & + !$omp shared(hmin,pixwidthmax) & + !$omp shared(iprintprogress,iprintinterval,j) & + !$omp private(hi,xi,yi,zi,radkernh,hi1,hi21) & + !$omp private(term,termnorm,xpixi,iprogress) & + !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & + !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & + !$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & + !$omp private(pixint,wint,negflag,dfac,threadid) & + !$omp firstprivate(iprintnext) & + !$omp reduction(+:nwarn,usedpart) + !$omp master + !$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' + !$omp end master + + !$omp do schedule (guided, 2) + over_parts: do i=1,npart + ! + !--report on progress + ! + if (iprintprogress) then + !$omp atomic + j=j+1_8 + !$ threadid = omp_get_thread_num() + iprogress = 100*j/npart + if (iprogress >= iprintnext .and. threadid==1) then + write(*,"(i3,'%.')",advance='no') iprogress + iprintnext = iprintnext + iprintinterval + endif + endif + ! + !--skip particles with itype < 0 + ! + if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts + + hi = hh(i) + if (hi <= 0.) then + cycle over_parts + elseif (hi < hmin) then + ! + !--use minimum h to capture subgrid particles + ! (get better results *without* adjusting weights) + ! + termnorm = const*weight(i) !*(hi*hi*hi)*dhmin3 + if (.not.exact_rendering) hi = hmin else - zi = zorigi + termnorm = const*weight(i) + endif + + ! + !--set kernel related quantities + ! + xi = x(i) + yi = y(i) + zi = z(i) + + hi1 = 1./hi + hi21 = hi1*hi1 + radkernh = radkernel*hi ! radius of the smoothing kernel + !termnorm = const*weight(i) + term = termnorm*dat(i) + dfac = hi**3/(pixwidthx*pixwidthy*pixwidthz*const) + !dfac = hi**3/(pixwidthx*pixwidthy*const) + ! + !--for each particle work out which pixels it contributes to + ! + ipixmin = int((xi - radkernh - xmin)/pixwidthx) + jpixmin = int((yi - radkernh - ymin)/pixwidthy) + kpixmin = int((zi - radkernh - zmin)/pixwidthz) + ipixmax = int((xi + radkernh - xmin)/pixwidthx) + 1 + jpixmax = int((yi + radkernh - ymin)/pixwidthy) + 1 + kpixmax = int((zi + radkernh - zmin)/pixwidthz) + 1 + + if (.not.periodicx) then + if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute + if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image endif -#endif - zpix = xmin(3) + (kpixi-0.5)*dxcell(3) - dz = zpix - zi - dz2 = dz*dz*hi21 - - do jpix = jpixmin,jpixmax - jpixi = jpix -#ifdef PERIODIC - if (jpixi < 1) then - jpixi = jpixi + npixy - yi = yorigi + dxmax(2) - elseif (jpixi > npixy) then - jpixi = jpixi - npixy - yi = yorigi - dxmax(2) - else - yi = yorigi + if (.not.periodicy) then + if (jpixmin < 1) jpixmin = 1 + if (jpixmax > npixy) jpixmax = npixy + endif + if (.not.periodicz) then + if (kpixmin < 1) kpixmin = 1 + if (kpixmax > npixz) kpixmax = npixz + endif + + negflag = 0 + + ! + !--precalculate an array of dx2 for this particle (optimisation) + ! + ! Check the x position of the grid cells + !open(unit=677,file="posxgrid.txt",action='write',position='append') + nxpix = 0 + do ipix=ipixmin,ipixmax + nxpix = nxpix + 1 + ipixi = ipix + if (periodicx) ipixi = iroll(ipix,npixx) + xpixi = xminpix + ipix*pixwidthx + !write(677,*) ipix, xpixi + !--watch out for errors with periodic wrapping... + if (nxpix <= size(dx2i)) then + dx2i(nxpix) = ((xpixi - xi)**2)*hi21 endif -#endif - ypix = xmin(2) + (jpixi-0.5)*dxcell(2) - dy = ypix - yi - dyz2 = dy*dy*hi21 + dz2 - - do ipix = ipixmin,ipixmax - ipixi = ipix -#ifdef PERIODIC - if (ipixi < 1) then - ipixi = ipixi + npixx - xi = xorigi + dxmax(1) - elseif (ipixi > npixx) then - ipixi = ipixi - npixx - xi = xorigi - dxmax(1) - else - xi = xorigi - endif -#endif - icell = ((kpixi-1)*nsub + (jpixi-1))*nsub + ipixi - ! - !--particle interpolates directly onto the root grid - ! - !print*,'onto root grid ',ipixi,jpixi,kpixi - xpix = xmin(1) + (ipixi-0.5)*dxcell(1) - !xpix = xmin(1) + (ipixi-1)*dxcell(1) ! Since we are vertex centered from Et - dx = xpix - xi - q2 = dx*dx*hi21 + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 - ! - !--SPH kernel - standard cubic spline - ! - if (q2 < 4.0) then - if (q2 < 1.0) then - qq = sqrt(q2) - wab = 1.-1.5*q2 + 0.75*q2*qq - else - qq = sqrt(q2) - wab = 0.25*(2.-qq)**3 + enddo + + !--if particle contributes to more than npixx pixels + ! (i.e. periodic boundaries wrap more than once) + ! truncate the contribution and give warning + if (nxpix > npixx) then + nwarn = nwarn + 1 + ipixmax = ipixmin + npixx - 1 + endif + ! + !--loop over pixels, adding the contribution from this particle + ! + do kpix = kpixmin,kpixmax + kpixi = kpix + if (periodicz) kpixi = iroll(kpix,npixz) + + zpix = zminpix + kpix*pixwidthz + dz = zpix - zi + dz2 = dz*dz*hi21 + + do jpix = jpixmin,jpixmax + jpixi = jpix + if (periodicy) jpixi = iroll(jpix,npixy) + + ypix = yminpix + jpix*pixwidthy + dy = ypix - yi + dyz2 = dy*dy*hi21 + dz2 + + nxpix = 0 + do ipix = ipixmin,ipixmax + if ((kpix==kpixmin).and.(jpix==jpixmin).and.(ipix==ipixmin)) then + usedpart = usedpart + 1 + endif + + nxpix = nxpix + 1 + ipixi = ipix + if (periodicx) ipixi = iroll(ipix,npixx) + + q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 + + if (exact_rendering .and. ipixmax-ipixmin <= 4) then + if (q2 < radkernel2 + 3.*pixwidthmax**2*hi21) then + xpixi = xminpix + ipix*pixwidthx + + ! Contribution of the cell walls in the xy-plane + pixint = 0.0 + wint = wallint(zpix-zi+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) + pixint = pixint + wint + + wint = wallint(zi-zpix+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) + pixint = pixint + wint + + ! Contribution of the cell walls in the xz-plane + wint = wallint(ypix-yi+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) + pixint = pixint + wint + + wint = wallint(yi-ypix+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) + pixint = pixint + wint + + ! Contribution of the cell walls in the yz-plane + wint = wallint(xpixi-xi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) + pixint = pixint + wint + + wint = wallint(xi-xpixi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) + pixint = pixint + wint + + wab = pixint*dfac ! /(pixwidthx*pixwidthy*pixwidthz*const)*hi**3 + + if (pixint < -0.01d0) then + print*, "Error: (",ipixi,jpixi,kpixi,") -> ", pixint, term*wab + endif + + ! + !--calculate data value at this pixel using the summation interpolant + ! + !$omp atomic + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + if (normalise) then + !$omp atomic + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + endif endif - ! - !--calculate data value at this pixel using the summation interpolant - ! - ! Change this to the access the pixel coords x,y,z - datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab - - !if (ipixi==1 .and. jpixi==1 .and. kpixi==1) print*, "x position of 1,1,1", xi,yi,zi - if (normalise) then - datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + else + if (q2 < radkernel2) then + + ! + !--SPH kernel - standard cubic spline + ! + wab = wkernel(q2) + ! + !--calculate data value at this pixel using the summation interpolant + ! + !$omp atomic + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + if (normalise) then + !$omp atomic + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + endif endif endif + enddo enddo enddo - enddo - enddo over_parts - !$omp enddo - !$omp end parallel - -!$ do i=0,nnodes -!$ call omp_destroy_lock(ilock(i)) -!$ enddo -!$ if (allocated(ilock)) deallocate(ilock) - - ! - !--normalise dat array - ! - if (normalise) then - where (datnorm > tiny(datnorm)) - datsmooth = datsmooth/datnorm - end where -endif - if (allocated(datnorm)) deallocate(datnorm) - ! - !--get ending CPU time - ! - call cpu_time(t_end) - print*,'completed in ',t_end-t_start,'s' - - return - -end subroutine interpolate3D + enddo over_parts + !$omp enddo + !$omp end parallel + + if (nwarn > 0) then + print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& + ' that wrap periodic boundaries more than once' + endif + ! + !--normalise dat array + ! + if (normalise) then + where (datnorm > tiny(datnorm)) + datsmooth = datsmooth/datnorm + end where + endif + if (allocated(datnorm)) deallocate(datnorm) + + !call wall_time(t_end) + call cpu_time(t_end) + t_used = t_end - t_start + print*, 'completed in ',t_end-t_start,'s' + !if (t_used > 10.) call print_time(t_used) + + !print*, 'Number of particles in the volume: ', usedpart + ! datsmooth(1,1,1) = 3.14159 + ! datsmooth(32,32,32) = 3.145159 + ! datsmooth(11,11,11) = 3.14159 + ! datsmooth(10,10,10) = 3.145159 + + end subroutine interpolate3D + + ! subroutine interpolate3D_vec(x,y,z,hh,weight,datvec,itype,npart,& + ! xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& + ! normalise,periodicx,periodicy,periodicz) + + ! integer, intent(in) :: npart,npixx,npixy,npixz + ! real, intent(in), dimension(npart) :: x,y,z,hh,weight + ! real, intent(in), dimension(npart,3) :: datvec + ! integer, intent(in), dimension(npart) :: itype + ! real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz + ! real(doub_prec), intent(out), dimension(3,npixx,npixy,npixz) :: datsmooth + ! logical, intent(in) :: normalise,periodicx,periodicy,periodicz + ! real(doub_prec), dimension(npixx,npixy,npixz) :: datnorm + + ! integer :: i,ipix,jpix,kpix + ! integer :: iprintinterval,iprintnext + ! integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax + ! integer :: ipixi,jpixi,kpixi,nxpix,nwarn + ! real :: xminpix,yminpix,zminpix + ! real, dimension(npixx) :: dx2i + ! real :: xi,yi,zi,hi,hi1,hi21,radkern,wab,q2,const,dyz2,dz2 + ! real :: termnorm,dy,dz,ypix,zpix,xpixi,ddatnorm + ! real, dimension(3) :: term + ! !real :: t_start,t_end + ! logical :: iprintprogress + ! !$ integer :: omp_get_num_threads + ! integer(kind=selected_int_kind(10)) :: iprogress ! up to 10 digits + + ! datsmooth = 0. + ! datnorm = 0. + ! if (normalise) then + ! print "(1x,a)",'interpolating to 3D grid (normalised) ...' + ! else + ! print "(1x,a)",'interpolating to 3D grid (non-normalised) ...' + ! endif + ! if (pixwidthx <= 0. .or. pixwidthy <= 0. .or. pixwidthz <= 0.) then + ! print "(1x,a)",'interpolate3D: error: pixel width <= 0' + ! return + ! endif + ! if (any(hh(1:npart) <= tiny(hh))) then + ! print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' + ! endif + + ! ! + ! !--print a progress report if it is going to take a long time + ! ! (a "long time" is, however, somewhat system dependent) + ! ! + ! iprintprogress = (npart >= 100000) .or. (npixx*npixy > 100000) + ! !$ iprintprogress = .false. + ! ! + ! !--loop over particles + ! ! + ! iprintinterval = 25 + ! if (npart >= 1e6) iprintinterval = 10 + ! iprintnext = iprintinterval + ! ! + ! !--get starting CPU time + ! ! + ! !call cpu_time(t_start) + + ! xminpix = xmin - 0.5*pixwidthx + ! yminpix = ymin - 0.5*pixwidthy + ! zminpix = zmin - 0.5*pixwidthz + + ! const = cnormk3D ! normalisation constant (3D) + ! nwarn = 0 + + ! !$omp parallel default(none) & + ! !$omp shared(hh,z,x,y,weight,datvec,itype,datsmooth,npart) & + ! !$omp shared(xmin,ymin,zmin,radkernel,radkernel2) & + ! !$omp shared(xminpix,yminpix,zminpix,pixwidthx,pixwidthy,pixwidthz) & + ! !$omp shared(npixx,npixy,npixz,const) & + ! !$omp shared(iprintprogress,iprintinterval) & + ! !$omp shared(datnorm,normalise,periodicx,periodicy,periodicz) & + ! !$omp private(hi,xi,yi,zi,radkern,hi1,hi21) & + ! !$omp private(term,termnorm,xpixi) & + ! !$omp private(iprogress,iprintnext) & + ! !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & + ! !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & + ! !$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & + ! !$omp reduction(+:nwarn) + ! !$omp master + ! !$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' + ! !$omp end master + ! ! + ! !--loop over particles + ! ! + ! !$omp do schedule (guided, 2) + ! over_parts: do i=1,npart + ! ! + ! !--report on progress + ! ! + ! if (iprintprogress) then + ! iprogress = 100*i/npart + ! if (iprogress >= iprintnext) then + ! write(*,"('(',i3,'% -',i12,' particles done)')") iprogress,i + ! iprintnext = iprintnext + iprintinterval + ! endif + ! endif + ! ! + ! !--skip particles with itype < 0 + ! ! + ! if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts + + ! hi = hh(i) + ! if (hi <= 0.) cycle over_parts + + ! ! + ! !--set kernel related quantities + ! ! + ! xi = x(i) + ! yi = y(i) + ! zi = z(i) + + ! hi1 = 1./hi + ! hi21 = hi1*hi1 + ! radkern = radkernel*hi ! radius of the smoothing kernel + ! termnorm = const*weight(i) + ! term(:) = termnorm*datvec(i,:) + ! ! + ! !--for each particle work out which pixels it contributes to + ! ! + ! ipixmin = int((xi - radkern - xmin)/pixwidthx) + ! jpixmin = int((yi - radkern - ymin)/pixwidthy) + ! kpixmin = int((zi - radkern - zmin)/pixwidthz) + ! ipixmax = int((xi + radkern - xmin)/pixwidthx) + 1 + ! jpixmax = int((yi + radkern - ymin)/pixwidthy) + 1 + ! kpixmax = int((zi + radkern - zmin)/pixwidthz) + 1 + + ! if (.not.periodicx) then + ! if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute + ! if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image + ! endif + ! if (.not.periodicy) then + ! if (jpixmin < 1) jpixmin = 1 + ! if (jpixmax > npixy) jpixmax = npixy + ! endif + ! if (.not.periodicz) then + ! if (kpixmin < 1) kpixmin = 1 + ! if (kpixmax > npixz) kpixmax = npixz + ! endif + ! ! + ! !--precalculate an array of dx2 for this particle (optimisation) + ! ! + ! nxpix = 0 + ! do ipix=ipixmin,ipixmax + ! nxpix = nxpix + 1 + ! ipixi = ipix + ! if (periodicx) ipixi = iroll(ipix,npixx) + ! xpixi = xminpix + ipix*pixwidthx + ! !--watch out for errors with perioic wrapping... + ! if (nxpix <= size(dx2i)) then + ! dx2i(nxpix) = ((xpixi - xi)**2)*hi21 + ! endif + ! enddo + + ! !--if particle contributes to more than npixx pixels + ! ! (i.e. periodic boundaries wrap more than once) + ! ! truncate the contribution and give warning + ! if (nxpix > npixx) then + ! nwarn = nwarn + 1 + ! ipixmax = ipixmin + npixx - 1 + ! endif + ! ! + ! !--loop over pixels, adding the contribution from this particle + ! ! + ! do kpix = kpixmin,kpixmax + ! kpixi = kpix + ! if (periodicz) kpixi = iroll(kpix,npixz) + ! zpix = zminpix + kpix*pixwidthz + ! dz = zpix - zi + ! dz2 = dz*dz*hi21 + + ! do jpix = jpixmin,jpixmax + ! jpixi = jpix + ! if (periodicy) jpixi = iroll(jpix,npixy) + ! ypix = yminpix + jpix*pixwidthy + ! dy = ypix - yi + ! dyz2 = dy*dy*hi21 + dz2 + + ! nxpix = 0 + ! do ipix = ipixmin,ipixmax + ! ipixi = ipix + ! if (periodicx) ipixi = iroll(ipix,npixx) + ! nxpix = nxpix + 1 + ! q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 + ! ! + ! !--SPH kernel - standard cubic spline + ! ! + ! if (q2 < radkernel2) then + ! wab = wkernel(q2) + ! ! + ! !--calculate data value at this pixel using the summation interpolant + ! ! + ! !$omp atomic + ! datsmooth(1,ipixi,jpixi,kpixi) = datsmooth(1,ipixi,jpixi,kpixi) + term(1)*wab + ! !$omp atomic + ! datsmooth(2,ipixi,jpixi,kpixi) = datsmooth(2,ipixi,jpixi,kpixi) + term(2)*wab + ! !$omp atomic + ! datsmooth(3,ipixi,jpixi,kpixi) = datsmooth(3,ipixi,jpixi,kpixi) + term(3)*wab + ! if (normalise) then + ! !$omp atomic + ! datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + ! endif + ! endif + ! enddo + ! enddo + ! enddo + ! enddo over_parts + ! !$omp enddo + ! !$omp end parallel + + ! if (nwarn > 0) then + ! print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& + ! ' that wrap periodic boundaries more than once' + ! endif + ! ! + ! !--normalise dat array + ! ! + ! if (normalise) then + ! !$omp parallel do default(none) schedule(static) & + ! !$omp shared(datsmooth,datnorm,npixz,npixy,npixx) & + ! !$omp private(kpix,jpix,ipix,ddatnorm) + ! do kpix=1,npixz + ! do jpix=1,npixy + ! do ipix=1,npixx + ! if (datnorm(ipix,jpix,kpix) > tiny(datnorm)) then + ! ddatnorm = 1./datnorm(ipix,jpix,kpix) + ! datsmooth(1,ipix,jpix,kpix) = datsmooth(1,ipix,jpix,kpix)*ddatnorm + ! datsmooth(2,ipix,jpix,kpix) = datsmooth(2,ipix,jpix,kpix)*ddatnorm + ! datsmooth(3,ipix,jpix,kpix) = datsmooth(3,ipix,jpix,kpix)*ddatnorm + ! endif + ! enddo + ! enddo + ! enddo + ! !$omp end parallel do + ! endif + + ! return + + ! end subroutine interpolate3D_vec + + !------------------------------------------------------------ + ! interface to kernel routine to avoid problems with openMP + !----------------------------------------------------------- + real function wkernel(q2) + use kernel, only:wkern + real, intent(in) :: q2 + real :: q + q = sqrt(q2) + wkernel = wkern(q2,q) + + end function wkernel + + !------------------------------------------------------------ + ! 3D functions to evaluate exact overlap of kernel with wall boundaries + ! see Petkova, Laibe & Bonnell (2018), J. Comp. Phys + !------------------------------------------------------------ + real function wallint(r0, xp, yp, xc, yc, pixwidthx, pixwidthy, hi) + real, intent(in) :: r0, xp, yp, xc, yc, pixwidthx, pixwidthy, hi + real(doub_prec) :: R_0, d1, d2, dx, dy, h + + wallint = 0.0 + dx = xc - xp + dy = yc - yp + h = hi + + ! + ! Contributions from each of the 4 sides of a cell wall + ! + R_0 = 0.5*pixwidthy + dy + d1 = 0.5*pixwidthx - dx + d2 = 0.5*pixwidthx + dx + wallint = wallint + pint3D(r0, R_0, d1, d2, h) + + R_0 = 0.5*pixwidthy - dy + d1 = 0.5*pixwidthx + dx + d2 = 0.5*pixwidthx - dx + wallint = wallint + pint3D(r0, R_0, d1, d2, h) + + R_0 = 0.5*pixwidthx + dx + d1 = 0.5*pixwidthy + dy + d2 = 0.5*pixwidthy - dy + wallint = wallint + pint3D(r0, R_0, d1, d2, h) + + R_0 = 0.5*pixwidthx - dx + d1 = 0.5*pixwidthy - dy + d2 = 0.5*pixwidthy + dy + wallint = wallint + pint3D(r0, R_0, d1, d2, h) + + end function wallint + + real function pint3D(r0, R_0, d1, d2, hi) + + real(doub_prec), intent(in) :: R_0, d1, d2, hi + real, intent(in) :: r0 + real(doub_prec) :: ar0, aR_0 + real(doub_prec) :: int1, int2 + integer :: fflag = 0 + + if (abs(r0) < tiny(0.)) then + pint3D = 0.d0 + return + endif + + if (r0 > 0.d0) then + pint3D = 1.d0 + ar0 = r0 + else + pint3D = -1.d0 + ar0 = -r0 + endif + + if (R_0 > 0.d0) then + aR_0 = R_0 + else + pint3D = -pint3D + aR_0 = -R_0 + endif + + int1 = full_integral_3D(d1, ar0, aR_0, hi) + int2 = full_integral_3D(d2, ar0, aR_0, hi) + + if (int1 < 0.d0) int1 = 0.d0 + if (int2 < 0.d0) int2 = 0.d0 + + if (d1*d2 >= 0) then + pint3D = pint3D*(int1 + int2) + if (int1 + int2 < 0.d0) print*, 'Error: int1 + int2 < 0' + elseif (abs(d1) < abs(d2)) then + pint3D = pint3D*(int2 - int1) + if (int2 - int1 < 0.d0) print*, 'Error: int2 - int1 < 0: ', int1, int2, '(', d1, d2,')' + else + pint3D = pint3D*(int1 - int2) + if (int1 - int2 < 0.d0) print*, 'Error: int1 - int2 < 0: ', int1, int2, '(', d1, d2,')' + endif + + end function pint3D + + real(doub_prec) function full_integral_3D(d, r0, R_0, h) + + real(doub_prec), intent(in) :: d, r0, R_0, h + real(doub_prec) :: B1, B2, B3, a, logs, u, u2, h2 + real(doub_prec), parameter :: pi = 4.*atan(1.) + real(doub_prec) :: tanphi, phi, a2, cosp, cosp2, mu2, mu2_1, r0h, r03, r0h2, r0h3, r0h_2, r0h_3, tanp + real(doub_prec) :: r2, R_, linedist2, phi1, phi2, cosphi, sinphi + real(doub_prec) :: I0, I1, I_1, I_2, I_3, I_4, I_5 + real(doub_prec) :: J_1, J_2, J_3, J_4, J_5 + real(doub_prec) :: D1, D2, D3 + + r0h = r0/h + tanphi = abs(d)/R_0 + phi = atan(tanphi) + + if (abs(r0h) < tiny(0.) .or. abs(R_0/h) < tiny(0.) .or. abs(phi) < tiny(0.)) then + full_integral_3D = 0.0 + return + endif + + h2 = h*h + r03 = r0*r0*r0 + r0h2 = r0h*r0h + r0h3 = r0h2*r0h + r0h_2 = 1./r0h2 + r0h_3 = 1./r0h3 + + if (r0 >= 2.0*h) then + B3 = 0.25*h2*h + elseif (r0 > h) then + B3 = 0.25*r03 *(-4./3. + (r0h) - 0.3*r0h2 + 1./30.*r0h3 - 1./15. *r0h_3+ 8./5.*r0h_2) + B2 = 0.25*r03 *(-4./3. + (r0h) - 0.3*r0h2 + 1./30.*r0h3 - 1./15. *r0h_3) + else + B3 = 0.25*r03 *(-2./3. + 0.3*r0h2 - 0.1*r0h3 + 7./5.*r0h_2) + B2 = 0.25*r03 *(-2./3. + 0.3*r0h2 - 0.1*r0h3 - 1./5.*r0h_2) + B1 = 0.25*r03 *(-2./3. + 0.3*r0h2 - 0.1*r0h3) + endif + + a = R_0/r0 + a2 = a*a + + linedist2 = (r0*r0 + R_0*R_0) + cosphi = cos(phi) + R_ = R_0/cosphi + r2 = (r0*r0 + R_*R_) + + D2 = 0.0 + D3 = 0.0 + + if (linedist2 < h2) then + !////// phi1 business ///// + cosp = R_0/sqrt(h2-r0*r0) + call get_I_terms(cosp,a2,a,I0,I1,I_2,I_3,I_4,I_5) + + D2 = -1./6.*I_2 + 0.25*(r0h) *I_3 - 0.15*r0h2 *I_4 + 1./30.*r0h3 *I_5 - 1./60. *r0h_3 *I1 + (B1-B2)/r03 *I0 + endif + if (linedist2 < 4.*h2) then + !////// phi2 business ///// + cosp = R_0/sqrt(4.0*h2-r0*r0) + call get_I_terms(cosp,a2,a,I0,I1,I_2,I_3,I_4,I_5) + + D3 = 1./3.*I_2 - 0.25*(r0h) *I_3 + 3./40.*r0h2 *I_4 - 1./120.*r0h3 *I_5 + 4./15. *r0h_3 *I1 + (B2-B3)/r03 *I0 + D2 + endif + + !////////////////////////////// + call get_I_terms(cosphi,a2,a,I0,I1,I_2,I_3,I_4,I_5,phi=phi,tanphi=tanphi) + + if (r2 < h2) then + full_integral_3D = r0h3/pi * (1./6. *I_2 - 3./40.*r0h2 *I_4 + 1./40.*r0h3 *I_5 + B1/r03 *I0) + elseif (r2 < 4.*h2) then + full_integral_3D= r0h3/pi * (0.25 * (4./3. *I_2 - (r0/h) *I_3 + 0.3*r0h2 *I_4 - & + & 1./30.*r0h3 *I_5 + 1./15. *r0h_3 *I1) + B2/r03 *I0 + D2) + else + full_integral_3D = r0h3/pi * (-0.25*r0h_3 *I1 + B3/r03 *I0 + D3) + endif + + end function full_integral_3D + + subroutine get_I_terms(cosp,a2,a,I0,I1,I_2,I_3,I_4,I_5,phi,tanphi) + real(doub_prec), intent(in) :: cosp,a2,a + real(doub_prec), intent(out) :: I0,I1,I_2,I_3,I_4,I_5 + real(doub_prec), intent(in), optional :: phi,tanphi + real(doub_prec) :: cosp2,p,tanp,u2,u,logs,I_1,mu2_1,fac + + cosp2 = cosp*cosp + if (present(phi)) then + p = phi + tanp = tanphi + else + p = acos(cosp) + tanp = sqrt(1.-cosp2)/cosp ! tan(p) + endif + + mu2_1 = 1. / (1. + cosp2/a2) + I0 = p + I_2 = p + a2 * tanp + I_4 = p + 2.*a2 * tanp + 1./3.*a2*a2 * tanp*(2. + 1./cosp2) + + u2 = (1.-cosp2)*mu2_1 + u = sqrt(u2) + logs = log((1.+u)/(1.-u)) + I1 = atan2(u,a) + + fac = 1./(1.-u2) + I_1 = 0.5*a*logs + I1 + I_3 = I_1 + a*0.25*(1.+a2)*(2.*u*fac + logs) + I_5 = I_3 + a*(1.+a2)*(1.+a2)/16. *( (10.*u - 6.*u*u2)*fac*fac + 3.*logs) + + end subroutine get_I_terms + + !------------------------------------------------------------ + ! function to return a soft maximum for 1/x with no bias + ! for x >> eps using the cubic spline kernel softening + ! i.e. something equivalent to 1/sqrt(x**2 + eps**2) but + ! with compact support, i.e. f=1/x when x > 2*eps + !------------------------------------------------------------ + pure elemental real function soft_func(x,eps) result(f) + real, intent(in) :: x,eps + real :: q,q2, q4, q6 + + q = x/eps + q2 = q*q + if (q < 1.) then + q4 = q2*q2 + f = (1./eps)*(q4*q/10. - 3.*q4/10. + 2.*q2/3. - 7./5.) + elseif (q < 2.) then + q4 = q2*q2 + f = (1./eps)*(q*(-q4*q + 9.*q4 - 30.*q2*q + 40.*q2 - 48.) + 2.)/(30.*q) + else + f = -1./x + endif + f = -f + + end function soft_func + + !-------------------------------------------------------------------------- + ! + ! utility to wrap pixel index around periodic domain + ! indices that roll beyond the last position are re-introduced at the first + ! + !-------------------------------------------------------------------------- + pure integer function iroll(i,n) + integer, intent(in) :: i,n + + if (i > n) then + iroll = mod(i-1,n) + 1 + elseif (i < 1) then + iroll = n + mod(i,n) ! mod is negative + else + iroll = i + endif + + end function iroll end module interpolations3D + diff --git a/src/utils/interpolate3Dold.F90 b/src/utils/interpolate3Dold.F90 new file mode 100644 index 000000000..8c92e8e82 --- /dev/null +++ b/src/utils/interpolate3Dold.F90 @@ -0,0 +1,367 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.bitbucket.io/ ! +!--------------------------------------------------------------------------! +module interpolations3D +! +! Module containing routine for interpolation from PHANTOM data +! to 3D adaptive mesh +! +! Requires adaptivemesh.f90 module +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: adaptivemesh +! + + implicit none + real, parameter, private :: dpi = 1./3.1415926536d0 + public :: interpolate3D +!$ integer(kind=8), dimension(:), private, allocatable :: ilock + +contains +!-------------------------------------------------------------------------- +! subroutine to interpolate from particle data to even grid of pixels +! +! The data is interpolated according to the formula +! +! datsmooth(pixel) = sum_b weight_b dat_b W(r-r_b, h_b) +! +! where _b is the quantity at the neighbouring particle b and +! W is the smoothing kernel, for which we use the usual cubic spline. +! +! For a standard SPH smoothing the weight function for each particle should be +! +! weight = pmass/(rho*h^3) +! +! this version is written for slices through a rectangular volume, ie. +! assumes a uniform pixel size in x,y, whilst the number of pixels +! in the z direction can be set to the number of cross-section slices. +! +! Input: particle coordinates and h : xyzh(4,npart) +! weight for each particle : weight [ same on all parts in PHANTOM ] +! scalar data to smooth : dat (npart) +! +! Output: smoothed data : datsmooth (npixx,npixy,npixz) +! +! Daniel Price, Monash University 2010 +! daniel.price@monash.edu +!-------------------------------------------------------------------------- + +subroutine interpolate3D(xyzh,weight,npart, & + xmin,datsmooth,nnodes,dxgrid,normalise,dat,ngrid,vertexcen) + use kernel, only:wkern, radkern, radkern2, cnormk + !use adaptivemesh, only:ifirstlevel,nsub,ndim,gridnodes + integer, intent(in) :: npart,nnodes,ngrid(3) + real, intent(in) :: xyzh(:,:)! ,vxyzu(:,:) + real, intent(in) :: weight !,pmass + real, intent(in) :: xmin(3),dxgrid(3) + real, intent(out) :: datsmooth(:,:,:) + logical, intent(in) :: normalise, vertexcen + real, intent(in), optional :: dat(:) + real, allocatable :: datnorm(:,:,:) +! real, dimension(nsub**ndim,nnodes) :: datnorm + integer, parameter :: ndim = 3, nsub=1 + integer :: i,ipix,jpix,kpix,isubmesh,imesh,level,icell + integer :: iprintinterval,iprintnext + integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax + integer :: ipixi,jpixi,kpixi,npixx,npixy,npixz + real :: xi,yi,zi,hi,hi1,hi21,radkernh,qq,wab,q2,const,dyz2,dz2 + real :: xorigi,yorigi,zorigi,xpix,ypix,zpix,dx,dy,dz + real :: dxcell(ndim),xminnew(ndim), dxmax(ndim) + real :: t_start,t_end + real :: termnorm + real :: term + logical :: iprintprogress +!$ integer :: omp_get_num_threads,j +#ifndef _OPENMP + integer(kind=8) :: iprogress +#endif + + print*, "size: ", size(datsmooth) + print*, "datsmooth out of bounds: ", datsmooth(35,1,1) + datsmooth = 0. + dxmax(:) = dxgrid(:) + !datnorm = 0. + if (normalise) then + print "(1x,a)",'interpolating from particles to Einstein toolkit grid (normalised) ...' + else + print "(1x,a)",'interpolating from particles to Einstein toolkit grid (non-normalised) ...' + endif +! if (any(dxmax(:) <= 0.)) then +! print "(1x,a)",'interpolate3D: error: grid size <= 0' +! return +! endif +! if (ilendat /= 0) then +! print "(1x,a)",'interpolate3D: error in interface: dat has non-zero length but is not present' +! return +! endif + if (normalise) then + allocate(datnorm(ngrid(1),ngrid(2),ngrid(3))) + datnorm = 0. + endif + +!$ allocate(ilock(0:nnodes)) +!$ do i=0,nnodes +!$ call omp_init_lock(ilock(i)) +!$ enddo + + ! + !--print a progress report if it is going to take a long time + ! (a "long time" is, however, somewhat system dependent) + ! + iprintprogress = (npart >= 100000) .or. (nnodes > 10000) + ! + !--loop over particles + ! + iprintinterval = 25 + if (npart >= 1e6) iprintinterval = 10 + iprintnext = iprintinterval + ! + !--get starting CPU time + ! + call cpu_time(t_start) + + imesh = 1 + level = 1 + dxcell(:) = dxgrid(:)/real(nsub**level) +! xminpix(:) = xmin(:) - 0.5*dxcell(:) + npixx = ngrid(1) + npixy = ngrid(2) + npixz = ngrid(3) + print "(3(a,i4))",' root grid: ',npixx,' x ',npixy,' x ',npixz + print*, "position of i cell is: ", 1*dxcell(1) + xmin(1) + print*, "npart: ", npart + + const = cnormk ! kernel normalisation constant (3D) + print*,"const: ", const + !stop + + ! + !--loop over particles + ! + !$omp parallel default(none) & + !$omp shared(npart,xyzh,dat,datsmooth,datnorm,vertexcen,const,weight) & + !$omp shared(xmin,imesh,nnodes,level) & + !$omp shared(npixx,npixy,npixz,dxmax,dxcell,normalise) & + !$omp private(i,j,hi,hi1,hi21,termnorm,term) & + !$omp private(xpix,ypix,zpix,dx,dy,dz,dz2,dyz2,qq,q2,wab,radkernh) & + !$omp private(xi,yi,zi,xorigi,yorigi,zorigi,xminnew) & + !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi,icell,isubmesh) & + !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) + !$omp master +!$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' + !$omp end master + !$omp do schedule(guided,10) + over_parts: do i=1,npart + ! + !--report on progress + ! + !print*, i +#ifndef _OPENMP + if (iprintprogress) then + iprogress = nint(100.*i/npart) + if (iprogress >= iprintnext) then + write(*,"('(',i3,'% -',i12,' particles done)')") iprogress,i + iprintnext = iprintnext + iprintinterval + endif + endif +#endif + ! + !--set kernel related quantities + ! + xi = xyzh(1,i); xorigi = xi + yi = xyzh(2,i); yorigi = yi + zi = xyzh(3,i); zorigi = zi + hi = xyzh(4,i) + radkernh = radkern*hi + !print*, "hi: ", hi + if (hi <= 0.) cycle over_parts + hi1 = 1./hi; hi21 = hi1*hi1 + termnorm = const*weight + ! print*, "const: ", const + ! print*, "weight: ", weight + ! print*, "termnorm: ", termnorm + + !radkern = 2.*hi ! radius of the smoothing kernel + !print*, "radkern: ", radkern + !print*, "part pos: ", xi,yi,zi + term = termnorm*dat(i) ! weight for density calculation + ! I don't understand why this doesnt involve any actual smoothing? + !dfac = hi**3/(dxcell(1)*dxcell(2)*dxcell(3)*const) + ! + !--for each particle work out which pixels it contributes to + ! + !print*, "radkern: ", radkern + ipixmin = int((xi - radkernh - xmin(1))/dxcell(1)) + jpixmin = int((yi - radkernh - xmin(2))/dxcell(2)) + kpixmin = int((zi - radkernh - xmin(3))/dxcell(3)) + + ipixmax = int((xi + radkernh - xmin(1))/dxcell(1)) + 1 + jpixmax = int((yi + radkernh - xmin(2))/dxcell(2)) + 1 + kpixmax = nint((zi + radkernh - xmin(3))/dxcell(3)) + 1 + + !if (ipixmax == 33) stop + + + !if (ipixmin == 4 .and. jpixmin == 30 .and. kpixmin == 33) print*, "particle (min): ", i + !if (ipixmax == 4 .and. jpixmax == 30 .and. kpixmax == 33) print*, "particle (max): ", i +#ifndef PERIODIC + if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute + if (jpixmin < 1) jpixmin = 1 ! to pixels in the image + if (kpixmin < 1) kpixmin = 1 + if (ipixmax > npixx) ipixmax = npixx + if (jpixmax > npixy) jpixmax = npixy + if (kpixmax > npixz) kpixmax = npixz + !print*, "ipixmin: ", ipixmin + !print*, "ipixmax: ", ipixmax + !print*, "jpixmin: ", jpixmin + !print*, "jpixmax: ", jpixmax + !print*, "kpixmin: ", kpixmin + !print*, "kpixmax: ", kpixmax +#endif + !print*,' part ',i,' lims = ',ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax + ! + !--loop over pixels, adding the contribution from this particle + ! (note that we handle the periodic boundary conditions + ! entirely on the root grid) + ! + do kpix = kpixmin,kpixmax + kpixi = kpix +#ifdef PERIODIC + if (kpixi < 1) then + kpixi = kpixi + npixz + zi = zorigi !+ dxmax(3) + elseif (kpixi > npixz) then + kpixi = kpixi - npixz + zi = zorigi !- dxmax(3) + else + zi = zorigi + endif +#endif + if (vertexcen) then + zpix = xmin(3) + (kpixi-1)*dxcell(3) + else + zpix = xmin(3) + (kpixi-0.5)*dxcell(3) + endif + dz = zpix - zi + dz2 = dz*dz*hi21 + + do jpix = jpixmin,jpixmax + jpixi = jpix +#ifdef PERIODIC + if (jpixi < 1) then + jpixi = jpixi + npixy + yi = yorigi !+ dxmax(2) + elseif (jpixi > npixy) then + jpixi = jpixi - npixy + yi = yorigi !- dxmax(2) + else + yi = yorigi + endif +#endif + if (vertexcen) then + ypix = xmin(2) + (jpixi-1)*dxcell(2) + else + ypix = xmin(2) + (jpixi-0.5)*dxcell(2) + endif + dy = ypix - yi + dyz2 = dy*dy*hi21 + dz2 + + do ipix = ipixmin,ipixmax + ipixi = ipix +#ifdef PERIODIC + if (ipixi < 1) then + ipixi = ipixi + npixx + xi = xorigi !+ dxmax(1) + elseif (ipixi > npixx) then + if (ipixi == 33) then + print*,"xi old: ", xorigi + print*, "xi new: ", xorigi-dxmax(1) + print*, "ipixi new: ", ipixi - npixx + endif + ipixi = ipixi - npixx + xi = xorigi !- dxmax(1) + else + xi = xorigi + endif +#endif + icell = ((kpixi-1)*nsub + (jpixi-1))*nsub + ipixi + ! + !--particle interpolates directly onto the root grid + ! + !print*,'onto root grid ',ipixi,jpixi,kpixi + if (vertexcen) then + xpix = xmin(1) + (ipixi-1)*dxcell(1) + else + xpix = xmin(1) + (ipixi-0.5)*dxcell(1) + endif + !print*, "xpix: ", xpix + !xpix = xmin(1) + (ipixi-1)*dxcell(1) ! Since we are vertex centered from Et + dx = xpix - xi + q2 = dx*dx*hi21 + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 + ! + !--SPH kernel - standard cubic spline + ! + if (q2 < radkern2) then + ! if (q2 < 1.0) then + ! qq = sqrt(q2) + ! wab = 1.-1.5*q2 + 0.75*q2*qq + ! else + ! qq = sqrt(q2) + ! wab = 0.25*(2.-qq)**3 + ! endif + ! Call the kernel routine + qq = sqrt(q2) + wab = wkern(q2,qq) + ! + !--calculate data value at this pixel using the summation interpolant + ! + ! Change this to the access the pixel coords x,y,z + !$omp critical + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + + !if (ipixi==1 .and. jpixi==1 .and. kpixi==1) print*, "x position of 1,1,1", xi,yi,zi + if (normalise) then + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + endif + !$omp end critical + endif + enddo + enddo + enddo + enddo over_parts + !$omp enddo + !$omp end parallel + +!$ do i=0,nnodes +!$ call omp_destroy_lock(ilock(i)) +!$ enddo +!$ if (allocated(ilock)) deallocate(ilock) + + ! + !--normalise dat array + ! + if (normalise) then + where (datnorm > tiny(datnorm)) + datsmooth = datsmooth/datnorm + end where +endif + if (allocated(datnorm)) deallocate(datnorm) + ! + !--get ending CPU time + ! + call cpu_time(t_end) + print*,'completed in ',t_end-t_start,'s' + + return + +end subroutine interpolate3D + +end module interpolations3D From fb7cd32ed0e513a01c9fc780cc698d379ede0061 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Thu, 30 Mar 2023 17:07:57 +0200 Subject: [PATCH 018/814] [header-bot] updated file headers --- src/main/utils_raytracer.f90 | 1010 +++++++++++++++++----------------- 1 file changed, 502 insertions(+), 508 deletions(-) diff --git a/src/main/utils_raytracer.f90 b/src/main/utils_raytracer.f90 index 165a3dad3..1abe0017c 100644 --- a/src/main/utils_raytracer.f90 +++ b/src/main/utils_raytracer.f90 @@ -6,519 +6,513 @@ !--------------------------------------------------------------------------! module raytracer ! -! This module contains all routines required to: -! - perform radial ray tracing starting from the primary star only -! - calculate optical depth along the rays given the opacity distribution -! - interpolate optical depths to all SPH particles -! Applicable both for single and binary star wind simulations -! -! WARNING: This module has only been tested on phantom wind setup +! raytracer ! ! :References: None ! -! :Owner: Lionel Siess +! :Owner: Not Committed Yet ! ! :Runtime parameters: None ! ! :Dependencies: healpix, kernel, linklist, part, units ! - use healpix - - implicit none - public :: get_all_tau - - private - -contains - - !------------------------------------------------------------------------------------ - !+ - ! MAIN ROUTINE - ! Returns the optical depth at each particle's location using an outward ray-tracing scheme - !+ - ! IN: npart: The number of SPH particles - ! IN: nptmass: The number of sink particles - ! IN: xyzm_ptmass: The array containing the properties of the sink particle - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: kappa_cgs: The array containing the opacities of all SPH particles - ! IN: order: The healpix order which is used for the uniform ray sampling - !+ - ! OUT: tau: The array of optical depths for each SPH particle - !+ - !------------------------------------------------------------------------------------ -subroutine get_all_tau(npart, nptmass, xyzmh_ptmass, xyzh, kappa_cgs, order, tau) - use part, only: iReff - integer, intent(in) :: npart, order, nptmass - real, intent(in) :: kappa_cgs(:), xyzh(:,:), xyzmh_ptmass(:,:) - real, intent(out) :: tau(:) - real :: Rinject - - Rinject = xyzmh_ptmass(iReff,1) - if (nptmass == 2 ) then - call get_all_tau_companion(npart, xyzmh_ptmass(1:3,1), xyzmh_ptmass(iReff,1), xyzh, kappa_cgs, & - Rinject, xyzmh_ptmass(1:3,2), xyzmh_ptmass(iReff,2), order, tau) - else - call get_all_tau_single(npart, xyzmh_ptmass(1:3,1), xyzmh_ptmass(iReff,1), xyzh,& - kappa_cgs, Rinject, order, tau) - endif -end subroutine get_all_tau - - !--------------------------------------------------------------------------------- - !+ - ! Calculates the optical depth at each particle's location, using the uniform outward - ! ray-tracing scheme for models containing a single star - ! - ! Relies on healpix, for more information: https://healpix.sourceforge.io/ - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: kappa: The array containing the kappa of all SPH particles - ! IN: Rstar: The radius of the primary star - ! IN: Rinject: The particles injection radius - ! IN: order: The healpix order which is used for the uniform ray sampling - !+ - ! OUT: taus: The array of optical depths to each SPH particle - !+ - !--------------------------------------------------------------------------------- -subroutine get_all_tau_single(npart, primary, Rstar, xyzh, kappa, Rinject, order, tau) - use part, only : isdead_or_accreted - integer, intent(in) :: npart,order - real, intent(in) :: primary(3), kappa(:), Rstar, Rinject, xyzh(:,:) - real, intent(out) :: tau(:) - - integer :: i, nrays, nsides - real :: ray_dir(3),part_dir(3) - real, dimension(:,:), allocatable :: rays_dist, rays_tau - integer, dimension(:), allocatable :: rays_dim - integer, parameter :: ndim = 200 ! maximum number of points along the ray where tau is calculated - - nrays = 12*4**order ! The number of rays traced given the healpix order - nsides = 2**order ! The healpix nsides given the healpix order - - allocate(rays_dist(ndim, nrays)) ! distance from the central star of the points on the rays - allocate(rays_tau(ndim, nrays)) ! value of tau at each point along each ray - allocate(rays_dim(nrays)) ! effective number of points on the ray (< ndim) - - !------------------------------------------- - ! CONSTRUCT the RAYS given the HEALPix ORDER - ! and determine the optical depth along them - !------------------------------------------- - -!$omp parallel default(none) & -!$omp private(ray_dir) & -!$omp shared(nrays,nsides,primary,kappa,xyzh,Rstar,Rinject,rays_dist,rays_tau,rays_dim) -!$omp do - do i = 1, nrays - !returns ray_dir, the unit vector identifying a ray (index i-1 because healpix starts counting from index 0) - call pix2vec_nest(nsides, i-1, ray_dir) - !calculate the properties along the ray (tau, distance, number of points) - call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i)) - enddo -!$omp enddo -!$omp end parallel - - - !_---------------------------------------------- - ! DETERMINE the optical depth for each particle - ! using the values available on the HEALPix rays - !----------------------------------------------- - -!$omp parallel default(none) & -!$omp private(part_dir) & -!$omp shared(npart,primary,nsides,xyzh,ray_dir,rays_dist,rays_tau,rays_dim,tau) -!$omp do - do i = 1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - part_dir = xyzh(1:3,i)-primary - call interpolate_tau(nsides, part_dir, rays_tau, rays_dist, rays_dim, tau(i)) - else - tau(i) = -99. - endif - enddo -!$omp enddo -!$omp end parallel - -end subroutine get_all_tau_single - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth at each particle's location, using the uniform outward - ! ray-tracing scheme for models containing a primary star and a companion - ! - ! Relies on healpix, for more information: https://healpix.sourceforge.io/ - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: kappa: The array containing the opacity of all the SPH particles - ! IN: Rstar: The radius of the primary star - ! IN: Rinject: The particles injection radius - ! IN: companion: The xyz coordinates of the companion - ! IN: Rcomp: The radius of the companion - ! IN: order: The healpix order which is used for the uniform ray sampling - !+ - ! OUT: tau: The array of optical depths for each SPH particle - !+ - !-------------------------------------------------------------------------- -subroutine get_all_tau_companion(npart, primary, Rstar, xyzh, kappa, Rinject, companion, Rcomp, order, tau) - use part, only : isdead_or_accreted - integer, intent(in) :: npart, order - real, intent(in) :: primary(3), companion(3), kappa(:), Rstar, Rinject, xyzh(:,:), Rcomp - real, intent(out) :: tau(:) - - integer :: i, nrays, nsides - real :: normCompanion,theta0,phi,cosphi,sinphi,theta,sep,root - real :: ray_dir(3),part_dir(3),uvecCompanion(3) - real, dimension(:,:), allocatable :: rays_dist, rays_tau - integer, dimension(:), allocatable :: rays_dim - integer, parameter :: ndim = 200 ! maximum number of points along the ray where tau is calculated - - nrays = 12*4**order ! The number of rays traced given the healpix order - nsides = 2**order ! The healpix nsides given the healpix order - - allocate(rays_dist(ndim, nrays)) ! distance from the central star of the points on the rays - allocate(rays_tau(ndim, nrays)) ! value of tau at each point along each ray - allocate(rays_dim(nrays)) ! effective number of points on the ray (< ndim) - - uvecCompanion = companion-primary - normCompanion = norm2(uvecCompanion) - uvecCompanion = uvecCompanion/normCompanion - theta0 = asin(Rcomp/normCompanion) - phi = atan2(uvecCompanion(2),uvecCompanion(1)) - cosphi = cos(phi) - sinphi = sin(phi) - - !------------------------------------------- - ! CONSTRUCT the RAYS given the HEALPix ORDER - ! and determine the optical depth along them - !------------------------------------------- - -!$omp parallel default(none) & -!$omp private(ray_dir,theta,root,sep) & -!$omp shared(nrays,nsides,primary,kappa,xyzh,Rstar,Rinject,Rcomp,rays_dist,rays_tau,rays_dim) & -!$omp shared(uvecCompanion,normCompanion,cosphi,sinphi,theta0) -!$omp do - do i = 1, nrays - !returns ray_dir, the unit vector identifying a ray (index i-1 because healpix starts counting from index 0) - call pix2vec_nest(nsides, i-1, ray_dir) - !rotate ray vectors by an angle = phi so the main axis points to the companion (This is because along the - !main axis (1,0,0) rays are distributed more uniformally - ray_dir = (/cosphi*ray_dir(1) - sinphi*ray_dir(2),sinphi*ray_dir(1) + cosphi*ray_dir(2), ray_dir(3)/) - theta = acos(dot_product(uvecCompanion, ray_dir)) - !the ray intersects the companion: only calculate tau up to the companion - if (theta < theta0) then - root = sqrt(Rcomp**2-normCompanion**2*sin(theta)**2) - sep = normCompanion*cos(theta)-root - call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i), sep) - else - call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i)) - endif - enddo -!$omp enddo -!$omp end parallel - - !----------------------------------------------- - ! DETERMINE the optical depth for each particle - ! using the values available on the HEALPix rays - !----------------------------------------------- - -!$omp parallel default(none) & -!$omp private(part_dir) & -!$omp shared(npart,primary,cosphi,sinphi,nsides,xyzh,ray_dir,rays_dist,rays_tau,rays_dim,tau) -!$omp do - do i = 1, npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - !vector joining the source to the particle - part_dir = xyzh(1:3,i)-primary - part_dir = (/cosphi*part_dir(1) + sinphi*part_dir(2),-sinphi*part_dir(1) + cosphi*part_dir(2), part_dir(3)/) - call interpolate_tau(nsides, part_dir, rays_tau, rays_dist, rays_dim, tau(i)) - else - tau(i) = -99. - endif - enddo -!$omp enddo -!$omp end parallel -end subroutine get_all_tau_companion - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth at the SPH particle's location. - ! Search for the four closest rays to a particle, perform four-point - ! interpolation of the optical depth from these rays. Weighted by the - ! inverse square of the perpendicular distance to the rays. - ! - ! Relies on healpix, for more information: https://healpix.sourceforge.io/ - !+ - ! IN: nsides: The healpix nsides of the simulation - ! IN: vec: The vector from the primary to the particle - ! IN: rays_tau: 2-dimensional array containing the cumulative optical - ! depth along each ray - ! IN: rays_dist: 2-dimensional array containing the distances from the - ! primary along each ray - ! IN: rays_dim: The vector containing the number of points defined along each ray - !+ - ! OUT: tau: The interpolated optical depth at the particle's location - !+ - !-------------------------------------------------------------------------- -subroutine interpolate_tau(nsides, vec, rays_tau, rays_dist, rays_dim, tau) - integer, intent(in) :: nsides, rays_dim(:) - real, intent(in) :: vec(:), rays_dist(:,:), rays_tau(:,:) - real, intent(out) :: tau - - integer :: rayIndex, neighbours(8), nneigh, i, k - real :: tautemp, ray(3), vectemp(3), weight, tempdist(8), distRay_sq, vec_norm2 - logical :: mask(8) - - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector of the HEALPix cell that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - !compute optical depth along ray rayIndex(+1) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - !determine distance of the particle to the HEALPix ray - vectemp = vec - vec_norm2*ray - distRay_sq = dot_product(vectemp,vectemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to interpolate with the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number rayIndex - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = dot_product(vectemp,vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight -end subroutine interpolate_tau - - - !-------------------------------------------------------------------------- - !+ - ! Interpolation of the optical depth for an arbitrary point on the ray, - ! at a given distance to the starting point of the ray (primary star). - !+ - ! IN: distance: The distance from the staring point of the ray to a - ! point on the ray - ! IN: tau_along_ray: The vector of cumulative optical depths along the ray - ! IN: dist_along_ray: The vector of distances from the primary along the ray - ! IN: len: The length of tau_along_ray and dist_along_ray - !+ - ! OUT: tau: The optical depth to the given distance along the ray - !+ - !-------------------------------------------------------------------------- -subroutine get_tau_on_ray(distance, tau_along_ray, dist_along_ray, len, tau) - real, intent(in) :: distance, tau_along_ray(:), dist_along_ray(:) - integer, intent(in) :: len - real, intent(out) :: tau - - integer :: L, R, m ! left, right and middle index for binary search - - if (distance < dist_along_ray(1)) then - tau = tau_along_ray(1) - elseif (distance > dist_along_ray(len)) then - tau = tau_along_ray(len) - else - L = 2 - R = len - !bysection search for the index of the closest points on the ray to the specified location - do while (L < R) - m = (L + R)/2 - if (dist_along_ray(m) > distance) then - R = m - else - L = m + 1 - endif - enddo - !linear interpolation of the optical depth at the the point's location - tau = tau_along_ray(L-1)+(tau_along_ray(L)-tau_along_ray(L-1))/ & - (dist_along_ray(L)-dist_along_ray(L-1))*(distance-dist_along_ray(L-1)) - endif -end subroutine get_tau_on_ray - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth along a given ray - !+ - ! IN: primary: The location of the primary star - ! IN: ray: The unit vector of the direction in which the - ! optical depth will be calculated - ! IN: xyzh: The array containing the particles position+smoothing lenght - ! IN: kappa: The array containing the particles opacity - ! IN: Rstar: The radius of the primary star - ! IN: Rinject: The particles injection radius - !+ - ! OUT: tau_along_ray: The vector of cumulative optical depth along the ray - ! OUT: dist_along_ray: The vector of distances from the primary along the ray - ! OUT: len: The length of tau_along_ray and dist_along_ray - !+ - ! OPT: maxDistance: The maximal distance the ray needs to be traced - !+ - !-------------------------------------------------------------------------- -subroutine ray_tracer(primary, ray, xyzh, kappa, Rstar, Rinject, tau_along_ray, dist_along_ray, len, maxDistance) - use units, only:unit_opacity - use part, only:itauL_alloc - real, intent(in) :: primary(3), ray(3), Rstar, Rinject, xyzh(:,:), kappa(:) - real, optional :: maxDistance - real, intent(out) :: dist_along_ray(:), tau_along_ray(:) - integer, intent(out) :: len - real, parameter :: tau_max = 99. - - real :: dr, next_dr, h, dtaudr, previousdtaudr, nextdtaudr, distance - integer :: inext, i, L, R, m ! left, right and middle index for binary search - - h = Rinject/100. - inext=0 - do while (inext==0) - h = h*2. - !find the next point along the ray : index inext - call find_next(primary+Rinject*ray, h, ray, xyzh, kappa, previousdtaudr, dr, inext) - enddo - - i = 1 - tau_along_ray(i) = 0. - distance = Rinject - dist_along_ray(i) = distance - do while (hasNext(inext,tau_along_ray(i),distance,maxDistance)) - distance = distance+dr - call find_next(primary + distance*ray, xyzh(4,inext), ray, xyzh, kappa, nextdtaudr, next_dr, inext) - i = i + 1 - if (itauL_alloc > 0) nextdtaudr = nextdtaudr*(Rstar/distance)**2 - dtaudr = (nextdtaudr+previousdtaudr)/2. - previousdtaudr = nextdtaudr - !fix units for tau (kappa is in cgs while rho & r are in code units) - tau_along_ray(i) = tau_along_ray(i-1) + real(dr*dtaudr/unit_opacity) - dist_along_ray(i) = distance - dr = next_dr - enddo - - if (itauL_alloc == 0 .and. present(maxDistance)) then - i = i + 1 - tau_along_ray(i) = tau_max - dist_along_ray(i) = maxDistance - endif - len = i - - if (itauL_alloc > 0) then - !reverse integration start from zero inward - tau_along_ray(1:len) = tau_along_ray(len) - tau_along_ray(1:len) - !find the first point where tau_lucy < 2/3 - if (tau_along_ray(1) > 2./3.) then - L = 1 - R = len - !bysection search for the index of the closest point to tau = 2/3 - do while (L < R) - m = (L + R)/2 - if (tau_along_ray(m) < 2./3.) then - R = m - else - L = m + 1 - endif - enddo - tau_along_ray(1:L) = 2./3. - !The photosphere is located between ray grid point L and L+1, may be useful information! - endif - endif -end subroutine ray_tracer - -logical function hasNext(inext, tau, distance, maxDistance) - integer, intent(in) :: inext - real, intent(in) :: tau, distance - real, optional :: maxDistance - real :: tau_max = 99. - if (present(maxDistance)) then - hasNext = inext /= 0 .and. distance < maxDistance .and. tau < tau_max - else - hasNext = inext /= 0 .and. tau < tau_max - endif -end function hasNext - - !-------------------------------------------------------------------------- - !+ - ! First finds the local optical depth derivative at the starting point, then finds the next - ! point on a ray and the distance to this point - !+ - ! IN: inpoint: The coordinate of the initial point projected on the ray - ! for which the opacity and the next point will be calculated - ! IN: h: The smoothing length at the initial point - ! IN: ray: The unit vector of the direction in which the next - ! point will be calculated - ! IN: xyzh: The array containing the particles position+smoothing length - ! IN: kappa: The array containing the particles opacity - ! IN: inext: The index of the initial point - ! (this point will not be considered as possible next point) - !+ - ! OUT: dtaudr: The radial optical depth derivative at the given location (inpoint) - ! OUT: distance: The distance to the next point - ! OUT: inext: The index of the next point on the ray - !+ - !-------------------------------------------------------------------------- -subroutine find_next(inpoint, h, ray, xyzh, kappa, dtaudr, distance, inext) - use linklist, only:getneigh_pos,ifirstincell,listneigh - use kernel, only:radkern,cnormk,wkern - use part, only:hfact,rhoh,massoftype,igas - real, intent(in) :: xyzh(:,:), kappa(:), inpoint(:), ray(:), h - integer, intent(inout) :: inext - real, intent(out) :: distance, dtaudr - - integer, parameter :: nmaxcache = 0 - real :: xyzcache(0,nmaxcache) - - integer :: nneigh, i, prev - real :: dmin, vec(3), dr, raydistance, q, norm_sq - - prev = inext - inext = 0 - distance = 0. - - !for a given point (inpoint), returns the list of neighbouring particles (listneigh) within a radius h*radkern - call getneigh_pos(inpoint,0.,h*radkern,3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) - - dtaudr = 0. - dmin = huge(0.) - !loop over all neighbours - do i=1,nneigh - vec = xyzh(1:3,listneigh(i)) - inpoint - norm_sq = dot_product(vec,vec) - q = sqrt(norm_sq)/xyzh(4,listneigh(i)) - !add optical depth contribution from each particle - dtaudr = dtaudr+wkern(q*q,q)*kappa(listneigh(i))*rhoh(xyzh(4,listneigh(i)), massoftype(igas)) - - ! find the next particle : among the neighbours find the particle located the closest to the ray - if (listneigh(i) /= prev) then - dr = dot_product(vec,ray) !projected distance along the ray - if (dr>0.) then - !distance perpendicular to the ray direction - raydistance = norm_sq - dr**2 - if (raydistance < dmin) then - dmin = raydistance - inext = listneigh(i) - distance = dr - endif - endif - endif - enddo - dtaudr = dtaudr*cnormk/hfact**3 -end subroutine find_next -end module raytracer + use healpix + + implicit none + public :: get_all_tau + + private + + contains + + !------------------------------------------------------------------------------------ + !+ + ! MAIN ROUTINE + ! Returns the optical depth at each particle's location using an outward ray-tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: nptmass: The number of sink particles + ! IN: xyzm_ptmass: The array containing the properties of the sink particle + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa_cgs: The array containing the opacities of all SPH particles + ! IN: order: The healpix order which is used for the uniform ray sampling + !+ + ! OUT: tau: The array of optical depths for each SPH particle + !+ + !------------------------------------------------------------------------------------ + subroutine get_all_tau(npart, nptmass, xyzmh_ptmass, xyzh, kappa_cgs, order, tau) + use part, only: iReff + integer, intent(in) :: npart, order, nptmass + real, intent(in) :: kappa_cgs(:), xyzh(:,:), xyzmh_ptmass(:,:) + real, intent(out) :: tau(:) + real :: Rinject + + Rinject = xyzmh_ptmass(iReff,1) + if (nptmass == 2 ) then + call get_all_tau_companion(npart, xyzmh_ptmass(1:3,1), xyzmh_ptmass(iReff,1), xyzh, kappa_cgs, & + Rinject, xyzmh_ptmass(1:3,2), xyzmh_ptmass(iReff,2), order, tau) + else + call get_all_tau_single(npart, xyzmh_ptmass(1:3,1), xyzmh_ptmass(iReff,1), xyzh,& + kappa_cgs, Rinject, order, tau) + endif + end subroutine get_all_tau + + !--------------------------------------------------------------------------------- + !+ + ! Calculates the optical depth at each particle's location, using the uniform outward + ! ray-tracing scheme for models containing a single star + ! + ! Relies on healpix, for more information: https://healpix.sourceforge.io/ + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa: The array containing the kappa of all SPH particles + ! IN: Rstar: The radius of the primary star + ! IN: Rinject: The particles injection radius + ! IN: order: The healpix order which is used for the uniform ray sampling + !+ + ! OUT: taus: The array of optical depths to each SPH particle + !+ + !--------------------------------------------------------------------------------- + subroutine get_all_tau_single(npart, primary, Rstar, xyzh, kappa, Rinject, order, tau) + use part, only : isdead_or_accreted + integer, intent(in) :: npart,order + real, intent(in) :: primary(3), kappa(:), Rstar, Rinject, xyzh(:,:) + real, intent(out) :: tau(:) + + integer :: i, nrays, nsides + real :: ray_dir(3),part_dir(3) + real, dimension(:,:), allocatable :: rays_dist, rays_tau + integer, dimension(:), allocatable :: rays_dim + integer, parameter :: ndim = 200 ! maximum number of points along the ray where tau is calculated + + nrays = 12*4**order ! The number of rays traced given the healpix order + nsides = 2**order ! The healpix nsides given the healpix order + + allocate(rays_dist(ndim, nrays)) ! distance from the central star of the points on the rays + allocate(rays_tau(ndim, nrays)) ! value of tau at each point along each ray + allocate(rays_dim(nrays)) ! effective number of points on the ray (< ndim) + + !------------------------------------------- + ! CONSTRUCT the RAYS given the HEALPix ORDER + ! and determine the optical depth along them + !------------------------------------------- + + !$omp parallel default(none) & + !$omp private(ray_dir) & + !$omp shared(nrays,nsides,primary,kappa,xyzh,Rstar,Rinject,rays_dist,rays_tau,rays_dim) + !$omp do + do i = 1, nrays + !returns ray_dir, the unit vector identifying a ray (index i-1 because healpix starts counting from index 0) + call pix2vec_nest(nsides, i-1, ray_dir) + !calculate the properties along the ray (tau, distance, number of points) + call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i)) + enddo + !$omp enddo + !$omp end parallel + + + !_---------------------------------------------- + ! DETERMINE the optical depth for each particle + ! using the values available on the HEALPix rays + !----------------------------------------------- + + !$omp parallel default(none) & + !$omp private(part_dir) & + !$omp shared(npart,primary,nsides,xyzh,ray_dir,rays_dist,rays_tau,rays_dim,tau) + !$omp do + do i = 1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + part_dir = xyzh(1:3,i)-primary + call interpolate_tau(nsides, part_dir, rays_tau, rays_dist, rays_dim, tau(i)) + else + tau(i) = -99. + endif + enddo + !$omp enddo + !$omp end parallel + + end subroutine get_all_tau_single + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth at each particle's location, using the uniform outward + ! ray-tracing scheme for models containing a primary star and a companion + ! + ! Relies on healpix, for more information: https://healpix.sourceforge.io/ + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + ! IN: Rinject: The particles injection radius + ! IN: companion: The xyz coordinates of the companion + ! IN: Rcomp: The radius of the companion + ! IN: order: The healpix order which is used for the uniform ray sampling + !+ + ! OUT: tau: The array of optical depths for each SPH particle + !+ + !-------------------------------------------------------------------------- + subroutine get_all_tau_companion(npart, primary, Rstar, xyzh, kappa, Rinject, companion, Rcomp, order, tau) + use part, only : isdead_or_accreted + integer, intent(in) :: npart, order + real, intent(in) :: primary(3), companion(3), kappa(:), Rstar, Rinject, xyzh(:,:), Rcomp + real, intent(out) :: tau(:) + + integer :: i, nrays, nsides + real :: normCompanion,theta0,phi,cosphi,sinphi,theta,sep,root + real :: ray_dir(3),part_dir(3),uvecCompanion(3) + real, dimension(:,:), allocatable :: rays_dist, rays_tau + integer, dimension(:), allocatable :: rays_dim + integer, parameter :: ndim = 200 ! maximum number of points along the ray where tau is calculated + + nrays = 12*4**order ! The number of rays traced given the healpix order + nsides = 2**order ! The healpix nsides given the healpix order + + allocate(rays_dist(ndim, nrays)) ! distance from the central star of the points on the rays + allocate(rays_tau(ndim, nrays)) ! value of tau at each point along each ray + allocate(rays_dim(nrays)) ! effective number of points on the ray (< ndim) + + uvecCompanion = companion-primary + normCompanion = norm2(uvecCompanion) + uvecCompanion = uvecCompanion/normCompanion + theta0 = asin(Rcomp/normCompanion) + phi = atan2(uvecCompanion(2),uvecCompanion(1)) + cosphi = cos(phi) + sinphi = sin(phi) + + !------------------------------------------- + ! CONSTRUCT the RAYS given the HEALPix ORDER + ! and determine the optical depth along them + !------------------------------------------- + + !$omp parallel default(none) & + !$omp private(ray_dir,theta,root,sep) & + !$omp shared(nrays,nsides,primary,kappa,xyzh,Rstar,Rinject,Rcomp,rays_dist,rays_tau,rays_dim) & + !$omp shared(uvecCompanion,normCompanion,cosphi,sinphi,theta0) + !$omp do + do i = 1, nrays + !returns ray_dir, the unit vector identifying a ray (index i-1 because healpix starts counting from index 0) + call pix2vec_nest(nsides, i-1, ray_dir) + !rotate ray vectors by an angle = phi so the main axis points to the companion (This is because along the + !main axis (1,0,0) rays are distributed more uniformally + ray_dir = (/cosphi*ray_dir(1) - sinphi*ray_dir(2),sinphi*ray_dir(1) + cosphi*ray_dir(2), ray_dir(3)/) + theta = acos(dot_product(uvecCompanion, ray_dir)) + !the ray intersects the companion: only calculate tau up to the companion + if (theta < theta0) then + root = sqrt(Rcomp**2-normCompanion**2*sin(theta)**2) + sep = normCompanion*cos(theta)-root + call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i), sep) + else + call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i)) + endif + enddo + !$omp enddo + !$omp end parallel + + !----------------------------------------------- + ! DETERMINE the optical depth for each particle + ! using the values available on the HEALPix rays + !----------------------------------------------- + + !$omp parallel default(none) & + !$omp private(part_dir) & + !$omp shared(npart,primary,cosphi,sinphi,nsides,xyzh,ray_dir,rays_dist,rays_tau,rays_dim,tau) + !$omp do + do i = 1, npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + !vector joining the source to the particle + part_dir = xyzh(1:3,i)-primary + part_dir = (/cosphi*part_dir(1) + sinphi*part_dir(2),-sinphi*part_dir(1) + cosphi*part_dir(2), part_dir(3)/) + call interpolate_tau(nsides, part_dir, rays_tau, rays_dist, rays_dim, tau(i)) + else + tau(i) = -99. + endif + enddo + !$omp enddo + !$omp end parallel + end subroutine get_all_tau_companion + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth at the SPH particle's location. + ! Search for the four closest rays to a particle, perform four-point + ! interpolation of the optical depth from these rays. Weighted by the + ! inverse square of the perpendicular distance to the rays. + ! + ! Relies on healpix, for more information: https://healpix.sourceforge.io/ + !+ + ! IN: nsides: The healpix nsides of the simulation + ! IN: vec: The vector from the primary to the particle + ! IN: rays_tau: 2-dimensional array containing the cumulative optical + ! depth along each ray + ! IN: rays_dist: 2-dimensional array containing the distances from the + ! primary along each ray + ! IN: rays_dim: The vector containing the number of points defined along each ray + !+ + ! OUT: tau: The interpolated optical depth at the particle's location + !+ + !-------------------------------------------------------------------------- + subroutine interpolate_tau(nsides, vec, rays_tau, rays_dist, rays_dim, tau) + integer, intent(in) :: nsides, rays_dim(:) + real, intent(in) :: vec(:), rays_dist(:,:), rays_tau(:,:) + real, intent(out) :: tau + + integer :: rayIndex, neighbours(8), nneigh, i, k + real :: tautemp, ray(3), vectemp(3), weight, tempdist(8), distRay_sq, vec_norm2 + logical :: mask(8) + + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector of the HEALPix cell that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + !compute optical depth along ray rayIndex(+1) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + !determine distance of the particle to the HEALPix ray + vectemp = vec - vec_norm2*ray + distRay_sq = dot_product(vectemp,vectemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to interpolate with the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number rayIndex + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = dot_product(vectemp,vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + end subroutine interpolate_tau + + + !-------------------------------------------------------------------------- + !+ + ! Interpolation of the optical depth for an arbitrary point on the ray, + ! at a given distance to the starting point of the ray (primary star). + !+ + ! IN: distance: The distance from the staring point of the ray to a + ! point on the ray + ! IN: tau_along_ray: The vector of cumulative optical depths along the ray + ! IN: dist_along_ray: The vector of distances from the primary along the ray + ! IN: len: The length of tau_along_ray and dist_along_ray + !+ + ! OUT: tau: The optical depth to the given distance along the ray + !+ + !-------------------------------------------------------------------------- + subroutine get_tau_on_ray(distance, tau_along_ray, dist_along_ray, len, tau) + real, intent(in) :: distance, tau_along_ray(:), dist_along_ray(:) + integer, intent(in) :: len + real, intent(out) :: tau + + integer :: L, R, m ! left, right and middle index for binary search + + if (distance < dist_along_ray(1)) then + tau = tau_along_ray(1) + elseif (distance > dist_along_ray(len)) then + tau = tau_along_ray(len) + else + L = 2 + R = len + !bysection search for the index of the closest points on the ray to the specified location + do while (L < R) + m = (L + R)/2 + if (dist_along_ray(m) > distance) then + R = m + else + L = m + 1 + endif + enddo + !linear interpolation of the optical depth at the the point's location + tau = tau_along_ray(L-1)+(tau_along_ray(L)-tau_along_ray(L-1))/ & + (dist_along_ray(L)-dist_along_ray(L-1))*(distance-dist_along_ray(L-1)) + endif + end subroutine get_tau_on_ray + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth along a given ray + !+ + ! IN: primary: The location of the primary star + ! IN: ray: The unit vector of the direction in which the + ! optical depth will be calculated + ! IN: xyzh: The array containing the particles position+smoothing lenght + ! IN: kappa: The array containing the particles opacity + ! IN: Rstar: The radius of the primary star + ! IN: Rinject: The particles injection radius + !+ + ! OUT: tau_along_ray: The vector of cumulative optical depth along the ray + ! OUT: dist_along_ray: The vector of distances from the primary along the ray + ! OUT: len: The length of tau_along_ray and dist_along_ray + !+ + ! OPT: maxDistance: The maximal distance the ray needs to be traced + !+ + !-------------------------------------------------------------------------- + subroutine ray_tracer(primary, ray, xyzh, kappa, Rstar, Rinject, tau_along_ray, dist_along_ray, len, maxDistance) + use units, only:unit_opacity + use part, only:itauL_alloc + real, intent(in) :: primary(3), ray(3), Rstar, Rinject, xyzh(:,:), kappa(:) + real, optional :: maxDistance + real, intent(out) :: dist_along_ray(:), tau_along_ray(:) + integer, intent(out) :: len + real, parameter :: tau_max = 99. + + real :: dr, next_dr, h, dtaudr, previousdtaudr, nextdtaudr, distance + integer :: inext, i, L, R, m ! left, right and middle index for binary search + + h = Rinject/100. + inext=0 + do while (inext==0) + h = h*2. + !find the next point along the ray : index inext + call find_next(primary+Rinject*ray, h, ray, xyzh, kappa, previousdtaudr, dr, inext) + enddo + + i = 1 + tau_along_ray(i) = 0. + distance = Rinject + dist_along_ray(i) = distance + do while (hasNext(inext,tau_along_ray(i),distance,maxDistance)) + distance = distance+dr + call find_next(primary + distance*ray, xyzh(4,inext), ray, xyzh, kappa, nextdtaudr, next_dr, inext) + i = i + 1 + if (itauL_alloc > 0) nextdtaudr = nextdtaudr*(Rstar/distance)**2 + dtaudr = (nextdtaudr+previousdtaudr)/2. + previousdtaudr = nextdtaudr + !fix units for tau (kappa is in cgs while rho & r are in code units) + tau_along_ray(i) = tau_along_ray(i-1) + real(dr*dtaudr/unit_opacity) + dist_along_ray(i) = distance + dr = next_dr + enddo + + if (itauL_alloc == 0 .and. present(maxDistance)) then + i = i + 1 + tau_along_ray(i) = tau_max + dist_along_ray(i) = maxDistance + endif + len = i + + if (itauL_alloc > 0) then + !reverse integration start from zero inward + tau_along_ray(1:len) = tau_along_ray(len) - tau_along_ray(1:len) + !find the first point where tau_lucy < 2/3 + if (tau_along_ray(1) > 2./3.) then + L = 1 + R = len + !bysection search for the index of the closest point to tau = 2/3 + do while (L < R) + m = (L + R)/2 + if (tau_along_ray(m) < 2./3.) then + R = m + else + L = m + 1 + endif + enddo + tau_along_ray(1:L) = 2./3. + !The photosphere is located between ray grid point L and L+1, may be useful information! + endif + endif + end subroutine ray_tracer + + logical function hasNext(inext, tau, distance, maxDistance) + integer, intent(in) :: inext + real, intent(in) :: tau, distance + real, optional :: maxDistance + real :: tau_max = 99. + if (present(maxDistance)) then + hasNext = inext /= 0 .and. distance < maxDistance .and. tau < tau_max + else + hasNext = inext /= 0 .and. tau < tau_max + endif + end function hasNext + + !-------------------------------------------------------------------------- + !+ + ! First finds the local optical depth derivative at the starting point, then finds the next + ! point on a ray and the distance to this point + !+ + ! IN: inpoint: The coordinate of the initial point projected on the ray + ! for which the opacity and the next point will be calculated + ! IN: h: The smoothing length at the initial point + ! IN: ray: The unit vector of the direction in which the next + ! point will be calculated + ! IN: xyzh: The array containing the particles position+smoothing length + ! IN: kappa: The array containing the particles opacity + ! IN: inext: The index of the initial point + ! (this point will not be considered as possible next point) + !+ + ! OUT: dtaudr: The radial optical depth derivative at the given location (inpoint) + ! OUT: distance: The distance to the next point + ! OUT: inext: The index of the next point on the ray + !+ + !-------------------------------------------------------------------------- + subroutine find_next(inpoint, h, ray, xyzh, kappa, dtaudr, distance, inext) + use linklist, only:getneigh_pos,ifirstincell,listneigh + use kernel, only:radkern,cnormk,wkern + use part, only:hfact,rhoh,massoftype,igas + real, intent(in) :: xyzh(:,:), kappa(:), inpoint(:), ray(:), h + integer, intent(inout) :: inext + real, intent(out) :: distance, dtaudr + + integer, parameter :: nmaxcache = 0 + real :: xyzcache(0,nmaxcache) + + integer :: nneigh, i, prev + real :: dmin, vec(3), dr, raydistance, q, norm_sq + + prev = inext + inext = 0 + distance = 0. + + !for a given point (inpoint), returns the list of neighbouring particles (listneigh) within a radius h*radkern + call getneigh_pos(inpoint,0.,h*radkern,3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) + + dtaudr = 0. + dmin = huge(0.) + !loop over all neighbours + do i=1,nneigh + vec = xyzh(1:3,listneigh(i)) - inpoint + norm_sq = dot_product(vec,vec) + q = sqrt(norm_sq)/xyzh(4,listneigh(i)) + !add optical depth contribution from each particle + dtaudr = dtaudr+wkern(q*q,q)*kappa(listneigh(i))*rhoh(xyzh(4,listneigh(i)), massoftype(igas)) + + ! find the next particle : among the neighbours find the particle located the closest to the ray + if (listneigh(i) /= prev) then + dr = dot_product(vec,ray) !projected distance along the ray + if (dr>0.) then + !distance perpendicular to the ray direction + raydistance = norm_sq - dr**2 + if (raydistance < dmin) then + dmin = raydistance + inext = listneigh(i) + distance = dr + endif + endif + endif + enddo + dtaudr = dtaudr*cnormk/hfact**3 + end subroutine find_next + end module raytracer From 48dde220f925a2fbd63838cd0c6dbfcb33ee3778 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Thu, 30 Mar 2023 17:08:02 +0200 Subject: [PATCH 019/814] [indent-bot] standardised indentation --- src/main/utils_raytracer.f90 | 992 +++++++++++++++++------------------ 1 file changed, 496 insertions(+), 496 deletions(-) diff --git a/src/main/utils_raytracer.f90 b/src/main/utils_raytracer.f90 index 1abe0017c..e68deddef 100644 --- a/src/main/utils_raytracer.f90 +++ b/src/main/utils_raytracer.f90 @@ -16,503 +16,503 @@ module raytracer ! ! :Dependencies: healpix, kernel, linklist, part, units ! - use healpix - - implicit none - public :: get_all_tau - - private - - contains - - !------------------------------------------------------------------------------------ - !+ - ! MAIN ROUTINE - ! Returns the optical depth at each particle's location using an outward ray-tracing scheme - !+ - ! IN: npart: The number of SPH particles - ! IN: nptmass: The number of sink particles - ! IN: xyzm_ptmass: The array containing the properties of the sink particle - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: kappa_cgs: The array containing the opacities of all SPH particles - ! IN: order: The healpix order which is used for the uniform ray sampling - !+ - ! OUT: tau: The array of optical depths for each SPH particle - !+ - !------------------------------------------------------------------------------------ - subroutine get_all_tau(npart, nptmass, xyzmh_ptmass, xyzh, kappa_cgs, order, tau) - use part, only: iReff - integer, intent(in) :: npart, order, nptmass - real, intent(in) :: kappa_cgs(:), xyzh(:,:), xyzmh_ptmass(:,:) - real, intent(out) :: tau(:) - real :: Rinject - - Rinject = xyzmh_ptmass(iReff,1) - if (nptmass == 2 ) then - call get_all_tau_companion(npart, xyzmh_ptmass(1:3,1), xyzmh_ptmass(iReff,1), xyzh, kappa_cgs, & + use healpix + + implicit none + public :: get_all_tau + + private + +contains + + !------------------------------------------------------------------------------------ + !+ + ! MAIN ROUTINE + ! Returns the optical depth at each particle's location using an outward ray-tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: nptmass: The number of sink particles + ! IN: xyzm_ptmass: The array containing the properties of the sink particle + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa_cgs: The array containing the opacities of all SPH particles + ! IN: order: The healpix order which is used for the uniform ray sampling + !+ + ! OUT: tau: The array of optical depths for each SPH particle + !+ + !------------------------------------------------------------------------------------ +subroutine get_all_tau(npart, nptmass, xyzmh_ptmass, xyzh, kappa_cgs, order, tau) + use part, only: iReff + integer, intent(in) :: npart, order, nptmass + real, intent(in) :: kappa_cgs(:), xyzh(:,:), xyzmh_ptmass(:,:) + real, intent(out) :: tau(:) + real :: Rinject + + Rinject = xyzmh_ptmass(iReff,1) + if (nptmass == 2 ) then + call get_all_tau_companion(npart, xyzmh_ptmass(1:3,1), xyzmh_ptmass(iReff,1), xyzh, kappa_cgs, & Rinject, xyzmh_ptmass(1:3,2), xyzmh_ptmass(iReff,2), order, tau) - else - call get_all_tau_single(npart, xyzmh_ptmass(1:3,1), xyzmh_ptmass(iReff,1), xyzh,& + else + call get_all_tau_single(npart, xyzmh_ptmass(1:3,1), xyzmh_ptmass(iReff,1), xyzh,& kappa_cgs, Rinject, order, tau) - endif - end subroutine get_all_tau - - !--------------------------------------------------------------------------------- - !+ - ! Calculates the optical depth at each particle's location, using the uniform outward - ! ray-tracing scheme for models containing a single star - ! - ! Relies on healpix, for more information: https://healpix.sourceforge.io/ - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: kappa: The array containing the kappa of all SPH particles - ! IN: Rstar: The radius of the primary star - ! IN: Rinject: The particles injection radius - ! IN: order: The healpix order which is used for the uniform ray sampling - !+ - ! OUT: taus: The array of optical depths to each SPH particle - !+ - !--------------------------------------------------------------------------------- - subroutine get_all_tau_single(npart, primary, Rstar, xyzh, kappa, Rinject, order, tau) - use part, only : isdead_or_accreted - integer, intent(in) :: npart,order - real, intent(in) :: primary(3), kappa(:), Rstar, Rinject, xyzh(:,:) - real, intent(out) :: tau(:) - - integer :: i, nrays, nsides - real :: ray_dir(3),part_dir(3) - real, dimension(:,:), allocatable :: rays_dist, rays_tau - integer, dimension(:), allocatable :: rays_dim - integer, parameter :: ndim = 200 ! maximum number of points along the ray where tau is calculated - - nrays = 12*4**order ! The number of rays traced given the healpix order - nsides = 2**order ! The healpix nsides given the healpix order - - allocate(rays_dist(ndim, nrays)) ! distance from the central star of the points on the rays - allocate(rays_tau(ndim, nrays)) ! value of tau at each point along each ray - allocate(rays_dim(nrays)) ! effective number of points on the ray (< ndim) - - !------------------------------------------- - ! CONSTRUCT the RAYS given the HEALPix ORDER - ! and determine the optical depth along them - !------------------------------------------- - - !$omp parallel default(none) & - !$omp private(ray_dir) & - !$omp shared(nrays,nsides,primary,kappa,xyzh,Rstar,Rinject,rays_dist,rays_tau,rays_dim) - !$omp do - do i = 1, nrays - !returns ray_dir, the unit vector identifying a ray (index i-1 because healpix starts counting from index 0) - call pix2vec_nest(nsides, i-1, ray_dir) - !calculate the properties along the ray (tau, distance, number of points) - call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i)) - enddo - !$omp enddo - !$omp end parallel - - - !_---------------------------------------------- - ! DETERMINE the optical depth for each particle - ! using the values available on the HEALPix rays - !----------------------------------------------- - - !$omp parallel default(none) & - !$omp private(part_dir) & - !$omp shared(npart,primary,nsides,xyzh,ray_dir,rays_dist,rays_tau,rays_dim,tau) - !$omp do - do i = 1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - part_dir = xyzh(1:3,i)-primary - call interpolate_tau(nsides, part_dir, rays_tau, rays_dist, rays_dim, tau(i)) - else - tau(i) = -99. - endif - enddo - !$omp enddo - !$omp end parallel - - end subroutine get_all_tau_single - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth at each particle's location, using the uniform outward - ! ray-tracing scheme for models containing a primary star and a companion - ! - ! Relies on healpix, for more information: https://healpix.sourceforge.io/ - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: kappa: The array containing the opacity of all the SPH particles - ! IN: Rstar: The radius of the primary star - ! IN: Rinject: The particles injection radius - ! IN: companion: The xyz coordinates of the companion - ! IN: Rcomp: The radius of the companion - ! IN: order: The healpix order which is used for the uniform ray sampling - !+ - ! OUT: tau: The array of optical depths for each SPH particle - !+ - !-------------------------------------------------------------------------- - subroutine get_all_tau_companion(npart, primary, Rstar, xyzh, kappa, Rinject, companion, Rcomp, order, tau) - use part, only : isdead_or_accreted - integer, intent(in) :: npart, order - real, intent(in) :: primary(3), companion(3), kappa(:), Rstar, Rinject, xyzh(:,:), Rcomp - real, intent(out) :: tau(:) - - integer :: i, nrays, nsides - real :: normCompanion,theta0,phi,cosphi,sinphi,theta,sep,root - real :: ray_dir(3),part_dir(3),uvecCompanion(3) - real, dimension(:,:), allocatable :: rays_dist, rays_tau - integer, dimension(:), allocatable :: rays_dim - integer, parameter :: ndim = 200 ! maximum number of points along the ray where tau is calculated - - nrays = 12*4**order ! The number of rays traced given the healpix order - nsides = 2**order ! The healpix nsides given the healpix order - - allocate(rays_dist(ndim, nrays)) ! distance from the central star of the points on the rays - allocate(rays_tau(ndim, nrays)) ! value of tau at each point along each ray - allocate(rays_dim(nrays)) ! effective number of points on the ray (< ndim) - - uvecCompanion = companion-primary - normCompanion = norm2(uvecCompanion) - uvecCompanion = uvecCompanion/normCompanion - theta0 = asin(Rcomp/normCompanion) - phi = atan2(uvecCompanion(2),uvecCompanion(1)) - cosphi = cos(phi) - sinphi = sin(phi) - - !------------------------------------------- - ! CONSTRUCT the RAYS given the HEALPix ORDER - ! and determine the optical depth along them - !------------------------------------------- - - !$omp parallel default(none) & - !$omp private(ray_dir,theta,root,sep) & - !$omp shared(nrays,nsides,primary,kappa,xyzh,Rstar,Rinject,Rcomp,rays_dist,rays_tau,rays_dim) & - !$omp shared(uvecCompanion,normCompanion,cosphi,sinphi,theta0) - !$omp do - do i = 1, nrays - !returns ray_dir, the unit vector identifying a ray (index i-1 because healpix starts counting from index 0) - call pix2vec_nest(nsides, i-1, ray_dir) - !rotate ray vectors by an angle = phi so the main axis points to the companion (This is because along the - !main axis (1,0,0) rays are distributed more uniformally - ray_dir = (/cosphi*ray_dir(1) - sinphi*ray_dir(2),sinphi*ray_dir(1) + cosphi*ray_dir(2), ray_dir(3)/) - theta = acos(dot_product(uvecCompanion, ray_dir)) - !the ray intersects the companion: only calculate tau up to the companion - if (theta < theta0) then - root = sqrt(Rcomp**2-normCompanion**2*sin(theta)**2) - sep = normCompanion*cos(theta)-root - call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i), sep) - else - call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i)) - endif - enddo - !$omp enddo - !$omp end parallel - - !----------------------------------------------- - ! DETERMINE the optical depth for each particle - ! using the values available on the HEALPix rays - !----------------------------------------------- - - !$omp parallel default(none) & - !$omp private(part_dir) & - !$omp shared(npart,primary,cosphi,sinphi,nsides,xyzh,ray_dir,rays_dist,rays_tau,rays_dim,tau) - !$omp do - do i = 1, npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - !vector joining the source to the particle - part_dir = xyzh(1:3,i)-primary - part_dir = (/cosphi*part_dir(1) + sinphi*part_dir(2),-sinphi*part_dir(1) + cosphi*part_dir(2), part_dir(3)/) - call interpolate_tau(nsides, part_dir, rays_tau, rays_dist, rays_dim, tau(i)) - else - tau(i) = -99. - endif - enddo - !$omp enddo - !$omp end parallel - end subroutine get_all_tau_companion - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth at the SPH particle's location. - ! Search for the four closest rays to a particle, perform four-point - ! interpolation of the optical depth from these rays. Weighted by the - ! inverse square of the perpendicular distance to the rays. - ! - ! Relies on healpix, for more information: https://healpix.sourceforge.io/ - !+ - ! IN: nsides: The healpix nsides of the simulation - ! IN: vec: The vector from the primary to the particle - ! IN: rays_tau: 2-dimensional array containing the cumulative optical - ! depth along each ray - ! IN: rays_dist: 2-dimensional array containing the distances from the - ! primary along each ray - ! IN: rays_dim: The vector containing the number of points defined along each ray - !+ - ! OUT: tau: The interpolated optical depth at the particle's location - !+ - !-------------------------------------------------------------------------- - subroutine interpolate_tau(nsides, vec, rays_tau, rays_dist, rays_dim, tau) - integer, intent(in) :: nsides, rays_dim(:) - real, intent(in) :: vec(:), rays_dist(:,:), rays_tau(:,:) - real, intent(out) :: tau - - integer :: rayIndex, neighbours(8), nneigh, i, k - real :: tautemp, ray(3), vectemp(3), weight, tempdist(8), distRay_sq, vec_norm2 - logical :: mask(8) - - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector of the HEALPix cell that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - !compute optical depth along ray rayIndex(+1) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - !determine distance of the particle to the HEALPix ray - vectemp = vec - vec_norm2*ray - distRay_sq = dot_product(vectemp,vectemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to interpolate with the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number rayIndex - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = dot_product(vectemp,vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + endif +end subroutine get_all_tau + + !--------------------------------------------------------------------------------- + !+ + ! Calculates the optical depth at each particle's location, using the uniform outward + ! ray-tracing scheme for models containing a single star + ! + ! Relies on healpix, for more information: https://healpix.sourceforge.io/ + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa: The array containing the kappa of all SPH particles + ! IN: Rstar: The radius of the primary star + ! IN: Rinject: The particles injection radius + ! IN: order: The healpix order which is used for the uniform ray sampling + !+ + ! OUT: taus: The array of optical depths to each SPH particle + !+ + !--------------------------------------------------------------------------------- +subroutine get_all_tau_single(npart, primary, Rstar, xyzh, kappa, Rinject, order, tau) + use part, only : isdead_or_accreted + integer, intent(in) :: npart,order + real, intent(in) :: primary(3), kappa(:), Rstar, Rinject, xyzh(:,:) + real, intent(out) :: tau(:) + + integer :: i, nrays, nsides + real :: ray_dir(3),part_dir(3) + real, dimension(:,:), allocatable :: rays_dist, rays_tau + integer, dimension(:), allocatable :: rays_dim + integer, parameter :: ndim = 200 ! maximum number of points along the ray where tau is calculated + + nrays = 12*4**order ! The number of rays traced given the healpix order + nsides = 2**order ! The healpix nsides given the healpix order + + allocate(rays_dist(ndim, nrays)) ! distance from the central star of the points on the rays + allocate(rays_tau(ndim, nrays)) ! value of tau at each point along each ray + allocate(rays_dim(nrays)) ! effective number of points on the ray (< ndim) + + !------------------------------------------- + ! CONSTRUCT the RAYS given the HEALPix ORDER + ! and determine the optical depth along them + !------------------------------------------- + + !$omp parallel default(none) & + !$omp private(ray_dir) & + !$omp shared(nrays,nsides,primary,kappa,xyzh,Rstar,Rinject,rays_dist,rays_tau,rays_dim) + !$omp do + do i = 1, nrays + !returns ray_dir, the unit vector identifying a ray (index i-1 because healpix starts counting from index 0) + call pix2vec_nest(nsides, i-1, ray_dir) + !calculate the properties along the ray (tau, distance, number of points) + call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i)) + enddo + !$omp enddo + !$omp end parallel + + + !_---------------------------------------------- + ! DETERMINE the optical depth for each particle + ! using the values available on the HEALPix rays + !----------------------------------------------- + + !$omp parallel default(none) & + !$omp private(part_dir) & + !$omp shared(npart,primary,nsides,xyzh,ray_dir,rays_dist,rays_tau,rays_dim,tau) + !$omp do + do i = 1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + part_dir = xyzh(1:3,i)-primary + call interpolate_tau(nsides, part_dir, rays_tau, rays_dist, rays_dim, tau(i)) + else + tau(i) = -99. + endif + enddo + !$omp enddo + !$omp end parallel + +end subroutine get_all_tau_single + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth at each particle's location, using the uniform outward + ! ray-tracing scheme for models containing a primary star and a companion + ! + ! Relies on healpix, for more information: https://healpix.sourceforge.io/ + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + ! IN: Rinject: The particles injection radius + ! IN: companion: The xyz coordinates of the companion + ! IN: Rcomp: The radius of the companion + ! IN: order: The healpix order which is used for the uniform ray sampling + !+ + ! OUT: tau: The array of optical depths for each SPH particle + !+ + !-------------------------------------------------------------------------- +subroutine get_all_tau_companion(npart, primary, Rstar, xyzh, kappa, Rinject, companion, Rcomp, order, tau) + use part, only : isdead_or_accreted + integer, intent(in) :: npart, order + real, intent(in) :: primary(3), companion(3), kappa(:), Rstar, Rinject, xyzh(:,:), Rcomp + real, intent(out) :: tau(:) + + integer :: i, nrays, nsides + real :: normCompanion,theta0,phi,cosphi,sinphi,theta,sep,root + real :: ray_dir(3),part_dir(3),uvecCompanion(3) + real, dimension(:,:), allocatable :: rays_dist, rays_tau + integer, dimension(:), allocatable :: rays_dim + integer, parameter :: ndim = 200 ! maximum number of points along the ray where tau is calculated + + nrays = 12*4**order ! The number of rays traced given the healpix order + nsides = 2**order ! The healpix nsides given the healpix order + + allocate(rays_dist(ndim, nrays)) ! distance from the central star of the points on the rays + allocate(rays_tau(ndim, nrays)) ! value of tau at each point along each ray + allocate(rays_dim(nrays)) ! effective number of points on the ray (< ndim) + + uvecCompanion = companion-primary + normCompanion = norm2(uvecCompanion) + uvecCompanion = uvecCompanion/normCompanion + theta0 = asin(Rcomp/normCompanion) + phi = atan2(uvecCompanion(2),uvecCompanion(1)) + cosphi = cos(phi) + sinphi = sin(phi) + + !------------------------------------------- + ! CONSTRUCT the RAYS given the HEALPix ORDER + ! and determine the optical depth along them + !------------------------------------------- + + !$omp parallel default(none) & + !$omp private(ray_dir,theta,root,sep) & + !$omp shared(nrays,nsides,primary,kappa,xyzh,Rstar,Rinject,Rcomp,rays_dist,rays_tau,rays_dim) & + !$omp shared(uvecCompanion,normCompanion,cosphi,sinphi,theta0) + !$omp do + do i = 1, nrays + !returns ray_dir, the unit vector identifying a ray (index i-1 because healpix starts counting from index 0) + call pix2vec_nest(nsides, i-1, ray_dir) + !rotate ray vectors by an angle = phi so the main axis points to the companion (This is because along the + !main axis (1,0,0) rays are distributed more uniformally + ray_dir = (/cosphi*ray_dir(1) - sinphi*ray_dir(2),sinphi*ray_dir(1) + cosphi*ray_dir(2), ray_dir(3)/) + theta = acos(dot_product(uvecCompanion, ray_dir)) + !the ray intersects the companion: only calculate tau up to the companion + if (theta < theta0) then + root = sqrt(Rcomp**2-normCompanion**2*sin(theta)**2) + sep = normCompanion*cos(theta)-root + call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i), sep) + else + call ray_tracer(primary,ray_dir,xyzh,kappa,Rstar,Rinject,rays_tau(:,i),rays_dist(:,i),rays_dim(i)) + endif + enddo + !$omp enddo + !$omp end parallel + + !----------------------------------------------- + ! DETERMINE the optical depth for each particle + ! using the values available on the HEALPix rays + !----------------------------------------------- + + !$omp parallel default(none) & + !$omp private(part_dir) & + !$omp shared(npart,primary,cosphi,sinphi,nsides,xyzh,ray_dir,rays_dist,rays_tau,rays_dim,tau) + !$omp do + do i = 1, npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + !vector joining the source to the particle + part_dir = xyzh(1:3,i)-primary + part_dir = (/cosphi*part_dir(1) + sinphi*part_dir(2),-sinphi*part_dir(1) + cosphi*part_dir(2), part_dir(3)/) + call interpolate_tau(nsides, part_dir, rays_tau, rays_dist, rays_dim, tau(i)) + else + tau(i) = -99. + endif + enddo + !$omp enddo + !$omp end parallel +end subroutine get_all_tau_companion + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth at the SPH particle's location. + ! Search for the four closest rays to a particle, perform four-point + ! interpolation of the optical depth from these rays. Weighted by the + ! inverse square of the perpendicular distance to the rays. + ! + ! Relies on healpix, for more information: https://healpix.sourceforge.io/ + !+ + ! IN: nsides: The healpix nsides of the simulation + ! IN: vec: The vector from the primary to the particle + ! IN: rays_tau: 2-dimensional array containing the cumulative optical + ! depth along each ray + ! IN: rays_dist: 2-dimensional array containing the distances from the + ! primary along each ray + ! IN: rays_dim: The vector containing the number of points defined along each ray + !+ + ! OUT: tau: The interpolated optical depth at the particle's location + !+ + !-------------------------------------------------------------------------- +subroutine interpolate_tau(nsides, vec, rays_tau, rays_dist, rays_dim, tau) + integer, intent(in) :: nsides, rays_dim(:) + real, intent(in) :: vec(:), rays_dist(:,:), rays_tau(:,:) + real, intent(out) :: tau + + integer :: rayIndex, neighbours(8), nneigh, i, k + real :: tautemp, ray(3), vectemp(3), weight, tempdist(8), distRay_sq, vec_norm2 + logical :: mask(8) + + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector of the HEALPix cell that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + !compute optical depth along ray rayIndex(+1) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + !determine distance of the particle to the HEALPix ray + vectemp = vec - vec_norm2*ray + distRay_sq = dot_product(vectemp,vectemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to interpolate with the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number rayIndex + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = dot_product(vectemp,vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - end subroutine interpolate_tau - - - !-------------------------------------------------------------------------- - !+ - ! Interpolation of the optical depth for an arbitrary point on the ray, - ! at a given distance to the starting point of the ray (primary star). - !+ - ! IN: distance: The distance from the staring point of the ray to a - ! point on the ray - ! IN: tau_along_ray: The vector of cumulative optical depths along the ray - ! IN: dist_along_ray: The vector of distances from the primary along the ray - ! IN: len: The length of tau_along_ray and dist_along_ray - !+ - ! OUT: tau: The optical depth to the given distance along the ray - !+ - !-------------------------------------------------------------------------- - subroutine get_tau_on_ray(distance, tau_along_ray, dist_along_ray, len, tau) - real, intent(in) :: distance, tau_along_ray(:), dist_along_ray(:) - integer, intent(in) :: len - real, intent(out) :: tau - - integer :: L, R, m ! left, right and middle index for binary search - - if (distance < dist_along_ray(1)) then - tau = tau_along_ray(1) - elseif (distance > dist_along_ray(len)) then - tau = tau_along_ray(len) - else - L = 2 - R = len - !bysection search for the index of the closest points on the ray to the specified location - do while (L < R) - m = (L + R)/2 - if (dist_along_ray(m) > distance) then - R = m - else - L = m + 1 - endif - enddo - !linear interpolation of the optical depth at the the point's location - tau = tau_along_ray(L-1)+(tau_along_ray(L)-tau_along_ray(L-1))/ & + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight +end subroutine interpolate_tau + + + !-------------------------------------------------------------------------- + !+ + ! Interpolation of the optical depth for an arbitrary point on the ray, + ! at a given distance to the starting point of the ray (primary star). + !+ + ! IN: distance: The distance from the staring point of the ray to a + ! point on the ray + ! IN: tau_along_ray: The vector of cumulative optical depths along the ray + ! IN: dist_along_ray: The vector of distances from the primary along the ray + ! IN: len: The length of tau_along_ray and dist_along_ray + !+ + ! OUT: tau: The optical depth to the given distance along the ray + !+ + !-------------------------------------------------------------------------- +subroutine get_tau_on_ray(distance, tau_along_ray, dist_along_ray, len, tau) + real, intent(in) :: distance, tau_along_ray(:), dist_along_ray(:) + integer, intent(in) :: len + real, intent(out) :: tau + + integer :: L, R, m ! left, right and middle index for binary search + + if (distance < dist_along_ray(1)) then + tau = tau_along_ray(1) + elseif (distance > dist_along_ray(len)) then + tau = tau_along_ray(len) + else + L = 2 + R = len + !bysection search for the index of the closest points on the ray to the specified location + do while (L < R) + m = (L + R)/2 + if (dist_along_ray(m) > distance) then + R = m + else + L = m + 1 + endif + enddo + !linear interpolation of the optical depth at the the point's location + tau = tau_along_ray(L-1)+(tau_along_ray(L)-tau_along_ray(L-1))/ & (dist_along_ray(L)-dist_along_ray(L-1))*(distance-dist_along_ray(L-1)) - endif - end subroutine get_tau_on_ray - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth along a given ray - !+ - ! IN: primary: The location of the primary star - ! IN: ray: The unit vector of the direction in which the - ! optical depth will be calculated - ! IN: xyzh: The array containing the particles position+smoothing lenght - ! IN: kappa: The array containing the particles opacity - ! IN: Rstar: The radius of the primary star - ! IN: Rinject: The particles injection radius - !+ - ! OUT: tau_along_ray: The vector of cumulative optical depth along the ray - ! OUT: dist_along_ray: The vector of distances from the primary along the ray - ! OUT: len: The length of tau_along_ray and dist_along_ray - !+ - ! OPT: maxDistance: The maximal distance the ray needs to be traced - !+ - !-------------------------------------------------------------------------- - subroutine ray_tracer(primary, ray, xyzh, kappa, Rstar, Rinject, tau_along_ray, dist_along_ray, len, maxDistance) - use units, only:unit_opacity - use part, only:itauL_alloc - real, intent(in) :: primary(3), ray(3), Rstar, Rinject, xyzh(:,:), kappa(:) - real, optional :: maxDistance - real, intent(out) :: dist_along_ray(:), tau_along_ray(:) - integer, intent(out) :: len - real, parameter :: tau_max = 99. - - real :: dr, next_dr, h, dtaudr, previousdtaudr, nextdtaudr, distance - integer :: inext, i, L, R, m ! left, right and middle index for binary search - - h = Rinject/100. - inext=0 - do while (inext==0) - h = h*2. - !find the next point along the ray : index inext - call find_next(primary+Rinject*ray, h, ray, xyzh, kappa, previousdtaudr, dr, inext) - enddo - - i = 1 - tau_along_ray(i) = 0. - distance = Rinject - dist_along_ray(i) = distance - do while (hasNext(inext,tau_along_ray(i),distance,maxDistance)) - distance = distance+dr - call find_next(primary + distance*ray, xyzh(4,inext), ray, xyzh, kappa, nextdtaudr, next_dr, inext) - i = i + 1 - if (itauL_alloc > 0) nextdtaudr = nextdtaudr*(Rstar/distance)**2 - dtaudr = (nextdtaudr+previousdtaudr)/2. - previousdtaudr = nextdtaudr - !fix units for tau (kappa is in cgs while rho & r are in code units) - tau_along_ray(i) = tau_along_ray(i-1) + real(dr*dtaudr/unit_opacity) - dist_along_ray(i) = distance - dr = next_dr - enddo - - if (itauL_alloc == 0 .and. present(maxDistance)) then - i = i + 1 - tau_along_ray(i) = tau_max - dist_along_ray(i) = maxDistance - endif - len = i - - if (itauL_alloc > 0) then - !reverse integration start from zero inward - tau_along_ray(1:len) = tau_along_ray(len) - tau_along_ray(1:len) - !find the first point where tau_lucy < 2/3 - if (tau_along_ray(1) > 2./3.) then - L = 1 - R = len - !bysection search for the index of the closest point to tau = 2/3 - do while (L < R) - m = (L + R)/2 - if (tau_along_ray(m) < 2./3.) then - R = m - else - L = m + 1 - endif - enddo - tau_along_ray(1:L) = 2./3. - !The photosphere is located between ray grid point L and L+1, may be useful information! - endif - endif - end subroutine ray_tracer - - logical function hasNext(inext, tau, distance, maxDistance) - integer, intent(in) :: inext - real, intent(in) :: tau, distance - real, optional :: maxDistance - real :: tau_max = 99. - if (present(maxDistance)) then - hasNext = inext /= 0 .and. distance < maxDistance .and. tau < tau_max - else - hasNext = inext /= 0 .and. tau < tau_max - endif - end function hasNext - - !-------------------------------------------------------------------------- - !+ - ! First finds the local optical depth derivative at the starting point, then finds the next - ! point on a ray and the distance to this point - !+ - ! IN: inpoint: The coordinate of the initial point projected on the ray - ! for which the opacity and the next point will be calculated - ! IN: h: The smoothing length at the initial point - ! IN: ray: The unit vector of the direction in which the next - ! point will be calculated - ! IN: xyzh: The array containing the particles position+smoothing length - ! IN: kappa: The array containing the particles opacity - ! IN: inext: The index of the initial point - ! (this point will not be considered as possible next point) - !+ - ! OUT: dtaudr: The radial optical depth derivative at the given location (inpoint) - ! OUT: distance: The distance to the next point - ! OUT: inext: The index of the next point on the ray - !+ - !-------------------------------------------------------------------------- - subroutine find_next(inpoint, h, ray, xyzh, kappa, dtaudr, distance, inext) - use linklist, only:getneigh_pos,ifirstincell,listneigh - use kernel, only:radkern,cnormk,wkern - use part, only:hfact,rhoh,massoftype,igas - real, intent(in) :: xyzh(:,:), kappa(:), inpoint(:), ray(:), h - integer, intent(inout) :: inext - real, intent(out) :: distance, dtaudr - - integer, parameter :: nmaxcache = 0 - real :: xyzcache(0,nmaxcache) - - integer :: nneigh, i, prev - real :: dmin, vec(3), dr, raydistance, q, norm_sq - - prev = inext - inext = 0 - distance = 0. - - !for a given point (inpoint), returns the list of neighbouring particles (listneigh) within a radius h*radkern - call getneigh_pos(inpoint,0.,h*radkern,3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) - - dtaudr = 0. - dmin = huge(0.) - !loop over all neighbours - do i=1,nneigh - vec = xyzh(1:3,listneigh(i)) - inpoint - norm_sq = dot_product(vec,vec) - q = sqrt(norm_sq)/xyzh(4,listneigh(i)) - !add optical depth contribution from each particle - dtaudr = dtaudr+wkern(q*q,q)*kappa(listneigh(i))*rhoh(xyzh(4,listneigh(i)), massoftype(igas)) - - ! find the next particle : among the neighbours find the particle located the closest to the ray - if (listneigh(i) /= prev) then - dr = dot_product(vec,ray) !projected distance along the ray - if (dr>0.) then - !distance perpendicular to the ray direction - raydistance = norm_sq - dr**2 - if (raydistance < dmin) then - dmin = raydistance - inext = listneigh(i) - distance = dr - endif - endif - endif - enddo - dtaudr = dtaudr*cnormk/hfact**3 - end subroutine find_next - end module raytracer + endif +end subroutine get_tau_on_ray + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth along a given ray + !+ + ! IN: primary: The location of the primary star + ! IN: ray: The unit vector of the direction in which the + ! optical depth will be calculated + ! IN: xyzh: The array containing the particles position+smoothing lenght + ! IN: kappa: The array containing the particles opacity + ! IN: Rstar: The radius of the primary star + ! IN: Rinject: The particles injection radius + !+ + ! OUT: tau_along_ray: The vector of cumulative optical depth along the ray + ! OUT: dist_along_ray: The vector of distances from the primary along the ray + ! OUT: len: The length of tau_along_ray and dist_along_ray + !+ + ! OPT: maxDistance: The maximal distance the ray needs to be traced + !+ + !-------------------------------------------------------------------------- +subroutine ray_tracer(primary, ray, xyzh, kappa, Rstar, Rinject, tau_along_ray, dist_along_ray, len, maxDistance) + use units, only:unit_opacity + use part, only:itauL_alloc + real, intent(in) :: primary(3), ray(3), Rstar, Rinject, xyzh(:,:), kappa(:) + real, optional :: maxDistance + real, intent(out) :: dist_along_ray(:), tau_along_ray(:) + integer, intent(out) :: len + real, parameter :: tau_max = 99. + + real :: dr, next_dr, h, dtaudr, previousdtaudr, nextdtaudr, distance + integer :: inext, i, L, R, m ! left, right and middle index for binary search + + h = Rinject/100. + inext=0 + do while (inext==0) + h = h*2. + !find the next point along the ray : index inext + call find_next(primary+Rinject*ray, h, ray, xyzh, kappa, previousdtaudr, dr, inext) + enddo + + i = 1 + tau_along_ray(i) = 0. + distance = Rinject + dist_along_ray(i) = distance + do while (hasNext(inext,tau_along_ray(i),distance,maxDistance)) + distance = distance+dr + call find_next(primary + distance*ray, xyzh(4,inext), ray, xyzh, kappa, nextdtaudr, next_dr, inext) + i = i + 1 + if (itauL_alloc > 0) nextdtaudr = nextdtaudr*(Rstar/distance)**2 + dtaudr = (nextdtaudr+previousdtaudr)/2. + previousdtaudr = nextdtaudr + !fix units for tau (kappa is in cgs while rho & r are in code units) + tau_along_ray(i) = tau_along_ray(i-1) + real(dr*dtaudr/unit_opacity) + dist_along_ray(i) = distance + dr = next_dr + enddo + + if (itauL_alloc == 0 .and. present(maxDistance)) then + i = i + 1 + tau_along_ray(i) = tau_max + dist_along_ray(i) = maxDistance + endif + len = i + + if (itauL_alloc > 0) then + !reverse integration start from zero inward + tau_along_ray(1:len) = tau_along_ray(len) - tau_along_ray(1:len) + !find the first point where tau_lucy < 2/3 + if (tau_along_ray(1) > 2./3.) then + L = 1 + R = len + !bysection search for the index of the closest point to tau = 2/3 + do while (L < R) + m = (L + R)/2 + if (tau_along_ray(m) < 2./3.) then + R = m + else + L = m + 1 + endif + enddo + tau_along_ray(1:L) = 2./3. + !The photosphere is located between ray grid point L and L+1, may be useful information! + endif + endif +end subroutine ray_tracer + +logical function hasNext(inext, tau, distance, maxDistance) + integer, intent(in) :: inext + real, intent(in) :: tau, distance + real, optional :: maxDistance + real :: tau_max = 99. + if (present(maxDistance)) then + hasNext = inext /= 0 .and. distance < maxDistance .and. tau < tau_max + else + hasNext = inext /= 0 .and. tau < tau_max + endif +end function hasNext + + !-------------------------------------------------------------------------- + !+ + ! First finds the local optical depth derivative at the starting point, then finds the next + ! point on a ray and the distance to this point + !+ + ! IN: inpoint: The coordinate of the initial point projected on the ray + ! for which the opacity and the next point will be calculated + ! IN: h: The smoothing length at the initial point + ! IN: ray: The unit vector of the direction in which the next + ! point will be calculated + ! IN: xyzh: The array containing the particles position+smoothing length + ! IN: kappa: The array containing the particles opacity + ! IN: inext: The index of the initial point + ! (this point will not be considered as possible next point) + !+ + ! OUT: dtaudr: The radial optical depth derivative at the given location (inpoint) + ! OUT: distance: The distance to the next point + ! OUT: inext: The index of the next point on the ray + !+ + !-------------------------------------------------------------------------- +subroutine find_next(inpoint, h, ray, xyzh, kappa, dtaudr, distance, inext) + use linklist, only:getneigh_pos,ifirstincell,listneigh + use kernel, only:radkern,cnormk,wkern + use part, only:hfact,rhoh,massoftype,igas + real, intent(in) :: xyzh(:,:), kappa(:), inpoint(:), ray(:), h + integer, intent(inout) :: inext + real, intent(out) :: distance, dtaudr + + integer, parameter :: nmaxcache = 0 + real :: xyzcache(0,nmaxcache) + + integer :: nneigh, i, prev + real :: dmin, vec(3), dr, raydistance, q, norm_sq + + prev = inext + inext = 0 + distance = 0. + + !for a given point (inpoint), returns the list of neighbouring particles (listneigh) within a radius h*radkern + call getneigh_pos(inpoint,0.,h*radkern,3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) + + dtaudr = 0. + dmin = huge(0.) + !loop over all neighbours + do i=1,nneigh + vec = xyzh(1:3,listneigh(i)) - inpoint + norm_sq = dot_product(vec,vec) + q = sqrt(norm_sq)/xyzh(4,listneigh(i)) + !add optical depth contribution from each particle + dtaudr = dtaudr+wkern(q*q,q)*kappa(listneigh(i))*rhoh(xyzh(4,listneigh(i)), massoftype(igas)) + + ! find the next particle : among the neighbours find the particle located the closest to the ray + if (listneigh(i) /= prev) then + dr = dot_product(vec,ray) !projected distance along the ray + if (dr>0.) then + !distance perpendicular to the ray direction + raydistance = norm_sq - dr**2 + if (raydistance < dmin) then + dmin = raydistance + inext = listneigh(i) + distance = dr + endif + endif + endif + enddo + dtaudr = dtaudr*cnormk/hfact**3 +end subroutine find_next +end module raytracer From 2ea4bb8663e6d1d0a7034e8ea47c6592ae4d1b07 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Thu, 30 Mar 2023 17:37:44 +0200 Subject: [PATCH 020/814] [header-bot] updated file headers --- .mailmap | 2 + AUTHORS | 3 +- src/main/utils_healpix.f90 | 2322 ++++++++++++++-------------- src/main/utils_raytracer.f90 | 2 +- src/utils/analysis_raytracer.f90 | 1384 ++++++++--------- src/utils/utils_raytracer_all.F90 | 2396 ++++++++++++++--------------- 6 files changed, 3055 insertions(+), 3054 deletions(-) diff --git a/.mailmap b/.mailmap index 567c60b95..73dbb81de 100644 --- a/.mailmap +++ b/.mailmap @@ -76,6 +76,8 @@ Lionel Siess Lionel Siess Lionel Siess Lionel Siess +Mats Esseldeurs +Mats Esseldeurs David Liptai David Liptai David Liptai <31463304+dliptai@users.noreply.github.com> diff --git a/AUTHORS b/AUTHORS index 92ea3dd46..9c99a6372 100644 --- a/AUTHORS +++ b/AUTHORS @@ -16,6 +16,7 @@ Arnaud Vericel Mark Hutchison Fitz Hu Megha Sharma +Mats Esseldeurs Rebecca Nealon Ward Homan Christophe Pinte @@ -23,8 +24,6 @@ Elisabeth Borchert Megha Sharma Terrence Tricco Fangyi (Fitz) Hu -Mats Esseldeurs -MatsEsseldeurs Caitlyn Hardiman Enrico Ragusa Sergei Biriukov diff --git a/src/main/utils_healpix.f90 b/src/main/utils_healpix.f90 index 51d0638a7..65e20bcab 100644 --- a/src/main/utils_healpix.f90 +++ b/src/main/utils_healpix.f90 @@ -1,1161 +1,1161 @@ -!--------------------------------------------------------------------------! -! 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 healpix -! -! This module sets the types used in the Fortran 90 modules (healpix_types.f90) -! of the HEALPIX distribution and follows the example of Numerical Recipes -! -! Benjamin D. Wandelt October 1997 -! Eric Hivon June 1998 -! Eric Hivon Oct 2001, edited to be compatible with 'F' compiler -! Eric Hivon July 2002, addition of i8b, i2b, i1b -! addition of max_i8b, max_i2b and max_i1b -! Jan 2005, explicit form of max_i1b because of ifc 8.1.021 -! June 2005, redefine i8b as 16 digit integer because of Nec f90 compiler -! Mars 2008: i8b same as i4b on machines not supporting 64 bits (NO64BITS flag set) -! Feb 2009: introduce healpix_version -! -! :References: None -! -! :Owner: Lionel Siess -! -! :Runtime parameters: None -! -! :Dependencies: None -! - implicit none - character(len=*), parameter, public :: healpix_version = '3.80' - integer, parameter, public :: i4b = selected_int_kind(9) - integer, parameter, public :: i8b = selected_int_kind(16) - integer, parameter, public :: i2b = selected_int_kind(4) - integer, parameter, public :: i1b = selected_int_kind(2) - integer, parameter, public :: sp = selected_real_kind(5,30) - integer, parameter, public :: dp = selected_real_kind(12,200) - integer, parameter, public :: lgt = kind(.TRUE.) - integer, parameter, public :: spc = kind((1.0_sp, 1.0_sp)) - integer, parameter, public :: dpc = kind((1.0_dp, 1.0_dp)) - ! - integer(I8B), parameter, public :: max_i8b = huge(1_i8b) - integer, parameter, public :: max_i4b = huge(1_i4b) - integer, parameter, public :: max_i2b = huge(1_i2b) - integer, parameter, public :: max_i1b = 127 - real(kind=sp), parameter, public :: max_sp = huge(1.0_sp) - real(kind=dp), parameter, public :: max_dp = huge(1.0_dp) - - ! Numerical Constant (Double precision) - real(kind=dp), parameter, public :: QUARTPI=0.785398163397448309615660845819875721049_dp - real, parameter, public :: HALFPI= 1.570796326794896619231321691639751442099 - real, parameter, public :: PI = 3.141592653589793238462643383279502884197 - real, parameter, public :: TWOPI = 6.283185307179586476925286766559005768394 - real(kind=dp), parameter, public :: FOURPI=12.56637061435917295385057353311801153679_dp - real(kind=dp), parameter, public :: SQRT2 = 1.41421356237309504880168872420969807856967_dp - real(kind=dp), parameter, public :: EULER = 0.5772156649015328606065120900824024310422_dp - real(kind=dp), parameter, public :: SQ4PI_INV = 0.2820947917738781434740397257803862929220_dp - real(kind=dp), parameter, public :: TWOTHIRD = 0.6666666666666666666666666666666666666666_dp - - real(kind=DP), parameter, public :: RAD2DEG = 180.0_DP / PI - real(kind=DP), parameter, public :: DEG2RAD = PI / 180.0_DP - real(kind=SP), parameter, public :: hpx_sbadval = -1.6375e30_sp - real(kind=DP), parameter, public :: hpx_dbadval = -1.6375e30_dp - - ! Maximum length of filenames - integer, parameter :: filenamelen = 1024 - - - ! ! ---- Normalisation and convention ---- - ! normalisation of spin weighted functions - real(kind=dp), parameter, public :: KvS = 1.0_dp ! 1.0 : CMBFAST (Healpix 1.2) - ! ! sign of Q - ! real(kind=dp), parameter, public :: sgQ = -1.0_dp ! -1 : CMBFAST (Healpix 1.2) - ! ! sign of spin weighted function ! - ! real(kind=dp), parameter, public :: SW1 = -1.0_dp ! -1 : Healpix 1.2, bug correction - - ! ! ! normalisation of spin weighted functions - ! ! real(kind=dp), parameter, public :: KvS = 2.0_dp ! 2.0 : KKS (Healpix 1.1) - ! ! ! sign of Q - ! ! real(kind=dp), parameter, public :: sgQ = +1.0_dp ! +1 : KKS (Healpix 1.1) - ! ! ! sign of spin weighted function ! - ! ! real(kind=dp), parameter, public :: SW1 = +1.0_dp ! +1 : Healpix 1.1 - - ! real(kind=dp), parameter, public :: iKvS = 1.0_dp / KvS ! inverse of KvS - integer(kind=i4b), private, parameter :: ns_max4=8192 ! 2^13 - integer(kind=i4b), private, save, dimension(0:127) :: x2pix1=-1,y2pix1=-1 - integer(kind=i4b), private, save, dimension(0:1023) :: pix2x=-1, pix2y=-1 - integer(i4b), parameter :: oddbits=89478485 ! 2^0 + 2^2 + 2^4+..+2^26 - integer(i4b), parameter :: evenbits=178956970 ! 2^1 + 2^3 + 2^4+..+2^27 - integer(kind=i4b), private, parameter :: ns_max=268435456! 2^28 - -contains - -!! Returns i with even and odd bit positions interchanged. -function swapLSBMSB(i) - integer(i4b) :: swapLSBMSB - integer(i4b), intent(in) :: i - - swapLSBMSB = iand(i,evenbits)/2 + iand(i,oddbits)*2 -end function swapLSBMSB - - !! Returns not(i) with even and odd bit positions interchanged. -function invswapLSBMSB(i) - integer(i4b) :: invswapLSBMSB - integer(i4b), intent(in) :: i - - invswapLSBMSB = not(swapLSBMSB(i)) -end function invswapLSBMSB - - !! Returns i with odd (1,3,5,...) bits inverted. -function invLSB(i) - integer(i4b) :: invLSB - integer(i4b), intent(in) :: i - - invLSB = ieor(i,oddbits) -end function invLSB - - !! Returns i with even (0,2,4,...) bits inverted. -function invMSB(i) - integer(i4b) :: invMSB - integer(i4b), intent(in) :: i - - invMSB = ieor(i,evenbits) -end function invMSB - -!======================================================================= -! vec2pix_nest -! -! renders the pixel number ipix (NESTED scheme) for a pixel which contains -! a point on a sphere at coordinate vector (=x,y,z), given the map -! resolution parameter nside -! -! 2009-03-10: calculations done directly at nside rather than ns_max -!======================================================================= -subroutine vec2pix_nest (nside, vector, ipix) - integer(i4b), parameter :: MKD = I4B - integer(kind=I4B), intent(in) :: nside - real, intent(in), dimension(1:) :: vector - integer(kind=MKD), intent(out) :: ipix - - integer(kind=MKD) :: ipf,scale,scale_factor - real(kind=DP) :: z,za,tt,tp,tmp,dnorm,phi - integer(kind=I4B) :: jp,jm,ifp,ifm,face_num,ix,iy,ix_low,iy_low,ntt,i,ismax - character(len=*), parameter :: code = "vec2pix_nest" - - !----------------------------------------------------------------------- - if (nside<1 .or. nside>ns_max4) call fatal_error(code//"> nside out of range") - dnorm = sqrt(vector(1)**2+vector(2)**2+vector(3)**2) - z = vector(3) / dnorm - phi = 0.0 - if (vector(1) /= 0.0 .or. vector(2) /= 0.0) & - & phi = atan2(vector(2),vector(1)) ! phi in ]-pi,pi] - - za = abs(z) - if (phi < 0.0) phi = phi + twopi ! phi in [0,2pi[ - tt = phi / halfpi ! in [0,4[ - if (x2pix1(127) <= 0) call mk_xy2pix1() - - if (za <= twothird) then ! equatorial region - - ! (the index of edge lines increase when the longitude=phi goes up) - jp = int(nside*(0.5_dp + tt - z*0.75_dp)) ! ascending edge line index - jm = int(nside*(0.5_dp + tt + z*0.75_dp)) ! descending edge line index - - ! finds the face - ifp = jp / nside ! in {0,4} - ifm = jm / nside - if (ifp == ifm) then ! faces 4 to 7 - face_num = iand(ifp,3) + 4 - elseif (ifp < ifm) then ! (half-)faces 0 to 3 - face_num = iand(ifp,3) - else ! (half-)faces 8 to 11 - face_num = iand(ifm,3) + 8 - endif - - ix = iand(jm, nside-1) - iy = nside - iand(jp, nside-1) - 1 - - else ! polar region, za > 2/3 - - ntt = int(tt) - if (ntt >= 4) ntt = 3 - tp = tt - ntt - !tmp = sqrt( 3.0_dp*(1.0_dp - za) ) ! in ]0,1] - tmp = sqrt(vector(1)**2+vector(2)**2) / dnorm ! sin(theta) - tmp = tmp * sqrt( 3.0_dp / (1.0_dp + za) ) !more accurate - - ! (the index of edge lines increase when distance from the closest pole goes up) - jp = int( nside * tp * tmp ) ! line going toward the pole as phi increases - jm = int( nside * (1.0_dp - tp) * tmp ) ! that one goes away of the closest pole - jp = min(nside-1, jp) ! for points too close to the boundary - jm = min(nside-1, jm) - - ! finds the face and pixel's (x,y) - if (z >= 0) then - face_num = ntt ! in {0,3} - ix = nside - jm - 1 - iy = nside - jp - 1 - else - face_num = ntt + 8 ! in {8,11} - ix = jp - iy = jm - endif - - endif - - if (nside <= ns_max4) then - ix_low = iand(ix, 127) - iy_low = iand(iy, 127) - ipf = x2pix1(ix_low) + y2pix1(iy_low) & - & + (x2pix1(ix/128) + y2pix1(iy/128)) * 16384 - else - scale = 1_MKD - scale_factor = 16384_MKD ! 128*128 - ipf = 0_MKD - ismax = 1 ! for nside in [2^14, 2^20] - if (nside > 1048576 ) ismax = 3 - do i=0, ismax - ix_low = iand(ix, 127) ! last 7 bits - iy_low = iand(iy, 127) ! last 7 bits - ipf = ipf + (x2pix1(ix_low)+y2pix1(iy_low)) * scale - scale = scale * scale_factor - ix = ix / 128 ! truncate out last 7 bits - iy = iy / 128 - enddo - ipf = ipf + (x2pix1(ix)+y2pix1(iy)) * scale - endif - ipix = ipf + face_num* int(nside,MKD) * nside ! in {0, 12*nside**2 - 1} - -end subroutine vec2pix_nest - -!======================================================================= -! pix2vec_nest -! -! renders vector (x,y,z) coordinates of the nominal pixel center -! for the pixel number ipix (NESTED scheme) -! given the map resolution parameter nside -! also returns the (x,y,z) position of the 4 pixel vertices (=corners) -! in the order N,W,S,E -!======================================================================= -subroutine pix2vec_nest (nside, ipix, vector, vertex) - integer(i4b), parameter :: MKD = i4b - integer(kind=I4B), intent(in) :: nside - integer(kind=MKD), intent(in) :: ipix - real, intent(out), dimension(1:) :: vector - real, intent(out), dimension(1:,1:), optional :: vertex - - integer(kind=MKD) :: npix, npface, ipf - integer(kind=I4B) :: ip_low, ip_trunc, ip_med, ip_hi - integer(kind=I4B) :: face_num, ix, iy, kshift, scale, i, ismax - integer(kind=I4B) :: jrt, jr, nr, jpt, jp, nl4 - real :: z, fn, fact1, fact2, sth, phi - - ! coordinate of the lowest corner of each face - integer(kind=I4B), dimension(1:12) :: jrll = (/ 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4 /) ! in unit of nside - integer(kind=I4B), dimension(1:12) :: jpll = (/ 1, 3, 5, 7, 0, 2, 4, 6, 1, 3, 5, 7 /) ! in unit of nside/2 - - real :: phi_nv, phi_wv, phi_sv, phi_ev, phi_up, phi_dn, sin_phi, cos_phi - real :: z_nv, z_sv, sth_nv, sth_sv - real :: hdelta_phi - integer(kind=I4B) :: iphi_mod, iphi_rat - logical(kind=LGT) :: do_vertex - integer(kind=i4b) :: diff_phi - character(len=*), parameter :: code = "pix2vec_nest" - - !----------------------------------------------------------------------- - if (nside > ns_max4) call fatal_error(code//"> nside out of range") - npix = nside2npix(nside) ! total number of points - if (ipix <0 .or. ipix>npix-1) call fatal_error(code//"> ipix out of range") - - ! initiates the array for the pixel number -> (x,y) mapping - if (pix2x(1023) <= 0) call mk_pix2xy() - - npface = nside * int(nside, kind=MKD) - nl4 = 4*nside - - ! finds the face, and the number in the face - face_num = ipix/npface ! face number in {0,11} - ipf = modulo(ipix,npface) ! pixel number in the face {0,npface-1} - - do_vertex = .false. - if (present(vertex)) then - if (size(vertex,dim=1) >= 3 .and. size(vertex,dim=2) >= 4) then - do_vertex = .true. - else - call fatal_error(code//"> vertex array has wrong size ") - endif - endif - fn = real(nside) - fact1 = 1.0/(3.0*fn*fn) - fact2 = 2.0/(3.0*fn) - - ! finds the x,y on the face (starting from the lowest corner) - ! from the pixel number - if (nside <= ns_max4) then - ip_low = iand(ipf,1023_MKD) ! content of the last 10 bits - ip_trunc = ipf/1024 ! truncation of the last 10 bits - ip_med = iand(ip_trunc,1023) ! content of the next 10 bits - ip_hi = ip_trunc/1024 ! content of the high weight 10 bits - - ix = 1024*pix2x(ip_hi) + 32*pix2x(ip_med) + pix2x(ip_low) - iy = 1024*pix2y(ip_hi) + 32*pix2y(ip_med) + pix2y(ip_low) - else - ix = 0 - iy = 0 - scale = 1 - ismax = 4 - do i=0, ismax - ip_low = iand(ipf,1023_MKD) - ix = ix + scale * pix2x(ip_low) - iy = iy + scale * pix2y(ip_low) - scale = scale * 32 - ipf = ipf/1024 - enddo - ix = ix + scale * pix2x(ipf) - iy = iy + scale * pix2y(ipf) - endif - - ! transforms this in (horizontal, vertical) coordinates - jrt = ix + iy ! 'vertical' in {0,2*(nside-1)} - jpt = ix - iy ! 'horizontal' in {-nside+1,nside-1} - - ! computes the z coordinate on the sphere - jr = jrll(face_num+1)*nside - jrt - 1 ! ring number in {1,4*nside-1} - - z_nv = 0.; z_sv = 0. ! avoid compiler warnings - - if (jr < nside) then ! north pole region - nr = jr - z = 1. - nr*fact1*nr - sth = nr * sqrt(fact1 * (1. + z) ) ! more accurate close to pole - kshift = 0 - if (do_vertex) then - z_nv = 1. - (nr-1)*fact1*(nr-1) - z_sv = 1. - (nr+1)*fact1*(nr+1) - endif - - elseif (jr <= 3*nside) then ! equatorial region - nr = nside - z = (2*nside-jr)*fact2 - sth = sqrt((1.0-z)*(1.0+z)) ! good enough on Equator - kshift = iand(jr - nside, 1) - if (do_vertex) then - z_nv = (2*nside-jr+1)*fact2 - z_sv = (2*nside-jr-1)*fact2 - if (jr == nside) then ! northern transition - z_nv = 1.0- (nside-1) * fact1 * (nside-1) - elseif (jr == 3*nside) then ! southern transition - z_sv = -1.0 + (nside-1) * fact1 * (nside-1) - endif - endif - - elseif (jr > 3*nside) then ! south pole region - nr = nl4 - jr - z = - 1.0 + nr*fact1*nr - sth = nr * sqrt(fact1 * (1. - z) ) - kshift = 0 - if (do_vertex) then - z_nv = - 1.0 + (nr+1)*fact1*(nr+1) - z_sv = - 1.0 + (nr-1)*fact1*(nr-1) - endif - endif - - ! computes the phi coordinate on the sphere, in [0,2Pi] - jp = (jpll(face_num+1)*nr + jpt + 1_MKD + kshift)/2 ! 'phi' number in the ring in {1,4*nr} - if (jp > nl4) jp = jp - nl4 - if (jp < 1) jp = jp + nl4 - - phi = (jp - (kshift+1)*0.5) * (halfpi / nr) - - ! pixel center - ! - cos_phi = cos(phi) - sin_phi = sin(phi) - vector(1) = sth * cos_phi - vector(2) = sth * sin_phi - vector(3) = z - - if (do_vertex) then - phi_nv = phi - phi_sv = phi - diff_phi = 0 ! phi_nv = phi_sv = phisth * 1} - iphi_rat = (jp-1) / nr ! in {0,1,2,3} - iphi_mod = mod(jp-1,nr) - phi_up = 0. - if (nr > 1) phi_up = HALFPI * (iphi_rat + iphi_mod /real(nr-1)) - phi_dn = HALFPI * (iphi_rat + (iphi_mod+1)/real(nr+1)) - if (jr < nside) then ! North polar cap - phi_nv = phi_up - phi_sv = phi_dn - diff_phi = 3 ! both phi_nv and phi_sv different from phi - elseif (jr > 3*nside) then ! South polar cap - phi_nv = phi_dn - phi_sv = phi_up - diff_phi = 3 ! both phi_nv and phi_sv different from phi - elseif (jr == nside) then ! North transition - phi_nv = phi_up - diff_phi = 1 - elseif (jr == 3*nside) then ! South transition - phi_sv = phi_up - diff_phi = 2 - endif - - hdelta_phi = PI / (4.0*nr) - - ! west vertex - phi_wv = phi - hdelta_phi - vertex(1,2) = sth * cos(phi_wv) - vertex(2,2) = sth * sin(phi_wv) - vertex(3,2) = z - - ! east vertex - phi_ev = phi + hdelta_phi - vertex(1,4) = sth * cos(phi_ev) - vertex(2,4) = sth * sin(phi_ev) - vertex(3,4) = z - - ! north and south vertices - sth_nv = sqrt((1.0-z_nv)*(1.0+z_nv)) - sth_sv = sqrt((1.0-z_sv)*(1.0+z_sv)) - if (diff_phi == 0) then - vertex(1,1) = sth_nv * cos_phi - vertex(2,1) = sth_nv * sin_phi - vertex(1,3) = sth_sv * cos_phi - vertex(2,3) = sth_sv * sin_phi - else - vertex(1,1) = sth_nv * cos(phi_nv) - vertex(2,1) = sth_nv * sin(phi_nv) - vertex(1,3) = sth_sv * cos(phi_sv) - vertex(2,3) = sth_sv * sin(phi_sv) - endif - vertex(3,1) = z_nv - vertex(3,3) = z_sv - endif - -end subroutine pix2vec_nest - -!======================================================================= -! npix2nside -! -! given npix, returns nside such that npix = 12*nside^2 -! nside should be a power of 2 smaller than ns_max -! if not, -1 is returned -! EH, Feb-2000 -! 2009-03-05, edited, accepts 8-byte npix -!======================================================================= -function npix2nside (npix) result(nside_result) - integer(i4b), parameter :: MKD = I4B - integer(kind=MKD), parameter :: npix_max = (12_MKD*ns_max4)*ns_max4 - integer(kind=MKD), intent(in) :: npix - integer(kind=MKD) :: npix1, npix2 - integer(kind=I4B) :: nside_result - integer(kind=I4B) :: nside - character(LEN=*), parameter :: code = "npix2nside" - !======================================================================= - - if (npix < 12 .or. npix > npix_max) then - print*, code,"> Npix=",npix, & - & " is out of allowed range: {12,",npix_max,"}" - nside_result = -1 - return - endif - - nside = nint( sqrt(npix/12.0_dp) ) - npix1 = (12_MKD*nside)*nside - if (abs(npix1-npix) > 0) then - print*, code,"> Npix=",npix, & - & " is not 12 * Nside * Nside " - nside_result = -1 - return - endif - - ! test validity of Nside - npix2 = nside2npix(nside) - if (npix2 < 0) then - nside_result = -1 - return - endif - - nside_result = nside - -end function npix2nside - - - !======================================================================= -function nside2npix(nside) result(npix_result) - !======================================================================= - ! given nside, returns npix such that npix = 12*nside^2 - ! nside should be a power of 2 smaller than ns_max - ! if not, -1 is returned - ! EH, Feb-2000 - ! 2009-03-04: returns i8b result, faster - !======================================================================= - integer(kind=I4B) :: npix_result - integer(kind=I4B), intent(in) :: nside - - integer(kind=I4B) :: npix - character(LEN=*), parameter :: code = "nside2npix" - !======================================================================= - - npix = (12_i4b*nside)*nside - if (nside < 1 .or. nside > ns_max4 .or. iand(nside-1,nside) /= 0) then - print*,code,": Nside=",nside," is not a power of 2." - npix = -1 - endif - npix_result = npix - -end function nside2npix - -!======================================================================= -! CHEAP_ISQRT -! Returns exact Floor(sqrt(x)) where x is a (64 bit) integer. -! y^2 <= x < (y+1)^2 (1) -! The double precision floating point operation is not accurate enough -! when dealing with 64 bit integers, especially in the vicinity of -! perfect squares. -!======================================================================= -function cheap_isqrt(lin) result (lout) - integer(i4b), intent(in) :: lin - integer(i4b) :: lout - lout = floor(sqrt(dble(lin)), kind=I4B) - return -end function cheap_isqrt - -!======================================================================= -subroutine mk_pix2xy() - !======================================================================= - ! constructs the array giving x and y in the face from pixel number - ! for the nested (quad-cube like) ordering of pixels - ! - ! the bits corresponding to x and y are interleaved in the pixel number - ! one breaks up the pixel number by even and odd bits - !======================================================================= - integer(kind=I4B) :: kpix, jpix, ix, iy, ip, id - - !cc cf block data data pix2x(1023) /0/ - !----------------------------------------------------------------------- - ! print *, 'initiate pix2xy' - do kpix=0,1023 ! pixel number - jpix = kpix - IX = 0 - IY = 0 - IP = 1 ! bit position (in x and y) -! do while (jpix/=0) ! go through all the bits - do - if (jpix == 0) exit ! go through all the bits - ID = modulo(jpix,2) ! bit value (in kpix), goes in ix - jpix = jpix/2 - IX = ID*IP+IX - - ID = modulo(jpix,2) ! bit value (in kpix), goes in iy - jpix = jpix/2 - IY = ID*IP+IY - - IP = 2*IP ! next bit (in x and y) - enddo - pix2x(kpix) = IX ! in 0,31 - pix2y(kpix) = IY ! in 0,31 - enddo - -end subroutine mk_pix2xy - !======================================================================= -subroutine mk_xy2pix1() - !======================================================================= - ! sets the array giving the number of the pixel lying in (x,y) - ! x and y are in {1,128} - ! the pixel number is in {0,128**2-1} - ! - ! if i-1 = sum_p=0 b_p * 2^p - ! then ix = sum_p=0 b_p * 4^p - ! iy = 2*ix - ! ix + iy in {0, 128**2 -1} - !======================================================================= - integer(kind=I4B):: k,ip,i,j,id - !======================================================================= - - do i = 0,127 !for converting x,y into - j = i !pixel numbers - k = 0 - ip = 1 - - do - if (j==0) then - x2pix1(i) = k - y2pix1(i) = 2*k - exit - else - id = modulo(J,2) - j = j/2 - k = ip*id+k - ip = ip*4 - endif - enddo - enddo - -end subroutine mk_xy2pix1 - -subroutine fatal_error (msg) - character(len=*), intent(in), optional :: msg - - if (present(msg)) then - print *,'Fatal error: ', trim(msg) - else - print *,'Fatal error' - endif - call exit_with_status(1) - -end subroutine fatal_error - -! =========================================================== -subroutine exit_with_status (code, msg) - integer(i4b), intent(in) :: code - character (len=*), intent(in), optional :: msg - - if (present(msg)) print *,trim(msg) - print *,'program exits with exit code ', code - call exit (code) - -end subroutine exit_with_status - -!==================================================================== -! The following is a routine which finds the 7 or 8 neighbours of -! any pixel in the nested scheme of the HEALPIX pixelisation. -!==================================================================== -! neighbours_nest -! -! Returns list n(8) of neighbours of pixel ipix (in NESTED scheme) -! the neighbours are ordered in the following way: -! First pixel is the one to the south (the one west of the south -! direction is taken -! for the pixels which don't have a southern neighbour). From -! then on the neighbours are ordered in the clockwise direction -! about the pixel with number ipix. -! -! nneigh is the number of neighbours (mostly 8, 8 pixels have 7 neighbours) -! -! Benjamin D. Wandelt October 1997 -! Added to pix_tools in March 1999 -! added 'return' for case nside=1, EH, Oct 2005 -! corrected bugs in case nside=1 and ipix=7, 9 or 11, EH, June 2006 -! 2009-06-16: deals with Nside > 8192 -!==================================================================== -subroutine neighbours_nest(nside, ipix, n, nneigh) -! use bit_manipulation - integer(kind=i4b), parameter :: MKD = I4B - !==================================================================== - integer(kind=i4b), intent(in):: nside - integer(kind=MKD), intent(in):: ipix - integer(kind=MKD), intent(out), dimension(1:):: n - integer(kind=i4b), intent(out):: nneigh - - integer(kind=i4b) :: ix,ixm,ixp,iy,iym,iyp,ixo,iyo - integer(kind=i4b) :: face_num,other_face - integer(kind=i4b) :: ia,ib,ibp,ibm,ib2,icase - integer(kind=MKD) :: npix,ipf,ipo - integer(kind=MKD) :: local_magic1,local_magic2,nsidesq - character(len=*), parameter :: code = "neighbours_nest" - -! integer(kind=i4b), intrinsic :: IAND - - !-------------------------------------------------------------------- - if (nside <1 .or. nside > ns_max4) call fatal_error(code//"> nside out of range") - npix = nside2npix(nside) ! total number of points - nsidesq = npix / 12 - if (ipix <0 .or. ipix>npix-1) call fatal_error(code//"> ipix out of range") - - ! quick and dirty hack for Nside=1 - - if (nside == 1) then - nneigh = 6 - if (ipix==0 ) n(1:6) = (/ 8, 4, 3, 2, 1, 5 /) - if (ipix==1 ) n(1:6) = (/ 9, 5, 0, 3, 2, 6 /) - if (ipix==2 ) n(1:6) = (/10, 6, 1, 0, 3, 7 /) - if (ipix==3 ) n(1:6) = (/11, 7, 2, 1, 0, 4 /) - if (ipix==4 ) n(1:6) = (/11, 7, 3, 0, 5, 8 /) - if (ipix==5 ) n(1:6) = (/ 8, 4, 0, 1, 6, 9 /) - if (ipix==6 ) n(1:6) = (/ 9, 5, 1, 2, 7,10 /) - if (ipix==7 ) n(1:6) = (/10, 6, 2, 3, 4,11 /) - if (ipix==8 ) n(1:6) = (/10,11, 4, 0, 5, 9 /) - if (ipix==9 ) n(1:6) = (/11, 8, 5, 1, 6,10 /) - if (ipix==10) n(1:6) = (/ 8, 9, 6, 2, 7,11 /) - if (ipix==11) n(1:6) = (/ 9,10, 7, 3, 4, 8 /) - return - endif - - ! initiates array for (x,y)-> pixel number -> (x,y) mapping - if (x2pix1(127) <= 0) call mk_xy2pix1() - - local_magic1=(nsidesq-1)/3 - local_magic2=2*local_magic1 - face_num=ipix/nsidesq - - ipf=modulo(ipix,nsidesq) !Pixel number in face - - call pix2xy_nest(nside,ipf,ix,iy) - ixm=ix-1 - ixp=ix+1 - iym=iy-1 - iyp=iy+1 - - nneigh=8 !Except in special cases below - - ! Exclude corners - if (ipf==local_magic2) then !WestCorner - icase=5 - goto 100 - endif - if (ipf==(nsidesq-1)) then !NorthCorner - icase=6 - goto 100 - endif - if (ipf==0) then !SouthCorner - icase=7 - goto 100 - endif - if (ipf==local_magic1) then !EastCorner - icase=8 - goto 100 - endif - - ! Detect edges - if (iand(ipf,local_magic1)==local_magic1) then !NorthEast - icase=1 - goto 100 - endif - if (iand(ipf,local_magic1)==0) then !SouthWest - icase=2 - goto 100 - endif - if (iand(ipf,local_magic2)==local_magic2) then !NorthWest - icase=3 - goto 100 - endif - if (iand(ipf,local_magic2)==0) then !SouthEast - icase=4 - goto 100 - endif - - ! Inside a face - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - return - -100 continue - - ia= face_num/4 !in {0,2} - ib= modulo(face_num,4) !in {0,3} - ibp=modulo(ib+1,4) - ibm=modulo(ib+4-1,4) - ib2=modulo(ib+2,4) - - if (ia==0) then !North Pole region - select case(icase) - case(1) !NorthEast edge - other_face=0+ibp - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - ipo=modulo(swapLSBMSB(ipf),nsidesq) !East-West flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo+1 , iyo, other_face, n(5)) - n(6)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(7)) - case(2) !SouthWest edge - other_face=4+ib - ipo=modulo(invLSB(ipf),nsidesq) !SW-NE flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) - n(2)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo+1, other_face, n(3)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - case(3) !NorthWest edge - other_face=0+ibm - ipo=modulo(swapLSBMSB(ipf),nsidesq) !East-West flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(3)) - n(4)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo+1, other_face, n(5)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - case(4) !SouthEast edge - other_face=4+ibp - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - ipo=modulo(invMSB(ipf),nsidesq) !SE-NW flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo+1, iyo, other_face, n(7)) - n(8)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) - case(5) !West corner - nneigh=7 - other_face=4+ib - n(2)=other_face*nsidesq+nsidesq-1 - n(1)=n(2)-2 - other_face=0+ibm - n(3)=other_face*nsidesq+local_magic1 - n(4)=n(3)+2 - n(5)=ipix+1 - n(6)=ipix-1 - n(7)=ipix-2 - case(6) !North corner - n(1)=ipix-3 - n(2)=ipix-1 - n(8)=ipix-2 - other_face=0+ibm - n(4)=other_face*nsidesq+nsidesq-1 - n(3)=n(4)-2 - other_face=0+ib2 - n(5)=other_face*nsidesq+nsidesq-1 - other_face=0+ibp - n(6)=other_face*nsidesq+nsidesq-1 - n(7)=n(6)-1 - case(7) !South corner - other_face=8+ib - n(1)=other_face*nsidesq+nsidesq-1 - other_face=4+ib - n(2)=other_face*nsidesq+local_magic1 - n(3)=n(2)+2 - n(4)=ipix+2 - n(5)=ipix+3 - n(6)=ipix+1 - other_face=4+ibp - n(8)=other_face*nsidesq+local_magic2 - n(7)=n(8)+1 - case(8) !East corner - nneigh=7 - n(2)=ipix-1 - n(3)=ipix+1 - n(4)=ipix+2 - other_face=0+ibp - n(6)=other_face*nsidesq+local_magic2 - n(5)=n(6)+1 - other_face=4+ibp - n(7)=other_face*nsidesq+nsidesq-1 - n(1)=n(7)-1 - end select ! north - - elseif (ia==1) then !Equatorial region - select case(icase) - case(1) !NorthEast edge - other_face=0+ib - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - ipo=modulo(invLSB(ipf),nsidesq) !NE-SW flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo , iyo+1, other_face, n(5)) - n(6)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(7)) - case(2) !SouthWest edge - other_face=8+ibm - ipo=modulo(invLSB(ipf),nsidesq) !SW-NE flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) - n(2)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo+1, other_face, n(3)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - case(3) !NorthWest edge - other_face=0+ibm - ipo=modulo(invMSB(ipf),nsidesq) !NW-SE flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(3)) - n(4)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo+1, iyo, other_face, n(5)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - case(4) !SouthEast edge - other_face=8+ib - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - ipo=modulo(invMSB(ipf),nsidesq) !SE-NW flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo+1, iyo, other_face, n(7)) - n(8)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) - case(5) !West corner - other_face=8+ibm - n(2)=other_face*nsidesq+nsidesq-1 - n(1)=n(2)-2 - other_face=4+ibm - n(3)=other_face*nsidesq+local_magic1 - other_face=0+ibm - n(4)=other_face*nsidesq - n(5)=n(4)+1 - n(6)=ipix+1 - n(7)=ipix-1 - n(8)=ipix-2 - case(6) !North corner - nneigh=7 - n(1)=ipix-3 - n(2)=ipix-1 - other_face=0+ibm - n(4)=other_face*nsidesq+local_magic1 - n(3)=n(4)-1 - other_face=0+ib - n(5)=other_face*nsidesq+local_magic2 - n(6)=n(5)-2 - n(7)=ipix-2 - case(7) !South corner - nneigh=7 - other_face=8+ibm - n(1)=other_face*nsidesq+local_magic1 - n(2)=n(1)+2 - n(3)=ipix+2 - n(4)=ipix+3 - n(5)=ipix+1 - other_face=8+ib - n(7)=other_face*nsidesq+local_magic2 - n(6)=n(7)+1 - case(8) !East corner - other_face=8+ib - n(8)=other_face*nsidesq+nsidesq-1 - n(1)=n(8)-1 - n(2)=ipix-1 - n(3)=ipix+1 - n(4)=ipix+2 - other_face=0+ib - n(6)=other_face*nsidesq - n(5)=n(6)+2 - other_face=4+ibp - n(7)=other_face*nsidesq+local_magic2 - end select ! equator - else !South Pole region - select case(icase) - case(1) !NorthEast edge - other_face=4+ibp - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - ipo=modulo(invLSB(ipf),nsidesq) !NE-SW flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo , iyo+1, other_face, n(5)) - n(6)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(7)) - case(2) !SouthWest edge - other_face=8+ibm - ipo=modulo(swapLSBMSB(ipf),nsidesq) !W-E flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) - n(2)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo+1, iyo, other_face, n(3)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - case(3) !NorthWest edge - other_face=4+ib - ipo=modulo(invMSB(ipf),nsidesq) !NW-SE flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(3)) - n(4)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo+1, iyo, other_face, n(5)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - case(4) !SouthEast edge - other_face=8+ibp - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - ipo=modulo(swapLSBMSB(ipf),nsidesq) !E-W flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo, iyo+1, other_face, n(7)) - n(8)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) - case(5) !West corner - nneigh=7 - other_face=8+ibm - n(2)=other_face*nsidesq+local_magic1 - n(1)=n(2)-1 - other_face=4+ib - n(3)=other_face*nsidesq - n(4)=n(3)+1 - n(5)=ipix+1 - n(6)=ipix-1 - n(7)=ipix-2 - case(6) !North corner - n(1)=ipix-3 - n(2)=ipix-1 - other_face=4+ib - n(4)=other_face*nsidesq+local_magic1 - n(3)=n(4)-1 - other_face=0+ib - n(5)=other_face*nsidesq - other_face=4+ibp - n(6)=other_face*nsidesq+local_magic2 - n(7)=n(6)-2 - n(8)=ipix-2 - case(7) !South corner - other_face=8+ib2 - n(1)=other_face*nsidesq - other_face=8+ibm - n(2)=other_face*nsidesq - n(3)=n(2)+1 - n(4)=ipix+2 - n(5)=ipix+3 - n(6)=ipix+1 - other_face=8+ibp - n(8)=other_face*nsidesq - n(7)=n(8)+2 - case(8) !East corner - nneigh=7 - other_face=8+ibp - n(7)=other_face*nsidesq+local_magic2 - n(1)=n(7)-2 - n(2)=ipix-1 - n(3)=ipix+1 - n(4)=ipix+2 - other_face=4+ibp - n(6)=other_face*nsidesq - n(5)=n(6)+2 - end select ! south - endif - -end subroutine neighbours_nest - - -!======================================================================= -! pix2xy_nest -! gives the x, y coords in a face from pixel number within the face (NESTED) -! -! Benjamin D. Wandelt 13/10/97 -! -! using code from HEALPIX toolkit by K.Gorski and E. Hivon -! 2009-06-15: deals with Nside > 8192 -! 2012-03-02: test validity of ipf_in instead of undefined ipf -! define ipf as MKD -! 2012-08-27: corrected bug on (ix,iy) for Nside > 8192 (MARK) -!======================================================================= -subroutine pix2xy_nest (nside, ipf_in, ix, iy) - integer(kind=i4b), parameter :: MKD = I4B - integer(kind=I4B), intent(in) :: nside - integer(kind=MKD), intent(in) :: ipf_in - integer(kind=I4B), intent(out) :: ix, iy - - integer(kind=MKD) :: ipf - integer(kind=I4B) :: ip_low, ip_trunc, ip_med, ip_hi, scale, i, ismax - character(len=*), parameter :: code = "pix2xy_nest" - - !----------------------------------------------------------------------- - if (nside<1 .or. nside>ns_max) call fatal_error(code//"> nside out of range") - if (ipf_in<0 .or. ipf_in>nside*nside-1) & - & call fatal_error(code//"> ipix out of range") - if (pix2x(1023) <= 0) call mk_pix2xy() - - ipf = ipf_in - if (nside <= ns_max4) then - ip_low = iand(ipf,1023_MKD) ! content of the last 10 bits - ip_trunc = ipf/1024 ! truncation of the last 10 bits - ip_med = iand(ip_trunc,1023) ! content of the next 10 bits - ip_hi = ip_trunc/1024 ! content of the high weight 10 bits - - ix = 1024*pix2x(ip_hi) + 32*pix2x(ip_med) + pix2x(ip_low) - iy = 1024*pix2y(ip_hi) + 32*pix2y(ip_med) + pix2y(ip_low) - else - ix = 0 - iy = 0 - scale = 1 - ismax = 4 - do i=0, ismax - ip_low = iand(ipf,1023_MKD) - ix = ix + scale * pix2x(ip_low) - iy = iy + scale * pix2y(ip_low) ! corrected 2012-08-27 - scale = scale * 32 - ipf = ipf/1024 - enddo - ix = ix + scale * pix2x(ipf) - iy = iy + scale * pix2y(ipf) ! corrected 2012-08-27 - endif - -end subroutine pix2xy_nest - -!======================================================================= -! gives the pixel number ipix (NESTED) -! corresponding to ix, iy and face_num -! -! Benjamin D. Wandelt 13/10/97 -! using code from HEALPIX toolkit by K.Gorski and E. Hivon -! 2009-06-15: deals with Nside > 8192 -! 2012-03-02: test validity of ix_in and iy_in instead of undefined ix and iy -!======================================================================= -subroutine xy2pix_nest(nside, ix_in, iy_in, face_num, ipix) - integer(kind=i4b), parameter :: MKD = I4B - !======================================================================= - integer(kind=I4B), intent(in) :: nside, ix_in, iy_in, face_num - integer(kind=MKD), intent(out) :: ipix - integer(kind=I4B) :: ix, iy, ix_low, iy_low, i, ismax - integer(kind=MKD) :: ipf, scale, scale_factor - character(len=*), parameter :: code = "xy2pix_nest" - - !----------------------------------------------------------------------- - if (nside<1 .or. nside>ns_max) call fatal_error(code//"> nside out of range") - if (ix_in<0 .or. ix_in>(nside-1)) call fatal_error(code//"> ix out of range") - if (iy_in<0 .or. iy_in>(nside-1)) call fatal_error(code//"> iy out of range") - if (x2pix1(127) <= 0) call mk_xy2pix1() - - ix = ix_in - iy = iy_in - if (nside <= ns_max4) then - ix_low = iand(ix, 127) - iy_low = iand(iy, 127) - ipf = x2pix1(ix_low) + y2pix1(iy_low) & - & + (x2pix1(ix/128) + y2pix1(iy/128)) * 16384 - else - scale = 1_MKD - scale_factor = 16384_MKD ! 128*128 - ipf = 0_MKD - ismax = 1 ! for nside in [2^14, 2^20] - if (nside > 1048576 ) ismax = 3 - do i=0, ismax - ix_low = iand(ix, 127) ! last 7 bits - iy_low = iand(iy, 127) ! last 7 bits - ipf = ipf + (x2pix1(ix_low)+y2pix1(iy_low)) * scale - scale = scale * scale_factor - ix = ix / 128 ! truncate out last 7 bits - iy = iy / 128 - enddo - ipf = ipf + (x2pix1(ix)+y2pix1(iy)) * scale - endif - ipix = ipf + face_num* int(nside,MKD) * nside ! in {0, 12*nside**2 - 1} - -end subroutine xy2pix_nest - -end module healpix + !--------------------------------------------------------------------------! + ! 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 healpix + ! + ! This module sets the types used in the Fortran 90 modules (healpix_types.f90) + ! of the HEALPIX distribution and follows the example of Numerical Recipes + ! + ! Benjamin D. Wandelt October 1997 + ! Eric Hivon June 1998 + ! Eric Hivon Oct 2001, edited to be compatible with 'F' compiler + ! Eric Hivon July 2002, addition of i8b, i2b, i1b + ! addition of max_i8b, max_i2b and max_i1b + ! Jan 2005, explicit form of max_i1b because of ifc 8.1.021 + ! June 2005, redefine i8b as 16 digit integer because of Nec f90 compiler + ! Mars 2008: i8b same as i4b on machines not supporting 64 bits (NO64BITS flag set) + ! Feb 2009: introduce healpix_version + ! + ! :References: None + ! + ! :Owner: Lionel Siess + ! + ! :Runtime parameters: None + ! + ! :Dependencies: None + ! + implicit none + character(len=*), parameter, public :: healpix_version = '3.80' + integer, parameter, public :: i4b = selected_int_kind(9) + integer, parameter, public :: i8b = selected_int_kind(16) + integer, parameter, public :: i2b = selected_int_kind(4) + integer, parameter, public :: i1b = selected_int_kind(2) + integer, parameter, public :: sp = selected_real_kind(5,30) + integer, parameter, public :: dp = selected_real_kind(12,200) + integer, parameter, public :: lgt = kind(.TRUE.) + integer, parameter, public :: spc = kind((1.0_sp, 1.0_sp)) + integer, parameter, public :: dpc = kind((1.0_dp, 1.0_dp)) + ! + integer(I8B), parameter, public :: max_i8b = huge(1_i8b) + integer, parameter, public :: max_i4b = huge(1_i4b) + integer, parameter, public :: max_i2b = huge(1_i2b) + integer, parameter, public :: max_i1b = 127 + real(kind=sp), parameter, public :: max_sp = huge(1.0_sp) + real(kind=dp), parameter, public :: max_dp = huge(1.0_dp) + + ! Numerical Constant (Double precision) + real(kind=dp), parameter, public :: QUARTPI=0.785398163397448309615660845819875721049_dp + real, parameter, public :: HALFPI= 1.570796326794896619231321691639751442099 + real, parameter, public :: PI = 3.141592653589793238462643383279502884197 + real, parameter, public :: TWOPI = 6.283185307179586476925286766559005768394 + real(kind=dp), parameter, public :: FOURPI=12.56637061435917295385057353311801153679_dp + real(kind=dp), parameter, public :: SQRT2 = 1.41421356237309504880168872420969807856967_dp + real(kind=dp), parameter, public :: EULER = 0.5772156649015328606065120900824024310422_dp + real(kind=dp), parameter, public :: SQ4PI_INV = 0.2820947917738781434740397257803862929220_dp + real(kind=dp), parameter, public :: TWOTHIRD = 0.6666666666666666666666666666666666666666_dp + + real(kind=DP), parameter, public :: RAD2DEG = 180.0_DP / PI + real(kind=DP), parameter, public :: DEG2RAD = PI / 180.0_DP + real(kind=SP), parameter, public :: hpx_sbadval = -1.6375e30_sp + real(kind=DP), parameter, public :: hpx_dbadval = -1.6375e30_dp + + ! Maximum length of filenames + integer, parameter :: filenamelen = 1024 + + + ! ! ---- Normalisation and convention ---- + ! normalisation of spin weighted functions + real(kind=dp), parameter, public :: KvS = 1.0_dp ! 1.0 : CMBFAST (Healpix 1.2) + ! ! sign of Q + ! real(kind=dp), parameter, public :: sgQ = -1.0_dp ! -1 : CMBFAST (Healpix 1.2) + ! ! sign of spin weighted function ! + ! real(kind=dp), parameter, public :: SW1 = -1.0_dp ! -1 : Healpix 1.2, bug correction + + ! ! ! normalisation of spin weighted functions + ! ! real(kind=dp), parameter, public :: KvS = 2.0_dp ! 2.0 : KKS (Healpix 1.1) + ! ! ! sign of Q + ! ! real(kind=dp), parameter, public :: sgQ = +1.0_dp ! +1 : KKS (Healpix 1.1) + ! ! ! sign of spin weighted function ! + ! ! real(kind=dp), parameter, public :: SW1 = +1.0_dp ! +1 : Healpix 1.1 + + ! real(kind=dp), parameter, public :: iKvS = 1.0_dp / KvS ! inverse of KvS + integer(kind=i4b), private, parameter :: ns_max4=8192 ! 2^13 + integer(kind=i4b), private, save, dimension(0:127) :: x2pix1=-1,y2pix1=-1 + integer(kind=i4b), private, save, dimension(0:1023) :: pix2x=-1, pix2y=-1 + integer(i4b), parameter :: oddbits=89478485 ! 2^0 + 2^2 + 2^4+..+2^26 + integer(i4b), parameter :: evenbits=178956970 ! 2^1 + 2^3 + 2^4+..+2^27 + integer(kind=i4b), private, parameter :: ns_max=268435456! 2^28 + + contains + + !! Returns i with even and odd bit positions interchanged. + function swapLSBMSB(i) + integer(i4b) :: swapLSBMSB + integer(i4b), intent(in) :: i + + swapLSBMSB = iand(i,evenbits)/2 + iand(i,oddbits)*2 + end function swapLSBMSB + + !! Returns not(i) with even and odd bit positions interchanged. + function invswapLSBMSB(i) + integer(i4b) :: invswapLSBMSB + integer(i4b), intent(in) :: i + + invswapLSBMSB = not(swapLSBMSB(i)) + end function invswapLSBMSB + + !! Returns i with odd (1,3,5,...) bits inverted. + function invLSB(i) + integer(i4b) :: invLSB + integer(i4b), intent(in) :: i + + invLSB = ieor(i,oddbits) + end function invLSB + + !! Returns i with even (0,2,4,...) bits inverted. + function invMSB(i) + integer(i4b) :: invMSB + integer(i4b), intent(in) :: i + + invMSB = ieor(i,evenbits) + end function invMSB + + !======================================================================= + ! vec2pix_nest + ! + ! renders the pixel number ipix (NESTED scheme) for a pixel which contains + ! a point on a sphere at coordinate vector (=x,y,z), given the map + ! resolution parameter nside + ! + ! 2009-03-10: calculations done directly at nside rather than ns_max + !======================================================================= + subroutine vec2pix_nest (nside, vector, ipix) + integer(i4b), parameter :: MKD = I4B + integer(kind=I4B), intent(in) :: nside + real, intent(in), dimension(1:) :: vector + integer(kind=MKD), intent(out) :: ipix + + integer(kind=MKD) :: ipf,scale,scale_factor + real(kind=DP) :: z,za,tt,tp,tmp,dnorm,phi + integer(kind=I4B) :: jp,jm,ifp,ifm,face_num,ix,iy,ix_low,iy_low,ntt,i,ismax + character(len=*), parameter :: code = "vec2pix_nest" + + !----------------------------------------------------------------------- + if (nside<1 .or. nside>ns_max4) call fatal_error(code//"> nside out of range") + dnorm = sqrt(vector(1)**2+vector(2)**2+vector(3)**2) + z = vector(3) / dnorm + phi = 0.0 + if (vector(1) /= 0.0 .or. vector(2) /= 0.0) & + & phi = atan2(vector(2),vector(1)) ! phi in ]-pi,pi] + + za = abs(z) + if (phi < 0.0) phi = phi + twopi ! phi in [0,2pi[ + tt = phi / halfpi ! in [0,4[ + if (x2pix1(127) <= 0) call mk_xy2pix1() + + if (za <= twothird) then ! equatorial region + + ! (the index of edge lines increase when the longitude=phi goes up) + jp = int(nside*(0.5_dp + tt - z*0.75_dp)) ! ascending edge line index + jm = int(nside*(0.5_dp + tt + z*0.75_dp)) ! descending edge line index + + ! finds the face + ifp = jp / nside ! in {0,4} + ifm = jm / nside + if (ifp == ifm) then ! faces 4 to 7 + face_num = iand(ifp,3) + 4 + elseif (ifp < ifm) then ! (half-)faces 0 to 3 + face_num = iand(ifp,3) + else ! (half-)faces 8 to 11 + face_num = iand(ifm,3) + 8 + endif + + ix = iand(jm, nside-1) + iy = nside - iand(jp, nside-1) - 1 + + else ! polar region, za > 2/3 + + ntt = int(tt) + if (ntt >= 4) ntt = 3 + tp = tt - ntt + !tmp = sqrt( 3.0_dp*(1.0_dp - za) ) ! in ]0,1] + tmp = sqrt(vector(1)**2+vector(2)**2) / dnorm ! sin(theta) + tmp = tmp * sqrt( 3.0_dp / (1.0_dp + za) ) !more accurate + + ! (the index of edge lines increase when distance from the closest pole goes up) + jp = int( nside * tp * tmp ) ! line going toward the pole as phi increases + jm = int( nside * (1.0_dp - tp) * tmp ) ! that one goes away of the closest pole + jp = min(nside-1, jp) ! for points too close to the boundary + jm = min(nside-1, jm) + + ! finds the face and pixel's (x,y) + if (z >= 0) then + face_num = ntt ! in {0,3} + ix = nside - jm - 1 + iy = nside - jp - 1 + else + face_num = ntt + 8 ! in {8,11} + ix = jp + iy = jm + endif + + endif + + if (nside <= ns_max4) then + ix_low = iand(ix, 127) + iy_low = iand(iy, 127) + ipf = x2pix1(ix_low) + y2pix1(iy_low) & + & + (x2pix1(ix/128) + y2pix1(iy/128)) * 16384 + else + scale = 1_MKD + scale_factor = 16384_MKD ! 128*128 + ipf = 0_MKD + ismax = 1 ! for nside in [2^14, 2^20] + if (nside > 1048576 ) ismax = 3 + do i=0, ismax + ix_low = iand(ix, 127) ! last 7 bits + iy_low = iand(iy, 127) ! last 7 bits + ipf = ipf + (x2pix1(ix_low)+y2pix1(iy_low)) * scale + scale = scale * scale_factor + ix = ix / 128 ! truncate out last 7 bits + iy = iy / 128 + enddo + ipf = ipf + (x2pix1(ix)+y2pix1(iy)) * scale + endif + ipix = ipf + face_num* int(nside,MKD) * nside ! in {0, 12*nside**2 - 1} + + end subroutine vec2pix_nest + + !======================================================================= + ! pix2vec_nest + ! + ! renders vector (x,y,z) coordinates of the nominal pixel center + ! for the pixel number ipix (NESTED scheme) + ! given the map resolution parameter nside + ! also returns the (x,y,z) position of the 4 pixel vertices (=corners) + ! in the order N,W,S,E + !======================================================================= + subroutine pix2vec_nest (nside, ipix, vector, vertex) + integer(i4b), parameter :: MKD = i4b + integer(kind=I4B), intent(in) :: nside + integer(kind=MKD), intent(in) :: ipix + real, intent(out), dimension(1:) :: vector + real, intent(out), dimension(1:,1:), optional :: vertex + + integer(kind=MKD) :: npix, npface, ipf + integer(kind=I4B) :: ip_low, ip_trunc, ip_med, ip_hi + integer(kind=I4B) :: face_num, ix, iy, kshift, scale, i, ismax + integer(kind=I4B) :: jrt, jr, nr, jpt, jp, nl4 + real :: z, fn, fact1, fact2, sth, phi + + ! coordinate of the lowest corner of each face + integer(kind=I4B), dimension(1:12) :: jrll = (/ 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4 /) ! in unit of nside + integer(kind=I4B), dimension(1:12) :: jpll = (/ 1, 3, 5, 7, 0, 2, 4, 6, 1, 3, 5, 7 /) ! in unit of nside/2 + + real :: phi_nv, phi_wv, phi_sv, phi_ev, phi_up, phi_dn, sin_phi, cos_phi + real :: z_nv, z_sv, sth_nv, sth_sv + real :: hdelta_phi + integer(kind=I4B) :: iphi_mod, iphi_rat + logical(kind=LGT) :: do_vertex + integer(kind=i4b) :: diff_phi + character(len=*), parameter :: code = "pix2vec_nest" + + !----------------------------------------------------------------------- + if (nside > ns_max4) call fatal_error(code//"> nside out of range") + npix = nside2npix(nside) ! total number of points + if (ipix <0 .or. ipix>npix-1) call fatal_error(code//"> ipix out of range") + + ! initiates the array for the pixel number -> (x,y) mapping + if (pix2x(1023) <= 0) call mk_pix2xy() + + npface = nside * int(nside, kind=MKD) + nl4 = 4*nside + + ! finds the face, and the number in the face + face_num = ipix/npface ! face number in {0,11} + ipf = modulo(ipix,npface) ! pixel number in the face {0,npface-1} + + do_vertex = .false. + if (present(vertex)) then + if (size(vertex,dim=1) >= 3 .and. size(vertex,dim=2) >= 4) then + do_vertex = .true. + else + call fatal_error(code//"> vertex array has wrong size ") + endif + endif + fn = real(nside) + fact1 = 1.0/(3.0*fn*fn) + fact2 = 2.0/(3.0*fn) + + ! finds the x,y on the face (starting from the lowest corner) + ! from the pixel number + if (nside <= ns_max4) then + ip_low = iand(ipf,1023_MKD) ! content of the last 10 bits + ip_trunc = ipf/1024 ! truncation of the last 10 bits + ip_med = iand(ip_trunc,1023) ! content of the next 10 bits + ip_hi = ip_trunc/1024 ! content of the high weight 10 bits + + ix = 1024*pix2x(ip_hi) + 32*pix2x(ip_med) + pix2x(ip_low) + iy = 1024*pix2y(ip_hi) + 32*pix2y(ip_med) + pix2y(ip_low) + else + ix = 0 + iy = 0 + scale = 1 + ismax = 4 + do i=0, ismax + ip_low = iand(ipf,1023_MKD) + ix = ix + scale * pix2x(ip_low) + iy = iy + scale * pix2y(ip_low) + scale = scale * 32 + ipf = ipf/1024 + enddo + ix = ix + scale * pix2x(ipf) + iy = iy + scale * pix2y(ipf) + endif + + ! transforms this in (horizontal, vertical) coordinates + jrt = ix + iy ! 'vertical' in {0,2*(nside-1)} + jpt = ix - iy ! 'horizontal' in {-nside+1,nside-1} + + ! computes the z coordinate on the sphere + jr = jrll(face_num+1)*nside - jrt - 1 ! ring number in {1,4*nside-1} + + z_nv = 0.; z_sv = 0. ! avoid compiler warnings + + if (jr < nside) then ! north pole region + nr = jr + z = 1. - nr*fact1*nr + sth = nr * sqrt(fact1 * (1. + z) ) ! more accurate close to pole + kshift = 0 + if (do_vertex) then + z_nv = 1. - (nr-1)*fact1*(nr-1) + z_sv = 1. - (nr+1)*fact1*(nr+1) + endif + + elseif (jr <= 3*nside) then ! equatorial region + nr = nside + z = (2*nside-jr)*fact2 + sth = sqrt((1.0-z)*(1.0+z)) ! good enough on Equator + kshift = iand(jr - nside, 1) + if (do_vertex) then + z_nv = (2*nside-jr+1)*fact2 + z_sv = (2*nside-jr-1)*fact2 + if (jr == nside) then ! northern transition + z_nv = 1.0- (nside-1) * fact1 * (nside-1) + elseif (jr == 3*nside) then ! southern transition + z_sv = -1.0 + (nside-1) * fact1 * (nside-1) + endif + endif + + elseif (jr > 3*nside) then ! south pole region + nr = nl4 - jr + z = - 1.0 + nr*fact1*nr + sth = nr * sqrt(fact1 * (1. - z) ) + kshift = 0 + if (do_vertex) then + z_nv = - 1.0 + (nr+1)*fact1*(nr+1) + z_sv = - 1.0 + (nr-1)*fact1*(nr-1) + endif + endif + + ! computes the phi coordinate on the sphere, in [0,2Pi] + jp = (jpll(face_num+1)*nr + jpt + 1_MKD + kshift)/2 ! 'phi' number in the ring in {1,4*nr} + if (jp > nl4) jp = jp - nl4 + if (jp < 1) jp = jp + nl4 + + phi = (jp - (kshift+1)*0.5) * (halfpi / nr) + + ! pixel center + ! + cos_phi = cos(phi) + sin_phi = sin(phi) + vector(1) = sth * cos_phi + vector(2) = sth * sin_phi + vector(3) = z + + if (do_vertex) then + phi_nv = phi + phi_sv = phi + diff_phi = 0 ! phi_nv = phi_sv = phisth * 1} + iphi_rat = (jp-1) / nr ! in {0,1,2,3} + iphi_mod = mod(jp-1,nr) + phi_up = 0. + if (nr > 1) phi_up = HALFPI * (iphi_rat + iphi_mod /real(nr-1)) + phi_dn = HALFPI * (iphi_rat + (iphi_mod+1)/real(nr+1)) + if (jr < nside) then ! North polar cap + phi_nv = phi_up + phi_sv = phi_dn + diff_phi = 3 ! both phi_nv and phi_sv different from phi + elseif (jr > 3*nside) then ! South polar cap + phi_nv = phi_dn + phi_sv = phi_up + diff_phi = 3 ! both phi_nv and phi_sv different from phi + elseif (jr == nside) then ! North transition + phi_nv = phi_up + diff_phi = 1 + elseif (jr == 3*nside) then ! South transition + phi_sv = phi_up + diff_phi = 2 + endif + + hdelta_phi = PI / (4.0*nr) + + ! west vertex + phi_wv = phi - hdelta_phi + vertex(1,2) = sth * cos(phi_wv) + vertex(2,2) = sth * sin(phi_wv) + vertex(3,2) = z + + ! east vertex + phi_ev = phi + hdelta_phi + vertex(1,4) = sth * cos(phi_ev) + vertex(2,4) = sth * sin(phi_ev) + vertex(3,4) = z + + ! north and south vertices + sth_nv = sqrt((1.0-z_nv)*(1.0+z_nv)) + sth_sv = sqrt((1.0-z_sv)*(1.0+z_sv)) + if (diff_phi == 0) then + vertex(1,1) = sth_nv * cos_phi + vertex(2,1) = sth_nv * sin_phi + vertex(1,3) = sth_sv * cos_phi + vertex(2,3) = sth_sv * sin_phi + else + vertex(1,1) = sth_nv * cos(phi_nv) + vertex(2,1) = sth_nv * sin(phi_nv) + vertex(1,3) = sth_sv * cos(phi_sv) + vertex(2,3) = sth_sv * sin(phi_sv) + endif + vertex(3,1) = z_nv + vertex(3,3) = z_sv + endif + + end subroutine pix2vec_nest + + !======================================================================= + ! npix2nside + ! + ! given npix, returns nside such that npix = 12*nside^2 + ! nside should be a power of 2 smaller than ns_max + ! if not, -1 is returned + ! EH, Feb-2000 + ! 2009-03-05, edited, accepts 8-byte npix + !======================================================================= + function npix2nside (npix) result(nside_result) + integer(i4b), parameter :: MKD = I4B + integer(kind=MKD), parameter :: npix_max = (12_MKD*ns_max4)*ns_max4 + integer(kind=MKD), intent(in) :: npix + integer(kind=MKD) :: npix1, npix2 + integer(kind=I4B) :: nside_result + integer(kind=I4B) :: nside + character(LEN=*), parameter :: code = "npix2nside" + !======================================================================= + + if (npix < 12 .or. npix > npix_max) then + print*, code,"> Npix=",npix, & + & " is out of allowed range: {12,",npix_max,"}" + nside_result = -1 + return + endif + + nside = nint( sqrt(npix/12.0_dp) ) + npix1 = (12_MKD*nside)*nside + if (abs(npix1-npix) > 0) then + print*, code,"> Npix=",npix, & + & " is not 12 * Nside * Nside " + nside_result = -1 + return + endif + + ! test validity of Nside + npix2 = nside2npix(nside) + if (npix2 < 0) then + nside_result = -1 + return + endif + + nside_result = nside + + end function npix2nside + + + !======================================================================= + function nside2npix(nside) result(npix_result) + !======================================================================= + ! given nside, returns npix such that npix = 12*nside^2 + ! nside should be a power of 2 smaller than ns_max + ! if not, -1 is returned + ! EH, Feb-2000 + ! 2009-03-04: returns i8b result, faster + !======================================================================= + integer(kind=I4B) :: npix_result + integer(kind=I4B), intent(in) :: nside + + integer(kind=I4B) :: npix + character(LEN=*), parameter :: code = "nside2npix" + !======================================================================= + + npix = (12_i4b*nside)*nside + if (nside < 1 .or. nside > ns_max4 .or. iand(nside-1,nside) /= 0) then + print*,code,": Nside=",nside," is not a power of 2." + npix = -1 + endif + npix_result = npix + + end function nside2npix + + !======================================================================= + ! CHEAP_ISQRT + ! Returns exact Floor(sqrt(x)) where x is a (64 bit) integer. + ! y^2 <= x < (y+1)^2 (1) + ! The double precision floating point operation is not accurate enough + ! when dealing with 64 bit integers, especially in the vicinity of + ! perfect squares. + !======================================================================= + function cheap_isqrt(lin) result (lout) + integer(i4b), intent(in) :: lin + integer(i4b) :: lout + lout = floor(sqrt(dble(lin)), kind=I4B) + return + end function cheap_isqrt + + !======================================================================= + subroutine mk_pix2xy() + !======================================================================= + ! constructs the array giving x and y in the face from pixel number + ! for the nested (quad-cube like) ordering of pixels + ! + ! the bits corresponding to x and y are interleaved in the pixel number + ! one breaks up the pixel number by even and odd bits + !======================================================================= + integer(kind=I4B) :: kpix, jpix, ix, iy, ip, id + + !cc cf block data data pix2x(1023) /0/ + !----------------------------------------------------------------------- + ! print *, 'initiate pix2xy' + do kpix=0,1023 ! pixel number + jpix = kpix + IX = 0 + IY = 0 + IP = 1 ! bit position (in x and y) + ! do while (jpix/=0) ! go through all the bits + do + if (jpix == 0) exit ! go through all the bits + ID = modulo(jpix,2) ! bit value (in kpix), goes in ix + jpix = jpix/2 + IX = ID*IP+IX + + ID = modulo(jpix,2) ! bit value (in kpix), goes in iy + jpix = jpix/2 + IY = ID*IP+IY + + IP = 2*IP ! next bit (in x and y) + enddo + pix2x(kpix) = IX ! in 0,31 + pix2y(kpix) = IY ! in 0,31 + enddo + + end subroutine mk_pix2xy + !======================================================================= + subroutine mk_xy2pix1() + !======================================================================= + ! sets the array giving the number of the pixel lying in (x,y) + ! x and y are in {1,128} + ! the pixel number is in {0,128**2-1} + ! + ! if i-1 = sum_p=0 b_p * 2^p + ! then ix = sum_p=0 b_p * 4^p + ! iy = 2*ix + ! ix + iy in {0, 128**2 -1} + !======================================================================= + integer(kind=I4B):: k,ip,i,j,id + !======================================================================= + + do i = 0,127 !for converting x,y into + j = i !pixel numbers + k = 0 + ip = 1 + + do + if (j==0) then + x2pix1(i) = k + y2pix1(i) = 2*k + exit + else + id = modulo(J,2) + j = j/2 + k = ip*id+k + ip = ip*4 + endif + enddo + enddo + + end subroutine mk_xy2pix1 + + subroutine fatal_error (msg) + character(len=*), intent(in), optional :: msg + + if (present(msg)) then + print *,'Fatal error: ', trim(msg) + else + print *,'Fatal error' + endif + call exit_with_status(1) + + end subroutine fatal_error + + ! =========================================================== + subroutine exit_with_status (code, msg) + integer(i4b), intent(in) :: code + character (len=*), intent(in), optional :: msg + + if (present(msg)) print *,trim(msg) + print *,'program exits with exit code ', code + call exit (code) + + end subroutine exit_with_status + + !==================================================================== + ! The following is a routine which finds the 7 or 8 neighbours of + ! any pixel in the nested scheme of the HEALPIX pixelisation. + !==================================================================== + ! neighbours_nest + ! + ! Returns list n(8) of neighbours of pixel ipix (in NESTED scheme) + ! the neighbours are ordered in the following way: + ! First pixel is the one to the south (the one west of the south + ! direction is taken + ! for the pixels which don't have a southern neighbour). From + ! then on the neighbours are ordered in the clockwise direction + ! about the pixel with number ipix. + ! + ! nneigh is the number of neighbours (mostly 8, 8 pixels have 7 neighbours) + ! + ! Benjamin D. Wandelt October 1997 + ! Added to pix_tools in March 1999 + ! added 'return' for case nside=1, EH, Oct 2005 + ! corrected bugs in case nside=1 and ipix=7, 9 or 11, EH, June 2006 + ! 2009-06-16: deals with Nside > 8192 + !==================================================================== + subroutine neighbours_nest(nside, ipix, n, nneigh) + ! use bit_manipulation + integer(kind=i4b), parameter :: MKD = I4B + !==================================================================== + integer(kind=i4b), intent(in):: nside + integer(kind=MKD), intent(in):: ipix + integer(kind=MKD), intent(out), dimension(1:):: n + integer(kind=i4b), intent(out):: nneigh + + integer(kind=i4b) :: ix,ixm,ixp,iy,iym,iyp,ixo,iyo + integer(kind=i4b) :: face_num,other_face + integer(kind=i4b) :: ia,ib,ibp,ibm,ib2,icase + integer(kind=MKD) :: npix,ipf,ipo + integer(kind=MKD) :: local_magic1,local_magic2,nsidesq + character(len=*), parameter :: code = "neighbours_nest" + + ! integer(kind=i4b), intrinsic :: IAND + + !-------------------------------------------------------------------- + if (nside <1 .or. nside > ns_max4) call fatal_error(code//"> nside out of range") + npix = nside2npix(nside) ! total number of points + nsidesq = npix / 12 + if (ipix <0 .or. ipix>npix-1) call fatal_error(code//"> ipix out of range") + + ! quick and dirty hack for Nside=1 + + if (nside == 1) then + nneigh = 6 + if (ipix==0 ) n(1:6) = (/ 8, 4, 3, 2, 1, 5 /) + if (ipix==1 ) n(1:6) = (/ 9, 5, 0, 3, 2, 6 /) + if (ipix==2 ) n(1:6) = (/10, 6, 1, 0, 3, 7 /) + if (ipix==3 ) n(1:6) = (/11, 7, 2, 1, 0, 4 /) + if (ipix==4 ) n(1:6) = (/11, 7, 3, 0, 5, 8 /) + if (ipix==5 ) n(1:6) = (/ 8, 4, 0, 1, 6, 9 /) + if (ipix==6 ) n(1:6) = (/ 9, 5, 1, 2, 7,10 /) + if (ipix==7 ) n(1:6) = (/10, 6, 2, 3, 4,11 /) + if (ipix==8 ) n(1:6) = (/10,11, 4, 0, 5, 9 /) + if (ipix==9 ) n(1:6) = (/11, 8, 5, 1, 6,10 /) + if (ipix==10) n(1:6) = (/ 8, 9, 6, 2, 7,11 /) + if (ipix==11) n(1:6) = (/ 9,10, 7, 3, 4, 8 /) + return + endif + + ! initiates array for (x,y)-> pixel number -> (x,y) mapping + if (x2pix1(127) <= 0) call mk_xy2pix1() + + local_magic1=(nsidesq-1)/3 + local_magic2=2*local_magic1 + face_num=ipix/nsidesq + + ipf=modulo(ipix,nsidesq) !Pixel number in face + + call pix2xy_nest(nside,ipf,ix,iy) + ixm=ix-1 + ixp=ix+1 + iym=iy-1 + iyp=iy+1 + + nneigh=8 !Except in special cases below + + ! Exclude corners + if (ipf==local_magic2) then !WestCorner + icase=5 + goto 100 + endif + if (ipf==(nsidesq-1)) then !NorthCorner + icase=6 + goto 100 + endif + if (ipf==0) then !SouthCorner + icase=7 + goto 100 + endif + if (ipf==local_magic1) then !EastCorner + icase=8 + goto 100 + endif + + ! Detect edges + if (iand(ipf,local_magic1)==local_magic1) then !NorthEast + icase=1 + goto 100 + endif + if (iand(ipf,local_magic1)==0) then !SouthWest + icase=2 + goto 100 + endif + if (iand(ipf,local_magic2)==local_magic2) then !NorthWest + icase=3 + goto 100 + endif + if (iand(ipf,local_magic2)==0) then !SouthEast + icase=4 + goto 100 + endif + + ! Inside a face + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + return + + 100 continue + + ia= face_num/4 !in {0,2} + ib= modulo(face_num,4) !in {0,3} + ibp=modulo(ib+1,4) + ibm=modulo(ib+4-1,4) + ib2=modulo(ib+2,4) + + if (ia==0) then !North Pole region + select case(icase) + case(1) !NorthEast edge + other_face=0+ibp + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + ipo=modulo(swapLSBMSB(ipf),nsidesq) !East-West flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo+1 , iyo, other_face, n(5)) + n(6)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(7)) + case(2) !SouthWest edge + other_face=4+ib + ipo=modulo(invLSB(ipf),nsidesq) !SW-NE flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) + n(2)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo+1, other_face, n(3)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + case(3) !NorthWest edge + other_face=0+ibm + ipo=modulo(swapLSBMSB(ipf),nsidesq) !East-West flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(3)) + n(4)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo+1, other_face, n(5)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + case(4) !SouthEast edge + other_face=4+ibp + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + ipo=modulo(invMSB(ipf),nsidesq) !SE-NW flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo+1, iyo, other_face, n(7)) + n(8)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) + case(5) !West corner + nneigh=7 + other_face=4+ib + n(2)=other_face*nsidesq+nsidesq-1 + n(1)=n(2)-2 + other_face=0+ibm + n(3)=other_face*nsidesq+local_magic1 + n(4)=n(3)+2 + n(5)=ipix+1 + n(6)=ipix-1 + n(7)=ipix-2 + case(6) !North corner + n(1)=ipix-3 + n(2)=ipix-1 + n(8)=ipix-2 + other_face=0+ibm + n(4)=other_face*nsidesq+nsidesq-1 + n(3)=n(4)-2 + other_face=0+ib2 + n(5)=other_face*nsidesq+nsidesq-1 + other_face=0+ibp + n(6)=other_face*nsidesq+nsidesq-1 + n(7)=n(6)-1 + case(7) !South corner + other_face=8+ib + n(1)=other_face*nsidesq+nsidesq-1 + other_face=4+ib + n(2)=other_face*nsidesq+local_magic1 + n(3)=n(2)+2 + n(4)=ipix+2 + n(5)=ipix+3 + n(6)=ipix+1 + other_face=4+ibp + n(8)=other_face*nsidesq+local_magic2 + n(7)=n(8)+1 + case(8) !East corner + nneigh=7 + n(2)=ipix-1 + n(3)=ipix+1 + n(4)=ipix+2 + other_face=0+ibp + n(6)=other_face*nsidesq+local_magic2 + n(5)=n(6)+1 + other_face=4+ibp + n(7)=other_face*nsidesq+nsidesq-1 + n(1)=n(7)-1 + end select ! north + + elseif (ia==1) then !Equatorial region + select case(icase) + case(1) !NorthEast edge + other_face=0+ib + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + ipo=modulo(invLSB(ipf),nsidesq) !NE-SW flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo , iyo+1, other_face, n(5)) + n(6)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(7)) + case(2) !SouthWest edge + other_face=8+ibm + ipo=modulo(invLSB(ipf),nsidesq) !SW-NE flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) + n(2)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo+1, other_face, n(3)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + case(3) !NorthWest edge + other_face=0+ibm + ipo=modulo(invMSB(ipf),nsidesq) !NW-SE flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(3)) + n(4)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo+1, iyo, other_face, n(5)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + case(4) !SouthEast edge + other_face=8+ib + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + ipo=modulo(invMSB(ipf),nsidesq) !SE-NW flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo+1, iyo, other_face, n(7)) + n(8)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) + case(5) !West corner + other_face=8+ibm + n(2)=other_face*nsidesq+nsidesq-1 + n(1)=n(2)-2 + other_face=4+ibm + n(3)=other_face*nsidesq+local_magic1 + other_face=0+ibm + n(4)=other_face*nsidesq + n(5)=n(4)+1 + n(6)=ipix+1 + n(7)=ipix-1 + n(8)=ipix-2 + case(6) !North corner + nneigh=7 + n(1)=ipix-3 + n(2)=ipix-1 + other_face=0+ibm + n(4)=other_face*nsidesq+local_magic1 + n(3)=n(4)-1 + other_face=0+ib + n(5)=other_face*nsidesq+local_magic2 + n(6)=n(5)-2 + n(7)=ipix-2 + case(7) !South corner + nneigh=7 + other_face=8+ibm + n(1)=other_face*nsidesq+local_magic1 + n(2)=n(1)+2 + n(3)=ipix+2 + n(4)=ipix+3 + n(5)=ipix+1 + other_face=8+ib + n(7)=other_face*nsidesq+local_magic2 + n(6)=n(7)+1 + case(8) !East corner + other_face=8+ib + n(8)=other_face*nsidesq+nsidesq-1 + n(1)=n(8)-1 + n(2)=ipix-1 + n(3)=ipix+1 + n(4)=ipix+2 + other_face=0+ib + n(6)=other_face*nsidesq + n(5)=n(6)+2 + other_face=4+ibp + n(7)=other_face*nsidesq+local_magic2 + end select ! equator + else !South Pole region + select case(icase) + case(1) !NorthEast edge + other_face=4+ibp + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + ipo=modulo(invLSB(ipf),nsidesq) !NE-SW flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo , iyo+1, other_face, n(5)) + n(6)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(7)) + case(2) !SouthWest edge + other_face=8+ibm + ipo=modulo(swapLSBMSB(ipf),nsidesq) !W-E flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) + n(2)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo+1, iyo, other_face, n(3)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + case(3) !NorthWest edge + other_face=4+ib + ipo=modulo(invMSB(ipf),nsidesq) !NW-SE flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(3)) + n(4)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo+1, iyo, other_face, n(5)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + case(4) !SouthEast edge + other_face=8+ibp + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + ipo=modulo(swapLSBMSB(ipf),nsidesq) !E-W flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo, iyo+1, other_face, n(7)) + n(8)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) + case(5) !West corner + nneigh=7 + other_face=8+ibm + n(2)=other_face*nsidesq+local_magic1 + n(1)=n(2)-1 + other_face=4+ib + n(3)=other_face*nsidesq + n(4)=n(3)+1 + n(5)=ipix+1 + n(6)=ipix-1 + n(7)=ipix-2 + case(6) !North corner + n(1)=ipix-3 + n(2)=ipix-1 + other_face=4+ib + n(4)=other_face*nsidesq+local_magic1 + n(3)=n(4)-1 + other_face=0+ib + n(5)=other_face*nsidesq + other_face=4+ibp + n(6)=other_face*nsidesq+local_magic2 + n(7)=n(6)-2 + n(8)=ipix-2 + case(7) !South corner + other_face=8+ib2 + n(1)=other_face*nsidesq + other_face=8+ibm + n(2)=other_face*nsidesq + n(3)=n(2)+1 + n(4)=ipix+2 + n(5)=ipix+3 + n(6)=ipix+1 + other_face=8+ibp + n(8)=other_face*nsidesq + n(7)=n(8)+2 + case(8) !East corner + nneigh=7 + other_face=8+ibp + n(7)=other_face*nsidesq+local_magic2 + n(1)=n(7)-2 + n(2)=ipix-1 + n(3)=ipix+1 + n(4)=ipix+2 + other_face=4+ibp + n(6)=other_face*nsidesq + n(5)=n(6)+2 + end select ! south + endif + + end subroutine neighbours_nest + + + !======================================================================= + ! pix2xy_nest + ! gives the x, y coords in a face from pixel number within the face (NESTED) + ! + ! Benjamin D. Wandelt 13/10/97 + ! + ! using code from HEALPIX toolkit by K.Gorski and E. Hivon + ! 2009-06-15: deals with Nside > 8192 + ! 2012-03-02: test validity of ipf_in instead of undefined ipf + ! define ipf as MKD + ! 2012-08-27: corrected bug on (ix,iy) for Nside > 8192 (MARK) + !======================================================================= + subroutine pix2xy_nest (nside, ipf_in, ix, iy) + integer(kind=i4b), parameter :: MKD = I4B + integer(kind=I4B), intent(in) :: nside + integer(kind=MKD), intent(in) :: ipf_in + integer(kind=I4B), intent(out) :: ix, iy + + integer(kind=MKD) :: ipf + integer(kind=I4B) :: ip_low, ip_trunc, ip_med, ip_hi, scale, i, ismax + character(len=*), parameter :: code = "pix2xy_nest" + + !----------------------------------------------------------------------- + if (nside<1 .or. nside>ns_max) call fatal_error(code//"> nside out of range") + if (ipf_in<0 .or. ipf_in>nside*nside-1) & + & call fatal_error(code//"> ipix out of range") + if (pix2x(1023) <= 0) call mk_pix2xy() + + ipf = ipf_in + if (nside <= ns_max4) then + ip_low = iand(ipf,1023_MKD) ! content of the last 10 bits + ip_trunc = ipf/1024 ! truncation of the last 10 bits + ip_med = iand(ip_trunc,1023) ! content of the next 10 bits + ip_hi = ip_trunc/1024 ! content of the high weight 10 bits + + ix = 1024*pix2x(ip_hi) + 32*pix2x(ip_med) + pix2x(ip_low) + iy = 1024*pix2y(ip_hi) + 32*pix2y(ip_med) + pix2y(ip_low) + else + ix = 0 + iy = 0 + scale = 1 + ismax = 4 + do i=0, ismax + ip_low = iand(ipf,1023_MKD) + ix = ix + scale * pix2x(ip_low) + iy = iy + scale * pix2y(ip_low) ! corrected 2012-08-27 + scale = scale * 32 + ipf = ipf/1024 + enddo + ix = ix + scale * pix2x(ipf) + iy = iy + scale * pix2y(ipf) ! corrected 2012-08-27 + endif + + end subroutine pix2xy_nest + + !======================================================================= + ! gives the pixel number ipix (NESTED) + ! corresponding to ix, iy and face_num + ! + ! Benjamin D. Wandelt 13/10/97 + ! using code from HEALPIX toolkit by K.Gorski and E. Hivon + ! 2009-06-15: deals with Nside > 8192 + ! 2012-03-02: test validity of ix_in and iy_in instead of undefined ix and iy + !======================================================================= + subroutine xy2pix_nest(nside, ix_in, iy_in, face_num, ipix) + integer(kind=i4b), parameter :: MKD = I4B + !======================================================================= + integer(kind=I4B), intent(in) :: nside, ix_in, iy_in, face_num + integer(kind=MKD), intent(out) :: ipix + integer(kind=I4B) :: ix, iy, ix_low, iy_low, i, ismax + integer(kind=MKD) :: ipf, scale, scale_factor + character(len=*), parameter :: code = "xy2pix_nest" + + !----------------------------------------------------------------------- + if (nside<1 .or. nside>ns_max) call fatal_error(code//"> nside out of range") + if (ix_in<0 .or. ix_in>(nside-1)) call fatal_error(code//"> ix out of range") + if (iy_in<0 .or. iy_in>(nside-1)) call fatal_error(code//"> iy out of range") + if (x2pix1(127) <= 0) call mk_xy2pix1() + + ix = ix_in + iy = iy_in + if (nside <= ns_max4) then + ix_low = iand(ix, 127) + iy_low = iand(iy, 127) + ipf = x2pix1(ix_low) + y2pix1(iy_low) & + & + (x2pix1(ix/128) + y2pix1(iy/128)) * 16384 + else + scale = 1_MKD + scale_factor = 16384_MKD ! 128*128 + ipf = 0_MKD + ismax = 1 ! for nside in [2^14, 2^20] + if (nside > 1048576 ) ismax = 3 + do i=0, ismax + ix_low = iand(ix, 127) ! last 7 bits + iy_low = iand(iy, 127) ! last 7 bits + ipf = ipf + (x2pix1(ix_low)+y2pix1(iy_low)) * scale + scale = scale * scale_factor + ix = ix / 128 ! truncate out last 7 bits + iy = iy / 128 + enddo + ipf = ipf + (x2pix1(ix)+y2pix1(iy)) * scale + endif + ipix = ipf + face_num* int(nside,MKD) * nside ! in {0, 12*nside**2 - 1} + + end subroutine xy2pix_nest + + end module healpix diff --git a/src/main/utils_raytracer.f90 b/src/main/utils_raytracer.f90 index e68deddef..fe45fd581 100644 --- a/src/main/utils_raytracer.f90 +++ b/src/main/utils_raytracer.f90 @@ -10,7 +10,7 @@ module raytracer ! ! :References: None ! -! :Owner: Not Committed Yet +! :Owner: Mats Esseldeurs ! ! :Runtime parameters: None ! diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index 6ef3f236b..79554e574 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.f90 @@ -1,692 +1,692 @@ -!--------------------------------------------------------------------------! -! 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 analysis -! -! Analysis routine which computes neighbour lists for all particles -! -! :References: None -! -! :Owner: Lionel Siess -! -! :Runtime parameters: None -! -! :Dependencies: dump_utils, dust_formation, getneighbours, linklist, -! omp_lib, part, physcon, raytracer, raytracer_all -! - use raytracer_all, only:get_all_tau_inwards, get_all_tau_outwards, get_all_tau_adaptive - use raytracer, only:get_all_tau - use part, only:rhoh,isdead_or_accreted,nsinkproperties,iReff - use dump_utils, only:read_array_from_file - use getneighbours, only:generate_neighbour_lists, read_neighbours, write_neighbours, & - neighcount,neighb,neighmax - use dust_formation, only:calc_kappa_bowen - use physcon, only:kboltz,mass_proton_cgs,au,solarm - use linklist, only:set_linklist,allocate_linklist,deallocate_linklist - - implicit none - - character(len=20), parameter, public :: analysistype = 'raytracer' - real :: gamma = 1.2 - real :: mu = 2.381 - public :: do_analysis - - private - -contains - -subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) - use omp_lib - - character(len=*), intent(in) :: dumpfile - integer, intent(in) :: num,npart,iunit - real(kind=8), intent(in) :: xyzh(:,:),vxyzu(:,:) - real(kind=8), intent(in) :: particlemass,time - - logical :: existneigh - character(100) :: neighbourfile - character(100) :: jstring, kstring - real :: primsec(4,2), rho(npart), kappa(npart), temp(npart), u(npart), & - xyzh2(4,npart), vxyzu2(4,npart), xyzmh_ptmass(nsinkproperties,2) - real, dimension(:), allocatable :: tau - integer :: i,j,k,ierr,iu1,iu2,iu3,iu4, npart2!,iu - integer :: start, finish, method, analyses, minOrder, maxOrder, order, raypolation, refineScheme - real :: totalTime, timeTau, Rstar, Rcomp, times(30) - logical :: SPH = .true., calcInwards = .false. - - real, parameter :: udist = au, umass = solarm - - Rstar = 2.37686663 - Rcomp = 0.1 - xyzmh_ptmass = 0. - xyzmh_ptmass(iReff,1) = Rstar - xyzmh_ptmass(iReff,2) = Rcomp - - print*,'("Reading kappa from file")' - call read_array_from_file(123,dumpfile,'kappa',kappa(:),ierr, 1) - if (ierr/=0) then - print*,'' - print*,'("WARNING: could not read kappa from file. It will be set to zero")' - print*,'' - kappa = 0. - endif - - if (kappa(1) <= 0. .and. kappa(2) <= 0. .and. kappa(2) <= 0.) then - print*,'("Reading temperature from file")' - call read_array_from_file(123,dumpfile,'temperature',temp(:),ierr, 1) - if (temp(1) <= 0. .and. temp(2) <= 0. .and. temp(2) <= 0.) then - print*,'("Reading internal energy from file")' - call read_array_from_file(123,dumpfile,'u',u(:),ierr, 1) - do i=1,npart - temp(i)=(gamma-1.)*mu*u(i)*mass_proton_cgs*kboltz - enddo - endif - do i=1,npart - kappa(i)=calc_kappa_bowen(temp(i)) - enddo - endif - - j=1 - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - xyzh2(:,j) = xyzh(:,i) - vxyzu2(:,j) = vxyzu(:,i) - kappa(j) = kappa(i) - j=j+1 - endif - enddo - npart2 = j-1 - call set_linklist(npart2,npart2,xyzh2,vxyzu) - print*,'npart = ',npart2 - allocate(tau(npart2)) - - !get position of sink particles (stars) - call read_array_from_file(123,dumpfile,'x',primsec(1,:),ierr, 2) - call read_array_from_file(123,dumpfile,'y',primsec(2,:),ierr, 2) - call read_array_from_file(123,dumpfile,'z',primsec(3,:),ierr, 2) - call read_array_from_file(123,dumpfile,'h',primsec(4,:),ierr, 2) - if (primsec(1,1) == xyzh(1,1) .and. primsec(2,1) == xyzh(2,1) .and. primsec(3,1) == xyzh(3,1)) then - primsec(:,1) = (/0.,0.,0.,1./) - endif - xyzmh_ptmass(1:4,1) = primsec(:,1) - xyzmh_ptmass(1:4,2) = primsec(:,2) - - - print *,'What do you want to do?' - print *, '(1) Analysis' - print *, '(2) Integration method' - print *, '(3) Calculate tau as done in realtime in PHANTOM' - print *, '(4) Preloaded settings' - print *, '(5) Print out points' - read *,analyses - ! analyses=4 - - if (analyses == 1) then - print *,'Which analysis would you like to run?' - print *, '(1) Inward Integration' - print *, '(2) Outward Integration (realtime)' - print *, '(3) Outward Integration (interpolation)' - print *, '(4) Outward Integration (interpolation-all)' - print *, '(5) Adaptive (Outward) Integration' - print *, '(6) Scaling' - print *, '(7) Time evolution for mutiple files' - read *,method - if (method == 1) then - SPH = .false. - elseif (method == 2) then - SPH = .false. - print *,'At which order would you like to start?' - read *,minOrder - print *,'At which order would you like to stop?' - read *,maxOrder - elseif (method == 3) then - print *,'At which order would you like to start?' - read *,minOrder - print *,'At which order would you like to stop?' - read *,maxOrder - print *,'What interpolation scheme would you like to use' - print *,'(0) 1 ray, no interpolation' - print *,'(1) 4 rays, linear interpolation' - print *,'(2) 9 rays, linear interpolation' - print *,'(3) 4 rays, square interpolation' - print *,'(4) 9 rays, square interpolation' - print *,'(5) 4 rays, cubed interpolation' - print *,'(6) 9 rays, cubed interpolation' - read*,raypolation - elseif (method == 4) then - SPH = .false. - calcInwards = .false. - print *,'At which order would you like to start?' - read *,minOrder - print *,'At which order would you like to stop?' - read *,maxOrder - elseif (method == 5) then - print *,'At which order would you like to start?' - read *,minOrder - print *,'At which order would you like to stop?' - read *,maxOrder - print *,'What refinement scheme would you like to use' - print *,'(1) refine half' - print *,'(2) refine overdens' - print *,'(0) all the above' - read *,refineScheme - elseif (method == 6) then - - elseif (method == 7) then - - endif - elseif (analyses == 2) then - print *,'Which algorithm would you like to run?' - print *, '(1) Inward' - print *, '(2) Outward (realtime)' - print *, '(3) Outward (interpolation)' - print *, '(4) Adaptive' - read *,method - if (method == 1) then - print *,'Do you want to use SPH neighbours? (T/F)' - read*,SPH - elseif (method == 2) then - print *,'What order do you want to run?' - read*,j - write(jstring,'(i0)') j - elseif (method == 3) then - print *,'What order do you want to run?' - read*,j - write(jstring,'(i0)') j - print *,'What interpolation scheme would you like to use' - print *,'(0) 1 ray, no interpolation' - print *,'(1) 4 rays, linear interpolation' - print *,'(2) 9 rays, linear interpolation' - print *,'(3) 4 rays, square interpolation' - print *,'(4) 9 rays, square interpolation' - print *,'(5) 4 rays, cubed interpolation' - print *,'(6) 9 rays, cubed interpolation' - read*,raypolation - write(kstring,'(i0)') raypolation - elseif (method == 4) then - print *,'What order do you want to run? (integer below 7)' - read*,j - write(jstring,'(i0)') j - print *,'What refinement level do you want to run? (integer below 7)' - read*,k - write(kstring,'(i0)') k - print *,'What refinement scheme would you like to use' - print *,'(1) refine half' - print *,'(2) refine overdens' - print *,'(0) all the above' - read *,refineScheme - endif - endif - - if (analyses == 2 .and. method==1) then ! get neighbours - if (SPH) then - neighbourfile = 'neigh_'//TRIM(dumpfile) - inquire(file=neighbourfile,exist = existneigh) - if (existneigh) then - print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' - call read_neighbours(neighbourfile,npart2) - else - ! If there is no neighbour file, generate the list - print*, 'No neighbour file found: generating' - call system_clock(start) - call generate_neighbour_lists(xyzh2,vxyzu2,npart2,dumpfile, .false.) - call system_clock(finish) - totalTime = (finish-start)/1000. - print*,'Time = ',totalTime,' seconds.' - call write_neighbours(neighbourfile, npart2) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) - endif - else - allocate(neighb(npart2+2,100)) - neighb = 0 - inquire(file='neighbors_tess.txt',exist = existneigh) - if (existneigh) then - print*, 'Neighbour file neighbors.txt found' - else - call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') - endif - open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') - do i=1, npart2+2 - read(iu4,*) neighb(i,:) - enddo - close(iu4) - endif - endif - - if (analyses == 1) then - - ! INWARD INTEGRATION ANALYSIS - if (method == 1) then - neighbourfile = 'neigh_'//TRIM(dumpfile) - inquire(file=neighbourfile,exist = existneigh) - if (existneigh) then - print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' - call read_neighbours(neighbourfile,npart2) - else - ! If there is no neighbour file, generate the list - print*, 'No neighbour file found: generating' - call system_clock(start) - call generate_neighbour_lists(xyzh2,vxyzu2,npart2,dumpfile, .false.) - call system_clock(finish) - totalTime = (finish-start)/1000. - print*,'Time = ',totalTime,' seconds.' - call write_neighbours(neighbourfile, npart2) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) - endif - print*,'' - print*, 'Start calculating optical depth inward SPH' - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt', status='replace', action='write') - write(iu4, *) timeTau - close(iu4) - totalTime = timeTau - open(newunit=iu2, file='taus_inwards_SPH_'//dumpfile//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - deallocate(neighb) - allocate(neighb(npart2+2,100)) - neighb = 0 - inquire(file='neighbors_tess.txt',exist = existneigh) - if (existneigh) then - print*, 'Delaunay neighbour file neighbours.txt found' - else - call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') - endif - open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') - do i=1, npart2+2 - read(iu4,*) neighb(i,:) - enddo - close(iu4) - print*,'' - print*, 'Start calculating optical depth inward Delaunay' - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt',position='append', status='old', action='write') - write(iu4, *) timeTau - close(iu4) - totalTime = timeTau - open(newunit=iu2, file='taus_inwards_Del_'//dumpfile//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - - ! OUTWARD INTEGRATION realTIME ANALYSIS - elseif (method == 2) then - open(newunit=iu4, file='times_'//dumpfile//'.txt', status='replace', action='write') - close(iu4) - totalTime=0 - - do j = minOrder, maxOrder - write(jstring,'(i0)') j - print*,'' - print*, 'Start calculating optical depth outward: ', trim(jstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, j, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, j, tau) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_'//dumpfile//'.txt',position='append', status='old', action='write') - write(iu4, *) timeTau - close(iu4) - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - enddo - print*,'' - print*,'Total time of the calculation = ',totalTime,' seconds.' - - ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS - elseif (method == 3) then - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') - close(iu4) - totalTime=0 - - do j = minOrder, maxOrder - write(jstring,'(i0)') j - print*,'' - print*, 'Start calculating optical depth outward: ', trim(jstring),', interpolation: ', trim(kstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') - write(iu4, *) timeTau - close(iu4) - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & - status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - enddo - print*,'' - print*,'Total time of the calculation = ',totalTime,' seconds.' - - ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS - elseif (method == 4) then - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') - close(iu4) - totalTime=0 - - do j = minOrder, maxOrder - do k = 0, 6 - write(jstring,'(i0)') j - write(kstring,'(i0)') k - print*,'' - print*, 'Start calculating optical depth outward: ', trim(jstring),', interpolation: ', trim(kstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - times(k+1) = timeTau - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & - status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - enddo - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') - write(iu4, *) times(1:7) - close(iu4) - enddo - print*,'' - print*,'Total time of the calculation = ',totalTime,' seconds.' - - !ADAPTIVE (OUTWARD) INTEGRATION ANALYSIS - elseif (method == 5) then - open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt', status='replace', action='write') - close(iu4) - totalTime=0 - - do j = minOrder, maxOrder - write(jstring,'(i0)') j - times = 0. - do k = minOrder,maxOrder-j - write(kstring,'(i0)') k - print*,'' - print*, 'Start calculating optical depth outward: minOrder = ', trim(jstring),', refineLevel = ', trim(kstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme,& - tau, primsec(1:3,2), Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - times(k-minOrder+1) = timeTau - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & - '_'//trim(kstring)//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - enddo - open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt',position='append', status='old', action='write') - write(iu4, *) times(1:maxOrder-minOrder+1) - close(iu4) - enddo - print*,'' - print*,'Total time of the calculation = ',totalTime,' seconds.' - - ! SCALING ANALYSIS - elseif (method == 6) then - order = 5 - print*,'Start doing scaling analysis with order =',order - open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt', status='replace', action='write') - close(iu4) - do i=1, omp_get_max_threads() - call omp_set_num_threads(i) - call deallocate_linklist - call allocate_linklist - call set_linklist(npart2,npart2,xyzh2,vxyzu) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'nthread = ',omp_get_max_threads(),': Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt',position='append', status='old', action='write') - write(iu4, *) omp_get_max_threads(), timeTau - close(iu4) - enddo - - ! TIME ANALYSIS MULTIPLE FILES - elseif (method == 7) then - order = 5 - print*,'Start doing scaling analysis with order =',order - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu1, file='npart_wind.txt',position='append', action='write') - write(iu1, *) npart2 - close(iu1) - open(newunit=iu4, file='times_wind.txt',position='append', action='write') - write(iu4, *) timeTau - close(iu4) - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - endif - - elseif (analyses == 2) then - !ADAPTIVE (OUTWARD) INTEGRATION SCHEME - if (method == 1) then - print*,'' - print*, 'Start calculating optical depth inward' - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - if (SPH) then - open(newunit=iu2, file='taus_'//dumpfile//'_inwards.txt', status='replace', action='write') - else - open(newunit=iu2, file='taus_'//dumpfile//'_tess_inwards.txt', status='replace', action='write') - endif - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - elseif (method == 2) then - print*,'' - print*, 'Start calculating optical depth outward: ', trim(jstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, j, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, j, tau) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - elseif (method == 3) then - print*,'' - print*, 'Start calculating optical depth outward: ', trim(jstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - elseif (method == 4) then - print*,'' - print*, 'Start calculating optical depth adaptive: minOrder = ', trim(jstring),', refineLevel = ', trim(kstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & - '_'//trim(kstring)//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - endif - - elseif (analyses == 3) then - order = 5 - print*,'Start calculating optical depth' - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='taus_'//dumpfile//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu4, *) tau(i) - enddo - close(iu4) - - elseif (analyses == 4) then - do i=1,npart - if (norm2(xyzh2(1:3,i) - (/10.,10.,10./)) < 4.) then - kappa(i) = 1e10 - endif - enddo - ! allocate(neighb(npart2+2,100)) - ! neighb = 0 - ! open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') - ! do i=1, npart2+2 - ! read(iu4,*) neighb(i,:) - ! enddo - ! close(iu4) - print*,'' - order = 7 - print*, 'Start calculating optical depth outward, order=',order - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_raypolation_7.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - - elseif (analyses == 5) then - open(newunit=iu1, file='points_'//dumpfile//'.txt', status='replace', action='write') - do i=1, npart2+2 - write(iu1, *) xyzh2(1:3,i) - enddo - close(iu1) - - open(newunit=iu3, file='rho_'//dumpfile//'.txt', status='replace', action='write') - do i=1,npart2 - rho(i) = rhoh(xyzh2(4,i), particlemass) - write(iu3, *) rho(i) - enddo - close(iu3) - endif - -end subroutine do_analysis -end module analysis + !--------------------------------------------------------------------------! + ! 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 analysis + ! + ! Analysis routine which computes neighbour lists for all particles + ! + ! :References: None + ! + ! :Owner: Lionel Siess + ! + ! :Runtime parameters: None + ! + ! :Dependencies: dump_utils, dust_formation, getneighbours, linklist, + ! omp_lib, part, physcon, raytracer, raytracer_all + ! + use raytracer_all, only:get_all_tau_inwards, get_all_tau_outwards, get_all_tau_adaptive + use raytracer, only:get_all_tau + use part, only:rhoh,isdead_or_accreted,nsinkproperties,iReff + use dump_utils, only:read_array_from_file + use getneighbours, only:generate_neighbour_lists, read_neighbours, write_neighbours, & + neighcount,neighb,neighmax + use dust_formation, only:calc_kappa_bowen + use physcon, only:kboltz,mass_proton_cgs,au,solarm + use linklist, only:set_linklist,allocate_linklist,deallocate_linklist + + implicit none + + character(len=20), parameter, public :: analysistype = 'raytracer' + real :: gamma = 1.2 + real :: mu = 2.381 + public :: do_analysis + + private + + contains + + subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) + use omp_lib + + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: num,npart,iunit + real(kind=8), intent(in) :: xyzh(:,:),vxyzu(:,:) + real(kind=8), intent(in) :: particlemass,time + + logical :: existneigh + character(100) :: neighbourfile + character(100) :: jstring, kstring + real :: primsec(4,2), rho(npart), kappa(npart), temp(npart), u(npart), & + xyzh2(4,npart), vxyzu2(4,npart), xyzmh_ptmass(nsinkproperties,2) + real, dimension(:), allocatable :: tau + integer :: i,j,k,ierr,iu1,iu2,iu3,iu4, npart2!,iu + integer :: start, finish, method, analyses, minOrder, maxOrder, order, raypolation, refineScheme + real :: totalTime, timeTau, Rstar, Rcomp, times(30) + logical :: SPH = .true., calcInwards = .false. + + real, parameter :: udist = au, umass = solarm + + Rstar = 2.37686663 + Rcomp = 0.1 + xyzmh_ptmass = 0. + xyzmh_ptmass(iReff,1) = Rstar + xyzmh_ptmass(iReff,2) = Rcomp + + print*,'("Reading kappa from file")' + call read_array_from_file(123,dumpfile,'kappa',kappa(:),ierr, 1) + if (ierr/=0) then + print*,'' + print*,'("WARNING: could not read kappa from file. It will be set to zero")' + print*,'' + kappa = 0. + endif + + if (kappa(1) <= 0. .and. kappa(2) <= 0. .and. kappa(2) <= 0.) then + print*,'("Reading temperature from file")' + call read_array_from_file(123,dumpfile,'temperature',temp(:),ierr, 1) + if (temp(1) <= 0. .and. temp(2) <= 0. .and. temp(2) <= 0.) then + print*,'("Reading internal energy from file")' + call read_array_from_file(123,dumpfile,'u',u(:),ierr, 1) + do i=1,npart + temp(i)=(gamma-1.)*mu*u(i)*mass_proton_cgs*kboltz + enddo + endif + do i=1,npart + kappa(i)=calc_kappa_bowen(temp(i)) + enddo + endif + + j=1 + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + xyzh2(:,j) = xyzh(:,i) + vxyzu2(:,j) = vxyzu(:,i) + kappa(j) = kappa(i) + j=j+1 + endif + enddo + npart2 = j-1 + call set_linklist(npart2,npart2,xyzh2,vxyzu) + print*,'npart = ',npart2 + allocate(tau(npart2)) + + !get position of sink particles (stars) + call read_array_from_file(123,dumpfile,'x',primsec(1,:),ierr, 2) + call read_array_from_file(123,dumpfile,'y',primsec(2,:),ierr, 2) + call read_array_from_file(123,dumpfile,'z',primsec(3,:),ierr, 2) + call read_array_from_file(123,dumpfile,'h',primsec(4,:),ierr, 2) + if (primsec(1,1) == xyzh(1,1) .and. primsec(2,1) == xyzh(2,1) .and. primsec(3,1) == xyzh(3,1)) then + primsec(:,1) = (/0.,0.,0.,1./) + endif + xyzmh_ptmass(1:4,1) = primsec(:,1) + xyzmh_ptmass(1:4,2) = primsec(:,2) + + + print *,'What do you want to do?' + print *, '(1) Analysis' + print *, '(2) Integration method' + print *, '(3) Calculate tau as done in realtime in PHANTOM' + print *, '(4) Preloaded settings' + print *, '(5) Print out points' + read *,analyses + ! analyses=4 + + if (analyses == 1) then + print *,'Which analysis would you like to run?' + print *, '(1) Inward Integration' + print *, '(2) Outward Integration (realtime)' + print *, '(3) Outward Integration (interpolation)' + print *, '(4) Outward Integration (interpolation-all)' + print *, '(5) Adaptive (Outward) Integration' + print *, '(6) Scaling' + print *, '(7) Time evolution for mutiple files' + read *,method + if (method == 1) then + SPH = .false. + elseif (method == 2) then + SPH = .false. + print *,'At which order would you like to start?' + read *,minOrder + print *,'At which order would you like to stop?' + read *,maxOrder + elseif (method == 3) then + print *,'At which order would you like to start?' + read *,minOrder + print *,'At which order would you like to stop?' + read *,maxOrder + print *,'What interpolation scheme would you like to use' + print *,'(0) 1 ray, no interpolation' + print *,'(1) 4 rays, linear interpolation' + print *,'(2) 9 rays, linear interpolation' + print *,'(3) 4 rays, square interpolation' + print *,'(4) 9 rays, square interpolation' + print *,'(5) 4 rays, cubed interpolation' + print *,'(6) 9 rays, cubed interpolation' + read*,raypolation + elseif (method == 4) then + SPH = .false. + calcInwards = .false. + print *,'At which order would you like to start?' + read *,minOrder + print *,'At which order would you like to stop?' + read *,maxOrder + elseif (method == 5) then + print *,'At which order would you like to start?' + read *,minOrder + print *,'At which order would you like to stop?' + read *,maxOrder + print *,'What refinement scheme would you like to use' + print *,'(1) refine half' + print *,'(2) refine overdens' + print *,'(0) all the above' + read *,refineScheme + elseif (method == 6) then + + elseif (method == 7) then + + endif + elseif (analyses == 2) then + print *,'Which algorithm would you like to run?' + print *, '(1) Inward' + print *, '(2) Outward (realtime)' + print *, '(3) Outward (interpolation)' + print *, '(4) Adaptive' + read *,method + if (method == 1) then + print *,'Do you want to use SPH neighbours? (T/F)' + read*,SPH + elseif (method == 2) then + print *,'What order do you want to run?' + read*,j + write(jstring,'(i0)') j + elseif (method == 3) then + print *,'What order do you want to run?' + read*,j + write(jstring,'(i0)') j + print *,'What interpolation scheme would you like to use' + print *,'(0) 1 ray, no interpolation' + print *,'(1) 4 rays, linear interpolation' + print *,'(2) 9 rays, linear interpolation' + print *,'(3) 4 rays, square interpolation' + print *,'(4) 9 rays, square interpolation' + print *,'(5) 4 rays, cubed interpolation' + print *,'(6) 9 rays, cubed interpolation' + read*,raypolation + write(kstring,'(i0)') raypolation + elseif (method == 4) then + print *,'What order do you want to run? (integer below 7)' + read*,j + write(jstring,'(i0)') j + print *,'What refinement level do you want to run? (integer below 7)' + read*,k + write(kstring,'(i0)') k + print *,'What refinement scheme would you like to use' + print *,'(1) refine half' + print *,'(2) refine overdens' + print *,'(0) all the above' + read *,refineScheme + endif + endif + + if (analyses == 2 .and. method==1) then ! get neighbours + if (SPH) then + neighbourfile = 'neigh_'//TRIM(dumpfile) + inquire(file=neighbourfile,exist = existneigh) + if (existneigh) then + print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' + call read_neighbours(neighbourfile,npart2) + else + ! If there is no neighbour file, generate the list + print*, 'No neighbour file found: generating' + call system_clock(start) + call generate_neighbour_lists(xyzh2,vxyzu2,npart2,dumpfile, .false.) + call system_clock(finish) + totalTime = (finish-start)/1000. + print*,'Time = ',totalTime,' seconds.' + call write_neighbours(neighbourfile, npart2) + print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + endif + else + allocate(neighb(npart2+2,100)) + neighb = 0 + inquire(file='neighbors_tess.txt',exist = existneigh) + if (existneigh) then + print*, 'Neighbour file neighbors.txt found' + else + call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') + endif + open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + do i=1, npart2+2 + read(iu4,*) neighb(i,:) + enddo + close(iu4) + endif + endif + + if (analyses == 1) then + + ! INWARD INTEGRATION ANALYSIS + if (method == 1) then + neighbourfile = 'neigh_'//TRIM(dumpfile) + inquire(file=neighbourfile,exist = existneigh) + if (existneigh) then + print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' + call read_neighbours(neighbourfile,npart2) + else + ! If there is no neighbour file, generate the list + print*, 'No neighbour file found: generating' + call system_clock(start) + call generate_neighbour_lists(xyzh2,vxyzu2,npart2,dumpfile, .false.) + call system_clock(finish) + totalTime = (finish-start)/1000. + print*,'Time = ',totalTime,' seconds.' + call write_neighbours(neighbourfile, npart2) + print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + endif + print*,'' + print*, 'Start calculating optical depth inward SPH' + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt', status='replace', action='write') + write(iu4, *) timeTau + close(iu4) + totalTime = timeTau + open(newunit=iu2, file='taus_inwards_SPH_'//dumpfile//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + deallocate(neighb) + allocate(neighb(npart2+2,100)) + neighb = 0 + inquire(file='neighbors_tess.txt',exist = existneigh) + if (existneigh) then + print*, 'Delaunay neighbour file neighbours.txt found' + else + call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') + endif + open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + do i=1, npart2+2 + read(iu4,*) neighb(i,:) + enddo + close(iu4) + print*,'' + print*, 'Start calculating optical depth inward Delaunay' + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt',position='append', status='old', action='write') + write(iu4, *) timeTau + close(iu4) + totalTime = timeTau + open(newunit=iu2, file='taus_inwards_Del_'//dumpfile//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + + ! OUTWARD INTEGRATION realTIME ANALYSIS + elseif (method == 2) then + open(newunit=iu4, file='times_'//dumpfile//'.txt', status='replace', action='write') + close(iu4) + totalTime=0 + + do j = minOrder, maxOrder + write(jstring,'(i0)') j + print*,'' + print*, 'Start calculating optical depth outward: ', trim(jstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, j, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, j, tau) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu4, file='times_'//dumpfile//'.txt',position='append', status='old', action='write') + write(iu4, *) timeTau + close(iu4) + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + enddo + print*,'' + print*,'Total time of the calculation = ',totalTime,' seconds.' + + ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS + elseif (method == 3) then + open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') + close(iu4) + totalTime=0 + + do j = minOrder, maxOrder + write(jstring,'(i0)') j + print*,'' + print*, 'Start calculating optical depth outward: ', trim(jstring),', interpolation: ', trim(kstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') + write(iu4, *) timeTau + close(iu4) + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & + status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + enddo + print*,'' + print*,'Total time of the calculation = ',totalTime,' seconds.' + + ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS + elseif (method == 4) then + open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') + close(iu4) + totalTime=0 + + do j = minOrder, maxOrder + do k = 0, 6 + write(jstring,'(i0)') j + write(kstring,'(i0)') k + print*,'' + print*, 'Start calculating optical depth outward: ', trim(jstring),', interpolation: ', trim(kstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + times(k+1) = timeTau + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & + status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + enddo + open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') + write(iu4, *) times(1:7) + close(iu4) + enddo + print*,'' + print*,'Total time of the calculation = ',totalTime,' seconds.' + + !ADAPTIVE (OUTWARD) INTEGRATION ANALYSIS + elseif (method == 5) then + open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt', status='replace', action='write') + close(iu4) + totalTime=0 + + do j = minOrder, maxOrder + write(jstring,'(i0)') j + times = 0. + do k = minOrder,maxOrder-j + write(kstring,'(i0)') k + print*,'' + print*, 'Start calculating optical depth outward: minOrder = ', trim(jstring),', refineLevel = ', trim(kstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme,& + tau, primsec(1:3,2), Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + times(k-minOrder+1) = timeTau + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & + '_'//trim(kstring)//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + enddo + open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt',position='append', status='old', action='write') + write(iu4, *) times(1:maxOrder-minOrder+1) + close(iu4) + enddo + print*,'' + print*,'Total time of the calculation = ',totalTime,' seconds.' + + ! SCALING ANALYSIS + elseif (method == 6) then + order = 5 + print*,'Start doing scaling analysis with order =',order + open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt', status='replace', action='write') + close(iu4) + do i=1, omp_get_max_threads() + call omp_set_num_threads(i) + call deallocate_linklist + call allocate_linklist + call set_linklist(npart2,npart2,xyzh2,vxyzu) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'nthread = ',omp_get_max_threads(),': Time = ',timeTau,' seconds.' + open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt',position='append', status='old', action='write') + write(iu4, *) omp_get_max_threads(), timeTau + close(iu4) + enddo + + ! TIME ANALYSIS MULTIPLE FILES + elseif (method == 7) then + order = 5 + print*,'Start doing scaling analysis with order =',order + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu1, file='npart_wind.txt',position='append', action='write') + write(iu1, *) npart2 + close(iu1) + open(newunit=iu4, file='times_wind.txt',position='append', action='write') + write(iu4, *) timeTau + close(iu4) + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + endif + + elseif (analyses == 2) then + !ADAPTIVE (OUTWARD) INTEGRATION SCHEME + if (method == 1) then + print*,'' + print*, 'Start calculating optical depth inward' + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + if (SPH) then + open(newunit=iu2, file='taus_'//dumpfile//'_inwards.txt', status='replace', action='write') + else + open(newunit=iu2, file='taus_'//dumpfile//'_tess_inwards.txt', status='replace', action='write') + endif + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + elseif (method == 2) then + print*,'' + print*, 'Start calculating optical depth outward: ', trim(jstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, j, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, j, tau) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + elseif (method == 3) then + print*,'' + print*, 'Start calculating optical depth outward: ', trim(jstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + elseif (method == 4) then + print*,'' + print*, 'Start calculating optical depth adaptive: minOrder = ', trim(jstring),', refineLevel = ', trim(kstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & + '_'//trim(kstring)//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + endif + + elseif (analyses == 3) then + order = 5 + print*,'Start calculating optical depth' + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu4, file='taus_'//dumpfile//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu4, *) tau(i) + enddo + close(iu4) + + elseif (analyses == 4) then + do i=1,npart + if (norm2(xyzh2(1:3,i) - (/10.,10.,10./)) < 4.) then + kappa(i) = 1e10 + endif + enddo + ! allocate(neighb(npart2+2,100)) + ! neighb = 0 + ! open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + ! do i=1, npart2+2 + ! read(iu4,*) neighb(i,:) + ! enddo + ! close(iu4) + print*,'' + order = 7 + print*, 'Start calculating optical depth outward, order=',order + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_raypolation_7.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + + elseif (analyses == 5) then + open(newunit=iu1, file='points_'//dumpfile//'.txt', status='replace', action='write') + do i=1, npart2+2 + write(iu1, *) xyzh2(1:3,i) + enddo + close(iu1) + + open(newunit=iu3, file='rho_'//dumpfile//'.txt', status='replace', action='write') + do i=1,npart2 + rho(i) = rhoh(xyzh2(4,i), particlemass) + write(iu3, *) rho(i) + enddo + close(iu3) + endif + + end subroutine do_analysis + end module analysis diff --git a/src/utils/utils_raytracer_all.F90 b/src/utils/utils_raytracer_all.F90 index 26855bb9c..7b3d6bb2a 100644 --- a/src/utils/utils_raytracer_all.F90 +++ b/src/utils/utils_raytracer_all.F90 @@ -1,1199 +1,1199 @@ -!--------------------------------------------------------------------------! -! 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 raytracer_all -! -! raytracer_all -! -! :References: None -! -! :Owner: Lionel Siess -! -! :Runtime parameters: None -! -! :Dependencies: healpix, kernel, linklist, part, units -! - use healpix - implicit none - public :: get_all_tau_outwards, get_all_tau_inwards, get_all_tau_adaptive - private -contains - -!*********************************************************************! -!*************************** ADAPTIVE ****************************! -!*********************************************************************! - -!-------------------------------------------------------------------------- -!+ -! Calculate the optical depth of each particle, using the adaptive ray- -! tracing scheme -!+ -! IN: npart: The number of SPH particles -! IN: primary: The xyz coordinates of the primary star -! IN: xyzh: The array containing the particles position+smooting lenght -! IN: kappa: The array containing the kappa of all SPH particles -! IN: Rstar: The radius of the star -! IN: minOrder: The minimal order in which the rays are sampled -! IN: refineLevel: The amount of orders in which the rays can be -! sampled deeper -! IN: refineScheme: The refinement scheme used for adaptive ray selection -!+ -! OUT: taus: The list of optical depths for each particle -!+ -! OPT: companion: The xyz coordinates of the companion -! OPT: Rcomp: The radius of the companion -!+ -!-------------------------------------------------------------------------- -subroutine get_all_tau_adaptive(npart, primary, xyzh, kappa, Rstar, minOrder,& - refineLevel, refineScheme, taus, companion, Rcomp) - integer, intent(in) :: npart, minOrder, refineLevel, refineScheme - real, intent(in) :: primary(3), kappa(:), xyzh(:,:), Rstar - real, optional :: Rcomp, companion(3) - real, intent(out) :: taus(:) - - integer :: i, nrays, nsides, index - real :: normCompanion, theta0, unitCompanion(3), theta, root, dist, vec(3), dir(3) - real, dimension(:,:), allocatable :: dirs - real, dimension(:,:), allocatable :: listsOfDists, listsOfTaus - integer, dimension(:), allocatable :: indices, rays_dim - real, dimension(:), allocatable :: tau, dists - - if (present(companion) .and. present(Rcomp)) then - unitCompanion = companion-primary - normCompanion = norm2(unitCompanion) - theta0 = asin(Rcomp/normCompanion) - unitCompanion = unitCompanion/normCompanion - - call get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, dirs, indices, nrays) - allocate(listsOfDists(200, nrays)) - allocate(listsOfTaus(size(listsOfDists(:,1)), nrays)) - allocate(tau(size(listsOfDists(:,1)))) - allocate(dists(size(listsOfDists(:,1)))) - allocate(rays_dim(nrays)) - - !$omp parallel do private(tau,dist,dir,dists,root,theta) - do i = 1, nrays - tau=0. - dists=0. - dir = dirs(:,i) - theta = acos(dot_product(unitCompanion, dir)) - if (theta < theta0) then - root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) - dist = normCompanion*cos(theta)-root - call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i), dist) - else - call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i)) - endif - listsOfTaus(:,i) = tau - listsOfDists(:,i) = dists - enddo - !$omp end parallel do - - nsides = 2**(minOrder+refineLevel) - taus = 0. - !$omp parallel do private(index,vec) - do i = 1, npart - vec = xyzh(1:3,i)-primary - call vec2pix_nest(nsides, vec, index) - index = indices(index + 1) - call get_tau_on_ray(norm2(vec), listsOfTaus(:,index), listsOfDists(:,index), rays_dim(index), taus(i)) - enddo - !$omp end parallel do - - else - call get_all_tau_outwards_single(npart, primary, xyzh, kappa, & - Rstar, minOrder+refineLevel, 0, taus) - endif -end subroutine get_all_tau_adaptive - -!-------------------------------------------------------------------------- -!+ -! Return all the directions of the rays that need to be traced for the -! adaptive ray-tracing scheme -!+ -! IN: npart: The number of SPH particles -! IN: primary: The xyz coordinates of the primary star -! IN: companion: The xyz coordinates of the companion -! IN: Rcomp: The radius of the companion -! IN: xyzh: The array containing the particles position+smooting lenght -! IN: minOrder: The minimal order in which the rays are sampled -! IN: refineLevel: The amount of orders in which the rays can be -! sampled deeper -! IN: refineScheme: The refinement scheme used for adaptive ray selection -!+ -! OUT: rays: A list containing the rays that need to be traced -! in the adaptive ray-tracing scheme -! OUT: indices: A list containing a link between the index in the -! deepest order and the rays in the adaptive ray-tracing scheme -! OUT: nrays: The number of rays after the ray selection -!+ -!-------------------------------------------------------------------------- -subroutine get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, rays, indices, nrays) - integer, intent(in) :: npart, minOrder, refineLevel, refineScheme - real, intent(in) :: primary(3), companion(3), xyzh(:,:), Rcomp - real, allocatable, intent(out) :: rays(:,:) - integer, allocatable, intent(out) :: indices(:) - integer, intent(out) :: nrays - - real :: theta, dist, phi, cosphi, sinphi - real, dimension(:,:), allocatable :: circ - integer :: i, j, minNsides, minNrays, ind,n, maxOrder, max, distr(12*4**(minOrder+refineLevel)) - integer, dimension(:,:), allocatable :: distrs - - maxOrder = minOrder+refineLevel - nrays = 12*4**(maxOrder) - allocate(rays(3, nrays)) - allocate(indices(12*4**(maxOrder))) - rays = 0. - indices = 0 - - !If there is no refinement, just return the uniform ray distribution - minNsides = 2**minOrder - minNrays = 12*4**minOrder - if (refineLevel == 0) then - do i=1, minNrays - call pix2vec_nest(minNsides,i-1, rays(:,i)) - indices(i) = i - enddo - return - endif - - !Fill a list to have the number distribution in angular space - distr = 0 - !$omp parallel do private(ind) - do i = 1, npart - call vec2pix_nest(2**maxOrder, xyzh(1:3, i)-primary, ind) - distr(ind+1) = distr(ind+1)+1 - enddo - max = maxval(distr) - - !Make sure the companion is described using the highest refinement - dist = norm2(primary-companion) - theta = asin(Rcomp/dist) - phi = atan2(companion(2)-primary(2),companion(1)-primary(1)) - cosphi = cos(phi) - sinphi = sin(phi) - dist = dist*cos(theta) - n = int(theta*6*2**(minOrder+refineLevel))+4 - allocate(circ(n,3)) - do i=1, n !Define boundary of the companion - circ(i,1) = dist*cos(theta) - circ(i,2) = dist*sin(theta)*cos(twopi*i/n) - circ(i,3) = dist*sin(theta)*sin(twopi*i/n) - circ(i,:) = (/cosphi*circ(i,1) - sinphi*circ(i,2),sinphi*circ(i,1) + cosphi*circ(i,2), circ(i,3)/) - enddo - do i=1, n !Make sure the boundary is maximally refined - call vec2pix_nest(2**maxOrder,circ(i,:),ind) - distr(ind+1) = max - enddo - - !Calculate the number distribution in all the orders needed - allocate(distrs(12*4**(minOrder+refineLevel),refineLevel+1)) - distrs = 0 - distrs(:,1) = distr - do i = 1, refineLevel - do j = 1, 12*4**(maxOrder-i) - distrs(j,i+1) = distrs(4*j,i)+distrs(4*j+1,i)+distrs(4*j+2,i)+distrs(4*j+3,i) - enddo - enddo - max = maxval(distrs(:,refineLevel+1))+1 - - !Fill the rays array walking through the orders - ind=1 - - ! refine half in each order - if (refineScheme == 1) then - do i=0, refineLevel-1 - call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) - do j=1, 6*4**minOrder*2**(i) - call pix2vec_nest(2**(minOrder+i), distr(j)-1, rays(:,ind)) - indices(4**(refineLevel-i)*(distr(j)-1)+1:4**(refineLevel-i)*distr(j)) = ind - ind=ind+1 - distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max - enddo - do j = j+1, 12*4**(minOrder+i) - if (distrs(distr(j),refineLevel-i+1) == max) then - distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max - endif - enddo - enddo - - ! refine overdens regions in each order - elseif (refineScheme == 2) then - do i=0, refineLevel-1 - call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) - j=1 - do while (distrs(distr(j),refineLevel-i+1) 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 9 rays, linear interpolation - elseif (raypolation==2) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = norm2(vectemp) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,nneigh - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 4 rays, square interpolation - elseif (raypolation==3) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = dot_product(vectemp,vectemp) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = dot_product(vectemp,vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 9 rays, square interpolation - elseif (raypolation==4) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = dot_product(vectemp,vectemp) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = dot_product(vectemp,vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,nneigh - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 4 rays, cubed interpolation - elseif (raypolation==5) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = norm2(vectemp)**3 - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp)**3 - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 9 rays, cubed interpolation - elseif (raypolation==6) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = norm2(vectemp)**3 - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp)**3 - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,nneigh - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - endif -end subroutine interpolate_tau - - -!-------------------------------------------------------------------------- -!+ -! Interpolation of the optical depth for an arbitrary point on the ray, -! with a given distance to the starting point of the ray. -!+ -! IN: distance: The distance from the staring point of the ray to a -! point on the ray -! IN: tau_along_ray: The vector of cumulative optical depths along the ray -! IN: dist_along_ray: The vector of distances from the primary along the ray -! IN: len: The length of listOfTau and listOfDist -!+ -! OUT: tau: The optical depth to the given distance along the ray -!+ -!-------------------------------------------------------------------------- -subroutine get_tau_on_ray(distance, tau_along_ray, dist_along_ray, len, tau) - real, intent(in) :: distance, tau_along_ray(:), dist_along_ray(:) - integer, intent(in) :: len - real, intent(out) :: tau - - integer :: L, R, m ! left, right and middle index for binary search - - if (distance < dist_along_ray(1)) then - tau = 0. - elseif (distance > dist_along_ray(len)) then - tau = 99. - else - L = 2 - R = len-1 - !bysection search for the index of the closest ray location to the particle - do while (L < R) - m = (L + R)/2 - if (dist_along_ray(m) > distance) then - R = m - else - L = m + 1 - endif - enddo - !interpolate linearly ray properties to get the particle's optical depth - tau = tau_along_ray(L-1)+(tau_along_ray(L)-tau_along_ray(L-1))/ & - (dist_along_ray(L)-dist_along_ray(L-1))*(distance-dist_along_ray(L-1)) - endif -end subroutine get_tau_on_ray - -!-------------------------------------------------------------------------- -!+ -! Calculate the optical depth along a given ray -!+ -! IN: primary: The location of the primary star -! IN: ray: The unit vector of the direction in which the -! optical depts will be calculated -! IN: xyzh: The array containing the particles position+smooting lenght -! IN: kappa: The array containing the particles opacity -! IN: Rstar: The radius of the primary star -!+ -! OUT: taus: The distribution of optical depths throughout the ray -! OUT: listOfDists: The distribution of distances throughout the ray -! OUT: len: The length of tau_along_ray and dist_along_ray -!+ -! OPT: maxDistance: The maximal distance the ray needs to be traced -!+ -!-------------------------------------------------------------------------- -subroutine ray_tracer(primary, ray, xyzh, kappa, Rstar, tau_along_ray, dist_along_ray, len, maxDistance) - use linklist, only:getneigh_pos,ifirstincell,listneigh - use kernel, only:radkern - use units, only:umass,udist - real, intent(in) :: primary(3), ray(3), Rstar, xyzh(:,:), kappa(:) - real, optional :: maxDistance - real, intent(out) :: dist_along_ray(:), tau_along_ray(:) - integer, intent(out) :: len - - integer, parameter :: maxcache = 0 - real, allocatable :: xyzcache(:,:) - real :: distance, h, dtaudr, previousdtaudr, nextdtaudr - integer :: nneigh, inext, i - - distance = Rstar - - h = Rstar/100. - inext=0 - do while (inext==0) - h = h*2. - call getneigh_pos(primary+Rstar*ray,0.,h,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) - call find_next(primary, ray, distance, xyzh, listneigh, inext, nneigh) - enddo - call calc_opacity(primary+Rstar*ray, xyzh, kappa, listneigh, nneigh, previousdtaudr) - - i = 1 - tau_along_ray(i) = 0. - distance = Rstar - dist_along_ray(i) = distance - do while (hasNext(inext,tau_along_ray(i),distance,maxDistance)) - i = i + 1 - call getneigh_pos(primary + distance*ray,0.,xyzh(4,inext)*radkern, & - 3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) - call calc_opacity(primary + distance*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) - dtaudr = (nextdtaudr+previousdtaudr)/2 - previousdtaudr = nextdtaudr - tau_along_ray(i) = tau_along_ray(i-1)+(distance-dist_along_ray(i-1))*dtaudr - dist_along_ray(i) = distance - call find_next(primary, ray, distance, xyzh, listneigh, inext,nneigh) - enddo - len = i - tau_along_ray = tau_along_ray*umass/(udist**2) -end subroutine ray_tracer - -logical function hasNext(inext, tau, distance, maxDistance) - integer, intent(in) :: inext - real, intent(in) :: distance, tau - real, optional :: maxDistance - real, parameter :: tau_max = 99. - if (present(maxDistance)) then - hasNext = inext /= 0 .and. distance < maxDistance .and. tau < tau_max - else - hasNext = inext /= 0 .and. tau < tau_max - endif -end function hasNext - -!*********************************************************************! -!**************************** INWARDS ****************************! -!*********************************************************************! - -!-------------------------------------------------------------------------- -!+ -! Calculate the optical depth of each particle, using the inwards ray- -! tracing scheme -!+ -! IN: npart: The number of SPH particles -! IN: primary: The xyz coordinates of the primary star -! IN: xyzh: The array containing the particles position+smooting lenght -! IN: neighbors: A list containing the indices of the neighbors of -! each particle -! IN: kappa: The array containing the opacity of all the SPH particles -! IN: Rstar: The radius of the primary star -!+ -! OUT: tau: The array of optical depths for each SPH particle -!+ -! OPT: companion: The location of the companion -! OPT: R: The radius of the companion -!+ -!-------------------------------------------------------------------------- -subroutine get_all_tau_inwards(npart, primary, xyzh, neighbors, kappa, Rstar, tau, companion, R) - real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) - integer, intent(in) :: npart, neighbors(:,:) - real, optional :: R, companion(3) - real, intent(out) :: tau(:) - - if (present(companion) .and. present(R)) then - call get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, R, tau) - else - call get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) - endif -end subroutine get_all_tau_inwards - -!-------------------------------------------------------------------------- -!+ -! Calculate the optical depth of each particle, using the inwards ray- -! tracing scheme concerning only a single star -!+ -! IN: npart: The number of SPH particles -! IN: primary: The xyz coordinates of the primary star -! IN: xyzh: The array containing the particles position+smooting lenght -! IN: neighbors: A list containing the indices of the neighbors of -! each particle -! IN: kappa: The array containing the opacity of all the SPH particles -! IN: Rstar: The radius of the primary star -!+ -! OUT: taus: The list of optical depths for each particle -!+ -!-------------------------------------------------------------------------- -subroutine get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) - real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) - integer, intent(in) :: npart, neighbors(:,:) - real, intent(out) :: tau(:) - - integer :: i - - !$omp parallel do - do i = 1, npart - call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) - enddo - !$omp end parallel do -end subroutine get_all_tau_inwards_single - -!-------------------------------------------------------------------------- -!+ -! Calculate the optical depth of each particle, using the inwards ray- -! tracing scheme concerning a binary system -!+ -! IN: npart: The number of SPH particles -! IN: primary: The xyz coordinates of the primary star -! IN: xyzh: The array containing the particles position+smooting lenght -! IN: neighbors: A list containing the indices of the neighbors of -! each particle -! IN: kappa: The array containing the opacity of all the SPH particles -! IN: Rstar: The radius of the primary star -! IN: companion: The xyz coordinates of the companion -! IN: Rcomp: The radius of the companion -!+ -! OUT: tau: The array of optical depths for each SPH particle -!+ -!-------------------------------------------------------------------------- -subroutine get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, Rcomp, tau) - real, intent(in) :: primary(3), companion(3), kappa(:), Rstar, xyzh(:,:), Rcomp - integer, intent(in) :: npart, neighbors(:,:) - real, intent(out) :: tau(:) - - integer :: i - real :: normCompanion, theta0, uvecCompanion(3), norm, theta, root, norm0 - - uvecCompanion = companion-primary - normCompanion = norm2(uvecCompanion) - uvecCompanion = uvecCompanion/normCompanion - theta0 = asin(Rcomp/normCompanion) - - !$omp parallel do private(norm,theta,root,norm0) - do i = 1, npart - norm = norm2(xyzh(1:3,i)-primary) - theta = acos(dot_product(uvecCompanion, xyzh(1:3,i)-primary)/norm) - if (theta < theta0) then - root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) - norm0 = normCompanion*cos(theta)-root - if (norm > norm0) then - tau(i) = 99. - else - call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) - endif - else - call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) - endif - enddo - !$omp end parallel do -end subroutine get_all_tau_inwards_companion - -!-------------------------------------------------------------------------- -!+ -! Calculate the optical depth for a given particle, using the inwards ray- -! tracing scheme -!+ -! IN: point: The index of the point that needs to be calculated -! IN: primary: The location of the primary star -! IN: xyzh: The array containing the particles position+smooting lenght -! IN: neighbors: A list containing the indices of the neighbors of -! each particle -! IN: kappa: The array containing the opacity of all the SPH particles -! IN: Rstar: The radius of the star -!+ -! OUT: tau: The list of optical depth of the given particle -!+ -!-------------------------------------------------------------------------- -subroutine get_tau_inwards(point, primary, xyzh, neighbors, kappa, Rstar, tau) - use linklist, only:getneigh_pos,ifirstincell,listneigh - use kernel, only:radkern - use units, only:umass,udist - real, intent(in) :: primary(3), xyzh(:,:), kappa(:), Rstar - integer, intent(in) :: point, neighbors(:,:) - real, intent(out) :: tau - - integer :: i, next, previous, nneigh - integer, parameter :: nmaxcache = 0 - real :: xyzcache(0,nmaxcache) - real :: ray(3), nextDist, previousDist, maxDist, dtaudr, previousdtaudr, nextdtaudr - - ray = primary - xyzh(1:3,point) - maxDist = norm2(ray) - ray = ray / maxDist - maxDist=max(maxDist-Rstar,0.) - next=point - call getneigh_pos(xyzh(1:3,point),0.,xyzh(4,point)*radkern, & - 3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) - call calc_opacity(xyzh(1:3,point), xyzh, kappa, listneigh, nneigh, nextdtaudr) - nextDist=0. - - tau = 0. - i=1 - do while (nextDist < maxDist .and. next /=0) - i = i + 1 - previous = next - previousDist = nextDist - call find_next(xyzh(1:3,point), ray, nextDist, xyzh, neighbors(next,:), next) - if (nextDist > maxDist) then - nextDist = maxDist - endif - call getneigh_pos(xyzh(1:3,point) + nextDist*ray,0.,xyzh(4,previous)*radkern, & + !--------------------------------------------------------------------------! + ! 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 raytracer_all + ! + ! raytracer_all + ! + ! :References: None + ! + ! :Owner: Lionel Siess + ! + ! :Runtime parameters: None + ! + ! :Dependencies: healpix, kernel, linklist, part, units + ! + use healpix + implicit none + public :: get_all_tau_outwards, get_all_tau_inwards, get_all_tau_adaptive + private + contains + + !*********************************************************************! + !*************************** ADAPTIVE ****************************! + !*********************************************************************! + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the adaptive ray- + ! tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa: The array containing the kappa of all SPH particles + ! IN: Rstar: The radius of the star + ! IN: minOrder: The minimal order in which the rays are sampled + ! IN: refineLevel: The amount of orders in which the rays can be + ! sampled deeper + ! IN: refineScheme: The refinement scheme used for adaptive ray selection + !+ + ! OUT: taus: The list of optical depths for each particle + !+ + ! OPT: companion: The xyz coordinates of the companion + ! OPT: Rcomp: The radius of the companion + !+ + !-------------------------------------------------------------------------- + subroutine get_all_tau_adaptive(npart, primary, xyzh, kappa, Rstar, minOrder,& + refineLevel, refineScheme, taus, companion, Rcomp) + integer, intent(in) :: npart, minOrder, refineLevel, refineScheme + real, intent(in) :: primary(3), kappa(:), xyzh(:,:), Rstar + real, optional :: Rcomp, companion(3) + real, intent(out) :: taus(:) + + integer :: i, nrays, nsides, index + real :: normCompanion, theta0, unitCompanion(3), theta, root, dist, vec(3), dir(3) + real, dimension(:,:), allocatable :: dirs + real, dimension(:,:), allocatable :: listsOfDists, listsOfTaus + integer, dimension(:), allocatable :: indices, rays_dim + real, dimension(:), allocatable :: tau, dists + + if (present(companion) .and. present(Rcomp)) then + unitCompanion = companion-primary + normCompanion = norm2(unitCompanion) + theta0 = asin(Rcomp/normCompanion) + unitCompanion = unitCompanion/normCompanion + + call get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, dirs, indices, nrays) + allocate(listsOfDists(200, nrays)) + allocate(listsOfTaus(size(listsOfDists(:,1)), nrays)) + allocate(tau(size(listsOfDists(:,1)))) + allocate(dists(size(listsOfDists(:,1)))) + allocate(rays_dim(nrays)) + + !$omp parallel do private(tau,dist,dir,dists,root,theta) + do i = 1, nrays + tau=0. + dists=0. + dir = dirs(:,i) + theta = acos(dot_product(unitCompanion, dir)) + if (theta < theta0) then + root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) + dist = normCompanion*cos(theta)-root + call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i), dist) + else + call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i)) + endif + listsOfTaus(:,i) = tau + listsOfDists(:,i) = dists + enddo + !$omp end parallel do + + nsides = 2**(minOrder+refineLevel) + taus = 0. + !$omp parallel do private(index,vec) + do i = 1, npart + vec = xyzh(1:3,i)-primary + call vec2pix_nest(nsides, vec, index) + index = indices(index + 1) + call get_tau_on_ray(norm2(vec), listsOfTaus(:,index), listsOfDists(:,index), rays_dim(index), taus(i)) + enddo + !$omp end parallel do + + else + call get_all_tau_outwards_single(npart, primary, xyzh, kappa, & + Rstar, minOrder+refineLevel, 0, taus) + endif + end subroutine get_all_tau_adaptive + + !-------------------------------------------------------------------------- + !+ + ! Return all the directions of the rays that need to be traced for the + ! adaptive ray-tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: companion: The xyz coordinates of the companion + ! IN: Rcomp: The radius of the companion + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: minOrder: The minimal order in which the rays are sampled + ! IN: refineLevel: The amount of orders in which the rays can be + ! sampled deeper + ! IN: refineScheme: The refinement scheme used for adaptive ray selection + !+ + ! OUT: rays: A list containing the rays that need to be traced + ! in the adaptive ray-tracing scheme + ! OUT: indices: A list containing a link between the index in the + ! deepest order and the rays in the adaptive ray-tracing scheme + ! OUT: nrays: The number of rays after the ray selection + !+ + !-------------------------------------------------------------------------- + subroutine get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, rays, indices, nrays) + integer, intent(in) :: npart, minOrder, refineLevel, refineScheme + real, intent(in) :: primary(3), companion(3), xyzh(:,:), Rcomp + real, allocatable, intent(out) :: rays(:,:) + integer, allocatable, intent(out) :: indices(:) + integer, intent(out) :: nrays + + real :: theta, dist, phi, cosphi, sinphi + real, dimension(:,:), allocatable :: circ + integer :: i, j, minNsides, minNrays, ind,n, maxOrder, max, distr(12*4**(minOrder+refineLevel)) + integer, dimension(:,:), allocatable :: distrs + + maxOrder = minOrder+refineLevel + nrays = 12*4**(maxOrder) + allocate(rays(3, nrays)) + allocate(indices(12*4**(maxOrder))) + rays = 0. + indices = 0 + + !If there is no refinement, just return the uniform ray distribution + minNsides = 2**minOrder + minNrays = 12*4**minOrder + if (refineLevel == 0) then + do i=1, minNrays + call pix2vec_nest(minNsides,i-1, rays(:,i)) + indices(i) = i + enddo + return + endif + + !Fill a list to have the number distribution in angular space + distr = 0 + !$omp parallel do private(ind) + do i = 1, npart + call vec2pix_nest(2**maxOrder, xyzh(1:3, i)-primary, ind) + distr(ind+1) = distr(ind+1)+1 + enddo + max = maxval(distr) + + !Make sure the companion is described using the highest refinement + dist = norm2(primary-companion) + theta = asin(Rcomp/dist) + phi = atan2(companion(2)-primary(2),companion(1)-primary(1)) + cosphi = cos(phi) + sinphi = sin(phi) + dist = dist*cos(theta) + n = int(theta*6*2**(minOrder+refineLevel))+4 + allocate(circ(n,3)) + do i=1, n !Define boundary of the companion + circ(i,1) = dist*cos(theta) + circ(i,2) = dist*sin(theta)*cos(twopi*i/n) + circ(i,3) = dist*sin(theta)*sin(twopi*i/n) + circ(i,:) = (/cosphi*circ(i,1) - sinphi*circ(i,2),sinphi*circ(i,1) + cosphi*circ(i,2), circ(i,3)/) + enddo + do i=1, n !Make sure the boundary is maximally refined + call vec2pix_nest(2**maxOrder,circ(i,:),ind) + distr(ind+1) = max + enddo + + !Calculate the number distribution in all the orders needed + allocate(distrs(12*4**(minOrder+refineLevel),refineLevel+1)) + distrs = 0 + distrs(:,1) = distr + do i = 1, refineLevel + do j = 1, 12*4**(maxOrder-i) + distrs(j,i+1) = distrs(4*j,i)+distrs(4*j+1,i)+distrs(4*j+2,i)+distrs(4*j+3,i) + enddo + enddo + max = maxval(distrs(:,refineLevel+1))+1 + + !Fill the rays array walking through the orders + ind=1 + + ! refine half in each order + if (refineScheme == 1) then + do i=0, refineLevel-1 + call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) + do j=1, 6*4**minOrder*2**(i) + call pix2vec_nest(2**(minOrder+i), distr(j)-1, rays(:,ind)) + indices(4**(refineLevel-i)*(distr(j)-1)+1:4**(refineLevel-i)*distr(j)) = ind + ind=ind+1 + distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max + enddo + do j = j+1, 12*4**(minOrder+i) + if (distrs(distr(j),refineLevel-i+1) == max) then + distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max + endif + enddo + enddo + + ! refine overdens regions in each order + elseif (refineScheme == 2) then + do i=0, refineLevel-1 + call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) + j=1 + do while (distrs(distr(j),refineLevel-i+1) 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 9 rays, linear interpolation + elseif (raypolation==2) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = norm2(vectemp) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,nneigh + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 4 rays, square interpolation + elseif (raypolation==3) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = dot_product(vectemp,vectemp) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = dot_product(vectemp,vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 9 rays, square interpolation + elseif (raypolation==4) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = dot_product(vectemp,vectemp) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = dot_product(vectemp,vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,nneigh + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 4 rays, cubed interpolation + elseif (raypolation==5) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = norm2(vectemp)**3 + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp)**3 + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 9 rays, cubed interpolation + elseif (raypolation==6) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = norm2(vectemp)**3 + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp)**3 + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,nneigh + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + endif + end subroutine interpolate_tau + + + !-------------------------------------------------------------------------- + !+ + ! Interpolation of the optical depth for an arbitrary point on the ray, + ! with a given distance to the starting point of the ray. + !+ + ! IN: distance: The distance from the staring point of the ray to a + ! point on the ray + ! IN: tau_along_ray: The vector of cumulative optical depths along the ray + ! IN: dist_along_ray: The vector of distances from the primary along the ray + ! IN: len: The length of listOfTau and listOfDist + !+ + ! OUT: tau: The optical depth to the given distance along the ray + !+ + !-------------------------------------------------------------------------- + subroutine get_tau_on_ray(distance, tau_along_ray, dist_along_ray, len, tau) + real, intent(in) :: distance, tau_along_ray(:), dist_along_ray(:) + integer, intent(in) :: len + real, intent(out) :: tau + + integer :: L, R, m ! left, right and middle index for binary search + + if (distance < dist_along_ray(1)) then + tau = 0. + elseif (distance > dist_along_ray(len)) then + tau = 99. + else + L = 2 + R = len-1 + !bysection search for the index of the closest ray location to the particle + do while (L < R) + m = (L + R)/2 + if (dist_along_ray(m) > distance) then + R = m + else + L = m + 1 + endif + enddo + !interpolate linearly ray properties to get the particle's optical depth + tau = tau_along_ray(L-1)+(tau_along_ray(L)-tau_along_ray(L-1))/ & + (dist_along_ray(L)-dist_along_ray(L-1))*(distance-dist_along_ray(L-1)) + endif + end subroutine get_tau_on_ray + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth along a given ray + !+ + ! IN: primary: The location of the primary star + ! IN: ray: The unit vector of the direction in which the + ! optical depts will be calculated + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa: The array containing the particles opacity + ! IN: Rstar: The radius of the primary star + !+ + ! OUT: taus: The distribution of optical depths throughout the ray + ! OUT: listOfDists: The distribution of distances throughout the ray + ! OUT: len: The length of tau_along_ray and dist_along_ray + !+ + ! OPT: maxDistance: The maximal distance the ray needs to be traced + !+ + !-------------------------------------------------------------------------- + subroutine ray_tracer(primary, ray, xyzh, kappa, Rstar, tau_along_ray, dist_along_ray, len, maxDistance) + use linklist, only:getneigh_pos,ifirstincell,listneigh + use kernel, only:radkern + use units, only:umass,udist + real, intent(in) :: primary(3), ray(3), Rstar, xyzh(:,:), kappa(:) + real, optional :: maxDistance + real, intent(out) :: dist_along_ray(:), tau_along_ray(:) + integer, intent(out) :: len + + integer, parameter :: maxcache = 0 + real, allocatable :: xyzcache(:,:) + real :: distance, h, dtaudr, previousdtaudr, nextdtaudr + integer :: nneigh, inext, i + + distance = Rstar + + h = Rstar/100. + inext=0 + do while (inext==0) + h = h*2. + call getneigh_pos(primary+Rstar*ray,0.,h,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) + call find_next(primary, ray, distance, xyzh, listneigh, inext, nneigh) + enddo + call calc_opacity(primary+Rstar*ray, xyzh, kappa, listneigh, nneigh, previousdtaudr) + + i = 1 + tau_along_ray(i) = 0. + distance = Rstar + dist_along_ray(i) = distance + do while (hasNext(inext,tau_along_ray(i),distance,maxDistance)) + i = i + 1 + call getneigh_pos(primary + distance*ray,0.,xyzh(4,inext)*radkern, & + 3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) + call calc_opacity(primary + distance*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) + dtaudr = (nextdtaudr+previousdtaudr)/2 + previousdtaudr = nextdtaudr + tau_along_ray(i) = tau_along_ray(i-1)+(distance-dist_along_ray(i-1))*dtaudr + dist_along_ray(i) = distance + call find_next(primary, ray, distance, xyzh, listneigh, inext,nneigh) + enddo + len = i + tau_along_ray = tau_along_ray*umass/(udist**2) + end subroutine ray_tracer + + logical function hasNext(inext, tau, distance, maxDistance) + integer, intent(in) :: inext + real, intent(in) :: distance, tau + real, optional :: maxDistance + real, parameter :: tau_max = 99. + if (present(maxDistance)) then + hasNext = inext /= 0 .and. distance < maxDistance .and. tau < tau_max + else + hasNext = inext /= 0 .and. tau < tau_max + endif + end function hasNext + + !*********************************************************************! + !**************************** INWARDS ****************************! + !*********************************************************************! + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the inwards ray- + ! tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + !+ + ! OUT: tau: The array of optical depths for each SPH particle + !+ + ! OPT: companion: The location of the companion + ! OPT: R: The radius of the companion + !+ + !-------------------------------------------------------------------------- + subroutine get_all_tau_inwards(npart, primary, xyzh, neighbors, kappa, Rstar, tau, companion, R) + real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) + integer, intent(in) :: npart, neighbors(:,:) + real, optional :: R, companion(3) + real, intent(out) :: tau(:) + + if (present(companion) .and. present(R)) then + call get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, R, tau) + else + call get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) + endif + end subroutine get_all_tau_inwards + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the inwards ray- + ! tracing scheme concerning only a single star + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + !+ + ! OUT: taus: The list of optical depths for each particle + !+ + !-------------------------------------------------------------------------- + subroutine get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) + real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) + integer, intent(in) :: npart, neighbors(:,:) + real, intent(out) :: tau(:) + + integer :: i + + !$omp parallel do + do i = 1, npart + call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) + enddo + !$omp end parallel do + end subroutine get_all_tau_inwards_single + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the inwards ray- + ! tracing scheme concerning a binary system + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + ! IN: companion: The xyz coordinates of the companion + ! IN: Rcomp: The radius of the companion + !+ + ! OUT: tau: The array of optical depths for each SPH particle + !+ + !-------------------------------------------------------------------------- + subroutine get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, Rcomp, tau) + real, intent(in) :: primary(3), companion(3), kappa(:), Rstar, xyzh(:,:), Rcomp + integer, intent(in) :: npart, neighbors(:,:) + real, intent(out) :: tau(:) + + integer :: i + real :: normCompanion, theta0, uvecCompanion(3), norm, theta, root, norm0 + + uvecCompanion = companion-primary + normCompanion = norm2(uvecCompanion) + uvecCompanion = uvecCompanion/normCompanion + theta0 = asin(Rcomp/normCompanion) + + !$omp parallel do private(norm,theta,root,norm0) + do i = 1, npart + norm = norm2(xyzh(1:3,i)-primary) + theta = acos(dot_product(uvecCompanion, xyzh(1:3,i)-primary)/norm) + if (theta < theta0) then + root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) + norm0 = normCompanion*cos(theta)-root + if (norm > norm0) then + tau(i) = 99. + else + call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) + endif + else + call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) + endif + enddo + !$omp end parallel do + end subroutine get_all_tau_inwards_companion + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth for a given particle, using the inwards ray- + ! tracing scheme + !+ + ! IN: point: The index of the point that needs to be calculated + ! IN: primary: The location of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the star + !+ + ! OUT: tau: The list of optical depth of the given particle + !+ + !-------------------------------------------------------------------------- + subroutine get_tau_inwards(point, primary, xyzh, neighbors, kappa, Rstar, tau) + use linklist, only:getneigh_pos,ifirstincell,listneigh + use kernel, only:radkern + use units, only:umass,udist + real, intent(in) :: primary(3), xyzh(:,:), kappa(:), Rstar + integer, intent(in) :: point, neighbors(:,:) + real, intent(out) :: tau + + integer :: i, next, previous, nneigh + integer, parameter :: nmaxcache = 0 + real :: xyzcache(0,nmaxcache) + real :: ray(3), nextDist, previousDist, maxDist, dtaudr, previousdtaudr, nextdtaudr + + ray = primary - xyzh(1:3,point) + maxDist = norm2(ray) + ray = ray / maxDist + maxDist=max(maxDist-Rstar,0.) + next=point + call getneigh_pos(xyzh(1:3,point),0.,xyzh(4,point)*radkern, & 3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) - previousdtaudr=nextdtaudr - call calc_opacity(xyzh(1:3,point) + nextDist*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) - dtaudr = (nextdtaudr+previousdtaudr)/2 - tau = tau + (nextDist-previousDist)*dtaudr - enddo - !fix units for tau (kappa is in cgs while rho & r are in code units) - tau = tau*umass/(udist**2) -end subroutine get_tau_inwards - -!*********************************************************************! -!**************************** COMMON *****************************! -!*********************************************************************! - -!-------------------------------------------------------------------------- -!+ -! Find the next point on a ray -!+ -! IN: inpoint: The coordinate of the initial point projected on the -! ray for which the next point will be calculated -! IN: ray: The unit vector of the direction in which the next -! point will be calculated -! IN: xyzh: The array containing the particles position+smoothing length -! IN: neighbors: A list containing the indices of the neighbors of -! the initial point -! IN: inext: The index of the initial point -! (this point will not be considered as possible next point) -!+ -! OPT: nneighin: The amount of neighbors -!+ -! OUT: inext: The index of the next point on the ray -!+ -!-------------------------------------------------------------------------- -subroutine find_next(inpoint, ray, dist, xyzh, neighbors, inext, nneighin) - integer, intent(in) :: neighbors(:) - real, intent(in) :: xyzh(:,:), inpoint(:), ray(:) - integer, intent(inout) :: inext - real, intent(inout) :: dist - integer, optional :: nneighin - - real :: trace_point(3), dmin, vec(3), tempdist, raydist - real :: nextdist - integer :: i, nneigh, prev - - dmin = huge(0.) - if (present(nneighin)) then - nneigh = nneighin - else - nneigh = size(neighbors) - endif - - prev=inext - inext=0 - nextDist=dist - trace_point = inpoint + dist*ray - - i = 1 - do while (i <= nneigh .and. neighbors(i) /= 0) - if (neighbors(i) /= prev) then - vec=xyzh(1:3,neighbors(i)) - trace_point - tempdist = dot_product(vec,ray) - if (tempdist>0.) then - raydist = dot_product(vec,vec) - tempdist**2 - if (raydist < dmin) then - dmin = raydist - inext = neighbors(i) - nextdist = dist+tempdist - endif - endif - endif - i = i+1 - enddo - dist=nextdist -end subroutine find_next - -!-------------------------------------------------------------------------- -!+ -! Calculate the opacity in a given location -!+ -! IN: r0: The location where the opacity will be calculated -! IN: xyzh: The xyzh of all the particles -! IN: opacities: The list of the opacities of the particles -! IN: neighbors: A list containing the indices of the neighbors of -! the initial point -! IN: nneigh: The amount of neighbors -!+ -! OUT: dtaudr: The local optical depth derivative at the given location (inpoint) -!+ -!-------------------------------------------------------------------------- -subroutine calc_opacity(r0, xyzh, opacities, neighbors, nneigh, dtaudr) - use kernel, only:cnormk,wkern - use part, only:hfact,rhoh,massoftype,igas - real, intent(in) :: r0(:), xyzh(:,:), opacities(:) - integer, intent(in) :: neighbors(:), nneigh - real, intent(out) :: dtaudr - - integer :: i - real :: q - - dtaudr=0 - do i=1,nneigh - q = norm2(r0 - xyzh(1:3,neighbors(i)))/xyzh(4,neighbors(i)) - dtaudr=dtaudr+wkern(q*q,q)*opacities(neighbors(i))*rhoh(xyzh(4,neighbors(i)), massoftype(igas)) - enddo - dtaudr = dtaudr*cnormk/hfact**3 -end subroutine calc_opacity -end module raytracer_all + call calc_opacity(xyzh(1:3,point), xyzh, kappa, listneigh, nneigh, nextdtaudr) + nextDist=0. + + tau = 0. + i=1 + do while (nextDist < maxDist .and. next /=0) + i = i + 1 + previous = next + previousDist = nextDist + call find_next(xyzh(1:3,point), ray, nextDist, xyzh, neighbors(next,:), next) + if (nextDist > maxDist) then + nextDist = maxDist + endif + call getneigh_pos(xyzh(1:3,point) + nextDist*ray,0.,xyzh(4,previous)*radkern, & + 3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) + previousdtaudr=nextdtaudr + call calc_opacity(xyzh(1:3,point) + nextDist*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) + dtaudr = (nextdtaudr+previousdtaudr)/2 + tau = tau + (nextDist-previousDist)*dtaudr + enddo + !fix units for tau (kappa is in cgs while rho & r are in code units) + tau = tau*umass/(udist**2) + end subroutine get_tau_inwards + + !*********************************************************************! + !**************************** COMMON *****************************! + !*********************************************************************! + + !-------------------------------------------------------------------------- + !+ + ! Find the next point on a ray + !+ + ! IN: inpoint: The coordinate of the initial point projected on the + ! ray for which the next point will be calculated + ! IN: ray: The unit vector of the direction in which the next + ! point will be calculated + ! IN: xyzh: The array containing the particles position+smoothing length + ! IN: neighbors: A list containing the indices of the neighbors of + ! the initial point + ! IN: inext: The index of the initial point + ! (this point will not be considered as possible next point) + !+ + ! OPT: nneighin: The amount of neighbors + !+ + ! OUT: inext: The index of the next point on the ray + !+ + !-------------------------------------------------------------------------- + subroutine find_next(inpoint, ray, dist, xyzh, neighbors, inext, nneighin) + integer, intent(in) :: neighbors(:) + real, intent(in) :: xyzh(:,:), inpoint(:), ray(:) + integer, intent(inout) :: inext + real, intent(inout) :: dist + integer, optional :: nneighin + + real :: trace_point(3), dmin, vec(3), tempdist, raydist + real :: nextdist + integer :: i, nneigh, prev + + dmin = huge(0.) + if (present(nneighin)) then + nneigh = nneighin + else + nneigh = size(neighbors) + endif + + prev=inext + inext=0 + nextDist=dist + trace_point = inpoint + dist*ray + + i = 1 + do while (i <= nneigh .and. neighbors(i) /= 0) + if (neighbors(i) /= prev) then + vec=xyzh(1:3,neighbors(i)) - trace_point + tempdist = dot_product(vec,ray) + if (tempdist>0.) then + raydist = dot_product(vec,vec) - tempdist**2 + if (raydist < dmin) then + dmin = raydist + inext = neighbors(i) + nextdist = dist+tempdist + endif + endif + endif + i = i+1 + enddo + dist=nextdist + end subroutine find_next + + !-------------------------------------------------------------------------- + !+ + ! Calculate the opacity in a given location + !+ + ! IN: r0: The location where the opacity will be calculated + ! IN: xyzh: The xyzh of all the particles + ! IN: opacities: The list of the opacities of the particles + ! IN: neighbors: A list containing the indices of the neighbors of + ! the initial point + ! IN: nneigh: The amount of neighbors + !+ + ! OUT: dtaudr: The local optical depth derivative at the given location (inpoint) + !+ + !-------------------------------------------------------------------------- + subroutine calc_opacity(r0, xyzh, opacities, neighbors, nneigh, dtaudr) + use kernel, only:cnormk,wkern + use part, only:hfact,rhoh,massoftype,igas + real, intent(in) :: r0(:), xyzh(:,:), opacities(:) + integer, intent(in) :: neighbors(:), nneigh + real, intent(out) :: dtaudr + + integer :: i + real :: q + + dtaudr=0 + do i=1,nneigh + q = norm2(r0 - xyzh(1:3,neighbors(i)))/xyzh(4,neighbors(i)) + dtaudr=dtaudr+wkern(q*q,q)*opacities(neighbors(i))*rhoh(xyzh(4,neighbors(i)), massoftype(igas)) + enddo + dtaudr = dtaudr*cnormk/hfact**3 + end subroutine calc_opacity + end module raytracer_all From 6d7d0b288f6eaa36fe963b69edf85db5f4fdc299 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Thu, 30 Mar 2023 17:41:54 +0200 Subject: [PATCH 021/814] Update file ownership via bots.sh --- src/main/utils_healpix.f90 | 2321 ++++++++++++++-------------- src/main/utils_raytracer.f90 | 6 +- src/utils/analysis_raytracer.f90 | 1356 ++++++++-------- src/utils/utils_raytracer_all.F90 | 2374 ++++++++++++++--------------- 4 files changed, 3030 insertions(+), 3027 deletions(-) diff --git a/src/main/utils_healpix.f90 b/src/main/utils_healpix.f90 index 65e20bcab..514a38ab4 100644 --- a/src/main/utils_healpix.f90 +++ b/src/main/utils_healpix.f90 @@ -1,1161 +1,1160 @@ - !--------------------------------------------------------------------------! - ! 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 healpix - ! - ! This module sets the types used in the Fortran 90 modules (healpix_types.f90) - ! of the HEALPIX distribution and follows the example of Numerical Recipes - ! - ! Benjamin D. Wandelt October 1997 - ! Eric Hivon June 1998 - ! Eric Hivon Oct 2001, edited to be compatible with 'F' compiler - ! Eric Hivon July 2002, addition of i8b, i2b, i1b - ! addition of max_i8b, max_i2b and max_i1b - ! Jan 2005, explicit form of max_i1b because of ifc 8.1.021 - ! June 2005, redefine i8b as 16 digit integer because of Nec f90 compiler - ! Mars 2008: i8b same as i4b on machines not supporting 64 bits (NO64BITS flag set) - ! Feb 2009: introduce healpix_version - ! - ! :References: None - ! - ! :Owner: Lionel Siess - ! - ! :Runtime parameters: None - ! - ! :Dependencies: None - ! - implicit none - character(len=*), parameter, public :: healpix_version = '3.80' - integer, parameter, public :: i4b = selected_int_kind(9) - integer, parameter, public :: i8b = selected_int_kind(16) - integer, parameter, public :: i2b = selected_int_kind(4) - integer, parameter, public :: i1b = selected_int_kind(2) - integer, parameter, public :: sp = selected_real_kind(5,30) - integer, parameter, public :: dp = selected_real_kind(12,200) - integer, parameter, public :: lgt = kind(.TRUE.) - integer, parameter, public :: spc = kind((1.0_sp, 1.0_sp)) - integer, parameter, public :: dpc = kind((1.0_dp, 1.0_dp)) - ! - integer(I8B), parameter, public :: max_i8b = huge(1_i8b) - integer, parameter, public :: max_i4b = huge(1_i4b) - integer, parameter, public :: max_i2b = huge(1_i2b) - integer, parameter, public :: max_i1b = 127 - real(kind=sp), parameter, public :: max_sp = huge(1.0_sp) - real(kind=dp), parameter, public :: max_dp = huge(1.0_dp) - - ! Numerical Constant (Double precision) - real(kind=dp), parameter, public :: QUARTPI=0.785398163397448309615660845819875721049_dp - real, parameter, public :: HALFPI= 1.570796326794896619231321691639751442099 - real, parameter, public :: PI = 3.141592653589793238462643383279502884197 - real, parameter, public :: TWOPI = 6.283185307179586476925286766559005768394 - real(kind=dp), parameter, public :: FOURPI=12.56637061435917295385057353311801153679_dp - real(kind=dp), parameter, public :: SQRT2 = 1.41421356237309504880168872420969807856967_dp - real(kind=dp), parameter, public :: EULER = 0.5772156649015328606065120900824024310422_dp - real(kind=dp), parameter, public :: SQ4PI_INV = 0.2820947917738781434740397257803862929220_dp - real(kind=dp), parameter, public :: TWOTHIRD = 0.6666666666666666666666666666666666666666_dp - - real(kind=DP), parameter, public :: RAD2DEG = 180.0_DP / PI - real(kind=DP), parameter, public :: DEG2RAD = PI / 180.0_DP - real(kind=SP), parameter, public :: hpx_sbadval = -1.6375e30_sp - real(kind=DP), parameter, public :: hpx_dbadval = -1.6375e30_dp - - ! Maximum length of filenames - integer, parameter :: filenamelen = 1024 - - - ! ! ---- Normalisation and convention ---- - ! normalisation of spin weighted functions - real(kind=dp), parameter, public :: KvS = 1.0_dp ! 1.0 : CMBFAST (Healpix 1.2) - ! ! sign of Q - ! real(kind=dp), parameter, public :: sgQ = -1.0_dp ! -1 : CMBFAST (Healpix 1.2) - ! ! sign of spin weighted function ! - ! real(kind=dp), parameter, public :: SW1 = -1.0_dp ! -1 : Healpix 1.2, bug correction - - ! ! ! normalisation of spin weighted functions - ! ! real(kind=dp), parameter, public :: KvS = 2.0_dp ! 2.0 : KKS (Healpix 1.1) - ! ! ! sign of Q - ! ! real(kind=dp), parameter, public :: sgQ = +1.0_dp ! +1 : KKS (Healpix 1.1) - ! ! ! sign of spin weighted function ! - ! ! real(kind=dp), parameter, public :: SW1 = +1.0_dp ! +1 : Healpix 1.1 - - ! real(kind=dp), parameter, public :: iKvS = 1.0_dp / KvS ! inverse of KvS - integer(kind=i4b), private, parameter :: ns_max4=8192 ! 2^13 - integer(kind=i4b), private, save, dimension(0:127) :: x2pix1=-1,y2pix1=-1 - integer(kind=i4b), private, save, dimension(0:1023) :: pix2x=-1, pix2y=-1 - integer(i4b), parameter :: oddbits=89478485 ! 2^0 + 2^2 + 2^4+..+2^26 - integer(i4b), parameter :: evenbits=178956970 ! 2^1 + 2^3 + 2^4+..+2^27 - integer(kind=i4b), private, parameter :: ns_max=268435456! 2^28 - - contains - - !! Returns i with even and odd bit positions interchanged. - function swapLSBMSB(i) - integer(i4b) :: swapLSBMSB - integer(i4b), intent(in) :: i - - swapLSBMSB = iand(i,evenbits)/2 + iand(i,oddbits)*2 - end function swapLSBMSB - - !! Returns not(i) with even and odd bit positions interchanged. - function invswapLSBMSB(i) - integer(i4b) :: invswapLSBMSB - integer(i4b), intent(in) :: i - - invswapLSBMSB = not(swapLSBMSB(i)) - end function invswapLSBMSB - - !! Returns i with odd (1,3,5,...) bits inverted. - function invLSB(i) - integer(i4b) :: invLSB - integer(i4b), intent(in) :: i - - invLSB = ieor(i,oddbits) - end function invLSB - - !! Returns i with even (0,2,4,...) bits inverted. - function invMSB(i) - integer(i4b) :: invMSB - integer(i4b), intent(in) :: i - - invMSB = ieor(i,evenbits) - end function invMSB - - !======================================================================= - ! vec2pix_nest - ! - ! renders the pixel number ipix (NESTED scheme) for a pixel which contains - ! a point on a sphere at coordinate vector (=x,y,z), given the map - ! resolution parameter nside - ! - ! 2009-03-10: calculations done directly at nside rather than ns_max - !======================================================================= - subroutine vec2pix_nest (nside, vector, ipix) - integer(i4b), parameter :: MKD = I4B - integer(kind=I4B), intent(in) :: nside - real, intent(in), dimension(1:) :: vector - integer(kind=MKD), intent(out) :: ipix - - integer(kind=MKD) :: ipf,scale,scale_factor - real(kind=DP) :: z,za,tt,tp,tmp,dnorm,phi - integer(kind=I4B) :: jp,jm,ifp,ifm,face_num,ix,iy,ix_low,iy_low,ntt,i,ismax - character(len=*), parameter :: code = "vec2pix_nest" - - !----------------------------------------------------------------------- - if (nside<1 .or. nside>ns_max4) call fatal_error(code//"> nside out of range") - dnorm = sqrt(vector(1)**2+vector(2)**2+vector(3)**2) - z = vector(3) / dnorm - phi = 0.0 - if (vector(1) /= 0.0 .or. vector(2) /= 0.0) & - & phi = atan2(vector(2),vector(1)) ! phi in ]-pi,pi] - - za = abs(z) - if (phi < 0.0) phi = phi + twopi ! phi in [0,2pi[ - tt = phi / halfpi ! in [0,4[ - if (x2pix1(127) <= 0) call mk_xy2pix1() - - if (za <= twothird) then ! equatorial region - - ! (the index of edge lines increase when the longitude=phi goes up) - jp = int(nside*(0.5_dp + tt - z*0.75_dp)) ! ascending edge line index - jm = int(nside*(0.5_dp + tt + z*0.75_dp)) ! descending edge line index - - ! finds the face - ifp = jp / nside ! in {0,4} - ifm = jm / nside - if (ifp == ifm) then ! faces 4 to 7 - face_num = iand(ifp,3) + 4 - elseif (ifp < ifm) then ! (half-)faces 0 to 3 - face_num = iand(ifp,3) - else ! (half-)faces 8 to 11 - face_num = iand(ifm,3) + 8 - endif - - ix = iand(jm, nside-1) - iy = nside - iand(jp, nside-1) - 1 - - else ! polar region, za > 2/3 - - ntt = int(tt) - if (ntt >= 4) ntt = 3 - tp = tt - ntt - !tmp = sqrt( 3.0_dp*(1.0_dp - za) ) ! in ]0,1] - tmp = sqrt(vector(1)**2+vector(2)**2) / dnorm ! sin(theta) - tmp = tmp * sqrt( 3.0_dp / (1.0_dp + za) ) !more accurate - - ! (the index of edge lines increase when distance from the closest pole goes up) - jp = int( nside * tp * tmp ) ! line going toward the pole as phi increases - jm = int( nside * (1.0_dp - tp) * tmp ) ! that one goes away of the closest pole - jp = min(nside-1, jp) ! for points too close to the boundary - jm = min(nside-1, jm) - - ! finds the face and pixel's (x,y) - if (z >= 0) then - face_num = ntt ! in {0,3} - ix = nside - jm - 1 - iy = nside - jp - 1 - else - face_num = ntt + 8 ! in {8,11} - ix = jp - iy = jm - endif - - endif - - if (nside <= ns_max4) then - ix_low = iand(ix, 127) - iy_low = iand(iy, 127) - ipf = x2pix1(ix_low) + y2pix1(iy_low) & - & + (x2pix1(ix/128) + y2pix1(iy/128)) * 16384 - else - scale = 1_MKD - scale_factor = 16384_MKD ! 128*128 - ipf = 0_MKD - ismax = 1 ! for nside in [2^14, 2^20] - if (nside > 1048576 ) ismax = 3 - do i=0, ismax - ix_low = iand(ix, 127) ! last 7 bits - iy_low = iand(iy, 127) ! last 7 bits - ipf = ipf + (x2pix1(ix_low)+y2pix1(iy_low)) * scale - scale = scale * scale_factor - ix = ix / 128 ! truncate out last 7 bits - iy = iy / 128 - enddo - ipf = ipf + (x2pix1(ix)+y2pix1(iy)) * scale - endif - ipix = ipf + face_num* int(nside,MKD) * nside ! in {0, 12*nside**2 - 1} - - end subroutine vec2pix_nest - - !======================================================================= - ! pix2vec_nest - ! - ! renders vector (x,y,z) coordinates of the nominal pixel center - ! for the pixel number ipix (NESTED scheme) - ! given the map resolution parameter nside - ! also returns the (x,y,z) position of the 4 pixel vertices (=corners) - ! in the order N,W,S,E - !======================================================================= - subroutine pix2vec_nest (nside, ipix, vector, vertex) - integer(i4b), parameter :: MKD = i4b - integer(kind=I4B), intent(in) :: nside - integer(kind=MKD), intent(in) :: ipix - real, intent(out), dimension(1:) :: vector - real, intent(out), dimension(1:,1:), optional :: vertex - - integer(kind=MKD) :: npix, npface, ipf - integer(kind=I4B) :: ip_low, ip_trunc, ip_med, ip_hi - integer(kind=I4B) :: face_num, ix, iy, kshift, scale, i, ismax - integer(kind=I4B) :: jrt, jr, nr, jpt, jp, nl4 - real :: z, fn, fact1, fact2, sth, phi - - ! coordinate of the lowest corner of each face - integer(kind=I4B), dimension(1:12) :: jrll = (/ 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4 /) ! in unit of nside - integer(kind=I4B), dimension(1:12) :: jpll = (/ 1, 3, 5, 7, 0, 2, 4, 6, 1, 3, 5, 7 /) ! in unit of nside/2 - - real :: phi_nv, phi_wv, phi_sv, phi_ev, phi_up, phi_dn, sin_phi, cos_phi - real :: z_nv, z_sv, sth_nv, sth_sv - real :: hdelta_phi - integer(kind=I4B) :: iphi_mod, iphi_rat - logical(kind=LGT) :: do_vertex - integer(kind=i4b) :: diff_phi - character(len=*), parameter :: code = "pix2vec_nest" - - !----------------------------------------------------------------------- - if (nside > ns_max4) call fatal_error(code//"> nside out of range") - npix = nside2npix(nside) ! total number of points - if (ipix <0 .or. ipix>npix-1) call fatal_error(code//"> ipix out of range") - - ! initiates the array for the pixel number -> (x,y) mapping - if (pix2x(1023) <= 0) call mk_pix2xy() - - npface = nside * int(nside, kind=MKD) - nl4 = 4*nside - - ! finds the face, and the number in the face - face_num = ipix/npface ! face number in {0,11} - ipf = modulo(ipix,npface) ! pixel number in the face {0,npface-1} - - do_vertex = .false. - if (present(vertex)) then - if (size(vertex,dim=1) >= 3 .and. size(vertex,dim=2) >= 4) then - do_vertex = .true. - else - call fatal_error(code//"> vertex array has wrong size ") - endif - endif - fn = real(nside) - fact1 = 1.0/(3.0*fn*fn) - fact2 = 2.0/(3.0*fn) - - ! finds the x,y on the face (starting from the lowest corner) - ! from the pixel number - if (nside <= ns_max4) then - ip_low = iand(ipf,1023_MKD) ! content of the last 10 bits - ip_trunc = ipf/1024 ! truncation of the last 10 bits - ip_med = iand(ip_trunc,1023) ! content of the next 10 bits - ip_hi = ip_trunc/1024 ! content of the high weight 10 bits - - ix = 1024*pix2x(ip_hi) + 32*pix2x(ip_med) + pix2x(ip_low) - iy = 1024*pix2y(ip_hi) + 32*pix2y(ip_med) + pix2y(ip_low) - else - ix = 0 - iy = 0 - scale = 1 - ismax = 4 - do i=0, ismax - ip_low = iand(ipf,1023_MKD) - ix = ix + scale * pix2x(ip_low) - iy = iy + scale * pix2y(ip_low) - scale = scale * 32 - ipf = ipf/1024 - enddo - ix = ix + scale * pix2x(ipf) - iy = iy + scale * pix2y(ipf) - endif - - ! transforms this in (horizontal, vertical) coordinates - jrt = ix + iy ! 'vertical' in {0,2*(nside-1)} - jpt = ix - iy ! 'horizontal' in {-nside+1,nside-1} - - ! computes the z coordinate on the sphere - jr = jrll(face_num+1)*nside - jrt - 1 ! ring number in {1,4*nside-1} - - z_nv = 0.; z_sv = 0. ! avoid compiler warnings - - if (jr < nside) then ! north pole region - nr = jr - z = 1. - nr*fact1*nr - sth = nr * sqrt(fact1 * (1. + z) ) ! more accurate close to pole - kshift = 0 - if (do_vertex) then - z_nv = 1. - (nr-1)*fact1*(nr-1) - z_sv = 1. - (nr+1)*fact1*(nr+1) - endif - - elseif (jr <= 3*nside) then ! equatorial region - nr = nside - z = (2*nside-jr)*fact2 - sth = sqrt((1.0-z)*(1.0+z)) ! good enough on Equator - kshift = iand(jr - nside, 1) - if (do_vertex) then - z_nv = (2*nside-jr+1)*fact2 - z_sv = (2*nside-jr-1)*fact2 - if (jr == nside) then ! northern transition - z_nv = 1.0- (nside-1) * fact1 * (nside-1) - elseif (jr == 3*nside) then ! southern transition - z_sv = -1.0 + (nside-1) * fact1 * (nside-1) - endif - endif - - elseif (jr > 3*nside) then ! south pole region - nr = nl4 - jr - z = - 1.0 + nr*fact1*nr - sth = nr * sqrt(fact1 * (1. - z) ) - kshift = 0 - if (do_vertex) then - z_nv = - 1.0 + (nr+1)*fact1*(nr+1) - z_sv = - 1.0 + (nr-1)*fact1*(nr-1) - endif - endif - - ! computes the phi coordinate on the sphere, in [0,2Pi] - jp = (jpll(face_num+1)*nr + jpt + 1_MKD + kshift)/2 ! 'phi' number in the ring in {1,4*nr} - if (jp > nl4) jp = jp - nl4 - if (jp < 1) jp = jp + nl4 - - phi = (jp - (kshift+1)*0.5) * (halfpi / nr) - - ! pixel center - ! - cos_phi = cos(phi) - sin_phi = sin(phi) - vector(1) = sth * cos_phi - vector(2) = sth * sin_phi - vector(3) = z - - if (do_vertex) then - phi_nv = phi - phi_sv = phi - diff_phi = 0 ! phi_nv = phi_sv = phisth * 1} - iphi_rat = (jp-1) / nr ! in {0,1,2,3} - iphi_mod = mod(jp-1,nr) - phi_up = 0. - if (nr > 1) phi_up = HALFPI * (iphi_rat + iphi_mod /real(nr-1)) - phi_dn = HALFPI * (iphi_rat + (iphi_mod+1)/real(nr+1)) - if (jr < nside) then ! North polar cap - phi_nv = phi_up - phi_sv = phi_dn - diff_phi = 3 ! both phi_nv and phi_sv different from phi - elseif (jr > 3*nside) then ! South polar cap - phi_nv = phi_dn - phi_sv = phi_up - diff_phi = 3 ! both phi_nv and phi_sv different from phi - elseif (jr == nside) then ! North transition - phi_nv = phi_up - diff_phi = 1 - elseif (jr == 3*nside) then ! South transition - phi_sv = phi_up - diff_phi = 2 - endif - - hdelta_phi = PI / (4.0*nr) - - ! west vertex - phi_wv = phi - hdelta_phi - vertex(1,2) = sth * cos(phi_wv) - vertex(2,2) = sth * sin(phi_wv) - vertex(3,2) = z - - ! east vertex - phi_ev = phi + hdelta_phi - vertex(1,4) = sth * cos(phi_ev) - vertex(2,4) = sth * sin(phi_ev) - vertex(3,4) = z - - ! north and south vertices - sth_nv = sqrt((1.0-z_nv)*(1.0+z_nv)) - sth_sv = sqrt((1.0-z_sv)*(1.0+z_sv)) - if (diff_phi == 0) then - vertex(1,1) = sth_nv * cos_phi - vertex(2,1) = sth_nv * sin_phi - vertex(1,3) = sth_sv * cos_phi - vertex(2,3) = sth_sv * sin_phi - else - vertex(1,1) = sth_nv * cos(phi_nv) - vertex(2,1) = sth_nv * sin(phi_nv) - vertex(1,3) = sth_sv * cos(phi_sv) - vertex(2,3) = sth_sv * sin(phi_sv) - endif - vertex(3,1) = z_nv - vertex(3,3) = z_sv - endif - - end subroutine pix2vec_nest - - !======================================================================= - ! npix2nside - ! - ! given npix, returns nside such that npix = 12*nside^2 - ! nside should be a power of 2 smaller than ns_max - ! if not, -1 is returned - ! EH, Feb-2000 - ! 2009-03-05, edited, accepts 8-byte npix - !======================================================================= - function npix2nside (npix) result(nside_result) - integer(i4b), parameter :: MKD = I4B - integer(kind=MKD), parameter :: npix_max = (12_MKD*ns_max4)*ns_max4 - integer(kind=MKD), intent(in) :: npix - integer(kind=MKD) :: npix1, npix2 - integer(kind=I4B) :: nside_result - integer(kind=I4B) :: nside - character(LEN=*), parameter :: code = "npix2nside" - !======================================================================= - - if (npix < 12 .or. npix > npix_max) then - print*, code,"> Npix=",npix, & - & " is out of allowed range: {12,",npix_max,"}" - nside_result = -1 - return - endif - - nside = nint( sqrt(npix/12.0_dp) ) - npix1 = (12_MKD*nside)*nside - if (abs(npix1-npix) > 0) then - print*, code,"> Npix=",npix, & - & " is not 12 * Nside * Nside " - nside_result = -1 - return - endif - - ! test validity of Nside - npix2 = nside2npix(nside) - if (npix2 < 0) then - nside_result = -1 - return - endif - - nside_result = nside - - end function npix2nside - - - !======================================================================= - function nside2npix(nside) result(npix_result) - !======================================================================= - ! given nside, returns npix such that npix = 12*nside^2 - ! nside should be a power of 2 smaller than ns_max - ! if not, -1 is returned - ! EH, Feb-2000 - ! 2009-03-04: returns i8b result, faster - !======================================================================= - integer(kind=I4B) :: npix_result - integer(kind=I4B), intent(in) :: nside - - integer(kind=I4B) :: npix - character(LEN=*), parameter :: code = "nside2npix" - !======================================================================= - - npix = (12_i4b*nside)*nside - if (nside < 1 .or. nside > ns_max4 .or. iand(nside-1,nside) /= 0) then - print*,code,": Nside=",nside," is not a power of 2." - npix = -1 - endif - npix_result = npix - - end function nside2npix - - !======================================================================= - ! CHEAP_ISQRT - ! Returns exact Floor(sqrt(x)) where x is a (64 bit) integer. - ! y^2 <= x < (y+1)^2 (1) - ! The double precision floating point operation is not accurate enough - ! when dealing with 64 bit integers, especially in the vicinity of - ! perfect squares. - !======================================================================= - function cheap_isqrt(lin) result (lout) - integer(i4b), intent(in) :: lin - integer(i4b) :: lout - lout = floor(sqrt(dble(lin)), kind=I4B) - return - end function cheap_isqrt - - !======================================================================= - subroutine mk_pix2xy() - !======================================================================= - ! constructs the array giving x and y in the face from pixel number - ! for the nested (quad-cube like) ordering of pixels - ! - ! the bits corresponding to x and y are interleaved in the pixel number - ! one breaks up the pixel number by even and odd bits - !======================================================================= - integer(kind=I4B) :: kpix, jpix, ix, iy, ip, id - - !cc cf block data data pix2x(1023) /0/ - !----------------------------------------------------------------------- - ! print *, 'initiate pix2xy' - do kpix=0,1023 ! pixel number - jpix = kpix - IX = 0 - IY = 0 - IP = 1 ! bit position (in x and y) - ! do while (jpix/=0) ! go through all the bits - do - if (jpix == 0) exit ! go through all the bits - ID = modulo(jpix,2) ! bit value (in kpix), goes in ix - jpix = jpix/2 - IX = ID*IP+IX - - ID = modulo(jpix,2) ! bit value (in kpix), goes in iy - jpix = jpix/2 - IY = ID*IP+IY - - IP = 2*IP ! next bit (in x and y) - enddo - pix2x(kpix) = IX ! in 0,31 - pix2y(kpix) = IY ! in 0,31 - enddo - - end subroutine mk_pix2xy - !======================================================================= - subroutine mk_xy2pix1() - !======================================================================= - ! sets the array giving the number of the pixel lying in (x,y) - ! x and y are in {1,128} - ! the pixel number is in {0,128**2-1} - ! - ! if i-1 = sum_p=0 b_p * 2^p - ! then ix = sum_p=0 b_p * 4^p - ! iy = 2*ix - ! ix + iy in {0, 128**2 -1} - !======================================================================= - integer(kind=I4B):: k,ip,i,j,id - !======================================================================= - - do i = 0,127 !for converting x,y into - j = i !pixel numbers - k = 0 - ip = 1 - - do - if (j==0) then - x2pix1(i) = k - y2pix1(i) = 2*k - exit - else - id = modulo(J,2) - j = j/2 - k = ip*id+k - ip = ip*4 - endif - enddo - enddo - - end subroutine mk_xy2pix1 - - subroutine fatal_error (msg) - character(len=*), intent(in), optional :: msg - - if (present(msg)) then - print *,'Fatal error: ', trim(msg) - else - print *,'Fatal error' - endif - call exit_with_status(1) - - end subroutine fatal_error - - ! =========================================================== - subroutine exit_with_status (code, msg) - integer(i4b), intent(in) :: code - character (len=*), intent(in), optional :: msg - - if (present(msg)) print *,trim(msg) - print *,'program exits with exit code ', code - call exit (code) - - end subroutine exit_with_status - - !==================================================================== - ! The following is a routine which finds the 7 or 8 neighbours of - ! any pixel in the nested scheme of the HEALPIX pixelisation. - !==================================================================== - ! neighbours_nest - ! - ! Returns list n(8) of neighbours of pixel ipix (in NESTED scheme) - ! the neighbours are ordered in the following way: - ! First pixel is the one to the south (the one west of the south - ! direction is taken - ! for the pixels which don't have a southern neighbour). From - ! then on the neighbours are ordered in the clockwise direction - ! about the pixel with number ipix. - ! - ! nneigh is the number of neighbours (mostly 8, 8 pixels have 7 neighbours) - ! - ! Benjamin D. Wandelt October 1997 - ! Added to pix_tools in March 1999 - ! added 'return' for case nside=1, EH, Oct 2005 - ! corrected bugs in case nside=1 and ipix=7, 9 or 11, EH, June 2006 - ! 2009-06-16: deals with Nside > 8192 - !==================================================================== - subroutine neighbours_nest(nside, ipix, n, nneigh) - ! use bit_manipulation - integer(kind=i4b), parameter :: MKD = I4B - !==================================================================== - integer(kind=i4b), intent(in):: nside - integer(kind=MKD), intent(in):: ipix - integer(kind=MKD), intent(out), dimension(1:):: n - integer(kind=i4b), intent(out):: nneigh - - integer(kind=i4b) :: ix,ixm,ixp,iy,iym,iyp,ixo,iyo - integer(kind=i4b) :: face_num,other_face - integer(kind=i4b) :: ia,ib,ibp,ibm,ib2,icase - integer(kind=MKD) :: npix,ipf,ipo - integer(kind=MKD) :: local_magic1,local_magic2,nsidesq - character(len=*), parameter :: code = "neighbours_nest" - - ! integer(kind=i4b), intrinsic :: IAND - - !-------------------------------------------------------------------- - if (nside <1 .or. nside > ns_max4) call fatal_error(code//"> nside out of range") - npix = nside2npix(nside) ! total number of points - nsidesq = npix / 12 - if (ipix <0 .or. ipix>npix-1) call fatal_error(code//"> ipix out of range") - - ! quick and dirty hack for Nside=1 - - if (nside == 1) then - nneigh = 6 - if (ipix==0 ) n(1:6) = (/ 8, 4, 3, 2, 1, 5 /) - if (ipix==1 ) n(1:6) = (/ 9, 5, 0, 3, 2, 6 /) - if (ipix==2 ) n(1:6) = (/10, 6, 1, 0, 3, 7 /) - if (ipix==3 ) n(1:6) = (/11, 7, 2, 1, 0, 4 /) - if (ipix==4 ) n(1:6) = (/11, 7, 3, 0, 5, 8 /) - if (ipix==5 ) n(1:6) = (/ 8, 4, 0, 1, 6, 9 /) - if (ipix==6 ) n(1:6) = (/ 9, 5, 1, 2, 7,10 /) - if (ipix==7 ) n(1:6) = (/10, 6, 2, 3, 4,11 /) - if (ipix==8 ) n(1:6) = (/10,11, 4, 0, 5, 9 /) - if (ipix==9 ) n(1:6) = (/11, 8, 5, 1, 6,10 /) - if (ipix==10) n(1:6) = (/ 8, 9, 6, 2, 7,11 /) - if (ipix==11) n(1:6) = (/ 9,10, 7, 3, 4, 8 /) - return - endif - - ! initiates array for (x,y)-> pixel number -> (x,y) mapping - if (x2pix1(127) <= 0) call mk_xy2pix1() - - local_magic1=(nsidesq-1)/3 - local_magic2=2*local_magic1 - face_num=ipix/nsidesq - - ipf=modulo(ipix,nsidesq) !Pixel number in face - - call pix2xy_nest(nside,ipf,ix,iy) - ixm=ix-1 - ixp=ix+1 - iym=iy-1 - iyp=iy+1 - - nneigh=8 !Except in special cases below - - ! Exclude corners - if (ipf==local_magic2) then !WestCorner - icase=5 - goto 100 - endif - if (ipf==(nsidesq-1)) then !NorthCorner - icase=6 - goto 100 - endif - if (ipf==0) then !SouthCorner - icase=7 - goto 100 - endif - if (ipf==local_magic1) then !EastCorner - icase=8 - goto 100 - endif - - ! Detect edges - if (iand(ipf,local_magic1)==local_magic1) then !NorthEast - icase=1 - goto 100 - endif - if (iand(ipf,local_magic1)==0) then !SouthWest - icase=2 - goto 100 - endif - if (iand(ipf,local_magic2)==local_magic2) then !NorthWest - icase=3 - goto 100 - endif - if (iand(ipf,local_magic2)==0) then !SouthEast - icase=4 - goto 100 - endif - - ! Inside a face - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - return - - 100 continue - - ia= face_num/4 !in {0,2} - ib= modulo(face_num,4) !in {0,3} - ibp=modulo(ib+1,4) - ibm=modulo(ib+4-1,4) - ib2=modulo(ib+2,4) - - if (ia==0) then !North Pole region - select case(icase) - case(1) !NorthEast edge - other_face=0+ibp - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - ipo=modulo(swapLSBMSB(ipf),nsidesq) !East-West flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo+1 , iyo, other_face, n(5)) - n(6)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(7)) - case(2) !SouthWest edge - other_face=4+ib - ipo=modulo(invLSB(ipf),nsidesq) !SW-NE flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) - n(2)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo+1, other_face, n(3)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - case(3) !NorthWest edge - other_face=0+ibm - ipo=modulo(swapLSBMSB(ipf),nsidesq) !East-West flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(3)) - n(4)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo+1, other_face, n(5)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - case(4) !SouthEast edge - other_face=4+ibp - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - ipo=modulo(invMSB(ipf),nsidesq) !SE-NW flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo+1, iyo, other_face, n(7)) - n(8)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) - case(5) !West corner - nneigh=7 - other_face=4+ib - n(2)=other_face*nsidesq+nsidesq-1 - n(1)=n(2)-2 - other_face=0+ibm - n(3)=other_face*nsidesq+local_magic1 - n(4)=n(3)+2 - n(5)=ipix+1 - n(6)=ipix-1 - n(7)=ipix-2 - case(6) !North corner - n(1)=ipix-3 - n(2)=ipix-1 - n(8)=ipix-2 - other_face=0+ibm - n(4)=other_face*nsidesq+nsidesq-1 - n(3)=n(4)-2 - other_face=0+ib2 - n(5)=other_face*nsidesq+nsidesq-1 - other_face=0+ibp - n(6)=other_face*nsidesq+nsidesq-1 - n(7)=n(6)-1 - case(7) !South corner - other_face=8+ib - n(1)=other_face*nsidesq+nsidesq-1 - other_face=4+ib - n(2)=other_face*nsidesq+local_magic1 - n(3)=n(2)+2 - n(4)=ipix+2 - n(5)=ipix+3 - n(6)=ipix+1 - other_face=4+ibp - n(8)=other_face*nsidesq+local_magic2 - n(7)=n(8)+1 - case(8) !East corner - nneigh=7 - n(2)=ipix-1 - n(3)=ipix+1 - n(4)=ipix+2 - other_face=0+ibp - n(6)=other_face*nsidesq+local_magic2 - n(5)=n(6)+1 - other_face=4+ibp - n(7)=other_face*nsidesq+nsidesq-1 - n(1)=n(7)-1 - end select ! north - - elseif (ia==1) then !Equatorial region - select case(icase) - case(1) !NorthEast edge - other_face=0+ib - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - ipo=modulo(invLSB(ipf),nsidesq) !NE-SW flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo , iyo+1, other_face, n(5)) - n(6)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(7)) - case(2) !SouthWest edge - other_face=8+ibm - ipo=modulo(invLSB(ipf),nsidesq) !SW-NE flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) - n(2)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo+1, other_face, n(3)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - case(3) !NorthWest edge - other_face=0+ibm - ipo=modulo(invMSB(ipf),nsidesq) !NW-SE flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(3)) - n(4)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo+1, iyo, other_face, n(5)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - case(4) !SouthEast edge - other_face=8+ib - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - ipo=modulo(invMSB(ipf),nsidesq) !SE-NW flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo+1, iyo, other_face, n(7)) - n(8)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) - case(5) !West corner - other_face=8+ibm - n(2)=other_face*nsidesq+nsidesq-1 - n(1)=n(2)-2 - other_face=4+ibm - n(3)=other_face*nsidesq+local_magic1 - other_face=0+ibm - n(4)=other_face*nsidesq - n(5)=n(4)+1 - n(6)=ipix+1 - n(7)=ipix-1 - n(8)=ipix-2 - case(6) !North corner - nneigh=7 - n(1)=ipix-3 - n(2)=ipix-1 - other_face=0+ibm - n(4)=other_face*nsidesq+local_magic1 - n(3)=n(4)-1 - other_face=0+ib - n(5)=other_face*nsidesq+local_magic2 - n(6)=n(5)-2 - n(7)=ipix-2 - case(7) !South corner - nneigh=7 - other_face=8+ibm - n(1)=other_face*nsidesq+local_magic1 - n(2)=n(1)+2 - n(3)=ipix+2 - n(4)=ipix+3 - n(5)=ipix+1 - other_face=8+ib - n(7)=other_face*nsidesq+local_magic2 - n(6)=n(7)+1 - case(8) !East corner - other_face=8+ib - n(8)=other_face*nsidesq+nsidesq-1 - n(1)=n(8)-1 - n(2)=ipix-1 - n(3)=ipix+1 - n(4)=ipix+2 - other_face=0+ib - n(6)=other_face*nsidesq - n(5)=n(6)+2 - other_face=4+ibp - n(7)=other_face*nsidesq+local_magic2 - end select ! equator - else !South Pole region - select case(icase) - case(1) !NorthEast edge - other_face=4+ibp - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - ipo=modulo(invLSB(ipf),nsidesq) !NE-SW flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo , iyo+1, other_face, n(5)) - n(6)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(7)) - case(2) !SouthWest edge - other_face=8+ibm - ipo=modulo(swapLSBMSB(ipf),nsidesq) !W-E flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) - n(2)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo+1, iyo, other_face, n(3)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - case(3) !NorthWest edge - other_face=4+ib - ipo=modulo(invMSB(ipf),nsidesq) !NW-SE flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo-1, iyo, other_face, n(3)) - n(4)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo+1, iyo, other_face, n(5)) - call xy2pix_nest(nside, ixm, iym, face_num, n(1)) - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ix , iym, face_num, n(8)) - call xy2pix_nest(nside, ixp, iym, face_num, n(7)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - case(4) !SouthEast edge - other_face=8+ibp - call xy2pix_nest(nside, ixm, iy , face_num, n(2)) - call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) - call xy2pix_nest(nside, ix , iyp, face_num, n(4)) - call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) - call xy2pix_nest(nside, ixp, iy , face_num, n(6)) - ipo=modulo(swapLSBMSB(ipf),nsidesq) !E-W flip - call pix2xy_nest(nside,ipo,ixo,iyo) - call xy2pix_nest(nside, ixo, iyo+1, other_face, n(7)) - n(8)=other_face*nsidesq+ipo - call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) - case(5) !West corner - nneigh=7 - other_face=8+ibm - n(2)=other_face*nsidesq+local_magic1 - n(1)=n(2)-1 - other_face=4+ib - n(3)=other_face*nsidesq - n(4)=n(3)+1 - n(5)=ipix+1 - n(6)=ipix-1 - n(7)=ipix-2 - case(6) !North corner - n(1)=ipix-3 - n(2)=ipix-1 - other_face=4+ib - n(4)=other_face*nsidesq+local_magic1 - n(3)=n(4)-1 - other_face=0+ib - n(5)=other_face*nsidesq - other_face=4+ibp - n(6)=other_face*nsidesq+local_magic2 - n(7)=n(6)-2 - n(8)=ipix-2 - case(7) !South corner - other_face=8+ib2 - n(1)=other_face*nsidesq - other_face=8+ibm - n(2)=other_face*nsidesq - n(3)=n(2)+1 - n(4)=ipix+2 - n(5)=ipix+3 - n(6)=ipix+1 - other_face=8+ibp - n(8)=other_face*nsidesq - n(7)=n(8)+2 - case(8) !East corner - nneigh=7 - other_face=8+ibp - n(7)=other_face*nsidesq+local_magic2 - n(1)=n(7)-2 - n(2)=ipix-1 - n(3)=ipix+1 - n(4)=ipix+2 - other_face=4+ibp - n(6)=other_face*nsidesq - n(5)=n(6)+2 - end select ! south - endif - - end subroutine neighbours_nest - - - !======================================================================= - ! pix2xy_nest - ! gives the x, y coords in a face from pixel number within the face (NESTED) - ! - ! Benjamin D. Wandelt 13/10/97 - ! - ! using code from HEALPIX toolkit by K.Gorski and E. Hivon - ! 2009-06-15: deals with Nside > 8192 - ! 2012-03-02: test validity of ipf_in instead of undefined ipf - ! define ipf as MKD - ! 2012-08-27: corrected bug on (ix,iy) for Nside > 8192 (MARK) - !======================================================================= - subroutine pix2xy_nest (nside, ipf_in, ix, iy) - integer(kind=i4b), parameter :: MKD = I4B - integer(kind=I4B), intent(in) :: nside - integer(kind=MKD), intent(in) :: ipf_in - integer(kind=I4B), intent(out) :: ix, iy - - integer(kind=MKD) :: ipf - integer(kind=I4B) :: ip_low, ip_trunc, ip_med, ip_hi, scale, i, ismax - character(len=*), parameter :: code = "pix2xy_nest" - - !----------------------------------------------------------------------- - if (nside<1 .or. nside>ns_max) call fatal_error(code//"> nside out of range") - if (ipf_in<0 .or. ipf_in>nside*nside-1) & - & call fatal_error(code//"> ipix out of range") - if (pix2x(1023) <= 0) call mk_pix2xy() - - ipf = ipf_in - if (nside <= ns_max4) then - ip_low = iand(ipf,1023_MKD) ! content of the last 10 bits - ip_trunc = ipf/1024 ! truncation of the last 10 bits - ip_med = iand(ip_trunc,1023) ! content of the next 10 bits - ip_hi = ip_trunc/1024 ! content of the high weight 10 bits - - ix = 1024*pix2x(ip_hi) + 32*pix2x(ip_med) + pix2x(ip_low) - iy = 1024*pix2y(ip_hi) + 32*pix2y(ip_med) + pix2y(ip_low) - else - ix = 0 - iy = 0 - scale = 1 - ismax = 4 - do i=0, ismax - ip_low = iand(ipf,1023_MKD) - ix = ix + scale * pix2x(ip_low) - iy = iy + scale * pix2y(ip_low) ! corrected 2012-08-27 - scale = scale * 32 - ipf = ipf/1024 - enddo - ix = ix + scale * pix2x(ipf) - iy = iy + scale * pix2y(ipf) ! corrected 2012-08-27 - endif - - end subroutine pix2xy_nest - - !======================================================================= - ! gives the pixel number ipix (NESTED) - ! corresponding to ix, iy and face_num - ! - ! Benjamin D. Wandelt 13/10/97 - ! using code from HEALPIX toolkit by K.Gorski and E. Hivon - ! 2009-06-15: deals with Nside > 8192 - ! 2012-03-02: test validity of ix_in and iy_in instead of undefined ix and iy - !======================================================================= - subroutine xy2pix_nest(nside, ix_in, iy_in, face_num, ipix) - integer(kind=i4b), parameter :: MKD = I4B - !======================================================================= - integer(kind=I4B), intent(in) :: nside, ix_in, iy_in, face_num - integer(kind=MKD), intent(out) :: ipix - integer(kind=I4B) :: ix, iy, ix_low, iy_low, i, ismax - integer(kind=MKD) :: ipf, scale, scale_factor - character(len=*), parameter :: code = "xy2pix_nest" - - !----------------------------------------------------------------------- - if (nside<1 .or. nside>ns_max) call fatal_error(code//"> nside out of range") - if (ix_in<0 .or. ix_in>(nside-1)) call fatal_error(code//"> ix out of range") - if (iy_in<0 .or. iy_in>(nside-1)) call fatal_error(code//"> iy out of range") - if (x2pix1(127) <= 0) call mk_xy2pix1() - - ix = ix_in - iy = iy_in - if (nside <= ns_max4) then - ix_low = iand(ix, 127) - iy_low = iand(iy, 127) - ipf = x2pix1(ix_low) + y2pix1(iy_low) & - & + (x2pix1(ix/128) + y2pix1(iy/128)) * 16384 - else - scale = 1_MKD - scale_factor = 16384_MKD ! 128*128 - ipf = 0_MKD - ismax = 1 ! for nside in [2^14, 2^20] - if (nside > 1048576 ) ismax = 3 - do i=0, ismax - ix_low = iand(ix, 127) ! last 7 bits - iy_low = iand(iy, 127) ! last 7 bits - ipf = ipf + (x2pix1(ix_low)+y2pix1(iy_low)) * scale - scale = scale * scale_factor - ix = ix / 128 ! truncate out last 7 bits - iy = iy / 128 - enddo - ipf = ipf + (x2pix1(ix)+y2pix1(iy)) * scale - endif - ipix = ipf + face_num* int(nside,MKD) * nside ! in {0, 12*nside**2 - 1} - - end subroutine xy2pix_nest - - end module healpix +!--------------------------------------------------------------------------! +! 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 healpix +! +! This module sets the types used in the Fortran 90 modules (healpix_types.f90) +! of the HEALPIX distribution and follows the example of Numerical Recipes +! Benjamin D. Wandelt October 1997 +! Eric Hivon June 1998 +! Eric Hivon Oct 2001, edited to be compatible with 'F' compiler +! Eric Hivon July 2002, addition of i8b, i2b, i1b +! addition of max_i8b, max_i2b and max_i1b +! Jan 2005, explicit form of max_i1b because of ifc 8.1.021 +! June 2005, redefine i8b as 16 digit integer because of Nec f90 compiler +! Mars 2008: i8b same as i4b on machines not supporting 64 bits (NO64BITS flag set) +! Feb 2009: introduce healpix_version +! +! :References: None +! +! :Owner: Mats Esseldeurs +! +! :Runtime parameters: None +! +! :Dependencies: None +! + implicit none + character(len=*), parameter, public :: healpix_version = '3.80' + integer, parameter, public :: i4b = selected_int_kind(9) + integer, parameter, public :: i8b = selected_int_kind(16) + integer, parameter, public :: i2b = selected_int_kind(4) + integer, parameter, public :: i1b = selected_int_kind(2) + integer, parameter, public :: sp = selected_real_kind(5,30) + integer, parameter, public :: dp = selected_real_kind(12,200) + integer, parameter, public :: lgt = kind(.TRUE.) + integer, parameter, public :: spc = kind((1.0_sp, 1.0_sp)) + integer, parameter, public :: dpc = kind((1.0_dp, 1.0_dp)) + ! + integer(I8B), parameter, public :: max_i8b = huge(1_i8b) + integer, parameter, public :: max_i4b = huge(1_i4b) + integer, parameter, public :: max_i2b = huge(1_i2b) + integer, parameter, public :: max_i1b = 127 + real(kind=sp), parameter, public :: max_sp = huge(1.0_sp) + real(kind=dp), parameter, public :: max_dp = huge(1.0_dp) + + ! Numerical Constant (Double precision) + real(kind=dp), parameter, public :: QUARTPI=0.785398163397448309615660845819875721049_dp + real, parameter, public :: HALFPI= 1.570796326794896619231321691639751442099 + real, parameter, public :: PI = 3.141592653589793238462643383279502884197 + real, parameter, public :: TWOPI = 6.283185307179586476925286766559005768394 + real(kind=dp), parameter, public :: FOURPI=12.56637061435917295385057353311801153679_dp + real(kind=dp), parameter, public :: SQRT2 = 1.41421356237309504880168872420969807856967_dp + real(kind=dp), parameter, public :: EULER = 0.5772156649015328606065120900824024310422_dp + real(kind=dp), parameter, public :: SQ4PI_INV = 0.2820947917738781434740397257803862929220_dp + real(kind=dp), parameter, public :: TWOTHIRD = 0.6666666666666666666666666666666666666666_dp + + real(kind=DP), parameter, public :: RAD2DEG = 180.0_DP / PI + real(kind=DP), parameter, public :: DEG2RAD = PI / 180.0_DP + real(kind=SP), parameter, public :: hpx_sbadval = -1.6375e30_sp + real(kind=DP), parameter, public :: hpx_dbadval = -1.6375e30_dp + + ! Maximum length of filenames + integer, parameter :: filenamelen = 1024 + + + ! ! ---- Normalisation and convention ---- + ! normalisation of spin weighted functions + real(kind=dp), parameter, public :: KvS = 1.0_dp ! 1.0 : CMBFAST (Healpix 1.2) + ! ! sign of Q + ! real(kind=dp), parameter, public :: sgQ = -1.0_dp ! -1 : CMBFAST (Healpix 1.2) + ! ! sign of spin weighted function ! + ! real(kind=dp), parameter, public :: SW1 = -1.0_dp ! -1 : Healpix 1.2, bug correction + + ! ! ! normalisation of spin weighted functions + ! ! real(kind=dp), parameter, public :: KvS = 2.0_dp ! 2.0 : KKS (Healpix 1.1) + ! ! ! sign of Q + ! ! real(kind=dp), parameter, public :: sgQ = +1.0_dp ! +1 : KKS (Healpix 1.1) + ! ! ! sign of spin weighted function ! + ! ! real(kind=dp), parameter, public :: SW1 = +1.0_dp ! +1 : Healpix 1.1 + + ! real(kind=dp), parameter, public :: iKvS = 1.0_dp / KvS ! inverse of KvS + integer(kind=i4b), private, parameter :: ns_max4=8192 ! 2^13 + integer(kind=i4b), private, save, dimension(0:127) :: x2pix1=-1,y2pix1=-1 + integer(kind=i4b), private, save, dimension(0:1023) :: pix2x=-1, pix2y=-1 + integer(i4b), parameter :: oddbits=89478485 ! 2^0 + 2^2 + 2^4+..+2^26 + integer(i4b), parameter :: evenbits=178956970 ! 2^1 + 2^3 + 2^4+..+2^27 + integer(kind=i4b), private, parameter :: ns_max=268435456! 2^28 + +contains + + !! Returns i with even and odd bit positions interchanged. +function swapLSBMSB(i) + integer(i4b) :: swapLSBMSB + integer(i4b), intent(in) :: i + + swapLSBMSB = iand(i,evenbits)/2 + iand(i,oddbits)*2 +end function swapLSBMSB + + !! Returns not(i) with even and odd bit positions interchanged. +function invswapLSBMSB(i) + integer(i4b) :: invswapLSBMSB + integer(i4b), intent(in) :: i + + invswapLSBMSB = not(swapLSBMSB(i)) +end function invswapLSBMSB + + !! Returns i with odd (1,3,5,...) bits inverted. +function invLSB(i) + integer(i4b) :: invLSB + integer(i4b), intent(in) :: i + + invLSB = ieor(i,oddbits) +end function invLSB + + !! Returns i with even (0,2,4,...) bits inverted. +function invMSB(i) + integer(i4b) :: invMSB + integer(i4b), intent(in) :: i + + invMSB = ieor(i,evenbits) +end function invMSB + + !======================================================================= + ! vec2pix_nest + ! + ! renders the pixel number ipix (NESTED scheme) for a pixel which contains + ! a point on a sphere at coordinate vector (=x,y,z), given the map + ! resolution parameter nside + ! + ! 2009-03-10: calculations done directly at nside rather than ns_max + !======================================================================= +subroutine vec2pix_nest (nside, vector, ipix) + integer(i4b), parameter :: MKD = I4B + integer(kind=I4B), intent(in) :: nside + real, intent(in), dimension(1:) :: vector + integer(kind=MKD), intent(out) :: ipix + + integer(kind=MKD) :: ipf,scale,scale_factor + real(kind=DP) :: z,za,tt,tp,tmp,dnorm,phi + integer(kind=I4B) :: jp,jm,ifp,ifm,face_num,ix,iy,ix_low,iy_low,ntt,i,ismax + character(len=*), parameter :: code = "vec2pix_nest" + + !----------------------------------------------------------------------- + if (nside<1 .or. nside>ns_max4) call fatal_error(code//"> nside out of range") + dnorm = sqrt(vector(1)**2+vector(2)**2+vector(3)**2) + z = vector(3) / dnorm + phi = 0.0 + if (vector(1) /= 0.0 .or. vector(2) /= 0.0) & + & phi = atan2(vector(2),vector(1)) ! phi in ]-pi,pi] + + za = abs(z) + if (phi < 0.0) phi = phi + twopi ! phi in [0,2pi[ + tt = phi / halfpi ! in [0,4[ + if (x2pix1(127) <= 0) call mk_xy2pix1() + + if (za <= twothird) then ! equatorial region + + ! (the index of edge lines increase when the longitude=phi goes up) + jp = int(nside*(0.5_dp + tt - z*0.75_dp)) ! ascending edge line index + jm = int(nside*(0.5_dp + tt + z*0.75_dp)) ! descending edge line index + + ! finds the face + ifp = jp / nside ! in {0,4} + ifm = jm / nside + if (ifp == ifm) then ! faces 4 to 7 + face_num = iand(ifp,3) + 4 + elseif (ifp < ifm) then ! (half-)faces 0 to 3 + face_num = iand(ifp,3) + else ! (half-)faces 8 to 11 + face_num = iand(ifm,3) + 8 + endif + + ix = iand(jm, nside-1) + iy = nside - iand(jp, nside-1) - 1 + + else ! polar region, za > 2/3 + + ntt = int(tt) + if (ntt >= 4) ntt = 3 + tp = tt - ntt + !tmp = sqrt( 3.0_dp*(1.0_dp - za) ) ! in ]0,1] + tmp = sqrt(vector(1)**2+vector(2)**2) / dnorm ! sin(theta) + tmp = tmp * sqrt( 3.0_dp / (1.0_dp + za) ) !more accurate + + ! (the index of edge lines increase when distance from the closest pole goes up) + jp = int( nside * tp * tmp ) ! line going toward the pole as phi increases + jm = int( nside * (1.0_dp - tp) * tmp ) ! that one goes away of the closest pole + jp = min(nside-1, jp) ! for points too close to the boundary + jm = min(nside-1, jm) + + ! finds the face and pixel's (x,y) + if (z >= 0) then + face_num = ntt ! in {0,3} + ix = nside - jm - 1 + iy = nside - jp - 1 + else + face_num = ntt + 8 ! in {8,11} + ix = jp + iy = jm + endif + + endif + + if (nside <= ns_max4) then + ix_low = iand(ix, 127) + iy_low = iand(iy, 127) + ipf = x2pix1(ix_low) + y2pix1(iy_low) & + & + (x2pix1(ix/128) + y2pix1(iy/128)) * 16384 + else + scale = 1_MKD + scale_factor = 16384_MKD ! 128*128 + ipf = 0_MKD + ismax = 1 ! for nside in [2^14, 2^20] + if (nside > 1048576 ) ismax = 3 + do i=0, ismax + ix_low = iand(ix, 127) ! last 7 bits + iy_low = iand(iy, 127) ! last 7 bits + ipf = ipf + (x2pix1(ix_low)+y2pix1(iy_low)) * scale + scale = scale * scale_factor + ix = ix / 128 ! truncate out last 7 bits + iy = iy / 128 + enddo + ipf = ipf + (x2pix1(ix)+y2pix1(iy)) * scale + endif + ipix = ipf + face_num* int(nside,MKD) * nside ! in {0, 12*nside**2 - 1} + +end subroutine vec2pix_nest + + !======================================================================= + ! pix2vec_nest + ! + ! renders vector (x,y,z) coordinates of the nominal pixel center + ! for the pixel number ipix (NESTED scheme) + ! given the map resolution parameter nside + ! also returns the (x,y,z) position of the 4 pixel vertices (=corners) + ! in the order N,W,S,E + !======================================================================= +subroutine pix2vec_nest (nside, ipix, vector, vertex) + integer(i4b), parameter :: MKD = i4b + integer(kind=I4B), intent(in) :: nside + integer(kind=MKD), intent(in) :: ipix + real, intent(out), dimension(1:) :: vector + real, intent(out), dimension(1:,1:), optional :: vertex + + integer(kind=MKD) :: npix, npface, ipf + integer(kind=I4B) :: ip_low, ip_trunc, ip_med, ip_hi + integer(kind=I4B) :: face_num, ix, iy, kshift, scale, i, ismax + integer(kind=I4B) :: jrt, jr, nr, jpt, jp, nl4 + real :: z, fn, fact1, fact2, sth, phi + + ! coordinate of the lowest corner of each face + integer(kind=I4B), dimension(1:12) :: jrll = (/ 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4 /) ! in unit of nside + integer(kind=I4B), dimension(1:12) :: jpll = (/ 1, 3, 5, 7, 0, 2, 4, 6, 1, 3, 5, 7 /) ! in unit of nside/2 + + real :: phi_nv, phi_wv, phi_sv, phi_ev, phi_up, phi_dn, sin_phi, cos_phi + real :: z_nv, z_sv, sth_nv, sth_sv + real :: hdelta_phi + integer(kind=I4B) :: iphi_mod, iphi_rat + logical(kind=LGT) :: do_vertex + integer(kind=i4b) :: diff_phi + character(len=*), parameter :: code = "pix2vec_nest" + + !----------------------------------------------------------------------- + if (nside > ns_max4) call fatal_error(code//"> nside out of range") + npix = nside2npix(nside) ! total number of points + if (ipix <0 .or. ipix>npix-1) call fatal_error(code//"> ipix out of range") + + ! initiates the array for the pixel number -> (x,y) mapping + if (pix2x(1023) <= 0) call mk_pix2xy() + + npface = nside * int(nside, kind=MKD) + nl4 = 4*nside + + ! finds the face, and the number in the face + face_num = ipix/npface ! face number in {0,11} + ipf = modulo(ipix,npface) ! pixel number in the face {0,npface-1} + + do_vertex = .false. + if (present(vertex)) then + if (size(vertex,dim=1) >= 3 .and. size(vertex,dim=2) >= 4) then + do_vertex = .true. + else + call fatal_error(code//"> vertex array has wrong size ") + endif + endif + fn = real(nside) + fact1 = 1.0/(3.0*fn*fn) + fact2 = 2.0/(3.0*fn) + + ! finds the x,y on the face (starting from the lowest corner) + ! from the pixel number + if (nside <= ns_max4) then + ip_low = iand(ipf,1023_MKD) ! content of the last 10 bits + ip_trunc = ipf/1024 ! truncation of the last 10 bits + ip_med = iand(ip_trunc,1023) ! content of the next 10 bits + ip_hi = ip_trunc/1024 ! content of the high weight 10 bits + + ix = 1024*pix2x(ip_hi) + 32*pix2x(ip_med) + pix2x(ip_low) + iy = 1024*pix2y(ip_hi) + 32*pix2y(ip_med) + pix2y(ip_low) + else + ix = 0 + iy = 0 + scale = 1 + ismax = 4 + do i=0, ismax + ip_low = iand(ipf,1023_MKD) + ix = ix + scale * pix2x(ip_low) + iy = iy + scale * pix2y(ip_low) + scale = scale * 32 + ipf = ipf/1024 + enddo + ix = ix + scale * pix2x(ipf) + iy = iy + scale * pix2y(ipf) + endif + + ! transforms this in (horizontal, vertical) coordinates + jrt = ix + iy ! 'vertical' in {0,2*(nside-1)} + jpt = ix - iy ! 'horizontal' in {-nside+1,nside-1} + + ! computes the z coordinate on the sphere + jr = jrll(face_num+1)*nside - jrt - 1 ! ring number in {1,4*nside-1} + + z_nv = 0.; z_sv = 0. ! avoid compiler warnings + + if (jr < nside) then ! north pole region + nr = jr + z = 1. - nr*fact1*nr + sth = nr * sqrt(fact1 * (1. + z) ) ! more accurate close to pole + kshift = 0 + if (do_vertex) then + z_nv = 1. - (nr-1)*fact1*(nr-1) + z_sv = 1. - (nr+1)*fact1*(nr+1) + endif + + elseif (jr <= 3*nside) then ! equatorial region + nr = nside + z = (2*nside-jr)*fact2 + sth = sqrt((1.0-z)*(1.0+z)) ! good enough on Equator + kshift = iand(jr - nside, 1) + if (do_vertex) then + z_nv = (2*nside-jr+1)*fact2 + z_sv = (2*nside-jr-1)*fact2 + if (jr == nside) then ! northern transition + z_nv = 1.0- (nside-1) * fact1 * (nside-1) + elseif (jr == 3*nside) then ! southern transition + z_sv = -1.0 + (nside-1) * fact1 * (nside-1) + endif + endif + + elseif (jr > 3*nside) then ! south pole region + nr = nl4 - jr + z = - 1.0 + nr*fact1*nr + sth = nr * sqrt(fact1 * (1. - z) ) + kshift = 0 + if (do_vertex) then + z_nv = - 1.0 + (nr+1)*fact1*(nr+1) + z_sv = - 1.0 + (nr-1)*fact1*(nr-1) + endif + endif + + ! computes the phi coordinate on the sphere, in [0,2Pi] + jp = (jpll(face_num+1)*nr + jpt + 1_MKD + kshift)/2 ! 'phi' number in the ring in {1,4*nr} + if (jp > nl4) jp = jp - nl4 + if (jp < 1) jp = jp + nl4 + + phi = (jp - (kshift+1)*0.5) * (halfpi / nr) + + ! pixel center + ! + cos_phi = cos(phi) + sin_phi = sin(phi) + vector(1) = sth * cos_phi + vector(2) = sth * sin_phi + vector(3) = z + + if (do_vertex) then + phi_nv = phi + phi_sv = phi + diff_phi = 0 ! phi_nv = phi_sv = phisth * 1} + iphi_rat = (jp-1) / nr ! in {0,1,2,3} + iphi_mod = mod(jp-1,nr) + phi_up = 0. + if (nr > 1) phi_up = HALFPI * (iphi_rat + iphi_mod /real(nr-1)) + phi_dn = HALFPI * (iphi_rat + (iphi_mod+1)/real(nr+1)) + if (jr < nside) then ! North polar cap + phi_nv = phi_up + phi_sv = phi_dn + diff_phi = 3 ! both phi_nv and phi_sv different from phi + elseif (jr > 3*nside) then ! South polar cap + phi_nv = phi_dn + phi_sv = phi_up + diff_phi = 3 ! both phi_nv and phi_sv different from phi + elseif (jr == nside) then ! North transition + phi_nv = phi_up + diff_phi = 1 + elseif (jr == 3*nside) then ! South transition + phi_sv = phi_up + diff_phi = 2 + endif + + hdelta_phi = PI / (4.0*nr) + + ! west vertex + phi_wv = phi - hdelta_phi + vertex(1,2) = sth * cos(phi_wv) + vertex(2,2) = sth * sin(phi_wv) + vertex(3,2) = z + + ! east vertex + phi_ev = phi + hdelta_phi + vertex(1,4) = sth * cos(phi_ev) + vertex(2,4) = sth * sin(phi_ev) + vertex(3,4) = z + + ! north and south vertices + sth_nv = sqrt((1.0-z_nv)*(1.0+z_nv)) + sth_sv = sqrt((1.0-z_sv)*(1.0+z_sv)) + if (diff_phi == 0) then + vertex(1,1) = sth_nv * cos_phi + vertex(2,1) = sth_nv * sin_phi + vertex(1,3) = sth_sv * cos_phi + vertex(2,3) = sth_sv * sin_phi + else + vertex(1,1) = sth_nv * cos(phi_nv) + vertex(2,1) = sth_nv * sin(phi_nv) + vertex(1,3) = sth_sv * cos(phi_sv) + vertex(2,3) = sth_sv * sin(phi_sv) + endif + vertex(3,1) = z_nv + vertex(3,3) = z_sv + endif + +end subroutine pix2vec_nest + + !======================================================================= + ! npix2nside + ! + ! given npix, returns nside such that npix = 12*nside^2 + ! nside should be a power of 2 smaller than ns_max + ! if not, -1 is returned + ! EH, Feb-2000 + ! 2009-03-05, edited, accepts 8-byte npix + !======================================================================= +function npix2nside (npix) result(nside_result) + integer(i4b), parameter :: MKD = I4B + integer(kind=MKD), parameter :: npix_max = (12_MKD*ns_max4)*ns_max4 + integer(kind=MKD), intent(in) :: npix + integer(kind=MKD) :: npix1, npix2 + integer(kind=I4B) :: nside_result + integer(kind=I4B) :: nside + character(LEN=*), parameter :: code = "npix2nside" + !======================================================================= + + if (npix < 12 .or. npix > npix_max) then + print*, code,"> Npix=",npix, & + & " is out of allowed range: {12,",npix_max,"}" + nside_result = -1 + return + endif + + nside = nint( sqrt(npix/12.0_dp) ) + npix1 = (12_MKD*nside)*nside + if (abs(npix1-npix) > 0) then + print*, code,"> Npix=",npix, & + & " is not 12 * Nside * Nside " + nside_result = -1 + return + endif + + ! test validity of Nside + npix2 = nside2npix(nside) + if (npix2 < 0) then + nside_result = -1 + return + endif + + nside_result = nside + +end function npix2nside + + + !======================================================================= +function nside2npix(nside) result(npix_result) + !======================================================================= + ! given nside, returns npix such that npix = 12*nside^2 + ! nside should be a power of 2 smaller than ns_max + ! if not, -1 is returned + ! EH, Feb-2000 + ! 2009-03-04: returns i8b result, faster + !======================================================================= + integer(kind=I4B) :: npix_result + integer(kind=I4B), intent(in) :: nside + + integer(kind=I4B) :: npix + character(LEN=*), parameter :: code = "nside2npix" + !======================================================================= + + npix = (12_i4b*nside)*nside + if (nside < 1 .or. nside > ns_max4 .or. iand(nside-1,nside) /= 0) then + print*,code,": Nside=",nside," is not a power of 2." + npix = -1 + endif + npix_result = npix + +end function nside2npix + + !======================================================================= + ! CHEAP_ISQRT + ! Returns exact Floor(sqrt(x)) where x is a (64 bit) integer. + ! y^2 <= x < (y+1)^2 (1) + ! The double precision floating point operation is not accurate enough + ! when dealing with 64 bit integers, especially in the vicinity of + ! perfect squares. + !======================================================================= +function cheap_isqrt(lin) result (lout) + integer(i4b), intent(in) :: lin + integer(i4b) :: lout + lout = floor(sqrt(dble(lin)), kind=I4B) + return +end function cheap_isqrt + + !======================================================================= +subroutine mk_pix2xy() + !======================================================================= + ! constructs the array giving x and y in the face from pixel number + ! for the nested (quad-cube like) ordering of pixels + ! + ! the bits corresponding to x and y are interleaved in the pixel number + ! one breaks up the pixel number by even and odd bits + !======================================================================= + integer(kind=I4B) :: kpix, jpix, ix, iy, ip, id + + !cc cf block data data pix2x(1023) /0/ + !----------------------------------------------------------------------- + ! print *, 'initiate pix2xy' + do kpix=0,1023 ! pixel number + jpix = kpix + IX = 0 + IY = 0 + IP = 1 ! bit position (in x and y) + ! do while (jpix/=0) ! go through all the bits + do + if (jpix == 0) exit ! go through all the bits + ID = modulo(jpix,2) ! bit value (in kpix), goes in ix + jpix = jpix/2 + IX = ID*IP+IX + + ID = modulo(jpix,2) ! bit value (in kpix), goes in iy + jpix = jpix/2 + IY = ID*IP+IY + + IP = 2*IP ! next bit (in x and y) + enddo + pix2x(kpix) = IX ! in 0,31 + pix2y(kpix) = IY ! in 0,31 + enddo + +end subroutine mk_pix2xy + !======================================================================= +subroutine mk_xy2pix1() + !======================================================================= + ! sets the array giving the number of the pixel lying in (x,y) + ! x and y are in {1,128} + ! the pixel number is in {0,128**2-1} + ! + ! if i-1 = sum_p=0 b_p * 2^p + ! then ix = sum_p=0 b_p * 4^p + ! iy = 2*ix + ! ix + iy in {0, 128**2 -1} + !======================================================================= + integer(kind=I4B):: k,ip,i,j,id + !======================================================================= + + do i = 0,127 !for converting x,y into + j = i !pixel numbers + k = 0 + ip = 1 + + do + if (j==0) then + x2pix1(i) = k + y2pix1(i) = 2*k + exit + else + id = modulo(J,2) + j = j/2 + k = ip*id+k + ip = ip*4 + endif + enddo + enddo + +end subroutine mk_xy2pix1 + +subroutine fatal_error (msg) + character(len=*), intent(in), optional :: msg + + if (present(msg)) then + print *,'Fatal error: ', trim(msg) + else + print *,'Fatal error' + endif + call exit_with_status(1) + +end subroutine fatal_error + + ! =========================================================== +subroutine exit_with_status (code, msg) + integer(i4b), intent(in) :: code + character (len=*), intent(in), optional :: msg + + if (present(msg)) print *,trim(msg) + print *,'program exits with exit code ', code + call exit (code) + +end subroutine exit_with_status + + !==================================================================== + ! The following is a routine which finds the 7 or 8 neighbours of + ! any pixel in the nested scheme of the HEALPIX pixelisation. + !==================================================================== + ! neighbours_nest + ! + ! Returns list n(8) of neighbours of pixel ipix (in NESTED scheme) + ! the neighbours are ordered in the following way: + ! First pixel is the one to the south (the one west of the south + ! direction is taken + ! for the pixels which don't have a southern neighbour). From + ! then on the neighbours are ordered in the clockwise direction + ! about the pixel with number ipix. + ! + ! nneigh is the number of neighbours (mostly 8, 8 pixels have 7 neighbours) + ! + ! Benjamin D. Wandelt October 1997 + ! Added to pix_tools in March 1999 + ! added 'return' for case nside=1, EH, Oct 2005 + ! corrected bugs in case nside=1 and ipix=7, 9 or 11, EH, June 2006 + ! 2009-06-16: deals with Nside > 8192 + !==================================================================== +subroutine neighbours_nest(nside, ipix, n, nneigh) + ! use bit_manipulation + integer(kind=i4b), parameter :: MKD = I4B + !==================================================================== + integer(kind=i4b), intent(in):: nside + integer(kind=MKD), intent(in):: ipix + integer(kind=MKD), intent(out), dimension(1:):: n + integer(kind=i4b), intent(out):: nneigh + + integer(kind=i4b) :: ix,ixm,ixp,iy,iym,iyp,ixo,iyo + integer(kind=i4b) :: face_num,other_face + integer(kind=i4b) :: ia,ib,ibp,ibm,ib2,icase + integer(kind=MKD) :: npix,ipf,ipo + integer(kind=MKD) :: local_magic1,local_magic2,nsidesq + character(len=*), parameter :: code = "neighbours_nest" + + ! integer(kind=i4b), intrinsic :: IAND + + !-------------------------------------------------------------------- + if (nside <1 .or. nside > ns_max4) call fatal_error(code//"> nside out of range") + npix = nside2npix(nside) ! total number of points + nsidesq = npix / 12 + if (ipix <0 .or. ipix>npix-1) call fatal_error(code//"> ipix out of range") + + ! quick and dirty hack for Nside=1 + + if (nside == 1) then + nneigh = 6 + if (ipix==0 ) n(1:6) = (/ 8, 4, 3, 2, 1, 5 /) + if (ipix==1 ) n(1:6) = (/ 9, 5, 0, 3, 2, 6 /) + if (ipix==2 ) n(1:6) = (/10, 6, 1, 0, 3, 7 /) + if (ipix==3 ) n(1:6) = (/11, 7, 2, 1, 0, 4 /) + if (ipix==4 ) n(1:6) = (/11, 7, 3, 0, 5, 8 /) + if (ipix==5 ) n(1:6) = (/ 8, 4, 0, 1, 6, 9 /) + if (ipix==6 ) n(1:6) = (/ 9, 5, 1, 2, 7,10 /) + if (ipix==7 ) n(1:6) = (/10, 6, 2, 3, 4,11 /) + if (ipix==8 ) n(1:6) = (/10,11, 4, 0, 5, 9 /) + if (ipix==9 ) n(1:6) = (/11, 8, 5, 1, 6,10 /) + if (ipix==10) n(1:6) = (/ 8, 9, 6, 2, 7,11 /) + if (ipix==11) n(1:6) = (/ 9,10, 7, 3, 4, 8 /) + return + endif + + ! initiates array for (x,y)-> pixel number -> (x,y) mapping + if (x2pix1(127) <= 0) call mk_xy2pix1() + + local_magic1=(nsidesq-1)/3 + local_magic2=2*local_magic1 + face_num=ipix/nsidesq + + ipf=modulo(ipix,nsidesq) !Pixel number in face + + call pix2xy_nest(nside,ipf,ix,iy) + ixm=ix-1 + ixp=ix+1 + iym=iy-1 + iyp=iy+1 + + nneigh=8 !Except in special cases below + + ! Exclude corners + if (ipf==local_magic2) then !WestCorner + icase=5 + goto 100 + endif + if (ipf==(nsidesq-1)) then !NorthCorner + icase=6 + goto 100 + endif + if (ipf==0) then !SouthCorner + icase=7 + goto 100 + endif + if (ipf==local_magic1) then !EastCorner + icase=8 + goto 100 + endif + + ! Detect edges + if (iand(ipf,local_magic1)==local_magic1) then !NorthEast + icase=1 + goto 100 + endif + if (iand(ipf,local_magic1)==0) then !SouthWest + icase=2 + goto 100 + endif + if (iand(ipf,local_magic2)==local_magic2) then !NorthWest + icase=3 + goto 100 + endif + if (iand(ipf,local_magic2)==0) then !SouthEast + icase=4 + goto 100 + endif + + ! Inside a face + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + return + +100 continue + + ia= face_num/4 !in {0,2} + ib= modulo(face_num,4) !in {0,3} + ibp=modulo(ib+1,4) + ibm=modulo(ib+4-1,4) + ib2=modulo(ib+2,4) + + if (ia==0) then !North Pole region + select case(icase) + case(1) !NorthEast edge + other_face=0+ibp + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + ipo=modulo(swapLSBMSB(ipf),nsidesq) !East-West flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo+1 , iyo, other_face, n(5)) + n(6)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(7)) + case(2) !SouthWest edge + other_face=4+ib + ipo=modulo(invLSB(ipf),nsidesq) !SW-NE flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) + n(2)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo+1, other_face, n(3)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + case(3) !NorthWest edge + other_face=0+ibm + ipo=modulo(swapLSBMSB(ipf),nsidesq) !East-West flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(3)) + n(4)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo+1, other_face, n(5)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + case(4) !SouthEast edge + other_face=4+ibp + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + ipo=modulo(invMSB(ipf),nsidesq) !SE-NW flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo+1, iyo, other_face, n(7)) + n(8)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) + case(5) !West corner + nneigh=7 + other_face=4+ib + n(2)=other_face*nsidesq+nsidesq-1 + n(1)=n(2)-2 + other_face=0+ibm + n(3)=other_face*nsidesq+local_magic1 + n(4)=n(3)+2 + n(5)=ipix+1 + n(6)=ipix-1 + n(7)=ipix-2 + case(6) !North corner + n(1)=ipix-3 + n(2)=ipix-1 + n(8)=ipix-2 + other_face=0+ibm + n(4)=other_face*nsidesq+nsidesq-1 + n(3)=n(4)-2 + other_face=0+ib2 + n(5)=other_face*nsidesq+nsidesq-1 + other_face=0+ibp + n(6)=other_face*nsidesq+nsidesq-1 + n(7)=n(6)-1 + case(7) !South corner + other_face=8+ib + n(1)=other_face*nsidesq+nsidesq-1 + other_face=4+ib + n(2)=other_face*nsidesq+local_magic1 + n(3)=n(2)+2 + n(4)=ipix+2 + n(5)=ipix+3 + n(6)=ipix+1 + other_face=4+ibp + n(8)=other_face*nsidesq+local_magic2 + n(7)=n(8)+1 + case(8) !East corner + nneigh=7 + n(2)=ipix-1 + n(3)=ipix+1 + n(4)=ipix+2 + other_face=0+ibp + n(6)=other_face*nsidesq+local_magic2 + n(5)=n(6)+1 + other_face=4+ibp + n(7)=other_face*nsidesq+nsidesq-1 + n(1)=n(7)-1 + end select ! north + + elseif (ia==1) then !Equatorial region + select case(icase) + case(1) !NorthEast edge + other_face=0+ib + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + ipo=modulo(invLSB(ipf),nsidesq) !NE-SW flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo , iyo+1, other_face, n(5)) + n(6)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(7)) + case(2) !SouthWest edge + other_face=8+ibm + ipo=modulo(invLSB(ipf),nsidesq) !SW-NE flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) + n(2)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo+1, other_face, n(3)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + case(3) !NorthWest edge + other_face=0+ibm + ipo=modulo(invMSB(ipf),nsidesq) !NW-SE flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(3)) + n(4)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo+1, iyo, other_face, n(5)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + case(4) !SouthEast edge + other_face=8+ib + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + ipo=modulo(invMSB(ipf),nsidesq) !SE-NW flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo+1, iyo, other_face, n(7)) + n(8)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) + case(5) !West corner + other_face=8+ibm + n(2)=other_face*nsidesq+nsidesq-1 + n(1)=n(2)-2 + other_face=4+ibm + n(3)=other_face*nsidesq+local_magic1 + other_face=0+ibm + n(4)=other_face*nsidesq + n(5)=n(4)+1 + n(6)=ipix+1 + n(7)=ipix-1 + n(8)=ipix-2 + case(6) !North corner + nneigh=7 + n(1)=ipix-3 + n(2)=ipix-1 + other_face=0+ibm + n(4)=other_face*nsidesq+local_magic1 + n(3)=n(4)-1 + other_face=0+ib + n(5)=other_face*nsidesq+local_magic2 + n(6)=n(5)-2 + n(7)=ipix-2 + case(7) !South corner + nneigh=7 + other_face=8+ibm + n(1)=other_face*nsidesq+local_magic1 + n(2)=n(1)+2 + n(3)=ipix+2 + n(4)=ipix+3 + n(5)=ipix+1 + other_face=8+ib + n(7)=other_face*nsidesq+local_magic2 + n(6)=n(7)+1 + case(8) !East corner + other_face=8+ib + n(8)=other_face*nsidesq+nsidesq-1 + n(1)=n(8)-1 + n(2)=ipix-1 + n(3)=ipix+1 + n(4)=ipix+2 + other_face=0+ib + n(6)=other_face*nsidesq + n(5)=n(6)+2 + other_face=4+ibp + n(7)=other_face*nsidesq+local_magic2 + end select ! equator + else !South Pole region + select case(icase) + case(1) !NorthEast edge + other_face=4+ibp + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + ipo=modulo(invLSB(ipf),nsidesq) !NE-SW flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo , iyo+1, other_face, n(5)) + n(6)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(7)) + case(2) !SouthWest edge + other_face=8+ibm + ipo=modulo(swapLSBMSB(ipf),nsidesq) !W-E flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(1)) + n(2)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo+1, iyo, other_face, n(3)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + case(3) !NorthWest edge + other_face=4+ib + ipo=modulo(invMSB(ipf),nsidesq) !NW-SE flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo-1, iyo, other_face, n(3)) + n(4)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo+1, iyo, other_face, n(5)) + call xy2pix_nest(nside, ixm, iym, face_num, n(1)) + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ix , iym, face_num, n(8)) + call xy2pix_nest(nside, ixp, iym, face_num, n(7)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + case(4) !SouthEast edge + other_face=8+ibp + call xy2pix_nest(nside, ixm, iy , face_num, n(2)) + call xy2pix_nest(nside, ixm, iyp, face_num, n(3)) + call xy2pix_nest(nside, ix , iyp, face_num, n(4)) + call xy2pix_nest(nside, ixp, iyp, face_num, n(5)) + call xy2pix_nest(nside, ixp, iy , face_num, n(6)) + ipo=modulo(swapLSBMSB(ipf),nsidesq) !E-W flip + call pix2xy_nest(nside,ipo,ixo,iyo) + call xy2pix_nest(nside, ixo, iyo+1, other_face, n(7)) + n(8)=other_face*nsidesq+ipo + call xy2pix_nest(nside, ixo, iyo-1, other_face, n(1)) + case(5) !West corner + nneigh=7 + other_face=8+ibm + n(2)=other_face*nsidesq+local_magic1 + n(1)=n(2)-1 + other_face=4+ib + n(3)=other_face*nsidesq + n(4)=n(3)+1 + n(5)=ipix+1 + n(6)=ipix-1 + n(7)=ipix-2 + case(6) !North corner + n(1)=ipix-3 + n(2)=ipix-1 + other_face=4+ib + n(4)=other_face*nsidesq+local_magic1 + n(3)=n(4)-1 + other_face=0+ib + n(5)=other_face*nsidesq + other_face=4+ibp + n(6)=other_face*nsidesq+local_magic2 + n(7)=n(6)-2 + n(8)=ipix-2 + case(7) !South corner + other_face=8+ib2 + n(1)=other_face*nsidesq + other_face=8+ibm + n(2)=other_face*nsidesq + n(3)=n(2)+1 + n(4)=ipix+2 + n(5)=ipix+3 + n(6)=ipix+1 + other_face=8+ibp + n(8)=other_face*nsidesq + n(7)=n(8)+2 + case(8) !East corner + nneigh=7 + other_face=8+ibp + n(7)=other_face*nsidesq+local_magic2 + n(1)=n(7)-2 + n(2)=ipix-1 + n(3)=ipix+1 + n(4)=ipix+2 + other_face=4+ibp + n(6)=other_face*nsidesq + n(5)=n(6)+2 + end select ! south + endif + +end subroutine neighbours_nest + + + !======================================================================= + ! pix2xy_nest + ! gives the x, y coords in a face from pixel number within the face (NESTED) + ! + ! Benjamin D. Wandelt 13/10/97 + ! + ! using code from HEALPIX toolkit by K.Gorski and E. Hivon + ! 2009-06-15: deals with Nside > 8192 + ! 2012-03-02: test validity of ipf_in instead of undefined ipf + ! define ipf as MKD + ! 2012-08-27: corrected bug on (ix,iy) for Nside > 8192 (MARK) + !======================================================================= +subroutine pix2xy_nest (nside, ipf_in, ix, iy) + integer(kind=i4b), parameter :: MKD = I4B + integer(kind=I4B), intent(in) :: nside + integer(kind=MKD), intent(in) :: ipf_in + integer(kind=I4B), intent(out) :: ix, iy + + integer(kind=MKD) :: ipf + integer(kind=I4B) :: ip_low, ip_trunc, ip_med, ip_hi, scale, i, ismax + character(len=*), parameter :: code = "pix2xy_nest" + + !----------------------------------------------------------------------- + if (nside<1 .or. nside>ns_max) call fatal_error(code//"> nside out of range") + if (ipf_in<0 .or. ipf_in>nside*nside-1) & + & call fatal_error(code//"> ipix out of range") + if (pix2x(1023) <= 0) call mk_pix2xy() + + ipf = ipf_in + if (nside <= ns_max4) then + ip_low = iand(ipf,1023_MKD) ! content of the last 10 bits + ip_trunc = ipf/1024 ! truncation of the last 10 bits + ip_med = iand(ip_trunc,1023) ! content of the next 10 bits + ip_hi = ip_trunc/1024 ! content of the high weight 10 bits + + ix = 1024*pix2x(ip_hi) + 32*pix2x(ip_med) + pix2x(ip_low) + iy = 1024*pix2y(ip_hi) + 32*pix2y(ip_med) + pix2y(ip_low) + else + ix = 0 + iy = 0 + scale = 1 + ismax = 4 + do i=0, ismax + ip_low = iand(ipf,1023_MKD) + ix = ix + scale * pix2x(ip_low) + iy = iy + scale * pix2y(ip_low) ! corrected 2012-08-27 + scale = scale * 32 + ipf = ipf/1024 + enddo + ix = ix + scale * pix2x(ipf) + iy = iy + scale * pix2y(ipf) ! corrected 2012-08-27 + endif + +end subroutine pix2xy_nest + + !======================================================================= + ! gives the pixel number ipix (NESTED) + ! corresponding to ix, iy and face_num + ! + ! Benjamin D. Wandelt 13/10/97 + ! using code from HEALPIX toolkit by K.Gorski and E. Hivon + ! 2009-06-15: deals with Nside > 8192 + ! 2012-03-02: test validity of ix_in and iy_in instead of undefined ix and iy + !======================================================================= +subroutine xy2pix_nest(nside, ix_in, iy_in, face_num, ipix) + integer(kind=i4b), parameter :: MKD = I4B + !======================================================================= + integer(kind=I4B), intent(in) :: nside, ix_in, iy_in, face_num + integer(kind=MKD), intent(out) :: ipix + integer(kind=I4B) :: ix, iy, ix_low, iy_low, i, ismax + integer(kind=MKD) :: ipf, scale, scale_factor + character(len=*), parameter :: code = "xy2pix_nest" + + !----------------------------------------------------------------------- + if (nside<1 .or. nside>ns_max) call fatal_error(code//"> nside out of range") + if (ix_in<0 .or. ix_in>(nside-1)) call fatal_error(code//"> ix out of range") + if (iy_in<0 .or. iy_in>(nside-1)) call fatal_error(code//"> iy out of range") + if (x2pix1(127) <= 0) call mk_xy2pix1() + + ix = ix_in + iy = iy_in + if (nside <= ns_max4) then + ix_low = iand(ix, 127) + iy_low = iand(iy, 127) + ipf = x2pix1(ix_low) + y2pix1(iy_low) & + & + (x2pix1(ix/128) + y2pix1(iy/128)) * 16384 + else + scale = 1_MKD + scale_factor = 16384_MKD ! 128*128 + ipf = 0_MKD + ismax = 1 ! for nside in [2^14, 2^20] + if (nside > 1048576 ) ismax = 3 + do i=0, ismax + ix_low = iand(ix, 127) ! last 7 bits + iy_low = iand(iy, 127) ! last 7 bits + ipf = ipf + (x2pix1(ix_low)+y2pix1(iy_low)) * scale + scale = scale * scale_factor + ix = ix / 128 ! truncate out last 7 bits + iy = iy / 128 + enddo + ipf = ipf + (x2pix1(ix)+y2pix1(iy)) * scale + endif + ipix = ipf + face_num* int(nside,MKD) * nside ! in {0, 12*nside**2 - 1} + +end subroutine xy2pix_nest + +end module healpix diff --git a/src/main/utils_raytracer.f90 b/src/main/utils_raytracer.f90 index fe45fd581..c5c77843c 100644 --- a/src/main/utils_raytracer.f90 +++ b/src/main/utils_raytracer.f90 @@ -6,7 +6,11 @@ !--------------------------------------------------------------------------! module raytracer ! -! raytracer +! This module contains all routines required to: +! - perform radial ray tracing starting from the primary star only +! - calculate optical depth along the rays given the opacity distribution +! - interpolate optical depths to all SPH particles +! Applicable both for single and binary star wind simulations ! ! :References: None ! diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index 79554e574..761fb5a17 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.f90 @@ -1,692 +1,692 @@ - !--------------------------------------------------------------------------! - ! 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 analysis - ! - ! Analysis routine which computes neighbour lists for all particles - ! - ! :References: None - ! - ! :Owner: Lionel Siess - ! - ! :Runtime parameters: None - ! - ! :Dependencies: dump_utils, dust_formation, getneighbours, linklist, - ! omp_lib, part, physcon, raytracer, raytracer_all - ! - use raytracer_all, only:get_all_tau_inwards, get_all_tau_outwards, get_all_tau_adaptive - use raytracer, only:get_all_tau - use part, only:rhoh,isdead_or_accreted,nsinkproperties,iReff - use dump_utils, only:read_array_from_file - use getneighbours, only:generate_neighbour_lists, read_neighbours, write_neighbours, & +!--------------------------------------------------------------------------! +! 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 analysis +! +! Analysis routine which computes neighbour lists for all particles +! +! :References: None +! +! :Owner: Mats Esseldeurs +! +! :Runtime parameters: None +! +! :Dependencies: dump_utils, dust_formation, getneighbours, linklist, +! omp_lib, part, physcon, raytracer, raytracer_all +! + use raytracer_all, only:get_all_tau_inwards, get_all_tau_outwards, get_all_tau_adaptive + use raytracer, only:get_all_tau + use part, only:rhoh,isdead_or_accreted,nsinkproperties,iReff + use dump_utils, only:read_array_from_file + use getneighbours, only:generate_neighbour_lists, read_neighbours, write_neighbours, & neighcount,neighb,neighmax - use dust_formation, only:calc_kappa_bowen - use physcon, only:kboltz,mass_proton_cgs,au,solarm - use linklist, only:set_linklist,allocate_linklist,deallocate_linklist + use dust_formation, only:calc_kappa_bowen + use physcon, only:kboltz,mass_proton_cgs,au,solarm + use linklist, only:set_linklist,allocate_linklist,deallocate_linklist - implicit none + implicit none - character(len=20), parameter, public :: analysistype = 'raytracer' - real :: gamma = 1.2 - real :: mu = 2.381 - public :: do_analysis + character(len=20), parameter, public :: analysistype = 'raytracer' + real :: gamma = 1.2 + real :: mu = 2.381 + public :: do_analysis - private + private - contains +contains - subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) - use omp_lib +subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) + use omp_lib - character(len=*), intent(in) :: dumpfile - integer, intent(in) :: num,npart,iunit - real(kind=8), intent(in) :: xyzh(:,:),vxyzu(:,:) - real(kind=8), intent(in) :: particlemass,time + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: num,npart,iunit + real(kind=8), intent(in) :: xyzh(:,:),vxyzu(:,:) + real(kind=8), intent(in) :: particlemass,time - logical :: existneigh - character(100) :: neighbourfile - character(100) :: jstring, kstring - real :: primsec(4,2), rho(npart), kappa(npart), temp(npart), u(npart), & + logical :: existneigh + character(100) :: neighbourfile + character(100) :: jstring, kstring + real :: primsec(4,2), rho(npart), kappa(npart), temp(npart), u(npart), & xyzh2(4,npart), vxyzu2(4,npart), xyzmh_ptmass(nsinkproperties,2) - real, dimension(:), allocatable :: tau - integer :: i,j,k,ierr,iu1,iu2,iu3,iu4, npart2!,iu - integer :: start, finish, method, analyses, minOrder, maxOrder, order, raypolation, refineScheme - real :: totalTime, timeTau, Rstar, Rcomp, times(30) - logical :: SPH = .true., calcInwards = .false. - - real, parameter :: udist = au, umass = solarm - - Rstar = 2.37686663 - Rcomp = 0.1 - xyzmh_ptmass = 0. - xyzmh_ptmass(iReff,1) = Rstar - xyzmh_ptmass(iReff,2) = Rcomp - - print*,'("Reading kappa from file")' - call read_array_from_file(123,dumpfile,'kappa',kappa(:),ierr, 1) - if (ierr/=0) then - print*,'' - print*,'("WARNING: could not read kappa from file. It will be set to zero")' - print*,'' - kappa = 0. - endif - - if (kappa(1) <= 0. .and. kappa(2) <= 0. .and. kappa(2) <= 0.) then - print*,'("Reading temperature from file")' - call read_array_from_file(123,dumpfile,'temperature',temp(:),ierr, 1) - if (temp(1) <= 0. .and. temp(2) <= 0. .and. temp(2) <= 0.) then - print*,'("Reading internal energy from file")' - call read_array_from_file(123,dumpfile,'u',u(:),ierr, 1) - do i=1,npart - temp(i)=(gamma-1.)*mu*u(i)*mass_proton_cgs*kboltz - enddo - endif - do i=1,npart - kappa(i)=calc_kappa_bowen(temp(i)) - enddo - endif - - j=1 - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - xyzh2(:,j) = xyzh(:,i) - vxyzu2(:,j) = vxyzu(:,i) - kappa(j) = kappa(i) - j=j+1 - endif - enddo - npart2 = j-1 - call set_linklist(npart2,npart2,xyzh2,vxyzu) - print*,'npart = ',npart2 - allocate(tau(npart2)) - - !get position of sink particles (stars) - call read_array_from_file(123,dumpfile,'x',primsec(1,:),ierr, 2) - call read_array_from_file(123,dumpfile,'y',primsec(2,:),ierr, 2) - call read_array_from_file(123,dumpfile,'z',primsec(3,:),ierr, 2) - call read_array_from_file(123,dumpfile,'h',primsec(4,:),ierr, 2) - if (primsec(1,1) == xyzh(1,1) .and. primsec(2,1) == xyzh(2,1) .and. primsec(3,1) == xyzh(3,1)) then - primsec(:,1) = (/0.,0.,0.,1./) - endif - xyzmh_ptmass(1:4,1) = primsec(:,1) - xyzmh_ptmass(1:4,2) = primsec(:,2) - - - print *,'What do you want to do?' - print *, '(1) Analysis' - print *, '(2) Integration method' - print *, '(3) Calculate tau as done in realtime in PHANTOM' - print *, '(4) Preloaded settings' - print *, '(5) Print out points' - read *,analyses - ! analyses=4 - - if (analyses == 1) then - print *,'Which analysis would you like to run?' - print *, '(1) Inward Integration' - print *, '(2) Outward Integration (realtime)' - print *, '(3) Outward Integration (interpolation)' - print *, '(4) Outward Integration (interpolation-all)' - print *, '(5) Adaptive (Outward) Integration' - print *, '(6) Scaling' - print *, '(7) Time evolution for mutiple files' - read *,method - if (method == 1) then - SPH = .false. - elseif (method == 2) then - SPH = .false. - print *,'At which order would you like to start?' - read *,minOrder - print *,'At which order would you like to stop?' - read *,maxOrder - elseif (method == 3) then - print *,'At which order would you like to start?' - read *,minOrder - print *,'At which order would you like to stop?' - read *,maxOrder - print *,'What interpolation scheme would you like to use' - print *,'(0) 1 ray, no interpolation' - print *,'(1) 4 rays, linear interpolation' - print *,'(2) 9 rays, linear interpolation' - print *,'(3) 4 rays, square interpolation' - print *,'(4) 9 rays, square interpolation' - print *,'(5) 4 rays, cubed interpolation' - print *,'(6) 9 rays, cubed interpolation' - read*,raypolation - elseif (method == 4) then - SPH = .false. - calcInwards = .false. - print *,'At which order would you like to start?' - read *,minOrder - print *,'At which order would you like to stop?' - read *,maxOrder - elseif (method == 5) then - print *,'At which order would you like to start?' - read *,minOrder - print *,'At which order would you like to stop?' - read *,maxOrder - print *,'What refinement scheme would you like to use' - print *,'(1) refine half' - print *,'(2) refine overdens' - print *,'(0) all the above' - read *,refineScheme - elseif (method == 6) then - - elseif (method == 7) then - - endif - elseif (analyses == 2) then - print *,'Which algorithm would you like to run?' - print *, '(1) Inward' - print *, '(2) Outward (realtime)' - print *, '(3) Outward (interpolation)' - print *, '(4) Adaptive' - read *,method - if (method == 1) then - print *,'Do you want to use SPH neighbours? (T/F)' - read*,SPH - elseif (method == 2) then - print *,'What order do you want to run?' - read*,j - write(jstring,'(i0)') j - elseif (method == 3) then - print *,'What order do you want to run?' - read*,j - write(jstring,'(i0)') j - print *,'What interpolation scheme would you like to use' - print *,'(0) 1 ray, no interpolation' - print *,'(1) 4 rays, linear interpolation' - print *,'(2) 9 rays, linear interpolation' - print *,'(3) 4 rays, square interpolation' - print *,'(4) 9 rays, square interpolation' - print *,'(5) 4 rays, cubed interpolation' - print *,'(6) 9 rays, cubed interpolation' - read*,raypolation - write(kstring,'(i0)') raypolation - elseif (method == 4) then - print *,'What order do you want to run? (integer below 7)' - read*,j - write(jstring,'(i0)') j - print *,'What refinement level do you want to run? (integer below 7)' - read*,k - write(kstring,'(i0)') k - print *,'What refinement scheme would you like to use' - print *,'(1) refine half' - print *,'(2) refine overdens' - print *,'(0) all the above' - read *,refineScheme - endif - endif - - if (analyses == 2 .and. method==1) then ! get neighbours - if (SPH) then - neighbourfile = 'neigh_'//TRIM(dumpfile) - inquire(file=neighbourfile,exist = existneigh) - if (existneigh) then - print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' - call read_neighbours(neighbourfile,npart2) - else - ! If there is no neighbour file, generate the list - print*, 'No neighbour file found: generating' - call system_clock(start) - call generate_neighbour_lists(xyzh2,vxyzu2,npart2,dumpfile, .false.) - call system_clock(finish) - totalTime = (finish-start)/1000. - print*,'Time = ',totalTime,' seconds.' - call write_neighbours(neighbourfile, npart2) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) - endif - else - allocate(neighb(npart2+2,100)) - neighb = 0 - inquire(file='neighbors_tess.txt',exist = existneigh) - if (existneigh) then - print*, 'Neighbour file neighbors.txt found' - else - call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') - endif - open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') - do i=1, npart2+2 - read(iu4,*) neighb(i,:) - enddo - close(iu4) - endif - endif - - if (analyses == 1) then - - ! INWARD INTEGRATION ANALYSIS - if (method == 1) then - neighbourfile = 'neigh_'//TRIM(dumpfile) - inquire(file=neighbourfile,exist = existneigh) - if (existneigh) then - print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' - call read_neighbours(neighbourfile,npart2) - else - ! If there is no neighbour file, generate the list - print*, 'No neighbour file found: generating' - call system_clock(start) - call generate_neighbour_lists(xyzh2,vxyzu2,npart2,dumpfile, .false.) - call system_clock(finish) - totalTime = (finish-start)/1000. - print*,'Time = ',totalTime,' seconds.' - call write_neighbours(neighbourfile, npart2) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) - endif - print*,'' - print*, 'Start calculating optical depth inward SPH' - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt', status='replace', action='write') - write(iu4, *) timeTau - close(iu4) - totalTime = timeTau - open(newunit=iu2, file='taus_inwards_SPH_'//dumpfile//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - deallocate(neighb) - allocate(neighb(npart2+2,100)) - neighb = 0 - inquire(file='neighbors_tess.txt',exist = existneigh) - if (existneigh) then - print*, 'Delaunay neighbour file neighbours.txt found' - else - call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') - endif - open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') - do i=1, npart2+2 - read(iu4,*) neighb(i,:) - enddo - close(iu4) - print*,'' - print*, 'Start calculating optical depth inward Delaunay' - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt',position='append', status='old', action='write') - write(iu4, *) timeTau - close(iu4) - totalTime = timeTau - open(newunit=iu2, file='taus_inwards_Del_'//dumpfile//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - - ! OUTWARD INTEGRATION realTIME ANALYSIS - elseif (method == 2) then - open(newunit=iu4, file='times_'//dumpfile//'.txt', status='replace', action='write') - close(iu4) - totalTime=0 - - do j = minOrder, maxOrder - write(jstring,'(i0)') j - print*,'' - print*, 'Start calculating optical depth outward: ', trim(jstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, j, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, j, tau) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_'//dumpfile//'.txt',position='append', status='old', action='write') - write(iu4, *) timeTau - close(iu4) - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - enddo - print*,'' - print*,'Total time of the calculation = ',totalTime,' seconds.' - - ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS - elseif (method == 3) then - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') - close(iu4) - totalTime=0 - - do j = minOrder, maxOrder - write(jstring,'(i0)') j - print*,'' - print*, 'Start calculating optical depth outward: ', trim(jstring),', interpolation: ', trim(kstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') - write(iu4, *) timeTau - close(iu4) - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & + real, dimension(:), allocatable :: tau + integer :: i,j,k,ierr,iu1,iu2,iu3,iu4, npart2!,iu + integer :: start, finish, method, analyses, minOrder, maxOrder, order, raypolation, refineScheme + real :: totalTime, timeTau, Rstar, Rcomp, times(30) + logical :: SPH = .true., calcInwards = .false. + + real, parameter :: udist = au, umass = solarm + + Rstar = 2.37686663 + Rcomp = 0.1 + xyzmh_ptmass = 0. + xyzmh_ptmass(iReff,1) = Rstar + xyzmh_ptmass(iReff,2) = Rcomp + + print*,'("Reading kappa from file")' + call read_array_from_file(123,dumpfile,'kappa',kappa(:),ierr, 1) + if (ierr/=0) then + print*,'' + print*,'("WARNING: could not read kappa from file. It will be set to zero")' + print*,'' + kappa = 0. + endif + + if (kappa(1) <= 0. .and. kappa(2) <= 0. .and. kappa(2) <= 0.) then + print*,'("Reading temperature from file")' + call read_array_from_file(123,dumpfile,'temperature',temp(:),ierr, 1) + if (temp(1) <= 0. .and. temp(2) <= 0. .and. temp(2) <= 0.) then + print*,'("Reading internal energy from file")' + call read_array_from_file(123,dumpfile,'u',u(:),ierr, 1) + do i=1,npart + temp(i)=(gamma-1.)*mu*u(i)*mass_proton_cgs*kboltz + enddo + endif + do i=1,npart + kappa(i)=calc_kappa_bowen(temp(i)) + enddo + endif + + j=1 + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + xyzh2(:,j) = xyzh(:,i) + vxyzu2(:,j) = vxyzu(:,i) + kappa(j) = kappa(i) + j=j+1 + endif + enddo + npart2 = j-1 + call set_linklist(npart2,npart2,xyzh2,vxyzu) + print*,'npart = ',npart2 + allocate(tau(npart2)) + + !get position of sink particles (stars) + call read_array_from_file(123,dumpfile,'x',primsec(1,:),ierr, 2) + call read_array_from_file(123,dumpfile,'y',primsec(2,:),ierr, 2) + call read_array_from_file(123,dumpfile,'z',primsec(3,:),ierr, 2) + call read_array_from_file(123,dumpfile,'h',primsec(4,:),ierr, 2) + if (primsec(1,1) == xyzh(1,1) .and. primsec(2,1) == xyzh(2,1) .and. primsec(3,1) == xyzh(3,1)) then + primsec(:,1) = (/0.,0.,0.,1./) + endif + xyzmh_ptmass(1:4,1) = primsec(:,1) + xyzmh_ptmass(1:4,2) = primsec(:,2) + + + print *,'What do you want to do?' + print *, '(1) Analysis' + print *, '(2) Integration method' + print *, '(3) Calculate tau as done in realtime in PHANTOM' + print *, '(4) Preloaded settings' + print *, '(5) Print out points' + read *,analyses + ! analyses=4 + + if (analyses == 1) then + print *,'Which analysis would you like to run?' + print *, '(1) Inward Integration' + print *, '(2) Outward Integration (realtime)' + print *, '(3) Outward Integration (interpolation)' + print *, '(4) Outward Integration (interpolation-all)' + print *, '(5) Adaptive (Outward) Integration' + print *, '(6) Scaling' + print *, '(7) Time evolution for mutiple files' + read *,method + if (method == 1) then + SPH = .false. + elseif (method == 2) then + SPH = .false. + print *,'At which order would you like to start?' + read *,minOrder + print *,'At which order would you like to stop?' + read *,maxOrder + elseif (method == 3) then + print *,'At which order would you like to start?' + read *,minOrder + print *,'At which order would you like to stop?' + read *,maxOrder + print *,'What interpolation scheme would you like to use' + print *,'(0) 1 ray, no interpolation' + print *,'(1) 4 rays, linear interpolation' + print *,'(2) 9 rays, linear interpolation' + print *,'(3) 4 rays, square interpolation' + print *,'(4) 9 rays, square interpolation' + print *,'(5) 4 rays, cubed interpolation' + print *,'(6) 9 rays, cubed interpolation' + read*,raypolation + elseif (method == 4) then + SPH = .false. + calcInwards = .false. + print *,'At which order would you like to start?' + read *,minOrder + print *,'At which order would you like to stop?' + read *,maxOrder + elseif (method == 5) then + print *,'At which order would you like to start?' + read *,minOrder + print *,'At which order would you like to stop?' + read *,maxOrder + print *,'What refinement scheme would you like to use' + print *,'(1) refine half' + print *,'(2) refine overdens' + print *,'(0) all the above' + read *,refineScheme + elseif (method == 6) then + + elseif (method == 7) then + + endif + elseif (analyses == 2) then + print *,'Which algorithm would you like to run?' + print *, '(1) Inward' + print *, '(2) Outward (realtime)' + print *, '(3) Outward (interpolation)' + print *, '(4) Adaptive' + read *,method + if (method == 1) then + print *,'Do you want to use SPH neighbours? (T/F)' + read*,SPH + elseif (method == 2) then + print *,'What order do you want to run?' + read*,j + write(jstring,'(i0)') j + elseif (method == 3) then + print *,'What order do you want to run?' + read*,j + write(jstring,'(i0)') j + print *,'What interpolation scheme would you like to use' + print *,'(0) 1 ray, no interpolation' + print *,'(1) 4 rays, linear interpolation' + print *,'(2) 9 rays, linear interpolation' + print *,'(3) 4 rays, square interpolation' + print *,'(4) 9 rays, square interpolation' + print *,'(5) 4 rays, cubed interpolation' + print *,'(6) 9 rays, cubed interpolation' + read*,raypolation + write(kstring,'(i0)') raypolation + elseif (method == 4) then + print *,'What order do you want to run? (integer below 7)' + read*,j + write(jstring,'(i0)') j + print *,'What refinement level do you want to run? (integer below 7)' + read*,k + write(kstring,'(i0)') k + print *,'What refinement scheme would you like to use' + print *,'(1) refine half' + print *,'(2) refine overdens' + print *,'(0) all the above' + read *,refineScheme + endif + endif + + if (analyses == 2 .and. method==1) then ! get neighbours + if (SPH) then + neighbourfile = 'neigh_'//TRIM(dumpfile) + inquire(file=neighbourfile,exist = existneigh) + if (existneigh) then + print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' + call read_neighbours(neighbourfile,npart2) + else + ! If there is no neighbour file, generate the list + print*, 'No neighbour file found: generating' + call system_clock(start) + call generate_neighbour_lists(xyzh2,vxyzu2,npart2,dumpfile, .false.) + call system_clock(finish) + totalTime = (finish-start)/1000. + print*,'Time = ',totalTime,' seconds.' + call write_neighbours(neighbourfile, npart2) + print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + endif + else + allocate(neighb(npart2+2,100)) + neighb = 0 + inquire(file='neighbors_tess.txt',exist = existneigh) + if (existneigh) then + print*, 'Neighbour file neighbors.txt found' + else + call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') + endif + open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + do i=1, npart2+2 + read(iu4,*) neighb(i,:) + enddo + close(iu4) + endif + endif + + if (analyses == 1) then + + ! INWARD INTEGRATION ANALYSIS + if (method == 1) then + neighbourfile = 'neigh_'//TRIM(dumpfile) + inquire(file=neighbourfile,exist = existneigh) + if (existneigh) then + print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' + call read_neighbours(neighbourfile,npart2) + else + ! If there is no neighbour file, generate the list + print*, 'No neighbour file found: generating' + call system_clock(start) + call generate_neighbour_lists(xyzh2,vxyzu2,npart2,dumpfile, .false.) + call system_clock(finish) + totalTime = (finish-start)/1000. + print*,'Time = ',totalTime,' seconds.' + call write_neighbours(neighbourfile, npart2) + print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + endif + print*,'' + print*, 'Start calculating optical depth inward SPH' + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt', status='replace', action='write') + write(iu4, *) timeTau + close(iu4) + totalTime = timeTau + open(newunit=iu2, file='taus_inwards_SPH_'//dumpfile//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + deallocate(neighb) + allocate(neighb(npart2+2,100)) + neighb = 0 + inquire(file='neighbors_tess.txt',exist = existneigh) + if (existneigh) then + print*, 'Delaunay neighbour file neighbours.txt found' + else + call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') + endif + open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + do i=1, npart2+2 + read(iu4,*) neighb(i,:) + enddo + close(iu4) + print*,'' + print*, 'Start calculating optical depth inward Delaunay' + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt',position='append', status='old', action='write') + write(iu4, *) timeTau + close(iu4) + totalTime = timeTau + open(newunit=iu2, file='taus_inwards_Del_'//dumpfile//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + + ! OUTWARD INTEGRATION realTIME ANALYSIS + elseif (method == 2) then + open(newunit=iu4, file='times_'//dumpfile//'.txt', status='replace', action='write') + close(iu4) + totalTime=0 + + do j = minOrder, maxOrder + write(jstring,'(i0)') j + print*,'' + print*, 'Start calculating optical depth outward: ', trim(jstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, j, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, j, tau) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu4, file='times_'//dumpfile//'.txt',position='append', status='old', action='write') + write(iu4, *) timeTau + close(iu4) + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + enddo + print*,'' + print*,'Total time of the calculation = ',totalTime,' seconds.' + + ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS + elseif (method == 3) then + open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') + close(iu4) + totalTime=0 + + do j = minOrder, maxOrder + write(jstring,'(i0)') j + print*,'' + print*, 'Start calculating optical depth outward: ', trim(jstring),', interpolation: ', trim(kstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') + write(iu4, *) timeTau + close(iu4) + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - enddo - print*,'' - print*,'Total time of the calculation = ',totalTime,' seconds.' - - ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS - elseif (method == 4) then - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') - close(iu4) - totalTime=0 - - do j = minOrder, maxOrder - do k = 0, 6 - write(jstring,'(i0)') j - write(kstring,'(i0)') k - print*,'' - print*, 'Start calculating optical depth outward: ', trim(jstring),', interpolation: ', trim(kstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - times(k+1) = timeTau - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + enddo + print*,'' + print*,'Total time of the calculation = ',totalTime,' seconds.' + + ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS + elseif (method == 4) then + open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') + close(iu4) + totalTime=0 + + do j = minOrder, maxOrder + do k = 0, 6 + write(jstring,'(i0)') j + write(kstring,'(i0)') k + print*,'' + print*, 'Start calculating optical depth outward: ', trim(jstring),', interpolation: ', trim(kstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + times(k+1) = timeTau + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - enddo - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') - write(iu4, *) times(1:7) - close(iu4) - enddo - print*,'' - print*,'Total time of the calculation = ',totalTime,' seconds.' - - !ADAPTIVE (OUTWARD) INTEGRATION ANALYSIS - elseif (method == 5) then - open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt', status='replace', action='write') - close(iu4) - totalTime=0 - - do j = minOrder, maxOrder - write(jstring,'(i0)') j - times = 0. - do k = minOrder,maxOrder-j - write(kstring,'(i0)') k - print*,'' - print*, 'Start calculating optical depth outward: minOrder = ', trim(jstring),', refineLevel = ', trim(kstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme,& + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + enddo + open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') + write(iu4, *) times(1:7) + close(iu4) + enddo + print*,'' + print*,'Total time of the calculation = ',totalTime,' seconds.' + + !ADAPTIVE (OUTWARD) INTEGRATION ANALYSIS + elseif (method == 5) then + open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt', status='replace', action='write') + close(iu4) + totalTime=0 + + do j = minOrder, maxOrder + write(jstring,'(i0)') j + times = 0. + do k = minOrder,maxOrder-j + write(kstring,'(i0)') k + print*,'' + print*, 'Start calculating optical depth outward: minOrder = ', trim(jstring),', refineLevel = ', trim(kstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme,& tau, primsec(1:3,2), Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - times(k-minOrder+1) = timeTau - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + times(k-minOrder+1) = timeTau + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & '_'//trim(kstring)//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - enddo - open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt',position='append', status='old', action='write') - write(iu4, *) times(1:maxOrder-minOrder+1) - close(iu4) - enddo - print*,'' - print*,'Total time of the calculation = ',totalTime,' seconds.' - - ! SCALING ANALYSIS - elseif (method == 6) then - order = 5 - print*,'Start doing scaling analysis with order =',order - open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt', status='replace', action='write') - close(iu4) - do i=1, omp_get_max_threads() - call omp_set_num_threads(i) - call deallocate_linklist - call allocate_linklist - call set_linklist(npart2,npart2,xyzh2,vxyzu) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'nthread = ',omp_get_max_threads(),': Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt',position='append', status='old', action='write') - write(iu4, *) omp_get_max_threads(), timeTau - close(iu4) - enddo - - ! TIME ANALYSIS MULTIPLE FILES - elseif (method == 7) then - order = 5 - print*,'Start doing scaling analysis with order =',order - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu1, file='npart_wind.txt',position='append', action='write') - write(iu1, *) npart2 - close(iu1) - open(newunit=iu4, file='times_wind.txt',position='append', action='write') - write(iu4, *) timeTau - close(iu4) - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - endif - - elseif (analyses == 2) then - !ADAPTIVE (OUTWARD) INTEGRATION SCHEME - if (method == 1) then - print*,'' - print*, 'Start calculating optical depth inward' - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - if (SPH) then - open(newunit=iu2, file='taus_'//dumpfile//'_inwards.txt', status='replace', action='write') - else - open(newunit=iu2, file='taus_'//dumpfile//'_tess_inwards.txt', status='replace', action='write') - endif - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - elseif (method == 2) then - print*,'' - print*, 'Start calculating optical depth outward: ', trim(jstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, j, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, j, tau) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - elseif (method == 3) then - print*,'' - print*, 'Start calculating optical depth outward: ', trim(jstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - elseif (method == 4) then - print*,'' - print*, 'Start calculating optical depth adaptive: minOrder = ', trim(jstring),', refineLevel = ', trim(kstring) - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau, primsec(1:3,2),Rcomp) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + enddo + open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt',position='append', status='old', action='write') + write(iu4, *) times(1:maxOrder-minOrder+1) + close(iu4) + enddo + print*,'' + print*,'Total time of the calculation = ',totalTime,' seconds.' + + ! SCALING ANALYSIS + elseif (method == 6) then + order = 5 + print*,'Start doing scaling analysis with order =',order + open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt', status='replace', action='write') + close(iu4) + do i=1, omp_get_max_threads() + call omp_set_num_threads(i) + call deallocate_linklist + call allocate_linklist + call set_linklist(npart2,npart2,xyzh2,vxyzu) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'nthread = ',omp_get_max_threads(),': Time = ',timeTau,' seconds.' + open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt',position='append', status='old', action='write') + write(iu4, *) omp_get_max_threads(), timeTau + close(iu4) + enddo + + ! TIME ANALYSIS MULTIPLE FILES + elseif (method == 7) then + order = 5 + print*,'Start doing scaling analysis with order =',order + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu1, file='npart_wind.txt',position='append', action='write') + write(iu1, *) npart2 + close(iu1) + open(newunit=iu4, file='times_wind.txt',position='append', action='write') + write(iu4, *) timeTau + close(iu4) + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + endif + + elseif (analyses == 2) then + !ADAPTIVE (OUTWARD) INTEGRATION SCHEME + if (method == 1) then + print*,'' + print*, 'Start calculating optical depth inward' + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_inwards(npart2, primsec(1:3,1), xyzh2, neighb, kappa, Rstar, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + if (SPH) then + open(newunit=iu2, file='taus_'//dumpfile//'_inwards.txt', status='replace', action='write') + else + open(newunit=iu2, file='taus_'//dumpfile//'_tess_inwards.txt', status='replace', action='write') + endif + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + elseif (method == 2) then + print*,'' + print*, 'Start calculating optical depth outward: ', trim(jstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, j, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, j, tau) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + elseif (method == 3) then + print*,'' + print*, 'Start calculating optical depth outward: ', trim(jstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_outwards(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, raypolation, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + elseif (method == 4) then + print*,'' + print*, 'Start calculating optical depth adaptive: minOrder = ', trim(jstring),', refineLevel = ', trim(kstring) + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme, tau, primsec(1:3,2),Rcomp) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & '_'//trim(kstring)//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - endif - - elseif (analyses == 3) then - order = 5 - print*,'Start calculating optical depth' - if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then - call system_clock(start) - call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - else - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - endif - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='taus_'//dumpfile//'.txt', status='replace', action='write') - do i=1, size(tau) - write(iu4, *) tau(i) - enddo - close(iu4) - - elseif (analyses == 4) then - do i=1,npart - if (norm2(xyzh2(1:3,i) - (/10.,10.,10./)) < 4.) then - kappa(i) = 1e10 - endif - enddo - ! allocate(neighb(npart2+2,100)) - ! neighb = 0 - ! open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') - ! do i=1, npart2+2 - ! read(iu4,*) neighb(i,:) - ! enddo - ! close(iu4) - print*,'' - order = 7 - print*, 'Start calculating optical depth outward, order=',order - call system_clock(start) - call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) - call system_clock(finish) - timeTau = (finish-start)/1000. - print*,'Time = ',timeTau,' seconds.' - totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_raypolation_7.txt', status='replace', action='write') - do i=1, size(tau) - write(iu2, *) tau(i) - enddo - close(iu2) - - elseif (analyses == 5) then - open(newunit=iu1, file='points_'//dumpfile//'.txt', status='replace', action='write') - do i=1, npart2+2 - write(iu1, *) xyzh2(1:3,i) - enddo - close(iu1) - - open(newunit=iu3, file='rho_'//dumpfile//'.txt', status='replace', action='write') - do i=1,npart2 - rho(i) = rhoh(xyzh2(4,i), particlemass) - write(iu3, *) rho(i) - enddo - close(iu3) - endif - - end subroutine do_analysis - end module analysis + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + endif + + elseif (analyses == 3) then + order = 5 + print*,'Start calculating optical depth' + if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then + call system_clock(start) + call get_all_tau(npart2, 1, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + else + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + endif + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + open(newunit=iu4, file='taus_'//dumpfile//'.txt', status='replace', action='write') + do i=1, size(tau) + write(iu4, *) tau(i) + enddo + close(iu4) + + elseif (analyses == 4) then + do i=1,npart + if (norm2(xyzh2(1:3,i) - (/10.,10.,10./)) < 4.) then + kappa(i) = 1e10 + endif + enddo + ! allocate(neighb(npart2+2,100)) + ! neighb = 0 + ! open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + ! do i=1, npart2+2 + ! read(iu4,*) neighb(i,:) + ! enddo + ! close(iu4) + print*,'' + order = 7 + print*, 'Start calculating optical depth outward, order=',order + call system_clock(start) + call get_all_tau(npart2, 2, xyzmh_ptmass, xyzh2, kappa, order, tau) + call system_clock(finish) + timeTau = (finish-start)/1000. + print*,'Time = ',timeTau,' seconds.' + totalTime = totalTime + timeTau + open(newunit=iu2, file='taus_'//dumpfile//'_raypolation_7.txt', status='replace', action='write') + do i=1, size(tau) + write(iu2, *) tau(i) + enddo + close(iu2) + + elseif (analyses == 5) then + open(newunit=iu1, file='points_'//dumpfile//'.txt', status='replace', action='write') + do i=1, npart2+2 + write(iu1, *) xyzh2(1:3,i) + enddo + close(iu1) + + open(newunit=iu3, file='rho_'//dumpfile//'.txt', status='replace', action='write') + do i=1,npart2 + rho(i) = rhoh(xyzh2(4,i), particlemass) + write(iu3, *) rho(i) + enddo + close(iu3) + endif + +end subroutine do_analysis +end module analysis diff --git a/src/utils/utils_raytracer_all.F90 b/src/utils/utils_raytracer_all.F90 index 7b3d6bb2a..421d4f647 100644 --- a/src/utils/utils_raytracer_all.F90 +++ b/src/utils/utils_raytracer_all.F90 @@ -1,1199 +1,1199 @@ - !--------------------------------------------------------------------------! - ! 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 raytracer_all - ! - ! raytracer_all - ! - ! :References: None - ! - ! :Owner: Lionel Siess - ! - ! :Runtime parameters: None - ! - ! :Dependencies: healpix, kernel, linklist, part, units - ! - use healpix - implicit none - public :: get_all_tau_outwards, get_all_tau_inwards, get_all_tau_adaptive - private - contains - - !*********************************************************************! - !*************************** ADAPTIVE ****************************! - !*********************************************************************! - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth of each particle, using the adaptive ray- - ! tracing scheme - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: kappa: The array containing the kappa of all SPH particles - ! IN: Rstar: The radius of the star - ! IN: minOrder: The minimal order in which the rays are sampled - ! IN: refineLevel: The amount of orders in which the rays can be - ! sampled deeper - ! IN: refineScheme: The refinement scheme used for adaptive ray selection - !+ - ! OUT: taus: The list of optical depths for each particle - !+ - ! OPT: companion: The xyz coordinates of the companion - ! OPT: Rcomp: The radius of the companion - !+ - !-------------------------------------------------------------------------- - subroutine get_all_tau_adaptive(npart, primary, xyzh, kappa, Rstar, minOrder,& +!--------------------------------------------------------------------------! +! 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 raytracer_all +! +! raytracer_all +! +! :References: None +! +! :Owner: Mats Esseldeurs +! +! :Runtime parameters: None +! +! :Dependencies: healpix, kernel, linklist, part, units +! + use healpix + implicit none + public :: get_all_tau_outwards, get_all_tau_inwards, get_all_tau_adaptive + private +contains + + !*********************************************************************! + !*************************** ADAPTIVE ****************************! + !*********************************************************************! + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the adaptive ray- + ! tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa: The array containing the kappa of all SPH particles + ! IN: Rstar: The radius of the star + ! IN: minOrder: The minimal order in which the rays are sampled + ! IN: refineLevel: The amount of orders in which the rays can be + ! sampled deeper + ! IN: refineScheme: The refinement scheme used for adaptive ray selection + !+ + ! OUT: taus: The list of optical depths for each particle + !+ + ! OPT: companion: The xyz coordinates of the companion + ! OPT: Rcomp: The radius of the companion + !+ + !-------------------------------------------------------------------------- +subroutine get_all_tau_adaptive(npart, primary, xyzh, kappa, Rstar, minOrder,& refineLevel, refineScheme, taus, companion, Rcomp) - integer, intent(in) :: npart, minOrder, refineLevel, refineScheme - real, intent(in) :: primary(3), kappa(:), xyzh(:,:), Rstar - real, optional :: Rcomp, companion(3) - real, intent(out) :: taus(:) - - integer :: i, nrays, nsides, index - real :: normCompanion, theta0, unitCompanion(3), theta, root, dist, vec(3), dir(3) - real, dimension(:,:), allocatable :: dirs - real, dimension(:,:), allocatable :: listsOfDists, listsOfTaus - integer, dimension(:), allocatable :: indices, rays_dim - real, dimension(:), allocatable :: tau, dists - - if (present(companion) .and. present(Rcomp)) then - unitCompanion = companion-primary - normCompanion = norm2(unitCompanion) - theta0 = asin(Rcomp/normCompanion) - unitCompanion = unitCompanion/normCompanion - - call get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, dirs, indices, nrays) - allocate(listsOfDists(200, nrays)) - allocate(listsOfTaus(size(listsOfDists(:,1)), nrays)) - allocate(tau(size(listsOfDists(:,1)))) - allocate(dists(size(listsOfDists(:,1)))) - allocate(rays_dim(nrays)) - - !$omp parallel do private(tau,dist,dir,dists,root,theta) - do i = 1, nrays - tau=0. - dists=0. - dir = dirs(:,i) - theta = acos(dot_product(unitCompanion, dir)) - if (theta < theta0) then - root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) - dist = normCompanion*cos(theta)-root - call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i), dist) - else - call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i)) - endif - listsOfTaus(:,i) = tau - listsOfDists(:,i) = dists - enddo - !$omp end parallel do - - nsides = 2**(minOrder+refineLevel) - taus = 0. - !$omp parallel do private(index,vec) - do i = 1, npart - vec = xyzh(1:3,i)-primary - call vec2pix_nest(nsides, vec, index) - index = indices(index + 1) - call get_tau_on_ray(norm2(vec), listsOfTaus(:,index), listsOfDists(:,index), rays_dim(index), taus(i)) - enddo - !$omp end parallel do - - else - call get_all_tau_outwards_single(npart, primary, xyzh, kappa, & + integer, intent(in) :: npart, minOrder, refineLevel, refineScheme + real, intent(in) :: primary(3), kappa(:), xyzh(:,:), Rstar + real, optional :: Rcomp, companion(3) + real, intent(out) :: taus(:) + + integer :: i, nrays, nsides, index + real :: normCompanion, theta0, unitCompanion(3), theta, root, dist, vec(3), dir(3) + real, dimension(:,:), allocatable :: dirs + real, dimension(:,:), allocatable :: listsOfDists, listsOfTaus + integer, dimension(:), allocatable :: indices, rays_dim + real, dimension(:), allocatable :: tau, dists + + if (present(companion) .and. present(Rcomp)) then + unitCompanion = companion-primary + normCompanion = norm2(unitCompanion) + theta0 = asin(Rcomp/normCompanion) + unitCompanion = unitCompanion/normCompanion + + call get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, dirs, indices, nrays) + allocate(listsOfDists(200, nrays)) + allocate(listsOfTaus(size(listsOfDists(:,1)), nrays)) + allocate(tau(size(listsOfDists(:,1)))) + allocate(dists(size(listsOfDists(:,1)))) + allocate(rays_dim(nrays)) + + !$omp parallel do private(tau,dist,dir,dists,root,theta) + do i = 1, nrays + tau=0. + dists=0. + dir = dirs(:,i) + theta = acos(dot_product(unitCompanion, dir)) + if (theta < theta0) then + root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) + dist = normCompanion*cos(theta)-root + call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i), dist) + else + call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i)) + endif + listsOfTaus(:,i) = tau + listsOfDists(:,i) = dists + enddo + !$omp end parallel do + + nsides = 2**(minOrder+refineLevel) + taus = 0. + !$omp parallel do private(index,vec) + do i = 1, npart + vec = xyzh(1:3,i)-primary + call vec2pix_nest(nsides, vec, index) + index = indices(index + 1) + call get_tau_on_ray(norm2(vec), listsOfTaus(:,index), listsOfDists(:,index), rays_dim(index), taus(i)) + enddo + !$omp end parallel do + + else + call get_all_tau_outwards_single(npart, primary, xyzh, kappa, & Rstar, minOrder+refineLevel, 0, taus) - endif - end subroutine get_all_tau_adaptive - - !-------------------------------------------------------------------------- - !+ - ! Return all the directions of the rays that need to be traced for the - ! adaptive ray-tracing scheme - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: companion: The xyz coordinates of the companion - ! IN: Rcomp: The radius of the companion - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: minOrder: The minimal order in which the rays are sampled - ! IN: refineLevel: The amount of orders in which the rays can be - ! sampled deeper - ! IN: refineScheme: The refinement scheme used for adaptive ray selection - !+ - ! OUT: rays: A list containing the rays that need to be traced - ! in the adaptive ray-tracing scheme - ! OUT: indices: A list containing a link between the index in the - ! deepest order and the rays in the adaptive ray-tracing scheme - ! OUT: nrays: The number of rays after the ray selection - !+ - !-------------------------------------------------------------------------- - subroutine get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, rays, indices, nrays) - integer, intent(in) :: npart, minOrder, refineLevel, refineScheme - real, intent(in) :: primary(3), companion(3), xyzh(:,:), Rcomp - real, allocatable, intent(out) :: rays(:,:) - integer, allocatable, intent(out) :: indices(:) - integer, intent(out) :: nrays - - real :: theta, dist, phi, cosphi, sinphi - real, dimension(:,:), allocatable :: circ - integer :: i, j, minNsides, minNrays, ind,n, maxOrder, max, distr(12*4**(minOrder+refineLevel)) - integer, dimension(:,:), allocatable :: distrs - - maxOrder = minOrder+refineLevel - nrays = 12*4**(maxOrder) - allocate(rays(3, nrays)) - allocate(indices(12*4**(maxOrder))) - rays = 0. - indices = 0 - - !If there is no refinement, just return the uniform ray distribution - minNsides = 2**minOrder - minNrays = 12*4**minOrder - if (refineLevel == 0) then - do i=1, minNrays - call pix2vec_nest(minNsides,i-1, rays(:,i)) - indices(i) = i - enddo - return - endif - - !Fill a list to have the number distribution in angular space - distr = 0 - !$omp parallel do private(ind) - do i = 1, npart - call vec2pix_nest(2**maxOrder, xyzh(1:3, i)-primary, ind) - distr(ind+1) = distr(ind+1)+1 - enddo - max = maxval(distr) - - !Make sure the companion is described using the highest refinement - dist = norm2(primary-companion) - theta = asin(Rcomp/dist) - phi = atan2(companion(2)-primary(2),companion(1)-primary(1)) - cosphi = cos(phi) - sinphi = sin(phi) - dist = dist*cos(theta) - n = int(theta*6*2**(minOrder+refineLevel))+4 - allocate(circ(n,3)) - do i=1, n !Define boundary of the companion - circ(i,1) = dist*cos(theta) - circ(i,2) = dist*sin(theta)*cos(twopi*i/n) - circ(i,3) = dist*sin(theta)*sin(twopi*i/n) - circ(i,:) = (/cosphi*circ(i,1) - sinphi*circ(i,2),sinphi*circ(i,1) + cosphi*circ(i,2), circ(i,3)/) - enddo - do i=1, n !Make sure the boundary is maximally refined - call vec2pix_nest(2**maxOrder,circ(i,:),ind) - distr(ind+1) = max - enddo - - !Calculate the number distribution in all the orders needed - allocate(distrs(12*4**(minOrder+refineLevel),refineLevel+1)) - distrs = 0 - distrs(:,1) = distr - do i = 1, refineLevel - do j = 1, 12*4**(maxOrder-i) - distrs(j,i+1) = distrs(4*j,i)+distrs(4*j+1,i)+distrs(4*j+2,i)+distrs(4*j+3,i) - enddo - enddo - max = maxval(distrs(:,refineLevel+1))+1 - - !Fill the rays array walking through the orders - ind=1 - - ! refine half in each order - if (refineScheme == 1) then - do i=0, refineLevel-1 - call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) - do j=1, 6*4**minOrder*2**(i) - call pix2vec_nest(2**(minOrder+i), distr(j)-1, rays(:,ind)) - indices(4**(refineLevel-i)*(distr(j)-1)+1:4**(refineLevel-i)*distr(j)) = ind - ind=ind+1 - distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max - enddo - do j = j+1, 12*4**(minOrder+i) - if (distrs(distr(j),refineLevel-i+1) == max) then - distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max - endif - enddo - enddo - - ! refine overdens regions in each order - elseif (refineScheme == 2) then - do i=0, refineLevel-1 - call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) - j=1 - do while (distrs(distr(j),refineLevel-i+1) 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + endif +end subroutine get_all_tau_adaptive + + !-------------------------------------------------------------------------- + !+ + ! Return all the directions of the rays that need to be traced for the + ! adaptive ray-tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: companion: The xyz coordinates of the companion + ! IN: Rcomp: The radius of the companion + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: minOrder: The minimal order in which the rays are sampled + ! IN: refineLevel: The amount of orders in which the rays can be + ! sampled deeper + ! IN: refineScheme: The refinement scheme used for adaptive ray selection + !+ + ! OUT: rays: A list containing the rays that need to be traced + ! in the adaptive ray-tracing scheme + ! OUT: indices: A list containing a link between the index in the + ! deepest order and the rays in the adaptive ray-tracing scheme + ! OUT: nrays: The number of rays after the ray selection + !+ + !-------------------------------------------------------------------------- +subroutine get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, rays, indices, nrays) + integer, intent(in) :: npart, minOrder, refineLevel, refineScheme + real, intent(in) :: primary(3), companion(3), xyzh(:,:), Rcomp + real, allocatable, intent(out) :: rays(:,:) + integer, allocatable, intent(out) :: indices(:) + integer, intent(out) :: nrays + + real :: theta, dist, phi, cosphi, sinphi + real, dimension(:,:), allocatable :: circ + integer :: i, j, minNsides, minNrays, ind,n, maxOrder, max, distr(12*4**(minOrder+refineLevel)) + integer, dimension(:,:), allocatable :: distrs + + maxOrder = minOrder+refineLevel + nrays = 12*4**(maxOrder) + allocate(rays(3, nrays)) + allocate(indices(12*4**(maxOrder))) + rays = 0. + indices = 0 + + !If there is no refinement, just return the uniform ray distribution + minNsides = 2**minOrder + minNrays = 12*4**minOrder + if (refineLevel == 0) then + do i=1, minNrays + call pix2vec_nest(minNsides,i-1, rays(:,i)) + indices(i) = i + enddo + return + endif + + !Fill a list to have the number distribution in angular space + distr = 0 + !$omp parallel do private(ind) + do i = 1, npart + call vec2pix_nest(2**maxOrder, xyzh(1:3, i)-primary, ind) + distr(ind+1) = distr(ind+1)+1 + enddo + max = maxval(distr) + + !Make sure the companion is described using the highest refinement + dist = norm2(primary-companion) + theta = asin(Rcomp/dist) + phi = atan2(companion(2)-primary(2),companion(1)-primary(1)) + cosphi = cos(phi) + sinphi = sin(phi) + dist = dist*cos(theta) + n = int(theta*6*2**(minOrder+refineLevel))+4 + allocate(circ(n,3)) + do i=1, n !Define boundary of the companion + circ(i,1) = dist*cos(theta) + circ(i,2) = dist*sin(theta)*cos(twopi*i/n) + circ(i,3) = dist*sin(theta)*sin(twopi*i/n) + circ(i,:) = (/cosphi*circ(i,1) - sinphi*circ(i,2),sinphi*circ(i,1) + cosphi*circ(i,2), circ(i,3)/) + enddo + do i=1, n !Make sure the boundary is maximally refined + call vec2pix_nest(2**maxOrder,circ(i,:),ind) + distr(ind+1) = max + enddo + + !Calculate the number distribution in all the orders needed + allocate(distrs(12*4**(minOrder+refineLevel),refineLevel+1)) + distrs = 0 + distrs(:,1) = distr + do i = 1, refineLevel + do j = 1, 12*4**(maxOrder-i) + distrs(j,i+1) = distrs(4*j,i)+distrs(4*j+1,i)+distrs(4*j+2,i)+distrs(4*j+3,i) + enddo + enddo + max = maxval(distrs(:,refineLevel+1))+1 + + !Fill the rays array walking through the orders + ind=1 + + ! refine half in each order + if (refineScheme == 1) then + do i=0, refineLevel-1 + call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) + do j=1, 6*4**minOrder*2**(i) + call pix2vec_nest(2**(minOrder+i), distr(j)-1, rays(:,ind)) + indices(4**(refineLevel-i)*(distr(j)-1)+1:4**(refineLevel-i)*distr(j)) = ind + ind=ind+1 + distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max + enddo + do j = j+1, 12*4**(minOrder+i) + if (distrs(distr(j),refineLevel-i+1) == max) then + distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max + endif + enddo + enddo + + ! refine overdens regions in each order + elseif (refineScheme == 2) then + do i=0, refineLevel-1 + call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) + j=1 + do while (distrs(distr(j),refineLevel-i+1) 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 9 rays, linear interpolation - elseif (raypolation==2) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = norm2(vectemp) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,nneigh - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 9 rays, linear interpolation + elseif (raypolation==2) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = norm2(vectemp) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,nneigh + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 4 rays, square interpolation - elseif (raypolation==3) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = dot_product(vectemp,vectemp) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = dot_product(vectemp,vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 4 rays, square interpolation + elseif (raypolation==3) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = dot_product(vectemp,vectemp) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = dot_product(vectemp,vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 9 rays, square interpolation - elseif (raypolation==4) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = dot_product(vectemp,vectemp) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = dot_product(vectemp,vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,nneigh - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 9 rays, square interpolation + elseif (raypolation==4) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = dot_product(vectemp,vectemp) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = dot_product(vectemp,vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,nneigh + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 4 rays, cubed interpolation - elseif (raypolation==5) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = norm2(vectemp)**3 - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp)**3 - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 4 rays, cubed interpolation + elseif (raypolation==5) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = norm2(vectemp)**3 + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp)**3 + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 9 rays, cubed interpolation - elseif (raypolation==6) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = norm2(vectemp)**3 - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp)**3 - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,nneigh - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 9 rays, cubed interpolation + elseif (raypolation==6) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = norm2(vectemp)**3 + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp)**3 + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,nneigh + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - endif - end subroutine interpolate_tau - - - !-------------------------------------------------------------------------- - !+ - ! Interpolation of the optical depth for an arbitrary point on the ray, - ! with a given distance to the starting point of the ray. - !+ - ! IN: distance: The distance from the staring point of the ray to a - ! point on the ray - ! IN: tau_along_ray: The vector of cumulative optical depths along the ray - ! IN: dist_along_ray: The vector of distances from the primary along the ray - ! IN: len: The length of listOfTau and listOfDist - !+ - ! OUT: tau: The optical depth to the given distance along the ray - !+ - !-------------------------------------------------------------------------- - subroutine get_tau_on_ray(distance, tau_along_ray, dist_along_ray, len, tau) - real, intent(in) :: distance, tau_along_ray(:), dist_along_ray(:) - integer, intent(in) :: len - real, intent(out) :: tau - - integer :: L, R, m ! left, right and middle index for binary search - - if (distance < dist_along_ray(1)) then - tau = 0. - elseif (distance > dist_along_ray(len)) then - tau = 99. - else - L = 2 - R = len-1 - !bysection search for the index of the closest ray location to the particle - do while (L < R) - m = (L + R)/2 - if (dist_along_ray(m) > distance) then - R = m - else - L = m + 1 - endif - enddo - !interpolate linearly ray properties to get the particle's optical depth - tau = tau_along_ray(L-1)+(tau_along_ray(L)-tau_along_ray(L-1))/ & + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + endif +end subroutine interpolate_tau + + + !-------------------------------------------------------------------------- + !+ + ! Interpolation of the optical depth for an arbitrary point on the ray, + ! with a given distance to the starting point of the ray. + !+ + ! IN: distance: The distance from the staring point of the ray to a + ! point on the ray + ! IN: tau_along_ray: The vector of cumulative optical depths along the ray + ! IN: dist_along_ray: The vector of distances from the primary along the ray + ! IN: len: The length of listOfTau and listOfDist + !+ + ! OUT: tau: The optical depth to the given distance along the ray + !+ + !-------------------------------------------------------------------------- +subroutine get_tau_on_ray(distance, tau_along_ray, dist_along_ray, len, tau) + real, intent(in) :: distance, tau_along_ray(:), dist_along_ray(:) + integer, intent(in) :: len + real, intent(out) :: tau + + integer :: L, R, m ! left, right and middle index for binary search + + if (distance < dist_along_ray(1)) then + tau = 0. + elseif (distance > dist_along_ray(len)) then + tau = 99. + else + L = 2 + R = len-1 + !bysection search for the index of the closest ray location to the particle + do while (L < R) + m = (L + R)/2 + if (dist_along_ray(m) > distance) then + R = m + else + L = m + 1 + endif + enddo + !interpolate linearly ray properties to get the particle's optical depth + tau = tau_along_ray(L-1)+(tau_along_ray(L)-tau_along_ray(L-1))/ & (dist_along_ray(L)-dist_along_ray(L-1))*(distance-dist_along_ray(L-1)) - endif - end subroutine get_tau_on_ray - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth along a given ray - !+ - ! IN: primary: The location of the primary star - ! IN: ray: The unit vector of the direction in which the - ! optical depts will be calculated - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: kappa: The array containing the particles opacity - ! IN: Rstar: The radius of the primary star - !+ - ! OUT: taus: The distribution of optical depths throughout the ray - ! OUT: listOfDists: The distribution of distances throughout the ray - ! OUT: len: The length of tau_along_ray and dist_along_ray - !+ - ! OPT: maxDistance: The maximal distance the ray needs to be traced - !+ - !-------------------------------------------------------------------------- - subroutine ray_tracer(primary, ray, xyzh, kappa, Rstar, tau_along_ray, dist_along_ray, len, maxDistance) - use linklist, only:getneigh_pos,ifirstincell,listneigh - use kernel, only:radkern - use units, only:umass,udist - real, intent(in) :: primary(3), ray(3), Rstar, xyzh(:,:), kappa(:) - real, optional :: maxDistance - real, intent(out) :: dist_along_ray(:), tau_along_ray(:) - integer, intent(out) :: len - - integer, parameter :: maxcache = 0 - real, allocatable :: xyzcache(:,:) - real :: distance, h, dtaudr, previousdtaudr, nextdtaudr - integer :: nneigh, inext, i - - distance = Rstar - - h = Rstar/100. - inext=0 - do while (inext==0) - h = h*2. - call getneigh_pos(primary+Rstar*ray,0.,h,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) - call find_next(primary, ray, distance, xyzh, listneigh, inext, nneigh) - enddo - call calc_opacity(primary+Rstar*ray, xyzh, kappa, listneigh, nneigh, previousdtaudr) - - i = 1 - tau_along_ray(i) = 0. - distance = Rstar - dist_along_ray(i) = distance - do while (hasNext(inext,tau_along_ray(i),distance,maxDistance)) - i = i + 1 - call getneigh_pos(primary + distance*ray,0.,xyzh(4,inext)*radkern, & + endif +end subroutine get_tau_on_ray + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth along a given ray + !+ + ! IN: primary: The location of the primary star + ! IN: ray: The unit vector of the direction in which the + ! optical depts will be calculated + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa: The array containing the particles opacity + ! IN: Rstar: The radius of the primary star + !+ + ! OUT: taus: The distribution of optical depths throughout the ray + ! OUT: listOfDists: The distribution of distances throughout the ray + ! OUT: len: The length of tau_along_ray and dist_along_ray + !+ + ! OPT: maxDistance: The maximal distance the ray needs to be traced + !+ + !-------------------------------------------------------------------------- +subroutine ray_tracer(primary, ray, xyzh, kappa, Rstar, tau_along_ray, dist_along_ray, len, maxDistance) + use linklist, only:getneigh_pos,ifirstincell,listneigh + use kernel, only:radkern + use units, only:umass,udist + real, intent(in) :: primary(3), ray(3), Rstar, xyzh(:,:), kappa(:) + real, optional :: maxDistance + real, intent(out) :: dist_along_ray(:), tau_along_ray(:) + integer, intent(out) :: len + + integer, parameter :: maxcache = 0 + real, allocatable :: xyzcache(:,:) + real :: distance, h, dtaudr, previousdtaudr, nextdtaudr + integer :: nneigh, inext, i + + distance = Rstar + + h = Rstar/100. + inext=0 + do while (inext==0) + h = h*2. + call getneigh_pos(primary+Rstar*ray,0.,h,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) + call find_next(primary, ray, distance, xyzh, listneigh, inext, nneigh) + enddo + call calc_opacity(primary+Rstar*ray, xyzh, kappa, listneigh, nneigh, previousdtaudr) + + i = 1 + tau_along_ray(i) = 0. + distance = Rstar + dist_along_ray(i) = distance + do while (hasNext(inext,tau_along_ray(i),distance,maxDistance)) + i = i + 1 + call getneigh_pos(primary + distance*ray,0.,xyzh(4,inext)*radkern, & 3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) - call calc_opacity(primary + distance*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) - dtaudr = (nextdtaudr+previousdtaudr)/2 - previousdtaudr = nextdtaudr - tau_along_ray(i) = tau_along_ray(i-1)+(distance-dist_along_ray(i-1))*dtaudr - dist_along_ray(i) = distance - call find_next(primary, ray, distance, xyzh, listneigh, inext,nneigh) - enddo - len = i - tau_along_ray = tau_along_ray*umass/(udist**2) - end subroutine ray_tracer - - logical function hasNext(inext, tau, distance, maxDistance) - integer, intent(in) :: inext - real, intent(in) :: distance, tau - real, optional :: maxDistance - real, parameter :: tau_max = 99. - if (present(maxDistance)) then - hasNext = inext /= 0 .and. distance < maxDistance .and. tau < tau_max - else - hasNext = inext /= 0 .and. tau < tau_max - endif - end function hasNext - - !*********************************************************************! - !**************************** INWARDS ****************************! - !*********************************************************************! - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth of each particle, using the inwards ray- - ! tracing scheme - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: neighbors: A list containing the indices of the neighbors of - ! each particle - ! IN: kappa: The array containing the opacity of all the SPH particles - ! IN: Rstar: The radius of the primary star - !+ - ! OUT: tau: The array of optical depths for each SPH particle - !+ - ! OPT: companion: The location of the companion - ! OPT: R: The radius of the companion - !+ - !-------------------------------------------------------------------------- - subroutine get_all_tau_inwards(npart, primary, xyzh, neighbors, kappa, Rstar, tau, companion, R) - real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) - integer, intent(in) :: npart, neighbors(:,:) - real, optional :: R, companion(3) - real, intent(out) :: tau(:) - - if (present(companion) .and. present(R)) then - call get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, R, tau) - else - call get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) - endif - end subroutine get_all_tau_inwards - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth of each particle, using the inwards ray- - ! tracing scheme concerning only a single star - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: neighbors: A list containing the indices of the neighbors of - ! each particle - ! IN: kappa: The array containing the opacity of all the SPH particles - ! IN: Rstar: The radius of the primary star - !+ - ! OUT: taus: The list of optical depths for each particle - !+ - !-------------------------------------------------------------------------- - subroutine get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) - real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) - integer, intent(in) :: npart, neighbors(:,:) - real, intent(out) :: tau(:) - - integer :: i - - !$omp parallel do - do i = 1, npart - call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) - enddo - !$omp end parallel do - end subroutine get_all_tau_inwards_single - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth of each particle, using the inwards ray- - ! tracing scheme concerning a binary system - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: neighbors: A list containing the indices of the neighbors of - ! each particle - ! IN: kappa: The array containing the opacity of all the SPH particles - ! IN: Rstar: The radius of the primary star - ! IN: companion: The xyz coordinates of the companion - ! IN: Rcomp: The radius of the companion - !+ - ! OUT: tau: The array of optical depths for each SPH particle - !+ - !-------------------------------------------------------------------------- - subroutine get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, Rcomp, tau) - real, intent(in) :: primary(3), companion(3), kappa(:), Rstar, xyzh(:,:), Rcomp - integer, intent(in) :: npart, neighbors(:,:) - real, intent(out) :: tau(:) - - integer :: i - real :: normCompanion, theta0, uvecCompanion(3), norm, theta, root, norm0 - - uvecCompanion = companion-primary - normCompanion = norm2(uvecCompanion) - uvecCompanion = uvecCompanion/normCompanion - theta0 = asin(Rcomp/normCompanion) - - !$omp parallel do private(norm,theta,root,norm0) - do i = 1, npart - norm = norm2(xyzh(1:3,i)-primary) - theta = acos(dot_product(uvecCompanion, xyzh(1:3,i)-primary)/norm) - if (theta < theta0) then - root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) - norm0 = normCompanion*cos(theta)-root - if (norm > norm0) then - tau(i) = 99. - else - call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) - endif - else - call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) - endif - enddo - !$omp end parallel do - end subroutine get_all_tau_inwards_companion - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth for a given particle, using the inwards ray- - ! tracing scheme - !+ - ! IN: point: The index of the point that needs to be calculated - ! IN: primary: The location of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: neighbors: A list containing the indices of the neighbors of - ! each particle - ! IN: kappa: The array containing the opacity of all the SPH particles - ! IN: Rstar: The radius of the star - !+ - ! OUT: tau: The list of optical depth of the given particle - !+ - !-------------------------------------------------------------------------- - subroutine get_tau_inwards(point, primary, xyzh, neighbors, kappa, Rstar, tau) - use linklist, only:getneigh_pos,ifirstincell,listneigh - use kernel, only:radkern - use units, only:umass,udist - real, intent(in) :: primary(3), xyzh(:,:), kappa(:), Rstar - integer, intent(in) :: point, neighbors(:,:) - real, intent(out) :: tau - - integer :: i, next, previous, nneigh - integer, parameter :: nmaxcache = 0 - real :: xyzcache(0,nmaxcache) - real :: ray(3), nextDist, previousDist, maxDist, dtaudr, previousdtaudr, nextdtaudr - - ray = primary - xyzh(1:3,point) - maxDist = norm2(ray) - ray = ray / maxDist - maxDist=max(maxDist-Rstar,0.) - next=point - call getneigh_pos(xyzh(1:3,point),0.,xyzh(4,point)*radkern, & + call calc_opacity(primary + distance*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) + dtaudr = (nextdtaudr+previousdtaudr)/2 + previousdtaudr = nextdtaudr + tau_along_ray(i) = tau_along_ray(i-1)+(distance-dist_along_ray(i-1))*dtaudr + dist_along_ray(i) = distance + call find_next(primary, ray, distance, xyzh, listneigh, inext,nneigh) + enddo + len = i + tau_along_ray = tau_along_ray*umass/(udist**2) +end subroutine ray_tracer + +logical function hasNext(inext, tau, distance, maxDistance) + integer, intent(in) :: inext + real, intent(in) :: distance, tau + real, optional :: maxDistance + real, parameter :: tau_max = 99. + if (present(maxDistance)) then + hasNext = inext /= 0 .and. distance < maxDistance .and. tau < tau_max + else + hasNext = inext /= 0 .and. tau < tau_max + endif +end function hasNext + + !*********************************************************************! + !**************************** INWARDS ****************************! + !*********************************************************************! + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the inwards ray- + ! tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + !+ + ! OUT: tau: The array of optical depths for each SPH particle + !+ + ! OPT: companion: The location of the companion + ! OPT: R: The radius of the companion + !+ + !-------------------------------------------------------------------------- +subroutine get_all_tau_inwards(npart, primary, xyzh, neighbors, kappa, Rstar, tau, companion, R) + real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) + integer, intent(in) :: npart, neighbors(:,:) + real, optional :: R, companion(3) + real, intent(out) :: tau(:) + + if (present(companion) .and. present(R)) then + call get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, R, tau) + else + call get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) + endif +end subroutine get_all_tau_inwards + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the inwards ray- + ! tracing scheme concerning only a single star + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + !+ + ! OUT: taus: The list of optical depths for each particle + !+ + !-------------------------------------------------------------------------- +subroutine get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) + real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) + integer, intent(in) :: npart, neighbors(:,:) + real, intent(out) :: tau(:) + + integer :: i + + !$omp parallel do + do i = 1, npart + call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) + enddo + !$omp end parallel do +end subroutine get_all_tau_inwards_single + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the inwards ray- + ! tracing scheme concerning a binary system + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + ! IN: companion: The xyz coordinates of the companion + ! IN: Rcomp: The radius of the companion + !+ + ! OUT: tau: The array of optical depths for each SPH particle + !+ + !-------------------------------------------------------------------------- +subroutine get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, Rcomp, tau) + real, intent(in) :: primary(3), companion(3), kappa(:), Rstar, xyzh(:,:), Rcomp + integer, intent(in) :: npart, neighbors(:,:) + real, intent(out) :: tau(:) + + integer :: i + real :: normCompanion, theta0, uvecCompanion(3), norm, theta, root, norm0 + + uvecCompanion = companion-primary + normCompanion = norm2(uvecCompanion) + uvecCompanion = uvecCompanion/normCompanion + theta0 = asin(Rcomp/normCompanion) + + !$omp parallel do private(norm,theta,root,norm0) + do i = 1, npart + norm = norm2(xyzh(1:3,i)-primary) + theta = acos(dot_product(uvecCompanion, xyzh(1:3,i)-primary)/norm) + if (theta < theta0) then + root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) + norm0 = normCompanion*cos(theta)-root + if (norm > norm0) then + tau(i) = 99. + else + call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) + endif + else + call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) + endif + enddo + !$omp end parallel do +end subroutine get_all_tau_inwards_companion + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth for a given particle, using the inwards ray- + ! tracing scheme + !+ + ! IN: point: The index of the point that needs to be calculated + ! IN: primary: The location of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the star + !+ + ! OUT: tau: The list of optical depth of the given particle + !+ + !-------------------------------------------------------------------------- +subroutine get_tau_inwards(point, primary, xyzh, neighbors, kappa, Rstar, tau) + use linklist, only:getneigh_pos,ifirstincell,listneigh + use kernel, only:radkern + use units, only:umass,udist + real, intent(in) :: primary(3), xyzh(:,:), kappa(:), Rstar + integer, intent(in) :: point, neighbors(:,:) + real, intent(out) :: tau + + integer :: i, next, previous, nneigh + integer, parameter :: nmaxcache = 0 + real :: xyzcache(0,nmaxcache) + real :: ray(3), nextDist, previousDist, maxDist, dtaudr, previousdtaudr, nextdtaudr + + ray = primary - xyzh(1:3,point) + maxDist = norm2(ray) + ray = ray / maxDist + maxDist=max(maxDist-Rstar,0.) + next=point + call getneigh_pos(xyzh(1:3,point),0.,xyzh(4,point)*radkern, & 3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) - call calc_opacity(xyzh(1:3,point), xyzh, kappa, listneigh, nneigh, nextdtaudr) - nextDist=0. - - tau = 0. - i=1 - do while (nextDist < maxDist .and. next /=0) - i = i + 1 - previous = next - previousDist = nextDist - call find_next(xyzh(1:3,point), ray, nextDist, xyzh, neighbors(next,:), next) - if (nextDist > maxDist) then - nextDist = maxDist - endif - call getneigh_pos(xyzh(1:3,point) + nextDist*ray,0.,xyzh(4,previous)*radkern, & + call calc_opacity(xyzh(1:3,point), xyzh, kappa, listneigh, nneigh, nextdtaudr) + nextDist=0. + + tau = 0. + i=1 + do while (nextDist < maxDist .and. next /=0) + i = i + 1 + previous = next + previousDist = nextDist + call find_next(xyzh(1:3,point), ray, nextDist, xyzh, neighbors(next,:), next) + if (nextDist > maxDist) then + nextDist = maxDist + endif + call getneigh_pos(xyzh(1:3,point) + nextDist*ray,0.,xyzh(4,previous)*radkern, & 3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) - previousdtaudr=nextdtaudr - call calc_opacity(xyzh(1:3,point) + nextDist*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) - dtaudr = (nextdtaudr+previousdtaudr)/2 - tau = tau + (nextDist-previousDist)*dtaudr - enddo - !fix units for tau (kappa is in cgs while rho & r are in code units) - tau = tau*umass/(udist**2) - end subroutine get_tau_inwards - - !*********************************************************************! - !**************************** COMMON *****************************! - !*********************************************************************! - - !-------------------------------------------------------------------------- - !+ - ! Find the next point on a ray - !+ - ! IN: inpoint: The coordinate of the initial point projected on the - ! ray for which the next point will be calculated - ! IN: ray: The unit vector of the direction in which the next - ! point will be calculated - ! IN: xyzh: The array containing the particles position+smoothing length - ! IN: neighbors: A list containing the indices of the neighbors of - ! the initial point - ! IN: inext: The index of the initial point - ! (this point will not be considered as possible next point) - !+ - ! OPT: nneighin: The amount of neighbors - !+ - ! OUT: inext: The index of the next point on the ray - !+ - !-------------------------------------------------------------------------- - subroutine find_next(inpoint, ray, dist, xyzh, neighbors, inext, nneighin) - integer, intent(in) :: neighbors(:) - real, intent(in) :: xyzh(:,:), inpoint(:), ray(:) - integer, intent(inout) :: inext - real, intent(inout) :: dist - integer, optional :: nneighin - - real :: trace_point(3), dmin, vec(3), tempdist, raydist - real :: nextdist - integer :: i, nneigh, prev - - dmin = huge(0.) - if (present(nneighin)) then - nneigh = nneighin - else - nneigh = size(neighbors) - endif - - prev=inext - inext=0 - nextDist=dist - trace_point = inpoint + dist*ray - - i = 1 - do while (i <= nneigh .and. neighbors(i) /= 0) - if (neighbors(i) /= prev) then - vec=xyzh(1:3,neighbors(i)) - trace_point - tempdist = dot_product(vec,ray) - if (tempdist>0.) then - raydist = dot_product(vec,vec) - tempdist**2 - if (raydist < dmin) then - dmin = raydist - inext = neighbors(i) - nextdist = dist+tempdist - endif - endif - endif - i = i+1 - enddo - dist=nextdist - end subroutine find_next - - !-------------------------------------------------------------------------- - !+ - ! Calculate the opacity in a given location - !+ - ! IN: r0: The location where the opacity will be calculated - ! IN: xyzh: The xyzh of all the particles - ! IN: opacities: The list of the opacities of the particles - ! IN: neighbors: A list containing the indices of the neighbors of - ! the initial point - ! IN: nneigh: The amount of neighbors - !+ - ! OUT: dtaudr: The local optical depth derivative at the given location (inpoint) - !+ - !-------------------------------------------------------------------------- - subroutine calc_opacity(r0, xyzh, opacities, neighbors, nneigh, dtaudr) - use kernel, only:cnormk,wkern - use part, only:hfact,rhoh,massoftype,igas - real, intent(in) :: r0(:), xyzh(:,:), opacities(:) - integer, intent(in) :: neighbors(:), nneigh - real, intent(out) :: dtaudr - - integer :: i - real :: q - - dtaudr=0 - do i=1,nneigh - q = norm2(r0 - xyzh(1:3,neighbors(i)))/xyzh(4,neighbors(i)) - dtaudr=dtaudr+wkern(q*q,q)*opacities(neighbors(i))*rhoh(xyzh(4,neighbors(i)), massoftype(igas)) - enddo - dtaudr = dtaudr*cnormk/hfact**3 - end subroutine calc_opacity - end module raytracer_all + previousdtaudr=nextdtaudr + call calc_opacity(xyzh(1:3,point) + nextDist*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) + dtaudr = (nextdtaudr+previousdtaudr)/2 + tau = tau + (nextDist-previousDist)*dtaudr + enddo + !fix units for tau (kappa is in cgs while rho & r are in code units) + tau = tau*umass/(udist**2) +end subroutine get_tau_inwards + + !*********************************************************************! + !**************************** COMMON *****************************! + !*********************************************************************! + + !-------------------------------------------------------------------------- + !+ + ! Find the next point on a ray + !+ + ! IN: inpoint: The coordinate of the initial point projected on the + ! ray for which the next point will be calculated + ! IN: ray: The unit vector of the direction in which the next + ! point will be calculated + ! IN: xyzh: The array containing the particles position+smoothing length + ! IN: neighbors: A list containing the indices of the neighbors of + ! the initial point + ! IN: inext: The index of the initial point + ! (this point will not be considered as possible next point) + !+ + ! OPT: nneighin: The amount of neighbors + !+ + ! OUT: inext: The index of the next point on the ray + !+ + !-------------------------------------------------------------------------- +subroutine find_next(inpoint, ray, dist, xyzh, neighbors, inext, nneighin) + integer, intent(in) :: neighbors(:) + real, intent(in) :: xyzh(:,:), inpoint(:), ray(:) + integer, intent(inout) :: inext + real, intent(inout) :: dist + integer, optional :: nneighin + + real :: trace_point(3), dmin, vec(3), tempdist, raydist + real :: nextdist + integer :: i, nneigh, prev + + dmin = huge(0.) + if (present(nneighin)) then + nneigh = nneighin + else + nneigh = size(neighbors) + endif + + prev=inext + inext=0 + nextDist=dist + trace_point = inpoint + dist*ray + + i = 1 + do while (i <= nneigh .and. neighbors(i) /= 0) + if (neighbors(i) /= prev) then + vec=xyzh(1:3,neighbors(i)) - trace_point + tempdist = dot_product(vec,ray) + if (tempdist>0.) then + raydist = dot_product(vec,vec) - tempdist**2 + if (raydist < dmin) then + dmin = raydist + inext = neighbors(i) + nextdist = dist+tempdist + endif + endif + endif + i = i+1 + enddo + dist=nextdist +end subroutine find_next + + !-------------------------------------------------------------------------- + !+ + ! Calculate the opacity in a given location + !+ + ! IN: r0: The location where the opacity will be calculated + ! IN: xyzh: The xyzh of all the particles + ! IN: opacities: The list of the opacities of the particles + ! IN: neighbors: A list containing the indices of the neighbors of + ! the initial point + ! IN: nneigh: The amount of neighbors + !+ + ! OUT: dtaudr: The local optical depth derivative at the given location (inpoint) + !+ + !-------------------------------------------------------------------------- +subroutine calc_opacity(r0, xyzh, opacities, neighbors, nneigh, dtaudr) + use kernel, only:cnormk,wkern + use part, only:hfact,rhoh,massoftype,igas + real, intent(in) :: r0(:), xyzh(:,:), opacities(:) + integer, intent(in) :: neighbors(:), nneigh + real, intent(out) :: dtaudr + + integer :: i + real :: q + + dtaudr=0 + do i=1,nneigh + q = norm2(r0 - xyzh(1:3,neighbors(i)))/xyzh(4,neighbors(i)) + dtaudr=dtaudr+wkern(q*q,q)*opacities(neighbors(i))*rhoh(xyzh(4,neighbors(i)), massoftype(igas)) + enddo + dtaudr = dtaudr*cnormk/hfact**3 +end subroutine calc_opacity +end module raytracer_all From cc7d4c0a977417d58e9ff7bbd1e1d3720fd31a3e Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Fri, 31 Mar 2023 16:24:41 +1100 Subject: [PATCH 022/814] Added radiation dominated universe setup --- src/setup/setup_flrw.f90 | 64 ++++++++++++++++++++++++++++++++++++---- 1 file changed, 58 insertions(+), 6 deletions(-) diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 6145b111f..15656468f 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -35,6 +35,7 @@ module setup use dim, only:use_dust,mhd use options, only:use_dustfrac use setup_params, only:rhozero + use physcon, only:radconst implicit none public :: setpart @@ -90,6 +91,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real :: perturb_rho0,xval real :: Vup(0:3),v(0:3),const,phi,rhoprim,sqrtg,u0,x,gcov(0:3,0:3),alpha,hub real :: perturb_wavelength + real :: last_scattering_temp + real :: u procedure(rho_func), pointer :: density_func procedure(mass_func), pointer :: mass_function @@ -104,7 +107,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, if (maxvxyzu < 4) then gamma = 1. else - gamma = 5./3. + ! 4/3 for radiation dominated case + ! irrelevant for + gamma = 4./3. endif ! Redefinition of pi to fix numerical error pi = 4.D0*DATAN(1.0D0) @@ -131,6 +136,13 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !!!!!! rhozero = (3H^2)/(8*pi*a*a) hub = 10.553495658357338 rhozero = 3.d0 * hub**2 / (8.d0 * pi) + phaseoffset = 0. + ! Approx Temp of the CMB in Kelvins + last_scattering_temp = 1e6 + last_scattering_temp = (rhozero/radconst)**(1./4.)*0.99999 + ! Calculate u from last scattering temp so mass density can be calculated + !u = radconst*(last_scattering_temp**4/rhozero) + rhozero = rhozero - radconst*last_scattering_temp**4 ! Define some parameters for Linear pertubations ! We assume ainit = 1, but this may not always be the case @@ -193,6 +205,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Hardcode to ensure double precision, that is requried !rhozero = 13.294563008157013D0 rhozero = 3.d0 * hub**2 / (8.d0 * pi) + rhozero = rhozero - radconst*last_scattering_temp**4 xval = density_func(0.75) xval = density_func(0.0) !print*, "rhofunc 0.: ", xval @@ -216,6 +229,11 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, case('"x"') call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& npart,xyzh,periodic,nptot=npart_total,mask=i_belong,rhofunc=density_func) + case('"y"') + call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& + npart,xyzh,periodic,nptot=npart_total,mask=i_belong) + call set_density_profile(npart,xyzh,min=ymin,max=ymax,rhofunc=density_func,& + geom=1,coord=2) case('"all"') call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& npart,xyzh,periodic,nptot=npart_total,mask=i_belong,rhofunc=density_func) @@ -264,13 +282,47 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, alpha = sqrt(-gcov(0,0)) vxyzu(1,i) = Vup(1)*alpha vxyzu(2:3,i) = 0. + case ('"y"') + vxyzu(2,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) + phi = ampl*sin(kwave*xyzh(2,i)-phaseoffset) + Vup = 0. + Vup(2) = kwave*c3*ampl*cos(2.d0*pi*xyzh(2,i) - phaseoffset) + + call perturb_metric(phi,gcov) + call get_sqrtg(gcov,sqrtg) + + alpha = sqrt(-gcov(0,0)) + vxyzu(:,i) = 0. + vxyzu(2,i) = Vup(2)*alpha + case ('"all"') - ! perturb the y and z velocities - vxyzu(2,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) - vxyzu(3,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(3,i))/lambda - phaseoffset) + phi = ampl*(sin(kwave*xyzh(1,i)-phaseoffset) - sin(kwave*xyzh(2,i)-phaseoffset) - sin(kwave*xyzh(3,i)-phaseoffset)) + Vup(1) = kwave*c3*ampl*cos((2.d0*pi*xyzh(1,i))/lambda - phaseoffset) + Vup(2) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) + Vup(3) = kwave*c3*ampl*cos((2.d0*pi*xyzh(3,i))/lambda - phaseoffset) + + call perturb_metric(phi,gcov) + call get_sqrtg(gcov,sqrtg) + + alpha = sqrt(-gcov(0,0)) + + ! perturb the y and z velocities + vxyzu(1,i) = Vup(1)*alpha + vxyzu(2,i) = Vup(2)*alpha + vxyzu(3,i) = Vup(3)*alpha end select - - if (maxvxyzu >= 4 .and. gamma > 1.) vxyzu(4,i) = cs0**2/(gamma*(gamma-1.)) + ! Setup the intial internal energy here? + ! This should be u = aT^4/\rho + ! Choose an initial temp of the cmb ~ 3000K + ! Set a=1 for now + ! Asssuming that this is constant density/pressure for now so I'm making sure that + ! Note that rhozero != rho + ! rhozero = rho + rho*u as this is the energy density + if (maxvxyzu >= 4 .and. gamma > 1.) vxyzu(4,i) = (radconst*(last_scattering_temp**4))/rhozero !vxyzu(4,i) = cs0**2/(gamma*(gamma-1.)) + ! Check that the pressure is correct + print*, "Pressure: ", (gamma-1)*rhozero*vxyzu(4,i) + print*, "Pressure from energy density: ", 3.d0 * hub**2 / (8.d0 * pi)/3. + print*, "Pressure 1/3 \rho u: ",radconst*(last_scattering_temp**4)/3. enddo From f6262bd8ae72e04de5e2050c6dcc41990440acc4 Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Tue, 4 Apr 2023 15:14:49 +1000 Subject: [PATCH 023/814] Minor changes to porosity --- src/main/growth.F90 | 5 +++ src/main/porosity.f90 | 94 +++++++++++++++++++++---------------------- 2 files changed, 52 insertions(+), 47 deletions(-) diff --git a/src/main/growth.F90 b/src/main/growth.F90 index 6702aee4c..c623802ff 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -582,6 +582,10 @@ subroutine check_dustprop(npart,dustprop,filfac,mprev,filfacprev) integer :: i,iam real :: stokesnew,sdustprev,sdustmin,sdust + !$omp parallel do default(none) & + !$omp shared(iamtype,iphase,idust,igas,dustgasprop,use_dustfrac,use_porosity) & + !$omp shared(npart,dustprop,filfac,mprev,filfacprev) & + !$omp private(i,iam,stokesnew,sdustprev,sdustmin,sdust) do i=1,npart iam = iamtype(iphase(i)) if ((iam == idust .or. (use_dustfrac .and. iam == igas)) .and. ifrag > 0 .and. dustprop(1,i) <= mprev(i)) then @@ -601,6 +605,7 @@ subroutine check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif endif enddo + !$omp end parallel do end subroutine check_dustprop diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index a5e7a96f3..b105cb78c 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -372,54 +372,54 @@ subroutine get_filfac_frag(mprev,dustprop,filfac,dustgasprop,rhod,VrelVf,dt,filf case (0) ! Fragmentation at constant filling factor filfacfrag = filfac +! case (1) +! ! model Fit1ncoll +! sdust = get_size(mprev,dustprop(2),filfac) +! vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) +! ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev +! +! compfactor = (3.*0.3*filfac**(-0.2))*exp(1.5*(0.3-VrelVf)) + 1. +! filfacfrag = filfac*compfactor**ncoll +! case (2) +! ! model Fit2ncoll +! sdust = get_size(mprev,dustprop(2),filfac) +! vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) +! ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev +! +! compfactor = 27.*filfac**(-0.2)*VrelVf**(1.5)/(2.*exp(4.*VrelVf)-1.) + 1. +! filfacfrag = filfac*compfactor**ncoll +! case (3) +! ! model Garcia +! sdust = get_size(mprev,dustprop(2),filfac) +! vol = fourpi/3. * sdust**3 +! vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) +! ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev +! +! ekin = mprev*vrel*vrel/4. +! +! if (filfac >= 0.01) then +! pdyn = Yd0*filfac**Ydpow +! else +! pdyn = Yd0*0.01**Ydpow +! endif +! +! deltavol = ekin/pdyn +! +! if (deltavol >= vol) deltavol = vol +! +! filfacfrag = filfac *(1./(1.-0.5*deltavol/vol))**ncoll +! case (4) +! !model Fit1 + garcia +! sdust = get_size(mprev,dustprop(2),filfac) +! vol = fourpi/3. * sdust**3 +! vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) +! ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev +! +! compfactor = (3.*0.3*filfac**(-0.2))*exp(1.5*(0.3-VrelVf)) + 1. +! deltavol = vol - dustprop(1)*vol/mprev/compfactor +! filfacfrag = filfac *(1./(1.-deltavol/vol))**ncoll +! case (1) - ! model Fit1ncoll - sdust = get_size(mprev,dustprop(2),filfac) - vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) - ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev - - compfactor = (3.*0.3*filfac**(-0.2))*exp(1.5*(0.3-VrelVf)) + 1. - filfacfrag = filfac*compfactor**ncoll - case (2) - ! model Fit2ncoll - sdust = get_size(mprev,dustprop(2),filfac) - vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) - ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev - - compfactor = 27.*filfac**(-0.2)*VrelVf**(1.5)/(2.*exp(4.*VrelVf)-1.) + 1. - filfacfrag = filfac*compfactor**ncoll - case (3) - ! model Garcia - sdust = get_size(mprev,dustprop(2),filfac) - vol = fourpi/3. * sdust**3 - vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) - ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev - - ekin = mprev*vrel*vrel/4. - - if (filfac >= 0.01) then - pdyn = Yd0*filfac**Ydpow - else - pdyn = Yd0*0.01**Ydpow - endif - - deltavol = ekin/pdyn - - if (deltavol >= vol) deltavol = vol - - filfacfrag = filfac *(1./(1.-0.5*deltavol/vol))**ncoll - case (4) - !model Fit1 + garcia - sdust = get_size(mprev,dustprop(2),filfac) - vol = fourpi/3. * sdust**3 - vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) - ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev - - compfactor = (3.*0.3*filfac**(-0.2))*exp(1.5*(0.3-VrelVf)) + 1. - deltavol = vol - dustprop(1)*vol/mprev/compfactor - filfacfrag = filfac *(1./(1.-deltavol/vol))**ncoll - - case (5) ! model Garcia + Kataoka mod sdust = get_size(mprev,dustprop(2),filfac) vol = fourpi/3. * sdust**3 From 21de775ee08b384a7d5b232da3bdd489d06da4cb Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 4 Apr 2023 15:31:29 +1000 Subject: [PATCH 024/814] Fixed the stress energy tensor calc for 3d case and added options for radiation dominated setup --- src/main/extern_gr.F90 | 36 +++++++------------- src/main/initial.F90 | 2 ++ src/setup/setup_flrw.f90 | 41 ++++++++++++---------- src/utils/einsteintk_utils.f90 | 4 +++ src/utils/einsteintk_wrapper.f90 | 58 ++++++++++++++++++++++++++++++-- 5 files changed, 96 insertions(+), 45 deletions(-) diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 358e40159..27cc6c9b1 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -294,13 +294,12 @@ subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) use utils_gr, only:get_u0 real, intent(in) :: x(3),metrici(:,:,:),v(3),dens,u,p real, intent(out) :: tmunu(0:3,0:3) - real :: tmunucon(0:3,0:3) logical, optional, intent(in) :: verbose - real :: w,v4(0:3),vcov(3),lorentz,bigV(3),uzero + real :: w,v4(0:3),vcov(3),lorentz,bigV(3),uzero,u_upper(0:3),u_lower(0:3) real :: gcov(0:3,0:3), gcon(0:3,0:3) real :: gammaijdown(1:3,1:3),betadown(3),alpha real :: velshiftterm - integer :: i,j,ierr + integer :: i,j,ierr,mu,nu ! Reference for all the variables used in this routine: ! w - the enthalpy @@ -364,34 +363,23 @@ subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) v4(0) = 1. v4(1:3) = v(:) + ! first component of the upper-case 4-velocity (contravariant) call get_u0(gcov,v,uzero,ierr) - - ! Stress energy tensor in contravariant form - do j=0,3 - do i=0,3 - tmunucon(i,j) = dens*w*uzero*uzero*v4(i)*v4(j) + p*gcon(i,j) - enddo + + u_upper = uzero*v4 + do mu=0,3 + u_lower(mu) = gcov(mu,0)*u_upper(0) + gcov(mu,1)*u_upper(1) & + + gcov(mu,2)*u_upper(2) + gcov(mu,3)*u_upper(3) enddo - ! Lower the stress energy tensor using the metric - ! This gives you T^{\mu}_nu - do j=0,3 - do i=0,3 - tmunu(i,j) = gcov(j,0)*tmunucon(i,0) & - + gcov(j,1)*tmunucon(i,1) + gcov(j,2)*tmunucon(i,2) + gcov(j,3)*tmunucon(i,3) - enddo - enddo - - ! Repeating it again gives T_{\mu\nu} - do j=0,3 - do i=0,3 - tmunu(i,j) = gcov(i,0)*tmunu(0,j) & - + gcov(i,1)*tmunu(1,j) + gcov(i,2)*tmunu(2,j) + gcov(i,3)*tmunu(3,j) + ! Stress energy tensor in contravariant form + do nu=0,3 + do mu=0,3 + tmunu(mu,nu) = dens*u_lower(mu)*u_lower(nu) + p*gcov(mu,nu) enddo enddo - ! Check that the calculated diagonials are equal to 1/tmuncon if (present(verbose) .and. verbose) then ! Do we get sensible values diff --git a/src/main/initial.F90 b/src/main/initial.F90 index b958bf4dd..5ad01f74d 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -424,6 +424,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) !print*, "Density value before prims2cons: ", dens(1) call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) !print*, "Density value after prims2cons: ", dens(1) + !print*, "internal energy is: ", vxyzu(4,1) + !print*, "initial entropy is : ", pxyzu(4,1) #endif if (iexternalforce > 0 .and. imetric /= imet_minkowski) then call initialise_externalforces(iexternalforce,ierr) diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 15656468f..88a4a6d4d 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -41,7 +41,7 @@ module setup integer :: npartx,ilattice real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,Bzero,ampl,phaseoffset - character(len=20) :: dist_unit,mass_unit,perturb_direction,perturb + character(len=20) :: dist_unit,mass_unit,perturb_direction,perturb,radiation_dominated real(kind=8) :: udist,umass !--change default defaults to reproduce the test from Section 5.6.7 of Price+(2018) @@ -130,19 +130,21 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, npartx = 64 ilattice = 1 perturb = '"no"' + perturb_direction = '"none"' + radiation_dominated = '"no"' + ! Ideally this should read the values of the box length ! and initial Hubble parameter from the par file. ! Then it should be set using the Friedmann equation: !!!!!! rhozero = (3H^2)/(8*pi*a*a) + hub = 10.553495658357338 rhozero = 3.d0 * hub**2 / (8.d0 * pi) phaseoffset = 0. + ! Approx Temp of the CMB in Kelvins - last_scattering_temp = 1e6 + last_scattering_temp = 3000 last_scattering_temp = (rhozero/radconst)**(1./4.)*0.99999 - ! Calculate u from last scattering temp so mass density can be calculated - !u = radconst*(last_scattering_temp**4/rhozero) - rhozero = rhozero - radconst*last_scattering_temp**4 ! Define some parameters for Linear pertubations ! We assume ainit = 1, but this may not always be the case @@ -152,13 +154,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, if (gr) then - !cs0 = 1.e-4 - !cs0 = 1. ! 0 Because dust? cs0 = 0. else cs0 = 1. endif + ! get disc setup parameters from file or interactive setup ! filename=trim(fileprefix)//'.setup' @@ -205,14 +206,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Hardcode to ensure double precision, that is requried !rhozero = 13.294563008157013D0 rhozero = 3.d0 * hub**2 / (8.d0 * pi) - rhozero = rhozero - radconst*last_scattering_temp**4 + + select case(radiation_dominated) + case('"yes"') + + rhozero = rhozero - radconst*last_scattering_temp**4 + end select + xval = density_func(0.75) xval = density_func(0.0) - !print*, "rhofunc 0.: ", xval - print*, "ampl :", ampl - !stop - print*, "phase offset is: ", phaseoffset - print*, "perturb direction is: ", perturb_direction select case(ilattice) case(2) @@ -251,9 +253,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, npartoftype(1) = npart print*,' npart = ',npart,npart_total - ! What should this be set as always 1? - !totmass = 1. - ! Setting it as this gives errors + totmass = rhozero*dxbound*dybound*dzbound massoftype = totmass/npart_total if (id==master) print*,' particle mass = ',massoftype(1) @@ -317,12 +317,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Set a=1 for now ! Asssuming that this is constant density/pressure for now so I'm making sure that ! Note that rhozero != rho - ! rhozero = rho + rho*u as this is the energy density + ! rhozero = rho + rho*u as this is the energy density + select case(radiation_dominated) + case('"yes"') if (maxvxyzu >= 4 .and. gamma > 1.) vxyzu(4,i) = (radconst*(last_scattering_temp**4))/rhozero !vxyzu(4,i) = cs0**2/(gamma*(gamma-1.)) ! Check that the pressure is correct print*, "Pressure: ", (gamma-1)*rhozero*vxyzu(4,i) print*, "Pressure from energy density: ", 3.d0 * hub**2 / (8.d0 * pi)/3. - print*, "Pressure 1/3 \rho u: ",radconst*(last_scattering_temp**4)/3. + print*, "Pressure 1/3 \rho u: ",radconst*(last_scattering_temp**4)/3. + end select enddo @@ -526,6 +529,7 @@ subroutine write_setupfile(filename) call write_inopt(ampl,'FLRWSolver::phi_amplitude','Pertubation amplitude',iunit) call write_inopt(phaseoffset,'FLRWSolver::phi_phase_offset','Pertubation phase offset',iunit) call write_inopt(perturb_direction, 'FLRWSolver::FLRW_perturb_direction','Pertubation direction',iunit) + call write_inopt(radiation_dominated, 'radiation_dominated','Radiation dominated universe (yes/no)',iunit) if (use_dustfrac) then call write_inopt(dust_to_gas,'dust_to_gas','dust-to-gas ratio',iunit) endif @@ -583,6 +587,7 @@ subroutine read_setupfile(filename,ierr) call read_inopt(ilattice,'ilattice',db,min=1,max=2,errcount=nerr) ! TODO Work out why this doesn't read in correctly call read_inopt(perturb,'FLRWSolver::FLRW_perturb',db,errcount=nerr) + call read_inopt(radiation_dominated,'radiation_dominated',db,errcount=nerr) !print*, db call close_db(db) diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index d2999e9f8..45e1b5623 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -6,6 +6,7 @@ module einsteintk_utils real, allocatable :: tmunugrid(:,:,:,:,:) real, allocatable :: rhostargrid(:,:,:) real, allocatable :: pxgrid(:,:,:,:) + real, allocatable :: entropygrid(:,:,:) real, allocatable :: metricderivsgrid(:,:,:,:,:,:) real :: dxgrid(3), gridorigin(3), boundsize(3) integer :: gridsize(3) @@ -41,6 +42,9 @@ subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) allocate(pxgrid(3,nx,ny,nz)) allocate(rhostargrid(nx,ny,nz)) + + ! TODO Toggle for this to save memory + allocate(entropygrid(nx,ny,nz)) ! metric derivs are stored in the form ! mu comp, nu comp, deriv, gridx,gridy,gridz diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index f1caf9838..671dc1c53 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -21,7 +21,7 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) use einsteintk_utils use extern_gr use metric - use part, only:xyzh,vxyzu,dens,metricderivs, metrics, npart, tmunus + use part, only:xyzh,pxyzu,vxyzu,dens,metricderivs, metrics, npart, tmunus implicit none @@ -84,6 +84,7 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) call get_phantom_dt(dtout) + print*,"pxyzu: ", pxyzu(:,1) end subroutine init_et2phantom @@ -242,7 +243,7 @@ subroutine phantom2et_consvar() use densityforce, only:densityiterate use metric_tools, only:init_metric use linklist, only:set_linklist - use einsteintk_utils, only:rhostargrid,pxgrid + use einsteintk_utils, only:rhostargrid,pxgrid,entropygrid use tmunu2grid, only:check_conserved_dens real :: stressmax @@ -266,6 +267,9 @@ subroutine phantom2et_consvar() ! Interpolate momentum to grid call phantom2et_momentum + ! Interpolate entropy to grid + call phantom2et_entropy + ! Conserved quantity checks + corrections @@ -277,7 +281,7 @@ subroutine phantom2et_consvar() ! Correct momentum and Density rhostargrid = cfac*rhostargrid pxgrid = cfac*pxgrid - !entropygrid = cfac*entropygrid + entropygrid = cfac*entropygrid end subroutine phantom2et_consvar @@ -320,6 +324,40 @@ subroutine phantom2et_rhostar() end subroutine phantom2et_rhostar + subroutine phantom2et_entropy() + use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& + igas, massoftype,rhoh + use cons2prim, only: cons2primall + use deriv + use extern_gr + use tmunu2grid + use einsteintk_utils, only: get_phantom_dt,entropygrid + use metric_tools, only:init_metric + real :: dat(npart), h, pmass,rho + integer :: i + + + ! Get new cons density from new particle positions somehow (maybe)? + ! Set linklist to update the tree for neighbour finding + ! Calculate the density for the new particle positions + ! Call density iterate + + ! Interpolate from particles to grid + ! This can all go into its own function as it will essentially + ! be the same thing for all quantites + ! get particle data + ! get rho from xyzh and rhoh + ! Get the conserved density on the particles + dat = 0. + do i=1, npart + ! Entropy is the u component of pxyzu + dat(i) = pxyzu(4,i) + enddo + entropygrid = 0. + call interpolate_to_grid(entropygrid,dat) + + end subroutine phantom2et_entropy + subroutine phantom2et_momentum() use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& igas,massoftype,alphaind,dvdx,gradh @@ -450,5 +488,19 @@ subroutine get_metricderivs_all(dtextforce_min,dt_et) ! enddo end subroutine get_metricderivs_all + subroutine get_eos_quantities(densi,en) + use cons2prim, only:cons2primall + use part, only:dens,vxyzu,npart,metrics,xyzh,pxyzu,eos_vars + real, intent(out) :: densi,en + + !call h2dens(densi,xyzhi,metrici,vi) ! Compute dens from h + densi = dens(1) ! Feed the newly computed dens back out of the routine + !call cons2primall(npart,xyzh,metrics,vxyzu,dens,pxyzu,.true.) + call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + ! print*,"pxyzu: ",pxyzu(:,1) + ! print*, "vxyzu: ",vxyzu(:,1) + en = vxyzu(4,1) + end subroutine get_eos_quantities + end module einsteintk_wrapper From 940d228ce486befecf8cd2417db3d7541650936d Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Tue, 4 Apr 2023 18:05:22 +1000 Subject: [PATCH 025/814] remove exp vertical profil for setting dust --- src/main/growth.F90 | 9 ++++----- src/utils/moddump_dustadd.f90 | 10 +++------- 2 files changed, 7 insertions(+), 12 deletions(-) diff --git a/src/main/growth.F90 b/src/main/growth.F90 index 5571a12c2..625bcdcf9 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -618,7 +618,7 @@ end subroutine check_dustprop ! Set dustprop (used by moddump) !+ !----------------------------------------------------------------------- -subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_index) +subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref) use dust, only:grainsizecgs,graindenscgs use part, only:iamtype,iphase,idust,igas,dustprop,filfac,probastick use physcon, only:fourpi @@ -628,16 +628,15 @@ subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_i integer :: i,iam real :: r,h logical, optional, intent(in) :: sizedistrib - real, optional, intent(in) :: pwl_sizedistrib,R_ref,H_R_ref,q_index + real, optional, intent(in) :: pwl_sizedistrib,R_ref do i=1,npart iam = iamtype(iphase(i)) if (iam == idust .or. (iam == igas .and. use_dustfrac)) then dustprop(2,i) = graindenscgs / unit_density if (sizedistrib) then - r = sqrt(xyzh(1,i)**2 + xyzh(2,i)**2) - h = H_R_ref * R_ref * au / udist * (r * udist / au / R_ref)**(1.5-q_index) - dustprop(1,i) = grainsizecgs/udist * (r * udist / au / R_ref)**pwl_sizedistrib * exp(-0.5*xyzh(3,i)**2/h**2) + r = sqrt(xyzh(1,i)**2 + xyzh(2,i)**2 + xyzh(3,i)**2) + dustprop(1,i) = grainsizecgs/udist * (r * udist / au / R_ref)**pwl_sizedistrib dustprop(1,i) = fourpi/3. * dustprop(2,i) * (dustprop(1,i))**3 else dustprop(1,i) = fourpi/3. * dustprop(2,i) * (grainsizecgs / udist)**3 diff --git a/src/utils/moddump_dustadd.f90 b/src/utils/moddump_dustadd.f90 index 3462cb542..a6474e8fd 100644 --- a/src/utils/moddump_dustadd.f90 +++ b/src/utils/moddump_dustadd.f90 @@ -46,7 +46,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) integer :: i,j,itype,ipart,iloc,dust_method,np_ratio,np_gas,np_dust,maxdust real :: dust_to_gas,smincgs,smaxcgs,sindex,dustbinfrac(maxdusttypes),udens integer :: iremoveparttype - real :: inradius,outradius,pwl_sizedistrib,R_ref,H_R_ref,q_index + real :: inradius,outradius,pwl_sizedistrib,R_ref logical :: icutinside,icutoutside,sizedistrib @@ -63,10 +63,8 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) smaxcgs = 1. sindex = 3.5 dustbinfrac = 0. - pwl_sizedistrib = -1.55 + pwl_sizedistrib = -2 R_ref = 100 - H_R_ref = 0.0895 - q_index = 0.25 icutinside = .false. icutoutside = .false. @@ -126,8 +124,6 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call prompt('Enter grain size in cm at Rref',grainsizecgs,0.) call prompt('Enter power-law index ',pwl_sizedistrib) call prompt('Enter R_ref ',R_ref,0.) - call prompt('Enter H/R at R_ref',H_R_ref,0.) - call prompt('Enter q index',q_index) else call prompt('Enter initial grain size in cm',grainsizecgs,0.) endif @@ -194,7 +190,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) enddo endif if (use_dustgrowth) then - call set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_index) + call set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref) endif endif !Delete particles if necessary From f57d486a79a4a7ca79722dfa971a16d9119316ba Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Wed, 5 Apr 2023 12:53:23 +1000 Subject: [PATCH 026/814] better initialisation for fluffy grains --- src/main/growth.F90 | 64 ++++++++++++----------------------- src/main/part.F90 | 3 -- src/main/step_leapfrog.F90 | 13 ++++--- src/utils/moddump_dustadd.f90 | 8 +++-- 4 files changed, 33 insertions(+), 55 deletions(-) diff --git a/src/main/growth.F90 b/src/main/growth.F90 index 625bcdcf9..a6a3ad8b0 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -23,7 +23,6 @@ module growth ! - flyby : *use primary for keplerian freq. calculation* ! - force_smax : *(mcfost) set manually maximum size for binning* ! - grainsizemin : *minimum allowed grain size in cm* -! - stokesmin : *minimum allowed Stokes number when porosity is on* ! - ieros : *erosion of dust (0=off,1=on)* ! - ifrag : *fragmentation of dust (0=off,1=on,2=Kobayashi)* ! - ieros : *erosion of dust (0=off,1=on) @@ -48,7 +47,6 @@ module growth integer, public :: ieros = 0 real, public :: gsizemincgs = 5.e-3 - real, public :: stokesmin = 1.e-4 real, public :: rsnow = 100. real, public :: Tsnow = 150. real, public :: vfragSI = 15. @@ -88,6 +86,7 @@ subroutine init_growth(ierr) use physcon, only:fourpi use viscosity, only:irealvisc,shearparam use dust, only:grainsizecgs + use options, only:use_porosity integer, intent(out) :: ierr ierr = 0 @@ -378,11 +377,7 @@ subroutine write_options_growth(iunit) call write_inopt(ifrag,'ifrag','dust fragmentation (0=off,1=on,2=Kobayashi)',iunit) call write_inopt(ieros,'ieros','erosion of dust (0=off,1=on)',iunit) if (ifrag /= 0) then - if (use_porosity) then - call write_inopt(stokesmin,'stokesmin','minimum allowed stokes number',iunit) - else - call write_inopt(gsizemincgs,'grainsizemin','minimum grain size in cm',iunit) - endif + call write_inopt(gsizemincgs,'grainsizemin','minimum grain size in cm',iunit) call write_inopt(isnow,'isnow','snow line (0=off,1=position based,2=temperature based)',iunit) if (isnow == 1) call write_inopt(rsnow,'rsnow','position of the snow line in AU',iunit) if (isnow == 2) call write_inopt(Tsnow,'Tsnow','snow line condensation temperature in K',iunit) @@ -433,9 +428,6 @@ subroutine read_options_growth(name,valstring,imatch,igotall,ierr) case('grainsizemin') read(valstring,*,iostat=ierr) gsizemincgs ngot = ngot + 1 - case('stokesmin') - read(valstring,*,iostat=ierr) stokesmin - ngot = ngot + 1 case('isnow') read(valstring,*,iostat=ierr) isnow ngot = ngot + 1 @@ -527,11 +519,7 @@ subroutine write_growth_setup_options(iunit) call write_inopt(vfragSI,'vfrag','uniform fragmentation threshold in m/s',iunit) call write_inopt(vfraginSI,'vfragin','inward fragmentation threshold in m/s',iunit) call write_inopt(vfragoutSI,'vfragout','inward fragmentation threshold in m/s',iunit) - if (use_porosity) then - call write_inopt(stokesmin,'stokesmin','minimum allowed stokes number',iunit) - else - call write_inopt(gsizemincgs,'grainsizemin','minimum allowed grain size in cm',iunit) - endif + call write_inopt(gsizemincgs,'grainsizemin','minimum allowed grain size in cm',iunit) end subroutine write_growth_setup_options @@ -550,11 +538,7 @@ subroutine read_growth_setup_options(db,nerr) call read_inopt(ieros,'ieros',db,min=0,max=1,errcount=nerr) if (ifrag > 0) then call read_inopt(isnow,'isnow',db,min=0,max=2,errcount=nerr) - if (use_porosity) then - call read_inopt(stokesmin,'stokesmin',db,min=1.e-5,errcount=nerr) - else - call read_inopt(gsizemincgs,'grainsizemin',db,min=1.e-5,errcount=nerr) - endif + call read_inopt(gsizemincgs,'grainsizemin',db,min=1.e-5,errcount=nerr) select case(isnow) case(0) call read_inopt(vfragSI,'vfrag',db,min=0.,errcount=nerr) @@ -576,37 +560,30 @@ end subroutine read_growth_setup_options ! In case of fragmentation, limit masses to a minimum value !+ !----------------------------------------------------------------------- -subroutine check_dustprop(npart,dustprop,filfac,mprev,filfacprev) - use part, only:iamtype,iphase,idust,igas,dustgasprop +subroutine check_dustprop(npart,dustprop,filfac,dmdt) + use part, only:iamtype,iphase,idust,igas use options, only:use_dustfrac,use_porosity real,intent(inout) :: dustprop(:,:) integer,intent(in) :: npart - real, intent(in) :: filfac(:),mprev(:),filfacprev(:) + real, intent(in) :: filfac(:),dmdt(:) integer :: i,iam - real :: stokesnew,sdustprev,sdustmin,sdust + real :: sdust !$omp parallel do default(none) & - !$omp shared(iphase,dustgasprop,use_dustfrac,use_porosity) & - !$omp shared(npart,ifrag,dustprop,filfac,mprev,filfacprev) & - !$omp shared(stokesmin,grainsizemin) & - !$omp private(i,iam,stokesnew,sdustprev,sdustmin,sdust) + !$omp shared(iphase,use_dustfrac,use_porosity) & + !$omp shared(npart,ifrag,dustprop,filfac,dmdt,grainsizemin) & + !$omp private(i,iam,sdust) do i=1,npart iam = iamtype(iphase(i)) - if ((iam == idust .or. (use_dustfrac .and. iam == igas)) .and. ifrag > 0 .and. dustprop(1,i) <= mprev(i)) then + if ((iam == idust .or. (use_dustfrac .and. iam == igas)) .and. ifrag > 0 .and. dmdt(i) < 0.) then if (use_porosity) then - sdustprev = get_size(mprev(i),dustprop(2,i),filfacprev(i)) sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) - stokesnew = dustgasprop(3,i)*sdustprev*filfacprev(i)/sdust/filfac(i) - if (stokesnew < stokesmin) then - sdustmin = stokesmin*sdustprev*filfacprev(i)/filfac(i)/dustgasprop(3,i) - dustprop(1,i) = dustprop(1,i) * (sdustmin/sdust)**3. - endif else sdust = get_size(dustprop(1,i),dustprop(2,i)) - if (sdust < grainsizemin) then - dustprop(1,i) = dustprop(1,i) * (grainsizemin/sdust)**3. ! fragmentation at constant density and filling factor - endif - endif + endif + if (sdust < grainsizemin) then + dustprop(1,i) = dustprop(1,i) * (grainsizemin/sdust)**3. ! fragmentation at constant density and filling factor + endif endif enddo !$omp end parallel do @@ -618,7 +595,7 @@ end subroutine check_dustprop ! Set dustprop (used by moddump) !+ !----------------------------------------------------------------------- -subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref) +subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_index) use dust, only:grainsizecgs,graindenscgs use part, only:iamtype,iphase,idust,igas,dustprop,filfac,probastick use physcon, only:fourpi @@ -628,15 +605,16 @@ subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref) integer :: i,iam real :: r,h logical, optional, intent(in) :: sizedistrib - real, optional, intent(in) :: pwl_sizedistrib,R_ref + real, optional, intent(in) :: pwl_sizedistrib,R_ref,H_R_ref,q_index do i=1,npart iam = iamtype(iphase(i)) if (iam == idust .or. (iam == igas .and. use_dustfrac)) then dustprop(2,i) = graindenscgs / unit_density if (sizedistrib) then - r = sqrt(xyzh(1,i)**2 + xyzh(2,i)**2 + xyzh(3,i)**2) - dustprop(1,i) = grainsizecgs/udist * (r * udist / au / R_ref)**pwl_sizedistrib + r = sqrt(xyzh(1,i)**2 + xyzh(2,i)**2) + h = H_R_ref * R_ref * au / udist * (r * udist / au / R_ref)**(1.5-q_index) + dustprop(1,i) = grainsizecgs/udist * (r * udist / au / R_ref)**pwl_sizedistrib * exp(-0.5*xyzh(3,i)**2/h**2) dustprop(1,i) = fourpi/3. * dustprop(2,i) * (dustprop(1,i))**3 else dustprop(1,i) = fourpi/3. * dustprop(2,i) * (grainsizecgs / udist)**3 diff --git a/src/main/part.F90 b/src/main/part.F90 index 21d68f8fd..db2483ee1 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -80,7 +80,6 @@ module part !- porosity integer, allocatable :: dragreg(:) !- drag regime real, allocatable :: mprev(:) !- previous mass - real, allocatable :: filfacprev(:) !- previous filling factor needed for minimum St condition real, allocatable :: filfac(:) !- filling factor real, allocatable :: probastick(:) !-probabily of sticking, when bounce is on character(len=*), parameter :: filfac_label = 'filfac' @@ -475,7 +474,6 @@ subroutine allocate_part call allocate_array('dragreg', dragreg, maxp_growth) call allocate_array('filfac', filfac, maxp_growth) call allocate_array('mprev', mprev, maxp_growth) - call allocate_array('filfacprev', filfacprev, maxp_growth) call allocate_array('probastick', probastick, maxp_growth) call allocate_array('deltav', deltav, 3, maxdustsmall, maxp_dustfrac) call allocate_array('pxyzu', pxyzu, maxvxyzu, maxgr) @@ -559,7 +557,6 @@ subroutine deallocate_part if (allocated(dragreg)) deallocate(dragreg) if (allocated(filfac)) deallocate(filfac) if (allocated(mprev)) deallocate(mprev) - if (allocated(filfacprev)) deallocate(filfacprev) if (allocated(probastick)) deallocate(probastick) if (allocated(deltav)) deallocate(deltav) if (allocated(pxyzu)) deallocate(pxyzu) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index c4a37005a..aa34b9bc9 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -101,7 +101,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) iamboundary,get_ntypes,npartoftypetot,& dustfrac,dustevol,ddustevol,eos_vars,alphaind,nptmass,& dustprop,ddustprop,dustproppred,ndustsmall,pxyzu,dens,metrics,ics,& - filfac,filfacpred,mprev,filfacprev + filfac,filfacpred,mprev use options, only:avdecayconst,alpha,ieos,alphamax use deriv, only:derivs use timestep, only:dterr,bignumber,tolv @@ -179,7 +179,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp shared(rad,drad,pxyzu)& !$omp shared(Bevol,dBevol,dustevol,ddustevol,use_dustfrac) & !$omp shared(dustprop,ddustprop,dustproppred,ufloor) & - !$omp shared(mprev,filfacprev,filfac,use_porosity) & + !$omp shared(mprev,filfac,use_porosity) & !$omp shared(ibin,ibin_old,twas,timei) & !$omp firstprivate(itype) & !$omp private(i,hdti) & @@ -215,7 +215,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif if (use_porosity) then mprev(i) = dustprop(1,i) - filfacprev(i) = filfac(i) endif if (itype==idust .and. use_dustgrowth) then dustprop(:,i) = dustprop(:,i) + hdti*ddustprop(:,i) @@ -235,7 +234,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_porosity) then call get_filfac(npart,xyzh,mprev,filfac,dustprop,hdti) endif - call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) + call check_dustprop(npart,dustprop,filfac,ddustprop(1,:)) endif @@ -377,7 +376,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_porosity) then call get_filfac(npart,xyzh,dustprop(1,:),filfacpred,dustproppred,hdti) endif - call check_dustprop(npart,dustproppred(:,:),filfacpred,dustprop(1,:),filfac) + call check_dustprop(npart,dustproppred(:,:),filfacpred,ddustprop(1,:)) endif ! ! recalculate all SPH forces, and new timestep @@ -597,7 +596,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_porosity) then call get_filfac(npart,xyzh,mprev,filfac,dustprop,dtsph) endif - call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) + call check_dustprop(npart,dustprop,filfac,ddustprop(1,:)) endif if (gr) then @@ -671,7 +670,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_porosity) then call get_filfac(npart,xyzh,mprev,filfac,dustprop,dtsph) endif - call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) + call check_dustprop(npart,dustprop,filfac,ddustprop(1,:)) endif ! ! get new force using updated velocity: no need to recalculate density etc. diff --git a/src/utils/moddump_dustadd.f90 b/src/utils/moddump_dustadd.f90 index a6474e8fd..591b6d46c 100644 --- a/src/utils/moddump_dustadd.f90 +++ b/src/utils/moddump_dustadd.f90 @@ -46,7 +46,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) integer :: i,j,itype,ipart,iloc,dust_method,np_ratio,np_gas,np_dust,maxdust real :: dust_to_gas,smincgs,smaxcgs,sindex,dustbinfrac(maxdusttypes),udens integer :: iremoveparttype - real :: inradius,outradius,pwl_sizedistrib,R_ref + real :: inradius,outradius,pwl_sizedistrib,R_ref,H_R_ref,q_index logical :: icutinside,icutoutside,sizedistrib @@ -65,6 +65,8 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) dustbinfrac = 0. pwl_sizedistrib = -2 R_ref = 100 + H_R_ref = 0.0895 + q_index = 0.25 icutinside = .false. icutoutside = .false. @@ -124,6 +126,8 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call prompt('Enter grain size in cm at Rref',grainsizecgs,0.) call prompt('Enter power-law index ',pwl_sizedistrib) call prompt('Enter R_ref ',R_ref,0.) + call prompt('Enter H/R at R_ref',H_R_ref,0.) + call prompt('Enter q index',q_index) else call prompt('Enter initial grain size in cm',grainsizecgs,0.) endif @@ -190,7 +194,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) enddo endif if (use_dustgrowth) then - call set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref) + call set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_index) endif endif !Delete particles if necessary From ab7a4f72b4bf0dc4f4b618b3c4d944657c59f066 Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Thu, 6 Apr 2023 23:34:36 +1000 Subject: [PATCH 027/814] better St limit with porosity --- src/main/growth.F90 | 56 +++++++++++++++++++++++++++----------- src/main/part.F90 | 3 ++ src/main/step_leapfrog.F90 | 13 +++++---- 3 files changed, 50 insertions(+), 22 deletions(-) diff --git a/src/main/growth.F90 b/src/main/growth.F90 index a6a3ad8b0..827ccae54 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -23,6 +23,7 @@ module growth ! - flyby : *use primary for keplerian freq. calculation* ! - force_smax : *(mcfost) set manually maximum size for binning* ! - grainsizemin : *minimum allowed grain size in cm* +! - stokesmin : *minimum allowed Stokes number when porosity is on* ! - ieros : *erosion of dust (0=off,1=on)* ! - ifrag : *fragmentation of dust (0=off,1=on,2=Kobayashi)* ! - ieros : *erosion of dust (0=off,1=on) @@ -47,6 +48,7 @@ module growth integer, public :: ieros = 0 real, public :: gsizemincgs = 5.e-3 + real, public :: stokesmin = 5.e-5 real, public :: rsnow = 100. real, public :: Tsnow = 150. real, public :: vfragSI = 15. @@ -106,7 +108,7 @@ subroutine init_growth(ierr) call error('init_growth','grainsizemin < 0',var='grainsizemin',val=grainsizemin) ierr = 1 endif - if (gsizemincgs > grainsizecgs) then + if (gsizemincgs > grainsizecgs .and. .not. use_porosity) then call error('init_growth','grainsizemin > grainsize',var='grainsizemin',val=grainsizemin) ierr = 1 endif @@ -377,7 +379,11 @@ subroutine write_options_growth(iunit) call write_inopt(ifrag,'ifrag','dust fragmentation (0=off,1=on,2=Kobayashi)',iunit) call write_inopt(ieros,'ieros','erosion of dust (0=off,1=on)',iunit) if (ifrag /= 0) then - call write_inopt(gsizemincgs,'grainsizemin','minimum grain size in cm',iunit) + if (use_porosity) then + call write_inopt(stokesmin,'stokesmin','minimum allowed stokes number',iunit) + else + call write_inopt(gsizemincgs,'grainsizemin','minimum grain size in cm',iunit) + endif call write_inopt(isnow,'isnow','snow line (0=off,1=position based,2=temperature based)',iunit) if (isnow == 1) call write_inopt(rsnow,'rsnow','position of the snow line in AU',iunit) if (isnow == 2) call write_inopt(Tsnow,'Tsnow','snow line condensation temperature in K',iunit) @@ -428,6 +434,9 @@ subroutine read_options_growth(name,valstring,imatch,igotall,ierr) case('grainsizemin') read(valstring,*,iostat=ierr) gsizemincgs ngot = ngot + 1 + case('stokesmin') + read(valstring,*,iostat=ierr) stokesmin + ngot = ngot + 1 case('isnow') read(valstring,*,iostat=ierr) isnow ngot = ngot + 1 @@ -519,7 +528,11 @@ subroutine write_growth_setup_options(iunit) call write_inopt(vfragSI,'vfrag','uniform fragmentation threshold in m/s',iunit) call write_inopt(vfraginSI,'vfragin','inward fragmentation threshold in m/s',iunit) call write_inopt(vfragoutSI,'vfragout','inward fragmentation threshold in m/s',iunit) - call write_inopt(gsizemincgs,'grainsizemin','minimum allowed grain size in cm',iunit) + if (use_porosity) then + call write_inopt(stokesmin,'stokesmin','minimum allowed stokes number',iunit) + else + call write_inopt(gsizemincgs,'grainsizemin','minimum allowed grain size in cm',iunit) + endif end subroutine write_growth_setup_options @@ -538,7 +551,11 @@ subroutine read_growth_setup_options(db,nerr) call read_inopt(ieros,'ieros',db,min=0,max=1,errcount=nerr) if (ifrag > 0) then call read_inopt(isnow,'isnow',db,min=0,max=2,errcount=nerr) - call read_inopt(gsizemincgs,'grainsizemin',db,min=1.e-5,errcount=nerr) + if (use_porosity) then + call read_inopt(stokesmin,'stokesmin',db,min=1.e-5,errcount=nerr) + else + call read_inopt(gsizemincgs,'grainsizemin',db,min=1.e-5,errcount=nerr) + endif select case(isnow) case(0) call read_inopt(vfragSI,'vfrag',db,min=0.,errcount=nerr) @@ -560,30 +577,37 @@ end subroutine read_growth_setup_options ! In case of fragmentation, limit masses to a minimum value !+ !----------------------------------------------------------------------- -subroutine check_dustprop(npart,dustprop,filfac,dmdt) - use part, only:iamtype,iphase,idust,igas +subroutine check_dustprop(npart,dustprop,filfac,mprev,filfacprev) + use part, only:iamtype,iphase,idust,igas,dustgasprop use options, only:use_dustfrac,use_porosity real,intent(inout) :: dustprop(:,:) integer,intent(in) :: npart - real, intent(in) :: filfac(:),dmdt(:) + real, intent(in) :: filfac(:),mprev(:),filfacprev(:) integer :: i,iam - real :: sdust + real :: stokesnew,sdustprev,sdustmin,sdust !$omp parallel do default(none) & - !$omp shared(iphase,use_dustfrac,use_porosity) & - !$omp shared(npart,ifrag,dustprop,filfac,dmdt,grainsizemin) & - !$omp private(i,iam,sdust) + !$omp shared(iphase,dustgasprop,use_dustfrac,use_porosity) & + !$omp shared(npart,ifrag,dustprop,filfac,mprev,filfacprev) & + !$omp shared(stokesmin,grainsizemin) & + !$omp private(i,iam,stokesnew,sdustprev,sdustmin,sdust) do i=1,npart iam = iamtype(iphase(i)) - if ((iam == idust .or. (use_dustfrac .and. iam == igas)) .and. ifrag > 0 .and. dmdt(i) < 0.) then + if ((iam == idust .or. (use_dustfrac .and. iam == igas)) .and. ifrag > 0 .and. dustprop(1,i) <= mprev(i)) then if (use_porosity) then + sdustprev = get_size(mprev(i),dustprop(2,i),filfacprev(i)) sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) + stokesnew = dustgasprop(3,i)*sdustprev*filfacprev(i)/sdust/filfac(i) + if (stokesnew < stokesmin) then + sdustmin = stokesmin*sdustprev*filfacprev(i)/filfac(i)/dustgasprop(3,i) + dustprop(1,i) = dustprop(1,i) * (sdustmin/sdust)**3. + endif else sdust = get_size(dustprop(1,i),dustprop(2,i)) - endif - if (sdust < grainsizemin) then - dustprop(1,i) = dustprop(1,i) * (grainsizemin/sdust)**3. ! fragmentation at constant density and filling factor - endif + if (sdust < grainsizemin) then + dustprop(1,i) = dustprop(1,i) * (grainsizemin/sdust)**3. ! fragmentation at constant density and filling factor + endif + endif endif enddo !$omp end parallel do diff --git a/src/main/part.F90 b/src/main/part.F90 index db2483ee1..ea7d40545 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -81,6 +81,7 @@ module part integer, allocatable :: dragreg(:) !- drag regime real, allocatable :: mprev(:) !- previous mass real, allocatable :: filfac(:) !- filling factor + real, allocatable :: filfacprev(:) !- previous filling factor needed for minimum St condition real, allocatable :: probastick(:) !-probabily of sticking, when bounce is on character(len=*), parameter :: filfac_label = 'filfac' !- options @@ -475,6 +476,7 @@ subroutine allocate_part call allocate_array('filfac', filfac, maxp_growth) call allocate_array('mprev', mprev, maxp_growth) call allocate_array('probastick', probastick, maxp_growth) + call allocate_array('filfacprev', filfacprev, maxp_growth) call allocate_array('deltav', deltav, 3, maxdustsmall, maxp_dustfrac) call allocate_array('pxyzu', pxyzu, maxvxyzu, maxgr) call allocate_array('dens', dens, maxgr) @@ -557,6 +559,7 @@ subroutine deallocate_part if (allocated(dragreg)) deallocate(dragreg) if (allocated(filfac)) deallocate(filfac) if (allocated(mprev)) deallocate(mprev) + if (allocated(filfacprev)) deallocate(filfacprev) if (allocated(probastick)) deallocate(probastick) if (allocated(deltav)) deallocate(deltav) if (allocated(pxyzu)) deallocate(pxyzu) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index aa34b9bc9..c4a37005a 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -101,7 +101,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) iamboundary,get_ntypes,npartoftypetot,& dustfrac,dustevol,ddustevol,eos_vars,alphaind,nptmass,& dustprop,ddustprop,dustproppred,ndustsmall,pxyzu,dens,metrics,ics,& - filfac,filfacpred,mprev + filfac,filfacpred,mprev,filfacprev use options, only:avdecayconst,alpha,ieos,alphamax use deriv, only:derivs use timestep, only:dterr,bignumber,tolv @@ -179,7 +179,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp shared(rad,drad,pxyzu)& !$omp shared(Bevol,dBevol,dustevol,ddustevol,use_dustfrac) & !$omp shared(dustprop,ddustprop,dustproppred,ufloor) & - !$omp shared(mprev,filfac,use_porosity) & + !$omp shared(mprev,filfacprev,filfac,use_porosity) & !$omp shared(ibin,ibin_old,twas,timei) & !$omp firstprivate(itype) & !$omp private(i,hdti) & @@ -215,6 +215,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif if (use_porosity) then mprev(i) = dustprop(1,i) + filfacprev(i) = filfac(i) endif if (itype==idust .and. use_dustgrowth) then dustprop(:,i) = dustprop(:,i) + hdti*ddustprop(:,i) @@ -234,7 +235,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_porosity) then call get_filfac(npart,xyzh,mprev,filfac,dustprop,hdti) endif - call check_dustprop(npart,dustprop,filfac,ddustprop(1,:)) + call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif @@ -376,7 +377,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_porosity) then call get_filfac(npart,xyzh,dustprop(1,:),filfacpred,dustproppred,hdti) endif - call check_dustprop(npart,dustproppred(:,:),filfacpred,ddustprop(1,:)) + call check_dustprop(npart,dustproppred(:,:),filfacpred,dustprop(1,:),filfac) endif ! ! recalculate all SPH forces, and new timestep @@ -596,7 +597,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_porosity) then call get_filfac(npart,xyzh,mprev,filfac,dustprop,dtsph) endif - call check_dustprop(npart,dustprop,filfac,ddustprop(1,:)) + call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif if (gr) then @@ -670,7 +671,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_porosity) then call get_filfac(npart,xyzh,mprev,filfac,dustprop,dtsph) endif - call check_dustprop(npart,dustprop,filfac,ddustprop(1,:)) + call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif ! ! get new force using updated velocity: no need to recalculate density etc. From 60fe91545b77827121f5830a5b7171d014dbe894 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Fri, 7 Apr 2023 15:13:47 +1000 Subject: [PATCH 028/814] Added parrelisation for simple loops --- src/main/extern_gr.F90 | 6 +++++- src/utils/einsteintk_wrapper.f90 | 17 ++++++++++++++--- 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 27cc6c9b1..275351da2 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -235,6 +235,9 @@ subroutine get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) verbose = .false. ! TODO write openmp parallel code + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,metrics,vxyzu,dens,ieos,tmunus) & + !$omp private(i,pi,verbose) do i=1, npart !print*, "i: ", i if (i==1) then @@ -247,7 +250,8 @@ subroutine get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) call get_tmunu(xyzh(:,i),metrics(:,:,:,i),& vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i),verbose) endif - enddo + enddo + !$omp end parallel do !print*, "tmunu calc val is: ", tmunus(0,0,5) end subroutine get_tmunu_all diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 671dc1c53..730096519 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -310,7 +310,10 @@ subroutine phantom2et_rhostar() ! get particle data ! get rho from xyzh and rhoh ! Get the conserved density on the particles - dat = 0. + dat = 0. + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,dat,igas) & + !$omp private(i,pmass,h,rho) do i=1, npart ! Get the smoothing length h = xyzh(4,i) @@ -319,6 +322,7 @@ subroutine phantom2et_rhostar() rho = rhoh(h,pmass) dat(i) = rho enddo + !$omp end parallel do rhostargrid = 0. call interpolate_to_grid(rhostargrid,dat) @@ -349,10 +353,14 @@ subroutine phantom2et_entropy() ! get rho from xyzh and rhoh ! Get the conserved density on the particles dat = 0. + !$omp parallel do default(none) & + !$omp shared(npart,pxyzu,dat) & + !$omp private(i) do i=1, npart ! Entropy is the u component of pxyzu dat(i) = pxyzu(4,i) enddo + !$omp end parallel do entropygrid = 0. call interpolate_to_grid(entropygrid,dat) @@ -375,13 +383,16 @@ subroutine phantom2et_momentum() ! Interpolate from particles to grid ! get particle data for the x component of momentum - dat = 0. + dat = 0. + !$omp parallel do default(none) & + !$omp shared(npart,pxyzu,dat) & + !$omp private(i) do i=1, npart dat(1,i) = pxyzu(1,i) dat(2,i) = pxyzu(2,i) dat(3,i) = pxyzu(3,i) enddo - + !$omp end parallel do pxgrid = 0. ! call interpolate 3d ! In this case call it 3 times one for each vector component From 5b7e950a56ea06f1026190cc94c3eee06616d017 Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Wed, 12 Apr 2023 00:18:59 +0900 Subject: [PATCH 029/814] add correction + // loop for porosity routines --- src/main/force.F90 | 4 +--- src/main/porosity.f90 | 20 +++++++++++++++----- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/src/main/force.F90 b/src/main/force.F90 index 3c5a707e7..1aec99525 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -3119,9 +3119,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv tstop(:,i) = tstopi(:) elseif (use_dust .and. .not.use_dustfrac) then tstop(:,i) = ts_min - if (drag_implicit) then - dtdrag = 90.*ts_min - else + if (.not. drag_implicit) then dtdrag = 0.9*ts_min endif endif diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 0b8890234..376a7ae10 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -22,7 +22,6 @@ module porosity real, public :: surfenerg real, public :: youngmod real, private :: eroll !--rolling - real, private :: grainmassmin = 1e-09 !--minimum grain mass for disruption (~100µm) real, private :: grainmassminlog real, private :: Yd0 !test for compaction real, private :: Ydpow !test for compaction @@ -55,7 +54,7 @@ subroutine init_porosity(ierr) Yd0 = 9.5e6 *10/unit_pressure ! for water+silicate; 9.8e6 for water only Ydpow = 6.4 !for silicate+water, 4 for water only - grainmassminlog = log10(grainmassmin/umass) + grainmassminlog = log10(50.*mmono) if (smono <= 0.) then call error('init_porosity','smonocgs <= 0',var='smonocgs',val=smonocgs) @@ -333,7 +332,8 @@ subroutine get_filfac_bounce(mprev,graindens,filfac,dustgasprop,probastick,rhod, ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !-number of collision in dt ekin = mprev*vrel*vrel/4. coeffrest = get_coeffrest(vstick/vrel,vyield/vrel) !-coefficient of restitution - pdyn = eroll * (filfac/(maxpacking - filfac)/smono)**3 + !pdyn = eroll * (filfac/(maxpacking - filfac)/smono)**3 + pdyn = eroll /((1./filfac - 1./maxpacking)*smono)**3 deltavol = (1.-coeffrest*coeffrest)*ekin/pdyn if (deltavol > vol) deltavol = vol @@ -426,7 +426,7 @@ subroutine get_filfac_frag(mprev,dustprop,filfac,dustgasprop,rhod,VrelVf,dt,filf ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !number of collisions in dt ekin = mprev*vrel*vrel/4. - (2.*mprev - dustprop(1))*0.23805*eroll/mmono !0.23805 = 1.5 * 48/302.46 - pdyn = eroll * (filfac/(maxpacking - filfac)/smono)**3 + pdyn = eroll /((1./filfac - 1./maxpacking)*smono)**3 deltavol = ekin/pdyn !-ekin is kinetic energy - all energy needed to break monomers if (deltavol < 0) deltavol = 0. @@ -551,6 +551,11 @@ subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) select case (idisrupt) case(1) + !$omp parallel do default(none) & + !$omp shared(xyzh,npart,massoftype,iphase,use_dustfrac) & + !$omp shared(filfac,dustprop,dustgasprop,mmono,smono,grainmassminlog,surfenerg,gammaft) & + !$omp private(grainmasscurlog,grainmassmaxlog,randmass) & + !$omp private(i,iam,rho,filfacmin,stress,strength) do i=1, npart if (.not.isdead_or_accreted(xyzh(4,i))) then iam = iamtype(iphase(i)) @@ -587,11 +592,11 @@ subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) !-compute filfacmin and compare it to filfac(i) call get_filfac_min(i,rho,dustprop(1,i)/mmono,dustprop(2,i),dustgasprop(:,i),filfacmin) filfac(i) = max(filfac(i),filfacmin) - endif endif endif enddo + !$omp end parallel do end select end subroutine get_disruption @@ -615,6 +620,10 @@ subroutine get_probastick(npart,xyzh,dmdt,dustprop,dustgasprop,filfac) real :: vrel,vstick,vend,sdust if (ibounce == 1) then + !$omp parallel do default(none) & + !$omp shared(xyzh,npart,iphase,use_dustfrac) & + !$omp shared(filfac,dmdt,dustprop,dustgasprop,probastick) & + !$omp private(i,iam,vrel,vstick,vend,sdust,shearparam) do i=1, npart if (.not.isdead_or_accreted(xyzh(4,i))) then iam = iamtype(iphase(i)) @@ -643,6 +652,7 @@ subroutine get_probastick(npart,xyzh,dmdt,dustprop,dustgasprop,filfac) endif endif enddo + !$omp end parallel do endif end subroutine get_probastick From 085ca68c3fcc7cffed21eb2081695bd6ea1d4008 Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Wed, 12 Apr 2023 00:24:59 +0900 Subject: [PATCH 030/814] add correction --- src/main/porosity.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 376a7ae10..ae0baecb5 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -622,8 +622,8 @@ subroutine get_probastick(npart,xyzh,dmdt,dustprop,dustgasprop,filfac) if (ibounce == 1) then !$omp parallel do default(none) & !$omp shared(xyzh,npart,iphase,use_dustfrac) & - !$omp shared(filfac,dmdt,dustprop,dustgasprop,probastick) & - !$omp private(i,iam,vrel,vstick,vend,sdust,shearparam) + !$omp shared(filfac,dmdt,dustprop,dustgasprop,probastick,shearparam) & + !$omp private(i,iam,vrel,vstick,vend,sdust) do i=1, npart if (.not.isdead_or_accreted(xyzh(4,i))) then iam = iamtype(iphase(i)) From b52fb740abad3cef3a5233588e542c0eee462da0 Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Fri, 14 Apr 2023 23:06:56 +0900 Subject: [PATCH 031/814] correct disruption --- src/main/porosity.f90 | 2 +- src/utils/moddump_dustadd.f90 | 18 ++++++++---------- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index ae0baecb5..7fd071289 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -578,7 +578,7 @@ subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) !--call random number between 2 float values to assign a random mass to dustprop(1) if (grainmassmaxlog > grainmassminlog) then - randmass = (grainmassmaxlog - grainmassminlog) * rand() + grainmassminlog + randmass = (grainmassmaxlog - grainmassminlog) * random_number() + grainmassminlog else if (grainmasscurlog > grainmassminlog) then randmass = grainmassminlog diff --git a/src/utils/moddump_dustadd.f90 b/src/utils/moddump_dustadd.f90 index 591b6d46c..f915eab2f 100644 --- a/src/utils/moddump_dustadd.f90 +++ b/src/utils/moddump_dustadd.f90 @@ -121,16 +121,14 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call prompt('Use porosity ? (0=no,1=yes)',iporosity,0,1) if (iporosity == 1) then use_porosity = .true. - call prompt('Set dust size via size distribution ?',sizedistrib) - if (sizedistrib) then - call prompt('Enter grain size in cm at Rref',grainsizecgs,0.) - call prompt('Enter power-law index ',pwl_sizedistrib) - call prompt('Enter R_ref ',R_ref,0.) - call prompt('Enter H/R at R_ref',H_R_ref,0.) - call prompt('Enter q index',q_index) - else - call prompt('Enter initial grain size in cm',grainsizecgs,0.) - endif + endif + call prompt('Set dust size via size distribution ?',sizedistrib) + if (sizedistrib) then + call prompt('Enter grain size in cm at Rref',grainsizecgs,0.) + call prompt('Enter power-law index ',pwl_sizedistrib) + call prompt('Enter R_ref ',R_ref,0.) + call prompt('Enter H/R at R_ref',H_R_ref,0.) + call prompt('Enter q index',q_index) else call prompt('Enter initial grain size in cm',grainsizecgs,0.) endif From 676ddee04ee7972d7e3ea0eb3180c9cb8f4891cb Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Mon, 17 Apr 2023 19:22:36 +0900 Subject: [PATCH 032/814] use random function for disruption --- src/main/porosity.f90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 7fd071289..e79b31c7c 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -542,10 +542,11 @@ subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) use options, only:use_dustfrac use part, only:idust,igas,iamtype,iphase,massoftype,isdead_or_accreted,rhoh use growth, only:check_dustprop,get_size + use random, only:ran2 integer, intent(in) :: npart real, intent(in) :: xyzh(:,:),dustgasprop(:,:) real, intent(inout) :: dustprop(:,:),filfac(:) - integer :: i,iam + integer :: i,iam,seed real :: stress,strength,filfacmin,rho real :: grainmasscurlog,grainmassmaxlog,randmass @@ -554,7 +555,7 @@ subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) !$omp parallel do default(none) & !$omp shared(xyzh,npart,massoftype,iphase,use_dustfrac) & !$omp shared(filfac,dustprop,dustgasprop,mmono,smono,grainmassminlog,surfenerg,gammaft) & - !$omp private(grainmasscurlog,grainmassmaxlog,randmass) & + !$omp private(grainmasscurlog,grainmassmaxlog,randmass,seed) & !$omp private(i,iam,rho,filfacmin,stress,strength) do i=1, npart if (.not.isdead_or_accreted(xyzh(4,i))) then @@ -563,6 +564,7 @@ subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) stress = 25./36. * dustprop(2,i) * filfac(i) * gammaft**2 * dustgasprop(4,i)**2 strength = 0.6*filfac(i)**(1.8)*surfenerg/smono + seed = int(stress) if (stress >= strength) then !-grain is rotationnaly disrupted !-compute rho to compute filfacmin @@ -578,7 +580,7 @@ subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) !--call random number between 2 float values to assign a random mass to dustprop(1) if (grainmassmaxlog > grainmassminlog) then - randmass = (grainmassmaxlog - grainmassminlog) * random_number() + grainmassminlog + randmass = (grainmassmaxlog - grainmassminlog) * ran2(seed) + grainmassminlog else if (grainmasscurlog > grainmassminlog) then randmass = grainmassminlog From e39125567109fbbc55da5c87452970fb34116ee0 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 18 Apr 2023 16:33:59 +1000 Subject: [PATCH 033/814] Added code to change perturbation wavelength --- src/setup/setup_flrw.f90 | 4 +++- src/utils/einsteintk_wrapper.f90 | 11 ++++++----- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 88a4a6d4d..c89575200 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -42,6 +42,7 @@ module setup integer :: npartx,ilattice real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,Bzero,ampl,phaseoffset character(len=20) :: dist_unit,mass_unit,perturb_direction,perturb,radiation_dominated + real :: perturb_wavelength real(kind=8) :: udist,umass !--change default defaults to reproduce the test from Section 5.6.7 of Price+(2018) @@ -90,7 +91,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real :: kwave,denom,length, c1,c3,lambda real :: perturb_rho0,xval real :: Vup(0:3),v(0:3),const,phi,rhoprim,sqrtg,u0,x,gcov(0:3,0:3),alpha,hub - real :: perturb_wavelength real :: last_scattering_temp real :: u procedure(rho_func), pointer :: density_func @@ -530,6 +530,7 @@ subroutine write_setupfile(filename) call write_inopt(phaseoffset,'FLRWSolver::phi_phase_offset','Pertubation phase offset',iunit) call write_inopt(perturb_direction, 'FLRWSolver::FLRW_perturb_direction','Pertubation direction',iunit) call write_inopt(radiation_dominated, 'radiation_dominated','Radiation dominated universe (yes/no)',iunit) + call write_inopt(perturb_wavelength,'FLRWSolver::single_perturb_wavelength','Perturbation wavelength',iunit) if (use_dustfrac) then call write_inopt(dust_to_gas,'dust_to_gas','dust-to-gas ratio',iunit) endif @@ -588,6 +589,7 @@ subroutine read_setupfile(filename,ierr) ! TODO Work out why this doesn't read in correctly call read_inopt(perturb,'FLRWSolver::FLRW_perturb',db,errcount=nerr) call read_inopt(radiation_dominated,'radiation_dominated',db,errcount=nerr) + call read_inopt(perturb_wavelength,'FLRWSolver::single_perturb_wavelength',db,errcount=nerr) !print*, db call close_db(db) diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 730096519..0fa682da8 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -311,18 +311,19 @@ subroutine phantom2et_rhostar() ! get rho from xyzh and rhoh ! Get the conserved density on the particles dat = 0. - !$omp parallel do default(none) & - !$omp shared(npart,xyzh,dat,igas) & - !$omp private(i,pmass,h,rho) + pmass = massoftype(igas) + ! $omp parallel do default(none) & + ! $omp shared(npart,xyzh,dat,pmass) & + ! $omp private(i,h,rho) do i=1, npart ! Get the smoothing length h = xyzh(4,i) ! Get pmass - pmass = massoftype(igas) + rho = rhoh(h,pmass) dat(i) = rho enddo - !$omp end parallel do + ! $omp end parallel do rhostargrid = 0. call interpolate_to_grid(rhostargrid,dat) From bcd2830760761305055993a1e5e17aef03c06e7c Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Fri, 21 Apr 2023 13:26:52 +1000 Subject: [PATCH 034/814] Fixed compilation errors with master branch merge --- src/main/cons2primsolver.f90 | 2 +- src/main/metric_tools.F90 | 2 +- src/utils/einsteintk_wrapper.f90 | 44 +++++++++++++++++--------------- 3 files changed, 25 insertions(+), 23 deletions(-) diff --git a/src/main/cons2primsolver.f90 b/src/main/cons2primsolver.f90 index 369b357fb..3dae367e2 100644 --- a/src/main/cons2primsolver.f90 +++ b/src/main/cons2primsolver.f90 @@ -144,7 +144,7 @@ subroutine conservative2primitive(x,metrici,v,dens,u,P,temp,gamma,rho,pmom,en,ie integer, intent(in) :: ien_type real, dimension(1:3,1:3) :: gammaijUP real :: sqrtg,sqrtg_inv,lorentz_LEO,pmom2,alpha,betadown(1:3),betaUP(1:3),enth_old,v3d(1:3) - real :: f,df,term,lorentz_LEO2,gamfac,pm_dot_b,sqrt_gamma_inv,enth,gamma1 + real :: f,df,term,lorentz_LEO2,gamfac,pm_dot_b,sqrt_gamma_inv,enth,gamma1,sqrt_gamma real(kind=8) :: cgsdens,cgsu integer :: niter, i real, parameter :: tol = 1.e-12 diff --git a/src/main/metric_tools.F90 b/src/main/metric_tools.F90 index 28c7c5756..d2292b65d 100644 --- a/src/main/metric_tools.F90 +++ b/src/main/metric_tools.F90 @@ -33,7 +33,7 @@ module metric_tools integer, public, parameter :: & imet_minkowski = 1, & ! Minkowski metric imet_schwarzschild = 2, & ! Schwarzschild metric - imet_kerr = 3, ! Kerr metric + imet_kerr = 3, & ! Kerr metric imet_et = 6 ! Tabulated metric from Einstein toolkit !--- Choice of coordinate system diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 0fa682da8..902c568a4 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -16,7 +16,7 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) use io, only:id,master,nprocs,set_io_unit_numbers,die use mpiutils, only:init_mpi,finalise_mpi use initial, only:initialise,finalise,startrun,endrun - use evolve, only:evol_init + !use evolve, only:evol_init use tmunu2grid use einsteintk_utils use extern_gr @@ -69,8 +69,9 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) !print*, "tmunugrid: ", tmunugrid(1,1,6,6,6) !stop ! Intialises values for the evol routine: t, dt, etc.. - call evol_init(infilestor,logfilestor,evfilestor,dumpfilestor,dt_et,nophantompart) - print*, "Evolve init finished!" + !call evol_init(infilestor,logfilestor,evfilestor,dumpfilestor,dt_et,nophantompart) + !print*, "Evolve init finished!" + nophantompart = npart ! Calculate the stress energy tensor for each particle ! Might be better to do this in evolve init !call get_tmunugrid_all @@ -113,28 +114,29 @@ subroutine et2phantom(rho,nx,ny,nz) ! send grid limits end subroutine et2phantom - subroutine step_et2phantom(infile,dt_et) - use einsteintk_utils - use evolve, only:evol_step - use tmunu2grid - character(len=*), intent(in) :: infile - real, intent(inout) :: dt_et - character(len=500) :: logfile,evfile,dumpfile,path + ! DONT THINK THIS IS USED ANYWHERE!!! + ! subroutine step_et2phantom(infile,dt_et) + ! use einsteintk_utils + ! use evolve, only:evol_step + ! use tmunu2grid + ! character(len=*), intent(in) :: infile + ! real, intent(inout) :: dt_et + ! character(len=500) :: logfile,evfile,dumpfile,path - ! Print the values of logfile, evfile, dumpfile to check they are sensible - !print*, "logfile, evfile, dumpfile: ", logfile, evfile, dumpfile - print*, "stored values of logfile, evfile, dumpfile: ", logfilestor, evfilestor, dumpfilestor + ! ! Print the values of logfile, evfile, dumpfile to check they are sensible + ! !print*, "logfile, evfile, dumpfile: ", logfile, evfile, dumpfile + ! print*, "stored values of logfile, evfile, dumpfile: ", logfilestor, evfilestor, dumpfilestor - ! Interpolation stuff - ! Call et2phantom (construct global grid, metric, metric derivs, determinant) - ! Run phantom for a step - call evol_step(infile,logfilestor,evfilestor,dumpfilestor,dt_et) - ! Interpolation stuff back to et - !call get_tmunugrid_all() - ! call phantom2et (Tmunu_grid) + ! ! Interpolation stuff + ! ! Call et2phantom (construct global grid, metric, metric derivs, determinant) + ! ! Run phantom for a step + ! call evol_step(infile,logfilestor,evfilestor,dumpfilestor,dt_et) + ! ! Interpolation stuff back to et + ! !call get_tmunugrid_all() + ! ! call phantom2et (Tmunu_grid) - end subroutine step_et2phantom + ! end subroutine step_et2phantom subroutine phantom2et() ! should take in the cctk_array for tmunu?? From b949d7deee22d869939ec5cee0a87f6374ab4eaa Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Mon, 24 Apr 2023 14:59:56 +1000 Subject: [PATCH 035/814] Added powerspectrum flrw setup --- build/Makefile_setups | 9 +- src/setup/setup_flrwpspec.f90 | 620 ++++++++++++++++++++++++++++++++++ 2 files changed, 628 insertions(+), 1 deletion(-) create mode 100644 src/setup/setup_flrwpspec.f90 diff --git a/build/Makefile_setups b/build/Makefile_setups index 80a6b5d23..c0cf06553 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -1002,7 +1002,14 @@ ifeq ($(SETUP), flrw) SETUPFILE= setup_flrw.f90 PERIODIC=yes endif - +ifeq ($(SETUP), flrwpspec) + GR=yes + KNOWN_SETUP=yes + IND_TIMESTEPS=no + METRIC=et + SETUPFILE= setup_flrwpspec.f90 + PERIODIC=yes +endif ifeq ($(SETUP), default) # default setup, uniform box KNOWN_SETUP=yes diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 new file mode 100644 index 000000000..1413cf990 --- /dev/null +++ b/src/setup/setup_flrwpspec.f90 @@ -0,0 +1,620 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.bitbucket.io/ ! +!--------------------------------------------------------------------------! +module setup +! +! Setup routine for uniform distribution +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: +! - Bzero : *magnetic field strength in code units* +! - cs0 : *initial sound speed in code units* +! - dist_unit : *distance unit (e.g. au)* +! - dust_to_gas : *dust-to-gas ratio* +! - ilattice : *lattice type (1=cubic, 2=closepacked)* +! - mass_unit : *mass unit (e.g. solarm)* +! - nx : *number of particles in x direction* +! - rhozero : *initial density in code units* +! - xmax : *xmax boundary* +! - xmin : *xmin boundary* +! - ymax : *ymax boundary* +! - ymin : *ymin boundary* +! - zmax : *zmax boundary* +! - zmin : *zmin boundary* +! +! :Dependencies: boundary, cooling, dim, eos, h2cooling, infile_utils, io, +! mpidomain, mpiutils, options, part, physcon, prompting, set_dust, +! setup_params, timestep, unifdis, units +! + use dim, only:use_dust,mhd + use options, only:use_dustfrac + use setup_params, only:rhozero + use physcon, only:radconst + implicit none + public :: setpart + + integer :: npartx,ilattice + real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,Bzero,ampl,phaseoffset + character(len=20) :: dist_unit,mass_unit,perturb_direction,perturb,radiation_dominated + real :: perturb_wavelength + real(kind=8) :: udist,umass + + !--change default defaults to reproduce the test from Section 5.6.7 of Price+(2018) + logical :: BalsaraKim = .false. + + !--dust + real :: dust_to_gas + + private + +contains + +!---------------------------------------------------------------- +!+ +! setup for uniform particle distributions +!+ +!---------------------------------------------------------------- +subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) + use dim, only:maxvxyzu,gr + use setup_params, only:npart_total + use io, only:master + use unifdis, only:set_unifdis,rho_func,mass_func + use boundary, only:xmin,ymin,zmin,xmax,ymax,zmax,dxbound,dybound,dzbound,set_boundary,cross_boundary + use part, only:periodic + use physcon, only:years,pc,solarm + use units, only:set_units + use mpidomain, only:i_belong + use stretchmap, only:set_density_profile + use utils_gr, only:perturb_metric, get_u0, get_sqrtg + !use cons2primsolver, only:primative2conservative + + integer, intent(in) :: id + integer, intent(inout) :: npart + integer, intent(out) :: npartoftype(:) + real, intent(out) :: xyzh(:,:) + real, intent(out) :: massoftype(:) + real, intent(out) :: polyk,gamma + real, intent(inout) :: hfact + real, intent(inout) :: time + character(len=20), intent(in) :: fileprefix + real, intent(out) :: vxyzu(:,:) + character(len=40) :: filename,lattice,pspec_filename1,pspec_filename2,pspec_filename3 + real :: totmass,deltax,pi + integer :: i,j,k,ierr,ncross + logical :: iexist,isperiodic(3) + real :: kwave,denom,length, c1,c3,lambda + real :: perturb_rho0,xval + real :: Vup(0:3),v(0:3),const,phi,rhoprim,sqrtg,u0,x,gcov(0:3,0:3),alpha,hub + real :: last_scattering_temp + real :: u + real :: scale_factor,gradphi(3),Hubble_param,vxyz(3),dxgrid,gridorigin + integer :: nghost, gridres, gridsize + real, allocatable :: vxgrid(:,:,:),vygrid(:,:,:),vzgrid(:,:,:) +! procedure(rho_func), pointer :: density_func +! procedure(mass_func), pointer :: mass_function + +! density_func => rhofunc ! desired density function +! mass_function => massfunc ! desired mass funciton + + ! + !--general parameters + ! + !perturb_wavelength = 1. + time = 0. + if (maxvxyzu < 4) then + gamma = 1. + else + ! 4/3 for radiation dominated case + ! irrelevant for + gamma = 4./3. + endif + ! Redefinition of pi to fix numerical error + pi = 4.D0*DATAN(1.0D0) + ! + ! default units + ! + mass_unit = 'solarm' + dist_unit = 'mpc' + ! + ! set boundaries to default values + ! + xmini = xmin; xmaxi = xmax + ymini = ymin; ymaxi = ymax + zmini = zmin; zmaxi = zmax + ! + ! set default values for input parameters + ! + npartx = 64 + ilattice = 1 + perturb = '"no"' + perturb_direction = '"none"' + radiation_dominated = '"no"' + + ! Ideally this should read the values of the box length + ! and initial Hubble parameter from the par file. + ! Then it should be set using the Friedmann equation: + !!!!!! rhozero = (3H^2)/(8*pi*a*a) + + hub = 10.553495658357338 + rhozero = 3.d0 * hub**2 / (8.d0 * pi) + phaseoffset = 0. + + ! Set some default values for the grid + nghost = 6 + gridres = 64 + + gridsize = nghost + gridres + gridorigin = 0. + xmax = 1. + dxgrid = xmax/gridres + gridorigin = gridorigin-3*dxgrid + + isperiodic = .true. + ncross = 0 + + allocate(vxgrid(gridsize,gridsize,gridsize)) + allocate(vygrid(gridsize,gridsize,gridsize)) + allocate(vzgrid(gridsize,gridsize,gridsize)) + + ! Approx Temp of the CMB in Kelvins + last_scattering_temp = 3000 + last_scattering_temp = (rhozero/radconst)**(1./4.)*0.99999 + + ! Define some parameters for Linear pertubations + ! We assume ainit = 1, but this may not always be the case + c1 = 1.d0/(4.d0*PI*rhozero) + !c2 = We set g(x^i) = 0 as we only want to extract the growing mode + c3 = - sqrt(1.d0/(6.d0*PI*rhozero)) + + + if (gr) then + ! 0 Because dust? + cs0 = 0. + else + cs0 = 1. + endif + + ! get disc setup parameters from file or interactive setup + ! + filename=trim(fileprefix)//'.setup' + inquire(file=filename,exist=iexist) + if (iexist) then + !--read from setup file + call read_setupfile(filename,ierr) + if (id==master) call write_setupfile(filename) + if (ierr /= 0) then + stop + endif + elseif (id==master) then + call setup_interactive(id,polyk) + call write_setupfile(filename) + stop 'rerun phantomsetup after editing .setup file' + else + stop + endif + ! + ! set units and boundaries + ! + if (gr) then + call set_units(dist=udist,c=1.d0,G=1.d0) + else + call set_units(dist=udist,mass=umass,G=1.d0) + endif + call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) + ! + ! setup particles + ! + + npart = 0 + npart_total = 0 + length = xmaxi - xmini + deltax = length/npartx +! +! general parameters +! +! time should be read in from the par file + time = 0.18951066686763596 ! z~1000 +! lambda = perturb_wavelength*length +! kwave = (2.d0*pi)/lambda +! denom = length - ampl/kwave*(cos(kwave*length)-1.0) + ! Hardcode to ensure double precision, that is requried + !rhozero = 13.294563008157013D0 + rhozero = 3.d0 * hub**2 / (8.d0 * pi) + + + lattice = 'cubic' + + call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& + npart,xyzh,periodic,nptot=npart_total,mask=i_belong) + + npartoftype(:) = 0 + npartoftype(1) = npart + print*,' npart = ',npart,npart_total + + + totmass = rhozero*dxbound*dybound*dzbound + massoftype = totmass/npart_total + if (id==master) print*,' particle mass = ',massoftype(1) + if (id==master) print*,' initial sound speed = ',cs0,' pressure = ',cs0**2/gamma + + + + if (maxvxyzu < 4 .or. gamma <= 1.) then + polyk = cs0**2 + else + polyk = 0. + endif + + pspec_filename1 = 'init_vel1_64.dat' + pspec_filename2 = 'init_vel2_64.dat' + pspec_filename3 = 'init_vel3_64.dat' + ! Read in velocities from vel file here + ! Should be made into a function at some point +! open(unit=444,file=pspec_filename,status='old') +! do k=1,gridsize +! do j=1,gridsize +! read(444,*) (vxgrid(i,j,k), i=1, 9) + +! enddo +! enddo +! close(444) + call read_veldata(vxgrid,pspec_filename1,gridsize) + call read_veldata(vygrid,pspec_filename2,gridsize) + call read_veldata(vzgrid,pspec_filename3,gridsize) + +! vxgrid = 1. +! vygrid = 2. +! vzgrid = 3. + !stop + do i=1,npart + ! Assign new particle possition + particle velocities here using the Zeldovich approximation: + ! Valid for Omega = 1 + ! x = q - a grad phi (1), where q is the non perturbed lattice point position + ! v = -aH grad phi (2) + ! Interpolate grid velocities to particles + ! big v vs small v? + ! Call interpolate from grid + !get_velocity_fromgrid(vxyz,pos) + ! CHECK THAT GRID ORIGIN IS CORRECT !!!!!!!!!!! + ! DO I NEED TO UPDATE THE GHOST CELLS?? + ! Get x velocity at particle position + call interpolate_val(xyzh(1:3,i),vxgrid,gridsize,gridorigin,dxgrid,vxyz(1)) + print*, "Finished x interp" + ! Get y velocity at particle position + call interpolate_val(xyzh(1:3,i),vygrid,gridsize,gridorigin,dxgrid,vxyz(2)) + ! Get z velocity at particle position + call interpolate_val(xyzh(1:3,i),vzgrid,gridsize,gridorigin,dxgrid,vxyz(3)) + + vxyzu(1:3,i) = vxyz + print*, vxyz + ! solve eqn (2) for grad phi + ! This is probally not constant?? + scale_factor = 1. + gradphi = -vxyz/(scale_factor*hub) + ! Set particle pos + xyzh(1:3,i) = xyzh(1:3,i) - scale_factor*gradphi + ! Apply periodic boundary conditions to particle position + call cross_boundary(isperiodic,xyzh(1:3,i),ncross) + + ! Calculate a new smoothing length?? Since the particle distrubtion has changed + + enddo + + + +end subroutine setpart + +!------------------------------------------------------------------------ +! +! interactive setup +! +!------------------------------------------------------------------------ +subroutine setup_interactive(id,polyk) + use io, only:master + use mpiutils, only:bcast_mpi + use dim, only:maxp,maxvxyzu + use prompting, only:prompt + use units, only:select_unit + integer, intent(in) :: id + real, intent(out) :: polyk + integer :: ierr + + if (id==master) then + 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 + + call prompt('enter xmin boundary',xmini) + call prompt('enter xmax boundary',xmaxi,xmini) + call prompt('enter ymin boundary',ymini) + call prompt('enter ymax boundary',ymaxi,ymini) + call prompt('enter zmin boundary',zmini) + call prompt('enter zmax boundary',zmaxi,zmini) + endif + ! + ! number of particles + ! + if (id==master) then + print*,' uniform setup... (max = ',nint((maxp)**(1/3.)),')' + call prompt('enter number of particles in x direction ',npartx,1) + endif + call bcast_mpi(npartx) + ! + ! mean density + ! + if (id==master) call prompt(' enter density (gives particle mass)',rhozero,0.) + call bcast_mpi(rhozero) + ! + ! sound speed in code units + ! + if (id==master) then + call prompt(' enter sound speed in code units (sets polyk)',cs0,0.) + endif + call bcast_mpi(cs0) + ! + ! dust to gas ratio + ! + if (use_dustfrac) then + call prompt('Enter dust to gas ratio',dust_to_gas,0.) + call bcast_mpi(dust_to_gas) + endif + ! + ! magnetic field strength + if (mhd .and. balsarakim) then + call prompt('Enter magnetic field strength in code units ',Bzero,0.) + call bcast_mpi(Bzero) + endif + ! + ! type of lattice + ! + if (id==master) then + call prompt(' select lattice type (1=cubic, 2=closepacked)',ilattice,1) + endif + call bcast_mpi(ilattice) +end subroutine setup_interactive + +!------------------------------------------------------------------------ +! +! write setup file +! +!------------------------------------------------------------------------ +subroutine write_setupfile(filename) + use infile_utils, only:write_inopt + 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 uniform setup routine' + + 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) + ! + ! boundaries + ! + write(iunit,"(/,a)") '# boundaries' + call write_inopt(xmini,'CoordBase::xmin','xmin boundary',iunit) + call write_inopt(xmaxi,'CoordBase::xmax','xmax boundary',iunit) + call write_inopt(ymini,'CoordBase::ymin','ymin boundary',iunit) + call write_inopt(ymaxi,'CoordBase::ymax','ymax boundary',iunit) + call write_inopt(zmini,'CoordBase::zmin','zmin boundary',iunit) + call write_inopt(zmaxi,'CoordBase::zmax','zmax boundary',iunit) + + + + ! + ! other parameters + ! + write(iunit,"(/,a)") '# setup' + call write_inopt(npartx,'nx','number of particles in x direction',iunit) + call write_inopt(rhozero,'rhozero','initial density in code units',iunit) + call write_inopt(cs0,'cs0','initial sound speed in code units',iunit) + call write_inopt(perturb,'FLRWSolver::FLRW_perturb','Pertrubations of FLRW?',iunit) + call write_inopt(ampl,'FLRWSolver::phi_amplitude','Pertubation amplitude',iunit) + call write_inopt(phaseoffset,'FLRWSolver::phi_phase_offset','Pertubation phase offset',iunit) + call write_inopt(perturb_direction, 'FLRWSolver::FLRW_perturb_direction','Pertubation direction',iunit) + call write_inopt(radiation_dominated, 'radiation_dominated','Radiation dominated universe (yes/no)',iunit) + call write_inopt(perturb_wavelength,'FLRWSolver::single_perturb_wavelength','Perturbation wavelength',iunit) + if (use_dustfrac) then + call write_inopt(dust_to_gas,'dust_to_gas','dust-to-gas ratio',iunit) + endif + if (mhd .and. balsarakim) then + call write_inopt(Bzero,'Bzero','magnetic field strength in code units',iunit) + endif + call write_inopt(ilattice,'ilattice','lattice type (1=cubic, 2=closepacked)',iunit) + close(iunit) + +end subroutine write_setupfile + +!------------------------------------------------------------------------ +! +! read setup file +! +!------------------------------------------------------------------------ +subroutine read_setupfile(filename,ierr) + use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db + use units, only:select_unit + use io, only:error + character(len=*), intent(in) :: filename + integer, intent(out) :: ierr + integer, parameter :: iunit = 21 + integer :: nerr + type(inopts), allocatable :: db(:) + + print "(a)",' reading setup options from '//trim(filename) + nerr = 0 + ierr = 0 + call open_db_from_file(db,filename,iunit,ierr) + ! + ! units + ! + call read_inopt(mass_unit,'mass_unit',db,errcount=nerr) + call read_inopt(dist_unit,'dist_unit',db,errcount=nerr) + ! + ! boundaries + ! + call read_inopt(xmini,'CoordBase::xmin',db,errcount=nerr) + call read_inopt(xmaxi,'CoordBase::xmax',db,min=xmini,errcount=nerr) + call read_inopt(ymini,'CoordBase::ymin',db,errcount=nerr) + call read_inopt(ymaxi,'CoordBase::ymax',db,min=ymini,errcount=nerr) + call read_inopt(zmini,'CoordBase::zmin',db,errcount=nerr) + call read_inopt(zmaxi,'CoordBase::zmax',db,min=zmini,errcount=nerr) + ! + ! other parameters + ! + call read_inopt(npartx,'nx',db,min=8,errcount=nerr) + call read_inopt(rhozero,'rhozero',db,min=0.,errcount=nerr) + call read_inopt(cs0,'cs0',db,min=0.,errcount=nerr) + + call read_inopt(perturb_direction,'FLRWSolver::FLRW_perturb_direction',db,errcount=nerr) + call read_inopt(ampl, 'FLRWSolver::phi_amplitude',db,errcount=nerr) + call read_inopt(phaseoffset,'FLRWSolver::phi_phase_offset',db,errcount=nerr) + call read_inopt(ilattice,'ilattice',db,min=1,max=2,errcount=nerr) + ! TODO Work out why this doesn't read in correctly + call read_inopt(perturb,'FLRWSolver::FLRW_perturb',db,errcount=nerr) + call read_inopt(radiation_dominated,'radiation_dominated',db,errcount=nerr) + call read_inopt(perturb_wavelength,'FLRWSolver::single_perturb_wavelength',db,errcount=nerr) + !print*, db + call close_db(db) + + if (nerr > 0) then + print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' + ierr = nerr +endif + ! + ! parse units + ! + call select_unit(mass_unit,umass,nerr) + if (nerr /= 0) then + call error('setup_unifdis','mass unit not recognised') + ierr = ierr + 1 + endif + call select_unit(dist_unit,udist,nerr) + if (nerr /= 0) then + call error('setup_unifdis','length unit not recognised') + ierr = ierr + 1 + endif + + +end subroutine read_setupfile + +subroutine read_veldata(velarray,vfile,gridsize) + ! TODO ERROR HANDLING?? + integer, intent(in) :: gridsize + character(len=20),intent(in) :: vfile + real,intent(out) :: velarray(:,:,:) + integer :: i,j,k + + open(unit=444,file=vfile,status='old') + do k=1,gridsize + do j=1,gridsize + read(444,*) (velarray(i,j,k), i=1, gridsize) + enddo + enddo + close(444) + print*, "Finished reading ", vfile + +end subroutine read_veldata + +subroutine interpolate_val(position,valgrid,gridsize,gridorigin,dxgrid,val) + ! Subroutine to interpolate quanities to particle positions given a cube + ! Note we have assumed that the grid will always be cubic!!!! + use eos_shen, only:linear_interpolator_one_d + real, intent(in) :: valgrid(:,:,:) + real, intent(inout) :: position(3) + real, intent(inout) :: dxgrid,gridorigin + integer, intent(in) :: gridsize + real, intent(out) :: val + integer :: xupper,yupper,zupper,xlower,ylower,zlower + real :: xlowerpos,ylowerpos,zlowerpos,xupperpos,yupperpos,zupperpos + real :: interptmp(7) + real :: xd,yd,zd + + + + call get_grid_neighbours(position,gridorigin,dxgrid,xlower,ylower,zlower) + + print*,"Neighbours: ", xlower,ylower,zlower + print*,"Position: ", position + ! This is not true as upper neighbours on the boundary will be on the side + ! take a mod of grid size + xupper = mod(xlower + 1, gridsize) + yupper = mod(ylower + 1, gridsize) + zupper = mod(zlower + 1, gridsize) + ! xupper - xlower should always just be dx provided we are using a uniform grid + ! xd = (position(1) - xlower)/(xupper - xlower) + ! yd = (position(2) - ylower)/(yupper - ylower) + ! zd = (position(3) - zlower)/(zupper - zlower) + xlowerpos = gridorigin + (xlower-1)*dxgrid + ylowerpos = gridorigin + (ylower-1)*dxgrid + zlowerpos = gridorigin + (zlower-1)*dxgrid + + xd = (position(1) - xlowerpos)/(dxgrid) + yd = (position(2) - ylowerpos)/(dxgrid) + zd = (position(3) - zlowerpos)/(dxgrid) + + interptmp = 0. + + call linear_interpolator_one_d(valgrid(xlower,ylower,zlower), & + valgrid(xlower+1,ylower,zlower),xd,interptmp(1)) + call linear_interpolator_one_d(valgrid(xlower,ylower,zlower+1), & + valgrid(xlower+1,ylower,zlower+1),xd,interptmp(2)) + call linear_interpolator_one_d(valgrid(xlower,ylower+1,zlower), & + valgrid(xlower+1,ylower+1,zlower),xd,interptmp(3)) + call linear_interpolator_one_d(valgrid(xlower,ylower+1,zlower+1), & + valgrid(xlower+1,ylower+1,zlower+1),xd,interptmp(4)) + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + val = interptmp(7) + +end subroutine interpolate_val + +subroutine get_grid_neighbours(position,gridorigin,dx,xlower,ylower,zlower) + ! TODO IDEALLY THIS SHOULDN'T BE HERE AND SHOULD BE IN A UTILS MODULE + ! WITH THE VERSION USED IN METRIC_ET + real, intent(in) :: position(3), gridorigin + real, intent(in) :: dx + integer, intent(out) :: xlower,ylower,zlower + + ! Get the lower grid neighbours of the position + ! If this is broken change from floor to int + ! How are we handling the edge case of a particle being + ! in exactly the same position as the grid? + ! Hopefully having different grid sizes in each direction + ! Doesn't break the lininterp + xlower = floor((position(1)-gridorigin)/dx) + print*, "pos x: ", position(1) + print*, "gridorigin: ", gridorigin + print*, "dx: ", dx + ylower = floor((position(2)-gridorigin)/dx) + zlower = floor((position(3)-gridorigin)/dx) + + ! +1 because fortran + xlower = xlower + 1 + ylower = ylower + 1 + zlower = zlower + 1 + + +end subroutine get_grid_neighbours + +end module setup From 0855dd6df43402213c1bad9688873eb7df0ecb3c Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Wed, 26 Apr 2023 06:30:52 +0100 Subject: [PATCH 036/814] (mailmap) update Mats --- .mailmap | 3 +++ AUTHORS | 26 ++++++++++++-------------- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/.mailmap b/.mailmap index 567c60b95..d1004cd8d 100644 --- a/.mailmap +++ b/.mailmap @@ -72,6 +72,9 @@ Enrico Ragusa Enrico Ragusa Kieran Hirsh Giulia Ballabio Giulia Ballabio +Mats Esseldeurs +Mats Esseldeurs +Mats Esseldeurs Lionel Siess Lionel Siess Lionel Siess diff --git a/AUTHORS b/AUTHORS index 9677cf6c1..0f4843b2e 100644 --- a/AUTHORS +++ b/AUTHORS @@ -16,6 +16,7 @@ Arnaud Vericel Mark Hutchison Fitz Hu Megha Sharma +Mats Esseldeurs Rebecca Nealon Ward Homan Christophe Pinte @@ -23,8 +24,6 @@ Elisabeth Borchert Fangyi (Fitz) Hu Megha Sharma Terrence Tricco -Mats Esseldeurs -MatsEsseldeurs Simone Ceppi Caitlyn Hardiman Enrico Ragusa @@ -34,41 +33,40 @@ Cristiano Longarini Roberto Iaconi fhu Hauke Worpel -Simone Ceppi Alison Young +Simone Ceppi Stephane Michoulier Amena Faruqi Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi Sahl Rowther -Thomas Reichardt Simon Glover +Thomas Reichardt Jean-François Gonzalez Christopher Russell Alessia Franchini +Alex Pettitt Jolien Malfait Phantom benchmark bot -Alex Pettitt -Nicole Rodrigues Kieran Hirsh +Nicole Rodrigues Amena Faruqi David Trevascus -Megha Sharma Chris Nixon +Megha Sharma Nicolas Cuello -Orsola De Marco -Megha Sharma -Maxime Lombart -Joe Fisher -Giulia Ballabio Benoit Commercon +Giulia Ballabio +Joe Fisher +Maxime Lombart +Megha Sharma +Orsola De Marco Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> -mats esseldeurs +Alison Young Cox, Samuel Jorge Cuadra -Alison Young Steven Rieder Stéven Toupin Terrence Tricco From 615c9ddb6fc46647027517f82eedbd6ab0550ea5 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Wed, 26 Apr 2023 06:33:08 +0100 Subject: [PATCH 037/814] (analysis_raytracer) add option tauL --- src/utils/analysis_raytracer.f90 | 30 +++++++++++++++++++----------- src/utils/utils_raytracer_all.F90 | 2 +- 2 files changed, 20 insertions(+), 12 deletions(-) diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index 6ef3f236b..bd9f317d2 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.f90 @@ -6,9 +6,9 @@ !--------------------------------------------------------------------------! module analysis ! -! Analysis routine which computes neighbour lists for all particles +! Analysis routine which computes optical depths throughout the simulation ! -! :References: None +! :References: Esseldeurs M., Siess L. et al, 2023, A&A, in press ! ! :Owner: Lionel Siess ! @@ -17,15 +17,16 @@ module analysis ! :Dependencies: dump_utils, dust_formation, getneighbours, linklist, ! omp_lib, part, physcon, raytracer, raytracer_all ! - use raytracer_all, only:get_all_tau_inwards, get_all_tau_outwards, get_all_tau_adaptive + use raytracer_all, only:get_all_tau_inwards, get_all_tau_outwards, get_all_tau_adaptive use raytracer, only:get_all_tau use part, only:rhoh,isdead_or_accreted,nsinkproperties,iReff use dump_utils, only:read_array_from_file use getneighbours, only:generate_neighbour_lists, read_neighbours, write_neighbours, & - neighcount,neighb,neighmax + neighcount,neighb,neighmax use dust_formation, only:calc_kappa_bowen use physcon, only:kboltz,mass_proton_cgs,au,solarm - use linklist, only:set_linklist,allocate_linklist,deallocate_linklist + use linklist, only:set_linklist,allocate_linklist,deallocate_linklist + use part, only:itauL_alloc implicit none @@ -50,7 +51,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) character(100) :: neighbourfile character(100) :: jstring, kstring real :: primsec(4,2), rho(npart), kappa(npart), temp(npart), u(npart), & - xyzh2(4,npart), vxyzu2(4,npart), xyzmh_ptmass(nsinkproperties,2) + xyzh2(4,npart), vxyzu2(4,npart), xyzmh_ptmass(nsinkproperties,2) real, dimension(:), allocatable :: tau integer :: i,j,k,ierr,iu1,iu2,iu3,iu4, npart2!,iu integer :: start, finish, method, analyses, minOrder, maxOrder, order, raypolation, refineScheme @@ -219,6 +220,11 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) print *,'(0) all the above' read *,refineScheme endif + elseif (analyses == 3) then + print *,'Which property would you like to integrate?' + print *, '(1) optical depth tau' + print *, '(2) Lucy optical depth tauL' + read *, method endif if (analyses == 2 .and. method==1) then ! get neighbours @@ -394,7 +400,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) close(iu4) totalTime = totalTime + timeTau open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & - status='replace', action='write') + status='replace', action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -429,7 +435,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) times(k+1) = timeTau totalTime = totalTime + timeTau open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & - status='replace', action='write') + status='replace', action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -462,7 +468,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) else call system_clock(start) call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme,& - tau, primsec(1:3,2), Rcomp) + tau, primsec(1:3,2), Rcomp) call system_clock(finish) endif timeTau = (finish-start)/1000. @@ -470,7 +476,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) times(k-minOrder+1) = timeTau totalTime = totalTime + timeTau open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & - '_'//trim(kstring)//'.txt', status='replace', action='write') + '_'//trim(kstring)//'.txt', status='replace', action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -618,7 +624,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) print*,'Time = ',timeTau,' seconds.' totalTime = totalTime + timeTau open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & - '_'//trim(kstring)//'.txt', status='replace', action='write') + '_'//trim(kstring)//'.txt', status='replace', action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -627,6 +633,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) elseif (analyses == 3) then order = 5 + if (method == 2) itauL_alloc = 1 print*,'Start calculating optical depth' if (primsec(1,2) == 0. .and. primsec(2,2) == 0. .and. primsec(3,2) == 0.) then call system_clock(start) @@ -690,3 +697,4 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) end subroutine do_analysis end module analysis +raytracer_all \ No newline at end of file diff --git a/src/utils/utils_raytracer_all.F90 b/src/utils/utils_raytracer_all.F90 index 26855bb9c..2d504554f 100644 --- a/src/utils/utils_raytracer_all.F90 +++ b/src/utils/utils_raytracer_all.F90 @@ -8,7 +8,7 @@ module raytracer_all ! ! raytracer_all ! -! :References: None +! :References: Esseldeurs M., Siess L. et al, 2023, A&A, in press ! ! :Owner: Lionel Siess ! From c5bf979e92df1ff3ea269799038319cc486a05aa Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Wed, 26 Apr 2023 15:44:53 +1000 Subject: [PATCH 038/814] Fixed stress energy calc for radiation dominated --- src/main/extern_gr.F90 | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index de01bf248..4697aa80a 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -380,7 +380,7 @@ subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) ! Stress energy tensor in contravariant form do nu=0,3 do mu=0,3 - tmunu(mu,nu) = dens*u_lower(mu)*u_lower(nu) + p*gcov(mu,nu) + tmunu(mu,nu) = w*dens*u_lower(mu)*u_lower(nu) + p*gcov(mu,nu) enddo enddo @@ -403,6 +403,13 @@ subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) print*, "p: ", p print*, "gcov: ", gcov endif + + ! print*, "tmunu part: ", tmunu + ! print*, "dens: ", dens + ! print*, "w: ", w + ! print*, "p: ", p + ! print*, "gcov: ", gcov + ! stop end subroutine get_tmunu subroutine get_tmunu_exact(x,metrici,metricderivsi,v,dens,u,p,tmunu) From a50b7794985d8332e89f9001e1fb96a7ae1bc2df Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 2 May 2023 12:03:16 +1000 Subject: [PATCH 039/814] Removed extra tmunu calculation --- src/utils/einsteintk_wrapper.f90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 902c568a4..63c4c97d8 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -178,10 +178,8 @@ subroutine step_et2phantom_MoL(infile,dt_et,dtout) ! Perform the calculation of the stress energy tensor ! Interpolate the stress energy tensor back to the ET grid! ! Calculate the stress energy tensor - call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) ! Interpolate stress energy tensor from particles back ! to grid - call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) call get_phantom_dt(dtout) From 6da3cd71552f1af39ee6c8c518bc3a92a6bad318 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 2 May 2023 12:11:57 +1000 Subject: [PATCH 040/814] [tab-bot] tabs removed --- src/utils/analysis_BRhoOrientation.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/analysis_BRhoOrientation.F90 b/src/utils/analysis_BRhoOrientation.F90 index 714f3558f..bec3a9819 100644 --- a/src/utils/analysis_BRhoOrientation.F90 +++ b/src/utils/analysis_BRhoOrientation.F90 @@ -164,7 +164,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! not require the full neighbour finding algorithm bparts: do p = 1,2 jj = ii - + keep_searching = .true. do while (keep_searching) if (p==1) then From 797203ba11d2cbad412fbb207a20205de6d2578a Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 2 May 2023 12:12:24 +1000 Subject: [PATCH 041/814] [format-bot] F77-style SHOUTING removed --- src/setup/setup_flrw.f90 | 2 +- src/setup/setup_flrwpspec.f90 | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index c89575200..6796da2b0 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -112,7 +112,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, gamma = 4./3. endif ! Redefinition of pi to fix numerical error - pi = 4.D0*DATAN(1.0D0) + pi = 4.D0*Datan(1.0D0) ! ! default units ! diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index 1413cf990..cbee73cf5 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -115,7 +115,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, gamma = 4./3. endif ! Redefinition of pi to fix numerical error - pi = 4.D0*DATAN(1.0D0) + pi = 4.D0*Datan(1.0D0) ! ! default units ! @@ -239,11 +239,11 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, totmass = rhozero*dxbound*dybound*dzbound - massoftype = totmass/npart_total + massoftype(1) = totmass/npart_total if (id==master) print*,' particle mass = ',massoftype(1) if (id==master) print*,' initial sound speed = ',cs0,' pressure = ',cs0**2/gamma - + if (maxvxyzu < 4 .or. gamma <= 1.) then polyk = cs0**2 From 0f571ec6d79877bfc233d20fbf3ca9616ec08f2b Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 2 May 2023 12:12:58 +1000 Subject: [PATCH 042/814] [header-bot] updated file headers --- src/main/boundary.f90 | 6 ++--- src/main/boundary_dynamic.f90 | 2 +- src/main/checkconserved.f90 | 2 +- src/main/checksetup.F90 | 6 ++--- src/main/energies.F90 | 4 ++-- src/main/evolve.F90 | 2 +- src/main/evwrite.F90 | 2 +- src/main/extern_gr.F90 | 2 +- src/main/initial.F90 | 19 ++++++++------- src/main/interp_metric.F90 | 17 +++++++++++++ src/main/metric_et.f90 | 6 ++--- src/main/metric_flrw.f90 | 6 ++--- src/main/readwrite_dumps_fortran.F90 | 6 ++--- src/main/readwrite_infile.F90 | 2 +- src/main/step_leapfrog.F90 | 2 +- src/main/tmunu2grid.f90 | 17 +++++++++++++ src/main/utils_gr.F90 | 2 +- src/main/writeheader.F90 | 4 ++-- src/setup/density_profiles.f90 | 2 +- src/setup/relax_star.f90 | 2 +- src/setup/set_star.f90 | 20 ++++++++++++---- src/setup/set_star_kepler.f90 | 2 +- src/setup/set_star_utils.f90 | 4 ++-- src/setup/setup_collidingclouds.f90 | 6 ++--- src/setup/setup_flrw.f90 | 33 +++++++++++--------------- src/setup/setup_flrwpspec.f90 | 33 +++++++++++--------------- src/setup/setup_grtde.f90 | 3 ++- src/setup/setup_star.f90 | 24 ++++--------------- src/tests/test_damping.f90 | 2 +- src/tests/test_externf.f90 | 4 ++-- src/tests/testsuite.F90 | 10 ++++---- src/utils/analysis_BRhoOrientation.F90 | 3 ++- src/utils/analysis_sphere.f90 | 2 +- src/utils/einsteintk_utils.f90 | 17 +++++++++++++ src/utils/einsteintk_wrapper.f90 | 19 ++++++++++++--- src/utils/interpolate3D.F90 | 28 ++++++++++------------ src/utils/interpolate3Dold.F90 | 6 ++--- src/utils/moddump_binary.f90 | 4 ++-- 38 files changed, 191 insertions(+), 140 deletions(-) diff --git a/src/main/boundary.f90 b/src/main/boundary.f90 index 40291ad9d..5f8e31d70 100644 --- a/src/main/boundary.f90 +++ b/src/main/boundary.f90 @@ -11,11 +11,11 @@ module boundary ! ! :References: ! -! :Owner: James Wurster +! :Owner: Daniel Price ! -! :Runtime parameters: +! :Runtime parameters: None ! -! :Dependencies: dim, infile_utils, io, kernel, mpidomain, part +! :Dependencies: dim ! use dim, only: maxvxyzu diff --git a/src/main/boundary_dynamic.f90 b/src/main/boundary_dynamic.f90 index 9e1f4c61d..7bf1b7a27 100644 --- a/src/main/boundary_dynamic.f90 +++ b/src/main/boundary_dynamic.f90 @@ -27,7 +27,7 @@ module boundary_dyn ! - width_bkg_py : *width of the boundary in the +y direction* ! - width_bkg_pz : *width of the boundary in the +z direction* ! -! :Dependencies: dim, infile_utils, io, kernel, mpidomain, part +! :Dependencies: boundary, dim, infile_utils, io, kernel, mpidomain, part ! use dim, only: maxvxyzu diff --git a/src/main/checkconserved.f90 b/src/main/checkconserved.f90 index 1e0c9351e..5591532bb 100644 --- a/src/main/checkconserved.f90 +++ b/src/main/checkconserved.f90 @@ -15,7 +15,7 @@ module checkconserved ! ! :Runtime parameters: None ! -! :Dependencies: boundary, dim, externalforces, io, options, part +! :Dependencies: boundary_dyn, dim, externalforces, io, options, part ! use dim, only:maxdusttypes implicit none diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index 9c3773a0f..1e745dda5 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.F90 @@ -14,9 +14,9 @@ module checksetup ! ! :Runtime parameters: None ! -! :Dependencies: boundary, centreofmass, dim, dust, eos, externalforces, -! io, metric_tools, nicil, options, part, physcon, sortutils, timestep, -! units, utils_gr +! :Dependencies: boundary, boundary_dyn, centreofmass, dim, dust, eos, +! externalforces, io, metric_tools, nicil, options, part, physcon, +! sortutils, timestep, units, utils_gr ! implicit none public :: check_setup diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 6103ccc98..19583f8bd 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -12,11 +12,11 @@ module energies ! ! :References: None ! -! :Owner: James Wurster +! :Owner: Daniel Price ! ! :Runtime parameters: None ! -! :Dependencies: boundary, centreofmass, dim, dust, eos, eos_piecewise, +! :Dependencies: boundary_dyn, centreofmass, dim, dust, eos, eos_piecewise, ! externalforces, fastmath, gravwaveutils, io, kernel, metric_tools, ! mpiutils, nicil, options, part, ptmass, timestep, units, utils_gr, ! vectorutils, viscosity diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index d4400865c..5ab58bf4b 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -16,7 +16,7 @@ module evolve ! ! :Runtime parameters: None ! -! :Dependencies: analysis, boundary, centreofmass, checkconserved, dim, +! :Dependencies: analysis, 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, readwrite_infile, diff --git a/src/main/evwrite.F90 b/src/main/evwrite.F90 index 6ea1a92ff..e5420c4e8 100644 --- a/src/main/evwrite.F90 +++ b/src/main/evwrite.F90 @@ -37,7 +37,7 @@ module evwrite ! ! :Runtime parameters: None ! -! :Dependencies: boundary, dim, energies, eos, extern_binary, +! :Dependencies: boundary, boundary_dyn, dim, energies, eos, extern_binary, ! externalforces, fileutils, gravwaveutils, io, mpiutils, nicil, options, ! part, ptmass, timestep, units, viscosity ! diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 4697aa80a..d68e55499 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -10,7 +10,7 @@ module extern_gr ! ! :References: None ! -! :Owner: David Liptai +! :Owner: Spencer Magnall ! ! :Runtime parameters: None ! diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 50a3d0d44..9eed78943 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -14,15 +14,16 @@ module initial ! ! :Runtime parameters: None ! -! :Dependencies: analysis, boundary, centreofmass, checkconserved, -! checkoptions, checksetup, cons2prim, cooling, cpuinfo, damping, -! densityforce, deriv, dim, dust, dust_formation, energies, eos, evwrite, -! extern_gr, externalforces, fastmath, fileutils, forcing, growth, -! inject, io, io_summary, krome_interface, linklist, metric_tools, -! mf_write, mpibalance, mpidomain, mpimemory, mpitree, mpiutils, nicil, -! nicil_sup, omputils, options, part, partinject, photoevap, ptmass, -! radiation_utils, readwrite_dumps, readwrite_infile, timestep, -! timestep_ind, timestep_sts, timing, units, writeheader +! :Dependencies: 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_tools, mf_write, mpibalance, +! mpidomain, mpimemory, mpitree, mpiutils, nicil, nicil_sup, omputils, +! options, part, partinject, photoevap, ptmass, radiation_utils, +! readwrite_dumps, readwrite_infile, timestep, timestep_ind, +! timestep_sts, timing, tmunu2grid, units, writeheader ! implicit none diff --git a/src/main/interp_metric.F90 b/src/main/interp_metric.F90 index d55547616..caa24d022 100644 --- a/src/main/interp_metric.F90 +++ b/src/main/interp_metric.F90 @@ -1,4 +1,21 @@ +!--------------------------------------------------------------------------! +! 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 metric_interp +! +! metric_interp +! +! :References: None +! +! :Owner: Spencer Magnall +! +! :Runtime parameters: None +! +! :Dependencies: einsteintk_utils +! interface trilinear_interp module procedure interp_g, interp_sqrtg, interp_gderiv diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index d3d8ceda4..513c2c8fa 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -1,6 +1,6 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.bitbucket.io/ ! !--------------------------------------------------------------------------! @@ -10,11 +10,11 @@ module metric ! ! :References: None ! -! :Owner: David Liptai +! :Owner: Spencer Magnall ! ! :Runtime parameters: None ! -! :Dependencies: infile_utils +! :Dependencies: einsteintk_utils, eos_shen, infile_utils ! implicit none character(len=*), parameter :: metric_type = 'et' diff --git a/src/main/metric_flrw.f90 b/src/main/metric_flrw.f90 index bd3f4a6f1..cfc2a1d6d 100644 --- a/src/main/metric_flrw.f90 +++ b/src/main/metric_flrw.f90 @@ -1,6 +1,6 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.bitbucket.io/ ! !--------------------------------------------------------------------------! @@ -10,11 +10,11 @@ module metric ! ! :References: None ! -! :Owner: David Liptai +! :Owner: Spencer Magnall ! ! :Runtime parameters: None ! -! :Dependencies: infile_utils +! :Dependencies: infile_utils, timestep ! diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index ea5d6c441..01fa5c60b 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -18,9 +18,9 @@ module readwrite_dumps_fortran ! ! :Runtime parameters: None ! -! :Dependencies: boundary, checkconserved, dim, dump_utils, dust, -! dust_formation, eos, externalforces, fileutils, io, krome_user, -! lumin_nsdisc, memory, mpi, mpiutils, options, part, +! :Dependencies: boundary, boundary_dyn, checkconserved, dim, dump_utils, +! dust, dust_formation, eos, externalforces, fileutils, io, krome_user, +! lumin_nsdisc, memory, metric_tools, mpi, mpiutils, options, part, ! readwrite_dumps_common, setup_params, sphNGutils, timestep, units ! use dump_utils, only:lenid,ndatatypes,i_int,i_int1,i_int2,i_int4,i_int8,& diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 7c1af52be..4d57cf21c 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -64,7 +64,7 @@ module readwrite_infile ! - use_mcfost : *use the mcfost library* ! - xtol : *tolerance on xyz iterations* ! -! :Dependencies: boundary, cooling, damping, dim, dust, dust_formation, +! :Dependencies: boundary_dyn, cooling, damping, dim, dust, dust_formation, ! eos, externalforces, forcing, gravwaveutils, growth, infile_utils, ! inject, io, linklist, metric, nicil_sup, options, part, photoevap, ! ptmass, ptmass_radiation, radiation_implicit, radiation_utils, diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index a98d97d9f..ed6fce597 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -22,7 +22,7 @@ module step_lf_global ! ! :Runtime parameters: None ! -! :Dependencies: boundary, chem, cons2prim, cons2primsolver, cooling, +! :Dependencies: boundary_dyn, chem, cons2prim, cons2primsolver, cooling, ! cooling_ism, damping, deriv, dim, dust_formation, eos, extern_gr, ! externalforces, growth, io, io_summary, krome_interface, metric_tools, ! mpiutils, options, part, ptmass, ptmass_radiation, timestep, diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index dd4197484..1c7bbb725 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -1,4 +1,21 @@ +!--------------------------------------------------------------------------! +! 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 tmunu2grid +! +! tmunu2grid +! +! :References: None +! +! :Owner: Spencer Magnall +! +! :Runtime parameters: None +! +! :Dependencies: boundary, einsteintk_utils, interpolations3D, part +! implicit none contains diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index d256a331d..c772ea2da 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.F90 @@ -14,7 +14,7 @@ module utils_gr ! ! :Runtime parameters: None ! -! :Dependencies: fastmath, io, metric_tools, part +! :Dependencies: fastmath, io, metric, metric_tools, part ! implicit none diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index 280961888..8c6a5c2e2 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -14,8 +14,8 @@ module writeheader ! ! :Runtime parameters: None ! -! :Dependencies: boundary, cooling, dim, dust, eos, gitinfo, growth, io, -! kernel, metric_tools, mpiutils, options, part, physcon, +! :Dependencies: boundary, boundary_dyn, cooling, dim, dust, eos, gitinfo, +! growth, io, kernel, metric_tools, mpiutils, options, part, physcon, ! readwrite_infile, units, viscosity ! implicit none diff --git a/src/setup/density_profiles.f90 b/src/setup/density_profiles.f90 index 20d60e4e1..792263102 100644 --- a/src/setup/density_profiles.f90 +++ b/src/setup/density_profiles.f90 @@ -20,7 +20,7 @@ module rho_profile ! ! :Runtime parameters: None ! -! :Dependencies: datafiles, eos, fileutils, physcon, prompting, units +! :Dependencies: physcon, prompting, units ! use physcon, only:pi,fourpi implicit none diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index 21724af66..8b610c455 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -20,7 +20,7 @@ module relaxstar ! ! :Dependencies: checksetup, damping, deriv, dim, energies, eos, fileutils, ! infile_utils, initial, io, io_summary, memory, options, part, physcon, -! ptmass, readwrite_dumps, setstar, sortutils, step_lf_global, +! ptmass, readwrite_dumps, setstar_utils, sortutils, step_lf_global, ! table_utils, units ! implicit none diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index e0e1fb916..95fd255eb 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -15,11 +15,23 @@ module setstar ! ! :Owner: Daniel Price ! -! :Runtime parameters: None +! :Runtime parameters: +! - Mstar : *mass of star* +! - Rstar : *radius of star* +! - hsoft : *Softening length of sink particle stellar core* +! - input_profile : *Path to input profile* +! - isinkcore : *Add a sink particle stellar core* +! - isoftcore : *0=no core softening, 1=cubic core, 2=constant entropy core* +! - isofteningopt : *1=supply rcore, 2=supply mcore, 3=supply both* +! - mcore : *Mass of sink particle stellar core* +! - np : *number of particles* +! - outputfilename : *Output path for softened MESA profile* +! - rcore : *Radius of core softening* +! - ui_coef : *specific internal energy (units of GM/R)* ! -! :Dependencies: eos, eos_piecewise, extern_densprofile, io, part, physcon, -! radiation_utils, rho_profile, setsoftenedcore, setup_params, sortutils, -! spherical, table_utils, unifdis, units +! :Dependencies: centreofmass, dim, eos, extern_densprofile, infile_utils, +! io, mpiutils, part, physcon, prompting, radiation_utils, relaxstar, +! setstar_utils, unifdis, units ! use setstar_utils, only:ikepler,imesa,ibpwpoly,ipoly,iuniform,ifromfile,ievrard,& need_polyk diff --git a/src/setup/set_star_kepler.f90 b/src/setup/set_star_kepler.f90 index 109548a91..5ddab669d 100644 --- a/src/setup/set_star_kepler.f90 +++ b/src/setup/set_star_kepler.f90 @@ -11,7 +11,7 @@ module setstar_kepler ! ! :References: None ! -! :Owner: Megha Sharma +! :Owner: Daniel Price ! ! :Runtime parameters: None ! diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 6e3bfc916..16afb478b 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -15,8 +15,8 @@ module setstar_utils ! :Runtime parameters: None ! ! :Dependencies: eos, eos_piecewise, extern_densprofile, io, part, physcon, -! radiation_utils, rho_profile, setsoftenedcore, setup_params, sortutils, -! spherical, table_utils, unifdis, units +! radiation_utils, rho_profile, setsoftenedcore, setstar_kepler, +! setstar_mesa, sortutils, spherical, table_utils, unifdis, units ! use extern_densprofile, only:nrhotab use setstar_kepler, only:write_kepler_comp diff --git a/src/setup/setup_collidingclouds.f90 b/src/setup/setup_collidingclouds.f90 index bf993852e..7e80f1c68 100644 --- a/src/setup/setup_collidingclouds.f90 +++ b/src/setup/setup_collidingclouds.f90 @@ -29,9 +29,9 @@ module setup ! - r_crit : *critical radius (code units)* ! - rho_crit_cgs : *sink formation density (cgs)* ! -! :Dependencies: boundary, cooling, datafiles, dim, eos, infile_utils, io, -! kernel, mpidomain, options, part, physcon, prompting, ptmass, -! setup_params, spherical, timestep, unifdis, units, velfield +! :Dependencies: boundary, boundary_dyn, cooling, datafiles, dim, eos, +! infile_utils, io, kernel, mpidomain, options, part, physcon, prompting, +! ptmass, setup_params, spherical, timestep, unifdis, units, velfield ! use part, only:mhd use dim, only:maxvxyzu,maxp_hard diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 6796da2b0..1e952f485 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -1,6 +1,6 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.bitbucket.io/ ! !--------------------------------------------------------------------------! @@ -10,27 +10,22 @@ module setup ! ! :References: None ! -! :Owner: Daniel Price +! :Owner: Spencer Magnall ! ! :Runtime parameters: -! - Bzero : *magnetic field strength in code units* -! - cs0 : *initial sound speed in code units* -! - dist_unit : *distance unit (e.g. au)* -! - dust_to_gas : *dust-to-gas ratio* -! - ilattice : *lattice type (1=cubic, 2=closepacked)* -! - mass_unit : *mass unit (e.g. solarm)* -! - nx : *number of particles in x direction* -! - rhozero : *initial density in code units* -! - xmax : *xmax boundary* -! - xmin : *xmin boundary* -! - ymax : *ymax boundary* -! - ymin : *ymin boundary* -! - zmax : *zmax boundary* -! - zmin : *zmin boundary* +! - Bzero : *magnetic field strength in code units* +! - cs0 : *initial sound speed in code units* +! - dist_unit : *distance unit (e.g. au)* +! - dust_to_gas : *dust-to-gas ratio* +! - ilattice : *lattice type (1=cubic, 2=closepacked)* +! - mass_unit : *mass unit (e.g. solarm)* +! - nx : *number of particles in x direction* +! - radiation_dominated : *Radiation dominated universe (yes/no)* +! - rhozero : *initial density in code units* ! -! :Dependencies: boundary, cooling, dim, eos, h2cooling, infile_utils, io, -! mpidomain, mpiutils, options, part, physcon, prompting, set_dust, -! setup_params, timestep, unifdis, units +! :Dependencies: boundary, dim, infile_utils, io, mpidomain, mpiutils, +! options, part, physcon, prompting, setup_params, stretchmap, unifdis, +! units, utils_gr ! use dim, only:use_dust,mhd use options, only:use_dustfrac diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index cbee73cf5..97701ebf3 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -1,6 +1,6 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.bitbucket.io/ ! !--------------------------------------------------------------------------! @@ -10,27 +10,22 @@ module setup ! ! :References: None ! -! :Owner: Daniel Price +! :Owner: Spencer Magnall ! ! :Runtime parameters: -! - Bzero : *magnetic field strength in code units* -! - cs0 : *initial sound speed in code units* -! - dist_unit : *distance unit (e.g. au)* -! - dust_to_gas : *dust-to-gas ratio* -! - ilattice : *lattice type (1=cubic, 2=closepacked)* -! - mass_unit : *mass unit (e.g. solarm)* -! - nx : *number of particles in x direction* -! - rhozero : *initial density in code units* -! - xmax : *xmax boundary* -! - xmin : *xmin boundary* -! - ymax : *ymax boundary* -! - ymin : *ymin boundary* -! - zmax : *zmax boundary* -! - zmin : *zmin boundary* +! - Bzero : *magnetic field strength in code units* +! - cs0 : *initial sound speed in code units* +! - dist_unit : *distance unit (e.g. au)* +! - dust_to_gas : *dust-to-gas ratio* +! - ilattice : *lattice type (1=cubic, 2=closepacked)* +! - mass_unit : *mass unit (e.g. solarm)* +! - nx : *number of particles in x direction* +! - radiation_dominated : *Radiation dominated universe (yes/no)* +! - rhozero : *initial density in code units* ! -! :Dependencies: boundary, cooling, dim, eos, h2cooling, infile_utils, io, -! mpidomain, mpiutils, options, part, physcon, prompting, set_dust, -! setup_params, timestep, unifdis, units +! :Dependencies: boundary, dim, eos_shen, infile_utils, io, mpidomain, +! mpiutils, options, part, physcon, prompting, setup_params, stretchmap, +! unifdis, units, utils_gr ! use dim, only:use_dust,mhd use options, only:use_dustfrac diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index 2a65ecd1e..f93446ee7 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -26,7 +26,8 @@ module setup ! ! :Dependencies: eos, extern_densprofile, externalforces, gravwaveutils, ! infile_utils, io, kernel, metric, part, physcon, rho_profile, -! setbinary, spherical, table_utils, timestep, units, vectorutils +! setbinary, setstar_kepler, spherical, table_utils, timestep, units, +! vectorutils ! implicit none public :: setpart diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 6d5cd5609..8f09929c2 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -14,38 +14,24 @@ module setup ! ! :Runtime parameters: ! - EOSopt : *EOS: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)* -! - Mstar : *mass of star* -! - Rstar : *radius of star* ! - X : *hydrogen mass fraction* ! - dist_unit : *distance unit (e.g. au)* ! - gamma : *Adiabatic index* -! - hsoft : *Softening length of sink particle stellar core* ! - ieos : *1=isothermal,2=adiabatic,10=MESA,12=idealplusrad* ! - initialtemp : *initial temperature of the star* -! - input_profile : *Path to input profile* ! - irecomb : *Species to include in recombination (0: H2+H+He, 1:H+He, 2:He* -! - isinkcore : *Add a sink particle stellar core* -! - isoftcore : *0=no core softening, 1=cubic core, 2=constant entropy core* -! - isofteningopt : *1=supply rcore, 2=supply mcore, 3=supply both* ! - mass_unit : *mass unit (e.g. solarm)* -! - mcore : *Mass of sink particle stellar core* ! - metallicity : *metallicity* ! - mu : *mean molecular weight* -! - np : *approx number of particles (in box of size 2R)* -! - outputfilename : *Output path for softened MESA profile* ! - polyk : *polytropic constant (cs^2 if isothermal)* -! - rcore : *Radius of core softening* -! - relax_star : *relax star automatically during setup* -! - ui_coef : *specific internal energy (units of GM/R)* -! - use_exactN : *find closest particle number to np* +! - relax_star : *relax star(s) automatically during setup* ! - use_var_comp : *Use variable composition (X, Z, mu)* -! - write_rho_to_file : *write density profile to file* +! - write_rho_to_file : *write density profile(s) to file* ! -! :Dependencies: centreofmass, dim, eos, eos_gasradrec, eos_piecewise, +! :Dependencies: dim, eos, eos_gasradrec, eos_piecewise, ! extern_densprofile, externalforces, infile_utils, io, kernel, -! mpidomain, mpiutils, options, part, physcon, prompting, -! radiation_utils, relaxstar, setsoftenedcore, setstar, setup_params, -! table_utils, timestep, units +! mpidomain, mpiutils, options, part, physcon, prompting, relaxstar, +! setstar, setup_params, timestep, units ! use io, only:fatal,error,warning,master use part, only:gravity,gr diff --git a/src/tests/test_damping.f90 b/src/tests/test_damping.f90 index 445bfcccc..252ec958b 100644 --- a/src/tests/test_damping.f90 +++ b/src/tests/test_damping.f90 @@ -14,7 +14,7 @@ module testdamping ! ! :Runtime parameters: None ! -! :Dependencies: io +! :Dependencies: damping, io, physcon, testutils ! implicit none public :: test_damping diff --git a/src/tests/test_externf.f90 b/src/tests/test_externf.f90 index b2fef4508..d457c73f3 100644 --- a/src/tests/test_externf.f90 +++ b/src/tests/test_externf.f90 @@ -14,8 +14,8 @@ module testexternf ! ! :Runtime parameters: None ! -! :Dependencies: extern_corotate, externalforces, io, mpidomain, part, -! physcon, testutils, unifdis, units +! :Dependencies: extern_corotate, externalforces, io, kernel, mpidomain, +! part, physcon, testutils, unifdis, units ! implicit none public :: test_externf diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index 78afc3020..0b665fc17 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -16,11 +16,11 @@ module test ! :Runtime parameters: None ! ! :Dependencies: dim, io, io_summary, mpiutils, options, testcooling, -! testcorotate, testderivs, testdust, testeos, testexternf, testgeometry, -! testgnewton, testgr, testgravity, testgrowth, testindtstep, testkdtree, -! testkernel, testlink, testmath, testmpi, testnimhd, testpart, testpoly, -! testptmass, testradiation, testrwdump, testsedov, testsetdisc, -! testsethier, testsmol, teststep, timing +! testcorotate, testdamping, testderivs, testdust, testeos, testexternf, +! testgeometry, testgnewton, testgr, testgravity, testgrowth, +! testindtstep, testkdtree, testkernel, testlink, testmath, testmpi, +! testnimhd, testpart, testpoly, testptmass, testradiation, testrwdump, +! testsedov, testsetdisc, testsethier, testsmol, teststep, timing ! implicit none public :: testsuite diff --git a/src/utils/analysis_BRhoOrientation.F90 b/src/utils/analysis_BRhoOrientation.F90 index bec3a9819..09eed38f3 100644 --- a/src/utils/analysis_BRhoOrientation.F90 +++ b/src/utils/analysis_BRhoOrientation.F90 @@ -16,7 +16,8 @@ module analysis ! ! :Runtime parameters: None ! -! :Dependencies: centreofmass, dim, part, physcon, units +! :Dependencies: boundary, centreofmass, kernel, part, physcon, sortutils, +! units ! implicit none character(len=20), parameter, public :: analysistype = 'Orientation' diff --git a/src/utils/analysis_sphere.f90 b/src/utils/analysis_sphere.f90 index 0107165f8..f7043b6e2 100644 --- a/src/utils/analysis_sphere.f90 +++ b/src/utils/analysis_sphere.f90 @@ -10,7 +10,7 @@ module analysis ! ! :References: None ! -! :Owner: Daniel Price +! :Owner: James Wurster ! ! :Runtime parameters: None ! diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index 45e1b5623..36a86a997 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -1,4 +1,21 @@ +!--------------------------------------------------------------------------! +! 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 einsteintk_utils +! +! einsteintk_utils +! +! :References: None +! +! :Owner: Spencer Magnall +! +! :Runtime parameters: None +! +! :Dependencies: part +! implicit none real, allocatable :: gcovgrid(:,:,:,:,:) real, allocatable :: gcongrid(:,:,:,:,:) diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 63c4c97d8..8d36c7ba7 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -1,9 +1,22 @@ +!--------------------------------------------------------------------------! +! 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 einsteintk_wrapper ! +! einsteintk_wrapper ! -! This module is a "wrapper" for the hydro evol + communication with ET -! Subroutines here should be called by ET rather than calling phantom subroutines -! directly +! :References: None +! +! :Owner: Spencer Magnall +! +! :Runtime parameters: None +! +! :Dependencies: cons2prim, densityforce, deriv, einsteintk_utils, evwrite, +! extern_gr, fileutils, initial, io, linklist, metric, metric_tools, +! mpiutils, part, readwrite_dumps, timestep, tmunu2grid ! implicit none contains diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index f614b4c9f..190e5ef1c 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -1,24 +1,21 @@ -!----------------------------------------------------------------- +!--------------------------------------------------------------------------! +! 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 interpolations3D ! -! This file is (or was) part of SPLASH, a visualisation tool -! for Smoothed Particle Hydrodynamics written by Daniel Price: +! interpolations3D ! -! http://users.monash.edu.au/~dprice/splash +! :References: None ! -! SPLASH comes with ABSOLUTELY NO WARRANTY. -! This is free software; and you are welcome to redistribute -! it under the terms of the GNU General Public License -! (see LICENSE file for details) and the provision that -! this notice remains intact. If you modify this file, please -! note section 2a) of the GPLv2 states that: +! :Owner: Spencer Magnall ! -! a) You must cause the modified files to carry prominent notices -! stating that you changed the files and the date of any change. +! :Runtime parameters: None ! -! Copyright (C) 2005-2019 Daniel Price. All rights reserved. -! Contact: daniel.price@monash.edu +! :Dependencies: einsteintk_utils, kernel ! -!----------------------------------------------------------------- !---------------------------------------------------------------------- ! @@ -27,7 +24,6 @@ ! !---------------------------------------------------------------------- -module interpolations3D use einsteintk_utils, only:exact_rendering use kernel, only:radkern2,radkern,cnormk,wkern!,wallint ! Moved to this module !use interpolation, only:iroll ! Moved to this module diff --git a/src/utils/interpolate3Dold.F90 b/src/utils/interpolate3Dold.F90 index 8c92e8e82..b202f69cb 100644 --- a/src/utils/interpolate3Dold.F90 +++ b/src/utils/interpolate3Dold.F90 @@ -1,6 +1,6 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.bitbucket.io/ ! !--------------------------------------------------------------------------! @@ -13,11 +13,11 @@ module interpolations3D ! ! :References: None ! -! :Owner: Daniel Price +! :Owner: Spencer Magnall ! ! :Runtime parameters: None ! -! :Dependencies: adaptivemesh +! :Dependencies: kernel ! implicit none diff --git a/src/utils/moddump_binary.f90 b/src/utils/moddump_binary.f90 index 188d78e5d..6ade9c926 100644 --- a/src/utils/moddump_binary.f90 +++ b/src/utils/moddump_binary.f90 @@ -16,9 +16,9 @@ module moddump ! ! :Runtime parameters: None ! -! :Dependencies: centreofmass, dim, extern_corotate, externalforces, +! :Dependencies: centreofmass, dim, eos, extern_corotate, externalforces, ! infile_utils, io, options, part, physcon, prompting, readwrite_dumps, -! rho_profile, setbinary, table_utils, timestep, units, vectorutils +! setbinary, setstar_mesa, table_utils, timestep, units, vectorutils ! implicit none From 14032805391670452199b4a5694afcf14fb5d840 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 2 May 2023 12:13:08 +1000 Subject: [PATCH 043/814] [space-bot] whitespace at end of lines removed --- src/main/extern_gr.F90 | 130 ++++++++-------- src/main/initial.F90 | 2 +- src/main/interp_metric.F90 | 12 +- src/main/metric_et.f90 | 144 ++++++++--------- src/main/metric_flrw.f90 | 28 ++-- src/main/tmunu2grid.f90 | 202 ++++++++++++------------ src/main/utils_gr.F90 | 36 ++--- src/main/utils_infiles.f90 | 6 +- src/setup/phantomsetup.F90 | 2 +- src/setup/setup_flrw.f90 | 112 +++++++------- src/setup/setup_flrwpspec.f90 | 118 +++++++------- src/setup/setup_hierarchical.f90 | 8 +- src/setup/stretchmap.f90 | 12 +- src/utils/analysis_BRhoOrientation.F90 | 32 ++-- src/utils/analysis_sphere.f90 | 6 +- src/utils/einsteintk_utils.f90 | 104 ++++++------- src/utils/einsteintk_wrapper.f90 | 204 ++++++++++++------------- src/utils/interpolate3D.F90 | 132 ++++++++-------- src/utils/interpolate3Dold.F90 | 58 +++---- 19 files changed, 674 insertions(+), 674 deletions(-) diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index d68e55499..87f2d8ba4 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -229,9 +229,9 @@ subroutine get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) integer, intent(in) :: npart real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) - real :: pi + real :: pi integer :: i - logical :: verbose + logical :: verbose verbose = .false. ! TODO write openmp parallel code @@ -239,19 +239,19 @@ subroutine get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) !$omp shared(npart,xyzh,metrics,vxyzu,dens,ieos,tmunus) & !$omp private(i,pi,verbose) do i=1, npart - !print*, "i: ", i - if (i==1) then + !print*, "i: ", i + if (i==1) then verbose = .true. - else + else verbose = .false. - endif + endif if (.not.isdead_or_accreted(xyzh(4,i))) then pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) call get_tmunu(xyzh(:,i),metrics(:,:,:,i),& vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i),verbose) - endif + endif enddo - !$omp end parallel do + !$omp end parallel do !print*, "tmunu calc val is: ", tmunus(0,0,5) end subroutine get_tmunu_all @@ -261,12 +261,12 @@ subroutine get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus integer, intent(in) :: npart real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) - real :: pi + real :: pi integer :: i logical :: firstpart real :: tmunu(4,4) !print*, "entered get tmunu_all_exact" - tmunu = 0. + tmunu = 0. firstpart = .true. ! TODO write openmp parallel code do i=1, npart @@ -282,134 +282,134 @@ subroutine get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus !print*, "Got tmunu val: ", tmunu !stop else - !print*, "setting tmunu for part: ", i + !print*, "setting tmunu for part: ", i tmunus(:,:,i) = tmunu(:,:) endif - - enddo + + enddo !print*, "tmunu calc val is: ", tmunus(0,0,5) end subroutine get_tmunu_all_exact -! Subroutine to calculate the covariant form of the stress energy tensor +! Subroutine to calculate the covariant form of the stress energy tensor ! For a particle at position p subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) use metric_tools, only:unpack_metric use utils_gr, only:get_u0 real, intent(in) :: x(3),metrici(:,:,:),v(3),dens,u,p real, intent(out) :: tmunu(0:3,0:3) - logical, optional, intent(in) :: verbose + logical, optional, intent(in) :: verbose real :: w,v4(0:3),vcov(3),lorentz,bigV(3),uzero,u_upper(0:3),u_lower(0:3) real :: gcov(0:3,0:3), gcon(0:3,0:3) real :: gammaijdown(1:3,1:3),betadown(3),alpha real :: velshiftterm integer :: i,j,ierr,mu,nu - + ! Reference for all the variables used in this routine: - ! w - the enthalpy + ! w - the enthalpy ! gcov - the covariant form of the metric tensor - ! gcon - the contravariant form of the metric tensor - ! gammaijdown - the covariant form of the spatial metric - ! alpha - the lapse - ! betadown - the covariant component of the shift - ! v4 - the uppercase 4 velocity in covariant form + ! gcon - the contravariant form of the metric tensor + ! gammaijdown - the covariant form of the spatial metric + ! alpha - the lapse + ! betadown - the covariant component of the shift + ! v4 - the uppercase 4 velocity in covariant form ! v - the fluid velocity v^x ! vcov - the covariant form of big V_i - ! bigV - the uppercase contravariant V^i + ! bigV - the uppercase contravariant V^i ! Calculate the enthalpy w = 1 + u + p/dens - + ! Get cov and con versions of the metric + spatial metric and lapse and shift ! Not entirely convinced that the lapse and shift calculations are acccurate for the general case!! !print*, "Before unpack metric " call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) !print*, "After unpack metric" - if (present(verbose) .and. verbose) then - ! Do we get sensible values + if (present(verbose) .and. verbose) then + ! Do we get sensible values print*, "Unpacked metric quantities..." print*, "gcov: ", gcov print*, "gcon: ", gcon print*, "gammaijdown: ", gammaijdown - print* , "alpha: ", alpha + print* , "alpha: ", alpha print*, "betadown: ", betadown print*, "v4: ", v4 - endif - - ! ! Need to change Betadown to betaup + endif + + ! ! Need to change Betadown to betaup ! ! Won't matter at this point as it is allways zero - ! ! get big V - ! bigV(:) = (v(:) + betadown)/alpha + ! ! get big V + ! bigV(:) = (v(:) + betadown)/alpha - ! ! We need the covariant version of the 3 velocity + ! ! We need the covariant version of the 3 velocity ! ! gamma_ij v^j = v_i where gamma_ij is the spatial metric ! do i=1, 3 - ! vcov(i) = gammaijdown(i,1)*bigv(1) + gammaijdown(i,2)*bigv(2) + gammaijdown(i,3)*bigv(3) + ! vcov(i) = gammaijdown(i,1)*bigv(1) + gammaijdown(i,2)*bigv(2) + gammaijdown(i,3)*bigv(3) ! enddo - + ! ! Calculate the lorentz factor ! lorentz = (1. - (vcov(1)*bigv(1) + vcov(2)*bigv(2) + vcov(3)*bigv(3)))**(-0.5) - + ! ! Calculate the 4-velocity ! velshiftterm = vcov(1)*betadown(1) + vcov(2)*betadown(2) + vcov(3)*betadown(3) ! v4(0) = lorentz*(-alpha + velshiftterm) ! ! This should be vcov not v ! v4(1:3) = lorentz*vcov(1:3) - - ! We are going to use the same Tmunu calc as force GR + + ! We are going to use the same Tmunu calc as force GR ! And then lower it using the metric ! i.e calc T^{\mu\nu} and then lower it using the metric - ! tensor + ! tensor ! lower-case 4-velocity (contravariant) v4(0) = 1. v4(1:3) = v(:) - + ! first component of the upper-case 4-velocity (contravariant) call get_u0(gcov,v,uzero,ierr) - + u_upper = uzero*v4 do mu=0,3 - u_lower(mu) = gcov(mu,0)*u_upper(0) + gcov(mu,1)*u_upper(1) & + u_lower(mu) = gcov(mu,0)*u_upper(0) + gcov(mu,1)*u_upper(1) & + gcov(mu,2)*u_upper(2) + gcov(mu,3)*u_upper(3) - enddo + enddo ! Stress energy tensor in contravariant form do nu=0,3 do mu=0,3 tmunu(mu,nu) = w*dens*u_lower(mu)*u_lower(nu) + p*gcov(mu,nu) - enddo - enddo + enddo + enddo - - if (present(verbose) .and. verbose) then - ! Do we get sensible values + + if (present(verbose) .and. verbose) then + ! Do we get sensible values print*, "Unpacked metric quantities..." print*, "gcov: ", gcov print*, "gcon: ", gcon print*, "gammaijdown: ", gammaijdown - print* , "alpha: ", alpha + print* , "alpha: ", alpha print*, "betadown: ", betadown print*, "v4: ", v4 - endif + endif - if (verbose) then + if (verbose) then print*, "tmunu part: ", tmunu print*, "dens: ", dens - print*, "w: ", w - print*, "p: ", p + print*, "w: ", w + print*, "p: ", p print*, "gcov: ", gcov endif ! print*, "tmunu part: ", tmunu ! print*, "dens: ", dens - ! print*, "w: ", w - ! print*, "p: ", p + ! print*, "w: ", w + ! print*, "p: ", p ! print*, "gcov: ", gcov - ! stop + ! stop end subroutine get_tmunu subroutine get_tmunu_exact(x,metrici,metricderivsi,v,dens,u,p,tmunu) @@ -426,28 +426,28 @@ subroutine get_tmunu_exact(x,metrici,metricderivsi,v,dens,u,p,tmunu) ! Calculate the enthalpy ! enthalpy should be 1 as we have zero pressure - ! or should have zero pressure + ! or should have zero pressure w = 1 ! Calculate the exact value of density from conserved density call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) - ! We need the covariant version of the 3 velocity + ! We need the covariant version of the 3 velocity ! gamma_ij v^j = v_i where gamma_ij is the spatial metric do i=1, 3 - vcov(i) = gammaijdown(i,1)*v(1) + gammaijdown(i,2)*v(2) + gammaijdown(i,3)*v(3) - enddo + vcov(i) = gammaijdown(i,1)*v(1) + gammaijdown(i,2)*v(2) + gammaijdown(i,3)*v(3) + enddo ! Calculate the lorentz factor lorentz = (1. - (vcov(1)*v(1) + vcov(2)*v(2) + vcov(3)*v(3)))**(-0.5) - + ! Calculate the 4-velocity velshiftterm = vcov(1)*betadown(1) + vcov(2)*betadown(2) + vcov(3)*betadown(3) v4(0) = lorentz*(-alpha + velshiftterm) v4(1:3) = lorentz*v(1:3) - rhostar = 13.294563008157013D0 + rhostar = 13.294563008157013D0 call get_sqrtg(gcov,negsqrtg) - ! Set/Calculate primitive density using rhostar exactly + ! Set/Calculate primitive density using rhostar exactly rhoprim = rhostar/(negsqrtg/alpha) @@ -455,8 +455,8 @@ subroutine get_tmunu_exact(x,metrici,metricderivsi,v,dens,u,p,tmunu) do j=0,3 do i=0,3 tmunu(i,j) = rhoprim*w*v4(i)*v4(j) ! + p*gcov(i,j) neglect the pressure term as we don't care - enddo - enddo + enddo + enddo diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 9eed78943..c27f72bbe 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -142,7 +142,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use extern_gr, only:get_grforce_all,get_tmunu_all,get_tmunu_all_exact use metric_tools, only:init_metric,imet_minkowski,imetric use einsteintk_utils - use tmunu2grid + use tmunu2grid #endif #ifdef PHOTO use photoevap, only:set_photoevap_grid diff --git a/src/main/interp_metric.F90 b/src/main/interp_metric.F90 index caa24d022..6889ae8f2 100644 --- a/src/main/interp_metric.F90 +++ b/src/main/interp_metric.F90 @@ -16,12 +16,12 @@ module metric_interp ! ! :Dependencies: einsteintk_utils ! - + interface trilinear_interp module procedure interp_g, interp_sqrtg, interp_gderiv end interface trilinear_interp - contains - + contains + subroutine interp_g() end subroutine interp_g @@ -38,12 +38,12 @@ pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) real, intent(in) :: position(3) real, intent(in) :: dx(3) integer, intent(out) :: xlower,ylower,zlower - - ! Get the lower grid neighbours of the position + + ! Get the lower grid neighbours of the position ! If this is broken change from floor to int ! How are we handling the edge case of a particle being ! in exactly the same position as the grid? - ! Hopefully having different grid sizes in each direction + ! Hopefully having different grid sizes in each direction ! Doesn't break the lininterp xlower = floor((position(1)-gridorigin(1))/dx(1)) ylower = floor((position(2)-gridorigin(2))/dx(2)) diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index 513c2c8fa..74f0abe6e 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -54,13 +54,13 @@ pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) gcon(1,1) = 1. gcon(2,2) = 1. gcon(3,3) = 1. - endif - if (present(sqrtg)) sqrtg = -1. - else if (present(gcon) .and. present(sqrtg)) then - call interpolate_metric(position,gcov,gcon,sqrtg) - else + endif + if (present(sqrtg)) sqrtg = -1. + else if (present(gcon) .and. present(sqrtg)) then + call interpolate_metric(position,gcov,gcon,sqrtg) + else call interpolate_metric(position,gcov) - endif + endif end subroutine get_metric_cartesian pure subroutine get_metric_spherical(position,gcov,gcon,sqrtg) @@ -96,13 +96,13 @@ pure subroutine metric_cartesian_derivatives(position,dgcovdx, dgcovdy, dgcovdz) use einsteintk_utils, only:gridinit real, intent(in) :: position(3) real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3), dgcovdz(0:3,0:3) - if (.not. gridinit) then + if (.not. gridinit) then dgcovdx = 0. dgcovdy = 0. dgcovdz = 0. else call interpolate_metric_derivs(position,dgcovdx,dgcovdy,dgcovdz) - endif + endif end subroutine metric_cartesian_derivatives pure subroutine metric_spherical_derivatives(position,dgcovdr, dgcovdtheta, dgcovdphi) @@ -171,16 +171,16 @@ end subroutine read_options_metric !----------------------------------------------------------------------- !+ -! Interpolates value from grid to position +! Interpolates value from grid to position !+ !----------------------------------------------------------------------- pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) - ! linear and cubic interpolators should be moved to their own subroutine + ! linear and cubic interpolators should be moved to their own subroutine ! away from eos_shen use eos_shen, only:linear_interpolator_one_d use einsteintk_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid,gridsize,gridorigin - real, intent(in) :: position(3) + real, intent(in) :: position(3) real, intent(out) :: gcov(0:3,0:3) real, intent(out), optional :: gcon(0:3,0:3), sqrtg integer :: xlower,ylower,zlower,xupper,yupper,zupper @@ -188,20 +188,20 @@ pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) real :: xd,yd,zd real :: interptmp(7) integer :: i,j - - ! If the issue is that the metric vals are undefined on + + ! If the issue is that the metric vals are undefined on ! Setup since we have not recieved anything about the metric ! from ET during phantomsetup - ! Then simply set gcov and gcon to 0 + ! Then simply set gcov and gcon to 0 ! as these values will be overwritten during the run anyway !print*, "Calling interp metric!" - ! Get neighbours + ! Get neighbours call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) !print*,"Neighbours: ", xlower,ylower,zlower ! This is not true as upper neighbours on the boundary will be on the side - ! take a mod of grid size + ! take a mod of grid size xupper = mod(xlower + 1, gridsize(1)) - yupper = mod(ylower + 1, gridsize(2)) + yupper = mod(ylower + 1, gridsize(2)) zupper = mod(zlower + 1, gridsize(3)) ! xupper - xlower should always just be dx provided we are using a uniform grid ! xd = (position(1) - xlower)/(xupper - xlower) @@ -214,74 +214,74 @@ pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) xd = (position(1) - xlowerpos)/(dxgrid(1)) yd = (position(2) - ylowerpos)/(dxgrid(2)) zd = (position(3) - zlowerpos)/(dxgrid(3)) - + interptmp = 0. ! All the interpolation should go into an interface, then you should just call trilinear_interp ! interpolate for gcov - do i=0, 3 + do i=0, 3 do j=0, 3 - ! Interpolate along x - call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower,zlower), & + ! Interpolate along x + call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower,zlower), & gcovgrid(i,j,xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower,zlower+1), & + call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower,zlower+1), & gcovgrid(i,j,xlower+1,ylower,zlower+1),xd,interptmp(2)) call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower+1,zlower), & gcovgrid(i,j,xlower+1,ylower+1,zlower),xd,interptmp(3)) call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower+1,zlower+1), & gcovgrid(i,j,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y + ! Interpolate along y call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) ! Interpolate along z call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - + gcov(i,j) = interptmp(7) enddo - enddo - - if (present(gcon)) then + enddo + + if (present(gcon)) then ! interpolate for gcon - do i=0, 3 + do i=0, 3 do j=0, 3 - ! Interpolate along x - call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower,zlower), & + ! Interpolate along x + call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower,zlower), & gcongrid(i,j,xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower,zlower+1), & + call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower,zlower+1), & gcongrid(i,j,xlower+1,ylower,zlower+1),xd,interptmp(2)) call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower+1,zlower), & gcongrid(i,j,xlower+1,ylower+1,zlower),xd,interptmp(3)) call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower+1,zlower+1), & gcongrid(i,j,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y + ! Interpolate along y call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) ! Interpolate along z call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - + gcon(i,j) = interptmp(7) enddo - enddo - endif + enddo + endif - if (present(sqrtg)) then - ! Interpolate for sqrtg - ! Interpolate along x - call linear_interpolator_one_d(sqrtggrid(xlower,ylower,zlower), & + if (present(sqrtg)) then + ! Interpolate for sqrtg + ! Interpolate along x + call linear_interpolator_one_d(sqrtggrid(xlower,ylower,zlower), & sqrtggrid(xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(sqrtggrid(xlower,ylower,zlower+1), & + call linear_interpolator_one_d(sqrtggrid(xlower,ylower,zlower+1), & sqrtggrid(xlower+1,ylower,zlower+1),xd,interptmp(2)) call linear_interpolator_one_d(sqrtggrid(xlower,ylower+1,zlower), & sqrtggrid(xlower+1,ylower+1,zlower),xd,interptmp(3)) call linear_interpolator_one_d(sqrtggrid(xlower,ylower+1,zlower+1), & sqrtggrid(xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y + ! Interpolate along y call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) ! Interpolate along z call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - + sqrtg = interptmp(7) - endif + endif end subroutine interpolate_metric @@ -290,8 +290,8 @@ pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) use eos_shen, only:linear_interpolator_one_d use einsteintk_utils, only:metricderivsgrid, dxgrid,gridorigin real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3),dgcovdz(0:3,0:3) - real, intent(in) :: position(3) - integer :: xlower,ylower,zlower,xupper,yupper,zupper + real, intent(in) :: position(3) + integer :: xlower,ylower,zlower,xupper,yupper,zupper real :: xd,yd,zd,xlowerpos, ylowerpos,zlowerpos real :: interptmp(7) integer :: i,j @@ -299,7 +299,7 @@ pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) !print*,"Neighbours: ", xlower,ylower,zlower xupper = xlower + 1 - yupper = yupper + 1 + yupper = yupper + 1 zupper = zupper + 1 ! xd = (position(1) - xlower)/(xupper - xlower) ! yd = (position(2) - ylower)/(yupper - ylower) @@ -313,89 +313,89 @@ pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) yd = (position(2) - ylowerpos)/(dxgrid(2)) zd = (position(3) - zlowerpos)/(dxgrid(3)) - interptmp = 0. + interptmp = 0. ! Interpolate for dx - do i=0, 3 + do i=0, 3 do j=0, 3 - ! Interpolate along x - call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower,zlower), & + ! Interpolate along x + call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower,zlower), & metricderivsgrid(i,j,1,xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower,zlower+1), & + call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower,zlower+1), & metricderivsgrid(i,j,1,xlower+1,ylower,zlower+1),xd,interptmp(2)) call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower+1,zlower), & metricderivsgrid(i,j,1,xlower+1,ylower+1,zlower),xd,interptmp(3)) call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower+1,zlower+1), & metricderivsgrid(i,j,1,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y + ! Interpolate along y call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) ! Interpolate along z call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - + dgcovdx(i,j) = interptmp(7) enddo - enddo + enddo ! Interpolate for dy - do i=0, 3 + do i=0, 3 do j=0, 3 - ! Interpolate along x - call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower,zlower), & + ! Interpolate along x + call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower,zlower), & metricderivsgrid(i,j,2,xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower,zlower+1), & + call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower,zlower+1), & metricderivsgrid(i,j,2,xlower+1,ylower,zlower+1),xd,interptmp(2)) call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower+1,zlower), & metricderivsgrid(i,j,2,xlower+1,ylower+1,zlower),xd,interptmp(3)) call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower+1,zlower+1), & metricderivsgrid(i,j,2,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y + ! Interpolate along y call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) ! Interpolate along z call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - + dgcovdy(i,j) = interptmp(7) enddo enddo - + ! Interpolate for dz - do i=0, 3 + do i=0, 3 do j=0, 3 - ! Interpolate along x - call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower,zlower), & + ! Interpolate along x + call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower,zlower), & metricderivsgrid(i,j,3,xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower,zlower+1), & + call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower,zlower+1), & metricderivsgrid(i,j,3,xlower+1,ylower,zlower+1),xd,interptmp(2)) call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower+1,zlower), & metricderivsgrid(i,j,3,xlower+1,ylower+1,zlower),xd,interptmp(3)) call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower+1,zlower+1), & metricderivsgrid(i,j,3,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y + ! Interpolate along y call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) ! Interpolate along z call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - + dgcovdz(i,j) = interptmp(7) enddo enddo - + end subroutine interpolate_metric_derivs - + pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) use einsteintk_utils, only:gridorigin real, intent(in) :: position(3) real, intent(in) :: dx(3) integer, intent(out) :: xlower,ylower,zlower - - ! Get the lower grid neighbours of the position + + ! Get the lower grid neighbours of the position ! If this is broken change from floor to int ! How are we handling the edge case of a particle being ! in exactly the same position as the grid? - ! Hopefully having different grid sizes in each direction + ! Hopefully having different grid sizes in each direction ! Doesn't break the lininterp xlower = floor((position(1)-gridorigin(1))/dx(1)) ylower = floor((position(2)-gridorigin(2))/dx(2)) diff --git a/src/main/metric_flrw.f90 b/src/main/metric_flrw.f90 index cfc2a1d6d..ec853e565 100644 --- a/src/main/metric_flrw.f90 +++ b/src/main/metric_flrw.f90 @@ -16,13 +16,13 @@ module metric ! ! :Dependencies: infile_utils, timestep ! - - -use timestep, only: time + + +use timestep, only: time implicit none character(len=*), parameter :: metric_type = 'flrw' integer, parameter :: imetric = 5 - + contains !---------------------------------------------------------------- @@ -36,9 +36,9 @@ pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) real, intent(out) :: gcov(0:3,0:3) real, intent(out), optional :: gcon(0:3,0:3) real, intent(out), optional :: sqrtg - real :: a,t - - t = time + real :: a,t + + t = time gcov = 0. ! Get the scale factor for the current time call get_scale_factor(t,a) @@ -47,13 +47,13 @@ pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) gcov(2,2) = a gcov(3,3) = a - if (present(gcon)) then + if (present(gcon)) then gcon = 0. gcon(0,0) = -1. gcon(1,1) = 1./a gcon(2,2) = 1./a gcon(3,3) = 1./a - endif + endif if (present(sqrtg)) sqrtg = a*a*a end subroutine get_metric_cartesian @@ -64,9 +64,9 @@ pure subroutine get_metric_spherical(position,gcov,gcon,sqrtg) real, intent(out), optional :: gcon(0:3,0:3) real, intent(out), optional :: sqrtg real :: r2,sintheta - real :: t,a + real :: t,a - t = time + t = time ! Get the scale factor for the current time call get_scale_factor(t,a) @@ -106,7 +106,7 @@ pure subroutine metric_spherical_derivatives(position,dgcovdr, dgcovdtheta, dgco real :: r, theta real :: t, a - t = time + t = time ! Get the scale factor for the current time call get_scale_factor(t,a) @@ -229,8 +229,8 @@ subroutine read_options_metric(name,valstring,imatch,igotall,ierr) end subroutine read_options_metric pure subroutine get_scale_factor(t,a) - real, intent(in) :: t - real, intent(out) :: a + real, intent(in) :: t + real, intent(out) :: a a = t*(0.5) + 1 diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index 1c7bbb725..e831224df 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -16,14 +16,14 @@ module tmunu2grid ! ! :Dependencies: boundary, einsteintk_utils, interpolations3D, part ! - implicit none + implicit none contains subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid use interpolations3D, only: interpolate3D use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax - use part, only: massoftype,igas,rhoh,dens,hfact + use part, only: massoftype,igas,rhoh,dens,hfact integer, intent(in) :: npart real, intent(in) :: vxyzu(:,:), tmunus(:,:,:) real, intent(inout) :: xyzh(:,:) @@ -38,21 +38,21 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper logical :: normalise, vertexcen,periodicx,periodicy,periodicz,exact_rendering real :: totalmass, totalmassgrid - integer :: itype(npart) + integer :: itype(npart) - - ! total mass of the particles + + ! total mass of the particles totalmass = npart*massoftype(igas) !print*, "totalmass(part): ", totalmass - ! Density interpolated to the grid - rhostargrid = 0. + ! Density interpolated to the grid + rhostargrid = 0. if (.not. allocated(datsmooth)) allocate (datsmooth(gridsize(1),gridsize(2),gridsize(3))) if (.not. allocated(dat)) allocate (dat(npart)) ! All particles have equal weighting in the interp ! Here we calculate the weight for the first particle - ! Get the smoothing length + ! Get the smoothing length h = xyzh(4,1) ! Get pmass pmass = massoftype(igas) @@ -60,10 +60,10 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) rho = rhoh(h,pmass) call get_weight(pmass,h,rho,weight) ! Correct for Kernel Bias, find correction factor - ! Wrap this into it's own subroutine - if (present(calc_cfac)) then + ! Wrap this into it's own subroutine + if (present(calc_cfac)) then if (calc_cfac) call get_cfac(cfac,rho) - endif + endif weights = weight itype = 1 @@ -77,43 +77,43 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) xmininterp(1) = xmin -dxgrid(1) !- 0.5*dxgrid(1) xmininterp(2) = ymin -dxgrid(2) !- 0.5*dxgrid(2) xmininterp(3) = zmin-dxgrid(3) !- 0.5*dxgrid(3) - + call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) - ! nnodes is just the size of the mesh + ! nnodes is just the size of the mesh ! might not be needed ! We note that this is not actually the size of the einstein toolkit grid - ! As we want our periodic boundary to be on the particle domain not the - ! ET grid domain + ! As we want our periodic boundary to be on the particle domain not the + ! ET grid domain ngrid(1) = (iupper-ilower) + 1 ngrid(2) = (jupper-jlower) + 1 ngrid(3) = (kupper-klower) + 1 nnodes = (iupper-ilower)*(jupper-jlower)*(kupper-klower) - ! Do we want to normalise interpolations? + ! Do we want to normalise interpolations? normalise = .true. ! Is our NR GRID vertex centered? vertexcen = .false. periodicx = .true. periodicy = .true. - periodicz = .true. + periodicz = .true. + + - - ! tt component tmunugrid = 0. datsmooth = 0. ! TODO Unroll this loop for speed + using symmetries - ! Possiblly cleanup the messy indexing + ! Possiblly cleanup the messy indexing do k=1,4 do j=1,4 do i=1, npart dat(i) = tmunus(k,j,i) - enddo + enddo - ! Get the position of the first grid cell x,y,z - ! Call to interpolate 3D + ! Get the position of the first grid cell x,y,z + ! Call to interpolate 3D ! COMMENTED OUT AS NOT USED BY NEW INTERPOLATE ROUTINE ! call interpolate3D(xyzh,weight,npart, & ! xmininterp,tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper), & @@ -126,75 +126,75 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) xmininterp(1),xmininterp(2),xmininterp(3), & tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper),& ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& - normalise,periodicx,periodicy,periodicz) - enddo + normalise,periodicx,periodicy,periodicz) + enddo enddo - - ! RHOSTARGRID CALCULATION IS NOW HANDLED BY AN EXTERNAL ROUTINE - ! THIS IS COMMENTED OUT IN CASE I BREAK EVERYTHING AND NEED TO GO BACK - ! Get the conserved density on the particles - ! dat = 0. + + ! RHOSTARGRID CALCULATION IS NOW HANDLED BY AN EXTERNAL ROUTINE + ! THIS IS COMMENTED OUT IN CASE I BREAK EVERYTHING AND NEED TO GO BACK + ! Get the conserved density on the particles + ! dat = 0. ! do i=1, npart - ! ! Get the smoothing length + ! ! Get the smoothing length ! h = xyzh(4,i) ! ! Get pmass ! pmass = massoftype(igas) ! rho = rhoh(h,pmass) ! dat(i) = rho - ! enddo - - ! Commented out as not used by new interpolate routine + ! enddo + + ! Commented out as not used by new interpolate routine ! call interpolate3D(xyzh,weight,npart, & ! xmininterp,rhostargrid(ilower:iupper,jlower:jupper,klower:kupper), & ! nnodes,dxgrid,.true.,dat,ngrid,vertexcen) - - + + ! Calculate the total mass on the grid !totalmassgrid = 0. ! do i=ilower,iupper ! do j=jlower,jupper ! do k=klower, kupper ! totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) - - ! enddo - ! enddo - ! enddo - ! Explicitly set pressure to be 0 + + ! enddo + ! enddo + ! enddo + ! Explicitly set pressure to be 0 ! Need to do this in the phantom setup file later ! tmunugrid(1,0:3,:,:,:) = 0. ! tmunugrid(2,0:3,:,:,:) = 0. ! tmunugrid(3,0:3,:,:,:) = 0. !tmunugrid(0,0,:,:,:) = tmunus(1,1,1) - ! Correction for kernel bias code + ! Correction for kernel bias code ! Hardcoded values for the cubic spline computed using ! a constant density flrw universe. - ! Ideally this should be in a more general form + ! Ideally this should be in a more general form ! cfac = totalmass/totalmassgrid ! ! Output total mass on grid, total mass on particles - ! ! and the residuals + ! ! and the residuals ! !cfac = 0.99917535781746514D0 ! tmunugrid = tmunugrid*cfac - ! if (iteration==0) then - ! write(666,*) "iteration ", "Mass(Grid) ", "Mass(Particles) ", "Mass(Grid-Particles)" - ! endif + ! if (iteration==0) then + ! write(666,*) "iteration ", "Mass(Grid) ", "Mass(Particles) ", "Mass(Grid-Particles)" + ! endif ! write(666,*) iteration, totalmassgrid, totalmass, abs(totalmassgrid-totalmass) ! close(unit=666) - ! iteration = iteration + 1 + ! iteration = iteration + 1 ! New rho/smoothing length calc based on correction?? - ! not sure that this is a valid thing to do + ! not sure that this is a valid thing to do ! do i=1, npart ! rho = rhoh(xyzh(i,4),pmass) ! rho = rho*cfac - ! xyzh(i,4) = hfact*(pmass/rho)**(1./3.) + ! xyzh(i,4) = hfact*(pmass/rho)**(1./3.) + + ! enddo - ! enddo - - ! Correct rhostargrid using cfac + ! Correct rhostargrid using cfac !rhostargrid = cfac*rhostargrid ! Calculate rho(prim), P and e on the grid - ! Apply kernel correction to primatives?? + ! Apply kernel correction to primatives?? ! Then calculate a stress energy tensor per grid and fill tmunu ! A good consistency check would be to do it both ways and compare values @@ -205,8 +205,8 @@ end subroutine get_tmunugrid_all subroutine get_weight(pmass,h,rhoi,weight) real, intent(in) :: pmass,h,rhoi - real, intent(out) :: weight - + real, intent(out) :: weight + weight = (pmass)/(rhoi*h**3) end subroutine get_weight @@ -219,39 +219,39 @@ end subroutine get_dat ! subroutine get_primdens(dens,dat) ! real, intent(in) :: dens - ! real, intent(out) :: dat - ! integer :: i, npart + ! real, intent(out) :: dat + ! integer :: i, npart - ! ! Get the primative density on the particles - ! dat = 0. + ! ! Get the primative density on the particles + ! dat = 0. ! do i=1, npart ! dat(i) = dens(i) ! enddo - + ! end subroutine get_primdens - + ! subroutine get_4velocity(vxyzu,dat) ! real, intent(in) :: vxyzu(:,:) ! real, intent(out) :: dat(:,:) - ! integer :: i,npart + ! integer :: i,npart - ! ! Get the primative density on the particles - ! dat = 0. + ! ! Get the primative density on the particles + ! dat = 0. ! do i=1, npart ! dat(:,i) = vxyzu(1:3,i) ! enddo - + ! end subroutine get_4velocity subroutine get_particle_domain(gridorigin,xmin,xmax,dxgrid,ilower,iupper) real, intent(in) :: gridorigin, xmin,xmax, dxgrid integer, intent(out) :: ilower, iupper - ! Changed from int to nint - ! to fix a bug - ilower = nint((xmin - gridorigin)/dxgrid) + 1 ! +1 since our arrays start at 1 not 0 - iupper = nint((xmax - gridorigin)/dxgrid) ! Removed the +1 as this was also a bug - ! The lower boundary is in the physical + ! Changed from int to nint + ! to fix a bug + ilower = nint((xmin - gridorigin)/dxgrid) + 1 ! +1 since our arrays start at 1 not 0 + iupper = nint((xmax - gridorigin)/dxgrid) ! Removed the +1 as this was also a bug + ! The lower boundary is in the physical ! domain but the upper is not; can't have both? end subroutine get_particle_domain @@ -268,7 +268,7 @@ subroutine interpolate_to_grid(gridarray,dat) use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid use interpolations3D, only: interpolate3D use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax - use part, only:npart,xyzh,massoftype,igas,rhoh,dens,hfact + use part, only:npart,xyzh,massoftype,igas,rhoh,dens,hfact real :: weight,h,rho,pmass,rhoexact real, save :: cfac integer, save :: iteration = 0 @@ -283,10 +283,10 @@ subroutine interpolate_to_grid(gridarray,dat) ! GRID MUST BE RESTRICTED WITH UPPER AND LOWER INDICIES real, intent(in) :: dat(:) ! The particle data to interpolate to grid real, allocatable :: interparray(:,:,:) - - - xmininterp(1) = xmin - dxgrid(1)!- 0.5*dxgrid(1) - xmininterp(2) = ymin - dxgrid(2) !- 0.5*dxgrid(2) + + + xmininterp(1) = xmin - dxgrid(1)!- 0.5*dxgrid(1) + xmininterp(2) = ymin - dxgrid(2) !- 0.5*dxgrid(2) xmininterp(3) = zmin - dxgrid(3) !- 0.5*dxgrid(3) !print*, "xminiterp: ", xmininterp call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) @@ -294,24 +294,24 @@ subroutine interpolate_to_grid(gridarray,dat) call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) ! We note that this is not actually the size of the einstein toolkit grid - ! As we want our periodic boundary to be on the particle domain not the - ! ET grid domain + ! As we want our periodic boundary to be on the particle domain not the + ! ET grid domain ngrid(1) = (iupper-ilower) + 1 - ngrid(2) = (jupper-jlower) + 1 - ngrid(3) = (kupper-klower) + 1 + ngrid(2) = (jupper-jlower) + 1 + ngrid(3) = (kupper-klower) + 1 allocate(interparray(ngrid(1),ngrid(2),ngrid(3))) interparray = 0. nnodes = (iupper-ilower)*(jupper-jlower)*(kupper-klower) - ! Do we want to normalise interpolations? + ! Do we want to normalise interpolations? normalise = .true. ! Is our NR GRID vertex centered? vertexcen = .false. - periodicx = .true. + periodicx = .true. periodicy = .true. - periodicz = .true. + periodicz = .true. + + - - do i=1, npart h = xyzh(4,i) ! Get pmass @@ -320,7 +320,7 @@ subroutine interpolate_to_grid(gridarray,dat) rho = rhoh(h,pmass) call get_weight(pmass,h,rho,weight) weights(i) = weight - enddo + enddo itype = igas ! call interpolate3D(xyzh,weight,npart, & ! xmininterp,gridarray(ilower:iupper,jlower:jupper,klower:kupper), & @@ -333,10 +333,10 @@ subroutine interpolate_to_grid(gridarray,dat) normalise,periodicx,periodicy,periodicz) - - + + end subroutine interpolate_to_grid - + subroutine check_conserved_dens(rhostargrid,cfac) use part, only:npart,massoftype,igas use einsteintk_utils, only: dxgrid, gridorigin @@ -351,17 +351,17 @@ subroutine check_conserved_dens(rhostargrid,cfac) call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) - totalmassgrid = 0. + totalmassgrid = 0. do i=ilower,iupper do j=jlower,jupper do k=klower, kupper totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) - - enddo - enddo + + enddo + enddo enddo - - ! total mass of the particles + + ! total mass of the particles totalmasspart = npart*massoftype(igas) !print*, "Total mass grid: ", totalmassgrid @@ -387,17 +387,17 @@ subroutine check_conserved_p(pgrid,cfac) call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) ! I'm still a bit unsure what this conserved quantity is actually meant to be?? - totalmomentumgrid = 0. + totalmomentumgrid = 0. do i=ilower,iupper do j=jlower,jupper do k=klower, kupper !totalmomentumgrid = totalmomentumgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) - - enddo - enddo + + enddo + enddo enddo - - ! total cons(momentum) of the particles + + ! total cons(momentum) of the particles totalmomentumpart = npart*massoftype(igas) ! Calculate cfac diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index c772ea2da..abb2dcf8f 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.F90 @@ -168,9 +168,9 @@ subroutine get_sqrtg(gcov, sqrtg) real :: a31,a32,a33,a34 real :: a41,a42,a43,a44 - - if (metric_type == 'et') then - + + if (metric_type == 'et') then + a11 = gcov(0,0) a21 = gcov(1,0) a31 = gcov(2,0) @@ -187,7 +187,7 @@ subroutine get_sqrtg(gcov, sqrtg) a24 = gcov(1,3) a34 = gcov(2,3) a44 = gcov(3,3) - + ! Calculate the determinant det = a14*a23*a32*a41 - a13*a24*a32*a41 - a14*a22*a33*a41 + a12*a24*a33*a41 + & a13*a22*a34*a41 - a12*a23*a34*a41 - a14*a23*a31*a42 + a13*a24*a31*a42 + & @@ -195,15 +195,15 @@ subroutine get_sqrtg(gcov, sqrtg) a14*a22*a31*a43 - a12*a24*a31*a43 - a14*a21*a32*a43 + a11*a24*a32*a43 + & a12*a21*a34*a43 - a11*a22*a34*a43 - a13*a22*a31*a44 + a12*a23*a31*a44 + & a13*a21*a32*a44 - a11*a23*a32*a44 - a12*a21*a33*a44 + a11*a22*a33*a44 - + sqrtg = sqrt(-det) !print*, "sqrtg: ", sqrtg !stop - else + else ! If we are not using an evolving metric then - ! Sqrtg = 1 + ! Sqrtg = 1 sqrtg = 1. - endif + endif end subroutine get_sqrtg @@ -218,10 +218,10 @@ subroutine get_sqrt_gamma(gcov,sqrt_gamma) real :: a41,a42,a43 real :: det - if (metric_type == 'et') then + if (metric_type == 'et') then ! Calculate the determinant of a 3x3 matrix ! Spatial metric is just the physical metric - ! without the tt component + ! without the tt component a11 = gcov(1,1) a12 = gcov(1,2) @@ -237,9 +237,9 @@ subroutine get_sqrt_gamma(gcov,sqrt_gamma) sqrt_gamma = sqrt(det) else - sqrt_gamma = -1. + sqrt_gamma = -1. - endif + endif end subroutine get_sqrt_gamma @@ -248,18 +248,18 @@ subroutine perturb_metric(phi,gcovper,gcov) real, intent(in) :: phi real, intent(out) :: gcovper(0:3,0:3) real, optional, intent(in) :: gcov(0:3,0:3) - - - if (present(gcov)) then + + + if (present(gcov)) then gcovper = gcov else - gcovper = 0. + gcovper = 0. gcovper(0,0) = -1. gcovper(1,1) = 1. gcovper(2,2) = 1. gcovper(3,3) = 1. - endif - + endif + ! Set the pertubed metric based on the Bardeen formulation gcovper(0,0) = gcovper(0,0) - 2.*phi gcovper(1,1) = gcovper(1,1) - 2.*phi diff --git a/src/main/utils_infiles.f90 b/src/main/utils_infiles.f90 index 47a47d7f7..56f3fafde 100644 --- a/src/main/utils_infiles.f90 +++ b/src/main/utils_infiles.f90 @@ -192,7 +192,7 @@ subroutine write_inopt_real8(rval,name,descript,iunit,ierr,exp,time) fmts = "a20" if (len_trim(name) > 20) fmts = "a" - + if (dotime) then trem = rval nhr = int(trem/3600.d0) @@ -219,7 +219,7 @@ subroutine write_inopt_real8(rval,name,descript,iunit,ierr,exp,time) write(tmpstring,"(g16.9)",iostat=ierror) rval tmpstring = adjustl(strip_zeros(tmpstring,3)) endif - + if (len_trim(tmpstring) > 10) then write(iunit,"("//trim(fmts)//",' = ',1x,a,2x,'! ',a)",iostat=ierror) name,adjustr(trim(tmpstring)),descript else @@ -278,7 +278,7 @@ subroutine write_inopt_string(sval,name,descript,iunit,ierr) fmts = "a20" if (len_trim(name) > 20) fmts = "a" - + if (len_trim(sval) > 10) then fmtstring = '('//fmts//','' = '',1x,a,3x,''! '',a)' else diff --git a/src/setup/phantomsetup.F90 b/src/setup/phantomsetup.F90 index a25085e6a..8c2efc20c 100644 --- a/src/setup/phantomsetup.F90 +++ b/src/setup/phantomsetup.F90 @@ -127,7 +127,7 @@ program phantomsetup myid1 = myid if (mpi) myid1 = id call setpart(myid1,npart,npartoftype(:),xyzh,massoftype(:),vxyzu,polyk,gamma,hfact,time,fileprefix) -! +! !--setup magnetic field if code compiled with MHD ! if (mhd .and. .not.ihavesetupB) then diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 1e952f485..0740c309c 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -37,7 +37,7 @@ module setup integer :: npartx,ilattice real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,Bzero,ampl,phaseoffset character(len=20) :: dist_unit,mass_unit,perturb_direction,perturb,radiation_dominated - real :: perturb_wavelength + real :: perturb_wavelength real(kind=8) :: udist,umass !--change default defaults to reproduce the test from Section 5.6.7 of Price+(2018) @@ -87,26 +87,26 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real :: perturb_rho0,xval real :: Vup(0:3),v(0:3),const,phi,rhoprim,sqrtg,u0,x,gcov(0:3,0:3),alpha,hub real :: last_scattering_temp - real :: u + real :: u procedure(rho_func), pointer :: density_func procedure(mass_func), pointer :: mass_function density_func => rhofunc ! desired density function - mass_function => massfunc ! desired mass funciton + mass_function => massfunc ! desired mass funciton ! !--general parameters ! - perturb_wavelength = 1. + perturb_wavelength = 1. time = 0. if (maxvxyzu < 4) then gamma = 1. else - ! 4/3 for radiation dominated case - ! irrelevant for + ! 4/3 for radiation dominated case + ! irrelevant for gamma = 4./3. endif - ! Redefinition of pi to fix numerical error + ! Redefinition of pi to fix numerical error pi = 4.D0*Datan(1.0D0) ! ! default units @@ -128,23 +128,23 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, perturb_direction = '"none"' radiation_dominated = '"no"' - ! Ideally this should read the values of the box length + ! Ideally this should read the values of the box length ! and initial Hubble parameter from the par file. - ! Then it should be set using the Friedmann equation: + ! Then it should be set using the Friedmann equation: !!!!!! rhozero = (3H^2)/(8*pi*a*a) hub = 10.553495658357338 rhozero = 3.d0 * hub**2 / (8.d0 * pi) phaseoffset = 0. - ! Approx Temp of the CMB in Kelvins + ! Approx Temp of the CMB in Kelvins last_scattering_temp = 3000 last_scattering_temp = (rhozero/radconst)**(1./4.)*0.99999 - + ! Define some parameters for Linear pertubations ! We assume ainit = 1, but this may not always be the case c1 = 1.d0/(4.d0*PI*rhozero) - !c2 = We set g(x^i) = 0 as we only want to extract the growing mode + !c2 = We set g(x^i) = 0 as we only want to extract the growing mode c3 = - sqrt(1.d0/(6.d0*PI*rhozero)) @@ -185,7 +185,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! setup particles ! - + npart = 0 npart_total = 0 length = xmaxi - xmini @@ -193,23 +193,23 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! general parameters ! -! time should be read in from the par file - time = 0.18951066686763596 ! z~1000 +! time should be read in from the par file + time = 0.18951066686763596 ! z~1000 lambda = perturb_wavelength*length kwave = (2.d0*pi)/lambda denom = length - ampl/kwave*(cos(kwave*length)-1.0) ! Hardcode to ensure double precision, that is requried !rhozero = 13.294563008157013D0 rhozero = 3.d0 * hub**2 / (8.d0 * pi) - + select case(radiation_dominated) case('"yes"') rhozero = rhozero - radconst*last_scattering_temp**4 end select - + xval = density_func(0.75) - xval = density_func(0.0) + xval = density_func(0.0) select case(ilattice) case(2) @@ -217,7 +217,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, case default if (ilattice /= 1) print*,' error: chosen lattice not available, using cubic' lattice = 'cubic' - end select + end select select case(perturb) case('"yes"') @@ -238,11 +238,11 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, geom=1,coord=2) call set_density_profile(npart,xyzh,min=zmin,max=zmax,rhofunc=density_func,& geom=1,coord=3) - end select + end select case('"no"') call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& npart,xyzh,periodic,nptot=npart_total,mask=i_belong) - end select + end select npartoftype(:) = 0 npartoftype(1) = npart @@ -254,7 +254,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, if (id==master) print*,' particle mass = ',massoftype(1) if (id==master) print*,' initial sound speed = ',cs0,' pressure = ',cs0**2/gamma - + if (maxvxyzu < 4 .or. gamma <= 1.) then polyk = cs0**2 @@ -262,7 +262,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, polyk = 0. endif do i=1,npart - + select case(perturb_direction) case ('"x"') ! should not be zero, for a pertrubed wave @@ -273,7 +273,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, Vup(2:3) = 0. call perturb_metric(phi,gcov) call get_sqrtg(gcov,sqrtg) - + alpha = sqrt(-gcov(0,0)) vxyzu(1,i) = Vup(1)*alpha vxyzu(2:3,i) = 0. @@ -282,45 +282,45 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, phi = ampl*sin(kwave*xyzh(2,i)-phaseoffset) Vup = 0. Vup(2) = kwave*c3*ampl*cos(2.d0*pi*xyzh(2,i) - phaseoffset) - + call perturb_metric(phi,gcov) call get_sqrtg(gcov,sqrtg) - + alpha = sqrt(-gcov(0,0)) vxyzu(:,i) = 0. vxyzu(2,i) = Vup(2)*alpha - + case ('"all"') phi = ampl*(sin(kwave*xyzh(1,i)-phaseoffset) - sin(kwave*xyzh(2,i)-phaseoffset) - sin(kwave*xyzh(3,i)-phaseoffset)) - Vup(1) = kwave*c3*ampl*cos((2.d0*pi*xyzh(1,i))/lambda - phaseoffset) + Vup(1) = kwave*c3*ampl*cos((2.d0*pi*xyzh(1,i))/lambda - phaseoffset) Vup(2) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) Vup(3) = kwave*c3*ampl*cos((2.d0*pi*xyzh(3,i))/lambda - phaseoffset) - + call perturb_metric(phi,gcov) call get_sqrtg(gcov,sqrtg) - - alpha = sqrt(-gcov(0,0)) + + alpha = sqrt(-gcov(0,0)) ! perturb the y and z velocities vxyzu(1,i) = Vup(1)*alpha vxyzu(2,i) = Vup(2)*alpha vxyzu(3,i) = Vup(3)*alpha - end select + end select ! Setup the intial internal energy here? - ! This should be u = aT^4/\rho + ! This should be u = aT^4/\rho ! Choose an initial temp of the cmb ~ 3000K ! Set a=1 for now ! Asssuming that this is constant density/pressure for now so I'm making sure that ! Note that rhozero != rho ! rhozero = rho + rho*u as this is the energy density select case(radiation_dominated) - case('"yes"') + case('"yes"') if (maxvxyzu >= 4 .and. gamma > 1.) vxyzu(4,i) = (radconst*(last_scattering_temp**4))/rhozero !vxyzu(4,i) = cs0**2/(gamma*(gamma-1.)) ! Check that the pressure is correct print*, "Pressure: ", (gamma-1)*rhozero*vxyzu(4,i) print*, "Pressure from energy density: ", 3.d0 * hub**2 / (8.d0 * pi)/3. print*, "Pressure 1/3 \rho u: ",radconst*(last_scattering_temp**4)/3. - end select + end select enddo @@ -335,31 +335,31 @@ real function rhofunc(x) !use metric_tools, only:unpack_metric real, intent(in) :: x real :: const, phi, rhoprim, gcov(0:3,0:3), sqrtg,u0,v(3),Vup(3) - real :: alpha + real :: alpha integer :: ierr !rhofunc = 1.d0 + ampl*sin(kwave*(x-xmin)) !rhofunc = ampl*sin(kwave*(x-xmin)) ! Eq 28. in Macpherson+ 2017 - ! Although it is missing a negative sign - const = -kwave*kwave*c1 - 2.d0 + ! Although it is missing a negative sign + const = -kwave*kwave*c1 - 2.d0 phi = ampl*sin(kwave*x-phaseoffset) !rhofunc = rhozero*(1.d0 + const*ampl*sin(kwave*x)) ! Get the primative density from the linear perb rhoprim = rhozero*(1.d0+const*phi) - + ! Get the perturbed 4-metric call perturb_metric(phi,gcov) ! Get sqrt(-det(g)) call get_sqrtg(gcov,sqrtg) ! Define the 3 velocities to calculate u0 - ! Three velocity will need to be converted from big V to small v - ! + ! Three velocity will need to be converted from big V to small v + ! Vup(1) = kwave*c3*ampl*cos((2.d0*pi*x)/lambda-phaseoffset) Vup(2:3) = 0. alpha = sqrt(-gcov(0,0)) v(1) = Vup(1)*alpha - v(2:3) = 0. + v(2:3) = 0. ! calculate u0 ! TODO Should probably handle this error at some point call get_u0(gcov,v,u0,ierr) @@ -369,19 +369,19 @@ real function rhofunc(x) end function rhofunc real function massfunc(x,xmin) - use utils_gr, only:perturb_metric, get_u0, get_sqrtg + use utils_gr, only:perturb_metric, get_u0, get_sqrtg real, intent(in) :: x,xmin real :: const, expr, exprmin, rhoprim, gcov(0:3,0:3), sqrtg,u0,v(3),Vup(3) real :: massprimx,massprimmin,massprim - - ! The value inside the bracket + + ! The value inside the bracket const = -kwave*kwave*c1 - 2.d0 expr = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*x)/lambda) exprmin = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*xmin)/lambda) massprimx = (x-const*expr) massprimmin = (xmin-const*exprmin) - ! Evalutation of the integral - ! rho0[x-Acos(kx)]^x_0 + ! Evalutation of the integral + ! rho0[x-Acos(kx)]^x_0 massprim = rhozero*(massprimx - massprimmin) ! Get the perturbed 4-metric @@ -389,14 +389,14 @@ real function massfunc(x,xmin) ! Get sqrt(-det(g)) call get_sqrtg(gcov,sqrtg) ! Define the 3 velocities to calculate u0 - ! Three velocity will need to be converted from big V to small v - ! + ! Three velocity will need to be converted from big V to small v + ! Vup(1) = kwave*c3*ampl*cos((2.d0*pi*x)/lambda-phaseoffset) Vup(2:3) = 0. alpha = sqrt(-gcov(0,0)) v(1) = Vup(1)*alpha - v(2:3) = 0. - + v(2:3) = 0. + call get_u0(gcov,v,u0,ierr) massfunc = massprim*sqrtg*u0 @@ -510,8 +510,8 @@ subroutine write_setupfile(filename) call write_inopt(ymaxi,'CoordBase::ymax','ymax boundary',iunit) call write_inopt(zmini,'CoordBase::zmin','zmin boundary',iunit) call write_inopt(zmaxi,'CoordBase::zmax','zmax boundary',iunit) - - + + ! ! other parameters @@ -576,8 +576,8 @@ subroutine read_setupfile(filename,ierr) call read_inopt(npartx,'nx',db,min=8,errcount=nerr) call read_inopt(rhozero,'rhozero',db,min=0.,errcount=nerr) call read_inopt(cs0,'cs0',db,min=0.,errcount=nerr) - - call read_inopt(perturb_direction,'FLRWSolver::FLRW_perturb_direction',db,errcount=nerr) + + call read_inopt(perturb_direction,'FLRWSolver::FLRW_perturb_direction',db,errcount=nerr) call read_inopt(ampl, 'FLRWSolver::phi_amplitude',db,errcount=nerr) call read_inopt(phaseoffset,'FLRWSolver::phi_phase_offset',db,errcount=nerr) call read_inopt(ilattice,'ilattice',db,min=1,max=2,errcount=nerr) @@ -585,7 +585,7 @@ subroutine read_setupfile(filename,ierr) call read_inopt(perturb,'FLRWSolver::FLRW_perturb',db,errcount=nerr) call read_inopt(radiation_dominated,'radiation_dominated',db,errcount=nerr) call read_inopt(perturb_wavelength,'FLRWSolver::single_perturb_wavelength',db,errcount=nerr) - !print*, db + !print*, db call close_db(db) if (nerr > 0) then diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index 97701ebf3..f35f033e4 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -37,7 +37,7 @@ module setup integer :: npartx,ilattice real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,Bzero,ampl,phaseoffset character(len=20) :: dist_unit,mass_unit,perturb_direction,perturb,radiation_dominated - real :: perturb_wavelength + real :: perturb_wavelength real(kind=8) :: udist,umass !--change default defaults to reproduce the test from Section 5.6.7 of Price+(2018) @@ -81,7 +81,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real, intent(out) :: vxyzu(:,:) character(len=40) :: filename,lattice,pspec_filename1,pspec_filename2,pspec_filename3 real :: totmass,deltax,pi - integer :: i,j,k,ierr,ncross + integer :: i,j,k,ierr,ncross logical :: iexist,isperiodic(3) real :: kwave,denom,length, c1,c3,lambda real :: perturb_rho0,xval @@ -95,21 +95,21 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! procedure(mass_func), pointer :: mass_function ! density_func => rhofunc ! desired density function -! mass_function => massfunc ! desired mass funciton +! mass_function => massfunc ! desired mass funciton ! !--general parameters ! - !perturb_wavelength = 1. + !perturb_wavelength = 1. time = 0. if (maxvxyzu < 4) then gamma = 1. else - ! 4/3 for radiation dominated case - ! irrelevant for + ! 4/3 for radiation dominated case + ! irrelevant for gamma = 4./3. endif - ! Redefinition of pi to fix numerical error + ! Redefinition of pi to fix numerical error pi = 4.D0*Datan(1.0D0) ! ! default units @@ -131,25 +131,25 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, perturb_direction = '"none"' radiation_dominated = '"no"' - ! Ideally this should read the values of the box length + ! Ideally this should read the values of the box length ! and initial Hubble parameter from the par file. - ! Then it should be set using the Friedmann equation: + ! Then it should be set using the Friedmann equation: !!!!!! rhozero = (3H^2)/(8*pi*a*a) hub = 10.553495658357338 rhozero = 3.d0 * hub**2 / (8.d0 * pi) phaseoffset = 0. - ! Set some default values for the grid + ! Set some default values for the grid nghost = 6 gridres = 64 - + gridsize = nghost + gridres gridorigin = 0. - xmax = 1. + xmax = 1. dxgrid = xmax/gridres gridorigin = gridorigin-3*dxgrid - + isperiodic = .true. ncross = 0 @@ -157,14 +157,14 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, allocate(vygrid(gridsize,gridsize,gridsize)) allocate(vzgrid(gridsize,gridsize,gridsize)) - ! Approx Temp of the CMB in Kelvins + ! Approx Temp of the CMB in Kelvins last_scattering_temp = 3000 last_scattering_temp = (rhozero/radconst)**(1./4.)*0.99999 - + ! Define some parameters for Linear pertubations ! We assume ainit = 1, but this may not always be the case c1 = 1.d0/(4.d0*PI*rhozero) - !c2 = We set g(x^i) = 0 as we only want to extract the growing mode + !c2 = We set g(x^i) = 0 as we only want to extract the growing mode c3 = - sqrt(1.d0/(6.d0*PI*rhozero)) @@ -205,7 +205,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! setup particles ! - + npart = 0 npart_total = 0 length = xmaxi - xmini @@ -213,20 +213,20 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! general parameters ! -! time should be read in from the par file - time = 0.18951066686763596 ! z~1000 +! time should be read in from the par file + time = 0.18951066686763596 ! z~1000 ! lambda = perturb_wavelength*length ! kwave = (2.d0*pi)/lambda ! denom = length - ampl/kwave*(cos(kwave*length)-1.0) ! Hardcode to ensure double precision, that is requried !rhozero = 13.294563008157013D0 rhozero = 3.d0 * hub**2 / (8.d0 * pi) - - lattice = 'cubic' + + lattice = 'cubic' call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& - npart,xyzh,periodic,nptot=npart_total,mask=i_belong) + npart,xyzh,periodic,nptot=npart_total,mask=i_belong) npartoftype(:) = 0 npartoftype(1) = npart @@ -238,7 +238,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, if (id==master) print*,' particle mass = ',massoftype(1) if (id==master) print*,' initial sound speed = ',cs0,' pressure = ',cs0**2/gamma - + if (maxvxyzu < 4 .or. gamma <= 1.) then polyk = cs0**2 @@ -250,34 +250,34 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, pspec_filename2 = 'init_vel2_64.dat' pspec_filename3 = 'init_vel3_64.dat' ! Read in velocities from vel file here - ! Should be made into a function at some point + ! Should be made into a function at some point ! open(unit=444,file=pspec_filename,status='old') ! do k=1,gridsize ! do j=1,gridsize ! read(444,*) (vxgrid(i,j,k), i=1, 9) - + ! enddo -! enddo +! enddo ! close(444) call read_veldata(vxgrid,pspec_filename1,gridsize) call read_veldata(vygrid,pspec_filename2,gridsize) call read_veldata(vzgrid,pspec_filename3,gridsize) -! vxgrid = 1. -! vygrid = 2. -! vzgrid = 3. - !stop +! vxgrid = 1. +! vygrid = 2. +! vzgrid = 3. + !stop do i=1,npart ! Assign new particle possition + particle velocities here using the Zeldovich approximation: - ! Valid for Omega = 1 + ! Valid for Omega = 1 ! x = q - a grad phi (1), where q is the non perturbed lattice point position ! v = -aH grad phi (2) ! Interpolate grid velocities to particles ! big v vs small v? - ! Call interpolate from grid - !get_velocity_fromgrid(vxyz,pos) + ! Call interpolate from grid + !get_velocity_fromgrid(vxyz,pos) ! CHECK THAT GRID ORIGIN IS CORRECT !!!!!!!!!!! - ! DO I NEED TO UPDATE THE GHOST CELLS?? + ! DO I NEED TO UPDATE THE GHOST CELLS?? ! Get x velocity at particle position call interpolate_val(xyzh(1:3,i),vxgrid,gridsize,gridorigin,dxgrid,vxyz(1)) print*, "Finished x interp" @@ -289,16 +289,16 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, vxyzu(1:3,i) = vxyz print*, vxyz ! solve eqn (2) for grad phi - ! This is probally not constant?? + ! This is probally not constant?? scale_factor = 1. - gradphi = -vxyz/(scale_factor*hub) + gradphi = -vxyz/(scale_factor*hub) ! Set particle pos xyzh(1:3,i) = xyzh(1:3,i) - scale_factor*gradphi ! Apply periodic boundary conditions to particle position call cross_boundary(isperiodic,xyzh(1:3,i),ncross) - ! Calculate a new smoothing length?? Since the particle distrubtion has changed - + ! Calculate a new smoothing length?? Since the particle distrubtion has changed + enddo @@ -410,8 +410,8 @@ subroutine write_setupfile(filename) call write_inopt(ymaxi,'CoordBase::ymax','ymax boundary',iunit) call write_inopt(zmini,'CoordBase::zmin','zmin boundary',iunit) call write_inopt(zmaxi,'CoordBase::zmax','zmax boundary',iunit) - - + + ! ! other parameters @@ -476,8 +476,8 @@ subroutine read_setupfile(filename,ierr) call read_inopt(npartx,'nx',db,min=8,errcount=nerr) call read_inopt(rhozero,'rhozero',db,min=0.,errcount=nerr) call read_inopt(cs0,'cs0',db,min=0.,errcount=nerr) - - call read_inopt(perturb_direction,'FLRWSolver::FLRW_perturb_direction',db,errcount=nerr) + + call read_inopt(perturb_direction,'FLRWSolver::FLRW_perturb_direction',db,errcount=nerr) call read_inopt(ampl, 'FLRWSolver::phi_amplitude',db,errcount=nerr) call read_inopt(phaseoffset,'FLRWSolver::phi_phase_offset',db,errcount=nerr) call read_inopt(ilattice,'ilattice',db,min=1,max=2,errcount=nerr) @@ -485,7 +485,7 @@ subroutine read_setupfile(filename,ierr) call read_inopt(perturb,'FLRWSolver::FLRW_perturb',db,errcount=nerr) call read_inopt(radiation_dominated,'radiation_dominated',db,errcount=nerr) call read_inopt(perturb_wavelength,'FLRWSolver::single_perturb_wavelength',db,errcount=nerr) - !print*, db + !print*, db call close_db(db) if (nerr > 0) then @@ -519,23 +519,23 @@ subroutine read_veldata(velarray,vfile,gridsize) open(unit=444,file=vfile,status='old') do k=1,gridsize do j=1,gridsize - read(444,*) (velarray(i,j,k), i=1, gridsize) + read(444,*) (velarray(i,j,k), i=1, gridsize) enddo - enddo + enddo close(444) print*, "Finished reading ", vfile end subroutine read_veldata subroutine interpolate_val(position,valgrid,gridsize,gridorigin,dxgrid,val) - ! Subroutine to interpolate quanities to particle positions given a cube + ! Subroutine to interpolate quanities to particle positions given a cube ! Note we have assumed that the grid will always be cubic!!!! use eos_shen, only:linear_interpolator_one_d real, intent(in) :: valgrid(:,:,:) real, intent(inout) :: position(3) real, intent(inout) :: dxgrid,gridorigin integer, intent(in) :: gridsize - real, intent(out) :: val + real, intent(out) :: val integer :: xupper,yupper,zupper,xlower,ylower,zlower real :: xlowerpos,ylowerpos,zlowerpos,xupperpos,yupperpos,zupperpos real :: interptmp(7) @@ -548,9 +548,9 @@ subroutine interpolate_val(position,valgrid,gridsize,gridorigin,dxgrid,val) print*,"Neighbours: ", xlower,ylower,zlower print*,"Position: ", position ! This is not true as upper neighbours on the boundary will be on the side - ! take a mod of grid size + ! take a mod of grid size xupper = mod(xlower + 1, gridsize) - yupper = mod(ylower + 1, gridsize) + yupper = mod(ylower + 1, gridsize) zupper = mod(zlower + 1, gridsize) ! xupper - xlower should always just be dx provided we are using a uniform grid ! xd = (position(1) - xlower)/(xupper - xlower) @@ -563,44 +563,44 @@ subroutine interpolate_val(position,valgrid,gridsize,gridorigin,dxgrid,val) xd = (position(1) - xlowerpos)/(dxgrid) yd = (position(2) - ylowerpos)/(dxgrid) zd = (position(3) - zlowerpos)/(dxgrid) - + interptmp = 0. - call linear_interpolator_one_d(valgrid(xlower,ylower,zlower), & + call linear_interpolator_one_d(valgrid(xlower,ylower,zlower), & valgrid(xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(valgrid(xlower,ylower,zlower+1), & + call linear_interpolator_one_d(valgrid(xlower,ylower,zlower+1), & valgrid(xlower+1,ylower,zlower+1),xd,interptmp(2)) call linear_interpolator_one_d(valgrid(xlower,ylower+1,zlower), & valgrid(xlower+1,ylower+1,zlower),xd,interptmp(3)) call linear_interpolator_one_d(valgrid(xlower,ylower+1,zlower+1), & valgrid(xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y + ! Interpolate along y call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) ! Interpolate along z call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - + val = interptmp(7) end subroutine interpolate_val subroutine get_grid_neighbours(position,gridorigin,dx,xlower,ylower,zlower) - ! TODO IDEALLY THIS SHOULDN'T BE HERE AND SHOULD BE IN A UTILS MODULE + ! TODO IDEALLY THIS SHOULDN'T BE HERE AND SHOULD BE IN A UTILS MODULE ! WITH THE VERSION USED IN METRIC_ET real, intent(in) :: position(3), gridorigin real, intent(in) :: dx integer, intent(out) :: xlower,ylower,zlower - - ! Get the lower grid neighbours of the position + + ! Get the lower grid neighbours of the position ! If this is broken change from floor to int ! How are we handling the edge case of a particle being ! in exactly the same position as the grid? - ! Hopefully having different grid sizes in each direction + ! Hopefully having different grid sizes in each direction ! Doesn't break the lininterp xlower = floor((position(1)-gridorigin)/dx) print*, "pos x: ", position(1) print*, "gridorigin: ", gridorigin - print*, "dx: ", dx + print*, "dx: ", dx ylower = floor((position(2)-gridorigin)/dx) zlower = floor((position(3)-gridorigin)/dx) diff --git a/src/setup/setup_hierarchical.f90 b/src/setup/setup_hierarchical.f90 index 2aa1bb658..27f9fb301 100644 --- a/src/setup/setup_hierarchical.f90 +++ b/src/setup/setup_hierarchical.f90 @@ -78,7 +78,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, if (id==master) then - print*," " + print*," " print*," _:_ " print*," '-.-' " print*," () __.'.__ " @@ -112,13 +112,13 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, print "(/,65('-'),1(/,a),/,65('-'),/)",& ' Welcome to CHESS (Complete Hierarchical Endless System Setup)' - + ! print "(/,65('-'),1(/,a),/,1(a),/,65('-'),/)",& ! ' Welcome to CHESS (Complete Hierarchical Endless System Setup)', & ! ' simulate the universe as a hierarchical system' - + endif - + filename = trim(fileprefix)//'.setup' inquire(file=filename,exist=iexist) if (iexist) call read_setupfile(filename,ierr) diff --git a/src/setup/stretchmap.f90 b/src/setup/stretchmap.f90 index 78c437c56..9b4c7588d 100644 --- a/src/setup/stretchmap.f90 +++ b/src/setup/stretchmap.f90 @@ -50,7 +50,7 @@ end function rho_func real function mass_func(x,xmin) real, intent(in) :: x, xmin end function mass_func - end interface + end interface private @@ -117,7 +117,7 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,massfunc,rhotab,xtab,star if (present(verbose)) isverbose = verbose if (present(rhotab)) use_rhotab = .true. - if (present(massfunc)) use_massfunc = .true. + if (present(massfunc)) use_massfunc = .true. print*,"Use mass func?: ", use_massfunc if (present(rhofunc) .or. present(rhotab)) then if (isverbose) print "(a)",' >>>>>> s t r e t c h m a p p i n g <<<<<<' @@ -187,7 +187,7 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,massfunc,rhotab,xtab,star totmass = get_mass_r(rhofunc,xmax,xmin) elseif (is_rcyl) then totmass = get_mass_rcyl(rhofunc,xmax,xmin) - elseif (use_massfunc) then + elseif (use_massfunc) then totmass = massfunc(xmax,min) else totmass = get_mass(rhofunc,xmax,xmin) @@ -252,7 +252,7 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,massfunc,rhotab,xtab,star func = get_mass_r(rhofunc,xi,xmin) elseif (is_rcyl) then func = get_mass_rcyl(rhofunc,xi,xmin) - elseif (use_massfunc) then + elseif (use_massfunc) then func = massfunc(xi,xmin) else func = get_mass(rhofunc,xi,xmin) @@ -281,9 +281,9 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,massfunc,rhotab,xtab,star elseif (is_rcyl) then func = get_mass_rcyl(rhofunc,xi,xmin) - fracmassold dfunc = 2.*pi*xi*rhofunc(xi) - elseif (use_massfunc) then + elseif (use_massfunc) then func = massfunc(xi,xmin) - fracmassold - dfunc = rhofunc(xi) + dfunc = rhofunc(xi) else func = get_mass(rhofunc,xi,xmin) - fracmassold dfunc = rhofunc(xi) diff --git a/src/utils/analysis_BRhoOrientation.F90 b/src/utils/analysis_BRhoOrientation.F90 index 09eed38f3..1a43e06f9 100644 --- a/src/utils/analysis_BRhoOrientation.F90 +++ b/src/utils/analysis_BRhoOrientation.F90 @@ -68,13 +68,13 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) real :: absB,absrho,costheta,vtheta,absV real :: rhobins(nbins),Bbins(nbins),costbins(nbins),vbins(nbins),vtbins(nbins) real :: mixedavg(nbins,nbins),paralavg(nbins,nbins),perpavg(nbins,nbins) - logical :: keep_searching + logical :: keep_searching character(len=200) :: fileout ! !-- Initialise parameters !-- Converting cgs units to code units - ! - rhomin = rhomin_cgs/unit_density + ! + rhomin = rhomin_cgs/unit_density rhomax = rhomax_cgs/unit_density Bmin = Bmin_cgs/unit_Bfield Bmax = Bmax_cgs/unit_Bfield @@ -114,11 +114,11 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) vtbins(i) = (vtmin + (i-1)*dvt) enddo - !--Sorting all particles into list ordered by ascending Z position + !--Sorting all particles into list ordered by ascending Z position ! Used to find the neighbouring particles without the full neighbour-finding process ikount = 0 do i = 1,npart - if (xyzh(4,i) > 0) then + if (xyzh(4,i) > 0) then ikount = ikount + 1 ipos(ikount) = i dpos(ikount) = xyzh(3,i) @@ -130,13 +130,13 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) !$omp shared(npart,xyzh,particlemass,Bxyz,costbins,Bbins,rhobins,Bmin,rhomin,unit_density,ikount,vxyzu) & !$omp shared(ipos,lst,vbins,vtbins) & #ifdef PERIODIC -!$omp shared(dxbound,dybound,dzbound) & +!$omp shared(dxbound,dybound,dzbound) & #endif !$omp private(i,xi,yi,zi,hi,rhoi,rhoi1,Bxi,Byi,Bzi,rhxi,rhyi,rhzi,xj,yj,zj,hj,j,dxi,dyi,dzi,dri,q,rhoj,l,vt) & !$omp private(grki,grkxi,grkyi,grkzi,absB,absrho,costheta,k,p,t,b,r,o,ii,jj,twohi,vxi,vyi,vzi,vtheta,absV) & - !$omp private(keep_searching) & + !$omp private(keep_searching) & !$omp reduction(+:thetB,thetrho,vvt,bvt,vcost,cost) & - !$omp reduction(+:paralavg,perpavg,mixedavg,perpi,parali,mixedi) + !$omp reduction(+:paralavg,perpavg,mixedavg,perpi,parali,mixedi) !$omp do schedule(runtime) aparts: do ii = 1,ikount ! properties of particle i @@ -165,7 +165,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! not require the full neighbour finding algorithm bparts: do p = 1,2 jj = ii - + keep_searching = .true. do while (keep_searching) if (p==1) then @@ -220,9 +220,9 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) vtheta = (Bxi*vxi + Byi*vyi + Bzi*vzi) / (absB*absV) ! Finding bins - t = 1 ! cosTheta/angle + t = 1 ! cosTheta/angle b = 1 ! mag/B field - r = 1 ! rho/density + r = 1 ! rho/density l = 1 ! velocity vt = 1 ! psi angle do while (costheta > costbins(t) .and. t < nbins) @@ -302,7 +302,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) write(iunit,"('#',3(1x,'[',i2.2,1x,a11,']',2x))") & 1,'cost', & 2,'B', & - 3,'freq' + 3,'freq' do i = 1,nbins do j = 1,nbins write(iunit,'(2(1pe18.10,1x),(I18,1x))') costbins(i),Bbins(j)*unit_Bfield,thetB(i,j) @@ -316,7 +316,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) write(iunit,"('#',3(1x,'[',i2.2,1x,a11,']',2x))") & 1,'cost', & 2,'rho', & - 3,'freq' + 3,'freq' do i = 1,nbins do j = 1,nbins write(iunit,'(2(1pe18.10,1x),(I18,1x))') costbins(i),rhobins(j)*unit_density,thetrho(i,j) @@ -346,7 +346,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) write(iunit,"('#',3(1x,'[',i2.2,1x,a11,']',2x))") & 1,'vcost', & 2,'B', & - 3,'freq' + 3,'freq' do i = 1,nbins do j = 1,nbins write(iunit,'(2(1pe18.10,1x),(I18,1x))') vtbins(i),Bbins(j)*unit_Bfield,bvt(i,j) @@ -360,7 +360,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) write(iunit,"('#',3(1x,'[',i2.2,1x,a11,']',2x))") & 1,'vcost', & 2,'v', & - 3,'freq' + 3,'freq' do i = 1,nbins do j = 1,nbins write(iunit,'(2(1pe18.10,1x),(I18,1x))') vtbins(i),vbins(j)*unit_velocity,vvt(i,j) @@ -375,7 +375,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) 1,'vcost', & 2,'freq' , & 3,'cost' , & - 4,'freq' + 4,'freq' do i = 1,nbins write(iunit,'((1pe18.10,1x),(I18,1x),(1pe18.10,1x),(I18,1x))') vtbins(i), vcost(i), costbins(i), cost(i) enddo diff --git a/src/utils/analysis_sphere.f90 b/src/utils/analysis_sphere.f90 index f7043b6e2..3233a3645 100644 --- a/src/utils/analysis_sphere.f90 +++ b/src/utils/analysis_sphere.f90 @@ -113,7 +113,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! adjust centres do i = 1,npart xyzh(1:3,i) = xyzh(1:3,i) - xcom - enddo + enddo else ! move to centre of mass call reset_centreofmass(npart,xyzh,vxyzu) @@ -178,10 +178,10 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) vbins(4,j) = vbins(4,j) + ui vbins(5,j) = vbins(5,j) + vr vbins(6,j) = vbins(6,j) + vphi - if (vphi > 0.) then + if (vphi > 0.) then ibins(2,j) = ibins(2,j) + 1 vbins(7,j) = vbins(7,j) + vphi - elseif (vphi < 0.) then + elseif (vphi < 0.) then ibins(3,j) = ibins(3,j) + 1 vbins(8,j) = vbins(8,j) + vphi endif diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index 36a86a997..428b73060 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -16,7 +16,7 @@ module einsteintk_utils ! ! :Dependencies: part ! - implicit none + implicit none real, allocatable :: gcovgrid(:,:,:,:,:) real, allocatable :: gcongrid(:,:,:,:,:) real, allocatable :: sqrtggrid(:,:,:) @@ -34,49 +34,49 @@ module einsteintk_utils subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) integer, intent(in) :: nx,ny,nz real, intent(in) :: dx,dy,dz,originx,originy,originz - + gridsize(1) = nx gridsize(2) = ny - gridsize(3) = nz + gridsize(3) = nz dxgrid(1) = dx dxgrid(2) = dy dxgrid(3) = dz - + gridorigin(1) = originx gridorigin(2) = originy gridorigin(3) = originz - + allocate(gcovgrid(0:3,0:3,nx,ny,nz)) allocate(gcongrid(0:3,0:3,nx,ny,nz)) allocate(sqrtggrid(nx,ny,nz)) - ! Will need to delete this at somepoint - ! For now it is the simplest way + ! Will need to delete this at somepoint + ! For now it is the simplest way allocate(tmunugrid(0:3,0:3,nx,ny,nz)) allocate(pxgrid(3,nx,ny,nz)) allocate(rhostargrid(nx,ny,nz)) - + ! TODO Toggle for this to save memory allocate(entropygrid(nx,ny,nz)) - ! metric derivs are stored in the form - ! mu comp, nu comp, deriv, gridx,gridy,gridz - ! Note that this is only the spatial derivs of - ! the metric and we will need an additional array + ! metric derivs are stored in the form + ! mu comp, nu comp, deriv, gridx,gridy,gridz + ! Note that this is only the spatial derivs of + ! the metric and we will need an additional array ! for time derivs - allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) - + allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) + gridinit = .true. !exact_rendering = exact end subroutine init_etgrid - + subroutine print_etgrid() - ! Subroutine for printing quantities of the ET grid + ! Subroutine for printing quantities of the ET grid print*, "Grid spacing (x,y,z) is : ", dxgrid print*, "Grid origin (x,y,z) is: ", gridorigin @@ -87,18 +87,18 @@ end subroutine print_etgrid subroutine get_particle_rhs(i,vx,vy,vz,fx,fy,fz,e_rhs) use part, only: vxyzu,fxyzu,fext integer, intent(in) :: i - real, intent(out) :: vx,vy,vz,fx,fy,fz,e_rhs + real, intent(out) :: vx,vy,vz,fx,fy,fz,e_rhs !vxyz vx = vxyzu(1,i) - vy = vxyzu(2,i) + vy = vxyzu(2,i) vz = vxyzu(3,i) - - ! dp/dt + + ! dp/dt !print*, "fext: ", fext(:,i) !print*, "fxyzu: ", fxyzu(:,i) !fx = fxyzu(1,i) + fext(1,i) - !print*, "fx: ", fx + !print*, "fx: ", fx !fy = fxyzu(2,i) + fext(2,i) !fz = fxyzu(3,i) + fext(3,i) fx = fext(1,i) @@ -107,20 +107,20 @@ subroutine get_particle_rhs(i,vx,vy,vz,fx,fy,fz,e_rhs) ! de/dt - e_rhs = 0. + e_rhs = 0. end subroutine get_particle_rhs subroutine get_particle_val(i,x,y,z,px,py,pz,e) use part, only: xyzh, pxyzu integer, intent(in) :: i - real, intent(out) :: x,y,z,px,py,pz,e + real, intent(out) :: x,y,z,px,py,pz,e !xyz - x = xyzh(1,i) - y = xyzh(2,i) + x = xyzh(1,i) + y = xyzh(2,i) z = xyzh(3,i) - + ! p px = pxyzu(1,i) py = pxyzu(2,i) @@ -128,7 +128,7 @@ subroutine get_particle_val(i,x,y,z,px,py,pz,e) ! e ! ??? - e = pxyzu(4,i) + e = pxyzu(4,i) end subroutine get_particle_val @@ -136,19 +136,19 @@ subroutine set_particle_val(i,x,y,z,px,py,pz,e) use part, only: xyzh, pxyzu integer, intent(in) :: i real, intent(in) :: x,y,z,px,py,pz,e - ! Subroutine for setting the particle values in phantom - ! using the values stored in einstein toolkit before a dump - + ! Subroutine for setting the particle values in phantom + ! using the values stored in einstein toolkit before a dump + !xyz - xyzh(1,i) = x - xyzh(2,i) = y - xyzh(3,i) = z + xyzh(1,i) = x + xyzh(2,i) = y + xyzh(3,i) = z - ! p - pxyzu(1,i) = px - pxyzu(2,i) = py - pxyzu(3,i) = pz - pxyzu(4,i) = e + ! p + pxyzu(1,i) = px + pxyzu(2,i) = py + pxyzu(3,i) = pz + pxyzu(4,i) = e end subroutine set_particle_val @@ -157,13 +157,13 @@ subroutine get_phantom_dt(dtout) use part, only:xyzh real, intent(out) :: dtout real, parameter :: safety_fac = 0.2 - real :: minh + real :: minh ! Get the smallest smoothing length minh = minval(xyzh(4,:)) ! Courant esque condition from Rosswog 2021+ - ! Since c is allways one in our units + ! Since c is allways one in our units dtout = safety_fac*minh print*, "dtout phantom: ", dtout @@ -171,18 +171,18 @@ subroutine get_phantom_dt(dtout) end subroutine get_phantom_dt subroutine set_rendering(flag) - logical, intent(in) :: flag + logical, intent(in) :: flag exact_rendering = flag end subroutine set_rendering - - ! Do I move this to tmunu2grid?? - ! I think yes - - ! Moved to einsteintk_wrapper.f90 to fix dependency issues - + ! Do I move this to tmunu2grid?? + ! I think yes + + + ! Moved to einsteintk_wrapper.f90 to fix dependency issues + ! subroutine get_metricderivs_all(dtextforce_min) ! use part, only:npart, xyzh,vxyzu,metrics,metricderivs,dens,fext ! use timestep, only:bignumber,C_force @@ -197,15 +197,15 @@ end subroutine set_rendering ! !$omp parallel do default(none) & ! !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & - ! !$omp firstprivate(pri) & - ! !$omp private(i,dtf) & + ! !$omp firstprivate(pri) & + ! !$omp private(i,dtf) & ! !$omp reduction(min:dtextforce_min) - ! do i=1, npart + ! do i=1, npart ! call pack_metricderivs(xyzh(1:3,i),metricderivs(:,:,:,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) ! dtextforce_min = min(dtextforce_min,C_force*dtf) - ! enddo - ! !$omp end parallel do + ! enddo + ! !$omp end parallel do ! end subroutine get_metricderivs_all end module einsteintk_utils diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 8d36c7ba7..182a1fd82 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -18,13 +18,13 @@ module einsteintk_wrapper ! extern_gr, fileutils, initial, io, linklist, metric, metric_tools, ! mpiutils, part, readwrite_dumps, timestep, tmunu2grid ! - implicit none + implicit none contains subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) ! Wrapper that intialises phantom ! Intended to hide all of the inner works of phantom from ET - ! Majority of the code from HelloHydro_init has been moved here + ! Majority of the code from HelloHydro_init has been moved here use io, only:id,master,nprocs,set_io_unit_numbers,die use mpiutils, only:init_mpi,finalise_mpi @@ -33,13 +33,13 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) use tmunu2grid use einsteintk_utils use extern_gr - use metric + use metric use part, only:xyzh,pxyzu,vxyzu,dens,metricderivs, metrics, npart, tmunus - + implicit none character(len=*), intent(in) :: infilestart - real, intent(in) :: dt_et + real, intent(in) :: dt_et integer, intent(inout) :: nophantompart real, intent(out) :: dtout !character(len=500) :: logfile,evfile,dumpfile,path @@ -47,18 +47,18 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) integer :: xlower,ylower,zlower,xupper,yupper,zupper real :: pos(3), gcovpart(0:3,0:3) !real :: dtout - + ! For now we just hardcode the infile, to see if startrun actually works! - ! I'm not sure what the best way to actually do this is? + ! I'm not sure what the best way to actually do this is? ! Do we store the phantom.in file in par and have it read from there? !infile = "/Users/spencer/phantomET/phantom/test/flrw.in" !infile = trim(infile)//'.in' - !print*, "phantom_path: ", phantom_path - !infile = phantom_path // "flrw.in" + !print*, "phantom_path: ", phantom_path + !infile = phantom_path // "flrw.in" !infile = trim(path) // "flrw.in" !infile = 'flrw.in' !infile = trim(infile) - !print*, "Phantom path is: ", path + !print*, "Phantom path is: ", path !print*, "Infile is: ", infile ! Use system call to copy phantom files to simulation directory ! This is a digusting temporary fix @@ -66,13 +66,13 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) ! The infile from ET infilestor = infilestart - + ! We should do everything that is done in phantom.f90 - + ! Setup mpi id=0 call init_mpi(id,nprocs) - ! setup io + ! setup io call set_io_unit_numbers ! routine that starts a phantom run print*, "Start run called!" @@ -80,54 +80,54 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) call startrun(infilestor,logfilestor,evfilestor,dumpfilestor) print*, "Start run finished!" !print*, "tmunugrid: ", tmunugrid(1,1,6,6,6) - !stop + !stop ! Intialises values for the evol routine: t, dt, etc.. !call evol_init(infilestor,logfilestor,evfilestor,dumpfilestor,dt_et,nophantompart) !print*, "Evolve init finished!" nophantompart = npart ! Calculate the stress energy tensor for each particle - ! Might be better to do this in evolve init + ! Might be better to do this in evolve init !call get_tmunugrid_all ! Calculate the stress energy tensor call get_metricderivs_all(dtout,dt_et) ! commented out to try and fix prim2cons !call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) ! commented out to try and fix prim2cons !call get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - ! Interpolate stress energy tensor from particles back + ! Interpolate stress energy tensor from particles back ! to grid !call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac=.true.) ! commented out to try and fix cons2prim call get_phantom_dt(dtout) - + print*,"pxyzu: ", pxyzu(:,1) - + end subroutine init_et2phantom subroutine init_et2phantomgrid(nx,ny,nz,originx,originy,originz,dx,dy,dz) use einsteintk_utils integer, intent(in) :: nx,ny,nz ! The maximum values of the grid in each dimension - real(8), intent(in) :: originx, originy, originz ! The origin of grid + real(8), intent(in) :: originx, originy, originz ! The origin of grid real(8), intent(in) :: dx, dy, dz ! Grid spacing in each dimension !integer, intent(in) :: boundsizex, boundsizey, boundsizez - ! Setup metric grid + ! Setup metric grid call init_etgrid(nx,ny,nz,originx,originy,originz,dx,dy,dz) end subroutine init_et2phantomgrid subroutine init_phantom2et() - ! Subroutine + ! Subroutine end subroutine init_phantom2et subroutine et2phantom(rho,nx,ny,nz) integer, intent(in) :: nx, ny, nz real, intent(in) :: rho(nx,ny,nz) - + print*, "Grid limits: ", nx, ny, nz ! get mpi thread number - ! send grid limits + ! send grid limits end subroutine et2phantom - ! DONT THINK THIS IS USED ANYWHERE!!! + ! DONT THINK THIS IS USED ANYWHERE!!! ! subroutine step_et2phantom(infile,dt_et) ! use einsteintk_utils ! use evolve, only:evol_step @@ -135,29 +135,29 @@ end subroutine et2phantom ! character(len=*), intent(in) :: infile ! real, intent(inout) :: dt_et ! character(len=500) :: logfile,evfile,dumpfile,path - - + + ! ! Print the values of logfile, evfile, dumpfile to check they are sensible ! !print*, "logfile, evfile, dumpfile: ", logfile, evfile, dumpfile ! print*, "stored values of logfile, evfile, dumpfile: ", logfilestor, evfilestor, dumpfilestor - - ! ! Interpolation stuff + + ! ! Interpolation stuff ! ! Call et2phantom (construct global grid, metric, metric derivs, determinant) - ! ! Run phantom for a step + ! ! Run phantom for a step ! call evol_step(infile,logfilestor,evfilestor,dumpfilestor,dt_et) ! ! Interpolation stuff back to et ! !call get_tmunugrid_all() ! ! call phantom2et (Tmunu_grid) - + ! end subroutine step_et2phantom - + subroutine phantom2et() ! should take in the cctk_array for tmunu?? - ! Is it better if this routine is just - ! Calculate stress energy tensor for each particle + ! Is it better if this routine is just + ! Calculate stress energy tensor for each particle + + ! Perform kernel interpolation from particles to grid positions - ! Perform kernel interpolation from particles to grid positions - end subroutine phantom2et subroutine step_et2phantom_MoL(infile,dt_et,dtout) @@ -176,8 +176,8 @@ subroutine step_et2phantom_MoL(infile,dt_et,dtout) ! and interpolated ! Call get_derivs global call get_derivs_global - - ! Get metric derivs + + ! Get metric derivs call get_metricderivs_all(dtout,dt_et) ! Store our particle quantities somewhere / send them to ET ! Cons2prim after moving the particles with the external force @@ -188,10 +188,10 @@ subroutine step_et2phantom_MoL(infile,dt_et,dtout) ! Does get_derivs_global perform a stress energy calc?? ! If not do that here - ! Perform the calculation of the stress energy tensor + ! Perform the calculation of the stress energy tensor ! Interpolate the stress energy tensor back to the ET grid! ! Calculate the stress energy tensor - ! Interpolate stress energy tensor from particles back + ! Interpolate stress energy tensor from particles back ! to grid call get_phantom_dt(dtout) @@ -216,7 +216,7 @@ subroutine et2phantom_tmunu() real :: stressmax real(kind=16) :: cfac - stressmax = 0. + stressmax = 0. ! Also probably need to pack the metric before I call things call init_metric(npart,xyzh,metrics) @@ -227,22 +227,22 @@ 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) - ! Get primative variables for tmunu + stressmax,fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) + ! Get primative variables for tmunu call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - ! Interpolate stress energy tensor from particles back + ! Interpolate stress energy tensor from particles back ! to grid call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) - + ! Interpolate density to grid call phantom2et_rhostar ! Density check vs particles call check_conserved_dens(rhostargrid,cfac) - ! Correct Tmunu + ! Correct Tmunu tmunugrid = cfac*tmunugrid @@ -264,7 +264,7 @@ subroutine phantom2et_consvar() ! Init metric call init_metric(npart,xyzh,metrics) - + ! Might be better to just do this in get derivs global with a number 2 call? ! Rebuild the tree call set_linklist(npart,npart,xyzh,vxyzu) @@ -272,15 +272,15 @@ 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) + ! Interpolate density to grid call phantom2et_rhostar - + ! Interpolate momentum to grid call phantom2et_momentum - ! Interpolate entropy to grid + ! Interpolate entropy to grid call phantom2et_entropy @@ -291,7 +291,7 @@ subroutine phantom2et_consvar() ! Momentum check vs particles - ! Correct momentum and Density + ! Correct momentum and Density rhostargrid = cfac*rhostargrid pxgrid = cfac*pxgrid entropygrid = cfac*entropygrid @@ -309,35 +309,35 @@ subroutine phantom2et_rhostar() use einsteintk_utils, only: get_phantom_dt,rhostargrid use metric_tools, only:init_metric real :: dat(npart), h, pmass,rho - integer :: i + integer :: i - ! Get new cons density from new particle positions somehow (maybe)? + ! Get new cons density from new particle positions somehow (maybe)? ! Set linklist to update the tree for neighbour finding ! Calculate the density for the new particle positions - ! Call density iterate + ! Call density iterate ! Interpolate from particles to grid ! This can all go into its own function as it will essentially - ! be the same thing for all quantites - ! get particle data - ! get rho from xyzh and rhoh - ! Get the conserved density on the particles + ! be the same thing for all quantites + ! get particle data + ! get rho from xyzh and rhoh + ! Get the conserved density on the particles dat = 0. pmass = massoftype(igas) ! $omp parallel do default(none) & ! $omp shared(npart,xyzh,dat,pmass) & - ! $omp private(i,h,rho) + ! $omp private(i,h,rho) do i=1, npart - ! Get the smoothing length + ! Get the smoothing length h = xyzh(4,i) ! Get pmass - + rho = rhoh(h,pmass) dat(i) = rho - enddo - ! $omp end parallel do - rhostargrid = 0. + enddo + ! $omp end parallel do + rhostargrid = 0. call interpolate_to_grid(rhostargrid,dat) end subroutine phantom2et_rhostar @@ -352,30 +352,30 @@ subroutine phantom2et_entropy() use einsteintk_utils, only: get_phantom_dt,entropygrid use metric_tools, only:init_metric real :: dat(npart), h, pmass,rho - integer :: i + integer :: i - ! Get new cons density from new particle positions somehow (maybe)? + ! Get new cons density from new particle positions somehow (maybe)? ! Set linklist to update the tree for neighbour finding ! Calculate the density for the new particle positions - ! Call density iterate + ! Call density iterate ! Interpolate from particles to grid ! This can all go into its own function as it will essentially - ! be the same thing for all quantites - ! get particle data - ! get rho from xyzh and rhoh - ! Get the conserved density on the particles - dat = 0. + ! be the same thing for all quantites + ! get particle data + ! get rho from xyzh and rhoh + ! Get the conserved density on the particles + dat = 0. !$omp parallel do default(none) & !$omp shared(npart,pxyzu,dat) & !$omp private(i) do i=1, npart - ! Entropy is the u component of pxyzu + ! Entropy is the u component of pxyzu dat(i) = pxyzu(4,i) - enddo - !$omp end parallel do - entropygrid = 0. + enddo + !$omp end parallel do + entropygrid = 0. call interpolate_to_grid(entropygrid,dat) end subroutine phantom2et_entropy @@ -390,40 +390,40 @@ subroutine phantom2et_momentum() use einsteintk_utils, only: get_phantom_dt,gcovgrid,pxgrid use metric_tools, only:init_metric real :: dat(3,npart) - integer :: i + integer :: i - ! Pi is directly updated at the end of each MoL add + ! Pi is directly updated at the end of each MoL add - ! Interpolate from particles to grid + ! Interpolate from particles to grid ! get particle data for the x component of momentum dat = 0. !$omp parallel do default(none) & !$omp shared(npart,pxyzu,dat) & - !$omp private(i) + !$omp private(i) do i=1, npart dat(1,i) = pxyzu(1,i) dat(2,i) = pxyzu(2,i) dat(3,i) = pxyzu(3,i) - enddo - !$omp end parallel do - pxgrid = 0. - ! call interpolate 3d + enddo + !$omp end parallel do + pxgrid = 0. + ! call interpolate 3d ! In this case call it 3 times one for each vector component ! px component call interpolate_to_grid(pxgrid(1,:,:,:), dat(1,:)) ! py component call interpolate_to_grid(pxgrid(2,:,:,:), dat(2,:)) - ! pz component + ! pz component call interpolate_to_grid(pxgrid(3,:,:,:),dat(3,:)) - - + + end subroutine phantom2et_momentum - ! Subroutine for performing a phantom dump from einstein toolkit + ! Subroutine for performing a phantom dump from einstein toolkit subroutine et2phantom_dumphydro(time,dt_et) use cons2prim, only:cons2primall use part, only:npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars @@ -433,10 +433,10 @@ subroutine et2phantom_dumphydro(time,dt_et) use fileutils, only:getnextfilename real, intent(in) :: time, dt_et !character(len=20) :: logfile,evfile,dumpfile - + ! Call cons2prim since values are updated with MoL - !call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) - ! Write EV_file + !call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + ! Write EV_file call write_evfile(time,dt_et) evfilestor = getnextfilename(evfilestor) @@ -451,7 +451,7 @@ subroutine et2phantom_dumphydro(time,dt_et) end subroutine et2phantom_dumphydro - ! Provides the RHS derivs for a particle at index i + ! Provides the RHS derivs for a particle at index i subroutine phantom2et_rhs(index, vx,vy,vz,fx,fy,fz,e_rhs) use einsteintk_utils real, intent(inout) :: vx,vy,vz,fx,fy,fz, e_rhs @@ -478,8 +478,8 @@ subroutine et2phantom_setparticlevars(index,x,y,z,px,py,pz,e) call set_particle_val(index,x,y,z,px,py,pz,e) end subroutine et2phantom_setparticlevars - - ! I really HATE this routine being here but it needs to be to fix dependency issues. + + ! I really HATE this routine being here but it needs to be to fix dependency issues. subroutine get_metricderivs_all(dtextforce_min,dt_et) use einsteintk_utils, only: metricderivsgrid use part, only:npart, xyzh,vxyzu,fxyzu,metrics,metricderivs,dens,fext @@ -493,24 +493,24 @@ subroutine get_metricderivs_all(dtextforce_min,dt_et) pri = 0. dtextforce_min = bignumber - + !$omp parallel do default(none) & !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & - !$omp firstprivate(pri) & - !$omp private(i,dtf) & + !$omp firstprivate(pri) & + !$omp private(i,dtf) & !$omp reduction(min:dtextforce_min) - do i=1, npart + do i=1, npart call pack_metricderivs(xyzh(1:3,i),metricderivs(:,:,:,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) dtextforce_min = min(dtextforce_min,C_force*dtf) - enddo - !$omp end parallel do + enddo + !$omp end parallel do ! manually add v contribution from gr ! do i=1, npart ! !fxyzu(:,i) = fxyzu(:,i) + fext(:,i) ! vxyzu(1:3,i) = vxyzu(1:3,i) + fext(:,i)*dt_et - ! enddo + ! enddo end subroutine get_metricderivs_all subroutine get_eos_quantities(densi,en) @@ -528,4 +528,4 @@ subroutine get_eos_quantities(densi,en) end subroutine get_eos_quantities -end module einsteintk_wrapper +end module einsteintk_wrapper diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index 190e5ef1c..228ed64b5 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -26,14 +26,14 @@ module interpolations3D use einsteintk_utils, only:exact_rendering use kernel, only:radkern2,radkern,cnormk,wkern!,wallint ! Moved to this module - !use interpolation, only:iroll ! Moved to this module + !use interpolation, only:iroll ! Moved to this module - !use timing, only:wall_time,print_time ! Using cpu_time for now + !use timing, only:wall_time,print_time ! Using cpu_time for now implicit none integer, parameter :: doub_prec = kind(0.d0) real :: cnormk3D = cnormk - public :: interpolate3D!,interpolate3D_vec not needed - + public :: interpolate3D!,interpolate3D_vec not needed + contains !-------------------------------------------------------------------------- ! subroutine to interpolate from particle data to even grid of pixels @@ -64,22 +64,22 @@ module interpolations3D ! Revised for "splash to grid", Monash University 02/11/09 ! Maya Petkova contributed exact subgrid interpolation, April 2019 !-------------------------------------------------------------------------- - + subroutine interpolate3D(xyzh,weight,dat,itype,npart,& xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& normalise,periodicx,periodicy,periodicz) - + integer, intent(in) :: npart,npixx,npixy,npixz real, intent(in) :: xyzh(4,npart) !real, intent(in), dimension(npart) :: x,y,z,hh ! change to xyzh() - real, intent(in), dimension(npart) :: weight,dat + real, intent(in), dimension(npart) :: weight,dat integer, intent(in), dimension(npart) :: itype real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz real(doub_prec), intent(out), dimension(npixx,npixy,npixz) :: datsmooth logical, intent(in) :: normalise,periodicx,periodicy,periodicz !logical, intent(in), exact_rendering real(doub_prec), allocatable :: datnorm(:,:,:) - + integer :: i,ipix,jpix,kpix integer :: iprintinterval,iprintnext integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax @@ -92,17 +92,17 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& logical :: iprintprogress real, dimension(npart) :: x,y,z,hh real :: radkernel, radkernel2, radkernh - + ! Exact rendering real :: pixint, wint !logical, parameter :: exact_rendering = .true. ! use exact rendering y/n integer :: usedpart, negflag - + !$ integer :: omp_get_num_threads,omp_get_thread_num integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits - - ! Fill the particle data with xyzh + + ! Fill the particle data with xyzh x(:) = xyzh(1,:) y(:) = xyzh(2,:) z(:) = xyzh(3,:) @@ -132,9 +132,9 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& if (any(hh(1:npart) <= tiny(hh))) then print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' endif - + !call wall_time(t_start) - + datsmooth = 0. if (normalise) then allocate(datnorm(npixx,npixy,npixz)) @@ -155,9 +155,9 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !--get starting CPU time ! call cpu_time(t_start) - + usedpart = 0 - + xminpix = xmin !- 0.5*pixwidthx yminpix = ymin !- 0.5*pixwidthy zminpix = zmin !- 0.5*pixwidthz @@ -173,7 +173,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& ! hmin = 0.5*pixwidthmax !dhmin3 = 1./(hmin*hmin*hmin) - + const = cnormk3D ! normalisation constant (3D) print*, "const: ", const nwarn = 0 @@ -201,7 +201,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !$omp master !$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' !$omp end master - + !$omp do schedule (guided, 2) over_parts: do i=1,npart ! @@ -221,7 +221,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !--skip particles with itype < 0 ! if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts - + hi = hh(i) if (hi <= 0.) then cycle over_parts @@ -235,14 +235,14 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& else termnorm = const*weight(i) endif - + ! !--set kernel related quantities ! xi = x(i) yi = y(i) zi = z(i) - + hi1 = 1./hi hi21 = hi1*hi1 radkernh = radkernel*hi ! radius of the smoothing kernel @@ -259,7 +259,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& ipixmax = int((xi + radkernh - xmin)/pixwidthx) + 1 jpixmax = int((yi + radkernh - ymin)/pixwidthy) + 1 kpixmax = int((zi + radkernh - zmin)/pixwidthz) + 1 - + if (.not.periodicx) then if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image @@ -272,9 +272,9 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& if (kpixmin < 1) kpixmin = 1 if (kpixmax > npixz) kpixmax = npixz endif - + negflag = 0 - + ! !--precalculate an array of dx2 for this particle (optimisation) ! @@ -292,7 +292,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& dx2i(nxpix) = ((xpixi - xi)**2)*hi21 endif enddo - + !--if particle contributes to more than npixx pixels ! (i.e. periodic boundaries wrap more than once) ! truncate the contribution and give warning @@ -306,63 +306,63 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& do kpix = kpixmin,kpixmax kpixi = kpix if (periodicz) kpixi = iroll(kpix,npixz) - + zpix = zminpix + kpix*pixwidthz dz = zpix - zi dz2 = dz*dz*hi21 - + do jpix = jpixmin,jpixmax jpixi = jpix if (periodicy) jpixi = iroll(jpix,npixy) - + ypix = yminpix + jpix*pixwidthy dy = ypix - yi dyz2 = dy*dy*hi21 + dz2 - + nxpix = 0 do ipix = ipixmin,ipixmax if ((kpix==kpixmin).and.(jpix==jpixmin).and.(ipix==ipixmin)) then usedpart = usedpart + 1 endif - + nxpix = nxpix + 1 ipixi = ipix if (periodicx) ipixi = iroll(ipix,npixx) - + q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 - + if (exact_rendering .and. ipixmax-ipixmin <= 4) then if (q2 < radkernel2 + 3.*pixwidthmax**2*hi21) then xpixi = xminpix + ipix*pixwidthx - + ! Contribution of the cell walls in the xy-plane pixint = 0.0 wint = wallint(zpix-zi+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) pixint = pixint + wint - + wint = wallint(zi-zpix+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) pixint = pixint + wint - + ! Contribution of the cell walls in the xz-plane wint = wallint(ypix-yi+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) pixint = pixint + wint - + wint = wallint(yi-ypix+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) pixint = pixint + wint - + ! Contribution of the cell walls in the yz-plane wint = wallint(xpixi-xi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) pixint = pixint + wint - + wint = wallint(xi-xpixi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) pixint = pixint + wint - + wab = pixint*dfac ! /(pixwidthx*pixwidthy*pixwidthz*const)*hi**3 - + if (pixint < -0.01d0) then print*, "Error: (",ipixi,jpixi,kpixi,") -> ", pixint, term*wab endif - + ! !--calculate data value at this pixel using the summation interpolant ! @@ -375,7 +375,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& endif else if (q2 < radkernel2) then - + ! !--SPH kernel - standard cubic spline ! @@ -397,7 +397,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& enddo over_parts !$omp enddo !$omp end parallel - + if (nwarn > 0) then print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& ' that wrap periodic boundaries more than once' @@ -411,13 +411,13 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& end where endif if (allocated(datnorm)) deallocate(datnorm) - + !call wall_time(t_end) call cpu_time(t_end) t_used = t_end - t_start print*, 'completed in ',t_end-t_start,'s' !if (t_used > 10.) call print_time(t_used) - + !print*, 'Number of particles in the volume: ', usedpart ! datsmooth(1,1,1) = 3.14159 ! datsmooth(32,32,32) = 3.145159 @@ -425,11 +425,11 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& ! datsmooth(10,10,10) = 3.145159 end subroutine interpolate3D - + ! subroutine interpolate3D_vec(x,y,z,hh,weight,datvec,itype,npart,& ! xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& ! normalise,periodicx,periodicy,periodicz) - + ! integer, intent(in) :: npart,npixx,npixy,npixz ! real, intent(in), dimension(npart) :: x,y,z,hh,weight ! real, intent(in), dimension(npart,3) :: datvec @@ -438,7 +438,7 @@ end subroutine interpolate3D ! real(doub_prec), intent(out), dimension(3,npixx,npixy,npixz) :: datsmooth ! logical, intent(in) :: normalise,periodicx,periodicy,periodicz ! real(doub_prec), dimension(npixx,npixy,npixz) :: datnorm - + ! integer :: i,ipix,jpix,kpix ! integer :: iprintinterval,iprintnext ! integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax @@ -452,7 +452,7 @@ end subroutine interpolate3D ! logical :: iprintprogress ! !$ integer :: omp_get_num_threads ! integer(kind=selected_int_kind(10)) :: iprogress ! up to 10 digits - + ! datsmooth = 0. ! datnorm = 0. ! if (normalise) then @@ -467,7 +467,7 @@ end subroutine interpolate3D ! if (any(hh(1:npart) <= tiny(hh))) then ! print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' ! endif - + ! ! ! !--print a progress report if it is going to take a long time ! ! (a "long time" is, however, somewhat system dependent) @@ -484,14 +484,14 @@ end subroutine interpolate3D ! !--get starting CPU time ! ! ! !call cpu_time(t_start) - + ! xminpix = xmin - 0.5*pixwidthx ! yminpix = ymin - 0.5*pixwidthy ! zminpix = zmin - 0.5*pixwidthz - + ! const = cnormk3D ! normalisation constant (3D) ! nwarn = 0 - + ! !$omp parallel default(none) & ! !$omp shared(hh,z,x,y,weight,datvec,itype,datsmooth,npart) & ! !$omp shared(xmin,ymin,zmin,radkernel,radkernel2) & @@ -528,17 +528,17 @@ end subroutine interpolate3D ! !--skip particles with itype < 0 ! ! ! if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts - + ! hi = hh(i) ! if (hi <= 0.) cycle over_parts - + ! ! ! !--set kernel related quantities ! ! ! xi = x(i) ! yi = y(i) ! zi = z(i) - + ! hi1 = 1./hi ! hi21 = hi1*hi1 ! radkern = radkernel*hi ! radius of the smoothing kernel @@ -553,7 +553,7 @@ end subroutine interpolate3D ! ipixmax = int((xi + radkern - xmin)/pixwidthx) + 1 ! jpixmax = int((yi + radkern - ymin)/pixwidthy) + 1 ! kpixmax = int((zi + radkern - zmin)/pixwidthz) + 1 - + ! if (.not.periodicx) then ! if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute ! if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image @@ -580,7 +580,7 @@ end subroutine interpolate3D ! dx2i(nxpix) = ((xpixi - xi)**2)*hi21 ! endif ! enddo - + ! !--if particle contributes to more than npixx pixels ! ! (i.e. periodic boundaries wrap more than once) ! ! truncate the contribution and give warning @@ -597,14 +597,14 @@ end subroutine interpolate3D ! zpix = zminpix + kpix*pixwidthz ! dz = zpix - zi ! dz2 = dz*dz*hi21 - + ! do jpix = jpixmin,jpixmax ! jpixi = jpix ! if (periodicy) jpixi = iroll(jpix,npixy) ! ypix = yminpix + jpix*pixwidthy ! dy = ypix - yi ! dyz2 = dy*dy*hi21 + dz2 - + ! nxpix = 0 ! do ipix = ipixmin,ipixmax ! ipixi = ipix @@ -636,7 +636,7 @@ end subroutine interpolate3D ! enddo over_parts ! !$omp enddo ! !$omp end parallel - + ! if (nwarn > 0) then ! print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& ! ' that wrap periodic boundaries more than once' @@ -662,21 +662,21 @@ end subroutine interpolate3D ! enddo ! !$omp end parallel do ! endif - + ! return - + ! end subroutine interpolate3D_vec - + !------------------------------------------------------------ ! interface to kernel routine to avoid problems with openMP !----------------------------------------------------------- real function wkernel(q2) use kernel, only:wkern real, intent(in) :: q2 - real :: q + real :: q q = sqrt(q2) wkernel = wkern(q2,q) - + end function wkernel !------------------------------------------------------------ diff --git a/src/utils/interpolate3Dold.F90 b/src/utils/interpolate3Dold.F90 index b202f69cb..32766e956 100644 --- a/src/utils/interpolate3Dold.F90 +++ b/src/utils/interpolate3Dold.F90 @@ -61,7 +61,7 @@ subroutine interpolate3D(xyzh,weight,npart, & integer, intent(in) :: npart,nnodes,ngrid(3) real, intent(in) :: xyzh(:,:)! ,vxyzu(:,:) real, intent(in) :: weight !,pmass - real, intent(in) :: xmin(3),dxgrid(3) + real, intent(in) :: xmin(3),dxgrid(3) real, intent(out) :: datsmooth(:,:,:) logical, intent(in) :: normalise, vertexcen real, intent(in), optional :: dat(:) @@ -136,12 +136,12 @@ subroutine interpolate3D(xyzh,weight,npart, & npixy = ngrid(2) npixz = ngrid(3) print "(3(a,i4))",' root grid: ',npixx,' x ',npixy,' x ',npixz - print*, "position of i cell is: ", 1*dxcell(1) + xmin(1) + print*, "position of i cell is: ", 1*dxcell(1) + xmin(1) print*, "npart: ", npart const = cnormk ! kernel normalisation constant (3D) - print*,"const: ", const - !stop + print*,"const: ", const + !stop ! !--loop over particles @@ -207,12 +207,12 @@ subroutine interpolate3D(xyzh,weight,npart, & jpixmax = int((yi + radkernh - xmin(2))/dxcell(2)) + 1 kpixmax = nint((zi + radkernh - xmin(3))/dxcell(3)) + 1 - !if (ipixmax == 33) stop - - + !if (ipixmax == 33) stop + + !if (ipixmin == 4 .and. jpixmin == 30 .and. kpixmin == 33) print*, "particle (min): ", i !if (ipixmax == 4 .and. jpixmax == 30 .and. kpixmax == 33) print*, "particle (max): ", i -#ifndef PERIODIC +#ifndef PERIODIC if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute if (jpixmin < 1) jpixmin = 1 ! to pixels in the image if (kpixmin < 1) kpixmin = 1 @@ -225,7 +225,7 @@ subroutine interpolate3D(xyzh,weight,npart, & !print*, "jpixmax: ", jpixmax !print*, "kpixmin: ", kpixmin !print*, "kpixmax: ", kpixmax -#endif +#endif !print*,' part ',i,' lims = ',ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax ! !--loop over pixels, adding the contribution from this particle @@ -244,18 +244,18 @@ subroutine interpolate3D(xyzh,weight,npart, & else zi = zorigi endif -#endif - if (vertexcen) then +#endif + if (vertexcen) then zpix = xmin(3) + (kpixi-1)*dxcell(3) - else + else zpix = xmin(3) + (kpixi-0.5)*dxcell(3) - endif + endif dz = zpix - zi dz2 = dz*dz*hi21 do jpix = jpixmin,jpixmax jpixi = jpix -#ifdef PERIODIC +#ifdef PERIODIC if (jpixi < 1) then jpixi = jpixi + npixy yi = yorigi !+ dxmax(2) @@ -266,26 +266,26 @@ subroutine interpolate3D(xyzh,weight,npart, & yi = yorigi endif #endif - if (vertexcen) then + if (vertexcen) then ypix = xmin(2) + (jpixi-1)*dxcell(2) else ypix = xmin(2) + (jpixi-0.5)*dxcell(2) - endif + endif dy = ypix - yi dyz2 = dy*dy*hi21 + dz2 do ipix = ipixmin,ipixmax ipixi = ipix -#ifdef PERIODIC +#ifdef PERIODIC if (ipixi < 1) then ipixi = ipixi + npixx xi = xorigi !+ dxmax(1) elseif (ipixi > npixx) then - if (ipixi == 33) then - print*,"xi old: ", xorigi - print*, "xi new: ", xorigi-dxmax(1) - print*, "ipixi new: ", ipixi - npixx - endif + if (ipixi == 33) then + print*,"xi old: ", xorigi + print*, "xi new: ", xorigi-dxmax(1) + print*, "ipixi new: ", ipixi - npixx + endif ipixi = ipixi - npixx xi = xorigi !- dxmax(1) else @@ -297,11 +297,11 @@ subroutine interpolate3D(xyzh,weight,npart, & !--particle interpolates directly onto the root grid ! !print*,'onto root grid ',ipixi,jpixi,kpixi - if (vertexcen) then + if (vertexcen) then xpix = xmin(1) + (ipixi-1)*dxcell(1) - else + else xpix = xmin(1) + (ipixi-0.5)*dxcell(1) - endif + endif !print*, "xpix: ", xpix !xpix = xmin(1) + (ipixi-1)*dxcell(1) ! Since we are vertex centered from Et dx = xpix - xi @@ -317,21 +317,21 @@ subroutine interpolate3D(xyzh,weight,npart, & ! qq = sqrt(q2) ! wab = 0.25*(2.-qq)**3 ! endif - ! Call the kernel routine + ! Call the kernel routine qq = sqrt(q2) wab = wkern(q2,qq) ! !--calculate data value at this pixel using the summation interpolant ! ! Change this to the access the pixel coords x,y,z - !$omp critical + !$omp critical datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab - + !if (ipixi==1 .and. jpixi==1 .and. kpixi==1) print*, "x position of 1,1,1", xi,yi,zi if (normalise) then datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab endif - !$omp end critical + !$omp end critical endif enddo enddo From 7f4c06cbdbc942a813ea45271f8903aa17537db4 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 2 May 2023 12:13:08 +1000 Subject: [PATCH 044/814] [author-bot] updated AUTHORS file --- AUTHORS | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/AUTHORS b/AUTHORS index 74a472715..6bf5acff1 100644 --- a/AUTHORS +++ b/AUTHORS @@ -26,49 +26,50 @@ Terrence Tricco Mats Esseldeurs Simone Ceppi MatsEsseldeurs -Caitlyn Hardiman Enrico Ragusa +Caitlyn Hardiman Sergei Biriukov Giovanni Dipierro -Cristiano Longarini Roberto Iaconi +Cristiano Longarini fhu Hauke Worpel -Simone Ceppi Alison Young +Simone Ceppi Stephane Michoulier +Spencer Magnall Amena Faruqi Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi Sahl Rowther -Thomas Reichardt Simon Glover +Thomas Reichardt Jean-François Gonzalez Christopher Russell Alessia Franchini +Alex Pettitt Jolien Malfait Phantom benchmark bot -Alex Pettitt Nicole Rodrigues Kieran Hirsh -Amena Faruqi David Trevascus +Amena Faruqi +Nicolas Cuello Megha Sharma Chris Nixon -Nicolas Cuello Orsola De Marco +s-neilson <36410751+s-neilson@users.noreply.github.com> Megha Sharma Maxime Lombart Joe Fisher Giulia Ballabio Benoit Commercon Zachary Pellow -s-neilson <36410751+s-neilson@users.noreply.github.com> +Steven Rieder mats esseldeurs Cox, Samuel Jorge Cuadra Alison Young -Steven Rieder Stéven Toupin Terrence Tricco From 615c116433bb2817547a1d5e39cfe704fcfe852a Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 2 May 2023 12:13:20 +1000 Subject: [PATCH 045/814] [format-bot] end if -> endif; end do -> enddo; if( -> if ( --- src/main/metric_et.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index 74f0abe6e..202164d3b 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -56,7 +56,7 @@ pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) gcon(3,3) = 1. endif if (present(sqrtg)) sqrtg = -1. - else if (present(gcon) .and. present(sqrtg)) then + elseif (present(gcon) .and. present(sqrtg)) then call interpolate_metric(position,gcov,gcon,sqrtg) else call interpolate_metric(position,gcov) From a041762aafcf2316f8601be0e94c69bf03a228ca Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 2 May 2023 12:13:32 +1000 Subject: [PATCH 046/814] [indent-bot] standardised indentation --- src/main/extern_gr.F90 | 436 +++--- src/main/interp_metric.F90 | 58 +- src/main/metric_et.f90 | 480 +++---- src/main/metric_flrw.f90 | 20 +- src/main/step_leapfrog.F90 | 2 +- src/main/tmunu2grid.f90 | 720 +++++----- src/main/utils_gr.F90 | 180 +-- src/setup/set_star.f90 | 28 +- src/setup/setup_flrw.f90 | 212 +-- src/setup/setup_flrwpspec.f90 | 176 +-- src/setup/stretchmap.f90 | 6 +- src/utils/analysis_BRhoOrientation.F90 | 10 +- src/utils/einsteintk_utils.f90 | 304 ++--- src/utils/einsteintk_wrapper.f90 | 956 ++++++------- src/utils/interpolate3D.F90 | 1710 ++++++++++++------------ src/utils/interpolate3Dold.F90 | 96 +- 16 files changed, 2697 insertions(+), 2697 deletions(-) diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 87f2d8ba4..932630acd 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -224,239 +224,239 @@ subroutine update_grforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi, end subroutine update_grforce_leapfrog subroutine get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - use eos, only:ieos,get_pressure - use part, only:isdead_or_accreted - integer, intent(in) :: npart - real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) - real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) - real :: pi - integer :: i - logical :: verbose - - verbose = .false. - ! TODO write openmp parallel code - !$omp parallel do default(none) & - !$omp shared(npart,xyzh,metrics,vxyzu,dens,ieos,tmunus) & - !$omp private(i,pi,verbose) - do i=1, npart - !print*, "i: ", i - if (i==1) then - verbose = .true. - else - verbose = .false. - endif - if (.not.isdead_or_accreted(xyzh(4,i))) then - pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) - call get_tmunu(xyzh(:,i),metrics(:,:,:,i),& + use eos, only:ieos,get_pressure + use part, only:isdead_or_accreted + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) + real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) + real :: pi + integer :: i + logical :: verbose + + verbose = .false. + ! TODO write openmp parallel code + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,metrics,vxyzu,dens,ieos,tmunus) & + !$omp private(i,pi,verbose) + do i=1, npart + !print*, "i: ", i + if (i==1) then + verbose = .true. + else + verbose = .false. + endif + if (.not.isdead_or_accreted(xyzh(4,i))) then + pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) + call get_tmunu(xyzh(:,i),metrics(:,:,:,i),& vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i),verbose) - endif - enddo - !$omp end parallel do - !print*, "tmunu calc val is: ", tmunus(0,0,5) + endif + enddo + !$omp end parallel do + !print*, "tmunu calc val is: ", tmunus(0,0,5) end subroutine get_tmunu_all subroutine get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - use eos, only:ieos,get_pressure - use part, only:isdead_or_accreted - integer, intent(in) :: npart - real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) - real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) - real :: pi - integer :: i - logical :: firstpart - real :: tmunu(4,4) - !print*, "entered get tmunu_all_exact" - tmunu = 0. - firstpart = .true. - ! TODO write openmp parallel code - do i=1, npart - if (.not.isdead_or_accreted(xyzh(4,i)) .and. firstpart) then - pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) - call get_tmunu_exact(xyzh(:,i),metrics(:,:,:,i), metricderivs(:,:,:,i), & + use eos, only:ieos,get_pressure + use part, only:isdead_or_accreted + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) + real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) + real :: pi + integer :: i + logical :: firstpart + real :: tmunu(4,4) + !print*, "entered get tmunu_all_exact" + tmunu = 0. + firstpart = .true. + ! TODO write openmp parallel code + do i=1, npart + if (.not.isdead_or_accreted(xyzh(4,i)) .and. firstpart) then + pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) + call get_tmunu_exact(xyzh(:,i),metrics(:,:,:,i), metricderivs(:,:,:,i), & vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i)) - !print*, "finished get_tmunu call!" - firstpart = .false. - !print*, "tmunu: ", tmunu - !print*, "tmunus: ", tmunus(:,:,i) - tmunu(:,:) = tmunus(:,:,i) - !print*, "Got tmunu val: ", tmunu - !stop - else - !print*, "setting tmunu for part: ", i - tmunus(:,:,i) = tmunu(:,:) - endif - - enddo - !print*, "tmunu calc val is: ", tmunus(0,0,5) + !print*, "finished get_tmunu call!" + firstpart = .false. + !print*, "tmunu: ", tmunu + !print*, "tmunus: ", tmunus(:,:,i) + tmunu(:,:) = tmunus(:,:,i) + !print*, "Got tmunu val: ", tmunu + !stop + else + !print*, "setting tmunu for part: ", i + tmunus(:,:,i) = tmunu(:,:) + endif + + enddo + !print*, "tmunu calc val is: ", tmunus(0,0,5) end subroutine get_tmunu_all_exact ! Subroutine to calculate the covariant form of the stress energy tensor ! For a particle at position p subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) - use metric_tools, only:unpack_metric - use utils_gr, only:get_u0 - real, intent(in) :: x(3),metrici(:,:,:),v(3),dens,u,p - real, intent(out) :: tmunu(0:3,0:3) - logical, optional, intent(in) :: verbose - real :: w,v4(0:3),vcov(3),lorentz,bigV(3),uzero,u_upper(0:3),u_lower(0:3) - real :: gcov(0:3,0:3), gcon(0:3,0:3) - real :: gammaijdown(1:3,1:3),betadown(3),alpha - real :: velshiftterm - integer :: i,j,ierr,mu,nu - - ! Reference for all the variables used in this routine: - ! w - the enthalpy - ! gcov - the covariant form of the metric tensor - ! gcon - the contravariant form of the metric tensor - ! gammaijdown - the covariant form of the spatial metric - ! alpha - the lapse - ! betadown - the covariant component of the shift - ! v4 - the uppercase 4 velocity in covariant form - ! v - the fluid velocity v^x - ! vcov - the covariant form of big V_i - ! bigV - the uppercase contravariant V^i - - ! Calculate the enthalpy - w = 1 + u + p/dens - - ! Get cov and con versions of the metric + spatial metric and lapse and shift - ! Not entirely convinced that the lapse and shift calculations are acccurate for the general case!! - !print*, "Before unpack metric " - call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) - !print*, "After unpack metric" - - if (present(verbose) .and. verbose) then - ! Do we get sensible values - print*, "Unpacked metric quantities..." - print*, "gcov: ", gcov - print*, "gcon: ", gcon - print*, "gammaijdown: ", gammaijdown - print* , "alpha: ", alpha - print*, "betadown: ", betadown - print*, "v4: ", v4 - endif - - ! ! Need to change Betadown to betaup - ! ! Won't matter at this point as it is allways zero - ! ! get big V - ! bigV(:) = (v(:) + betadown)/alpha - - ! ! We need the covariant version of the 3 velocity - ! ! gamma_ij v^j = v_i where gamma_ij is the spatial metric - ! do i=1, 3 - ! vcov(i) = gammaijdown(i,1)*bigv(1) + gammaijdown(i,2)*bigv(2) + gammaijdown(i,3)*bigv(3) - ! enddo - - - ! ! Calculate the lorentz factor - ! lorentz = (1. - (vcov(1)*bigv(1) + vcov(2)*bigv(2) + vcov(3)*bigv(3)))**(-0.5) - - ! ! Calculate the 4-velocity - ! velshiftterm = vcov(1)*betadown(1) + vcov(2)*betadown(2) + vcov(3)*betadown(3) - ! v4(0) = lorentz*(-alpha + velshiftterm) - ! ! This should be vcov not v - ! v4(1:3) = lorentz*vcov(1:3) - - - ! We are going to use the same Tmunu calc as force GR - ! And then lower it using the metric - ! i.e calc T^{\mu\nu} and then lower it using the metric - ! tensor - ! lower-case 4-velocity (contravariant) - v4(0) = 1. - v4(1:3) = v(:) - - - ! first component of the upper-case 4-velocity (contravariant) - call get_u0(gcov,v,uzero,ierr) - - u_upper = uzero*v4 - do mu=0,3 - u_lower(mu) = gcov(mu,0)*u_upper(0) + gcov(mu,1)*u_upper(1) & + use metric_tools, only:unpack_metric + use utils_gr, only:get_u0 + real, intent(in) :: x(3),metrici(:,:,:),v(3),dens,u,p + real, intent(out) :: tmunu(0:3,0:3) + logical, optional, intent(in) :: verbose + real :: w,v4(0:3),vcov(3),lorentz,bigV(3),uzero,u_upper(0:3),u_lower(0:3) + real :: gcov(0:3,0:3), gcon(0:3,0:3) + real :: gammaijdown(1:3,1:3),betadown(3),alpha + real :: velshiftterm + integer :: i,j,ierr,mu,nu + + ! Reference for all the variables used in this routine: + ! w - the enthalpy + ! gcov - the covariant form of the metric tensor + ! gcon - the contravariant form of the metric tensor + ! gammaijdown - the covariant form of the spatial metric + ! alpha - the lapse + ! betadown - the covariant component of the shift + ! v4 - the uppercase 4 velocity in covariant form + ! v - the fluid velocity v^x + ! vcov - the covariant form of big V_i + ! bigV - the uppercase contravariant V^i + + ! Calculate the enthalpy + w = 1 + u + p/dens + + ! Get cov and con versions of the metric + spatial metric and lapse and shift + ! Not entirely convinced that the lapse and shift calculations are acccurate for the general case!! + !print*, "Before unpack metric " + call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) + !print*, "After unpack metric" + + if (present(verbose) .and. verbose) then + ! Do we get sensible values + print*, "Unpacked metric quantities..." + print*, "gcov: ", gcov + print*, "gcon: ", gcon + print*, "gammaijdown: ", gammaijdown + print* , "alpha: ", alpha + print*, "betadown: ", betadown + print*, "v4: ", v4 + endif + + ! ! Need to change Betadown to betaup + ! ! Won't matter at this point as it is allways zero + ! ! get big V + ! bigV(:) = (v(:) + betadown)/alpha + + ! ! We need the covariant version of the 3 velocity + ! ! gamma_ij v^j = v_i where gamma_ij is the spatial metric + ! do i=1, 3 + ! vcov(i) = gammaijdown(i,1)*bigv(1) + gammaijdown(i,2)*bigv(2) + gammaijdown(i,3)*bigv(3) + ! enddo + + + ! ! Calculate the lorentz factor + ! lorentz = (1. - (vcov(1)*bigv(1) + vcov(2)*bigv(2) + vcov(3)*bigv(3)))**(-0.5) + + ! ! Calculate the 4-velocity + ! velshiftterm = vcov(1)*betadown(1) + vcov(2)*betadown(2) + vcov(3)*betadown(3) + ! v4(0) = lorentz*(-alpha + velshiftterm) + ! ! This should be vcov not v + ! v4(1:3) = lorentz*vcov(1:3) + + + ! We are going to use the same Tmunu calc as force GR + ! And then lower it using the metric + ! i.e calc T^{\mu\nu} and then lower it using the metric + ! tensor + ! lower-case 4-velocity (contravariant) + v4(0) = 1. + v4(1:3) = v(:) + + + ! first component of the upper-case 4-velocity (contravariant) + call get_u0(gcov,v,uzero,ierr) + + u_upper = uzero*v4 + do mu=0,3 + u_lower(mu) = gcov(mu,0)*u_upper(0) + gcov(mu,1)*u_upper(1) & + gcov(mu,2)*u_upper(2) + gcov(mu,3)*u_upper(3) - enddo - - ! Stress energy tensor in contravariant form - do nu=0,3 - do mu=0,3 - tmunu(mu,nu) = w*dens*u_lower(mu)*u_lower(nu) + p*gcov(mu,nu) - enddo - enddo - - - if (present(verbose) .and. verbose) then - ! Do we get sensible values - print*, "Unpacked metric quantities..." - print*, "gcov: ", gcov - print*, "gcon: ", gcon - print*, "gammaijdown: ", gammaijdown - print* , "alpha: ", alpha - print*, "betadown: ", betadown - print*, "v4: ", v4 - endif - - if (verbose) then - print*, "tmunu part: ", tmunu - print*, "dens: ", dens - print*, "w: ", w - print*, "p: ", p - print*, "gcov: ", gcov - endif - - ! print*, "tmunu part: ", tmunu - ! print*, "dens: ", dens - ! print*, "w: ", w - ! print*, "p: ", p - ! print*, "gcov: ", gcov - ! stop + enddo + + ! Stress energy tensor in contravariant form + do nu=0,3 + do mu=0,3 + tmunu(mu,nu) = w*dens*u_lower(mu)*u_lower(nu) + p*gcov(mu,nu) + enddo + enddo + + + if (present(verbose) .and. verbose) then + ! Do we get sensible values + print*, "Unpacked metric quantities..." + print*, "gcov: ", gcov + print*, "gcon: ", gcon + print*, "gammaijdown: ", gammaijdown + print* , "alpha: ", alpha + print*, "betadown: ", betadown + print*, "v4: ", v4 + endif + + if (verbose) then + print*, "tmunu part: ", tmunu + print*, "dens: ", dens + print*, "w: ", w + print*, "p: ", p + print*, "gcov: ", gcov + endif + + ! print*, "tmunu part: ", tmunu + ! print*, "dens: ", dens + ! print*, "w: ", w + ! print*, "p: ", p + ! print*, "gcov: ", gcov + ! stop end subroutine get_tmunu subroutine get_tmunu_exact(x,metrici,metricderivsi,v,dens,u,p,tmunu) - use metric_tools, only:unpack_metric - use utils_gr, only:get_sqrtg - real, intent(in) :: x(3),metrici(:,:,:),metricderivsi(0:3,0:3,3),v(3),dens,u,p - real, intent(out) :: tmunu(0:3,0:3) - real :: w,v4(0:3),vcov(3),lorentz - real :: gcov(0:3,0:3), gcon(0:3,0:3) - real :: gammaijdown(1:3,1:3),betadown(3),alpha - real :: velshiftterm - real :: rhostar,rhoprim,negsqrtg - integer :: i,j - - ! Calculate the enthalpy - ! enthalpy should be 1 as we have zero pressure - ! or should have zero pressure - w = 1 - ! Calculate the exact value of density from conserved density - - call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) - ! We need the covariant version of the 3 velocity - ! gamma_ij v^j = v_i where gamma_ij is the spatial metric - do i=1, 3 - vcov(i) = gammaijdown(i,1)*v(1) + gammaijdown(i,2)*v(2) + gammaijdown(i,3)*v(3) - enddo - - ! Calculate the lorentz factor - lorentz = (1. - (vcov(1)*v(1) + vcov(2)*v(2) + vcov(3)*v(3)))**(-0.5) - - ! Calculate the 4-velocity - velshiftterm = vcov(1)*betadown(1) + vcov(2)*betadown(2) + vcov(3)*betadown(3) - v4(0) = lorentz*(-alpha + velshiftterm) - v4(1:3) = lorentz*v(1:3) - - rhostar = 13.294563008157013D0 - call get_sqrtg(gcov,negsqrtg) - ! Set/Calculate primitive density using rhostar exactly - rhoprim = rhostar/(negsqrtg/alpha) - - - ! Stress energy tensor - do j=0,3 - do i=0,3 - tmunu(i,j) = rhoprim*w*v4(i)*v4(j) ! + p*gcov(i,j) neglect the pressure term as we don't care - enddo - enddo + use metric_tools, only:unpack_metric + use utils_gr, only:get_sqrtg + real, intent(in) :: x(3),metrici(:,:,:),metricderivsi(0:3,0:3,3),v(3),dens,u,p + real, intent(out) :: tmunu(0:3,0:3) + real :: w,v4(0:3),vcov(3),lorentz + real :: gcov(0:3,0:3), gcon(0:3,0:3) + real :: gammaijdown(1:3,1:3),betadown(3),alpha + real :: velshiftterm + real :: rhostar,rhoprim,negsqrtg + integer :: i,j + + ! Calculate the enthalpy + ! enthalpy should be 1 as we have zero pressure + ! or should have zero pressure + w = 1 + ! Calculate the exact value of density from conserved density + + call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) + ! We need the covariant version of the 3 velocity + ! gamma_ij v^j = v_i where gamma_ij is the spatial metric + do i=1, 3 + vcov(i) = gammaijdown(i,1)*v(1) + gammaijdown(i,2)*v(2) + gammaijdown(i,3)*v(3) + enddo + + ! Calculate the lorentz factor + lorentz = (1. - (vcov(1)*v(1) + vcov(2)*v(2) + vcov(3)*v(3)))**(-0.5) + + ! Calculate the 4-velocity + velshiftterm = vcov(1)*betadown(1) + vcov(2)*betadown(2) + vcov(3)*betadown(3) + v4(0) = lorentz*(-alpha + velshiftterm) + v4(1:3) = lorentz*v(1:3) + + rhostar = 13.294563008157013D0 + call get_sqrtg(gcov,negsqrtg) + ! Set/Calculate primitive density using rhostar exactly + rhoprim = rhostar/(negsqrtg/alpha) + + + ! Stress energy tensor + do j=0,3 + do i=0,3 + tmunu(i,j) = rhoprim*w*v4(i)*v4(j) ! + p*gcov(i,j) neglect the pressure term as we don't care + enddo + enddo diff --git a/src/main/interp_metric.F90 b/src/main/interp_metric.F90 index 6889ae8f2..fc4dd62bf 100644 --- a/src/main/interp_metric.F90 +++ b/src/main/interp_metric.F90 @@ -17,44 +17,44 @@ module metric_interp ! :Dependencies: einsteintk_utils ! - interface trilinear_interp - module procedure interp_g, interp_sqrtg, interp_gderiv - end interface trilinear_interp - contains + interface trilinear_interp + module procedure interp_g, interp_sqrtg, interp_gderiv + end interface trilinear_interp +contains - subroutine interp_g() - end subroutine interp_g +subroutine interp_g() +end subroutine interp_g - subroutine interp_sqrtg() +subroutine interp_sqrtg() - end subroutine interp_sqrtg +end subroutine interp_sqrtg - subroutine interp_gderiv() +subroutine interp_gderiv() - end subroutine interp_gderiv +end subroutine interp_gderiv - pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) - use einsteintk_utils, only:gridorigin - real, intent(in) :: position(3) - real, intent(in) :: dx(3) - integer, intent(out) :: xlower,ylower,zlower +pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) + use einsteintk_utils, only:gridorigin + real, intent(in) :: position(3) + real, intent(in) :: dx(3) + integer, intent(out) :: xlower,ylower,zlower - ! Get the lower grid neighbours of the position - ! If this is broken change from floor to int - ! How are we handling the edge case of a particle being - ! in exactly the same position as the grid? - ! Hopefully having different grid sizes in each direction - ! Doesn't break the lininterp - xlower = floor((position(1)-gridorigin(1))/dx(1)) - ylower = floor((position(2)-gridorigin(2))/dx(2)) - zlower = floor((position(3)-gridorigin(3))/dx(3)) + ! Get the lower grid neighbours of the position + ! If this is broken change from floor to int + ! How are we handling the edge case of a particle being + ! in exactly the same position as the grid? + ! Hopefully having different grid sizes in each direction + ! Doesn't break the lininterp + xlower = floor((position(1)-gridorigin(1))/dx(1)) + ylower = floor((position(2)-gridorigin(2))/dx(2)) + zlower = floor((position(3)-gridorigin(3))/dx(3)) - ! +1 because fortran - xlower = xlower + 1 - ylower = ylower + 1 - zlower = zlower + 1 + ! +1 because fortran + xlower = xlower + 1 + ylower = ylower + 1 + zlower = zlower + 1 end subroutine get_grid_neighbours -end module metric_interp \ No newline at end of file +end module metric_interp diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index 202164d3b..437e40ef2 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -40,22 +40,22 @@ pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) ! Perform trilenar interpolation if ( .not. gridinit) then - ! This is required for phantomsetup - ! As no grid information has been passed to phantom from ET - ! So interpolation cannot be performed - gcov = 0. - gcov(0,0) = -1. - gcov(1,1) = 1. - gcov(2,2) = 1. - gcov(3,3) = 1. - if (present(gcon)) then - gcon = 0. - gcon(0,0) = -1. - gcon(1,1) = 1. - gcon(2,2) = 1. - gcon(3,3) = 1. - endif - if (present(sqrtg)) sqrtg = -1. + ! This is required for phantomsetup + ! As no grid information has been passed to phantom from ET + ! So interpolation cannot be performed + gcov = 0. + gcov(0,0) = -1. + gcov(1,1) = 1. + gcov(2,2) = 1. + gcov(3,3) = 1. + if (present(gcon)) then + gcon = 0. + gcon(0,0) = -1. + gcon(1,1) = 1. + gcon(2,2) = 1. + gcon(3,3) = 1. + endif + if (present(sqrtg)) sqrtg = -1. elseif (present(gcon) .and. present(sqrtg)) then call interpolate_metric(position,gcov,gcon,sqrtg) else @@ -64,31 +64,31 @@ pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) end subroutine get_metric_cartesian pure subroutine get_metric_spherical(position,gcov,gcon,sqrtg) - real, intent(in) :: position(3) - real, intent(out) :: gcov(0:3,0:3) - real, intent(out), optional :: gcon(0:3,0:3) - real, intent(out), optional :: sqrtg - real :: r2,sintheta + real, intent(in) :: position(3) + real, intent(out) :: gcov(0:3,0:3) + real, intent(out), optional :: gcon(0:3,0:3) + real, intent(out), optional :: sqrtg + real :: r2,sintheta - gcov = 0. + gcov = 0. - r2 = position(1)**2 - sintheta = sin(position(2)) + r2 = position(1)**2 + sintheta = sin(position(2)) - gcov(0,0) = -1. - gcov(1,1) = 1. - gcov(2,2) = r2 - gcov(3,3) = r2*sintheta**2 + gcov(0,0) = -1. + gcov(1,1) = 1. + gcov(2,2) = r2 + gcov(3,3) = r2*sintheta**2 - if (present(gcon)) then - gcon = 0. - gcon(0,0) = -1. - gcon(1,1) = 1. - gcon(2,2) = 1./r2 - gcov(3,3) = 1./gcov(3,3) - endif + if (present(gcon)) then + gcon = 0. + gcon(0,0) = -1. + gcon(1,1) = 1. + gcon(2,2) = 1./r2 + gcov(3,3) = 1./gcov(3,3) + endif - if (present(sqrtg)) sqrtg = r2*sintheta + if (present(sqrtg)) sqrtg = r2*sintheta end subroutine get_metric_spherical @@ -106,39 +106,39 @@ pure subroutine metric_cartesian_derivatives(position,dgcovdx, dgcovdy, dgcovdz) end subroutine metric_cartesian_derivatives pure subroutine metric_spherical_derivatives(position,dgcovdr, dgcovdtheta, dgcovdphi) - real, intent(in) :: position(3) - real, intent(out), dimension(0:3,0:3) :: dgcovdr,dgcovdtheta,dgcovdphi - real :: r, theta + real, intent(in) :: position(3) + real, intent(out), dimension(0:3,0:3) :: dgcovdr,dgcovdtheta,dgcovdphi + real :: r, theta - r = position(1) - theta = position(2) + r = position(1) + theta = position(2) - dgcovdr = 0. - dgcovdtheta = 0. - dgcovdphi = 0. + dgcovdr = 0. + dgcovdtheta = 0. + dgcovdphi = 0. - dgcovdr(2,2) = 2*r - dgcovdr(3,3) = 2*r*sin(theta)**2 + dgcovdr(2,2) = 2*r + dgcovdr(3,3) = 2*r*sin(theta)**2 - dgcovdtheta(3,3) = 2*r**2*cos(theta)*sin(theta) + dgcovdtheta(3,3) = 2*r**2*cos(theta)*sin(theta) end subroutine metric_spherical_derivatives pure subroutine cartesian2spherical(xcart,xspher) - real, intent(in) :: xcart(3) - real, intent(out) :: xspher(3) - real :: x,y,z - real :: r,theta,phi + real, intent(in) :: xcart(3) + real, intent(out) :: xspher(3) + real :: x,y,z + real :: r,theta,phi - x = xcart(1) - y = xcart(2) - z = xcart(3) + x = xcart(1) + y = xcart(2) + z = xcart(3) - r = sqrt(x**2+y**2+z**2) - theta = acos(z/r) - phi = atan2(y,x) + r = sqrt(x**2+y**2+z**2) + theta = acos(z/r) + phi = atan2(y,x) - xspher = (/r,theta,phi/) + xspher = (/r,theta,phi/) end subroutine cartesian2spherical !----------------------------------------------------------------------- @@ -176,209 +176,209 @@ end subroutine read_options_metric !----------------------------------------------------------------------- pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) - ! linear and cubic interpolators should be moved to their own subroutine - ! away from eos_shen - use eos_shen, only:linear_interpolator_one_d - use einsteintk_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid,gridsize,gridorigin - real, intent(in) :: position(3) - real, intent(out) :: gcov(0:3,0:3) - real, intent(out), optional :: gcon(0:3,0:3), sqrtg - integer :: xlower,ylower,zlower,xupper,yupper,zupper - real :: xlowerpos,ylowerpos,zlowerpos - real :: xd,yd,zd - real :: interptmp(7) - integer :: i,j - - ! If the issue is that the metric vals are undefined on - ! Setup since we have not recieved anything about the metric - ! from ET during phantomsetup - ! Then simply set gcov and gcon to 0 - ! as these values will be overwritten during the run anyway - !print*, "Calling interp metric!" - ! Get neighbours - call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) - !print*,"Neighbours: ", xlower,ylower,zlower - ! This is not true as upper neighbours on the boundary will be on the side - ! take a mod of grid size - xupper = mod(xlower + 1, gridsize(1)) - yupper = mod(ylower + 1, gridsize(2)) - zupper = mod(zlower + 1, gridsize(3)) - ! xupper - xlower should always just be dx provided we are using a uniform grid - ! xd = (position(1) - xlower)/(xupper - xlower) - ! yd = (position(2) - ylower)/(yupper - ylower) - ! zd = (position(3) - zlower)/(zupper - zlower) - xlowerpos = gridorigin(1) + (xlower-1)*dxgrid(1) - ylowerpos = gridorigin(2) + (ylower-1)*dxgrid(2) - zlowerpos = gridorigin(3) + (zlower-1)*dxgrid(3) - - xd = (position(1) - xlowerpos)/(dxgrid(1)) - yd = (position(2) - ylowerpos)/(dxgrid(2)) - zd = (position(3) - zlowerpos)/(dxgrid(3)) - - interptmp = 0. - ! All the interpolation should go into an interface, then you should just call trilinear_interp - ! interpolate for gcov - do i=0, 3 - do j=0, 3 - ! Interpolate along x - call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower,zlower), & + ! linear and cubic interpolators should be moved to their own subroutine + ! away from eos_shen + use eos_shen, only:linear_interpolator_one_d + use einsteintk_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid,gridsize,gridorigin + real, intent(in) :: position(3) + real, intent(out) :: gcov(0:3,0:3) + real, intent(out), optional :: gcon(0:3,0:3), sqrtg + integer :: xlower,ylower,zlower,xupper,yupper,zupper + real :: xlowerpos,ylowerpos,zlowerpos + real :: xd,yd,zd + real :: interptmp(7) + integer :: i,j + + ! If the issue is that the metric vals are undefined on + ! Setup since we have not recieved anything about the metric + ! from ET during phantomsetup + ! Then simply set gcov and gcon to 0 + ! as these values will be overwritten during the run anyway + !print*, "Calling interp metric!" + ! Get neighbours + call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) + !print*,"Neighbours: ", xlower,ylower,zlower + ! This is not true as upper neighbours on the boundary will be on the side + ! take a mod of grid size + xupper = mod(xlower + 1, gridsize(1)) + yupper = mod(ylower + 1, gridsize(2)) + zupper = mod(zlower + 1, gridsize(3)) + ! xupper - xlower should always just be dx provided we are using a uniform grid + ! xd = (position(1) - xlower)/(xupper - xlower) + ! yd = (position(2) - ylower)/(yupper - ylower) + ! zd = (position(3) - zlower)/(zupper - zlower) + xlowerpos = gridorigin(1) + (xlower-1)*dxgrid(1) + ylowerpos = gridorigin(2) + (ylower-1)*dxgrid(2) + zlowerpos = gridorigin(3) + (zlower-1)*dxgrid(3) + + xd = (position(1) - xlowerpos)/(dxgrid(1)) + yd = (position(2) - ylowerpos)/(dxgrid(2)) + zd = (position(3) - zlowerpos)/(dxgrid(3)) + + interptmp = 0. + ! All the interpolation should go into an interface, then you should just call trilinear_interp + ! interpolate for gcov + do i=0, 3 + do j=0, 3 + ! Interpolate along x + call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower,zlower), & gcovgrid(i,j,xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower,zlower+1), & + call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower,zlower+1), & gcovgrid(i,j,xlower+1,ylower,zlower+1),xd,interptmp(2)) - call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower+1,zlower), & + call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower+1,zlower), & gcovgrid(i,j,xlower+1,ylower+1,zlower),xd,interptmp(3)) - call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower+1,zlower+1), & + call linear_interpolator_one_d(gcovgrid(i,j,xlower,ylower+1,zlower+1), & gcovgrid(i,j,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y - call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) - call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) - ! Interpolate along z - call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - - gcov(i,j) = interptmp(7) - enddo + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + gcov(i,j) = interptmp(7) enddo + enddo - if (present(gcon)) then + if (present(gcon)) then ! interpolate for gcon do i=0, 3 - do j=0, 3 - ! Interpolate along x - call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower,zlower), & + do j=0, 3 + ! Interpolate along x + call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower,zlower), & gcongrid(i,j,xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower,zlower+1), & + call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower,zlower+1), & gcongrid(i,j,xlower+1,ylower,zlower+1),xd,interptmp(2)) - call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower+1,zlower), & + call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower+1,zlower), & gcongrid(i,j,xlower+1,ylower+1,zlower),xd,interptmp(3)) - call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower+1,zlower+1), & + call linear_interpolator_one_d(gcongrid(i,j,xlower,ylower+1,zlower+1), & gcongrid(i,j,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y - call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) - call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) - ! Interpolate along z - call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - - gcon(i,j) = interptmp(7) - enddo + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + gcon(i,j) = interptmp(7) + enddo enddo - endif + endif - if (present(sqrtg)) then - ! Interpolate for sqrtg - ! Interpolate along x - call linear_interpolator_one_d(sqrtggrid(xlower,ylower,zlower), & + if (present(sqrtg)) then + ! Interpolate for sqrtg + ! Interpolate along x + call linear_interpolator_one_d(sqrtggrid(xlower,ylower,zlower), & sqrtggrid(xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(sqrtggrid(xlower,ylower,zlower+1), & + call linear_interpolator_one_d(sqrtggrid(xlower,ylower,zlower+1), & sqrtggrid(xlower+1,ylower,zlower+1),xd,interptmp(2)) - call linear_interpolator_one_d(sqrtggrid(xlower,ylower+1,zlower), & + call linear_interpolator_one_d(sqrtggrid(xlower,ylower+1,zlower), & sqrtggrid(xlower+1,ylower+1,zlower),xd,interptmp(3)) - call linear_interpolator_one_d(sqrtggrid(xlower,ylower+1,zlower+1), & + call linear_interpolator_one_d(sqrtggrid(xlower,ylower+1,zlower+1), & sqrtggrid(xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y - call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) - call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) - ! Interpolate along z - call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - sqrtg = interptmp(7) - endif + sqrtg = interptmp(7) + endif end subroutine interpolate_metric pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) - use eos_shen, only:linear_interpolator_one_d - use einsteintk_utils, only:metricderivsgrid, dxgrid,gridorigin - real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3),dgcovdz(0:3,0:3) - real, intent(in) :: position(3) - integer :: xlower,ylower,zlower,xupper,yupper,zupper - real :: xd,yd,zd,xlowerpos, ylowerpos,zlowerpos - real :: interptmp(7) - integer :: i,j - - call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) - !print*,"Neighbours: ", xlower,ylower,zlower - xupper = xlower + 1 - yupper = yupper + 1 - zupper = zupper + 1 - ! xd = (position(1) - xlower)/(xupper - xlower) - ! yd = (position(2) - ylower)/(yupper - ylower) - ! zd = (position(3) - zlower)/(zupper - zlower) - - xlowerpos = gridorigin(1) + (xlower-1)*dxgrid(1) - ylowerpos = gridorigin(2) + (ylower-1)*dxgrid(2) - zlowerpos = gridorigin(3) + (zlower-1)*dxgrid(3) - - xd = (position(1) - xlowerpos)/(dxgrid(1)) - yd = (position(2) - ylowerpos)/(dxgrid(2)) - zd = (position(3) - zlowerpos)/(dxgrid(3)) - - interptmp = 0. - - ! Interpolate for dx - do i=0, 3 - do j=0, 3 - ! Interpolate along x - call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower,zlower), & + use eos_shen, only:linear_interpolator_one_d + use einsteintk_utils, only:metricderivsgrid, dxgrid,gridorigin + real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3),dgcovdz(0:3,0:3) + real, intent(in) :: position(3) + integer :: xlower,ylower,zlower,xupper,yupper,zupper + real :: xd,yd,zd,xlowerpos, ylowerpos,zlowerpos + real :: interptmp(7) + integer :: i,j + + call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) + !print*,"Neighbours: ", xlower,ylower,zlower + xupper = xlower + 1 + yupper = yupper + 1 + zupper = zupper + 1 + ! xd = (position(1) - xlower)/(xupper - xlower) + ! yd = (position(2) - ylower)/(yupper - ylower) + ! zd = (position(3) - zlower)/(zupper - zlower) + + xlowerpos = gridorigin(1) + (xlower-1)*dxgrid(1) + ylowerpos = gridorigin(2) + (ylower-1)*dxgrid(2) + zlowerpos = gridorigin(3) + (zlower-1)*dxgrid(3) + + xd = (position(1) - xlowerpos)/(dxgrid(1)) + yd = (position(2) - ylowerpos)/(dxgrid(2)) + zd = (position(3) - zlowerpos)/(dxgrid(3)) + + interptmp = 0. + + ! Interpolate for dx + do i=0, 3 + do j=0, 3 + ! Interpolate along x + call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower,zlower), & metricderivsgrid(i,j,1,xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower,zlower+1), & + call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower,zlower+1), & metricderivsgrid(i,j,1,xlower+1,ylower,zlower+1),xd,interptmp(2)) - call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower+1,zlower), & + call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower+1,zlower), & metricderivsgrid(i,j,1,xlower+1,ylower+1,zlower),xd,interptmp(3)) - call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower+1,zlower+1), & + call linear_interpolator_one_d(metricderivsgrid(i,j,1,xlower,ylower+1,zlower+1), & metricderivsgrid(i,j,1,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y - call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) - call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) - ! Interpolate along z - call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - - dgcovdx(i,j) = interptmp(7) - enddo + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + dgcovdx(i,j) = interptmp(7) enddo - ! Interpolate for dy - do i=0, 3 - do j=0, 3 - ! Interpolate along x - call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower,zlower), & + enddo + ! Interpolate for dy + do i=0, 3 + do j=0, 3 + ! Interpolate along x + call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower,zlower), & metricderivsgrid(i,j,2,xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower,zlower+1), & + call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower,zlower+1), & metricderivsgrid(i,j,2,xlower+1,ylower,zlower+1),xd,interptmp(2)) - call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower+1,zlower), & + call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower+1,zlower), & metricderivsgrid(i,j,2,xlower+1,ylower+1,zlower),xd,interptmp(3)) - call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower+1,zlower+1), & + call linear_interpolator_one_d(metricderivsgrid(i,j,2,xlower,ylower+1,zlower+1), & metricderivsgrid(i,j,2,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y - call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) - call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) - ! Interpolate along z - call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - - dgcovdy(i,j) = interptmp(7) - enddo + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + dgcovdy(i,j) = interptmp(7) enddo + enddo - ! Interpolate for dz - do i=0, 3 - do j=0, 3 - ! Interpolate along x - call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower,zlower), & + ! Interpolate for dz + do i=0, 3 + do j=0, 3 + ! Interpolate along x + call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower,zlower), & metricderivsgrid(i,j,3,xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower,zlower+1), & + call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower,zlower+1), & metricderivsgrid(i,j,3,xlower+1,ylower,zlower+1),xd,interptmp(2)) - call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower+1,zlower), & + call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower+1,zlower), & metricderivsgrid(i,j,3,xlower+1,ylower+1,zlower),xd,interptmp(3)) - call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower+1,zlower+1), & + call linear_interpolator_one_d(metricderivsgrid(i,j,3,xlower,ylower+1,zlower+1), & metricderivsgrid(i,j,3,xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y - call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) - call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) - ! Interpolate along z - call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - - dgcovdz(i,j) = interptmp(7) - enddo + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + + dgcovdz(i,j) = interptmp(7) enddo + enddo @@ -386,25 +386,25 @@ pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) end subroutine interpolate_metric_derivs pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) - use einsteintk_utils, only:gridorigin - real, intent(in) :: position(3) - real, intent(in) :: dx(3) - integer, intent(out) :: xlower,ylower,zlower - - ! Get the lower grid neighbours of the position - ! If this is broken change from floor to int - ! How are we handling the edge case of a particle being - ! in exactly the same position as the grid? - ! Hopefully having different grid sizes in each direction - ! Doesn't break the lininterp - xlower = floor((position(1)-gridorigin(1))/dx(1)) - ylower = floor((position(2)-gridorigin(2))/dx(2)) - zlower = floor((position(3)-gridorigin(3))/dx(3)) - - ! +1 because fortran - xlower = xlower + 1 - ylower = ylower + 1 - zlower = zlower + 1 + use einsteintk_utils, only:gridorigin + real, intent(in) :: position(3) + real, intent(in) :: dx(3) + integer, intent(out) :: xlower,ylower,zlower + + ! Get the lower grid neighbours of the position + ! If this is broken change from floor to int + ! How are we handling the edge case of a particle being + ! in exactly the same position as the grid? + ! Hopefully having different grid sizes in each direction + ! Doesn't break the lininterp + xlower = floor((position(1)-gridorigin(1))/dx(1)) + ylower = floor((position(2)-gridorigin(2))/dx(2)) + zlower = floor((position(3)-gridorigin(3))/dx(3)) + + ! +1 because fortran + xlower = xlower + 1 + ylower = ylower + 1 + zlower = zlower + 1 end subroutine get_grid_neighbours diff --git a/src/main/metric_flrw.f90 b/src/main/metric_flrw.f90 index ec853e565..68152b86d 100644 --- a/src/main/metric_flrw.f90 +++ b/src/main/metric_flrw.f90 @@ -18,8 +18,8 @@ module metric ! -use timestep, only: time -implicit none + use timestep, only: time + implicit none character(len=*), parameter :: metric_type = 'flrw' integer, parameter :: imetric = 5 @@ -48,11 +48,11 @@ pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) gcov(3,3) = a if (present(gcon)) then - gcon = 0. - gcon(0,0) = -1. - gcon(1,1) = 1./a - gcon(2,2) = 1./a - gcon(3,3) = 1./a + gcon = 0. + gcon(0,0) = -1. + gcon(1,1) = 1./a + gcon(2,2) = 1./a + gcon(3,3) = 1./a endif if (present(sqrtg)) sqrtg = a*a*a @@ -229,10 +229,10 @@ subroutine read_options_metric(name,valstring,imatch,igotall,ierr) end subroutine read_options_metric pure subroutine get_scale_factor(t,a) - real, intent(in) :: t - real, intent(out) :: a + real, intent(in) :: t + real, intent(out) :: a - a = t*(0.5) + 1 + a = t*(0.5) + 1 end subroutine get_scale_factor diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index ed6fce597..fa057a860 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -580,7 +580,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) enddo corrector !$omp enddo !$omp end parallel -print*, "after corrector" + print*, "after corrector" if (use_dustgrowth) call check_dustprop(npart,dustprop(1,:)) if (gr) then diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index e831224df..2939747bd 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -16,318 +16,318 @@ module tmunu2grid ! ! :Dependencies: boundary, einsteintk_utils, interpolations3D, part ! - implicit none + implicit none contains - subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) - use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid - use interpolations3D, only: interpolate3D - use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax - use part, only: massoftype,igas,rhoh,dens,hfact - integer, intent(in) :: npart - real, intent(in) :: vxyzu(:,:), tmunus(:,:,:) - real, intent(inout) :: xyzh(:,:) - logical, intent(in), optional :: calc_cfac - real :: weight,h,rho,pmass,rhoexact - real :: weights(npart) - real, save :: cfac - integer, save :: iteration = 0 - real :: xmininterp(3) - integer :: ngrid(3) - real,allocatable :: datsmooth(:,:,:), dat(:) - integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper - logical :: normalise, vertexcen,periodicx,periodicy,periodicz,exact_rendering - real :: totalmass, totalmassgrid - integer :: itype(npart) - - - ! total mass of the particles - totalmass = npart*massoftype(igas) - - !print*, "totalmass(part): ", totalmass - - ! Density interpolated to the grid - rhostargrid = 0. - if (.not. allocated(datsmooth)) allocate (datsmooth(gridsize(1),gridsize(2),gridsize(3))) - if (.not. allocated(dat)) allocate (dat(npart)) - ! All particles have equal weighting in the interp - ! Here we calculate the weight for the first particle - ! Get the smoothing length - h = xyzh(4,1) - ! Get pmass - pmass = massoftype(igas) - ! Get density - rho = rhoh(h,pmass) - call get_weight(pmass,h,rho,weight) - ! Correct for Kernel Bias, find correction factor - ! Wrap this into it's own subroutine - if (present(calc_cfac)) then - if (calc_cfac) call get_cfac(cfac,rho) - endif - - weights = weight - itype = 1 - !call get_cfac(cfac,rho) - !print*, "Weighting for particle smoothing is: ", weight - !weight = 1. - ! For now we can set this to the origin, but it might need to be - ! set to the grid origin of the CCTK_grid since we have boundary points - ! TODO This should also be the proper phantom values and not a magic number - !xmin(:) = gridorigin(:) - 0.5*dxgrid(:) ! We move the origin back by 0.5*dx to make a pseudo cell-centered grid - xmininterp(1) = xmin -dxgrid(1) !- 0.5*dxgrid(1) - xmininterp(2) = ymin -dxgrid(2) !- 0.5*dxgrid(2) - xmininterp(3) = zmin-dxgrid(3) !- 0.5*dxgrid(3) - - call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) - call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) - call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) - ! nnodes is just the size of the mesh - ! might not be needed - ! We note that this is not actually the size of the einstein toolkit grid - ! As we want our periodic boundary to be on the particle domain not the - ! ET grid domain - ngrid(1) = (iupper-ilower) + 1 - ngrid(2) = (jupper-jlower) + 1 - ngrid(3) = (kupper-klower) + 1 - nnodes = (iupper-ilower)*(jupper-jlower)*(kupper-klower) - ! Do we want to normalise interpolations? - normalise = .true. - ! Is our NR GRID vertex centered? - vertexcen = .false. - periodicx = .true. - periodicy = .true. - periodicz = .true. - - - - ! tt component - - tmunugrid = 0. - datsmooth = 0. - ! TODO Unroll this loop for speed + using symmetries - ! Possiblly cleanup the messy indexing - do k=1,4 - do j=1,4 - do i=1, npart - dat(i) = tmunus(k,j,i) - enddo - - ! Get the position of the first grid cell x,y,z - ! Call to interpolate 3D - ! COMMENTED OUT AS NOT USED BY NEW INTERPOLATE ROUTINE - ! call interpolate3D(xyzh,weight,npart, & - ! xmininterp,tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper), & - ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) - - !print*, "Interpolated grid values are: ", datsmooth(4:38,4:38,4:38) - !stop - ! NEW INTERPOLATION ROUTINE - call interpolate3D(xyzh,weights,dat,itype,npart,& +subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) + use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid + use interpolations3D, only: interpolate3D + use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax + use part, only: massoftype,igas,rhoh,dens,hfact + integer, intent(in) :: npart + real, intent(in) :: vxyzu(:,:), tmunus(:,:,:) + real, intent(inout) :: xyzh(:,:) + logical, intent(in), optional :: calc_cfac + real :: weight,h,rho,pmass,rhoexact + real :: weights(npart) + real, save :: cfac + integer, save :: iteration = 0 + real :: xmininterp(3) + integer :: ngrid(3) + real,allocatable :: datsmooth(:,:,:), dat(:) + integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper + logical :: normalise, vertexcen,periodicx,periodicy,periodicz,exact_rendering + real :: totalmass, totalmassgrid + integer :: itype(npart) + + + ! total mass of the particles + totalmass = npart*massoftype(igas) + + !print*, "totalmass(part): ", totalmass + + ! Density interpolated to the grid + rhostargrid = 0. + if (.not. allocated(datsmooth)) allocate (datsmooth(gridsize(1),gridsize(2),gridsize(3))) + if (.not. allocated(dat)) allocate (dat(npart)) + ! All particles have equal weighting in the interp + ! Here we calculate the weight for the first particle + ! Get the smoothing length + h = xyzh(4,1) + ! Get pmass + pmass = massoftype(igas) + ! Get density + rho = rhoh(h,pmass) + call get_weight(pmass,h,rho,weight) + ! Correct for Kernel Bias, find correction factor + ! Wrap this into it's own subroutine + if (present(calc_cfac)) then + if (calc_cfac) call get_cfac(cfac,rho) + endif + + weights = weight + itype = 1 + !call get_cfac(cfac,rho) + !print*, "Weighting for particle smoothing is: ", weight + !weight = 1. + ! For now we can set this to the origin, but it might need to be + ! set to the grid origin of the CCTK_grid since we have boundary points + ! TODO This should also be the proper phantom values and not a magic number + !xmin(:) = gridorigin(:) - 0.5*dxgrid(:) ! We move the origin back by 0.5*dx to make a pseudo cell-centered grid + xmininterp(1) = xmin -dxgrid(1) !- 0.5*dxgrid(1) + xmininterp(2) = ymin -dxgrid(2) !- 0.5*dxgrid(2) + xmininterp(3) = zmin-dxgrid(3) !- 0.5*dxgrid(3) + + call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) + call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) + call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) + ! nnodes is just the size of the mesh + ! might not be needed + ! We note that this is not actually the size of the einstein toolkit grid + ! As we want our periodic boundary to be on the particle domain not the + ! ET grid domain + ngrid(1) = (iupper-ilower) + 1 + ngrid(2) = (jupper-jlower) + 1 + ngrid(3) = (kupper-klower) + 1 + nnodes = (iupper-ilower)*(jupper-jlower)*(kupper-klower) + ! Do we want to normalise interpolations? + normalise = .true. + ! Is our NR GRID vertex centered? + vertexcen = .false. + periodicx = .true. + periodicy = .true. + periodicz = .true. + + + + ! tt component + + tmunugrid = 0. + datsmooth = 0. + ! TODO Unroll this loop for speed + using symmetries + ! Possiblly cleanup the messy indexing + do k=1,4 + do j=1,4 + do i=1, npart + dat(i) = tmunus(k,j,i) + enddo + + ! Get the position of the first grid cell x,y,z + ! Call to interpolate 3D + ! COMMENTED OUT AS NOT USED BY NEW INTERPOLATE ROUTINE + ! call interpolate3D(xyzh,weight,npart, & + ! xmininterp,tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper), & + ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) + + !print*, "Interpolated grid values are: ", datsmooth(4:38,4:38,4:38) + !stop + ! NEW INTERPOLATION ROUTINE + call interpolate3D(xyzh,weights,dat,itype,npart,& xmininterp(1),xmininterp(2),xmininterp(3), & tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper),& ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& normalise,periodicx,periodicy,periodicz) - enddo - enddo - - ! RHOSTARGRID CALCULATION IS NOW HANDLED BY AN EXTERNAL ROUTINE - ! THIS IS COMMENTED OUT IN CASE I BREAK EVERYTHING AND NEED TO GO BACK - ! Get the conserved density on the particles - ! dat = 0. - ! do i=1, npart - ! ! Get the smoothing length - ! h = xyzh(4,i) - ! ! Get pmass - ! pmass = massoftype(igas) - ! rho = rhoh(h,pmass) - ! dat(i) = rho - ! enddo - - ! Commented out as not used by new interpolate routine - ! call interpolate3D(xyzh,weight,npart, & - ! xmininterp,rhostargrid(ilower:iupper,jlower:jupper,klower:kupper), & - ! nnodes,dxgrid,.true.,dat,ngrid,vertexcen) - - - ! Calculate the total mass on the grid - !totalmassgrid = 0. - ! do i=ilower,iupper - ! do j=jlower,jupper - ! do k=klower, kupper - ! totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) - - ! enddo - ! enddo - ! enddo - ! Explicitly set pressure to be 0 - ! Need to do this in the phantom setup file later - ! tmunugrid(1,0:3,:,:,:) = 0. - ! tmunugrid(2,0:3,:,:,:) = 0. - ! tmunugrid(3,0:3,:,:,:) = 0. - !tmunugrid(0,0,:,:,:) = tmunus(1,1,1) - ! Correction for kernel bias code - ! Hardcoded values for the cubic spline computed using - ! a constant density flrw universe. - ! Ideally this should be in a more general form - ! cfac = totalmass/totalmassgrid - ! ! Output total mass on grid, total mass on particles - ! ! and the residuals - ! !cfac = 0.99917535781746514D0 - ! tmunugrid = tmunugrid*cfac - ! if (iteration==0) then - ! write(666,*) "iteration ", "Mass(Grid) ", "Mass(Particles) ", "Mass(Grid-Particles)" - ! endif - ! write(666,*) iteration, totalmassgrid, totalmass, abs(totalmassgrid-totalmass) - ! close(unit=666) - ! iteration = iteration + 1 - - ! New rho/smoothing length calc based on correction?? - ! not sure that this is a valid thing to do - ! do i=1, npart - ! rho = rhoh(xyzh(i,4),pmass) - ! rho = rho*cfac - ! xyzh(i,4) = hfact*(pmass/rho)**(1./3.) - - ! enddo - - ! Correct rhostargrid using cfac - !rhostargrid = cfac*rhostargrid - - ! Calculate rho(prim), P and e on the grid - ! Apply kernel correction to primatives?? - ! Then calculate a stress energy tensor per grid and fill tmunu - ! A good consistency check would be to do it both ways and compare values - - ! Primative density - - - end subroutine get_tmunugrid_all - - subroutine get_weight(pmass,h,rhoi,weight) - real, intent(in) :: pmass,h,rhoi - real, intent(out) :: weight - - weight = (pmass)/(rhoi*h**3) - - end subroutine get_weight - - subroutine get_dat(tmunus,dat) - real, intent(in) :: tmunus - real, intent(out) :: dat - - end subroutine get_dat - - ! subroutine get_primdens(dens,dat) - ! real, intent(in) :: dens - ! real, intent(out) :: dat - ! integer :: i, npart - - ! ! Get the primative density on the particles - ! dat = 0. - ! do i=1, npart - ! dat(i) = dens(i) - ! enddo - - ! end subroutine get_primdens - - ! subroutine get_4velocity(vxyzu,dat) - ! real, intent(in) :: vxyzu(:,:) - ! real, intent(out) :: dat(:,:) - ! integer :: i,npart - - ! ! Get the primative density on the particles - ! dat = 0. - ! do i=1, npart - ! dat(:,i) = vxyzu(1:3,i) - ! enddo - - ! end subroutine get_4velocity - - subroutine get_particle_domain(gridorigin,xmin,xmax,dxgrid,ilower,iupper) - real, intent(in) :: gridorigin, xmin,xmax, dxgrid - integer, intent(out) :: ilower, iupper - - ! Changed from int to nint - ! to fix a bug - ilower = nint((xmin - gridorigin)/dxgrid) + 1 ! +1 since our arrays start at 1 not 0 - iupper = nint((xmax - gridorigin)/dxgrid) ! Removed the +1 as this was also a bug - ! The lower boundary is in the physical - ! domain but the upper is not; can't have both? - end subroutine get_particle_domain - - subroutine get_cfac(cfac,rho) - real, intent(in) :: rho - real, intent(out) :: cfac - real :: rhoexact - rhoexact = 13.294563008157013D0 - cfac = rhoexact/rho - - end subroutine get_cfac - - subroutine interpolate_to_grid(gridarray,dat) - use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid - use interpolations3D, only: interpolate3D - use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax - use part, only:npart,xyzh,massoftype,igas,rhoh,dens,hfact - real :: weight,h,rho,pmass,rhoexact - real, save :: cfac - integer, save :: iteration = 0 - real :: xmininterp(3) - integer :: ngrid(3) - integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper - logical :: normalise, vertexcen,periodicx, periodicy, periodicz - real :: totalmass, totalmassgrid - real, dimension(npart) :: weights - integer, dimension(npart) :: itype - real, intent(out) :: gridarray(:,:,:) ! Grid array to interpolate a quantity to - ! GRID MUST BE RESTRICTED WITH UPPER AND LOWER INDICIES - real, intent(in) :: dat(:) ! The particle data to interpolate to grid - real, allocatable :: interparray(:,:,:) - - - xmininterp(1) = xmin - dxgrid(1)!- 0.5*dxgrid(1) - xmininterp(2) = ymin - dxgrid(2) !- 0.5*dxgrid(2) - xmininterp(3) = zmin - dxgrid(3) !- 0.5*dxgrid(3) - !print*, "xminiterp: ", xmininterp - call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) - call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) - call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) - - ! We note that this is not actually the size of the einstein toolkit grid - ! As we want our periodic boundary to be on the particle domain not the - ! ET grid domain - ngrid(1) = (iupper-ilower) + 1 - ngrid(2) = (jupper-jlower) + 1 - ngrid(3) = (kupper-klower) + 1 - allocate(interparray(ngrid(1),ngrid(2),ngrid(3))) - interparray = 0. - nnodes = (iupper-ilower)*(jupper-jlower)*(kupper-klower) - ! Do we want to normalise interpolations? - normalise = .true. - ! Is our NR GRID vertex centered? - vertexcen = .false. - periodicx = .true. - periodicy = .true. - periodicz = .true. - - - - do i=1, npart - h = xyzh(4,i) - ! Get pmass - pmass = massoftype(igas) - ! Get density - rho = rhoh(h,pmass) - call get_weight(pmass,h,rho,weight) - weights(i) = weight - enddo - itype = igas - ! call interpolate3D(xyzh,weight,npart, & - ! xmininterp,gridarray(ilower:iupper,jlower:jupper,klower:kupper), & - ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) - call interpolate3D(xyzh,weights,dat,itype,npart,& + enddo + enddo + + ! RHOSTARGRID CALCULATION IS NOW HANDLED BY AN EXTERNAL ROUTINE + ! THIS IS COMMENTED OUT IN CASE I BREAK EVERYTHING AND NEED TO GO BACK + ! Get the conserved density on the particles + ! dat = 0. + ! do i=1, npart + ! ! Get the smoothing length + ! h = xyzh(4,i) + ! ! Get pmass + ! pmass = massoftype(igas) + ! rho = rhoh(h,pmass) + ! dat(i) = rho + ! enddo + + ! Commented out as not used by new interpolate routine + ! call interpolate3D(xyzh,weight,npart, & + ! xmininterp,rhostargrid(ilower:iupper,jlower:jupper,klower:kupper), & + ! nnodes,dxgrid,.true.,dat,ngrid,vertexcen) + + + ! Calculate the total mass on the grid + !totalmassgrid = 0. + ! do i=ilower,iupper + ! do j=jlower,jupper + ! do k=klower, kupper + ! totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) + + ! enddo + ! enddo + ! enddo + ! Explicitly set pressure to be 0 + ! Need to do this in the phantom setup file later + ! tmunugrid(1,0:3,:,:,:) = 0. + ! tmunugrid(2,0:3,:,:,:) = 0. + ! tmunugrid(3,0:3,:,:,:) = 0. + !tmunugrid(0,0,:,:,:) = tmunus(1,1,1) + ! Correction for kernel bias code + ! Hardcoded values for the cubic spline computed using + ! a constant density flrw universe. + ! Ideally this should be in a more general form + ! cfac = totalmass/totalmassgrid + ! ! Output total mass on grid, total mass on particles + ! ! and the residuals + ! !cfac = 0.99917535781746514D0 + ! tmunugrid = tmunugrid*cfac + ! if (iteration==0) then + ! write(666,*) "iteration ", "Mass(Grid) ", "Mass(Particles) ", "Mass(Grid-Particles)" + ! endif + ! write(666,*) iteration, totalmassgrid, totalmass, abs(totalmassgrid-totalmass) + ! close(unit=666) + ! iteration = iteration + 1 + + ! New rho/smoothing length calc based on correction?? + ! not sure that this is a valid thing to do + ! do i=1, npart + ! rho = rhoh(xyzh(i,4),pmass) + ! rho = rho*cfac + ! xyzh(i,4) = hfact*(pmass/rho)**(1./3.) + + ! enddo + + ! Correct rhostargrid using cfac + !rhostargrid = cfac*rhostargrid + + ! Calculate rho(prim), P and e on the grid + ! Apply kernel correction to primatives?? + ! Then calculate a stress energy tensor per grid and fill tmunu + ! A good consistency check would be to do it both ways and compare values + + ! Primative density + + +end subroutine get_tmunugrid_all + +subroutine get_weight(pmass,h,rhoi,weight) + real, intent(in) :: pmass,h,rhoi + real, intent(out) :: weight + + weight = (pmass)/(rhoi*h**3) + +end subroutine get_weight + +subroutine get_dat(tmunus,dat) + real, intent(in) :: tmunus + real, intent(out) :: dat + +end subroutine get_dat + + ! subroutine get_primdens(dens,dat) + ! real, intent(in) :: dens + ! real, intent(out) :: dat + ! integer :: i, npart + + ! ! Get the primative density on the particles + ! dat = 0. + ! do i=1, npart + ! dat(i) = dens(i) + ! enddo + + ! end subroutine get_primdens + + ! subroutine get_4velocity(vxyzu,dat) + ! real, intent(in) :: vxyzu(:,:) + ! real, intent(out) :: dat(:,:) + ! integer :: i,npart + + ! ! Get the primative density on the particles + ! dat = 0. + ! do i=1, npart + ! dat(:,i) = vxyzu(1:3,i) + ! enddo + + ! end subroutine get_4velocity + +subroutine get_particle_domain(gridorigin,xmin,xmax,dxgrid,ilower,iupper) + real, intent(in) :: gridorigin, xmin,xmax, dxgrid + integer, intent(out) :: ilower, iupper + + ! Changed from int to nint + ! to fix a bug + ilower = nint((xmin - gridorigin)/dxgrid) + 1 ! +1 since our arrays start at 1 not 0 + iupper = nint((xmax - gridorigin)/dxgrid) ! Removed the +1 as this was also a bug + ! The lower boundary is in the physical + ! domain but the upper is not; can't have both? +end subroutine get_particle_domain + +subroutine get_cfac(cfac,rho) + real, intent(in) :: rho + real, intent(out) :: cfac + real :: rhoexact + rhoexact = 13.294563008157013D0 + cfac = rhoexact/rho + +end subroutine get_cfac + +subroutine interpolate_to_grid(gridarray,dat) + use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid + use interpolations3D, only: interpolate3D + use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax + use part, only:npart,xyzh,massoftype,igas,rhoh,dens,hfact + real :: weight,h,rho,pmass,rhoexact + real, save :: cfac + integer, save :: iteration = 0 + real :: xmininterp(3) + integer :: ngrid(3) + integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper + logical :: normalise, vertexcen,periodicx, periodicy, periodicz + real :: totalmass, totalmassgrid + real, dimension(npart) :: weights + integer, dimension(npart) :: itype + real, intent(out) :: gridarray(:,:,:) ! Grid array to interpolate a quantity to + ! GRID MUST BE RESTRICTED WITH UPPER AND LOWER INDICIES + real, intent(in) :: dat(:) ! The particle data to interpolate to grid + real, allocatable :: interparray(:,:,:) + + + xmininterp(1) = xmin - dxgrid(1)!- 0.5*dxgrid(1) + xmininterp(2) = ymin - dxgrid(2) !- 0.5*dxgrid(2) + xmininterp(3) = zmin - dxgrid(3) !- 0.5*dxgrid(3) + !print*, "xminiterp: ", xmininterp + call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) + call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) + call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) + + ! We note that this is not actually the size of the einstein toolkit grid + ! As we want our periodic boundary to be on the particle domain not the + ! ET grid domain + ngrid(1) = (iupper-ilower) + 1 + ngrid(2) = (jupper-jlower) + 1 + ngrid(3) = (kupper-klower) + 1 + allocate(interparray(ngrid(1),ngrid(2),ngrid(3))) + interparray = 0. + nnodes = (iupper-ilower)*(jupper-jlower)*(kupper-klower) + ! Do we want to normalise interpolations? + normalise = .true. + ! Is our NR GRID vertex centered? + vertexcen = .false. + periodicx = .true. + periodicy = .true. + periodicz = .true. + + + + do i=1, npart + h = xyzh(4,i) + ! Get pmass + pmass = massoftype(igas) + ! Get density + rho = rhoh(h,pmass) + call get_weight(pmass,h,rho,weight) + weights(i) = weight + enddo + itype = igas + ! call interpolate3D(xyzh,weight,npart, & + ! xmininterp,gridarray(ilower:iupper,jlower:jupper,klower:kupper), & + ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) + call interpolate3D(xyzh,weights,dat,itype,npart,& xmininterp(1),xmininterp(2),xmininterp(3), & - !interparray, & + !interparray, & gridarray(ilower:iupper,jlower:jupper,klower:kupper),& ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& normalise,periodicx,periodicy,periodicz) @@ -335,76 +335,76 @@ subroutine interpolate_to_grid(gridarray,dat) - end subroutine interpolate_to_grid +end subroutine interpolate_to_grid - subroutine check_conserved_dens(rhostargrid,cfac) - use part, only:npart,massoftype,igas - use einsteintk_utils, only: dxgrid, gridorigin - use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax - real, intent(in) :: rhostargrid(:,:,:) - real(kind=16), intent(out) :: cfac - real :: totalmassgrid,totalmasspart - integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper +subroutine check_conserved_dens(rhostargrid,cfac) + use part, only:npart,massoftype,igas + use einsteintk_utils, only: dxgrid, gridorigin + use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax + real, intent(in) :: rhostargrid(:,:,:) + real(kind=16), intent(out) :: cfac + real :: totalmassgrid,totalmasspart + integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper - call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) - call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) - call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) + call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) + call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) + call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) - totalmassgrid = 0. - do i=ilower,iupper - do j=jlower,jupper - do k=klower, kupper - totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) + totalmassgrid = 0. + do i=ilower,iupper + do j=jlower,jupper + do k=klower, kupper + totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) - enddo - enddo - enddo + enddo + enddo + enddo - ! total mass of the particles - totalmasspart = npart*massoftype(igas) + ! total mass of the particles + totalmasspart = npart*massoftype(igas) - !print*, "Total mass grid: ", totalmassgrid - !print*, "Total mass part: ", totalmasspart - ! Calculate cfac - cfac = totalmasspart/totalmassgrid + !print*, "Total mass grid: ", totalmassgrid + !print*, "Total mass part: ", totalmasspart + ! Calculate cfac + cfac = totalmasspart/totalmassgrid - !print*, "cfac mass: ", cfac + !print*, "cfac mass: ", cfac - end subroutine check_conserved_dens +end subroutine check_conserved_dens - subroutine check_conserved_p(pgrid,cfac) - use part, only:npart,massoftype,igas,pxyzu - use einsteintk_utils, only: dxgrid, gridorigin - use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax - real, intent(in) :: pgrid(:,:,:) - real(kind=16), intent(out) :: cfac - real :: totalmomentumgrid,totalmomentumpart - integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper +subroutine check_conserved_p(pgrid,cfac) + use part, only:npart,massoftype,igas,pxyzu + use einsteintk_utils, only: dxgrid, gridorigin + use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax + real, intent(in) :: pgrid(:,:,:) + real(kind=16), intent(out) :: cfac + real :: totalmomentumgrid,totalmomentumpart + integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper - call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) - call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) - call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) + call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) + call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) + call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) - ! I'm still a bit unsure what this conserved quantity is actually meant to be?? - totalmomentumgrid = 0. - do i=ilower,iupper - do j=jlower,jupper - do k=klower, kupper - !totalmomentumgrid = totalmomentumgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) + ! I'm still a bit unsure what this conserved quantity is actually meant to be?? + totalmomentumgrid = 0. + do i=ilower,iupper + do j=jlower,jupper + do k=klower, kupper + !totalmomentumgrid = totalmomentumgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) - enddo - enddo - enddo + enddo + enddo + enddo - ! total cons(momentum) of the particles - totalmomentumpart = npart*massoftype(igas) + ! total cons(momentum) of the particles + totalmomentumpart = npart*massoftype(igas) - ! Calculate cfac - cfac = totalmomentumpart/totalmomentumgrid + ! Calculate cfac + cfac = totalmomentumpart/totalmomentumgrid - !print*, "cfac mass: ", cfac + !print*, "cfac mass: ", cfac - end subroutine check_conserved_p +end subroutine check_conserved_p -end module tmunu2grid \ No newline at end of file +end module tmunu2grid diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index abb2dcf8f..22d5f392b 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.F90 @@ -159,112 +159,112 @@ subroutine get_geodesic_accel(axyz,npart,vxyz,metrics,metricderivs) end subroutine get_geodesic_accel subroutine get_sqrtg(gcov, sqrtg) - use metric, only: metric_type - real, intent(in) :: gcov(0:3,0:3) - real, intent(out) :: sqrtg - real :: det - real :: a11,a12,a13,a14 - real :: a21,a22,a23,a24 - real :: a31,a32,a33,a34 - real :: a41,a42,a43,a44 - - - if (metric_type == 'et') then - - a11 = gcov(0,0) - a21 = gcov(1,0) - a31 = gcov(2,0) - a41 = gcov(3,0) - a12 = gcov(0,1) - a22 = gcov(1,1) - a32 = gcov(2,1) - a42 = gcov(3,1) - a13 = gcov(0,2) - a23 = gcov(1,2) - a33 = gcov(2,2) - a43 = gcov(3,2) - a14 = gcov(0,3) - a24 = gcov(1,3) - a34 = gcov(2,3) - a44 = gcov(3,3) - - ! Calculate the determinant - det = a14*a23*a32*a41 - a13*a24*a32*a41 - a14*a22*a33*a41 + a12*a24*a33*a41 + & + use metric, only: metric_type + real, intent(in) :: gcov(0:3,0:3) + real, intent(out) :: sqrtg + real :: det + real :: a11,a12,a13,a14 + real :: a21,a22,a23,a24 + real :: a31,a32,a33,a34 + real :: a41,a42,a43,a44 + + + if (metric_type == 'et') then + + a11 = gcov(0,0) + a21 = gcov(1,0) + a31 = gcov(2,0) + a41 = gcov(3,0) + a12 = gcov(0,1) + a22 = gcov(1,1) + a32 = gcov(2,1) + a42 = gcov(3,1) + a13 = gcov(0,2) + a23 = gcov(1,2) + a33 = gcov(2,2) + a43 = gcov(3,2) + a14 = gcov(0,3) + a24 = gcov(1,3) + a34 = gcov(2,3) + a44 = gcov(3,3) + + ! Calculate the determinant + det = a14*a23*a32*a41 - a13*a24*a32*a41 - a14*a22*a33*a41 + a12*a24*a33*a41 + & a13*a22*a34*a41 - a12*a23*a34*a41 - a14*a23*a31*a42 + a13*a24*a31*a42 + & a14*a21*a33*a42 - a11*a24*a33*a42 - a13*a21*a34*a42 + a11*a23*a34*a42 + & a14*a22*a31*a43 - a12*a24*a31*a43 - a14*a21*a32*a43 + a11*a24*a32*a43 + & a12*a21*a34*a43 - a11*a22*a34*a43 - a13*a22*a31*a44 + a12*a23*a31*a44 + & a13*a21*a32*a44 - a11*a23*a32*a44 - a12*a21*a33*a44 + a11*a22*a33*a44 - sqrtg = sqrt(-det) - !print*, "sqrtg: ", sqrtg - !stop - else - ! If we are not using an evolving metric then - ! Sqrtg = 1 - sqrtg = 1. - endif + sqrtg = sqrt(-det) + !print*, "sqrtg: ", sqrtg + !stop + else + ! If we are not using an evolving metric then + ! Sqrtg = 1 + sqrtg = 1. + endif end subroutine get_sqrtg subroutine get_sqrt_gamma(gcov,sqrt_gamma) - use metric, only: metric_type - real, intent(in) :: gcov(0:3,0:3) - real, intent(out) :: sqrt_gamma - real :: a11,a12,a13 - real :: a21,a22,a23 - real :: a31,a32,a33 - real :: a41,a42,a43 - real :: det - - if (metric_type == 'et') then - ! Calculate the determinant of a 3x3 matrix - ! Spatial metric is just the physical metric - ! without the tt component - - a11 = gcov(1,1) - a12 = gcov(1,2) - a13 = gcov(1,3) - a21 = gcov(2,1) - a22 = gcov(2,2) - a23 = gcov(2,3) - a31 = gcov(3,1) - a32 = gcov(3,2) - a33 = gcov(3,3) - - det = a11*(a22*a33 - a23*a32) - a12*(a21*a33 - a23*a31) + a13*(a21*a32-a22*a31) - sqrt_gamma = sqrt(det) - - else - sqrt_gamma = -1. - - endif + use metric, only: metric_type + real, intent(in) :: gcov(0:3,0:3) + real, intent(out) :: sqrt_gamma + real :: a11,a12,a13 + real :: a21,a22,a23 + real :: a31,a32,a33 + real :: a41,a42,a43 + real :: det + + if (metric_type == 'et') then + ! Calculate the determinant of a 3x3 matrix + ! Spatial metric is just the physical metric + ! without the tt component + + a11 = gcov(1,1) + a12 = gcov(1,2) + a13 = gcov(1,3) + a21 = gcov(2,1) + a22 = gcov(2,2) + a23 = gcov(2,3) + a31 = gcov(3,1) + a32 = gcov(3,2) + a33 = gcov(3,3) + + det = a11*(a22*a33 - a23*a32) - a12*(a21*a33 - a23*a31) + a13*(a21*a32-a22*a31) + sqrt_gamma = sqrt(det) + + else + sqrt_gamma = -1. + + endif end subroutine get_sqrt_gamma subroutine perturb_metric(phi,gcovper,gcov) - real, intent(in) :: phi - real, intent(out) :: gcovper(0:3,0:3) - real, optional, intent(in) :: gcov(0:3,0:3) - - - if (present(gcov)) then - gcovper = gcov - else - gcovper = 0. - gcovper(0,0) = -1. - gcovper(1,1) = 1. - gcovper(2,2) = 1. - gcovper(3,3) = 1. - endif - - ! Set the pertubed metric based on the Bardeen formulation - gcovper(0,0) = gcovper(0,0) - 2.*phi - gcovper(1,1) = gcovper(1,1) - 2.*phi - gcovper(2,2) = gcovper(2,2) - 2.*phi - gcovper(3,3) = gcovper(3,3) - 2.*phi + real, intent(in) :: phi + real, intent(out) :: gcovper(0:3,0:3) + real, optional, intent(in) :: gcov(0:3,0:3) + + + if (present(gcov)) then + gcovper = gcov + else + gcovper = 0. + gcovper(0,0) = -1. + gcovper(1,1) = 1. + gcovper(2,2) = 1. + gcovper(3,3) = 1. + endif + + ! Set the pertubed metric based on the Bardeen formulation + gcovper(0,0) = gcovper(0,0) - 2.*phi + gcovper(1,1) = gcovper(1,1) - 2.*phi + gcovper(2,2) = gcovper(2,2) - 2.*phi + gcovper(3,3) = gcovper(3,3) - 2.*phi end subroutine perturb_metric diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 95fd255eb..6dfd45049 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -42,20 +42,20 @@ module setstar ! to setup star (these are per-star, not per-simulation options) ! type star_t - integer :: iprofile - integer :: isoftcore - logical :: isinkcore - integer :: isofteningopt - integer :: np - real :: Rstar - real :: Mstar - real :: ui_coef - real :: initialtemp - real :: rcore - real :: mcore - real :: hsoft - character(len=120) :: input_profile,dens_profile - character(len=120) :: outputfilename ! outputfilename is the path to the cored profile + integer :: iprofile + integer :: isoftcore + logical :: isinkcore + integer :: isofteningopt + integer :: np + real :: Rstar + real :: Mstar + real :: ui_coef + real :: initialtemp + real :: rcore + real :: mcore + real :: hsoft + character(len=120) :: input_profile,dens_profile + character(len=120) :: outputfilename ! outputfilename is the path to the cored profile end type star_t public :: star_t diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 0740c309c..4b6e3283c 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -205,7 +205,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, select case(radiation_dominated) case('"yes"') - rhozero = rhozero - radconst*last_scattering_temp**4 + rhozero = rhozero - radconst*last_scattering_temp**4 end select xval = density_func(0.75) @@ -213,36 +213,36 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, select case(ilattice) case(2) - lattice = 'closepacked' + lattice = 'closepacked' case default - if (ilattice /= 1) print*,' error: chosen lattice not available, using cubic' - lattice = 'cubic' + if (ilattice /= 1) print*,' error: chosen lattice not available, using cubic' + lattice = 'cubic' end select - select case(perturb) - case('"yes"') - select case(perturb_direction) - !TODO Z AND Y LINEAR PERTURBATIONS - case('"x"') - call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& + select case(perturb) + case('"yes"') + select case(perturb_direction) + !TODO Z AND Y LINEAR PERTURBATIONS + case('"x"') + call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& npart,xyzh,periodic,nptot=npart_total,mask=i_belong,rhofunc=density_func) - case('"y"') - call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& + case('"y"') + call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& npart,xyzh,periodic,nptot=npart_total,mask=i_belong) - call set_density_profile(npart,xyzh,min=ymin,max=ymax,rhofunc=density_func,& + call set_density_profile(npart,xyzh,min=ymin,max=ymax,rhofunc=density_func,& geom=1,coord=2) - case('"all"') - call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& + case('"all"') + call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& npart,xyzh,periodic,nptot=npart_total,mask=i_belong,rhofunc=density_func) - call set_density_profile(npart,xyzh,min=ymin,max=ymax,rhofunc=density_func,& + call set_density_profile(npart,xyzh,min=ymin,max=ymax,rhofunc=density_func,& geom=1,coord=2) - call set_density_profile(npart,xyzh,min=zmin,max=zmax,rhofunc=density_func,& + call set_density_profile(npart,xyzh,min=zmin,max=zmax,rhofunc=density_func,& geom=1,coord=3) - end select - case('"no"') - call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& + end select + case('"no"') + call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& npart,xyzh,periodic,nptot=npart_total,mask=i_belong) - end select + end select npartoftype(:) = 0 npartoftype(1) = npart @@ -263,49 +263,49 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif do i=1,npart - select case(perturb_direction) - case ('"x"') - ! should not be zero, for a pertrubed wave - !vxyzu(1,i) = ampl*sin(kwave*(xyzh(1,i)-xmin)) - vxyzu(1,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(1,i))/lambda - phaseoffset) - phi = ampl*sin(kwave*xyzh(1,i)-phaseoffset) - Vup(1) = kwave*c3*ampl*cos(2.d0*pi*xyzh(1,i) - phaseoffset) - Vup(2:3) = 0. - call perturb_metric(phi,gcov) - call get_sqrtg(gcov,sqrtg) - - alpha = sqrt(-gcov(0,0)) - vxyzu(1,i) = Vup(1)*alpha - vxyzu(2:3,i) = 0. - case ('"y"') - vxyzu(2,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) - phi = ampl*sin(kwave*xyzh(2,i)-phaseoffset) - Vup = 0. - Vup(2) = kwave*c3*ampl*cos(2.d0*pi*xyzh(2,i) - phaseoffset) - - call perturb_metric(phi,gcov) - call get_sqrtg(gcov,sqrtg) - - alpha = sqrt(-gcov(0,0)) - vxyzu(:,i) = 0. - vxyzu(2,i) = Vup(2)*alpha - - case ('"all"') - phi = ampl*(sin(kwave*xyzh(1,i)-phaseoffset) - sin(kwave*xyzh(2,i)-phaseoffset) - sin(kwave*xyzh(3,i)-phaseoffset)) - Vup(1) = kwave*c3*ampl*cos((2.d0*pi*xyzh(1,i))/lambda - phaseoffset) - Vup(2) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) - Vup(3) = kwave*c3*ampl*cos((2.d0*pi*xyzh(3,i))/lambda - phaseoffset) - - call perturb_metric(phi,gcov) - call get_sqrtg(gcov,sqrtg) - - alpha = sqrt(-gcov(0,0)) - - ! perturb the y and z velocities - vxyzu(1,i) = Vup(1)*alpha - vxyzu(2,i) = Vup(2)*alpha - vxyzu(3,i) = Vup(3)*alpha - end select + select case(perturb_direction) + case ('"x"') + ! should not be zero, for a pertrubed wave + !vxyzu(1,i) = ampl*sin(kwave*(xyzh(1,i)-xmin)) + vxyzu(1,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(1,i))/lambda - phaseoffset) + phi = ampl*sin(kwave*xyzh(1,i)-phaseoffset) + Vup(1) = kwave*c3*ampl*cos(2.d0*pi*xyzh(1,i) - phaseoffset) + Vup(2:3) = 0. + call perturb_metric(phi,gcov) + call get_sqrtg(gcov,sqrtg) + + alpha = sqrt(-gcov(0,0)) + vxyzu(1,i) = Vup(1)*alpha + vxyzu(2:3,i) = 0. + case ('"y"') + vxyzu(2,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) + phi = ampl*sin(kwave*xyzh(2,i)-phaseoffset) + Vup = 0. + Vup(2) = kwave*c3*ampl*cos(2.d0*pi*xyzh(2,i) - phaseoffset) + + call perturb_metric(phi,gcov) + call get_sqrtg(gcov,sqrtg) + + alpha = sqrt(-gcov(0,0)) + vxyzu(:,i) = 0. + vxyzu(2,i) = Vup(2)*alpha + + case ('"all"') + phi = ampl*(sin(kwave*xyzh(1,i)-phaseoffset) - sin(kwave*xyzh(2,i)-phaseoffset) - sin(kwave*xyzh(3,i)-phaseoffset)) + Vup(1) = kwave*c3*ampl*cos((2.d0*pi*xyzh(1,i))/lambda - phaseoffset) + Vup(2) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) + Vup(3) = kwave*c3*ampl*cos((2.d0*pi*xyzh(3,i))/lambda - phaseoffset) + + call perturb_metric(phi,gcov) + call get_sqrtg(gcov,sqrtg) + + alpha = sqrt(-gcov(0,0)) + + ! perturb the y and z velocities + vxyzu(1,i) = Vup(1)*alpha + vxyzu(2,i) = Vup(2)*alpha + vxyzu(3,i) = Vup(3)*alpha + end select ! Setup the intial internal energy here? ! This should be u = aT^4/\rho ! Choose an initial temp of the cmb ~ 3000K @@ -313,18 +313,18 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Asssuming that this is constant density/pressure for now so I'm making sure that ! Note that rhozero != rho ! rhozero = rho + rho*u as this is the energy density - select case(radiation_dominated) - case('"yes"') - if (maxvxyzu >= 4 .and. gamma > 1.) vxyzu(4,i) = (radconst*(last_scattering_temp**4))/rhozero !vxyzu(4,i) = cs0**2/(gamma*(gamma-1.)) - ! Check that the pressure is correct - print*, "Pressure: ", (gamma-1)*rhozero*vxyzu(4,i) - print*, "Pressure from energy density: ", 3.d0 * hub**2 / (8.d0 * pi)/3. - print*, "Pressure 1/3 \rho u: ",radconst*(last_scattering_temp**4)/3. - end select + select case(radiation_dominated) + case('"yes"') + if (maxvxyzu >= 4 .and. gamma > 1.) vxyzu(4,i) = (radconst*(last_scattering_temp**4))/rhozero !vxyzu(4,i) = cs0**2/(gamma*(gamma-1.)) + ! Check that the pressure is correct + print*, "Pressure: ", (gamma-1)*rhozero*vxyzu(4,i) + print*, "Pressure from energy density: ", 3.d0 * hub**2 / (8.d0 * pi)/3. + print*, "Pressure 1/3 \rho u: ",radconst*(last_scattering_temp**4)/3. + end select enddo - contains +contains !---------------------------------------------------- !+ ! callback function giving desired density profile @@ -369,36 +369,36 @@ real function rhofunc(x) end function rhofunc real function massfunc(x,xmin) - use utils_gr, only:perturb_metric, get_u0, get_sqrtg - real, intent(in) :: x,xmin - real :: const, expr, exprmin, rhoprim, gcov(0:3,0:3), sqrtg,u0,v(3),Vup(3) - real :: massprimx,massprimmin,massprim - - ! The value inside the bracket - const = -kwave*kwave*c1 - 2.d0 - expr = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*x)/lambda) - exprmin = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*xmin)/lambda) - massprimx = (x-const*expr) - massprimmin = (xmin-const*exprmin) - ! Evalutation of the integral - ! rho0[x-Acos(kx)]^x_0 - massprim = rhozero*(massprimx - massprimmin) - - ! Get the perturbed 4-metric - call perturb_metric(phi,gcov) - ! Get sqrt(-det(g)) - call get_sqrtg(gcov,sqrtg) - ! Define the 3 velocities to calculate u0 - ! Three velocity will need to be converted from big V to small v - ! - Vup(1) = kwave*c3*ampl*cos((2.d0*pi*x)/lambda-phaseoffset) - Vup(2:3) = 0. - alpha = sqrt(-gcov(0,0)) - v(1) = Vup(1)*alpha - v(2:3) = 0. - - call get_u0(gcov,v,u0,ierr) - massfunc = massprim*sqrtg*u0 + use utils_gr, only:perturb_metric, get_u0, get_sqrtg + real, intent(in) :: x,xmin + real :: const, expr, exprmin, rhoprim, gcov(0:3,0:3), sqrtg,u0,v(3),Vup(3) + real :: massprimx,massprimmin,massprim + + ! The value inside the bracket + const = -kwave*kwave*c1 - 2.d0 + expr = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*x)/lambda) + exprmin = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*xmin)/lambda) + massprimx = (x-const*expr) + massprimmin = (xmin-const*exprmin) + ! Evalutation of the integral + ! rho0[x-Acos(kx)]^x_0 + massprim = rhozero*(massprimx - massprimmin) + + ! Get the perturbed 4-metric + call perturb_metric(phi,gcov) + ! Get sqrt(-det(g)) + call get_sqrtg(gcov,sqrtg) + ! Define the 3 velocities to calculate u0 + ! Three velocity will need to be converted from big V to small v + ! + Vup(1) = kwave*c3*ampl*cos((2.d0*pi*x)/lambda-phaseoffset) + Vup(2:3) = 0. + alpha = sqrt(-gcov(0,0)) + v(1) = Vup(1)*alpha + v(2:3) = 0. + + call get_u0(gcov,v,u0,ierr) + massfunc = massprim*sqrtg*u0 end function massfunc @@ -589,9 +589,9 @@ subroutine read_setupfile(filename,ierr) call close_db(db) if (nerr > 0) then - print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' - ierr = nerr -endif + print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' + ierr = nerr + endif ! ! parse units ! diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index f35f033e4..322d7cb3b 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -489,9 +489,9 @@ subroutine read_setupfile(filename,ierr) call close_db(db) if (nerr > 0) then - print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' - ierr = nerr -endif + print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' + ierr = nerr + endif ! ! parse units ! @@ -510,104 +510,104 @@ subroutine read_setupfile(filename,ierr) end subroutine read_setupfile subroutine read_veldata(velarray,vfile,gridsize) - ! TODO ERROR HANDLING?? - integer, intent(in) :: gridsize - character(len=20),intent(in) :: vfile - real,intent(out) :: velarray(:,:,:) - integer :: i,j,k - - open(unit=444,file=vfile,status='old') - do k=1,gridsize - do j=1,gridsize - read(444,*) (velarray(i,j,k), i=1, gridsize) - enddo - enddo - close(444) - print*, "Finished reading ", vfile + ! TODO ERROR HANDLING?? + integer, intent(in) :: gridsize + character(len=20),intent(in) :: vfile + real,intent(out) :: velarray(:,:,:) + integer :: i,j,k + + open(unit=444,file=vfile,status='old') + do k=1,gridsize + do j=1,gridsize + read(444,*) (velarray(i,j,k), i=1, gridsize) + enddo + enddo + close(444) + print*, "Finished reading ", vfile end subroutine read_veldata subroutine interpolate_val(position,valgrid,gridsize,gridorigin,dxgrid,val) - ! Subroutine to interpolate quanities to particle positions given a cube - ! Note we have assumed that the grid will always be cubic!!!! - use eos_shen, only:linear_interpolator_one_d - real, intent(in) :: valgrid(:,:,:) - real, intent(inout) :: position(3) - real, intent(inout) :: dxgrid,gridorigin - integer, intent(in) :: gridsize - real, intent(out) :: val - integer :: xupper,yupper,zupper,xlower,ylower,zlower - real :: xlowerpos,ylowerpos,zlowerpos,xupperpos,yupperpos,zupperpos - real :: interptmp(7) - real :: xd,yd,zd - - - - call get_grid_neighbours(position,gridorigin,dxgrid,xlower,ylower,zlower) - - print*,"Neighbours: ", xlower,ylower,zlower - print*,"Position: ", position - ! This is not true as upper neighbours on the boundary will be on the side - ! take a mod of grid size - xupper = mod(xlower + 1, gridsize) - yupper = mod(ylower + 1, gridsize) - zupper = mod(zlower + 1, gridsize) - ! xupper - xlower should always just be dx provided we are using a uniform grid - ! xd = (position(1) - xlower)/(xupper - xlower) - ! yd = (position(2) - ylower)/(yupper - ylower) - ! zd = (position(3) - zlower)/(zupper - zlower) - xlowerpos = gridorigin + (xlower-1)*dxgrid - ylowerpos = gridorigin + (ylower-1)*dxgrid - zlowerpos = gridorigin + (zlower-1)*dxgrid - - xd = (position(1) - xlowerpos)/(dxgrid) - yd = (position(2) - ylowerpos)/(dxgrid) - zd = (position(3) - zlowerpos)/(dxgrid) - - interptmp = 0. - - call linear_interpolator_one_d(valgrid(xlower,ylower,zlower), & + ! Subroutine to interpolate quanities to particle positions given a cube + ! Note we have assumed that the grid will always be cubic!!!! + use eos_shen, only:linear_interpolator_one_d + real, intent(in) :: valgrid(:,:,:) + real, intent(inout) :: position(3) + real, intent(inout) :: dxgrid,gridorigin + integer, intent(in) :: gridsize + real, intent(out) :: val + integer :: xupper,yupper,zupper,xlower,ylower,zlower + real :: xlowerpos,ylowerpos,zlowerpos,xupperpos,yupperpos,zupperpos + real :: interptmp(7) + real :: xd,yd,zd + + + + call get_grid_neighbours(position,gridorigin,dxgrid,xlower,ylower,zlower) + + print*,"Neighbours: ", xlower,ylower,zlower + print*,"Position: ", position + ! This is not true as upper neighbours on the boundary will be on the side + ! take a mod of grid size + xupper = mod(xlower + 1, gridsize) + yupper = mod(ylower + 1, gridsize) + zupper = mod(zlower + 1, gridsize) + ! xupper - xlower should always just be dx provided we are using a uniform grid + ! xd = (position(1) - xlower)/(xupper - xlower) + ! yd = (position(2) - ylower)/(yupper - ylower) + ! zd = (position(3) - zlower)/(zupper - zlower) + xlowerpos = gridorigin + (xlower-1)*dxgrid + ylowerpos = gridorigin + (ylower-1)*dxgrid + zlowerpos = gridorigin + (zlower-1)*dxgrid + + xd = (position(1) - xlowerpos)/(dxgrid) + yd = (position(2) - ylowerpos)/(dxgrid) + zd = (position(3) - zlowerpos)/(dxgrid) + + interptmp = 0. + + call linear_interpolator_one_d(valgrid(xlower,ylower,zlower), & valgrid(xlower+1,ylower,zlower),xd,interptmp(1)) - call linear_interpolator_one_d(valgrid(xlower,ylower,zlower+1), & + call linear_interpolator_one_d(valgrid(xlower,ylower,zlower+1), & valgrid(xlower+1,ylower,zlower+1),xd,interptmp(2)) - call linear_interpolator_one_d(valgrid(xlower,ylower+1,zlower), & + call linear_interpolator_one_d(valgrid(xlower,ylower+1,zlower), & valgrid(xlower+1,ylower+1,zlower),xd,interptmp(3)) - call linear_interpolator_one_d(valgrid(xlower,ylower+1,zlower+1), & + call linear_interpolator_one_d(valgrid(xlower,ylower+1,zlower+1), & valgrid(xlower+1,ylower+1,zlower+1),xd,interptmp(4)) - ! Interpolate along y - call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) - call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) - ! Interpolate along z - call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) + ! Interpolate along y + call linear_interpolator_one_d(interptmp(1),interptmp(3),yd,interptmp(5)) + call linear_interpolator_one_d(interptmp(2),interptmp(4),yd,interptmp(6)) + ! Interpolate along z + call linear_interpolator_one_d(interptmp(5),interptmp(6),zd,interptmp(7)) - val = interptmp(7) + val = interptmp(7) end subroutine interpolate_val subroutine get_grid_neighbours(position,gridorigin,dx,xlower,ylower,zlower) - ! TODO IDEALLY THIS SHOULDN'T BE HERE AND SHOULD BE IN A UTILS MODULE - ! WITH THE VERSION USED IN METRIC_ET - real, intent(in) :: position(3), gridorigin - real, intent(in) :: dx - integer, intent(out) :: xlower,ylower,zlower - - ! Get the lower grid neighbours of the position - ! If this is broken change from floor to int - ! How are we handling the edge case of a particle being - ! in exactly the same position as the grid? - ! Hopefully having different grid sizes in each direction - ! Doesn't break the lininterp - xlower = floor((position(1)-gridorigin)/dx) - print*, "pos x: ", position(1) - print*, "gridorigin: ", gridorigin - print*, "dx: ", dx - ylower = floor((position(2)-gridorigin)/dx) - zlower = floor((position(3)-gridorigin)/dx) - - ! +1 because fortran - xlower = xlower + 1 - ylower = ylower + 1 - zlower = zlower + 1 + ! TODO IDEALLY THIS SHOULDN'T BE HERE AND SHOULD BE IN A UTILS MODULE + ! WITH THE VERSION USED IN METRIC_ET + real, intent(in) :: position(3), gridorigin + real, intent(in) :: dx + integer, intent(out) :: xlower,ylower,zlower + + ! Get the lower grid neighbours of the position + ! If this is broken change from floor to int + ! How are we handling the edge case of a particle being + ! in exactly the same position as the grid? + ! Hopefully having different grid sizes in each direction + ! Doesn't break the lininterp + xlower = floor((position(1)-gridorigin)/dx) + print*, "pos x: ", position(1) + print*, "gridorigin: ", gridorigin + print*, "dx: ", dx + ylower = floor((position(2)-gridorigin)/dx) + zlower = floor((position(3)-gridorigin)/dx) + + ! +1 because fortran + xlower = xlower + 1 + ylower = ylower + 1 + zlower = zlower + 1 end subroutine get_grid_neighbours diff --git a/src/setup/stretchmap.f90 b/src/setup/stretchmap.f90 index 9b4c7588d..bb0e92fa1 100644 --- a/src/setup/stretchmap.f90 +++ b/src/setup/stretchmap.f90 @@ -188,7 +188,7 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,massfunc,rhotab,xtab,star elseif (is_rcyl) then totmass = get_mass_rcyl(rhofunc,xmax,xmin) elseif (use_massfunc) then - totmass = massfunc(xmax,min) + totmass = massfunc(xmax,min) else totmass = get_mass(rhofunc,xmax,xmin) endif @@ -282,8 +282,8 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,massfunc,rhotab,xtab,star func = get_mass_rcyl(rhofunc,xi,xmin) - fracmassold dfunc = 2.*pi*xi*rhofunc(xi) elseif (use_massfunc) then - func = massfunc(xi,xmin) - fracmassold - dfunc = rhofunc(xi) + func = massfunc(xi,xmin) - fracmassold + dfunc = rhofunc(xi) else func = get_mass(rhofunc,xi,xmin) - fracmassold dfunc = rhofunc(xi) diff --git a/src/utils/analysis_BRhoOrientation.F90 b/src/utils/analysis_BRhoOrientation.F90 index 1a43e06f9..85de0a47c 100644 --- a/src/utils/analysis_BRhoOrientation.F90 +++ b/src/utils/analysis_BRhoOrientation.F90 @@ -238,7 +238,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) r = r + 1 enddo do while (absV > vbins(l) .and. l < nbins) - l = l + 1 + l = l + 1 enddo ! Binning particles (B-costheta, rho-costheta, rho-B plane and by orientation) @@ -246,9 +246,9 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) cost(t) = cost(t) + 1 if (b < nbins) then thetB(t,b) = thetB(t,b) + 1 - if (r < nbins) then - !-- Binning by orientation, perpendicular, parallel and mixed - not being used - if (costheta > 0.0 .and. costheta < 0.4) then + if (r < nbins) then + !-- Binning by orientation, perpendicular, parallel and mixed - not being used + if (costheta > 0.0 .and. costheta < 0.4) then perpavg(b,r) = perpavg(b,r) + costheta perpi(b,r) = perpi(b,r) + 1 endif @@ -380,7 +380,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) write(iunit,'((1pe18.10,1x),(I18,1x),(1pe18.10,1x),(I18,1x))') vtbins(i), vcost(i), costbins(i), cost(i) enddo close(iunit) - end subroutine do_analysis +end subroutine do_analysis !----------------------------------------------------------------------- end module analysis diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index 428b73060..b6ac8d4c5 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -16,196 +16,196 @@ module einsteintk_utils ! ! :Dependencies: part ! - implicit none - real, allocatable :: gcovgrid(:,:,:,:,:) - real, allocatable :: gcongrid(:,:,:,:,:) - real, allocatable :: sqrtggrid(:,:,:) - real, allocatable :: tmunugrid(:,:,:,:,:) - real, allocatable :: rhostargrid(:,:,:) - real, allocatable :: pxgrid(:,:,:,:) - real, allocatable :: entropygrid(:,:,:) - real, allocatable :: metricderivsgrid(:,:,:,:,:,:) - real :: dxgrid(3), gridorigin(3), boundsize(3) - integer :: gridsize(3) - logical :: gridinit = .false. - logical :: exact_rendering - character(len=128) :: logfilestor,evfilestor,dumpfilestor,infilestor + implicit none + real, allocatable :: gcovgrid(:,:,:,:,:) + real, allocatable :: gcongrid(:,:,:,:,:) + real, allocatable :: sqrtggrid(:,:,:) + real, allocatable :: tmunugrid(:,:,:,:,:) + real, allocatable :: rhostargrid(:,:,:) + real, allocatable :: pxgrid(:,:,:,:) + real, allocatable :: entropygrid(:,:,:) + real, allocatable :: metricderivsgrid(:,:,:,:,:,:) + real :: dxgrid(3), gridorigin(3), boundsize(3) + integer :: gridsize(3) + logical :: gridinit = .false. + logical :: exact_rendering + character(len=128) :: logfilestor,evfilestor,dumpfilestor,infilestor contains - subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) - integer, intent(in) :: nx,ny,nz - real, intent(in) :: dx,dy,dz,originx,originy,originz +subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) + integer, intent(in) :: nx,ny,nz + real, intent(in) :: dx,dy,dz,originx,originy,originz - gridsize(1) = nx - gridsize(2) = ny - gridsize(3) = nz + gridsize(1) = nx + gridsize(2) = ny + gridsize(3) = nz - dxgrid(1) = dx - dxgrid(2) = dy - dxgrid(3) = dz + dxgrid(1) = dx + dxgrid(2) = dy + dxgrid(3) = dz - gridorigin(1) = originx - gridorigin(2) = originy - gridorigin(3) = originz + gridorigin(1) = originx + gridorigin(2) = originy + gridorigin(3) = originz - allocate(gcovgrid(0:3,0:3,nx,ny,nz)) - allocate(gcongrid(0:3,0:3,nx,ny,nz)) - allocate(sqrtggrid(nx,ny,nz)) + allocate(gcovgrid(0:3,0:3,nx,ny,nz)) + allocate(gcongrid(0:3,0:3,nx,ny,nz)) + allocate(sqrtggrid(nx,ny,nz)) - ! Will need to delete this at somepoint - ! For now it is the simplest way - allocate(tmunugrid(0:3,0:3,nx,ny,nz)) + ! Will need to delete this at somepoint + ! For now it is the simplest way + allocate(tmunugrid(0:3,0:3,nx,ny,nz)) - allocate(pxgrid(3,nx,ny,nz)) + allocate(pxgrid(3,nx,ny,nz)) - allocate(rhostargrid(nx,ny,nz)) + allocate(rhostargrid(nx,ny,nz)) - ! TODO Toggle for this to save memory - allocate(entropygrid(nx,ny,nz)) + ! TODO Toggle for this to save memory + allocate(entropygrid(nx,ny,nz)) - ! metric derivs are stored in the form - ! mu comp, nu comp, deriv, gridx,gridy,gridz - ! Note that this is only the spatial derivs of - ! the metric and we will need an additional array - ! for time derivs - allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) + ! metric derivs are stored in the form + ! mu comp, nu comp, deriv, gridx,gridy,gridz + ! Note that this is only the spatial derivs of + ! the metric and we will need an additional array + ! for time derivs + allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) - gridinit = .true. - !exact_rendering = exact + gridinit = .true. + !exact_rendering = exact - end subroutine init_etgrid +end subroutine init_etgrid - subroutine print_etgrid() - ! Subroutine for printing quantities of the ET grid +subroutine print_etgrid() + ! Subroutine for printing quantities of the ET grid - print*, "Grid spacing (x,y,z) is : ", dxgrid - print*, "Grid origin (x,y,z) is: ", gridorigin - print*, "Covariant metric tensor of the grid is: ", gcovgrid(:,:,1,1,1) + print*, "Grid spacing (x,y,z) is : ", dxgrid + print*, "Grid origin (x,y,z) is: ", gridorigin + print*, "Covariant metric tensor of the grid is: ", gcovgrid(:,:,1,1,1) - end subroutine print_etgrid +end subroutine print_etgrid - subroutine get_particle_rhs(i,vx,vy,vz,fx,fy,fz,e_rhs) - use part, only: vxyzu,fxyzu,fext - integer, intent(in) :: i - real, intent(out) :: vx,vy,vz,fx,fy,fz,e_rhs +subroutine get_particle_rhs(i,vx,vy,vz,fx,fy,fz,e_rhs) + use part, only: vxyzu,fxyzu,fext + integer, intent(in) :: i + real, intent(out) :: vx,vy,vz,fx,fy,fz,e_rhs - !vxyz - vx = vxyzu(1,i) - vy = vxyzu(2,i) - vz = vxyzu(3,i) + !vxyz + vx = vxyzu(1,i) + vy = vxyzu(2,i) + vz = vxyzu(3,i) - ! dp/dt - !print*, "fext: ", fext(:,i) - !print*, "fxyzu: ", fxyzu(:,i) - !fx = fxyzu(1,i) + fext(1,i) - !print*, "fx: ", fx - !fy = fxyzu(2,i) + fext(2,i) - !fz = fxyzu(3,i) + fext(3,i) - fx = fext(1,i) - fy = fext(2,i) - fz = fext(3,i) + ! dp/dt + !print*, "fext: ", fext(:,i) + !print*, "fxyzu: ", fxyzu(:,i) + !fx = fxyzu(1,i) + fext(1,i) + !print*, "fx: ", fx + !fy = fxyzu(2,i) + fext(2,i) + !fz = fxyzu(3,i) + fext(3,i) + fx = fext(1,i) + fy = fext(2,i) + fz = fext(3,i) - ! de/dt - e_rhs = 0. + ! de/dt + e_rhs = 0. - end subroutine get_particle_rhs +end subroutine get_particle_rhs - subroutine get_particle_val(i,x,y,z,px,py,pz,e) - use part, only: xyzh, pxyzu - integer, intent(in) :: i - real, intent(out) :: x,y,z,px,py,pz,e +subroutine get_particle_val(i,x,y,z,px,py,pz,e) + use part, only: xyzh, pxyzu + integer, intent(in) :: i + real, intent(out) :: x,y,z,px,py,pz,e - !xyz - x = xyzh(1,i) - y = xyzh(2,i) - z = xyzh(3,i) + !xyz + x = xyzh(1,i) + y = xyzh(2,i) + z = xyzh(3,i) - ! p - px = pxyzu(1,i) - py = pxyzu(2,i) - pz = pxyzu(3,i) + ! p + px = pxyzu(1,i) + py = pxyzu(2,i) + pz = pxyzu(3,i) - ! e - ! ??? - e = pxyzu(4,i) + ! e + ! ??? + e = pxyzu(4,i) - end subroutine get_particle_val +end subroutine get_particle_val - subroutine set_particle_val(i,x,y,z,px,py,pz,e) - use part, only: xyzh, pxyzu - integer, intent(in) :: i - real, intent(in) :: x,y,z,px,py,pz,e - ! Subroutine for setting the particle values in phantom - ! using the values stored in einstein toolkit before a dump +subroutine set_particle_val(i,x,y,z,px,py,pz,e) + use part, only: xyzh, pxyzu + integer, intent(in) :: i + real, intent(in) :: x,y,z,px,py,pz,e + ! Subroutine for setting the particle values in phantom + ! using the values stored in einstein toolkit before a dump - !xyz - xyzh(1,i) = x - xyzh(2,i) = y - xyzh(3,i) = z + !xyz + xyzh(1,i) = x + xyzh(2,i) = y + xyzh(3,i) = z - ! p - pxyzu(1,i) = px - pxyzu(2,i) = py - pxyzu(3,i) = pz - pxyzu(4,i) = e + ! p + pxyzu(1,i) = px + pxyzu(2,i) = py + pxyzu(3,i) = pz + pxyzu(4,i) = e - end subroutine set_particle_val +end subroutine set_particle_val - subroutine get_phantom_dt(dtout) - use part, only:xyzh - real, intent(out) :: dtout - real, parameter :: safety_fac = 0.2 - real :: minh +subroutine get_phantom_dt(dtout) + use part, only:xyzh + real, intent(out) :: dtout + real, parameter :: safety_fac = 0.2 + real :: minh - ! Get the smallest smoothing length - minh = minval(xyzh(4,:)) + ! Get the smallest smoothing length + minh = minval(xyzh(4,:)) - ! Courant esque condition from Rosswog 2021+ - ! Since c is allways one in our units - dtout = safety_fac*minh - print*, "dtout phantom: ", dtout + ! Courant esque condition from Rosswog 2021+ + ! Since c is allways one in our units + dtout = safety_fac*minh + print*, "dtout phantom: ", dtout - end subroutine get_phantom_dt +end subroutine get_phantom_dt - subroutine set_rendering(flag) - logical, intent(in) :: flag +subroutine set_rendering(flag) + logical, intent(in) :: flag - exact_rendering = flag + exact_rendering = flag - end subroutine set_rendering - - ! Do I move this to tmunu2grid?? - ! I think yes - - - ! Moved to einsteintk_wrapper.f90 to fix dependency issues - - ! subroutine get_metricderivs_all(dtextforce_min) - ! use part, only:npart, xyzh,vxyzu,metrics,metricderivs,dens,fext - ! use timestep, only:bignumber,C_force - ! use extern_gr, only:get_grforce - ! use metric_tools, only:pack_metricderivs - ! real, intent(out) :: dtextforce_min - ! integer :: i - ! real :: pri,dtf - - ! pri = 0. - ! dtextforce_min = bignumber - - ! !$omp parallel do default(none) & - ! !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & - ! !$omp firstprivate(pri) & - ! !$omp private(i,dtf) & - ! !$omp reduction(min:dtextforce_min) - ! do i=1, npart - ! call pack_metricderivs(xyzh(1:3,i),metricderivs(:,:,:,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) - ! dtextforce_min = min(dtextforce_min,C_force*dtf) - ! enddo - ! !$omp end parallel do - ! end subroutine get_metricderivs_all +end subroutine set_rendering + + ! Do I move this to tmunu2grid?? + ! I think yes + + + ! Moved to einsteintk_wrapper.f90 to fix dependency issues + + ! subroutine get_metricderivs_all(dtextforce_min) + ! use part, only:npart, xyzh,vxyzu,metrics,metricderivs,dens,fext + ! use timestep, only:bignumber,C_force + ! use extern_gr, only:get_grforce + ! use metric_tools, only:pack_metricderivs + ! real, intent(out) :: dtextforce_min + ! integer :: i + ! real :: pri,dtf + + ! pri = 0. + ! dtextforce_min = bignumber + + ! !$omp parallel do default(none) & + ! !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & + ! !$omp firstprivate(pri) & + ! !$omp private(i,dtf) & + ! !$omp reduction(min:dtextforce_min) + ! do i=1, npart + ! call pack_metricderivs(xyzh(1:3,i),metricderivs(:,:,:,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) + ! dtextforce_min = min(dtextforce_min,C_force*dtf) + ! enddo + ! !$omp end parallel do + ! end subroutine get_metricderivs_all end module einsteintk_utils diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 182a1fd82..7bf75f86e 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -18,514 +18,514 @@ module einsteintk_wrapper ! extern_gr, fileutils, initial, io, linklist, metric, metric_tools, ! mpiutils, part, readwrite_dumps, timestep, tmunu2grid ! - implicit none - contains - - subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) - ! Wrapper that intialises phantom - ! Intended to hide all of the inner works of phantom from ET - ! Majority of the code from HelloHydro_init has been moved here - - use io, only:id,master,nprocs,set_io_unit_numbers,die - use mpiutils, only:init_mpi,finalise_mpi - use initial, only:initialise,finalise,startrun,endrun - !use evolve, only:evol_init - use tmunu2grid - use einsteintk_utils - use extern_gr - use metric - use part, only:xyzh,pxyzu,vxyzu,dens,metricderivs, metrics, npart, tmunus - - - implicit none - character(len=*), intent(in) :: infilestart - real, intent(in) :: dt_et - integer, intent(inout) :: nophantompart - real, intent(out) :: dtout - !character(len=500) :: logfile,evfile,dumpfile,path - integer :: i,j,k,pathstringlength - integer :: xlower,ylower,zlower,xupper,yupper,zupper - real :: pos(3), gcovpart(0:3,0:3) - !real :: dtout - - ! For now we just hardcode the infile, to see if startrun actually works! - ! I'm not sure what the best way to actually do this is? - ! Do we store the phantom.in file in par and have it read from there? - !infile = "/Users/spencer/phantomET/phantom/test/flrw.in" - !infile = trim(infile)//'.in' - !print*, "phantom_path: ", phantom_path - !infile = phantom_path // "flrw.in" - !infile = trim(path) // "flrw.in" - !infile = 'flrw.in' - !infile = trim(infile) - !print*, "Phantom path is: ", path - !print*, "Infile is: ", infile - ! Use system call to copy phantom files to simulation directory - ! This is a digusting temporary fix - !call SYSTEM('cp ~/phantomET/phantom/test/flrw* ./') - - ! The infile from ET - infilestor = infilestart - - ! We should do everything that is done in phantom.f90 - - ! Setup mpi - id=0 - call init_mpi(id,nprocs) - ! setup io - call set_io_unit_numbers - ! routine that starts a phantom run - print*, "Start run called!" - ! Do we want to pass dt in here?? - call startrun(infilestor,logfilestor,evfilestor,dumpfilestor) - print*, "Start run finished!" - !print*, "tmunugrid: ", tmunugrid(1,1,6,6,6) - !stop - ! Intialises values for the evol routine: t, dt, etc.. - !call evol_init(infilestor,logfilestor,evfilestor,dumpfilestor,dt_et,nophantompart) - !print*, "Evolve init finished!" - nophantompart = npart - ! Calculate the stress energy tensor for each particle - ! Might be better to do this in evolve init - !call get_tmunugrid_all - ! Calculate the stress energy tensor - call get_metricderivs_all(dtout,dt_et) ! commented out to try and fix prim2cons - !call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) ! commented out to try and fix prim2cons - !call get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - ! Interpolate stress energy tensor from particles back - ! to grid - !call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac=.true.) ! commented out to try and fix cons2prim - - call get_phantom_dt(dtout) - - print*,"pxyzu: ", pxyzu(:,1) - - end subroutine init_et2phantom - - subroutine init_et2phantomgrid(nx,ny,nz,originx,originy,originz,dx,dy,dz) - use einsteintk_utils - integer, intent(in) :: nx,ny,nz ! The maximum values of the grid in each dimension - real(8), intent(in) :: originx, originy, originz ! The origin of grid - real(8), intent(in) :: dx, dy, dz ! Grid spacing in each dimension - !integer, intent(in) :: boundsizex, boundsizey, boundsizez - - ! Setup metric grid - call init_etgrid(nx,ny,nz,originx,originy,originz,dx,dy,dz) - - end subroutine init_et2phantomgrid - - subroutine init_phantom2et() - ! Subroutine - end subroutine init_phantom2et - - subroutine et2phantom(rho,nx,ny,nz) - integer, intent(in) :: nx, ny, nz - real, intent(in) :: rho(nx,ny,nz) - - print*, "Grid limits: ", nx, ny, nz - ! get mpi thread number - ! send grid limits - end subroutine et2phantom - - ! DONT THINK THIS IS USED ANYWHERE!!! - ! subroutine step_et2phantom(infile,dt_et) - ! use einsteintk_utils - ! use evolve, only:evol_step - ! use tmunu2grid - ! character(len=*), intent(in) :: infile - ! real, intent(inout) :: dt_et - ! character(len=500) :: logfile,evfile,dumpfile,path - - - ! ! Print the values of logfile, evfile, dumpfile to check they are sensible - ! !print*, "logfile, evfile, dumpfile: ", logfile, evfile, dumpfile - ! print*, "stored values of logfile, evfile, dumpfile: ", logfilestor, evfilestor, dumpfilestor - - ! ! Interpolation stuff - ! ! Call et2phantom (construct global grid, metric, metric derivs, determinant) - ! ! Run phantom for a step - ! call evol_step(infile,logfilestor,evfilestor,dumpfilestor,dt_et) - ! ! Interpolation stuff back to et - ! !call get_tmunugrid_all() - ! ! call phantom2et (Tmunu_grid) - - ! end subroutine step_et2phantom - - subroutine phantom2et() - ! should take in the cctk_array for tmunu?? - ! Is it better if this routine is just - ! Calculate stress energy tensor for each particle - - ! Perform kernel interpolation from particles to grid positions - - end subroutine phantom2et - - subroutine step_et2phantom_MoL(infile,dt_et,dtout) - use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars - use cons2prim, only: cons2primall - use deriv - use extern_gr - use tmunu2grid - use einsteintk_utils, only: get_phantom_dt,gcovgrid - character(len=*), intent(in) :: infile - real, intent(inout) :: dt_et - real, intent(out) :: dtout - real :: vbefore,vafter - - ! Metric should have already been passed in - ! and interpolated - ! Call get_derivs global - call get_derivs_global - - ! Get metric derivs - call get_metricderivs_all(dtout,dt_et) - ! Store our particle quantities somewhere / send them to ET - ! Cons2prim after moving the particles with the external force - vbefore = vxyzu(1,1) - call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) - vafter = vxyzu(1,1) - - ! Does get_derivs_global perform a stress energy calc?? - ! If not do that here - - ! Perform the calculation of the stress energy tensor - ! Interpolate the stress energy tensor back to the ET grid! - ! Calculate the stress energy tensor - ! Interpolate stress energy tensor from particles back - ! to grid - call get_phantom_dt(dtout) - - - end subroutine step_et2phantom_MoL - - subroutine et2phantom_tmunu() - use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& + implicit none +contains + +subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) + ! Wrapper that intialises phantom + ! Intended to hide all of the inner works of phantom from ET + ! Majority of the code from HelloHydro_init has been moved here + + use io, only:id,master,nprocs,set_io_unit_numbers,die + use mpiutils, only:init_mpi,finalise_mpi + use initial, only:initialise,finalise,startrun,endrun + !use evolve, only:evol_init + use tmunu2grid + use einsteintk_utils + use extern_gr + use metric + use part, only:xyzh,pxyzu,vxyzu,dens,metricderivs, metrics, npart, tmunus + + + implicit none + character(len=*), intent(in) :: infilestart + real, intent(in) :: dt_et + integer, intent(inout) :: nophantompart + real, intent(out) :: dtout + !character(len=500) :: logfile,evfile,dumpfile,path + integer :: i,j,k,pathstringlength + integer :: xlower,ylower,zlower,xupper,yupper,zupper + real :: pos(3), gcovpart(0:3,0:3) + !real :: dtout + + ! For now we just hardcode the infile, to see if startrun actually works! + ! I'm not sure what the best way to actually do this is? + ! Do we store the phantom.in file in par and have it read from there? + !infile = "/Users/spencer/phantomET/phantom/test/flrw.in" + !infile = trim(infile)//'.in' + !print*, "phantom_path: ", phantom_path + !infile = phantom_path // "flrw.in" + !infile = trim(path) // "flrw.in" + !infile = 'flrw.in' + !infile = trim(infile) + !print*, "Phantom path is: ", path + !print*, "Infile is: ", infile + ! Use system call to copy phantom files to simulation directory + ! This is a digusting temporary fix + !call SYSTEM('cp ~/phantomET/phantom/test/flrw* ./') + + ! The infile from ET + infilestor = infilestart + + ! We should do everything that is done in phantom.f90 + + ! Setup mpi + id=0 + call init_mpi(id,nprocs) + ! setup io + call set_io_unit_numbers + ! routine that starts a phantom run + print*, "Start run called!" + ! Do we want to pass dt in here?? + call startrun(infilestor,logfilestor,evfilestor,dumpfilestor) + print*, "Start run finished!" + !print*, "tmunugrid: ", tmunugrid(1,1,6,6,6) + !stop + ! Intialises values for the evol routine: t, dt, etc.. + !call evol_init(infilestor,logfilestor,evfilestor,dumpfilestor,dt_et,nophantompart) + !print*, "Evolve init finished!" + nophantompart = npart + ! Calculate the stress energy tensor for each particle + ! Might be better to do this in evolve init + !call get_tmunugrid_all + ! Calculate the stress energy tensor + call get_metricderivs_all(dtout,dt_et) ! commented out to try and fix prim2cons + !call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) ! commented out to try and fix prim2cons + !call get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + ! Interpolate stress energy tensor from particles back + ! to grid + !call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac=.true.) ! commented out to try and fix cons2prim + + call get_phantom_dt(dtout) + + print*,"pxyzu: ", pxyzu(:,1) + +end subroutine init_et2phantom + +subroutine init_et2phantomgrid(nx,ny,nz,originx,originy,originz,dx,dy,dz) + use einsteintk_utils + integer, intent(in) :: nx,ny,nz ! The maximum values of the grid in each dimension + real(8), intent(in) :: originx, originy, originz ! The origin of grid + real(8), intent(in) :: dx, dy, dz ! Grid spacing in each dimension + !integer, intent(in) :: boundsizex, boundsizey, boundsizez + + ! Setup metric grid + call init_etgrid(nx,ny,nz,originx,originy,originz,dx,dy,dz) + +end subroutine init_et2phantomgrid + +subroutine init_phantom2et() + ! Subroutine +end subroutine init_phantom2et + +subroutine et2phantom(rho,nx,ny,nz) + integer, intent(in) :: nx, ny, nz + real, intent(in) :: rho(nx,ny,nz) + + print*, "Grid limits: ", nx, ny, nz + ! get mpi thread number + ! send grid limits +end subroutine et2phantom + + ! DONT THINK THIS IS USED ANYWHERE!!! + ! subroutine step_et2phantom(infile,dt_et) + ! use einsteintk_utils + ! use evolve, only:evol_step + ! use tmunu2grid + ! character(len=*), intent(in) :: infile + ! real, intent(inout) :: dt_et + ! character(len=500) :: logfile,evfile,dumpfile,path + + + ! ! Print the values of logfile, evfile, dumpfile to check they are sensible + ! !print*, "logfile, evfile, dumpfile: ", logfile, evfile, dumpfile + ! print*, "stored values of logfile, evfile, dumpfile: ", logfilestor, evfilestor, dumpfilestor + + ! ! Interpolation stuff + ! ! Call et2phantom (construct global grid, metric, metric derivs, determinant) + ! ! Run phantom for a step + ! call evol_step(infile,logfilestor,evfilestor,dumpfilestor,dt_et) + ! ! Interpolation stuff back to et + ! !call get_tmunugrid_all() + ! ! call phantom2et (Tmunu_grid) + + ! end subroutine step_et2phantom + +subroutine phantom2et() + ! should take in the cctk_array for tmunu?? + ! Is it better if this routine is just + ! Calculate stress energy tensor for each particle + + ! Perform kernel interpolation from particles to grid positions + +end subroutine phantom2et + +subroutine step_et2phantom_MoL(infile,dt_et,dtout) + use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars + use cons2prim, only: cons2primall + use deriv + use extern_gr + use tmunu2grid + use einsteintk_utils, only: get_phantom_dt,gcovgrid + character(len=*), intent(in) :: infile + real, intent(inout) :: dt_et + real, intent(out) :: dtout + real :: vbefore,vafter + + ! Metric should have already been passed in + ! and interpolated + ! Call get_derivs global + call get_derivs_global + + ! Get metric derivs + call get_metricderivs_all(dtout,dt_et) + ! Store our particle quantities somewhere / send them to ET + ! Cons2prim after moving the particles with the external force + vbefore = vxyzu(1,1) + call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + vafter = vxyzu(1,1) + + ! Does get_derivs_global perform a stress energy calc?? + ! If not do that here + + ! Perform the calculation of the stress energy tensor + ! Interpolate the stress energy tensor back to the ET grid! + ! Calculate the stress energy tensor + ! Interpolate stress energy tensor from particles back + ! to grid + call get_phantom_dt(dtout) + + +end subroutine step_et2phantom_MoL + +subroutine et2phantom_tmunu() + use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,& dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol,tmunus,metricderivs,& massoftype,igas,rhoh,alphaind,dvdx,gradh - !use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars - use cons2prim, only: cons2primall - use deriv - use extern_gr - use tmunu2grid - use einsteintk_utils, only: get_phantom_dt,gcovgrid,rhostargrid,tmunugrid - use metric_tools, only:init_metric - use densityforce, only:densityiterate - use linklist, only:set_linklist - - real :: stressmax - real(kind=16) :: cfac - - stressmax = 0. - - ! Also probably need to pack the metric before I call things - call init_metric(npart,xyzh,metrics) - ! Might be better to just do this in get derivs global with a number 2 call? - ! Rebuild the tree - call set_linklist(npart,npart,xyzh,vxyzu) - ! Apparently init metric needs to be called again??? - !call init_metric(npart,xyzh,metrics) - ! Calculate the cons density - call densityiterate(1,npart,npart,xyzh,vxyzu,divcurlv,divcurlB,Bevol,& + !use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars + use cons2prim, only: cons2primall + use deriv + use extern_gr + use tmunu2grid + use einsteintk_utils, only: get_phantom_dt,gcovgrid,rhostargrid,tmunugrid + use metric_tools, only:init_metric + use densityforce, only:densityiterate + use linklist, only:set_linklist + + real :: stressmax + real(kind=16) :: cfac + + stressmax = 0. + + ! Also probably need to pack the metric before I call things + call init_metric(npart,xyzh,metrics) + ! Might be better to just do this in get derivs global with a number 2 call? + ! Rebuild the tree + call set_linklist(npart,npart,xyzh,vxyzu) + ! Apparently init metric needs to be called again??? + !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) - ! Get primative variables for tmunu - call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + ! Get primative variables for tmunu + call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) - call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - ! Interpolate stress energy tensor from particles back - ! to grid - call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) + call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + ! Interpolate stress energy tensor from particles back + ! to grid + call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) - ! Interpolate density to grid - call phantom2et_rhostar + ! Interpolate density to grid + call phantom2et_rhostar - ! Density check vs particles - call check_conserved_dens(rhostargrid,cfac) + ! Density check vs particles + call check_conserved_dens(rhostargrid,cfac) - ! Correct Tmunu - tmunugrid = cfac*tmunugrid + ! Correct Tmunu + tmunugrid = cfac*tmunugrid - end subroutine et2phantom_tmunu +end subroutine et2phantom_tmunu - subroutine phantom2et_consvar() - use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& +subroutine phantom2et_consvar() + use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,& dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol,tmunus,metricderivs,& massoftype,igas,rhoh,alphaind,dvdx,gradh - use densityforce, only:densityiterate - use metric_tools, only:init_metric - use linklist, only:set_linklist - use einsteintk_utils, only:rhostargrid,pxgrid,entropygrid - use tmunu2grid, only:check_conserved_dens - - real :: stressmax - real(kind=16) :: cfac - - ! Init metric - call init_metric(npart,xyzh,metrics) - - ! Might be better to just do this in get derivs global with a number 2 call? - ! Rebuild the tree - call set_linklist(npart,npart,xyzh,vxyzu) - ! Apparently init metric needs to be called again??? - call init_metric(npart,xyzh,metrics) - ! Calculate the cons density - call densityiterate(1,npart,npart,xyzh,vxyzu,divcurlv,divcurlB,Bevol,& + use densityforce, only:densityiterate + use metric_tools, only:init_metric + use linklist, only:set_linklist + use einsteintk_utils, only:rhostargrid,pxgrid,entropygrid + use tmunu2grid, only:check_conserved_dens + + real :: stressmax + real(kind=16) :: cfac + + ! Init metric + call init_metric(npart,xyzh,metrics) + + ! Might be better to just do this in get derivs global with a number 2 call? + ! Rebuild the tree + call set_linklist(npart,npart,xyzh,vxyzu) + ! Apparently init metric needs to be called again??? + 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) - ! Interpolate density to grid - call phantom2et_rhostar + ! Interpolate density to grid + call phantom2et_rhostar - ! Interpolate momentum to grid - call phantom2et_momentum + ! Interpolate momentum to grid + call phantom2et_momentum - ! Interpolate entropy to grid - call phantom2et_entropy + ! Interpolate entropy to grid + call phantom2et_entropy - ! Conserved quantity checks + corrections + ! Conserved quantity checks + corrections - ! Density check vs particles - call check_conserved_dens(rhostargrid,cfac) + ! Density check vs particles + call check_conserved_dens(rhostargrid,cfac) - ! Momentum check vs particles + ! Momentum check vs particles - ! Correct momentum and Density - rhostargrid = cfac*rhostargrid - pxgrid = cfac*pxgrid - entropygrid = cfac*entropygrid + ! Correct momentum and Density + rhostargrid = cfac*rhostargrid + pxgrid = cfac*pxgrid + entropygrid = cfac*entropygrid - end subroutine phantom2et_consvar +end subroutine phantom2et_consvar - subroutine phantom2et_rhostar() - use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& +subroutine phantom2et_rhostar() + use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& igas, massoftype,rhoh - use cons2prim, only: cons2primall - use deriv - use extern_gr - use tmunu2grid - use einsteintk_utils, only: get_phantom_dt,rhostargrid - use metric_tools, only:init_metric - real :: dat(npart), h, pmass,rho - integer :: i - - - ! Get new cons density from new particle positions somehow (maybe)? - ! Set linklist to update the tree for neighbour finding - ! Calculate the density for the new particle positions - ! Call density iterate - - ! Interpolate from particles to grid - ! This can all go into its own function as it will essentially - ! be the same thing for all quantites - ! get particle data - ! get rho from xyzh and rhoh - ! Get the conserved density on the particles - dat = 0. - pmass = massoftype(igas) - ! $omp parallel do default(none) & - ! $omp shared(npart,xyzh,dat,pmass) & - ! $omp private(i,h,rho) - do i=1, npart - ! Get the smoothing length - h = xyzh(4,i) - ! Get pmass - - rho = rhoh(h,pmass) - dat(i) = rho - enddo - ! $omp end parallel do - rhostargrid = 0. - call interpolate_to_grid(rhostargrid,dat) - - end subroutine phantom2et_rhostar - - subroutine phantom2et_entropy() - use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& + use cons2prim, only: cons2primall + use deriv + use extern_gr + use tmunu2grid + use einsteintk_utils, only: get_phantom_dt,rhostargrid + use metric_tools, only:init_metric + real :: dat(npart), h, pmass,rho + integer :: i + + + ! Get new cons density from new particle positions somehow (maybe)? + ! Set linklist to update the tree for neighbour finding + ! Calculate the density for the new particle positions + ! Call density iterate + + ! Interpolate from particles to grid + ! This can all go into its own function as it will essentially + ! be the same thing for all quantites + ! get particle data + ! get rho from xyzh and rhoh + ! Get the conserved density on the particles + dat = 0. + pmass = massoftype(igas) + ! $omp parallel do default(none) & + ! $omp shared(npart,xyzh,dat,pmass) & + ! $omp private(i,h,rho) + do i=1, npart + ! Get the smoothing length + h = xyzh(4,i) + ! Get pmass + + rho = rhoh(h,pmass) + dat(i) = rho + enddo + ! $omp end parallel do + rhostargrid = 0. + call interpolate_to_grid(rhostargrid,dat) + +end subroutine phantom2et_rhostar + +subroutine phantom2et_entropy() + use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& igas, massoftype,rhoh - use cons2prim, only: cons2primall - use deriv - use extern_gr - use tmunu2grid - use einsteintk_utils, only: get_phantom_dt,entropygrid - use metric_tools, only:init_metric - real :: dat(npart), h, pmass,rho - integer :: i - - - ! Get new cons density from new particle positions somehow (maybe)? - ! Set linklist to update the tree for neighbour finding - ! Calculate the density for the new particle positions - ! Call density iterate - - ! Interpolate from particles to grid - ! This can all go into its own function as it will essentially - ! be the same thing for all quantites - ! get particle data - ! get rho from xyzh and rhoh - ! Get the conserved density on the particles - dat = 0. - !$omp parallel do default(none) & - !$omp shared(npart,pxyzu,dat) & - !$omp private(i) - do i=1, npart - ! Entropy is the u component of pxyzu - dat(i) = pxyzu(4,i) - enddo - !$omp end parallel do - entropygrid = 0. - call interpolate_to_grid(entropygrid,dat) - - end subroutine phantom2et_entropy - - subroutine phantom2et_momentum() - use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& + use cons2prim, only: cons2primall + use deriv + use extern_gr + use tmunu2grid + use einsteintk_utils, only: get_phantom_dt,entropygrid + use metric_tools, only:init_metric + real :: dat(npart), h, pmass,rho + integer :: i + + + ! Get new cons density from new particle positions somehow (maybe)? + ! Set linklist to update the tree for neighbour finding + ! Calculate the density for the new particle positions + ! Call density iterate + + ! Interpolate from particles to grid + ! This can all go into its own function as it will essentially + ! be the same thing for all quantites + ! get particle data + ! get rho from xyzh and rhoh + ! Get the conserved density on the particles + dat = 0. + !$omp parallel do default(none) & + !$omp shared(npart,pxyzu,dat) & + !$omp private(i) + do i=1, npart + ! Entropy is the u component of pxyzu + dat(i) = pxyzu(4,i) + enddo + !$omp end parallel do + entropygrid = 0. + call interpolate_to_grid(entropygrid,dat) + +end subroutine phantom2et_entropy + +subroutine phantom2et_momentum() + use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& igas,massoftype,alphaind,dvdx,gradh - use cons2prim, only: cons2primall - use deriv - use extern_gr - use tmunu2grid - use einsteintk_utils, only: get_phantom_dt,gcovgrid,pxgrid - use metric_tools, only:init_metric - real :: dat(3,npart) - integer :: i - - - ! Pi is directly updated at the end of each MoL add - - ! Interpolate from particles to grid - ! get particle data for the x component of momentum - dat = 0. - !$omp parallel do default(none) & - !$omp shared(npart,pxyzu,dat) & - !$omp private(i) - do i=1, npart - dat(1,i) = pxyzu(1,i) - dat(2,i) = pxyzu(2,i) - dat(3,i) = pxyzu(3,i) - enddo - !$omp end parallel do - pxgrid = 0. - ! call interpolate 3d - ! In this case call it 3 times one for each vector component - ! px component - call interpolate_to_grid(pxgrid(1,:,:,:), dat(1,:)) - ! py component - call interpolate_to_grid(pxgrid(2,:,:,:), dat(2,:)) - ! pz component - call interpolate_to_grid(pxgrid(3,:,:,:),dat(3,:)) - - - - end subroutine phantom2et_momentum - - - - ! Subroutine for performing a phantom dump from einstein toolkit - subroutine et2phantom_dumphydro(time,dt_et) - use cons2prim, only:cons2primall - use part, only:npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars - use einsteintk_utils - use evwrite, only:write_evfile,write_evlog - use readwrite_dumps, only:write_smalldump,write_fulldump - use fileutils, only:getnextfilename - real, intent(in) :: time, dt_et - !character(len=20) :: logfile,evfile,dumpfile - - ! Call cons2prim since values are updated with MoL - !call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) - ! Write EV_file - call write_evfile(time,dt_et) - - evfilestor = getnextfilename(evfilestor) - logfilestor = getnextfilename(logfilestor) - dumpfilestor = getnextfilename(dumpfilestor) - - !print*, "Evfile: ", evfilestor - !print*, "logfile: ", logfilestor - !print*, "dumpfle: ", dumpfilestor - ! Write full dump - call write_fulldump(time,dumpfilestor) - - end subroutine et2phantom_dumphydro - - ! Provides the RHS derivs for a particle at index i - subroutine phantom2et_rhs(index, vx,vy,vz,fx,fy,fz,e_rhs) - use einsteintk_utils - real, intent(inout) :: vx,vy,vz,fx,fy,fz, e_rhs - integer, intent(in) :: index - - call get_particle_rhs(index,vx,vy,vz,fx,fy,fz,e_rhs) - - end subroutine phantom2et_rhs - - subroutine phantom2et_initial(index,x,y,z,px,py,pz,e) - use einsteintk_utils - real, intent(inout) :: x,y,z,px,py,pz,e - integer, intent(in) :: index - - call get_particle_val(index,x,y,z,px,py,pz,e) - - end subroutine phantom2et_initial - - subroutine et2phantom_setparticlevars(index,x,y,z,px,py,pz,e) - use einsteintk_utils - real, intent(inout) :: x,y,z,px,py,pz,e - integer, intent(in) :: index - - call set_particle_val(index,x,y,z,px,py,pz,e) - - end subroutine et2phantom_setparticlevars - - ! I really HATE this routine being here but it needs to be to fix dependency issues. - subroutine get_metricderivs_all(dtextforce_min,dt_et) - use einsteintk_utils, only: metricderivsgrid - use part, only:npart, xyzh,vxyzu,fxyzu,metrics,metricderivs,dens,fext - use timestep, only:bignumber,C_force - use extern_gr, only:get_grforce - use metric_tools, only:pack_metricderivs - real, intent(out) :: dtextforce_min - real, intent(in) :: dt_et - integer :: i - real :: pri,dtf - - pri = 0. - dtextforce_min = bignumber - - !$omp parallel do default(none) & - !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & - !$omp firstprivate(pri) & - !$omp private(i,dtf) & - !$omp reduction(min:dtextforce_min) - do i=1, npart - call pack_metricderivs(xyzh(1:3,i),metricderivs(:,:,:,i)) - call get_grforce(xyzh(:,i),metrics(:,:,:,i),metricderivs(:,:,:,i), & + use cons2prim, only: cons2primall + use deriv + use extern_gr + use tmunu2grid + use einsteintk_utils, only: get_phantom_dt,gcovgrid,pxgrid + use metric_tools, only:init_metric + real :: dat(3,npart) + integer :: i + + + ! Pi is directly updated at the end of each MoL add + + ! Interpolate from particles to grid + ! get particle data for the x component of momentum + dat = 0. + !$omp parallel do default(none) & + !$omp shared(npart,pxyzu,dat) & + !$omp private(i) + do i=1, npart + dat(1,i) = pxyzu(1,i) + dat(2,i) = pxyzu(2,i) + dat(3,i) = pxyzu(3,i) + enddo + !$omp end parallel do + pxgrid = 0. + ! call interpolate 3d + ! In this case call it 3 times one for each vector component + ! px component + call interpolate_to_grid(pxgrid(1,:,:,:), dat(1,:)) + ! py component + call interpolate_to_grid(pxgrid(2,:,:,:), dat(2,:)) + ! pz component + call interpolate_to_grid(pxgrid(3,:,:,:),dat(3,:)) + + + +end subroutine phantom2et_momentum + + + + ! Subroutine for performing a phantom dump from einstein toolkit +subroutine et2phantom_dumphydro(time,dt_et) + use cons2prim, only:cons2primall + use part, only:npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars + use einsteintk_utils + use evwrite, only:write_evfile,write_evlog + use readwrite_dumps, only:write_smalldump,write_fulldump + use fileutils, only:getnextfilename + real, intent(in) :: time, dt_et + !character(len=20) :: logfile,evfile,dumpfile + + ! Call cons2prim since values are updated with MoL + !call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + ! Write EV_file + call write_evfile(time,dt_et) + + evfilestor = getnextfilename(evfilestor) + logfilestor = getnextfilename(logfilestor) + dumpfilestor = getnextfilename(dumpfilestor) + + !print*, "Evfile: ", evfilestor + !print*, "logfile: ", logfilestor + !print*, "dumpfle: ", dumpfilestor + ! Write full dump + call write_fulldump(time,dumpfilestor) + +end subroutine et2phantom_dumphydro + + ! Provides the RHS derivs for a particle at index i +subroutine phantom2et_rhs(index, vx,vy,vz,fx,fy,fz,e_rhs) + use einsteintk_utils + real, intent(inout) :: vx,vy,vz,fx,fy,fz, e_rhs + integer, intent(in) :: index + + call get_particle_rhs(index,vx,vy,vz,fx,fy,fz,e_rhs) + +end subroutine phantom2et_rhs + +subroutine phantom2et_initial(index,x,y,z,px,py,pz,e) + use einsteintk_utils + real, intent(inout) :: x,y,z,px,py,pz,e + integer, intent(in) :: index + + call get_particle_val(index,x,y,z,px,py,pz,e) + +end subroutine phantom2et_initial + +subroutine et2phantom_setparticlevars(index,x,y,z,px,py,pz,e) + use einsteintk_utils + real, intent(inout) :: x,y,z,px,py,pz,e + integer, intent(in) :: index + + call set_particle_val(index,x,y,z,px,py,pz,e) + +end subroutine et2phantom_setparticlevars + + ! I really HATE this routine being here but it needs to be to fix dependency issues. +subroutine get_metricderivs_all(dtextforce_min,dt_et) + use einsteintk_utils, only: metricderivsgrid + use part, only:npart, xyzh,vxyzu,fxyzu,metrics,metricderivs,dens,fext + use timestep, only:bignumber,C_force + use extern_gr, only:get_grforce + use metric_tools, only:pack_metricderivs + real, intent(out) :: dtextforce_min + real, intent(in) :: dt_et + integer :: i + real :: pri,dtf + + pri = 0. + dtextforce_min = bignumber + + !$omp parallel do default(none) & + !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & + !$omp firstprivate(pri) & + !$omp private(i,dtf) & + !$omp reduction(min:dtextforce_min) + do i=1, npart + call pack_metricderivs(xyzh(1:3,i),metricderivs(:,:,:,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) - dtextforce_min = min(dtextforce_min,C_force*dtf) - enddo - !$omp end parallel do - ! manually add v contribution from gr - ! do i=1, npart - ! !fxyzu(:,i) = fxyzu(:,i) + fext(:,i) - ! vxyzu(1:3,i) = vxyzu(1:3,i) + fext(:,i)*dt_et - ! enddo - end subroutine get_metricderivs_all - - subroutine get_eos_quantities(densi,en) - use cons2prim, only:cons2primall - use part, only:dens,vxyzu,npart,metrics,xyzh,pxyzu,eos_vars - real, intent(out) :: densi,en - - !call h2dens(densi,xyzhi,metrici,vi) ! Compute dens from h - densi = dens(1) ! Feed the newly computed dens back out of the routine - !call cons2primall(npart,xyzh,metrics,vxyzu,dens,pxyzu,.true.) - call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) - ! print*,"pxyzu: ",pxyzu(:,1) - ! print*, "vxyzu: ",vxyzu(:,1) - en = vxyzu(4,1) - end subroutine get_eos_quantities + dtextforce_min = min(dtextforce_min,C_force*dtf) + enddo + !$omp end parallel do + ! manually add v contribution from gr + ! do i=1, npart + ! !fxyzu(:,i) = fxyzu(:,i) + fext(:,i) + ! vxyzu(1:3,i) = vxyzu(1:3,i) + fext(:,i)*dt_et + ! enddo +end subroutine get_metricderivs_all + +subroutine get_eos_quantities(densi,en) + use cons2prim, only:cons2primall + use part, only:dens,vxyzu,npart,metrics,xyzh,pxyzu,eos_vars + real, intent(out) :: densi,en + + !call h2dens(densi,xyzhi,metrici,vi) ! Compute dens from h + densi = dens(1) ! Feed the newly computed dens back out of the routine + !call cons2primall(npart,xyzh,metrics,vxyzu,dens,pxyzu,.true.) + call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + ! print*,"pxyzu: ",pxyzu(:,1) + ! print*, "vxyzu: ",vxyzu(:,1) + en = vxyzu(4,1) +end subroutine get_eos_quantities end module einsteintk_wrapper diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index 228ed64b5..feeb6a98f 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -24,899 +24,899 @@ module interpolations3D ! !---------------------------------------------------------------------- - use einsteintk_utils, only:exact_rendering - use kernel, only:radkern2,radkern,cnormk,wkern!,wallint ! Moved to this module - !use interpolation, only:iroll ! Moved to this module - - !use timing, only:wall_time,print_time ! Using cpu_time for now - implicit none - integer, parameter :: doub_prec = kind(0.d0) - real :: cnormk3D = cnormk - public :: interpolate3D!,interpolate3D_vec not needed - - contains - !-------------------------------------------------------------------------- - ! subroutine to interpolate from particle data to even grid of pixels - ! - ! The data is interpolated according to the formula - ! - ! datsmooth(pixel) = sum_b weight_b dat_b W(r-r_b, h_b) - ! - ! where _b is the quantity at the neighbouring particle b and - ! W is the smoothing kernel, for which we use the usual cubic spline. - ! - ! For a standard SPH smoothing the weight function for each particle should be - ! - ! weight = pmass/(rho*h^3) - ! - ! this version is written for slices through a rectangular volume, ie. - ! assumes a uniform pixel size in x,y, whilst the number of pixels - ! in the z direction can be set to the number of cross-section slices. - ! - ! Input: particle coordinates : x,y,z (npart) - ! smoothing lengths : hh (npart) - ! weight for each particle : weight (npart) - ! scalar data to smooth : dat (npart) - ! - ! Output: smoothed data : datsmooth (npixx,npixy,npixz) - ! - ! Daniel Price, Institute of Astronomy, Cambridge 16/7/03 - ! Revised for "splash to grid", Monash University 02/11/09 - ! Maya Petkova contributed exact subgrid interpolation, April 2019 - !-------------------------------------------------------------------------- - - subroutine interpolate3D(xyzh,weight,dat,itype,npart,& + use einsteintk_utils, only:exact_rendering + use kernel, only:radkern2,radkern,cnormk,wkern!,wallint ! Moved to this module + !use interpolation, only:iroll ! Moved to this module + + !use timing, only:wall_time,print_time ! Using cpu_time for now + implicit none + integer, parameter :: doub_prec = kind(0.d0) + real :: cnormk3D = cnormk + public :: interpolate3D!,interpolate3D_vec not needed + +contains + !-------------------------------------------------------------------------- + ! subroutine to interpolate from particle data to even grid of pixels + ! + ! The data is interpolated according to the formula + ! + ! datsmooth(pixel) = sum_b weight_b dat_b W(r-r_b, h_b) + ! + ! where _b is the quantity at the neighbouring particle b and + ! W is the smoothing kernel, for which we use the usual cubic spline. + ! + ! For a standard SPH smoothing the weight function for each particle should be + ! + ! weight = pmass/(rho*h^3) + ! + ! this version is written for slices through a rectangular volume, ie. + ! assumes a uniform pixel size in x,y, whilst the number of pixels + ! in the z direction can be set to the number of cross-section slices. + ! + ! Input: particle coordinates : x,y,z (npart) + ! smoothing lengths : hh (npart) + ! weight for each particle : weight (npart) + ! scalar data to smooth : dat (npart) + ! + ! Output: smoothed data : datsmooth (npixx,npixy,npixz) + ! + ! Daniel Price, Institute of Astronomy, Cambridge 16/7/03 + ! Revised for "splash to grid", Monash University 02/11/09 + ! Maya Petkova contributed exact subgrid interpolation, April 2019 + !-------------------------------------------------------------------------- + +subroutine interpolate3D(xyzh,weight,dat,itype,npart,& xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& normalise,periodicx,periodicy,periodicz) - integer, intent(in) :: npart,npixx,npixy,npixz - real, intent(in) :: xyzh(4,npart) - !real, intent(in), dimension(npart) :: x,y,z,hh ! change to xyzh() - real, intent(in), dimension(npart) :: weight,dat - integer, intent(in), dimension(npart) :: itype - real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz - real(doub_prec), intent(out), dimension(npixx,npixy,npixz) :: datsmooth - logical, intent(in) :: normalise,periodicx,periodicy,periodicz - !logical, intent(in), exact_rendering - real(doub_prec), allocatable :: datnorm(:,:,:) - - integer :: i,ipix,jpix,kpix - integer :: iprintinterval,iprintnext - integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax - integer :: ipixi,jpixi,kpixi,nxpix,nwarn,threadid - real :: xminpix,yminpix,zminpix,hmin !,dhmin3 - real, dimension(npixx) :: dx2i - real :: xi,yi,zi,hi,hi1,hi21,wab,q2,const,dyz2,dz2 - real :: term,termnorm,dy,dz,ypix,zpix,xpixi,pixwidthmax,dfac - real :: t_start,t_end,t_used - logical :: iprintprogress - real, dimension(npart) :: x,y,z,hh - real :: radkernel, radkernel2, radkernh - - ! Exact rendering - real :: pixint, wint - !logical, parameter :: exact_rendering = .true. ! use exact rendering y/n - integer :: usedpart, negflag - - - !$ integer :: omp_get_num_threads,omp_get_thread_num - integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits - - ! Fill the particle data with xyzh - x(:) = xyzh(1,:) - y(:) = xyzh(2,:) - z(:) = xyzh(3,:) - hh(:) = xyzh(4,:) - print*, "smoothing length: ", hh(1:10) - ! cnormk3D set the value from the kernel routine - cnormk3D = cnormk - radkernel = radkern - radkernel2 = radkern2 - print*, "radkern: ", radkern - print*, "radkernel: ",radkernel - print*, "radkern2: ", radkern2 - - print*, "npix: ", npixx, npixy,npixz - - if (exact_rendering) then - print "(1x,a)",'interpolating to 3D grid (exact/Petkova+2018 on subgrid) ...' - elseif (normalise) then - print "(1x,a)",'interpolating to 3D grid (normalised) ...' - else - print "(1x,a)",'interpolating to 3D grid (non-normalised) ...' - endif - if (pixwidthx <= 0. .or. pixwidthy <= 0 .or. pixwidthz <= 0) then - print "(1x,a)",'interpolate3D: error: pixel width <= 0' - return - endif - if (any(hh(1:npart) <= tiny(hh))) then - print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' - endif - - !call wall_time(t_start) - - datsmooth = 0. - if (normalise) then - allocate(datnorm(npixx,npixy,npixz)) - datnorm = 0. - endif + integer, intent(in) :: npart,npixx,npixy,npixz + real, intent(in) :: xyzh(4,npart) + !real, intent(in), dimension(npart) :: x,y,z,hh ! change to xyzh() + real, intent(in), dimension(npart) :: weight,dat + integer, intent(in), dimension(npart) :: itype + real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz + real(doub_prec), intent(out), dimension(npixx,npixy,npixz) :: datsmooth + logical, intent(in) :: normalise,periodicx,periodicy,periodicz + !logical, intent(in), exact_rendering + real(doub_prec), allocatable :: datnorm(:,:,:) + + integer :: i,ipix,jpix,kpix + integer :: iprintinterval,iprintnext + integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax + integer :: ipixi,jpixi,kpixi,nxpix,nwarn,threadid + real :: xminpix,yminpix,zminpix,hmin !,dhmin3 + real, dimension(npixx) :: dx2i + real :: xi,yi,zi,hi,hi1,hi21,wab,q2,const,dyz2,dz2 + real :: term,termnorm,dy,dz,ypix,zpix,xpixi,pixwidthmax,dfac + real :: t_start,t_end,t_used + logical :: iprintprogress + real, dimension(npart) :: x,y,z,hh + real :: radkernel, radkernel2, radkernh + + ! Exact rendering + real :: pixint, wint + !logical, parameter :: exact_rendering = .true. ! use exact rendering y/n + integer :: usedpart, negflag + + +!$ integer :: omp_get_num_threads,omp_get_thread_num + integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits + + ! Fill the particle data with xyzh + x(:) = xyzh(1,:) + y(:) = xyzh(2,:) + z(:) = xyzh(3,:) + hh(:) = xyzh(4,:) + print*, "smoothing length: ", hh(1:10) + ! cnormk3D set the value from the kernel routine + cnormk3D = cnormk + radkernel = radkern + radkernel2 = radkern2 + print*, "radkern: ", radkern + print*, "radkernel: ",radkernel + print*, "radkern2: ", radkern2 + + print*, "npix: ", npixx, npixy,npixz + + if (exact_rendering) then + print "(1x,a)",'interpolating to 3D grid (exact/Petkova+2018 on subgrid) ...' + elseif (normalise) then + print "(1x,a)",'interpolating to 3D grid (normalised) ...' + else + print "(1x,a)",'interpolating to 3D grid (non-normalised) ...' + endif + if (pixwidthx <= 0. .or. pixwidthy <= 0 .or. pixwidthz <= 0) then + print "(1x,a)",'interpolate3D: error: pixel width <= 0' + return + endif + if (any(hh(1:npart) <= tiny(hh))) then + print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' + endif + + !call wall_time(t_start) + + datsmooth = 0. + if (normalise) then + allocate(datnorm(npixx,npixy,npixz)) + datnorm = 0. + endif + ! + !--print a progress report if it is going to take a long time + ! (a "long time" is, however, somewhat system dependent) + ! + iprintprogress = (npart >= 100000) .or. (npixx*npixy > 100000) !.or. exact_rendering + ! + !--loop over particles + ! + iprintinterval = 25 + if (npart >= 1e6) iprintinterval = 10 + iprintnext = iprintinterval + ! + !--get starting CPU time + ! + call cpu_time(t_start) + + usedpart = 0 + + xminpix = xmin !- 0.5*pixwidthx + yminpix = ymin !- 0.5*pixwidthy + zminpix = zmin !- 0.5*pixwidthz + print*, "xminpix: ", xminpix + print*, "yminpix: ", yminpix + print*, "zminpix: ", zminpix + print*, "dat: ", dat(1:10) + print*, "weights: ", weight(1:10) + pixwidthmax = max(pixwidthx,pixwidthy,pixwidthz) + ! + !--use a minimum smoothing length on the grid to make + ! sure that particles contribute to at least one pixel + ! + hmin = 0.5*pixwidthmax + !dhmin3 = 1./(hmin*hmin*hmin) + + const = cnormk3D ! normalisation constant (3D) + print*, "const: ", const + nwarn = 0 + j = 0_8 + threadid = 1 + ! + !--loop over particles + ! + !$omp parallel default(none) & + !$omp shared(hh,z,x,y,weight,dat,itype,datsmooth,npart) & + !$omp shared(xmin,ymin,zmin,radkernel,radkernel2) & + !$omp shared(xminpix,yminpix,zminpix,pixwidthx,pixwidthy,pixwidthz) & + !$omp shared(npixx,npixy,npixz,const) & + !$omp shared(datnorm,normalise,periodicx,periodicy,periodicz,exact_rendering) & + !$omp shared(hmin,pixwidthmax) & + !$omp shared(iprintprogress,iprintinterval,j) & + !$omp private(hi,xi,yi,zi,radkernh,hi1,hi21) & + !$omp private(term,termnorm,xpixi,iprogress) & + !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & + !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & + !$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & + !$omp private(pixint,wint,negflag,dfac,threadid) & + !$omp firstprivate(iprintnext) & + !$omp reduction(+:nwarn,usedpart) + !$omp master +!$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' + !$omp end master + + !$omp do schedule (guided, 2) + over_parts: do i=1,npart ! - !--print a progress report if it is going to take a long time - ! (a "long time" is, however, somewhat system dependent) + !--report on progress ! - iprintprogress = (npart >= 100000) .or. (npixx*npixy > 100000) !.or. exact_rendering + if (iprintprogress) then + !$omp atomic + j=j+1_8 +!$ threadid = omp_get_thread_num() + iprogress = 100*j/npart + if (iprogress >= iprintnext .and. threadid==1) then + write(*,"(i3,'%.')",advance='no') iprogress + iprintnext = iprintnext + iprintinterval + endif + endif ! - !--loop over particles + !--skip particles with itype < 0 ! - iprintinterval = 25 - if (npart >= 1e6) iprintinterval = 10 - iprintnext = iprintinterval + if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts + + hi = hh(i) + if (hi <= 0.) then + cycle over_parts + elseif (hi < hmin) then + ! + !--use minimum h to capture subgrid particles + ! (get better results *without* adjusting weights) + ! + termnorm = const*weight(i) !*(hi*hi*hi)*dhmin3 + if (.not.exact_rendering) hi = hmin + else + termnorm = const*weight(i) + endif + ! - !--get starting CPU time + !--set kernel related quantities ! - call cpu_time(t_start) - - usedpart = 0 - - xminpix = xmin !- 0.5*pixwidthx - yminpix = ymin !- 0.5*pixwidthy - zminpix = zmin !- 0.5*pixwidthz - print*, "xminpix: ", xminpix - print*, "yminpix: ", yminpix - print*, "zminpix: ", zminpix - print*, "dat: ", dat(1:10) - print*, "weights: ", weight(1:10) - pixwidthmax = max(pixwidthx,pixwidthy,pixwidthz) + xi = x(i) + yi = y(i) + zi = z(i) + + hi1 = 1./hi + hi21 = hi1*hi1 + radkernh = radkernel*hi ! radius of the smoothing kernel + !termnorm = const*weight(i) + term = termnorm*dat(i) + dfac = hi**3/(pixwidthx*pixwidthy*pixwidthz*const) + !dfac = hi**3/(pixwidthx*pixwidthy*const) ! - !--use a minimum smoothing length on the grid to make - ! sure that particles contribute to at least one pixel + !--for each particle work out which pixels it contributes to ! - hmin = 0.5*pixwidthmax - !dhmin3 = 1./(hmin*hmin*hmin) - - const = cnormk3D ! normalisation constant (3D) - print*, "const: ", const - nwarn = 0 - j = 0_8 - threadid = 1 + ipixmin = int((xi - radkernh - xmin)/pixwidthx) + jpixmin = int((yi - radkernh - ymin)/pixwidthy) + kpixmin = int((zi - radkernh - zmin)/pixwidthz) + ipixmax = int((xi + radkernh - xmin)/pixwidthx) + 1 + jpixmax = int((yi + radkernh - ymin)/pixwidthy) + 1 + kpixmax = int((zi + radkernh - zmin)/pixwidthz) + 1 + + if (.not.periodicx) then + if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute + if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image + endif + if (.not.periodicy) then + if (jpixmin < 1) jpixmin = 1 + if (jpixmax > npixy) jpixmax = npixy + endif + if (.not.periodicz) then + if (kpixmin < 1) kpixmin = 1 + if (kpixmax > npixz) kpixmax = npixz + endif + + negflag = 0 + ! - !--loop over particles + !--precalculate an array of dx2 for this particle (optimisation) ! - !$omp parallel default(none) & - !$omp shared(hh,z,x,y,weight,dat,itype,datsmooth,npart) & - !$omp shared(xmin,ymin,zmin,radkernel,radkernel2) & - !$omp shared(xminpix,yminpix,zminpix,pixwidthx,pixwidthy,pixwidthz) & - !$omp shared(npixx,npixy,npixz,const) & - !$omp shared(datnorm,normalise,periodicx,periodicy,periodicz,exact_rendering) & - !$omp shared(hmin,pixwidthmax) & - !$omp shared(iprintprogress,iprintinterval,j) & - !$omp private(hi,xi,yi,zi,radkernh,hi1,hi21) & - !$omp private(term,termnorm,xpixi,iprogress) & - !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & - !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & - !$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & - !$omp private(pixint,wint,negflag,dfac,threadid) & - !$omp firstprivate(iprintnext) & - !$omp reduction(+:nwarn,usedpart) - !$omp master - !$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' - !$omp end master - - !$omp do schedule (guided, 2) - over_parts: do i=1,npart - ! - !--report on progress - ! - if (iprintprogress) then - !$omp atomic - j=j+1_8 - !$ threadid = omp_get_thread_num() - iprogress = 100*j/npart - if (iprogress >= iprintnext .and. threadid==1) then - write(*,"(i3,'%.')",advance='no') iprogress - iprintnext = iprintnext + iprintinterval - endif - endif - ! - !--skip particles with itype < 0 - ! - if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts - - hi = hh(i) - if (hi <= 0.) then - cycle over_parts - elseif (hi < hmin) then - ! - !--use minimum h to capture subgrid particles - ! (get better results *without* adjusting weights) - ! - termnorm = const*weight(i) !*(hi*hi*hi)*dhmin3 - if (.not.exact_rendering) hi = hmin - else - termnorm = const*weight(i) + ! Check the x position of the grid cells + !open(unit=677,file="posxgrid.txt",action='write',position='append') + nxpix = 0 + do ipix=ipixmin,ipixmax + nxpix = nxpix + 1 + ipixi = ipix + if (periodicx) ipixi = iroll(ipix,npixx) + xpixi = xminpix + ipix*pixwidthx + !write(677,*) ipix, xpixi + !--watch out for errors with periodic wrapping... + if (nxpix <= size(dx2i)) then + dx2i(nxpix) = ((xpixi - xi)**2)*hi21 endif + enddo + + !--if particle contributes to more than npixx pixels + ! (i.e. periodic boundaries wrap more than once) + ! truncate the contribution and give warning + if (nxpix > npixx) then + nwarn = nwarn + 1 + ipixmax = ipixmin + npixx - 1 + endif + ! + !--loop over pixels, adding the contribution from this particle + ! + do kpix = kpixmin,kpixmax + kpixi = kpix + if (periodicz) kpixi = iroll(kpix,npixz) - ! - !--set kernel related quantities - ! - xi = x(i) - yi = y(i) - zi = z(i) - - hi1 = 1./hi - hi21 = hi1*hi1 - radkernh = radkernel*hi ! radius of the smoothing kernel - !termnorm = const*weight(i) - term = termnorm*dat(i) - dfac = hi**3/(pixwidthx*pixwidthy*pixwidthz*const) - !dfac = hi**3/(pixwidthx*pixwidthy*const) - ! - !--for each particle work out which pixels it contributes to - ! - ipixmin = int((xi - radkernh - xmin)/pixwidthx) - jpixmin = int((yi - radkernh - ymin)/pixwidthy) - kpixmin = int((zi - radkernh - zmin)/pixwidthz) - ipixmax = int((xi + radkernh - xmin)/pixwidthx) + 1 - jpixmax = int((yi + radkernh - ymin)/pixwidthy) + 1 - kpixmax = int((zi + radkernh - zmin)/pixwidthz) + 1 - - if (.not.periodicx) then - if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute - if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image - endif - if (.not.periodicy) then - if (jpixmin < 1) jpixmin = 1 - if (jpixmax > npixy) jpixmax = npixy - endif - if (.not.periodicz) then - if (kpixmin < 1) kpixmin = 1 - if (kpixmax > npixz) kpixmax = npixz - endif + zpix = zminpix + kpix*pixwidthz + dz = zpix - zi + dz2 = dz*dz*hi21 - negflag = 0 + do jpix = jpixmin,jpixmax + jpixi = jpix + if (periodicy) jpixi = iroll(jpix,npixy) - ! - !--precalculate an array of dx2 for this particle (optimisation) - ! - ! Check the x position of the grid cells - !open(unit=677,file="posxgrid.txt",action='write',position='append') - nxpix = 0 - do ipix=ipixmin,ipixmax - nxpix = nxpix + 1 - ipixi = ipix - if (periodicx) ipixi = iroll(ipix,npixx) - xpixi = xminpix + ipix*pixwidthx - !write(677,*) ipix, xpixi - !--watch out for errors with periodic wrapping... - if (nxpix <= size(dx2i)) then - dx2i(nxpix) = ((xpixi - xi)**2)*hi21 - endif - enddo + ypix = yminpix + jpix*pixwidthy + dy = ypix - yi + dyz2 = dy*dy*hi21 + dz2 - !--if particle contributes to more than npixx pixels - ! (i.e. periodic boundaries wrap more than once) - ! truncate the contribution and give warning - if (nxpix > npixx) then - nwarn = nwarn + 1 - ipixmax = ipixmin + npixx - 1 - endif - ! - !--loop over pixels, adding the contribution from this particle - ! - do kpix = kpixmin,kpixmax - kpixi = kpix - if (periodicz) kpixi = iroll(kpix,npixz) - - zpix = zminpix + kpix*pixwidthz - dz = zpix - zi - dz2 = dz*dz*hi21 - - do jpix = jpixmin,jpixmax - jpixi = jpix - if (periodicy) jpixi = iroll(jpix,npixy) - - ypix = yminpix + jpix*pixwidthy - dy = ypix - yi - dyz2 = dy*dy*hi21 + dz2 - - nxpix = 0 - do ipix = ipixmin,ipixmax - if ((kpix==kpixmin).and.(jpix==jpixmin).and.(ipix==ipixmin)) then - usedpart = usedpart + 1 - endif + nxpix = 0 + do ipix = ipixmin,ipixmax + if ((kpix==kpixmin).and.(jpix==jpixmin).and.(ipix==ipixmin)) then + usedpart = usedpart + 1 + endif - nxpix = nxpix + 1 - ipixi = ipix - if (periodicx) ipixi = iroll(ipix,npixx) + nxpix = nxpix + 1 + ipixi = ipix + if (periodicx) ipixi = iroll(ipix,npixx) - q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 + q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 - if (exact_rendering .and. ipixmax-ipixmin <= 4) then - if (q2 < radkernel2 + 3.*pixwidthmax**2*hi21) then - xpixi = xminpix + ipix*pixwidthx + if (exact_rendering .and. ipixmax-ipixmin <= 4) then + if (q2 < radkernel2 + 3.*pixwidthmax**2*hi21) then + xpixi = xminpix + ipix*pixwidthx - ! Contribution of the cell walls in the xy-plane - pixint = 0.0 - wint = wallint(zpix-zi+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) - pixint = pixint + wint + ! Contribution of the cell walls in the xy-plane + pixint = 0.0 + wint = wallint(zpix-zi+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) + pixint = pixint + wint - wint = wallint(zi-zpix+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) - pixint = pixint + wint + wint = wallint(zi-zpix+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) + pixint = pixint + wint - ! Contribution of the cell walls in the xz-plane - wint = wallint(ypix-yi+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) - pixint = pixint + wint + ! Contribution of the cell walls in the xz-plane + wint = wallint(ypix-yi+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) + pixint = pixint + wint - wint = wallint(yi-ypix+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) - pixint = pixint + wint + wint = wallint(yi-ypix+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) + pixint = pixint + wint - ! Contribution of the cell walls in the yz-plane - wint = wallint(xpixi-xi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) - pixint = pixint + wint + ! Contribution of the cell walls in the yz-plane + wint = wallint(xpixi-xi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) + pixint = pixint + wint - wint = wallint(xi-xpixi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) - pixint = pixint + wint + wint = wallint(xi-xpixi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) + pixint = pixint + wint - wab = pixint*dfac ! /(pixwidthx*pixwidthy*pixwidthz*const)*hi**3 + wab = pixint*dfac ! /(pixwidthx*pixwidthy*pixwidthz*const)*hi**3 - if (pixint < -0.01d0) then - print*, "Error: (",ipixi,jpixi,kpixi,") -> ", pixint, term*wab - endif + if (pixint < -0.01d0) then + print*, "Error: (",ipixi,jpixi,kpixi,") -> ", pixint, term*wab + endif - ! - !--calculate data value at this pixel using the summation interpolant - ! + ! + !--calculate data value at this pixel using the summation interpolant + ! + !$omp atomic + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + if (normalise) then !$omp atomic - datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab - if (normalise) then - !$omp atomic - datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - endif + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab endif - else - if (q2 < radkernel2) then - - ! - !--SPH kernel - standard cubic spline - ! - wab = wkernel(q2) - ! - !--calculate data value at this pixel using the summation interpolant - ! + endif + else + if (q2 < radkernel2) then + + ! + !--SPH kernel - standard cubic spline + ! + wab = wkernel(q2) + ! + !--calculate data value at this pixel using the summation interpolant + ! + !$omp atomic + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + if (normalise) then !$omp atomic - datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab - if (normalise) then - !$omp atomic - datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - endif + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab endif endif - enddo + endif enddo enddo - enddo over_parts - !$omp enddo - !$omp end parallel + enddo + enddo over_parts + !$omp enddo + !$omp end parallel - if (nwarn > 0) then - print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& + if (nwarn > 0) then + print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& ' that wrap periodic boundaries more than once' - endif - ! - !--normalise dat array - ! - if (normalise) then - where (datnorm > tiny(datnorm)) - datsmooth = datsmooth/datnorm - end where - endif - if (allocated(datnorm)) deallocate(datnorm) - - !call wall_time(t_end) - call cpu_time(t_end) - t_used = t_end - t_start - print*, 'completed in ',t_end-t_start,'s' - !if (t_used > 10.) call print_time(t_used) - - !print*, 'Number of particles in the volume: ', usedpart - ! datsmooth(1,1,1) = 3.14159 - ! datsmooth(32,32,32) = 3.145159 - ! datsmooth(11,11,11) = 3.14159 - ! datsmooth(10,10,10) = 3.145159 - - end subroutine interpolate3D - - ! subroutine interpolate3D_vec(x,y,z,hh,weight,datvec,itype,npart,& - ! xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& - ! normalise,periodicx,periodicy,periodicz) - - ! integer, intent(in) :: npart,npixx,npixy,npixz - ! real, intent(in), dimension(npart) :: x,y,z,hh,weight - ! real, intent(in), dimension(npart,3) :: datvec - ! integer, intent(in), dimension(npart) :: itype - ! real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz - ! real(doub_prec), intent(out), dimension(3,npixx,npixy,npixz) :: datsmooth - ! logical, intent(in) :: normalise,periodicx,periodicy,periodicz - ! real(doub_prec), dimension(npixx,npixy,npixz) :: datnorm - - ! integer :: i,ipix,jpix,kpix - ! integer :: iprintinterval,iprintnext - ! integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax - ! integer :: ipixi,jpixi,kpixi,nxpix,nwarn - ! real :: xminpix,yminpix,zminpix - ! real, dimension(npixx) :: dx2i - ! real :: xi,yi,zi,hi,hi1,hi21,radkern,wab,q2,const,dyz2,dz2 - ! real :: termnorm,dy,dz,ypix,zpix,xpixi,ddatnorm - ! real, dimension(3) :: term - ! !real :: t_start,t_end - ! logical :: iprintprogress - ! !$ integer :: omp_get_num_threads - ! integer(kind=selected_int_kind(10)) :: iprogress ! up to 10 digits - - ! datsmooth = 0. - ! datnorm = 0. - ! if (normalise) then - ! print "(1x,a)",'interpolating to 3D grid (normalised) ...' - ! else - ! print "(1x,a)",'interpolating to 3D grid (non-normalised) ...' - ! endif - ! if (pixwidthx <= 0. .or. pixwidthy <= 0. .or. pixwidthz <= 0.) then - ! print "(1x,a)",'interpolate3D: error: pixel width <= 0' - ! return - ! endif - ! if (any(hh(1:npart) <= tiny(hh))) then - ! print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' - ! endif - - ! ! - ! !--print a progress report if it is going to take a long time - ! ! (a "long time" is, however, somewhat system dependent) - ! ! - ! iprintprogress = (npart >= 100000) .or. (npixx*npixy > 100000) - ! !$ iprintprogress = .false. - ! ! - ! !--loop over particles - ! ! - ! iprintinterval = 25 - ! if (npart >= 1e6) iprintinterval = 10 - ! iprintnext = iprintinterval - ! ! - ! !--get starting CPU time - ! ! - ! !call cpu_time(t_start) - - ! xminpix = xmin - 0.5*pixwidthx - ! yminpix = ymin - 0.5*pixwidthy - ! zminpix = zmin - 0.5*pixwidthz - - ! const = cnormk3D ! normalisation constant (3D) - ! nwarn = 0 - - ! !$omp parallel default(none) & - ! !$omp shared(hh,z,x,y,weight,datvec,itype,datsmooth,npart) & - ! !$omp shared(xmin,ymin,zmin,radkernel,radkernel2) & - ! !$omp shared(xminpix,yminpix,zminpix,pixwidthx,pixwidthy,pixwidthz) & - ! !$omp shared(npixx,npixy,npixz,const) & - ! !$omp shared(iprintprogress,iprintinterval) & - ! !$omp shared(datnorm,normalise,periodicx,periodicy,periodicz) & - ! !$omp private(hi,xi,yi,zi,radkern,hi1,hi21) & - ! !$omp private(term,termnorm,xpixi) & - ! !$omp private(iprogress,iprintnext) & - ! !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & - ! !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & - ! !$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & - ! !$omp reduction(+:nwarn) - ! !$omp master - ! !$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' - ! !$omp end master - ! ! - ! !--loop over particles - ! ! - ! !$omp do schedule (guided, 2) - ! over_parts: do i=1,npart - ! ! - ! !--report on progress - ! ! - ! if (iprintprogress) then - ! iprogress = 100*i/npart - ! if (iprogress >= iprintnext) then - ! write(*,"('(',i3,'% -',i12,' particles done)')") iprogress,i - ! iprintnext = iprintnext + iprintinterval - ! endif - ! endif - ! ! - ! !--skip particles with itype < 0 - ! ! - ! if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts - - ! hi = hh(i) - ! if (hi <= 0.) cycle over_parts - - ! ! - ! !--set kernel related quantities - ! ! - ! xi = x(i) - ! yi = y(i) - ! zi = z(i) - - ! hi1 = 1./hi - ! hi21 = hi1*hi1 - ! radkern = radkernel*hi ! radius of the smoothing kernel - ! termnorm = const*weight(i) - ! term(:) = termnorm*datvec(i,:) - ! ! - ! !--for each particle work out which pixels it contributes to - ! ! - ! ipixmin = int((xi - radkern - xmin)/pixwidthx) - ! jpixmin = int((yi - radkern - ymin)/pixwidthy) - ! kpixmin = int((zi - radkern - zmin)/pixwidthz) - ! ipixmax = int((xi + radkern - xmin)/pixwidthx) + 1 - ! jpixmax = int((yi + radkern - ymin)/pixwidthy) + 1 - ! kpixmax = int((zi + radkern - zmin)/pixwidthz) + 1 - - ! if (.not.periodicx) then - ! if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute - ! if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image - ! endif - ! if (.not.periodicy) then - ! if (jpixmin < 1) jpixmin = 1 - ! if (jpixmax > npixy) jpixmax = npixy - ! endif - ! if (.not.periodicz) then - ! if (kpixmin < 1) kpixmin = 1 - ! if (kpixmax > npixz) kpixmax = npixz - ! endif - ! ! - ! !--precalculate an array of dx2 for this particle (optimisation) - ! ! - ! nxpix = 0 - ! do ipix=ipixmin,ipixmax - ! nxpix = nxpix + 1 - ! ipixi = ipix - ! if (periodicx) ipixi = iroll(ipix,npixx) - ! xpixi = xminpix + ipix*pixwidthx - ! !--watch out for errors with perioic wrapping... - ! if (nxpix <= size(dx2i)) then - ! dx2i(nxpix) = ((xpixi - xi)**2)*hi21 - ! endif - ! enddo - - ! !--if particle contributes to more than npixx pixels - ! ! (i.e. periodic boundaries wrap more than once) - ! ! truncate the contribution and give warning - ! if (nxpix > npixx) then - ! nwarn = nwarn + 1 - ! ipixmax = ipixmin + npixx - 1 - ! endif - ! ! - ! !--loop over pixels, adding the contribution from this particle - ! ! - ! do kpix = kpixmin,kpixmax - ! kpixi = kpix - ! if (periodicz) kpixi = iroll(kpix,npixz) - ! zpix = zminpix + kpix*pixwidthz - ! dz = zpix - zi - ! dz2 = dz*dz*hi21 - - ! do jpix = jpixmin,jpixmax - ! jpixi = jpix - ! if (periodicy) jpixi = iroll(jpix,npixy) - ! ypix = yminpix + jpix*pixwidthy - ! dy = ypix - yi - ! dyz2 = dy*dy*hi21 + dz2 - - ! nxpix = 0 - ! do ipix = ipixmin,ipixmax - ! ipixi = ipix - ! if (periodicx) ipixi = iroll(ipix,npixx) - ! nxpix = nxpix + 1 - ! q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 - ! ! - ! !--SPH kernel - standard cubic spline - ! ! - ! if (q2 < radkernel2) then - ! wab = wkernel(q2) - ! ! - ! !--calculate data value at this pixel using the summation interpolant - ! ! - ! !$omp atomic - ! datsmooth(1,ipixi,jpixi,kpixi) = datsmooth(1,ipixi,jpixi,kpixi) + term(1)*wab - ! !$omp atomic - ! datsmooth(2,ipixi,jpixi,kpixi) = datsmooth(2,ipixi,jpixi,kpixi) + term(2)*wab - ! !$omp atomic - ! datsmooth(3,ipixi,jpixi,kpixi) = datsmooth(3,ipixi,jpixi,kpixi) + term(3)*wab - ! if (normalise) then - ! !$omp atomic - ! datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - ! endif - ! endif - ! enddo - ! enddo - ! enddo - ! enddo over_parts - ! !$omp enddo - ! !$omp end parallel - - ! if (nwarn > 0) then - ! print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& - ! ' that wrap periodic boundaries more than once' - ! endif - ! ! - ! !--normalise dat array - ! ! - ! if (normalise) then - ! !$omp parallel do default(none) schedule(static) & - ! !$omp shared(datsmooth,datnorm,npixz,npixy,npixx) & - ! !$omp private(kpix,jpix,ipix,ddatnorm) - ! do kpix=1,npixz - ! do jpix=1,npixy - ! do ipix=1,npixx - ! if (datnorm(ipix,jpix,kpix) > tiny(datnorm)) then - ! ddatnorm = 1./datnorm(ipix,jpix,kpix) - ! datsmooth(1,ipix,jpix,kpix) = datsmooth(1,ipix,jpix,kpix)*ddatnorm - ! datsmooth(2,ipix,jpix,kpix) = datsmooth(2,ipix,jpix,kpix)*ddatnorm - ! datsmooth(3,ipix,jpix,kpix) = datsmooth(3,ipix,jpix,kpix)*ddatnorm - ! endif - ! enddo - ! enddo - ! enddo - ! !$omp end parallel do - ! endif - - ! return - - ! end subroutine interpolate3D_vec - - !------------------------------------------------------------ - ! interface to kernel routine to avoid problems with openMP - !----------------------------------------------------------- - real function wkernel(q2) - use kernel, only:wkern - real, intent(in) :: q2 - real :: q - q = sqrt(q2) - wkernel = wkern(q2,q) - - end function wkernel - - !------------------------------------------------------------ - ! 3D functions to evaluate exact overlap of kernel with wall boundaries - ! see Petkova, Laibe & Bonnell (2018), J. Comp. Phys - !------------------------------------------------------------ - real function wallint(r0, xp, yp, xc, yc, pixwidthx, pixwidthy, hi) - real, intent(in) :: r0, xp, yp, xc, yc, pixwidthx, pixwidthy, hi - real(doub_prec) :: R_0, d1, d2, dx, dy, h - - wallint = 0.0 - dx = xc - xp - dy = yc - yp - h = hi - - ! - ! Contributions from each of the 4 sides of a cell wall - ! - R_0 = 0.5*pixwidthy + dy - d1 = 0.5*pixwidthx - dx - d2 = 0.5*pixwidthx + dx - wallint = wallint + pint3D(r0, R_0, d1, d2, h) - - R_0 = 0.5*pixwidthy - dy - d1 = 0.5*pixwidthx + dx - d2 = 0.5*pixwidthx - dx - wallint = wallint + pint3D(r0, R_0, d1, d2, h) - - R_0 = 0.5*pixwidthx + dx - d1 = 0.5*pixwidthy + dy - d2 = 0.5*pixwidthy - dy - wallint = wallint + pint3D(r0, R_0, d1, d2, h) - - R_0 = 0.5*pixwidthx - dx - d1 = 0.5*pixwidthy - dy - d2 = 0.5*pixwidthy + dy - wallint = wallint + pint3D(r0, R_0, d1, d2, h) - - end function wallint - - - real function pint3D(r0, R_0, d1, d2, hi) - - real(doub_prec), intent(in) :: R_0, d1, d2, hi - real, intent(in) :: r0 - real(doub_prec) :: ar0, aR_0 - real(doub_prec) :: int1, int2 - integer :: fflag = 0 - - if (abs(r0) < tiny(0.)) then - pint3D = 0.d0 - return - endif - - if (r0 > 0.d0) then - pint3D = 1.d0 - ar0 = r0 - else - pint3D = -1.d0 - ar0 = -r0 - endif - - if (R_0 > 0.d0) then - aR_0 = R_0 - else - pint3D = -pint3D - aR_0 = -R_0 - endif - - int1 = full_integral_3D(d1, ar0, aR_0, hi) - int2 = full_integral_3D(d2, ar0, aR_0, hi) - - if (int1 < 0.d0) int1 = 0.d0 - if (int2 < 0.d0) int2 = 0.d0 - - if (d1*d2 >= 0) then - pint3D = pint3D*(int1 + int2) - if (int1 + int2 < 0.d0) print*, 'Error: int1 + int2 < 0' - elseif (abs(d1) < abs(d2)) then - pint3D = pint3D*(int2 - int1) - if (int2 - int1 < 0.d0) print*, 'Error: int2 - int1 < 0: ', int1, int2, '(', d1, d2,')' - else - pint3D = pint3D*(int1 - int2) - if (int1 - int2 < 0.d0) print*, 'Error: int1 - int2 < 0: ', int1, int2, '(', d1, d2,')' - endif - - end function pint3D - - real(doub_prec) function full_integral_3D(d, r0, R_0, h) - - real(doub_prec), intent(in) :: d, r0, R_0, h - real(doub_prec) :: B1, B2, B3, a, logs, u, u2, h2 - real(doub_prec), parameter :: pi = 4.*atan(1.) - real(doub_prec) :: tanphi, phi, a2, cosp, cosp2, mu2, mu2_1, r0h, r03, r0h2, r0h3, r0h_2, r0h_3, tanp - real(doub_prec) :: r2, R_, linedist2, phi1, phi2, cosphi, sinphi - real(doub_prec) :: I0, I1, I_1, I_2, I_3, I_4, I_5 - real(doub_prec) :: J_1, J_2, J_3, J_4, J_5 - real(doub_prec) :: D1, D2, D3 - - r0h = r0/h - tanphi = abs(d)/R_0 - phi = atan(tanphi) - - if (abs(r0h) < tiny(0.) .or. abs(R_0/h) < tiny(0.) .or. abs(phi) < tiny(0.)) then - full_integral_3D = 0.0 - return - endif - - h2 = h*h - r03 = r0*r0*r0 - r0h2 = r0h*r0h - r0h3 = r0h2*r0h - r0h_2 = 1./r0h2 - r0h_3 = 1./r0h3 - - if (r0 >= 2.0*h) then - B3 = 0.25*h2*h - elseif (r0 > h) then - B3 = 0.25*r03 *(-4./3. + (r0h) - 0.3*r0h2 + 1./30.*r0h3 - 1./15. *r0h_3+ 8./5.*r0h_2) - B2 = 0.25*r03 *(-4./3. + (r0h) - 0.3*r0h2 + 1./30.*r0h3 - 1./15. *r0h_3) - else - B3 = 0.25*r03 *(-2./3. + 0.3*r0h2 - 0.1*r0h3 + 7./5.*r0h_2) - B2 = 0.25*r03 *(-2./3. + 0.3*r0h2 - 0.1*r0h3 - 1./5.*r0h_2) - B1 = 0.25*r03 *(-2./3. + 0.3*r0h2 - 0.1*r0h3) - endif - - a = R_0/r0 - a2 = a*a - - linedist2 = (r0*r0 + R_0*R_0) - cosphi = cos(phi) - R_ = R_0/cosphi - r2 = (r0*r0 + R_*R_) - - D2 = 0.0 - D3 = 0.0 - - if (linedist2 < h2) then - !////// phi1 business ///// - cosp = R_0/sqrt(h2-r0*r0) - call get_I_terms(cosp,a2,a,I0,I1,I_2,I_3,I_4,I_5) - - D2 = -1./6.*I_2 + 0.25*(r0h) *I_3 - 0.15*r0h2 *I_4 + 1./30.*r0h3 *I_5 - 1./60. *r0h_3 *I1 + (B1-B2)/r03 *I0 - endif - if (linedist2 < 4.*h2) then - !////// phi2 business ///// - cosp = R_0/sqrt(4.0*h2-r0*r0) - call get_I_terms(cosp,a2,a,I0,I1,I_2,I_3,I_4,I_5) - - D3 = 1./3.*I_2 - 0.25*(r0h) *I_3 + 3./40.*r0h2 *I_4 - 1./120.*r0h3 *I_5 + 4./15. *r0h_3 *I1 + (B2-B3)/r03 *I0 + D2 - endif - - !////////////////////////////// - call get_I_terms(cosphi,a2,a,I0,I1,I_2,I_3,I_4,I_5,phi=phi,tanphi=tanphi) - - if (r2 < h2) then - full_integral_3D = r0h3/pi * (1./6. *I_2 - 3./40.*r0h2 *I_4 + 1./40.*r0h3 *I_5 + B1/r03 *I0) - elseif (r2 < 4.*h2) then - full_integral_3D= r0h3/pi * (0.25 * (4./3. *I_2 - (r0/h) *I_3 + 0.3*r0h2 *I_4 - & - & 1./30.*r0h3 *I_5 + 1./15. *r0h_3 *I1) + B2/r03 *I0 + D2) - else - full_integral_3D = r0h3/pi * (-0.25*r0h_3 *I1 + B3/r03 *I0 + D3) - endif - - end function full_integral_3D - - subroutine get_I_terms(cosp,a2,a,I0,I1,I_2,I_3,I_4,I_5,phi,tanphi) - real(doub_prec), intent(in) :: cosp,a2,a - real(doub_prec), intent(out) :: I0,I1,I_2,I_3,I_4,I_5 - real(doub_prec), intent(in), optional :: phi,tanphi - real(doub_prec) :: cosp2,p,tanp,u2,u,logs,I_1,mu2_1,fac - - cosp2 = cosp*cosp - if (present(phi)) then - p = phi - tanp = tanphi - else - p = acos(cosp) - tanp = sqrt(1.-cosp2)/cosp ! tan(p) - endif - - mu2_1 = 1. / (1. + cosp2/a2) - I0 = p - I_2 = p + a2 * tanp - I_4 = p + 2.*a2 * tanp + 1./3.*a2*a2 * tanp*(2. + 1./cosp2) - - u2 = (1.-cosp2)*mu2_1 - u = sqrt(u2) - logs = log((1.+u)/(1.-u)) - I1 = atan2(u,a) - - fac = 1./(1.-u2) - I_1 = 0.5*a*logs + I1 - I_3 = I_1 + a*0.25*(1.+a2)*(2.*u*fac + logs) - I_5 = I_3 + a*(1.+a2)*(1.+a2)/16. *( (10.*u - 6.*u*u2)*fac*fac + 3.*logs) - - end subroutine get_I_terms - - !------------------------------------------------------------ - ! function to return a soft maximum for 1/x with no bias - ! for x >> eps using the cubic spline kernel softening - ! i.e. something equivalent to 1/sqrt(x**2 + eps**2) but - ! with compact support, i.e. f=1/x when x > 2*eps - !------------------------------------------------------------ - pure elemental real function soft_func(x,eps) result(f) - real, intent(in) :: x,eps - real :: q,q2, q4, q6 - - q = x/eps - q2 = q*q - if (q < 1.) then - q4 = q2*q2 - f = (1./eps)*(q4*q/10. - 3.*q4/10. + 2.*q2/3. - 7./5.) - elseif (q < 2.) then - q4 = q2*q2 - f = (1./eps)*(q*(-q4*q + 9.*q4 - 30.*q2*q + 40.*q2 - 48.) + 2.)/(30.*q) - else - f = -1./x - endif - f = -f - - end function soft_func - - !-------------------------------------------------------------------------- - ! - ! utility to wrap pixel index around periodic domain - ! indices that roll beyond the last position are re-introduced at the first - ! - !-------------------------------------------------------------------------- - pure integer function iroll(i,n) - integer, intent(in) :: i,n - - if (i > n) then - iroll = mod(i-1,n) + 1 - elseif (i < 1) then - iroll = n + mod(i,n) ! mod is negative - else - iroll = i - endif - - end function iroll + endif + ! + !--normalise dat array + ! + if (normalise) then + where (datnorm > tiny(datnorm)) + datsmooth = datsmooth/datnorm + end where + endif + if (allocated(datnorm)) deallocate(datnorm) + + !call wall_time(t_end) + call cpu_time(t_end) + t_used = t_end - t_start + print*, 'completed in ',t_end-t_start,'s' + !if (t_used > 10.) call print_time(t_used) + + !print*, 'Number of particles in the volume: ', usedpart + ! datsmooth(1,1,1) = 3.14159 + ! datsmooth(32,32,32) = 3.145159 + ! datsmooth(11,11,11) = 3.14159 + ! datsmooth(10,10,10) = 3.145159 + +end subroutine interpolate3D + + ! subroutine interpolate3D_vec(x,y,z,hh,weight,datvec,itype,npart,& + ! xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& + ! normalise,periodicx,periodicy,periodicz) + + ! integer, intent(in) :: npart,npixx,npixy,npixz + ! real, intent(in), dimension(npart) :: x,y,z,hh,weight + ! real, intent(in), dimension(npart,3) :: datvec + ! integer, intent(in), dimension(npart) :: itype + ! real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz + ! real(doub_prec), intent(out), dimension(3,npixx,npixy,npixz) :: datsmooth + ! logical, intent(in) :: normalise,periodicx,periodicy,periodicz + ! real(doub_prec), dimension(npixx,npixy,npixz) :: datnorm + + ! integer :: i,ipix,jpix,kpix + ! integer :: iprintinterval,iprintnext + ! integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax + ! integer :: ipixi,jpixi,kpixi,nxpix,nwarn + ! real :: xminpix,yminpix,zminpix + ! real, dimension(npixx) :: dx2i + ! real :: xi,yi,zi,hi,hi1,hi21,radkern,wab,q2,const,dyz2,dz2 + ! real :: termnorm,dy,dz,ypix,zpix,xpixi,ddatnorm + ! real, dimension(3) :: term + ! !real :: t_start,t_end + ! logical :: iprintprogress + ! !$ integer :: omp_get_num_threads + ! integer(kind=selected_int_kind(10)) :: iprogress ! up to 10 digits + + ! datsmooth = 0. + ! datnorm = 0. + ! if (normalise) then + ! print "(1x,a)",'interpolating to 3D grid (normalised) ...' + ! else + ! print "(1x,a)",'interpolating to 3D grid (non-normalised) ...' + ! endif + ! if (pixwidthx <= 0. .or. pixwidthy <= 0. .or. pixwidthz <= 0.) then + ! print "(1x,a)",'interpolate3D: error: pixel width <= 0' + ! return + ! endif + ! if (any(hh(1:npart) <= tiny(hh))) then + ! print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' + ! endif + + ! ! + ! !--print a progress report if it is going to take a long time + ! ! (a "long time" is, however, somewhat system dependent) + ! ! + ! iprintprogress = (npart >= 100000) .or. (npixx*npixy > 100000) + ! !$ iprintprogress = .false. + ! ! + ! !--loop over particles + ! ! + ! iprintinterval = 25 + ! if (npart >= 1e6) iprintinterval = 10 + ! iprintnext = iprintinterval + ! ! + ! !--get starting CPU time + ! ! + ! !call cpu_time(t_start) + + ! xminpix = xmin - 0.5*pixwidthx + ! yminpix = ymin - 0.5*pixwidthy + ! zminpix = zmin - 0.5*pixwidthz + + ! const = cnormk3D ! normalisation constant (3D) + ! nwarn = 0 + + ! !$omp parallel default(none) & + ! !$omp shared(hh,z,x,y,weight,datvec,itype,datsmooth,npart) & + ! !$omp shared(xmin,ymin,zmin,radkernel,radkernel2) & + ! !$omp shared(xminpix,yminpix,zminpix,pixwidthx,pixwidthy,pixwidthz) & + ! !$omp shared(npixx,npixy,npixz,const) & + ! !$omp shared(iprintprogress,iprintinterval) & + ! !$omp shared(datnorm,normalise,periodicx,periodicy,periodicz) & + ! !$omp private(hi,xi,yi,zi,radkern,hi1,hi21) & + ! !$omp private(term,termnorm,xpixi) & + ! !$omp private(iprogress,iprintnext) & + ! !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & + ! !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & + ! !$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & + ! !$omp reduction(+:nwarn) + ! !$omp master + ! !$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' + ! !$omp end master + ! ! + ! !--loop over particles + ! ! + ! !$omp do schedule (guided, 2) + ! over_parts: do i=1,npart + ! ! + ! !--report on progress + ! ! + ! if (iprintprogress) then + ! iprogress = 100*i/npart + ! if (iprogress >= iprintnext) then + ! write(*,"('(',i3,'% -',i12,' particles done)')") iprogress,i + ! iprintnext = iprintnext + iprintinterval + ! endif + ! endif + ! ! + ! !--skip particles with itype < 0 + ! ! + ! if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts + + ! hi = hh(i) + ! if (hi <= 0.) cycle over_parts + + ! ! + ! !--set kernel related quantities + ! ! + ! xi = x(i) + ! yi = y(i) + ! zi = z(i) + + ! hi1 = 1./hi + ! hi21 = hi1*hi1 + ! radkern = radkernel*hi ! radius of the smoothing kernel + ! termnorm = const*weight(i) + ! term(:) = termnorm*datvec(i,:) + ! ! + ! !--for each particle work out which pixels it contributes to + ! ! + ! ipixmin = int((xi - radkern - xmin)/pixwidthx) + ! jpixmin = int((yi - radkern - ymin)/pixwidthy) + ! kpixmin = int((zi - radkern - zmin)/pixwidthz) + ! ipixmax = int((xi + radkern - xmin)/pixwidthx) + 1 + ! jpixmax = int((yi + radkern - ymin)/pixwidthy) + 1 + ! kpixmax = int((zi + radkern - zmin)/pixwidthz) + 1 + + ! if (.not.periodicx) then + ! if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute + ! if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image + ! endif + ! if (.not.periodicy) then + ! if (jpixmin < 1) jpixmin = 1 + ! if (jpixmax > npixy) jpixmax = npixy + ! endif + ! if (.not.periodicz) then + ! if (kpixmin < 1) kpixmin = 1 + ! if (kpixmax > npixz) kpixmax = npixz + ! endif + ! ! + ! !--precalculate an array of dx2 for this particle (optimisation) + ! ! + ! nxpix = 0 + ! do ipix=ipixmin,ipixmax + ! nxpix = nxpix + 1 + ! ipixi = ipix + ! if (periodicx) ipixi = iroll(ipix,npixx) + ! xpixi = xminpix + ipix*pixwidthx + ! !--watch out for errors with perioic wrapping... + ! if (nxpix <= size(dx2i)) then + ! dx2i(nxpix) = ((xpixi - xi)**2)*hi21 + ! endif + ! enddo + + ! !--if particle contributes to more than npixx pixels + ! ! (i.e. periodic boundaries wrap more than once) + ! ! truncate the contribution and give warning + ! if (nxpix > npixx) then + ! nwarn = nwarn + 1 + ! ipixmax = ipixmin + npixx - 1 + ! endif + ! ! + ! !--loop over pixels, adding the contribution from this particle + ! ! + ! do kpix = kpixmin,kpixmax + ! kpixi = kpix + ! if (periodicz) kpixi = iroll(kpix,npixz) + ! zpix = zminpix + kpix*pixwidthz + ! dz = zpix - zi + ! dz2 = dz*dz*hi21 + + ! do jpix = jpixmin,jpixmax + ! jpixi = jpix + ! if (periodicy) jpixi = iroll(jpix,npixy) + ! ypix = yminpix + jpix*pixwidthy + ! dy = ypix - yi + ! dyz2 = dy*dy*hi21 + dz2 + + ! nxpix = 0 + ! do ipix = ipixmin,ipixmax + ! ipixi = ipix + ! if (periodicx) ipixi = iroll(ipix,npixx) + ! nxpix = nxpix + 1 + ! q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 + ! ! + ! !--SPH kernel - standard cubic spline + ! ! + ! if (q2 < radkernel2) then + ! wab = wkernel(q2) + ! ! + ! !--calculate data value at this pixel using the summation interpolant + ! ! + ! !$omp atomic + ! datsmooth(1,ipixi,jpixi,kpixi) = datsmooth(1,ipixi,jpixi,kpixi) + term(1)*wab + ! !$omp atomic + ! datsmooth(2,ipixi,jpixi,kpixi) = datsmooth(2,ipixi,jpixi,kpixi) + term(2)*wab + ! !$omp atomic + ! datsmooth(3,ipixi,jpixi,kpixi) = datsmooth(3,ipixi,jpixi,kpixi) + term(3)*wab + ! if (normalise) then + ! !$omp atomic + ! datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + ! endif + ! endif + ! enddo + ! enddo + ! enddo + ! enddo over_parts + ! !$omp enddo + ! !$omp end parallel + + ! if (nwarn > 0) then + ! print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& + ! ' that wrap periodic boundaries more than once' + ! endif + ! ! + ! !--normalise dat array + ! ! + ! if (normalise) then + ! !$omp parallel do default(none) schedule(static) & + ! !$omp shared(datsmooth,datnorm,npixz,npixy,npixx) & + ! !$omp private(kpix,jpix,ipix,ddatnorm) + ! do kpix=1,npixz + ! do jpix=1,npixy + ! do ipix=1,npixx + ! if (datnorm(ipix,jpix,kpix) > tiny(datnorm)) then + ! ddatnorm = 1./datnorm(ipix,jpix,kpix) + ! datsmooth(1,ipix,jpix,kpix) = datsmooth(1,ipix,jpix,kpix)*ddatnorm + ! datsmooth(2,ipix,jpix,kpix) = datsmooth(2,ipix,jpix,kpix)*ddatnorm + ! datsmooth(3,ipix,jpix,kpix) = datsmooth(3,ipix,jpix,kpix)*ddatnorm + ! endif + ! enddo + ! enddo + ! enddo + ! !$omp end parallel do + ! endif + + ! return + + ! end subroutine interpolate3D_vec + + !------------------------------------------------------------ + ! interface to kernel routine to avoid problems with openMP + !----------------------------------------------------------- +real function wkernel(q2) + use kernel, only:wkern + real, intent(in) :: q2 + real :: q + q = sqrt(q2) + wkernel = wkern(q2,q) + +end function wkernel + + !------------------------------------------------------------ + ! 3D functions to evaluate exact overlap of kernel with wall boundaries + ! see Petkova, Laibe & Bonnell (2018), J. Comp. Phys + !------------------------------------------------------------ +real function wallint(r0, xp, yp, xc, yc, pixwidthx, pixwidthy, hi) + real, intent(in) :: r0, xp, yp, xc, yc, pixwidthx, pixwidthy, hi + real(doub_prec) :: R_0, d1, d2, dx, dy, h + + wallint = 0.0 + dx = xc - xp + dy = yc - yp + h = hi + + ! + ! Contributions from each of the 4 sides of a cell wall + ! + R_0 = 0.5*pixwidthy + dy + d1 = 0.5*pixwidthx - dx + d2 = 0.5*pixwidthx + dx + wallint = wallint + pint3D(r0, R_0, d1, d2, h) + + R_0 = 0.5*pixwidthy - dy + d1 = 0.5*pixwidthx + dx + d2 = 0.5*pixwidthx - dx + wallint = wallint + pint3D(r0, R_0, d1, d2, h) + + R_0 = 0.5*pixwidthx + dx + d1 = 0.5*pixwidthy + dy + d2 = 0.5*pixwidthy - dy + wallint = wallint + pint3D(r0, R_0, d1, d2, h) + + R_0 = 0.5*pixwidthx - dx + d1 = 0.5*pixwidthy - dy + d2 = 0.5*pixwidthy + dy + wallint = wallint + pint3D(r0, R_0, d1, d2, h) + +end function wallint + + +real function pint3D(r0, R_0, d1, d2, hi) + + real(doub_prec), intent(in) :: R_0, d1, d2, hi + real, intent(in) :: r0 + real(doub_prec) :: ar0, aR_0 + real(doub_prec) :: int1, int2 + integer :: fflag = 0 + + if (abs(r0) < tiny(0.)) then + pint3D = 0.d0 + return + endif + + if (r0 > 0.d0) then + pint3D = 1.d0 + ar0 = r0 + else + pint3D = -1.d0 + ar0 = -r0 + endif + + if (R_0 > 0.d0) then + aR_0 = R_0 + else + pint3D = -pint3D + aR_0 = -R_0 + endif + + int1 = full_integral_3D(d1, ar0, aR_0, hi) + int2 = full_integral_3D(d2, ar0, aR_0, hi) + + if (int1 < 0.d0) int1 = 0.d0 + if (int2 < 0.d0) int2 = 0.d0 + + if (d1*d2 >= 0) then + pint3D = pint3D*(int1 + int2) + if (int1 + int2 < 0.d0) print*, 'Error: int1 + int2 < 0' + elseif (abs(d1) < abs(d2)) then + pint3D = pint3D*(int2 - int1) + if (int2 - int1 < 0.d0) print*, 'Error: int2 - int1 < 0: ', int1, int2, '(', d1, d2,')' + else + pint3D = pint3D*(int1 - int2) + if (int1 - int2 < 0.d0) print*, 'Error: int1 - int2 < 0: ', int1, int2, '(', d1, d2,')' + endif + +end function pint3D + +real(doub_prec) function full_integral_3D(d, r0, R_0, h) + + real(doub_prec), intent(in) :: d, r0, R_0, h + real(doub_prec) :: B1, B2, B3, a, logs, u, u2, h2 + real(doub_prec), parameter :: pi = 4.*atan(1.) + real(doub_prec) :: tanphi, phi, a2, cosp, cosp2, mu2, mu2_1, r0h, r03, r0h2, r0h3, r0h_2, r0h_3, tanp + real(doub_prec) :: r2, R_, linedist2, phi1, phi2, cosphi, sinphi + real(doub_prec) :: I0, I1, I_1, I_2, I_3, I_4, I_5 + real(doub_prec) :: J_1, J_2, J_3, J_4, J_5 + real(doub_prec) :: D1, D2, D3 + + r0h = r0/h + tanphi = abs(d)/R_0 + phi = atan(tanphi) + + if (abs(r0h) < tiny(0.) .or. abs(R_0/h) < tiny(0.) .or. abs(phi) < tiny(0.)) then + full_integral_3D = 0.0 + return + endif + + h2 = h*h + r03 = r0*r0*r0 + r0h2 = r0h*r0h + r0h3 = r0h2*r0h + r0h_2 = 1./r0h2 + r0h_3 = 1./r0h3 + + if (r0 >= 2.0*h) then + B3 = 0.25*h2*h + elseif (r0 > h) then + B3 = 0.25*r03 *(-4./3. + (r0h) - 0.3*r0h2 + 1./30.*r0h3 - 1./15. *r0h_3+ 8./5.*r0h_2) + B2 = 0.25*r03 *(-4./3. + (r0h) - 0.3*r0h2 + 1./30.*r0h3 - 1./15. *r0h_3) + else + B3 = 0.25*r03 *(-2./3. + 0.3*r0h2 - 0.1*r0h3 + 7./5.*r0h_2) + B2 = 0.25*r03 *(-2./3. + 0.3*r0h2 - 0.1*r0h3 - 1./5.*r0h_2) + B1 = 0.25*r03 *(-2./3. + 0.3*r0h2 - 0.1*r0h3) + endif + + a = R_0/r0 + a2 = a*a + + linedist2 = (r0*r0 + R_0*R_0) + cosphi = cos(phi) + R_ = R_0/cosphi + r2 = (r0*r0 + R_*R_) + + D2 = 0.0 + D3 = 0.0 + + if (linedist2 < h2) then + !////// phi1 business ///// + cosp = R_0/sqrt(h2-r0*r0) + call get_I_terms(cosp,a2,a,I0,I1,I_2,I_3,I_4,I_5) + + D2 = -1./6.*I_2 + 0.25*(r0h) *I_3 - 0.15*r0h2 *I_4 + 1./30.*r0h3 *I_5 - 1./60. *r0h_3 *I1 + (B1-B2)/r03 *I0 + endif + if (linedist2 < 4.*h2) then + !////// phi2 business ///// + cosp = R_0/sqrt(4.0*h2-r0*r0) + call get_I_terms(cosp,a2,a,I0,I1,I_2,I_3,I_4,I_5) + + D3 = 1./3.*I_2 - 0.25*(r0h) *I_3 + 3./40.*r0h2 *I_4 - 1./120.*r0h3 *I_5 + 4./15. *r0h_3 *I1 + (B2-B3)/r03 *I0 + D2 + endif + + !////////////////////////////// + call get_I_terms(cosphi,a2,a,I0,I1,I_2,I_3,I_4,I_5,phi=phi,tanphi=tanphi) + + if (r2 < h2) then + full_integral_3D = r0h3/pi * (1./6. *I_2 - 3./40.*r0h2 *I_4 + 1./40.*r0h3 *I_5 + B1/r03 *I0) + elseif (r2 < 4.*h2) then + full_integral_3D= r0h3/pi * (0.25 * (4./3. *I_2 - (r0/h) *I_3 + 0.3*r0h2 *I_4 - & + & 1./30.*r0h3 *I_5 + 1./15. *r0h_3 *I1) + B2/r03 *I0 + D2) + else + full_integral_3D = r0h3/pi * (-0.25*r0h_3 *I1 + B3/r03 *I0 + D3) + endif + +end function full_integral_3D + +subroutine get_I_terms(cosp,a2,a,I0,I1,I_2,I_3,I_4,I_5,phi,tanphi) + real(doub_prec), intent(in) :: cosp,a2,a + real(doub_prec), intent(out) :: I0,I1,I_2,I_3,I_4,I_5 + real(doub_prec), intent(in), optional :: phi,tanphi + real(doub_prec) :: cosp2,p,tanp,u2,u,logs,I_1,mu2_1,fac + + cosp2 = cosp*cosp + if (present(phi)) then + p = phi + tanp = tanphi + else + p = acos(cosp) + tanp = sqrt(1.-cosp2)/cosp ! tan(p) + endif + + mu2_1 = 1. / (1. + cosp2/a2) + I0 = p + I_2 = p + a2 * tanp + I_4 = p + 2.*a2 * tanp + 1./3.*a2*a2 * tanp*(2. + 1./cosp2) + + u2 = (1.-cosp2)*mu2_1 + u = sqrt(u2) + logs = log((1.+u)/(1.-u)) + I1 = atan2(u,a) + + fac = 1./(1.-u2) + I_1 = 0.5*a*logs + I1 + I_3 = I_1 + a*0.25*(1.+a2)*(2.*u*fac + logs) + I_5 = I_3 + a*(1.+a2)*(1.+a2)/16. *( (10.*u - 6.*u*u2)*fac*fac + 3.*logs) + +end subroutine get_I_terms + + !------------------------------------------------------------ + ! function to return a soft maximum for 1/x with no bias + ! for x >> eps using the cubic spline kernel softening + ! i.e. something equivalent to 1/sqrt(x**2 + eps**2) but + ! with compact support, i.e. f=1/x when x > 2*eps + !------------------------------------------------------------ +pure elemental real function soft_func(x,eps) result(f) + real, intent(in) :: x,eps + real :: q,q2, q4, q6 + + q = x/eps + q2 = q*q + if (q < 1.) then + q4 = q2*q2 + f = (1./eps)*(q4*q/10. - 3.*q4/10. + 2.*q2/3. - 7./5.) + elseif (q < 2.) then + q4 = q2*q2 + f = (1./eps)*(q*(-q4*q + 9.*q4 - 30.*q2*q + 40.*q2 - 48.) + 2.)/(30.*q) + else + f = -1./x + endif + f = -f + +end function soft_func + + !-------------------------------------------------------------------------- + ! + ! utility to wrap pixel index around periodic domain + ! indices that roll beyond the last position are re-introduced at the first + ! + !-------------------------------------------------------------------------- +pure integer function iroll(i,n) + integer, intent(in) :: i,n + + if (i > n) then + iroll = mod(i-1,n) + 1 + elseif (i < 1) then + iroll = n + mod(i,n) ! mod is negative + else + iroll = i + endif + +end function iroll end module interpolations3D diff --git a/src/utils/interpolate3Dold.F90 b/src/utils/interpolate3Dold.F90 index 32766e956..d1344fd96 100644 --- a/src/utils/interpolate3Dold.F90 +++ b/src/utils/interpolate3Dold.F90 @@ -163,7 +163,7 @@ subroutine interpolate3D(xyzh,weight,npart, & ! !--report on progress ! - !print*, i + !print*, i #ifndef _OPENMP if (iprintprogress) then iprogress = nint(100.*i/npart) @@ -185,9 +185,9 @@ subroutine interpolate3D(xyzh,weight,npart, & if (hi <= 0.) cycle over_parts hi1 = 1./hi; hi21 = hi1*hi1 termnorm = const*weight - ! print*, "const: ", const - ! print*, "weight: ", weight - ! print*, "termnorm: ", termnorm + ! print*, "const: ", const + ! print*, "weight: ", weight + ! print*, "termnorm: ", termnorm !radkern = 2.*hi ! radius of the smoothing kernel !print*, "radkern: ", radkern @@ -246,9 +246,9 @@ subroutine interpolate3D(xyzh,weight,npart, & endif #endif if (vertexcen) then - zpix = xmin(3) + (kpixi-1)*dxcell(3) + zpix = xmin(3) + (kpixi-1)*dxcell(3) else - zpix = xmin(3) + (kpixi-0.5)*dxcell(3) + zpix = xmin(3) + (kpixi-0.5)*dxcell(3) endif dz = zpix - zi dz2 = dz*dz*hi21 @@ -267,9 +267,9 @@ subroutine interpolate3D(xyzh,weight,npart, & endif #endif if (vertexcen) then - ypix = xmin(2) + (jpixi-1)*dxcell(2) + ypix = xmin(2) + (jpixi-1)*dxcell(2) else - ypix = xmin(2) + (jpixi-0.5)*dxcell(2) + ypix = xmin(2) + (jpixi-0.5)*dxcell(2) endif dy = ypix - yi dyz2 = dy*dy*hi21 + dz2 @@ -293,46 +293,46 @@ subroutine interpolate3D(xyzh,weight,npart, & endif #endif icell = ((kpixi-1)*nsub + (jpixi-1))*nsub + ipixi + ! + !--particle interpolates directly onto the root grid + ! + !print*,'onto root grid ',ipixi,jpixi,kpixi + if (vertexcen) then + xpix = xmin(1) + (ipixi-1)*dxcell(1) + else + xpix = xmin(1) + (ipixi-0.5)*dxcell(1) + endif + !print*, "xpix: ", xpix + !xpix = xmin(1) + (ipixi-1)*dxcell(1) ! Since we are vertex centered from Et + dx = xpix - xi + q2 = dx*dx*hi21 + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 + ! + !--SPH kernel - standard cubic spline + ! + if (q2 < radkern2) then + ! if (q2 < 1.0) then + ! qq = sqrt(q2) + ! wab = 1.-1.5*q2 + 0.75*q2*qq + ! else + ! qq = sqrt(q2) + ! wab = 0.25*(2.-qq)**3 + ! endif + ! Call the kernel routine + qq = sqrt(q2) + wab = wkern(q2,qq) ! - !--particle interpolates directly onto the root grid - ! - !print*,'onto root grid ',ipixi,jpixi,kpixi - if (vertexcen) then - xpix = xmin(1) + (ipixi-1)*dxcell(1) - else - xpix = xmin(1) + (ipixi-0.5)*dxcell(1) - endif - !print*, "xpix: ", xpix - !xpix = xmin(1) + (ipixi-1)*dxcell(1) ! Since we are vertex centered from Et - dx = xpix - xi - q2 = dx*dx*hi21 + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 - ! - !--SPH kernel - standard cubic spline + !--calculate data value at this pixel using the summation interpolant ! - if (q2 < radkern2) then - ! if (q2 < 1.0) then - ! qq = sqrt(q2) - ! wab = 1.-1.5*q2 + 0.75*q2*qq - ! else - ! qq = sqrt(q2) - ! wab = 0.25*(2.-qq)**3 - ! endif - ! Call the kernel routine - qq = sqrt(q2) - wab = wkern(q2,qq) - ! - !--calculate data value at this pixel using the summation interpolant - ! - ! Change this to the access the pixel coords x,y,z - !$omp critical - datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + ! Change this to the access the pixel coords x,y,z + !$omp critical + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab - !if (ipixi==1 .and. jpixi==1 .and. kpixi==1) print*, "x position of 1,1,1", xi,yi,zi - if (normalise) then - datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - endif - !$omp end critical + !if (ipixi==1 .and. jpixi==1 .and. kpixi==1) print*, "x position of 1,1,1", xi,yi,zi + if (normalise) then + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab endif + !$omp end critical + endif enddo enddo enddo @@ -349,10 +349,10 @@ subroutine interpolate3D(xyzh,weight,npart, & !--normalise dat array ! if (normalise) then - where (datnorm > tiny(datnorm)) - datsmooth = datsmooth/datnorm - end where -endif + where (datnorm > tiny(datnorm)) + datsmooth = datsmooth/datnorm + end where + endif if (allocated(datnorm)) deallocate(datnorm) ! !--get ending CPU time From 995d246ed8d5ec8d547f1d7eb54566f61751bac6 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 2 May 2023 12:22:48 +1000 Subject: [PATCH 047/814] fixed tmunu allocation error --- src/main/part.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/main/part.F90 b/src/main/part.F90 index a09da43cd..bbac0611d 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -545,6 +545,7 @@ subroutine deallocate_part if (allocated(dens)) deallocate(dens) if (allocated(metrics)) deallocate(metrics) if (allocated(metricderivs)) deallocate(metricderivs) + if (allocated(tmunus)) deallocate(tmunus) if (allocated(xyzmh_ptmass)) deallocate(xyzmh_ptmass) if (allocated(vxyz_ptmass)) deallocate(vxyz_ptmass) if (allocated(fxyz_ptmass)) deallocate(fxyz_ptmass) From 71866a7c120a6b045583213d7aa75bebb6b4b151 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 2 May 2023 14:47:12 +1000 Subject: [PATCH 048/814] Fixed sqrtg allocation error --- src/main/part.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/main/part.F90 b/src/main/part.F90 index bbac0611d..80ac08f3e 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -546,6 +546,7 @@ subroutine deallocate_part if (allocated(metrics)) deallocate(metrics) if (allocated(metricderivs)) deallocate(metricderivs) if (allocated(tmunus)) deallocate(tmunus) + if (allocated(sqrtgs)) deallocate(sqrtgs) if (allocated(xyzmh_ptmass)) deallocate(xyzmh_ptmass) if (allocated(vxyz_ptmass)) deallocate(vxyz_ptmass) if (allocated(fxyz_ptmass)) deallocate(fxyz_ptmass) From b892559f4e40b52bd135d77fc2bb10f2e67d0ca8 Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Wed, 10 May 2023 17:50:58 +0200 Subject: [PATCH 049/814] min with ts and not St --- src/main/dens.F90 | 2 +- src/main/force.F90 | 4 +++- src/main/growth.F90 | 33 +++++++++++++++++++-------------- src/main/porosity.f90 | 18 +++++++++++++++++- src/main/timestep.F90 | 15 ++++++++++----- 5 files changed, 50 insertions(+), 22 deletions(-) diff --git a/src/main/dens.F90 b/src/main/dens.F90 index bf666407f..07cace492 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -101,7 +101,7 @@ module densityforce !real, parameter :: cnormk = 1./pi, wab0 = 1., gradh0 = -3.*wab0, radkern2 = 4F.0 integer, parameter :: isizecellcache = 1000 integer, parameter :: isizeneighcache = 0 - integer, parameter :: maxdensits = 50 + integer, parameter :: maxdensits = 100 !--statistics which can be queried later integer, private :: maxneighact,nrelink diff --git a/src/main/force.F90 b/src/main/force.F90 index 1aec99525..0fc309762 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -3119,7 +3119,9 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv tstop(:,i) = tstopi(:) elseif (use_dust .and. .not.use_dustfrac) then tstop(:,i) = ts_min - if (.not. drag_implicit) then + if (drag_implicit) then + dtdrag = 90*ts_min + else dtdrag = 0.9*ts_min endif endif diff --git a/src/main/growth.F90 b/src/main/growth.F90 index 827ccae54..e9aaf14f2 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -23,7 +23,7 @@ module growth ! - flyby : *use primary for keplerian freq. calculation* ! - force_smax : *(mcfost) set manually maximum size for binning* ! - grainsizemin : *minimum allowed grain size in cm* -! - stokesmin : *minimum allowed Stokes number when porosity is on* +! - tsmin : *minimum allowed stopping time when porosity is on* ! - ieros : *erosion of dust (0=off,1=on)* ! - ifrag : *fragmentation of dust (0=off,1=on,2=Kobayashi)* ! - ieros : *erosion of dust (0=off,1=on) @@ -48,7 +48,7 @@ module growth integer, public :: ieros = 0 real, public :: gsizemincgs = 5.e-3 - real, public :: stokesmin = 5.e-5 + real, public :: tsmincgs = 1.e5 real, public :: rsnow = 100. real, public :: Tsnow = 150. real, public :: vfragSI = 15. @@ -62,6 +62,7 @@ module growth real, public :: vfragin real, public :: vfragout real, public :: grainsizemin + real, public :: tsmin real, public :: cohacc real, public :: dsize @@ -102,6 +103,7 @@ subroutine init_growth(ierr) grainsizemin = gsizemincgs / udist cohacc = cohacccgs * utime * utime / umass dsize = dsizecgs / udist + tsmin = tsmincgs / utime if (ifrag > 0) then if (grainsizemin < 0.) then @@ -380,7 +382,7 @@ subroutine write_options_growth(iunit) call write_inopt(ieros,'ieros','erosion of dust (0=off,1=on)',iunit) if (ifrag /= 0) then if (use_porosity) then - call write_inopt(stokesmin,'stokesmin','minimum allowed stokes number',iunit) + call write_inopt(tsmincgs,'tsmincgs','minimum allowed stopping time',iunit) else call write_inopt(gsizemincgs,'grainsizemin','minimum grain size in cm',iunit) endif @@ -434,8 +436,8 @@ subroutine read_options_growth(name,valstring,imatch,igotall,ierr) case('grainsizemin') read(valstring,*,iostat=ierr) gsizemincgs ngot = ngot + 1 - case('stokesmin') - read(valstring,*,iostat=ierr) stokesmin + case('tsmincgs') + read(valstring,*,iostat=ierr) tsmincgs ngot = ngot + 1 case('isnow') read(valstring,*,iostat=ierr) isnow @@ -529,7 +531,7 @@ subroutine write_growth_setup_options(iunit) call write_inopt(vfraginSI,'vfragin','inward fragmentation threshold in m/s',iunit) call write_inopt(vfragoutSI,'vfragout','inward fragmentation threshold in m/s',iunit) if (use_porosity) then - call write_inopt(stokesmin,'stokesmin','minimum allowed stokes number',iunit) + call write_inopt(tsmincgs,'tsmincgs','minimum allowed stopping time',iunit) else call write_inopt(gsizemincgs,'grainsizemin','minimum allowed grain size in cm',iunit) endif @@ -552,7 +554,7 @@ subroutine read_growth_setup_options(db,nerr) if (ifrag > 0) then call read_inopt(isnow,'isnow',db,min=0,max=2,errcount=nerr) if (use_porosity) then - call read_inopt(stokesmin,'stokesmin',db,min=1.e-5,errcount=nerr) + call read_inopt(tsmincgs,'tsmincgs',db,min=1.e-5,errcount=nerr) else call read_inopt(gsizemincgs,'grainsizemin',db,min=1.e-5,errcount=nerr) endif @@ -578,28 +580,28 @@ end subroutine read_growth_setup_options !+ !----------------------------------------------------------------------- subroutine check_dustprop(npart,dustprop,filfac,mprev,filfacprev) - use part, only:iamtype,iphase,idust,igas,dustgasprop + use part, only:iamtype,iphase,idust,igas,dustgasprop,Omega_k use options, only:use_dustfrac,use_porosity real,intent(inout) :: dustprop(:,:) integer,intent(in) :: npart real, intent(in) :: filfac(:),mprev(:),filfacprev(:) integer :: i,iam - real :: stokesnew,sdustprev,sdustmin,sdust + real :: tsnew,sdustprev,sdustmin,sdust !$omp parallel do default(none) & !$omp shared(iphase,dustgasprop,use_dustfrac,use_porosity) & !$omp shared(npart,ifrag,dustprop,filfac,mprev,filfacprev) & - !$omp shared(stokesmin,grainsizemin) & - !$omp private(i,iam,stokesnew,sdustprev,sdustmin,sdust) + !$omp shared(tsmin,grainsizemin) & + !$omp private(i,iam,tsnew,sdustprev,sdustmin,sdust) do i=1,npart iam = iamtype(iphase(i)) if ((iam == idust .or. (use_dustfrac .and. iam == igas)) .and. ifrag > 0 .and. dustprop(1,i) <= mprev(i)) then if (use_porosity) then sdustprev = get_size(mprev(i),dustprop(2,i),filfacprev(i)) sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) - stokesnew = dustgasprop(3,i)*sdustprev*filfacprev(i)/sdust/filfac(i) - if (stokesnew < stokesmin) then - sdustmin = stokesmin*sdustprev*filfacprev(i)/filfac(i)/dustgasprop(3,i) + tsnew = dustgasprop(3,i)*sdustprev*filfacprev(i)/sdust/filfac(i)/Omega_k(i) + if (tsnew < tsmin) then + sdustmin = tsmin*sdustprev*filfacprev(i)*Omega_k(i)/filfac(i)/dustgasprop(3,i) dustprop(1,i) = dustprop(1,i) * (sdustmin/sdust)**3. endif else @@ -639,6 +641,9 @@ subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_i r = sqrt(xyzh(1,i)**2 + xyzh(2,i)**2) h = H_R_ref * R_ref * au / udist * (r * udist / au / R_ref)**(1.5-q_index) dustprop(1,i) = grainsizecgs/udist * (r * udist / au / R_ref)**pwl_sizedistrib * exp(-0.5*xyzh(3,i)**2/h**2) + if (dustprop(1,i) < 2.e-5/udist) then + dustprop(1,i) = 2.e-5/udist + endif dustprop(1,i) = fourpi/3. * dustprop(2,i) * (dustprop(1,i))**3 else dustprop(1,i) = fourpi/3. * dustprop(2,i) * (grainsizecgs / udist)**3 diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index e79b31c7c..35db4f32b 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -106,7 +106,7 @@ subroutine init_filfac(npart,xyzh,vxyzu) select case (iporosity) ! add other case for other models here - case (-1,1) + case (1) !--initialize filling factor (Garcia & Gonzalez 2020, Suyama et al. 2008, Okuzumi et al. 2012) @@ -174,6 +174,22 @@ subroutine init_filfac(npart,xyzh,vxyzu) endif enddo endif + case (-1) + !--initialize filling factor for compact grains + if (all(filfac(:) == 0.)) then ! check if filfac(i) was already initialize by init_filfac or not + do i=1,npart + iam = iamtype(iphase(i)) + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then + sfrac = (dustprop(1,i)/mmono)**(1./3.) + if (sfrac > 1.) then ! if grainsize > monomer size, compute filling factor + filfac(i) = 1. + else + filfac(i) = 1. + dustprop(1,i) = mmono + endif + endif + enddo + endif end select end subroutine init_filfac diff --git a/src/main/timestep.F90 b/src/main/timestep.F90 index 2fe558e3f..d841c2bb5 100644 --- a/src/main/timestep.F90 +++ b/src/main/timestep.F90 @@ -22,11 +22,11 @@ module timestep integer :: nmax,nout integer :: nsteps real, parameter :: bignumber = 1.e29 - integer :: idtmax_n = 1 - integer :: idtmax_n_next = 1 - integer :: idtmax_frac = 0 - integer :: idtmax_frac_next = 0 - real :: dtmax_user = -1. ! require this initialisation for user-friendliness in phantomsetup + integer :: idtmax_n + integer :: idtmax_n_next + integer :: idtmax_frac + integer :: idtmax_frac_next + real :: dtmax_user real :: dt,dtcourant,dtforce,dtrad,dtextforce,dterr,dtdiff,time real :: dtmax_dratio, dtmax_max, dtmax_min, rhomaxnow @@ -63,6 +63,11 @@ subroutine set_defaults_timestep dtmax_max = -1.0 ! maximum dtmax allowed (to be reset to dtmax if = -1) dtmax_min = 0. ! minimum dtmax allowed + idtmax_n = 1 + idtmax_n_next = 1 + idtmax_frac = 0 + idtmax_frac_next = 0 + dtmax_user = -1. end subroutine set_defaults_timestep !----------------------------------------------------------------- From bf717dc13c0291e2872845493d4dc2affd26b20e Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Mon, 29 May 2023 15:55:22 +1000 Subject: [PATCH 050/814] Added vectorisation to interpolation --- src/main/tmunu2grid.f90 | 103 ++++++--- src/setup/set_unifdis.f90 | 2 +- src/setup/setup_flrw.f90 | 56 +++-- src/setup/stretchmap.f90 | 2 +- src/utils/interpolate3D.F90 | 433 ++++++++++++++++++++++++++++++++++-- 5 files changed, 530 insertions(+), 66 deletions(-) diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index 2939747bd..cd12b48f9 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -21,7 +21,7 @@ module tmunu2grid contains subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid - use interpolations3D, only: interpolate3D + use interpolations3D, only: interpolate3D,interpolate3D_vecexact use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax use part, only: massoftype,igas,rhoh,dens,hfact integer, intent(in) :: npart @@ -34,11 +34,11 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) integer, save :: iteration = 0 real :: xmininterp(3) integer :: ngrid(3) - real,allocatable :: datsmooth(:,:,:), dat(:) + real,allocatable :: datsmooth(:,:,:,:), dat(:,:) integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper logical :: normalise, vertexcen,periodicx,periodicy,periodicz,exact_rendering real :: totalmass, totalmassgrid - integer :: itype(npart) + integer :: itype(npart),ilendat ! total mass of the particles @@ -48,8 +48,8 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) ! Density interpolated to the grid rhostargrid = 0. - if (.not. allocated(datsmooth)) allocate (datsmooth(gridsize(1),gridsize(2),gridsize(3))) - if (.not. allocated(dat)) allocate (dat(npart)) + if (.not. allocated(datsmooth)) allocate (datsmooth(16,gridsize(1),gridsize(2),gridsize(3))) + if (.not. allocated(dat)) allocate (dat(npart,16)) ! All particles have equal weighting in the interp ! Here we calculate the weight for the first particle ! Get the smoothing length @@ -104,31 +104,78 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) tmunugrid = 0. datsmooth = 0. + + ! Vectorized tmunu calculation + + ! Put tmunu into an array of form + ! tmunu(npart,16) + do k=1, 4 + do j=1,4 + do i=1,npart + ! Check that this is correct!!! + ! print*,"i j is: ", k, j + ! print*, "Index in array is: ", (k-1)*4 + j + ! print*,tmunus(k,j,1) + dat(i, (k-1)*4 + j) = tmunus(k,j,i) + enddo + enddo +enddo +!stop +ilendat = 16 + +call interpolate3D_vecexact(xyzh,weights,dat,ilendat,itype,npart,& + xmininterp(1),xmininterp(2),xmininterp(3), & + datsmooth(:,ilower:iupper,jlower:jupper,klower:kupper),& + ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& + normalise,periodicx,periodicy,periodicz) + +! Put the smoothed array into tmunugrid +do i=1,4 + do j=1,4 + ! Check this is correct too! + !print*,"i j is: ", i, j + !print*, "Index in array is: ", (i-1)*4 + j + tmunugrid(i-1,j-1,:,:,:) = datsmooth((i-1)*4 + j, :,:,:) + print*, "tmunugrid: ", tmunugrid(i-1,j-1,10,10,10) + print*, datsmooth((i-1)*4 + j, 10,10,10) + enddo +enddo +!stop +do k=1,4 + do j=1,4 + do i=1,4 + print*, "Lock index is: ", (k-1)*16+ (j-1)*4 + i + enddo + enddo +enddo + +! tmunugrid(0,0,:,:,:) = datsmooth(1,:,:,:) + ! TODO Unroll this loop for speed + using symmetries ! Possiblly cleanup the messy indexing - do k=1,4 - do j=1,4 - do i=1, npart - dat(i) = tmunus(k,j,i) - enddo - - ! Get the position of the first grid cell x,y,z - ! Call to interpolate 3D - ! COMMENTED OUT AS NOT USED BY NEW INTERPOLATE ROUTINE - ! call interpolate3D(xyzh,weight,npart, & - ! xmininterp,tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper), & - ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) - - !print*, "Interpolated grid values are: ", datsmooth(4:38,4:38,4:38) - !stop - ! NEW INTERPOLATION ROUTINE - call interpolate3D(xyzh,weights,dat,itype,npart,& - xmininterp(1),xmininterp(2),xmininterp(3), & - tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper),& - ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& - normalise,periodicx,periodicy,periodicz) - enddo - enddo +! do k=1,4 +! do j=1,4 +! do i=1, npart +! dat(i) = tmunus(k,j,i) +! enddo + +! ! Get the position of the first grid cell x,y,z +! ! Call to interpolate 3D +! ! COMMENTED OUT AS NOT USED BY NEW INTERPOLATE ROUTINE +! ! call interpolate3D(xyzh,weight,npart, & +! ! xmininterp,tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper), & +! ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) + +! !print*, "Interpolated grid values are: ", datsmooth(4:38,4:38,4:38) +! !stop +! ! NEW INTERPOLATION ROUTINE +! call interpolate3D(xyzh,weights,dat,itype,npart,& +! xmininterp(1),xmininterp(2),xmininterp(3), & +! tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper),& +! ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& +! normalise,periodicx,periodicy,periodicz) +! enddo +! enddo ! RHOSTARGRID CALCULATION IS NOW HANDLED BY AN EXTERNAL ROUTINE ! THIS IS COMMENTED OUT IN CASE I BREAK EVERYTHING AND NEED TO GO BACK diff --git a/src/setup/set_unifdis.f90 b/src/setup/set_unifdis.f90 index 7aee54662..20c8291a6 100644 --- a/src/setup/set_unifdis.f90 +++ b/src/setup/set_unifdis.f90 @@ -583,7 +583,7 @@ subroutine set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax, & endif endif call set_density_profile(np,xyzh,min=xmins,max=xmaxs,rhofunc=rhofunc,& - start=npin,geom=igeom,coord=icoord,verbose=(id==master .and. is_verbose),err=ierr) + start=npin,geom=igeom,coord=icoord,verbose=(id==master .and. is_verbose),err=ierr)!,massfunc=massfunc) if (ierr > 0) then if (present(err)) err = ierr return diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 4b6e3283c..97701e9e0 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -133,19 +133,22 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Then it should be set using the Friedmann equation: !!!!!! rhozero = (3H^2)/(8*pi*a*a) - hub = 10.553495658357338 + hub = 10.553495658357338/100.d0 + !hub = 23.588901903912664 + !hub = 0.06472086375185665 rhozero = 3.d0 * hub**2 / (8.d0 * pi) phaseoffset = 0. ! Approx Temp of the CMB in Kelvins last_scattering_temp = 3000 - last_scattering_temp = (rhozero/radconst)**(1./4.)*0.99999 + last_scattering_temp = (rhozero/radconst)**(1./4.)*0.999999999999999d0 ! Define some parameters for Linear pertubations ! We assume ainit = 1, but this may not always be the case c1 = 1.d0/(4.d0*PI*rhozero) !c2 = We set g(x^i) = 0 as we only want to extract the growing mode - c3 = - sqrt(1.d0/(6.d0*PI*rhozero)) + c3 = - sqrt(1.d0/(6.d0*PI*rhozero)) + !c3 = hub/(4.d0*PI*rhozero) if (gr) then @@ -194,13 +197,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! general parameters ! ! time should be read in from the par file - time = 0.18951066686763596 ! z~1000 + !time = 0.08478563386065302 + time = 1.8951066686763596 ! z~1000 lambda = perturb_wavelength*length kwave = (2.d0*pi)/lambda denom = length - ampl/kwave*(cos(kwave*length)-1.0) ! Hardcode to ensure double precision, that is requried !rhozero = 13.294563008157013D0 rhozero = 3.d0 * hub**2 / (8.d0 * pi) + print*, rhozero select case(radiation_dominated) case('"yes"') @@ -209,7 +214,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, end select xval = density_func(0.75) - xval = density_func(0.0) + xval = density_func(0.5) + !stop select case(ilattice) case(2) @@ -225,7 +231,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !TODO Z AND Y LINEAR PERTURBATIONS case('"x"') call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& - npart,xyzh,periodic,nptot=npart_total,mask=i_belong,rhofunc=density_func) + npart,xyzh,periodic,nptot=npart_total,mask=i_belong,rhofunc=density_func,massfunc=mass_function) case('"y"') call set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax,zmin,zmax,deltax,hfact,& npart,xyzh,periodic,nptot=npart_total,mask=i_belong) @@ -363,26 +369,33 @@ real function rhofunc(x) ! calculate u0 ! TODO Should probably handle this error at some point call get_u0(gcov,v,u0,ierr) + !print*,"u0: ", u0 + !print*, alpha + !print*,"gcov: ", gcov + !print*, "sqrtg: ", sqrtg ! Perform a prim2cons - rhofunc = rhoprim*sqrtg*u0 + rhofunc = rhoprim*u0*sqrtg end function rhofunc real function massfunc(x,xmin) - use utils_gr, only:perturb_metric, get_u0, get_sqrtg + use utils_gr, only:perturb_metric, get_u0, get_sqrtg,dot_product_gr real, intent(in) :: x,xmin real :: const, expr, exprmin, rhoprim, gcov(0:3,0:3), sqrtg,u0,v(3),Vup(3) real :: massprimx,massprimmin,massprim + real :: lorrentz, bigv2 ! The value inside the bracket const = -kwave*kwave*c1 - 2.d0 - expr = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*x)/lambda) - exprmin = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*xmin)/lambda) - massprimx = (x-const*expr) - massprimmin = (xmin-const*exprmin) + phi = ampl*sin(kwave*x-phaseoffset) + !expr = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*x)/lambda) + !exprmin = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*xmin)/lambda) + massprimx = (x+deltaint(x)) + massprimmin = (xmin+deltaint(xmin)) ! Evalutation of the integral ! rho0[x-Acos(kx)]^x_0 massprim = rhozero*(massprimx - massprimmin) + print*, massprim ! Get the perturbed 4-metric call perturb_metric(phi,gcov) @@ -394,15 +407,30 @@ real function massfunc(x,xmin) Vup(1) = kwave*c3*ampl*cos((2.d0*pi*x)/lambda-phaseoffset) Vup(2:3) = 0. alpha = sqrt(-gcov(0,0)) + !v(0) = 1 v(1) = Vup(1)*alpha v(2:3) = 0. - + bigv2 = dot_product_gr(Vup,Vup,gcov) + lorrentz = 1./sqrt(1.-bigv2) call get_u0(gcov,v,u0,ierr) - massfunc = massprim*sqrtg*u0 + massfunc = (massprim)!*lorrentz + massfunc = massprim!*sqrtg*u0 +! print*,u0 +! print*,sqrtg +! print*, massfunc +! print*, massprim + !stop end function massfunc +real function deltaint(x) + real, intent(in) :: x + + deltaint = (1./kwave)*(kwave*kwave*c1 - 2)*ampl*cos(2*pi*x/lambda) + +end function deltaint + end subroutine setpart !------------------------------------------------------------------------ diff --git a/src/setup/stretchmap.f90 b/src/setup/stretchmap.f90 index bb0e92fa1..e03e259e2 100644 --- a/src/setup/stretchmap.f90 +++ b/src/setup/stretchmap.f90 @@ -32,7 +32,7 @@ module stretchmap public :: rho_func public :: mass_func - integer, private :: ngrid = 2048 ! number of points used when integrating rho to get mass + integer, private :: ngrid = 8192 ! number of points used when integrating rho to get mass integer, parameter, private :: maxits = 100 ! max number of iterations integer, parameter, private :: maxits_nr = 30 ! max iterations with Newton-Raphson real, parameter, private :: tol = 1.e-10 ! tolerance on iterations diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index feeb6a98f..8eabc3f8e 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -32,7 +32,8 @@ module interpolations3D implicit none integer, parameter :: doub_prec = kind(0.d0) real :: cnormk3D = cnormk - public :: interpolate3D!,interpolate3D_vec not needed + public :: interpolate3D,interpolate3D_vecexact +!$ integer(kind=8), dimension(:), private, allocatable :: ilock contains !-------------------------------------------------------------------------- @@ -64,30 +65,391 @@ module interpolations3D ! Revised for "splash to grid", Monash University 02/11/09 ! Maya Petkova contributed exact subgrid interpolation, April 2019 !-------------------------------------------------------------------------- - subroutine interpolate3D(xyzh,weight,dat,itype,npart,& + xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& + normalise,periodicx,periodicy,periodicz) + +integer, intent(in) :: npart,npixx,npixy,npixz +real, intent(in) :: xyzh(4,npart) +!real, intent(in), dimension(npart) :: x,y,z,hh ! change to xyzh() +real, intent(in), dimension(npart) :: weight,dat +integer, intent(in), dimension(npart) :: itype +real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz +real(doub_prec), intent(out), dimension(npixx,npixy,npixz) :: datsmooth +logical, intent(in) :: normalise,periodicx,periodicy,periodicz +!logical, intent(in), exact_rendering +real(doub_prec), allocatable :: datnorm(:,:,:) + +integer :: i,ipix,jpix,kpix +integer :: iprintinterval,iprintnext +integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax +integer :: ipixi,jpixi,kpixi,nxpix,nwarn,threadid +real :: xminpix,yminpix,zminpix,hmin !,dhmin3 +real, dimension(npixx) :: dx2i +real :: xi,yi,zi,hi,hi1,hi21,wab,q2,const,dyz2,dz2 +real :: term,termnorm,dy,dz,ypix,zpix,xpixi,pixwidthmax,dfac +real :: t_start,t_end,t_used +logical :: iprintprogress +real, dimension(npart) :: x,y,z,hh +real :: radkernel, radkernel2, radkernh + +! Exact rendering +real :: pixint, wint +!logical, parameter :: exact_rendering = .true. ! use exact rendering y/n +integer :: usedpart, negflag + + +!$ integer :: omp_get_num_threads,omp_get_thread_num +integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits + +! Fill the particle data with xyzh +x(:) = xyzh(1,:) +y(:) = xyzh(2,:) +z(:) = xyzh(3,:) +hh(:) = xyzh(4,:) +print*, "smoothing length: ", hh(1:10) +! cnormk3D set the value from the kernel routine +cnormk3D = cnormk +radkernel = radkern +radkernel2 = radkern2 +print*, "radkern: ", radkern +print*, "radkernel: ",radkernel +print*, "radkern2: ", radkern2 + +print*, "npix: ", npixx, npixy,npixz + +if (exact_rendering) then +print "(1x,a)",'interpolating to 3D grid (exact/Petkova+2018 on subgrid) ...' +elseif (normalise) then +print "(1x,a)",'interpolating to 3D grid (normalised) ...' +else +print "(1x,a)",'interpolating to 3D grid (non-normalised) ...' +endif +if (pixwidthx <= 0. .or. pixwidthy <= 0 .or. pixwidthz <= 0) then +print "(1x,a)",'interpolate3D: error: pixel width <= 0' +return +endif +if (any(hh(1:npart) <= tiny(hh))) then +print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' +endif + +!call wall_time(t_start) + +datsmooth = 0. +if (normalise) then +allocate(datnorm(npixx,npixy,npixz)) +datnorm = 0. +endif +! +!--print a progress report if it is going to take a long time +! (a "long time" is, however, somewhat system dependent) +! +iprintprogress = (npart >= 100000) .or. (npixx*npixy > 100000) !.or. exact_rendering +! +!--loop over particles +! +iprintinterval = 25 +if (npart >= 1e6) iprintinterval = 10 +iprintnext = iprintinterval +! +!--get starting CPU time +! +call cpu_time(t_start) + +usedpart = 0 + +xminpix = xmin !- 0.5*pixwidthx +yminpix = ymin !- 0.5*pixwidthy +zminpix = zmin !- 0.5*pixwidthz +print*, "xminpix: ", xminpix +print*, "yminpix: ", yminpix +print*, "zminpix: ", zminpix +print*, "dat: ", dat(1:10) +print*, "weights: ", weight(1:10) +pixwidthmax = max(pixwidthx,pixwidthy,pixwidthz) +! +!--use a minimum smoothing length on the grid to make +! sure that particles contribute to at least one pixel +! +hmin = 0.5*pixwidthmax +!dhmin3 = 1./(hmin*hmin*hmin) + +const = cnormk3D ! normalisation constant (3D) +print*, "const: ", const +nwarn = 0 +j = 0_8 +threadid = 1 +! +!--loop over particles +! +!$omp parallel default(none) & +!$omp shared(hh,z,x,y,weight,dat,itype,datsmooth,npart) & +!$omp shared(xmin,ymin,zmin,radkernel,radkernel2) & +!$omp shared(xminpix,yminpix,zminpix,pixwidthx,pixwidthy,pixwidthz) & +!$omp shared(npixx,npixy,npixz,const) & +!$omp shared(datnorm,normalise,periodicx,periodicy,periodicz,exact_rendering) & +!$omp shared(hmin,pixwidthmax) & +!$omp shared(iprintprogress,iprintinterval,j) & +!$omp private(hi,xi,yi,zi,radkernh,hi1,hi21) & +!$omp private(term,termnorm,xpixi,iprogress) & +!$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & +!$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & +!$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & +!$omp private(pixint,wint,negflag,dfac,threadid) & +!$omp firstprivate(iprintnext) & +!$omp reduction(+:nwarn,usedpart) +!$omp master +!$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' +!$omp end master + +!$omp do schedule (guided, 2) +over_parts: do i=1,npart +! +!--report on progress +! +if (iprintprogress) then + !$omp atomic + j=j+1_8 +!$ threadid = omp_get_thread_num() + iprogress = 100*j/npart + if (iprogress >= iprintnext .and. threadid==1) then + write(*,"(i3,'%.')",advance='no') iprogress + iprintnext = iprintnext + iprintinterval + endif +endif +! +!--skip particles with itype < 0 +! +if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts + +hi = hh(i) +if (hi <= 0.) then + cycle over_parts +elseif (hi < hmin) then + ! + !--use minimum h to capture subgrid particles + ! (get better results *without* adjusting weights) + ! + termnorm = const*weight(i) !*(hi*hi*hi)*dhmin3 + if (.not.exact_rendering) hi = hmin +else + termnorm = const*weight(i) +endif + +! +!--set kernel related quantities +! +xi = x(i) +yi = y(i) +zi = z(i) + +hi1 = 1./hi +hi21 = hi1*hi1 +radkernh = radkernel*hi ! radius of the smoothing kernel +!termnorm = const*weight(i) +term = termnorm*dat(i) +dfac = hi**3/(pixwidthx*pixwidthy*pixwidthz*const) +!dfac = hi**3/(pixwidthx*pixwidthy*const) +! +!--for each particle work out which pixels it contributes to +! +ipixmin = int((xi - radkernh - xmin)/pixwidthx) +jpixmin = int((yi - radkernh - ymin)/pixwidthy) +kpixmin = int((zi - radkernh - zmin)/pixwidthz) +ipixmax = int((xi + radkernh - xmin)/pixwidthx) + 1 +jpixmax = int((yi + radkernh - ymin)/pixwidthy) + 1 +kpixmax = int((zi + radkernh - zmin)/pixwidthz) + 1 + +if (.not.periodicx) then + if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute + if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image +endif +if (.not.periodicy) then + if (jpixmin < 1) jpixmin = 1 + if (jpixmax > npixy) jpixmax = npixy +endif +if (.not.periodicz) then + if (kpixmin < 1) kpixmin = 1 + if (kpixmax > npixz) kpixmax = npixz +endif + +negflag = 0 + +! +!--precalculate an array of dx2 for this particle (optimisation) +! +! Check the x position of the grid cells +!open(unit=677,file="posxgrid.txt",action='write',position='append') +nxpix = 0 +do ipix=ipixmin,ipixmax + nxpix = nxpix + 1 + ipixi = ipix + if (periodicx) ipixi = iroll(ipix,npixx) + xpixi = xminpix + ipix*pixwidthx + !write(677,*) ipix, xpixi + !--watch out for errors with periodic wrapping... + if (nxpix <= size(dx2i)) then + dx2i(nxpix) = ((xpixi - xi)**2)*hi21 + endif +enddo + +!--if particle contributes to more than npixx pixels +! (i.e. periodic boundaries wrap more than once) +! truncate the contribution and give warning +if (nxpix > npixx) then + nwarn = nwarn + 1 + ipixmax = ipixmin + npixx - 1 +endif +! +!--loop over pixels, adding the contribution from this particle +! +do kpix = kpixmin,kpixmax + kpixi = kpix + if (periodicz) kpixi = iroll(kpix,npixz) + + zpix = zminpix + kpix*pixwidthz + dz = zpix - zi + dz2 = dz*dz*hi21 + + do jpix = jpixmin,jpixmax + jpixi = jpix + if (periodicy) jpixi = iroll(jpix,npixy) + + ypix = yminpix + jpix*pixwidthy + dy = ypix - yi + dyz2 = dy*dy*hi21 + dz2 + + nxpix = 0 + do ipix = ipixmin,ipixmax + if ((kpix==kpixmin).and.(jpix==jpixmin).and.(ipix==ipixmin)) then + usedpart = usedpart + 1 + endif + + nxpix = nxpix + 1 + ipixi = ipix + if (periodicx) ipixi = iroll(ipix,npixx) + + q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 + + if (exact_rendering .and. ipixmax-ipixmin <= 4) then + if (q2 < radkernel2 + 3.*pixwidthmax**2*hi21) then + xpixi = xminpix + ipix*pixwidthx + + ! Contribution of the cell walls in the xy-plane + pixint = 0.0 + wint = wallint(zpix-zi+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) + pixint = pixint + wint + + wint = wallint(zi-zpix+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) + pixint = pixint + wint + + ! Contribution of the cell walls in the xz-plane + wint = wallint(ypix-yi+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) + pixint = pixint + wint + + wint = wallint(yi-ypix+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) + pixint = pixint + wint + + ! Contribution of the cell walls in the yz-plane + wint = wallint(xpixi-xi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) + pixint = pixint + wint + + wint = wallint(xi-xpixi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) + pixint = pixint + wint + + wab = pixint*dfac ! /(pixwidthx*pixwidthy*pixwidthz*const)*hi**3 + + if (pixint < -0.01d0) then + print*, "Error: (",ipixi,jpixi,kpixi,") -> ", pixint, term*wab + endif + + ! + !--calculate data value at this pixel using the summation interpolant + ! + !$omp atomic + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + if (normalise) then + !$omp atomic + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + endif + endif + else + if (q2 < radkernel2) then + + ! + !--SPH kernel - standard cubic spline + ! + wab = wkernel(q2) + ! + !--calculate data value at this pixel using the summation interpolant + ! + !$omp atomic + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + if (normalise) then + !$omp atomic + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + endif + endif + endif + enddo + enddo +enddo +enddo over_parts +!$omp enddo +!$omp end parallel + +if (nwarn > 0) then +print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& + ' that wrap periodic boundaries more than once' +endif +! +!--normalise dat array +! +if (normalise) then +where (datnorm > tiny(datnorm)) + datsmooth = datsmooth/datnorm +end where +endif +if (allocated(datnorm)) deallocate(datnorm) + +!call wall_time(t_end) +call cpu_time(t_end) +t_used = t_end - t_start +print*, 'completed in ',t_end-t_start,'s' +!if (t_used > 10.) call print_time(t_used) + +!print*, 'Number of particles in the volume: ', usedpart +! datsmooth(1,1,1) = 3.14159 +! datsmooth(32,32,32) = 3.145159 +! datsmooth(11,11,11) = 3.14159 +! datsmooth(10,10,10) = 3.145159 + +end subroutine interpolate3D + +subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& normalise,periodicx,periodicy,periodicz) - integer, intent(in) :: npart,npixx,npixy,npixz + integer, intent(in) :: npart,npixx,npixy,npixz,ilendat real, intent(in) :: xyzh(4,npart) !real, intent(in), dimension(npart) :: x,y,z,hh ! change to xyzh() - real, intent(in), dimension(npart) :: weight,dat + real, intent(in), dimension(npart) :: weight + real, intent(in),dimension(npart,ilendat) :: dat integer, intent(in), dimension(npart) :: itype real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz - real(doub_prec), intent(out), dimension(npixx,npixy,npixz) :: datsmooth + real(doub_prec), intent(out), dimension(ilendat,npixx,npixy,npixz) :: datsmooth logical, intent(in) :: normalise,periodicx,periodicy,periodicz !logical, intent(in), exact_rendering real(doub_prec), allocatable :: datnorm(:,:,:) - integer :: i,ipix,jpix,kpix + integer :: i,ipix,jpix,kpix,lockindex integer :: iprintinterval,iprintnext integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax integer :: ipixi,jpixi,kpixi,nxpix,nwarn,threadid real :: xminpix,yminpix,zminpix,hmin !,dhmin3 real, dimension(npixx) :: dx2i real :: xi,yi,zi,hi,hi1,hi21,wab,q2,const,dyz2,dz2 - real :: term,termnorm,dy,dz,ypix,zpix,xpixi,pixwidthmax,dfac + real :: term(ilendat),termnorm,dy,dz,ypix,zpix,xpixi,pixwidthmax,dfac real :: t_start,t_end,t_used logical :: iprintprogress real, dimension(npart) :: x,y,z,hh @@ -135,6 +497,11 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !call wall_time(t_start) +!$ allocate(ilock(npixx*npixy*npixz)) +!$ do i=1,npixx*npixy*npixz +!$ call omp_init_lock(ilock(i)) +!$ enddo + datsmooth = 0. if (normalise) then allocate(datnorm(npixx,npixy,npixz)) @@ -161,11 +528,11 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& xminpix = xmin !- 0.5*pixwidthx yminpix = ymin !- 0.5*pixwidthy zminpix = zmin !- 0.5*pixwidthz - print*, "xminpix: ", xminpix - print*, "yminpix: ", yminpix - print*, "zminpix: ", zminpix - print*, "dat: ", dat(1:10) - print*, "weights: ", weight(1:10) +! print*, "xminpix: ", xminpix +! print*, "yminpix: ", yminpix +! print*, "zminpix: ", zminpix +! print*, "dat: ", dat(1:10) +! print*, "weights: ", weight(1:10) pixwidthmax = max(pixwidthx,pixwidthy,pixwidthz) ! !--use a minimum smoothing length on the grid to make @@ -195,7 +562,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & !$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & - !$omp private(pixint,wint,negflag,dfac,threadid) & + !$omp private(pixint,wint,negflag,dfac,threadid,lockindex) & !$omp firstprivate(iprintnext) & !$omp reduction(+:nwarn,usedpart) !$omp master @@ -247,7 +614,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& hi21 = hi1*hi1 radkernh = radkernel*hi ! radius of the smoothing kernel !termnorm = const*weight(i) - term = termnorm*dat(i) + term(:) = termnorm*dat(i,:) dfac = hi**3/(pixwidthx*pixwidthy*pixwidthz*const) !dfac = hi**3/(pixwidthx*pixwidthy*const) ! @@ -366,12 +733,18 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& ! !--calculate data value at this pixel using the summation interpolant ! - !$omp atomic - datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + ! Find out where this pixel sits in the lock array + ! lockindex = (k-1)*nx*ny + (j-1)*nx + i + lockindex = (kpixi-1)*npixx*npixy + (jpixi-1)*npixx + ipixi + !!$call omp_set_lock(ilock(lockindex)) + !$omp critical + datsmooth(:,ipixi,jpixi,kpixi) = datsmooth(:,ipixi,jpixi,kpixi) + term(:)*wab if (normalise) then - !$omp atomic + !!$omp atomic datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab endif + !$omp end critical + !!$call omp_unset_lock(ilock(lockindex)) endif else if (q2 < radkernel2) then @@ -383,12 +756,20 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& ! !--calculate data value at this pixel using the summation interpolant ! - !$omp atomic - datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + !!$omp atomic ! Atomic statmements only work with scalars + !!$omp set lock ! Does this work with an array? + ! Find out where this pixel sits in the lock array + ! lockindex = (k-1)*nx*ny + (j-1)*nx + i + lockindex = (kpixi-1)*npixx*npixy + (jpixi-1)*npixx + ipixi + !!$call omp_set_lock(ilock(lockindex)) + !$omp critical + datsmooth(:,ipixi,jpixi,kpixi) = datsmooth(:,ipixi,jpixi,kpixi) + term(:)*wab if (normalise) then - !$omp atomic + !!$omp atomic datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab endif + !!$call omp_unset_lock(ilock(lockindex)) + !$omp end critical endif endif enddo @@ -398,6 +779,11 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !$omp enddo !$omp end parallel +!$ do i=1,npixx*npixy*npixz +!$ call omp_destroy_lock(ilock(i)) +!$ enddo +!$ if (allocated(ilock)) deallocate(ilock) + if (nwarn > 0) then print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& ' that wrap periodic boundaries more than once' @@ -406,9 +792,12 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !--normalise dat array ! if (normalise) then + do i=1, ilendat where (datnorm > tiny(datnorm)) - datsmooth = datsmooth/datnorm + + datsmooth(i,:,:,:) = datsmooth(i,:,:,:)/datnorm(:,:,:) end where + enddo endif if (allocated(datnorm)) deallocate(datnorm) @@ -424,7 +813,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& ! datsmooth(11,11,11) = 3.14159 ! datsmooth(10,10,10) = 3.145159 -end subroutine interpolate3D +end subroutine interpolate3D_vecexact ! subroutine interpolate3D_vec(x,y,z,hh,weight,datvec,itype,npart,& ! xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& From 80541de0c85213c33a953c0b70da06c941288b64 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Mon, 5 Jun 2023 13:39:51 +1000 Subject: [PATCH 051/814] Code optimisation and phantom checkpoint added --- src/main/extern_gr.F90 | 56 ++++++++++++------------- src/main/tmunu2grid.f90 | 18 ++++---- src/setup/setup_flrw.f90 | 2 +- src/utils/einsteintk_wrapper.f90 | 28 ++++++++++--- src/utils/interpolate3D.F90 | 72 +++++++++++++++++--------------- 5 files changed, 99 insertions(+), 77 deletions(-) diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 932630acd..6fa399ff6 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -326,16 +326,16 @@ subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) !print*, "After unpack metric" - if (present(verbose) .and. verbose) then - ! Do we get sensible values - print*, "Unpacked metric quantities..." - print*, "gcov: ", gcov - print*, "gcon: ", gcon - print*, "gammaijdown: ", gammaijdown - print* , "alpha: ", alpha - print*, "betadown: ", betadown - print*, "v4: ", v4 - endif +! if (present(verbose) .and. verbose) then +! ! Do we get sensible values +! print*, "Unpacked metric quantities..." +! print*, "gcov: ", gcov +! print*, "gcon: ", gcon +! print*, "gammaijdown: ", gammaijdown +! print* , "alpha: ", alpha +! print*, "betadown: ", betadown +! print*, "v4: ", v4 +! endif ! ! Need to change Betadown to betaup ! ! Won't matter at this point as it is allways zero @@ -385,24 +385,24 @@ subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) enddo - if (present(verbose) .and. verbose) then - ! Do we get sensible values - print*, "Unpacked metric quantities..." - print*, "gcov: ", gcov - print*, "gcon: ", gcon - print*, "gammaijdown: ", gammaijdown - print* , "alpha: ", alpha - print*, "betadown: ", betadown - print*, "v4: ", v4 - endif - - if (verbose) then - print*, "tmunu part: ", tmunu - print*, "dens: ", dens - print*, "w: ", w - print*, "p: ", p - print*, "gcov: ", gcov - endif +! if (present(verbose) .and. verbose) then +! ! Do we get sensible values +! print*, "Unpacked metric quantities..." +! print*, "gcov: ", gcov +! print*, "gcon: ", gcon +! print*, "gammaijdown: ", gammaijdown +! print* , "alpha: ", alpha +! print*, "betadown: ", betadown +! print*, "v4: ", v4 +! endif + +! if (verbose) then +! print*, "tmunu part: ", tmunu +! print*, "dens: ", dens +! print*, "w: ", w +! print*, "p: ", p +! print*, "gcov: ", gcov +! endif ! print*, "tmunu part: ", tmunu ! print*, "dens: ", dens diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index cd12b48f9..a1e3ce6ce 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -136,18 +136,18 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) !print*,"i j is: ", i, j !print*, "Index in array is: ", (i-1)*4 + j tmunugrid(i-1,j-1,:,:,:) = datsmooth((i-1)*4 + j, :,:,:) - print*, "tmunugrid: ", tmunugrid(i-1,j-1,10,10,10) - print*, datsmooth((i-1)*4 + j, 10,10,10) + !print*, "tmunugrid: ", tmunugrid(i-1,j-1,10,10,10) + !print*, datsmooth((i-1)*4 + j, 10,10,10) enddo enddo !stop -do k=1,4 - do j=1,4 - do i=1,4 - print*, "Lock index is: ", (k-1)*16+ (j-1)*4 + i - enddo - enddo -enddo +! do k=1,4 +! do j=1,4 +! do i=1,4 +! print*, "Lock index is: ", (k-1)*16+ (j-1)*4 + i +! enddo +! enddo +! enddo ! tmunugrid(0,0,:,:,:) = datsmooth(1,:,:,:) diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 97701e9e0..e630b757d 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -133,7 +133,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Then it should be set using the Friedmann equation: !!!!!! rhozero = (3H^2)/(8*pi*a*a) - hub = 10.553495658357338/100.d0 + hub = 10.553495658357338/10.d0 !hub = 23.588901903912664 !hub = 0.06472086375185665 rhozero = 3.d0 * hub**2 / (8.d0 * pi) diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 7bf75f86e..7ff0412b7 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -424,7 +424,7 @@ end subroutine phantom2et_momentum ! Subroutine for performing a phantom dump from einstein toolkit -subroutine et2phantom_dumphydro(time,dt_et) +subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) use cons2prim, only:cons2primall use part, only:npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars use einsteintk_utils @@ -432,22 +432,38 @@ subroutine et2phantom_dumphydro(time,dt_et) use readwrite_dumps, only:write_smalldump,write_fulldump use fileutils, only:getnextfilename real, intent(in) :: time, dt_et + !logical, intent(in), optional :: checkpoint + !integer, intent(in) :: checkpointno + character(*),optional, intent(in) :: checkpointfile + logical :: createcheckpoint + + if (present(checkpointfile)) then + createcheckpoint = .true. + else + createcheckpoint = .false. + endif !character(len=20) :: logfile,evfile,dumpfile ! Call cons2prim since values are updated with MoL !call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) ! Write EV_file - call write_evfile(time,dt_et) + if (.not. createcheckpoint) then + call write_evfile(time,dt_et) - evfilestor = getnextfilename(evfilestor) - logfilestor = getnextfilename(logfilestor) - dumpfilestor = getnextfilename(dumpfilestor) + evfilestor = getnextfilename(evfilestor) + logfilestor = getnextfilename(logfilestor) + dumpfilestor = getnextfilename(dumpfilestor) + call write_fulldump(time,dumpfilestor) + endif !print*, "Evfile: ", evfilestor !print*, "logfile: ", logfilestor !print*, "dumpfle: ", dumpfilestor ! Write full dump - call write_fulldump(time,dumpfilestor) + if (createcheckpoint) then + call write_fulldump(time,checkpointfile) + endif + end subroutine et2phantom_dumphydro diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index 8eabc3f8e..9d1cf5f5b 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -107,16 +107,16 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& y(:) = xyzh(2,:) z(:) = xyzh(3,:) hh(:) = xyzh(4,:) -print*, "smoothing length: ", hh(1:10) +!print*, "smoothing length: ", hh(1:10) ! cnormk3D set the value from the kernel routine cnormk3D = cnormk radkernel = radkern radkernel2 = radkern2 -print*, "radkern: ", radkern -print*, "radkernel: ",radkernel -print*, "radkern2: ", radkern2 +! print*, "radkern: ", radkern +! print*, "radkernel: ",radkernel +! print*, "radkern2: ", radkern2 -print*, "npix: ", npixx, npixy,npixz +! print*, "npix: ", npixx, npixy,npixz if (exact_rendering) then print "(1x,a)",'interpolating to 3D grid (exact/Petkova+2018 on subgrid) ...' @@ -161,11 +161,11 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& xminpix = xmin !- 0.5*pixwidthx yminpix = ymin !- 0.5*pixwidthy zminpix = zmin !- 0.5*pixwidthz -print*, "xminpix: ", xminpix -print*, "yminpix: ", yminpix -print*, "zminpix: ", zminpix -print*, "dat: ", dat(1:10) -print*, "weights: ", weight(1:10) +! print*, "xminpix: ", xminpix +! print*, "yminpix: ", yminpix +! print*, "zminpix: ", zminpix +! print*, "dat: ", dat(1:10) +! print*, "weights: ", weight(1:10) pixwidthmax = max(pixwidthx,pixwidthy,pixwidthz) ! !--use a minimum smoothing length on the grid to make @@ -175,7 +175,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !dhmin3 = 1./(hmin*hmin*hmin) const = cnormk3D ! normalisation constant (3D) -print*, "const: ", const +!print*, "const: ", const nwarn = 0 j = 0_8 threadid = 1 @@ -415,7 +415,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !call wall_time(t_end) call cpu_time(t_end) t_used = t_end - t_start -print*, 'completed in ',t_end-t_start,'s' +print*, 'Interpolate3D completed in ',t_end-t_start,'s' !if (t_used > 10.) call print_time(t_used) !print*, 'Number of particles in the volume: ', usedpart @@ -469,16 +469,16 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& y(:) = xyzh(2,:) z(:) = xyzh(3,:) hh(:) = xyzh(4,:) - print*, "smoothing length: ", hh(1:10) + !print*, "smoothing length: ", hh(1:10) ! cnormk3D set the value from the kernel routine cnormk3D = cnormk radkernel = radkern radkernel2 = radkern2 - print*, "radkern: ", radkern - print*, "radkernel: ",radkernel - print*, "radkern2: ", radkern2 +! print*, "radkern: ", radkern +! print*, "radkernel: ",radkernel +! print*, "radkern2: ", radkern2 - print*, "npix: ", npixx, npixy,npixz + !print*, "npix: ", npixx, npixy,npixz if (exact_rendering) then print "(1x,a)",'interpolating to 3D grid (exact/Petkova+2018 on subgrid) ...' @@ -497,10 +497,10 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !call wall_time(t_start) -!$ allocate(ilock(npixx*npixy*npixz)) -!$ do i=1,npixx*npixy*npixz -!$ call omp_init_lock(ilock(i)) -!$ enddo +!! $ allocate(ilock(npixx*npixy*npixz)) +!! $ do i=1,npixx*npixy*npixz +!! $ call omp_init_lock(ilock(i)) +!! $ enddo datsmooth = 0. if (normalise) then @@ -542,7 +542,7 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !dhmin3 = 1./(hmin*hmin*hmin) const = cnormk3D ! normalisation constant (3D) - print*, "const: ", const + !print*, "const: ", const nwarn = 0 j = 0_8 threadid = 1 @@ -735,15 +735,18 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& ! ! Find out where this pixel sits in the lock array ! lockindex = (k-1)*nx*ny + (j-1)*nx + i - lockindex = (kpixi-1)*npixx*npixy + (jpixi-1)*npixx + ipixi + !lockindex = (kpixi-1)*npixx*npixy + (jpixi-1)*npixx + ipixi !!$call omp_set_lock(ilock(lockindex)) - !$omp critical + !$omp critical (datsmooth) datsmooth(:,ipixi,jpixi,kpixi) = datsmooth(:,ipixi,jpixi,kpixi) + term(:)*wab + !$omp end critical (datsmooth) if (normalise) then !!$omp atomic + !$omp critical (datnorm) datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + !$omp end critical (datnorm) endif - !$omp end critical + !!$call omp_unset_lock(ilock(lockindex)) endif else @@ -760,16 +763,19 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !!$omp set lock ! Does this work with an array? ! Find out where this pixel sits in the lock array ! lockindex = (k-1)*nx*ny + (j-1)*nx + i - lockindex = (kpixi-1)*npixx*npixy + (jpixi-1)*npixx + ipixi + !lockindex = (kpixi-1)*npixx*npixy + (jpixi-1)*npixx + ipixi !!$call omp_set_lock(ilock(lockindex)) - !$omp critical + !$omp critical (datsmooth) datsmooth(:,ipixi,jpixi,kpixi) = datsmooth(:,ipixi,jpixi,kpixi) + term(:)*wab + !$omp end critical (datsmooth) if (normalise) then !!$omp atomic + !$omp critical (datnorm) datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + !$omp end critical (datnorm) endif !!$call omp_unset_lock(ilock(lockindex)) - !$omp end critical + endif endif enddo @@ -779,10 +785,10 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !$omp enddo !$omp end parallel -!$ do i=1,npixx*npixy*npixz -!$ call omp_destroy_lock(ilock(i)) -!$ enddo -!$ if (allocated(ilock)) deallocate(ilock) +!!$ do i=1,npixx*npixy*npixz +!!$ call omp_destroy_lock(ilock(i)) +!!$ enddo +!!$ if (allocated(ilock)) deallocate(ilock) if (nwarn > 0) then print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& @@ -804,7 +810,7 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !call wall_time(t_end) call cpu_time(t_end) t_used = t_end - t_start - print*, 'completed in ',t_end-t_start,'s' + print*, 'Interpolate3DVec completed in ',t_end-t_start,'s' !if (t_used > 10.) call print_time(t_used) !print*, 'Number of particles in the volume: ', usedpart From 1c669ded442c18e565d71ee2c97c4ada67ec012b Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Thu, 8 Jun 2023 11:31:18 +1000 Subject: [PATCH 052/814] Improved vectorised code --- src/setup/setup_flrw.f90 | 4 ++-- src/utils/interpolate3D.F90 | 36 +++++++++++++++++++++--------------- 2 files changed, 23 insertions(+), 17 deletions(-) diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index e630b757d..c28e2723b 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -133,7 +133,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Then it should be set using the Friedmann equation: !!!!!! rhozero = (3H^2)/(8*pi*a*a) - hub = 10.553495658357338/10.d0 + hub = 10.553495658357338!/10.d0 !hub = 23.588901903912664 !hub = 0.06472086375185665 rhozero = 3.d0 * hub**2 / (8.d0 * pi) @@ -198,7 +198,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! time should be read in from the par file !time = 0.08478563386065302 - time = 1.8951066686763596 ! z~1000 + time = 0.18951066686763596 ! z~1000 lambda = perturb_wavelength*length kwave = (2.d0*pi)/lambda denom = length - ampl/kwave*(cos(kwave*length)-1.0) diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index 9d1cf5f5b..b307544f6 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -442,7 +442,7 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !logical, intent(in), exact_rendering real(doub_prec), allocatable :: datnorm(:,:,:) - integer :: i,ipix,jpix,kpix,lockindex + integer :: i,ipix,jpix,kpix,lockindex,smoothindex integer :: iprintinterval,iprintnext integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax integer :: ipixi,jpixi,kpixi,nxpix,nwarn,threadid @@ -553,7 +553,7 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !$omp shared(hh,z,x,y,weight,dat,itype,datsmooth,npart) & !$omp shared(xmin,ymin,zmin,radkernel,radkernel2) & !$omp shared(xminpix,yminpix,zminpix,pixwidthx,pixwidthy,pixwidthz) & - !$omp shared(npixx,npixy,npixz,const) & + !$omp shared(npixx,npixy,npixz,const,ilendat) & !$omp shared(datnorm,normalise,periodicx,periodicy,periodicz,exact_rendering) & !$omp shared(hmin,pixwidthmax) & !$omp shared(iprintprogress,iprintinterval,j) & @@ -562,7 +562,7 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & !$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & - !$omp private(pixint,wint,negflag,dfac,threadid,lockindex) & + !$omp private(pixint,wint,negflag,dfac,threadid,lockindex,smoothindex) & !$omp firstprivate(iprintnext) & !$omp reduction(+:nwarn,usedpart) !$omp master @@ -737,14 +737,17 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& ! lockindex = (k-1)*nx*ny + (j-1)*nx + i !lockindex = (kpixi-1)*npixx*npixy + (jpixi-1)*npixx + ipixi !!$call omp_set_lock(ilock(lockindex)) - !$omp critical (datsmooth) - datsmooth(:,ipixi,jpixi,kpixi) = datsmooth(:,ipixi,jpixi,kpixi) + term(:)*wab - !$omp end critical (datsmooth) + !!$omp critical (datsmooth) + do smoothindex=1, ilendat + !$omp atomic + datsmooth(smoothindex,ipixi,jpixi,kpixi) = datsmooth(smoothindex,ipixi,jpixi,kpixi) + term(smoothindex)*wab + enddo + !!$omp end critical (datsmooth) if (normalise) then - !!$omp atomic - !$omp critical (datnorm) + !$omp atomic + !!$omp critical (datnorm) datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - !$omp end critical (datnorm) + !!$omp end critical (datnorm) endif !!$call omp_unset_lock(ilock(lockindex)) @@ -765,14 +768,17 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& ! lockindex = (k-1)*nx*ny + (j-1)*nx + i !lockindex = (kpixi-1)*npixx*npixy + (jpixi-1)*npixx + ipixi !!$call omp_set_lock(ilock(lockindex)) - !$omp critical (datsmooth) - datsmooth(:,ipixi,jpixi,kpixi) = datsmooth(:,ipixi,jpixi,kpixi) + term(:)*wab - !$omp end critical (datsmooth) + !!$omp critical (datsmooth) + do smoothindex=1,ilendat + !$omp atomic + datsmooth(smoothindex,ipixi,jpixi,kpixi) = datsmooth(smoothindex,ipixi,jpixi,kpixi) + term(smoothindex)*wab + enddo + !!$omp end critical (datsmooth) if (normalise) then - !!$omp atomic - !$omp critical (datnorm) + !$omp atomic + !!$omp critical (datnorm) datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - !$omp end critical (datnorm) + !!$omp end critical (datnorm) endif !!$call omp_unset_lock(ilock(lockindex)) From d8c66ade9b06b0af54f0a28fe7a485c9bf07cd22 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Fri, 9 Jun 2023 13:13:51 +1000 Subject: [PATCH 053/814] Removed unused variable warnings --- src/main/deriv.F90 | 2 +- src/main/extern_gr.F90 | 5 ++- src/main/initial.F90 | 2 +- src/main/metric_et.f90 | 18 +++++------ src/main/tmunu2grid.f90 | 26 ++++++++-------- src/main/utils_gr.F90 | 2 +- src/setup/setup_flrw.f90 | 7 ++--- src/utils/einsteintk_utils.f90 | 2 +- src/utils/einsteintk_wrapper.f90 | 53 ++++++++++++++------------------ src/utils/interpolate3D.F90 | 20 ++++++------ 10 files changed, 64 insertions(+), 73 deletions(-) diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index 462781d17..bf4fb2b58 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -234,7 +234,7 @@ 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,& - dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol,tmunus,metricderivs + dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol use timing, only:printused,getused use io, only:id,master real(kind=4), intent(out), optional :: tused diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 6fa399ff6..0ce4c197d 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -299,11 +299,10 @@ subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) real, intent(in) :: x(3),metrici(:,:,:),v(3),dens,u,p real, intent(out) :: tmunu(0:3,0:3) logical, optional, intent(in) :: verbose - real :: w,v4(0:3),vcov(3),lorentz,bigV(3),uzero,u_upper(0:3),u_lower(0:3) + real :: w,v4(0:3),uzero,u_upper(0:3),u_lower(0:3) real :: gcov(0:3,0:3), gcon(0:3,0:3) real :: gammaijdown(1:3,1:3),betadown(3),alpha - real :: velshiftterm - integer :: i,j,ierr,mu,nu + integer :: ierr,mu,nu ! Reference for all the variables used in this routine: ! w - the enthalpy diff --git a/src/main/initial.F90 b/src/main/initial.F90 index c27f72bbe..1f1ba9772 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -136,7 +136,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use linklist, only:set_linklist use boundary_dyn, only:dynamic_bdy,init_dynamic_bdy #ifdef GR - use part, only:metricderivs,tmunus + use part, only:metricderivs use cons2prim, only:prim2consall use eos, only:ieos use extern_gr, only:get_grforce_all,get_tmunu_all,get_tmunu_all_exact diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index 437e40ef2..907b9bcb7 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -179,11 +179,11 @@ pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) ! linear and cubic interpolators should be moved to their own subroutine ! away from eos_shen use eos_shen, only:linear_interpolator_one_d - use einsteintk_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid,gridsize,gridorigin + use einsteintk_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid,gridorigin!,gridsize real, intent(in) :: position(3) real, intent(out) :: gcov(0:3,0:3) real, intent(out), optional :: gcon(0:3,0:3), sqrtg - integer :: xlower,ylower,zlower,xupper,yupper,zupper + integer :: xlower,ylower,zlower!,xupper,yupper,zupper real :: xlowerpos,ylowerpos,zlowerpos real :: xd,yd,zd real :: interptmp(7) @@ -200,9 +200,9 @@ pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) !print*,"Neighbours: ", xlower,ylower,zlower ! This is not true as upper neighbours on the boundary will be on the side ! take a mod of grid size - xupper = mod(xlower + 1, gridsize(1)) - yupper = mod(ylower + 1, gridsize(2)) - zupper = mod(zlower + 1, gridsize(3)) +! xupper = mod(xlower + 1, gridsize(1)) +! yupper = mod(ylower + 1, gridsize(2)) +! zupper = mod(zlower + 1, gridsize(3)) ! xupper - xlower should always just be dx provided we are using a uniform grid ! xd = (position(1) - xlower)/(xupper - xlower) ! yd = (position(2) - ylower)/(yupper - ylower) @@ -291,16 +291,16 @@ pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) use einsteintk_utils, only:metricderivsgrid, dxgrid,gridorigin real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3),dgcovdz(0:3,0:3) real, intent(in) :: position(3) - integer :: xlower,ylower,zlower,xupper,yupper,zupper + integer :: xlower,ylower,zlower!,xupper,yupper,zupper real :: xd,yd,zd,xlowerpos, ylowerpos,zlowerpos real :: interptmp(7) integer :: i,j call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) !print*,"Neighbours: ", xlower,ylower,zlower - xupper = xlower + 1 - yupper = yupper + 1 - zupper = zupper + 1 +! xupper = xlower + 1 +! yupper = yupper + 1 +! zupper = zupper + 1 ! xd = (position(1) - xlower)/(xupper - xlower) ! yd = (position(2) - ylower)/(yupper - ylower) ! zd = (position(3) - zlower)/(zupper - zlower) diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index a1e3ce6ce..c2ff7ab27 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -20,24 +20,23 @@ module tmunu2grid contains subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) - use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid + use einsteintk_utils, only: dxgrid, gridorigin,gridsize,tmunugrid,rhostargrid use interpolations3D, only: interpolate3D,interpolate3D_vecexact use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax - use part, only: massoftype,igas,rhoh,dens,hfact + use part, only: massoftype,igas,rhoh integer, intent(in) :: npart real, intent(in) :: vxyzu(:,:), tmunus(:,:,:) real, intent(inout) :: xyzh(:,:) logical, intent(in), optional :: calc_cfac - real :: weight,h,rho,pmass,rhoexact + real :: weight,h,rho,pmass real :: weights(npart) real, save :: cfac - integer, save :: iteration = 0 real :: xmininterp(3) integer :: ngrid(3) real,allocatable :: datsmooth(:,:,:,:), dat(:,:) integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper - logical :: normalise, vertexcen,periodicx,periodicy,periodicz,exact_rendering - real :: totalmass, totalmassgrid + logical :: normalise, vertexcen,periodicx,periodicy,periodicz + real :: totalmass integer :: itype(npart),ilendat @@ -312,18 +311,17 @@ subroutine get_cfac(cfac,rho) end subroutine get_cfac subroutine interpolate_to_grid(gridarray,dat) - use einsteintk_utils, only: dxgrid, gridorigin,boundsize,gridsize,gcovgrid,tmunugrid,rhostargrid + use einsteintk_utils, only: dxgrid, gridorigin use interpolations3D, only: interpolate3D use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax - use part, only:npart,xyzh,massoftype,igas,rhoh,dens,hfact - real :: weight,h,rho,pmass,rhoexact - real, save :: cfac - integer, save :: iteration = 0 + use part, only:npart,xyzh,massoftype,igas,rhoh + real :: weight,h,rho,pmass + !real, save :: cfac + !integer, save :: iteration = 0 real :: xmininterp(3) integer :: ngrid(3) - integer :: nnodes,i,k,j, ilower, iupper, jlower, jupper, klower, kupper + integer :: nnodes,i, ilower, iupper, jlower, jupper, klower, kupper logical :: normalise, vertexcen,periodicx, periodicy, periodicz - real :: totalmass, totalmassgrid real, dimension(npart) :: weights integer, dimension(npart) :: itype real, intent(out) :: gridarray(:,:,:) ! Grid array to interpolate a quantity to @@ -421,7 +419,7 @@ subroutine check_conserved_dens(rhostargrid,cfac) end subroutine check_conserved_dens subroutine check_conserved_p(pgrid,cfac) - use part, only:npart,massoftype,igas,pxyzu + use part, only:npart,massoftype,igas use einsteintk_utils, only: dxgrid, gridorigin use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax real, intent(in) :: pgrid(:,:,:) diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index 22d5f392b..ec654ebc0 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.F90 @@ -215,7 +215,7 @@ subroutine get_sqrt_gamma(gcov,sqrt_gamma) real :: a11,a12,a13 real :: a21,a22,a23 real :: a31,a32,a33 - real :: a41,a42,a43 + !real :: a41,a42,a43 real :: det if (metric_type == 'et') then diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index c28e2723b..ca3e9bfc8 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -84,10 +84,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, integer :: i,ierr logical :: iexist real :: kwave,denom,length, c1,c3,lambda - real :: perturb_rho0,xval - real :: Vup(0:3),v(0:3),const,phi,rhoprim,sqrtg,u0,x,gcov(0:3,0:3),alpha,hub + real :: xval + real :: Vup(0:3),phi,sqrtg,gcov(0:3,0:3),alpha,hub real :: last_scattering_temp - real :: u procedure(rho_func), pointer :: density_func procedure(mass_func), pointer :: mass_function @@ -381,7 +380,7 @@ end function rhofunc real function massfunc(x,xmin) use utils_gr, only:perturb_metric, get_u0, get_sqrtg,dot_product_gr real, intent(in) :: x,xmin - real :: const, expr, exprmin, rhoprim, gcov(0:3,0:3), sqrtg,u0,v(3),Vup(3) + real :: const, gcov(0:3,0:3), sqrtg,u0,v(3),Vup(3) real :: massprimx,massprimmin,massprim real :: lorrentz, bigv2 diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index b6ac8d4c5..7c28cf89c 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -85,7 +85,7 @@ subroutine print_etgrid() end subroutine print_etgrid subroutine get_particle_rhs(i,vx,vy,vz,fx,fy,fz,e_rhs) - use part, only: vxyzu,fxyzu,fext + use part, only: vxyzu,fext!,fxyzu integer, intent(in) :: i real, intent(out) :: vx,vy,vz,fx,fy,fz,e_rhs diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 7ff0412b7..072508797 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -34,7 +34,7 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) use einsteintk_utils use extern_gr use metric - use part, only:xyzh,pxyzu,vxyzu,dens,metricderivs, metrics, npart, tmunus + use part, only:npart!, tmunus implicit none @@ -43,10 +43,7 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) integer, intent(inout) :: nophantompart real, intent(out) :: dtout !character(len=500) :: logfile,evfile,dumpfile,path - integer :: i,j,k,pathstringlength - integer :: xlower,ylower,zlower,xupper,yupper,zupper - real :: pos(3), gcovpart(0:3,0:3) - !real :: dtout + !integer :: i,j,k,pathstringlength ! For now we just hardcode the infile, to see if startrun actually works! ! I'm not sure what the best way to actually do this is? @@ -98,8 +95,6 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) call get_phantom_dt(dtout) - print*,"pxyzu: ", pxyzu(:,1) - end subroutine init_et2phantom subroutine init_et2phantomgrid(nx,ny,nz,originx,originy,originz,dx,dy,dz) @@ -161,12 +156,12 @@ subroutine phantom2et() end subroutine phantom2et subroutine step_et2phantom_MoL(infile,dt_et,dtout) - use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars + use part, only:xyzh,vxyzu,pxyzu,dens,metrics, npart, eos_vars use cons2prim, only: cons2primall use deriv use extern_gr use tmunu2grid - use einsteintk_utils, only: get_phantom_dt,gcovgrid + use einsteintk_utils, only: get_phantom_dt character(len=*), intent(in) :: infile real, intent(inout) :: dt_et real, intent(out) :: dtout @@ -200,15 +195,14 @@ end subroutine step_et2phantom_MoL subroutine et2phantom_tmunu() use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& - Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,& - dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol,tmunus,metricderivs,& - massoftype,igas,rhoh,alphaind,dvdx,gradh + Bevol,rad,radprop,eos_vars,pxyzu,dens,metrics,tmunus,metricderivs,& + igas,rhoh,alphaind,dvdx,gradh !use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars use cons2prim, only: cons2primall use deriv use extern_gr use tmunu2grid - use einsteintk_utils, only: get_phantom_dt,gcovgrid,rhostargrid,tmunugrid + use einsteintk_utils, only: get_phantom_dt,rhostargrid,tmunugrid use metric_tools, only:init_metric use densityforce, only:densityiterate use linklist, only:set_linklist @@ -243,16 +237,15 @@ subroutine et2phantom_tmunu() call check_conserved_dens(rhostargrid,cfac) ! Correct Tmunu - tmunugrid = cfac*tmunugrid + ! Convert to 8byte real to stop compiler warning + tmunugrid = real(cfac)*tmunugrid end subroutine et2phantom_tmunu subroutine phantom2et_consvar() use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& - Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,& - dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol,tmunus,metricderivs,& - massoftype,igas,rhoh,alphaind,dvdx,gradh + Bevol,rad,radprop,metrics,igas,rhoh,alphaind,dvdx,gradh use densityforce, only:densityiterate use metric_tools, only:init_metric use linklist, only:set_linklist @@ -292,15 +285,17 @@ subroutine phantom2et_consvar() ! Momentum check vs particles ! Correct momentum and Density - rhostargrid = cfac*rhostargrid - pxgrid = cfac*pxgrid - entropygrid = cfac*entropygrid + ! Conversion of cfac to 8byte real to avoid + ! compiler warning + rhostargrid = real(cfac)*rhostargrid + pxgrid = real(cfac)*pxgrid + entropygrid = real(cfac)*entropygrid end subroutine phantom2et_consvar subroutine phantom2et_rhostar() - use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& + use part, only:xyzh,npart,& igas, massoftype,rhoh use cons2prim, only: cons2primall use deriv @@ -343,15 +338,14 @@ subroutine phantom2et_rhostar() end subroutine phantom2et_rhostar subroutine phantom2et_entropy() - use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& - igas, massoftype,rhoh + use part, only:pxyzu,npart use cons2prim, only: cons2primall use deriv use extern_gr use tmunu2grid use einsteintk_utils, only: get_phantom_dt,entropygrid use metric_tools, only:init_metric - real :: dat(npart), h, pmass,rho + real :: dat(npart) integer :: i @@ -381,13 +375,12 @@ subroutine phantom2et_entropy() end subroutine phantom2et_entropy subroutine phantom2et_momentum() - use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars,& - igas,massoftype,alphaind,dvdx,gradh + use part, only:pxyzu, npart use cons2prim, only: cons2primall use deriv use extern_gr use tmunu2grid - use einsteintk_utils, only: get_phantom_dt,gcovgrid,pxgrid + use einsteintk_utils, only: get_phantom_dt,pxgrid use metric_tools, only:init_metric real :: dat(3,npart) integer :: i @@ -426,7 +419,7 @@ end subroutine phantom2et_momentum ! Subroutine for performing a phantom dump from einstein toolkit subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) use cons2prim, only:cons2primall - use part, only:npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars + !use part, only:npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars use einsteintk_utils use evwrite, only:write_evfile,write_evlog use readwrite_dumps, only:write_smalldump,write_fulldump @@ -497,8 +490,8 @@ end subroutine et2phantom_setparticlevars ! I really HATE this routine being here but it needs to be to fix dependency issues. subroutine get_metricderivs_all(dtextforce_min,dt_et) - use einsteintk_utils, only: metricderivsgrid - use part, only:npart, xyzh,vxyzu,fxyzu,metrics,metricderivs,dens,fext + !use einsteintk_utils, only: metricderivsgrid + use part, only:npart,xyzh,vxyzu,dens,metrics,metricderivs,fext!,fxyzu use timestep, only:bignumber,C_force use extern_gr, only:get_grforce use metric_tools, only:pack_metricderivs diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index b307544f6..076d594bf 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -33,7 +33,6 @@ module interpolations3D integer, parameter :: doub_prec = kind(0.d0) real :: cnormk3D = cnormk public :: interpolate3D,interpolate3D_vecexact -!$ integer(kind=8), dimension(:), private, allocatable :: ilock contains !-------------------------------------------------------------------------- @@ -1125,7 +1124,7 @@ real function pint3D(r0, R_0, d1, d2, hi) real, intent(in) :: r0 real(doub_prec) :: ar0, aR_0 real(doub_prec) :: int1, int2 - integer :: fflag = 0 + !integer :: fflag = 0 if (abs(r0) < tiny(0.)) then pint3D = 0.d0 @@ -1169,13 +1168,12 @@ end function pint3D real(doub_prec) function full_integral_3D(d, r0, R_0, h) real(doub_prec), intent(in) :: d, r0, R_0, h - real(doub_prec) :: B1, B2, B3, a, logs, u, u2, h2 + real(doub_prec) :: B1, B2, B3, a, h2 real(doub_prec), parameter :: pi = 4.*atan(1.) - real(doub_prec) :: tanphi, phi, a2, cosp, cosp2, mu2, mu2_1, r0h, r03, r0h2, r0h3, r0h_2, r0h_3, tanp - real(doub_prec) :: r2, R_, linedist2, phi1, phi2, cosphi, sinphi - real(doub_prec) :: I0, I1, I_1, I_2, I_3, I_4, I_5 - real(doub_prec) :: J_1, J_2, J_3, J_4, J_5 - real(doub_prec) :: D1, D2, D3 + real(doub_prec) :: tanphi, phi, a2, cosp, r0h, r03, r0h2, r0h3, r0h_2, r0h_3 + real(doub_prec) :: r2, R_, linedist2, cosphi + real(doub_prec) :: I0, I1, I_2, I_3, I_4, I_5 + real(doub_prec) :: D2, D3 r0h = r0/h tanphi = abs(d)/R_0 @@ -1193,6 +1191,10 @@ real(doub_prec) function full_integral_3D(d, r0, R_0, h) r0h_2 = 1./r0h2 r0h_3 = 1./r0h3 + ! Avoid Compiler warnings + B1 = 0. + B2 = 0. + if (r0 >= 2.0*h) then B3 = 0.25*h2*h elseif (r0 > h) then @@ -1284,7 +1286,7 @@ end subroutine get_I_terms !------------------------------------------------------------ pure elemental real function soft_func(x,eps) result(f) real, intent(in) :: x,eps - real :: q,q2, q4, q6 + real :: q,q2,q4 q = x/eps q2 = q*q From a8cc2c0a00a5e5bba2d9cee29458b5347977778e Mon Sep 17 00:00:00 2001 From: MICHOULIER Stephane Date: Thu, 6 Jul 2023 15:19:25 +0200 Subject: [PATCH 054/814] correct mistake in compaction formula --- src/main/porosity.f90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 35db4f32b..6ce079f23 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -441,7 +441,7 @@ subroutine get_filfac_frag(mprev,dustprop,filfac,dustgasprop,rhod,VrelVf,dt,filf vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !number of collisions in dt - ekin = mprev*vrel*vrel/4. - (2.*mprev - dustprop(1))*0.23805*eroll/mmono !0.23805 = 1.5 * 48/302.46 + ekin = mprev*vrel*vrel/4. - (2.*mprev - dustprop(1))*0.85697283*eroll/mmono !0.856973 = 3* 1.8 * 48/302.46 pdyn = eroll /((1./filfac - 1./maxpacking)*smono)**3 deltavol = ekin/pdyn !-ekin is kinetic energy - all energy needed to break monomers @@ -813,5 +813,4 @@ real function compute_vend(vstick) compute_vend = 24343220.*vstick end function - -end module porosity \ No newline at end of file +end module porosity From 3e270f36b2265739e08b598bcb81795ac2f69dae Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 17 Jul 2023 22:43:51 +1000 Subject: [PATCH 055/814] (rad-implicit) cache lambda, eddington, opacity, cv in EU0 array --- src/main/radiation_implicit.f90 | 173 +++++++++++++++++--------------- 1 file changed, 94 insertions(+), 79 deletions(-) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 5f354fa34..18af62ba0 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -71,7 +71,7 @@ subroutine do_radiation_implicit(dt,npart,rad,xyzh,vxyzu,radprop,drad,ierr) ierr = 0 - allocate(origEU(2,npart),EU0(2,npart),stat=ierr) + allocate(origEU(2,npart),EU0(6,npart),stat=ierr) if (ierr/=0) call fatal('radiation_implicit','could not allocate memory to origEU and EU0') call get_timings(tlast,tcpulast) @@ -159,7 +159,7 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile real, intent(inout) :: radprop(:,:),rad(:,:),vxyzu(:,:) logical, intent(out) :: failed,moresweep integer, intent(out) :: nit,ierr - real, intent(out) :: errorE,errorU,EU0(2,npart) + real, intent(out) :: errorE,errorU,EU0(6,npart) integer, allocatable :: ivar(:,:),ijvar(:) integer :: ncompact,ncompactlocal,icompactmax,nneigh_average,its_global,its real, allocatable :: vari(:,:),varij(:,:),varij2(:,:),varinew(:,:) @@ -268,7 +268,7 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile nit = its call do_timing('radits',tlast,tcpulast) - call store_radiation_results(ncompactlocal,npart,ivar,EU0,rad,vxyzu) + call store_radiation_results(ncompactlocal,npart,ivar,EU0,rad,radprop,vxyzu) call do_timing('radstore',tlast,tcpulast) end subroutine do_radiation_onestep @@ -423,7 +423,7 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv integer, intent(in) :: ivar(:,:),ijvar(:) real, intent(in) :: dt,xyzh(:,:),vxyzu(:,:),rad(:,:) real, intent(inout) :: radprop(:,:) - real, intent(out) :: vari(:,:),EU0(2,npart),varij(2,icompactmax),varij2(4,icompactmax) + real, intent(out) :: vari(:,:),EU0(6,npart),varij(2,icompactmax),varij2(4,icompactmax) integer :: n,i,j,k,icompact real :: cv_effective,pmi,hi,hi21,hi41,rhoi,dx,dy,dz,rij2,rij,rij1,dr,dti,& dvxdxi,dvxdyi,dvxdzi,dvydxi,dvydyi,dvydzi,dvzdxi,dvzdyi,dvzdzi,& @@ -445,11 +445,11 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv dti = dt i = ivar(3,n) ! if (iphase(i) == 0) then + rhoi = rhoh(xyzh(4,i), massoftype(igas)) EU0(1,i) = rad(iradxi,i) EU0(2,i) = vxyzu(4,i) - rhoi = rhoh(xyzh(4,i), massoftype(igas)) - radprop(icv,i) = get_cv(rhoi,vxyzu(4,i),cv_type) - radprop(ikappa,i) = get_kappa(iopacity_type,vxyzu(4,i),radprop(icv,i),rhoi) + EU0(3,i) = get_cv(rhoi,vxyzu(4,i),cv_type) + EU0(4,i) = get_kappa(iopacity_type,vxyzu(4,i),EU0(3,i),rhoi) ! !--Diffuse ISM: Set dust temperature and opacity ! @@ -460,7 +460,7 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv ! !--Note that CV and Kappa have already been done in ASS ! - cv_effective = radprop(icv,i)/get_1overmu(rhoi,vxyzu(4,i),cv_type) + cv_effective = EU0(3,i)/get_1overmu(rhoi,vxyzu(4,i),cv_type) dvxdxi = 0. dvxdyi = 0. dvxdzi = 0. @@ -483,13 +483,15 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv ! !--Need to make sure that E and U values are loaded for non-active neighbours ! + rhoj = rhoh(xyzh(4,j), massoftype(igas)) EU0(1,j) = rad(iradxi,j) EU0(2,j) = vxyzu(4,j) + EU0(3,j) = get_cv(rhoj,vxyzu(4,j),cv_type) + EU0(4,j) = get_kappa(iopacity_type,vxyzu(4,j),EU0(3,j),rhoj) ! !--Note that CV and Kappa have already been done in ASS ! - rhoj = rhoh(xyzh(4,j), massoftype(igas)) - cv_effective = radprop(icv,j)/get_1overmu(rhoj,vxyzu(4,j),cv_type) + cv_effective = EU0(3,j)/get_1overmu(rhoj,vxyzu(4,j),cv_type) !dti = dt ! !--Calculate other quantities @@ -595,7 +597,7 @@ end subroutine fill_arrays !--------------------------------------------------------- subroutine compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,varinew,radprop) integer, intent(in) :: ivar(:,:),ijvar(:),ncompact,npart,icompactmax - real, intent(in) :: varij2(4,icompactmax),vari(2,npart),EU0(2,npart) + real, intent(in) :: varij2(4,icompactmax),vari(2,npart),EU0(6,npart) real, intent(inout) :: radprop(:,:) real, intent(out) :: varinew(3,npart) ! we use this parallel loop to set varinew to zero integer :: i,j,k,n,icompact @@ -653,8 +655,8 @@ subroutine calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,i use radiation_utils, only:get_rad_R use options, only:limit_radiation_flux integer, intent(in) :: ivar(:,:),ncompactlocal,npart - real, intent(in) :: vari(:,:),EU0(2,npart) - real, intent(inout) :: radprop(:,:) + real, intent(in) :: vari(:,:) + real, intent(inout) :: radprop(:,:),EU0(6,npart) integer, intent(out) :: ierr integer :: n,i real :: rhoi,gradE1i,opacity,radRi @@ -671,7 +673,7 @@ subroutine calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,i ! dependent opacity when dust temperatures are cold (T_d<100 K). ! Otherwise use the tabulated grey dust opacities. ! - opacity = radprop(ikappa,i) + opacity = EU0(4,i) if (dustRT) then if (dust_temp(i) < Tdust_threshold) opacity = nucleation(idkappa,i) endif @@ -685,8 +687,8 @@ subroutine calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,i else radRi = 0. endif - radprop(ilambda,i) = (2. + radRi ) / (6. + 3.*radRi + radRi**2) ! Levermore & Pomraning's flux limiter (e.g. eq 12, Whitehouse & Bate 2004) - radprop(iedd,i) = radprop(ilambda,i) + radprop(ilambda,i)**2 * radRi**2 ! e.g., eq 11, Whitehouse & Bate (2004) + EU0(5,i) = (2. + radRi ) / (6. + 3.*radRi + radRi**2) ! Levermore & Pomraning's flux limiter (e.g. eq 12, Whitehouse & Bate 2004) + EU0(6,i) = EU0(5,i) + EU0(5,i)**2 * radRi**2 ! e.g., eq 11, Whitehouse & Bate (2004) enddo !$omp enddo @@ -703,24 +705,24 @@ subroutine calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax, & use io, only:error use part, only:dust_temp,nucleation integer, intent(in) :: ivar(:,:),ijvar(:),ncompact,npart,icompactmax - real, intent(in) :: vari(:,:),varij(2,icompactmax),EU0(2,npart),radprop(:,:) + real, intent(in) :: vari(:,:),varij(2,icompactmax),EU0(6,npart),radprop(:,:) integer, intent(out) :: ierr real, intent(inout) :: varinew(3,npart) integer :: n,i,j,k,icompact - real :: rhoi,rhoj,opacityi,opacityj,bi,bj,b1,dWdrlightrhorhom + real :: rhoi,rhoj,opacityi,opacityj,Ej,bi,bj,b1,dWdrlightrhorhom real :: diffusion_numerator,diffusion_denominator,tempval1,tempval2 ierr = 0 !$omp do schedule(runtime)& - !$omp private(i,j,k,n,rhoi,rhoj,opacityi,opacityj,bi,bj,b1,diffusion_numerator,diffusion_denominator)& + !$omp private(i,j,k,n,rhoi,rhoj,opacityi,opacityj,Ej,bi,bj,b1,diffusion_numerator,diffusion_denominator)& !$omp private(dWdrlightrhorhom,tempval1,tempval2,icompact)& !$omp reduction(max:ierr) do n = 1,ncompact i = ivar(3,n) ! if (iphase(i) == 0) then rhoi = vari(2,n) - opacityi = radprop(ikappa,i) - bi = radprop(ilambda,i)/(opacityi*rhoi) + opacityi = EU0(4,i) + bi = EU0(5,i)/(opacityi*rhoi) ! !--NOTE: Needs to do this loop even for boundaryparticles because active ! boundary particles will need to contribute to the varinew() @@ -744,7 +746,8 @@ subroutine calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax, & ! !--Set c*lambda/kappa*rho term (radiative diffusion coefficient) for current quantities ! - opacityj = radprop(ikappa,j) + Ej = EU0(1,j) + opacityj = EU0(4,j) if (dustRT) then if (dust_temp(i) < Tdust_threshold) opacityi = nucleation(idkappa,i) if (dust_temp(j) < Tdust_threshold) opacityj = nucleation(idkappa,j) @@ -753,7 +756,7 @@ subroutine calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax, & ierr = max(ierr,ierr_negative_opacity) call error(label,'Negative or zero opacity',val=min(opacityi,opacityj)) endif - bj = radprop(ilambda,j)/(opacityj*rhoj) + bj = EU0(5,j)/(opacityj*rhoj) ! !--Choose the 'average' diffusion value. The (bi+bj) quantity biased in ! favour of the particle with the lowest opacity. The other average @@ -762,7 +765,7 @@ subroutine calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax, & ! !--Diffusion numerator and denominator ! - diffusion_numerator = diffusion_numerator - dWdrlightrhorhom*b1*EU0(1,j)*rhoj + diffusion_numerator = diffusion_numerator - dWdrlightrhorhom*b1*Ej*rhoj diffusion_denominator = diffusion_denominator + dWdrlightrhorhom*b1*rhoi enddo varinew(1,i) = varinew(1,i) + diffusion_numerator @@ -790,7 +793,7 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& real(kind=4), intent(in) :: pdvvisc(:),dvdx(:,:) real, intent(in) :: eos_vars(:,:) real, intent(inout) :: drad(:,:),fxyzu(:,:),nucleation(:,:),dust_temp(:) - real, intent(inout) :: radprop(:,:),EU0(2,npart) + real, intent(inout) :: radprop(:,:),EU0(6,npart) real, intent(out) :: maxerrE2,maxerrU2 logical, intent(in) :: store_drad logical, intent(out):: moresweep @@ -803,6 +806,8 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& real :: u4term,u1term,u0term,pcoleni,dust_cooling,heatingISRi,dust_gas real :: pres_numerator,pres_denominator,mui,U1i,E1i,Tgas,dUcomb,dEcomb real :: residualE,residualU,xchange,maxerrU2old,Tgas4,Trad4,ck,ack + real :: Ei,Ui,cvi,opacityi,eddi + real :: maxerrE2i,maxerrU2i a_code = get_radconst_code() c_code = get_c_code() @@ -819,6 +824,7 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& !$omp private(cooling_line,photoelectric,h2form,dust_heating,dust_term,betaval,chival,gammaval,betaval_d,tfour) & !$omp private(e_planetesimali,u4term,u1term,u0term,pcoleni,pres_numerator,pres_denominator,moresweep2,mui,ierr) & !$omp private(residualE,residualU,xchange,maxerrU2old,gas_temp,ieqtype,unit_density,Tgas4,Trad4,ck,ack) & + !$omp private(maxerrE2i,maxerrU2i) & !$omp reduction(max:maxerrE2,maxerrU2) main_loop: do n = 1,ncompactlocal i = ivar(3,n) @@ -826,11 +832,15 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& ! if (iphase(i)==0) then dti = vari(1,n) rhoi = vari(2,n) - ! if (.NOT.boundaryparticle(i,xyzmh,rhoi)) then diffusion_numerator = varinew(1,i) diffusion_denominator = varinew(2,i) pres_numerator = pdvvisc(i)/massoftype(igas) ! in phantom pdvvisc->luminosity which is m*du/dt not du/dt pres_denominator = 0. + Ei = EU0(1,i) + Ui = EU0(2,i) + cvi = EU0(3,i) + opacityi = EU0(4,i) + eddi = EU0(6,i) ! !--Radiation pressure... ! @@ -839,8 +849,8 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& if (gradEi2 < tiny(0.)) then gradvPi = 0. else - rpdiag = 0.5*(1.-radprop(iedd,i)) ! Diagonal component of Eddington tensor (eq 10, Whitehouse & Bate 2004) - rpall = 0.5*(3.*radprop(iedd,i)-1.)/gradEi2 ! n,n-component of Eddington tensor, where n is the direction of grad(E) (or -ve flux) + rpdiag = 0.5*(1.-eddi) ! Diagonal component of Eddington tensor (eq 10, Whitehouse & Bate 2004) + rpall = 0.5*(3.*eddi-1.)/gradEi2 ! n,n-component of Eddington tensor, where n is the direction of grad(E) (or -ve flux) gradvPi = (((rpdiag+rpall*radprop(ifluxx,i)**2)*dvdx(1,i))+ & ((rpall*radprop(ifluxx,i)*radprop(ifluxy,i))*dvdx(2,i))+ & ((rpall*radprop(ifluxx,i)*radprop(ifluxz,i))*dvdx(3,i))+ & @@ -852,7 +862,7 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& ((rpdiag+rpall*radprop(ifluxz,i)**2)*dvdx(9,i))) ! e.g. eq 23, Whitehouse & Bate (2004) endif - radpresdenom = gradvPi * EU0(1,i) + radpresdenom = gradvPi * Ei stellarradiation = 0. ! set to zero e_planetesimali = 0. @@ -863,9 +873,9 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& ! by the dust-radiation term, but keep the T_d rather than T_g ! if (dustRT) then - radprop(ikappa,i) = get_kappa(iopacity_type,EU0(2,i),radprop(icv,i),rhoi) - dust_tempi = dust_temperature(rad(iradxi,i),EU0(2,i),rhoi,dust_kappai,dust_cooling,heatingISRi,dust_gas) - gas_temp = EU0(2,i)/radprop(icv,i) + radprop(ikappa,i) = get_kappa(iopacity_type,Ui,cvi,rhoi) + dust_tempi = dust_temperature(rad(iradxi,i),Ui,rhoi,dust_kappai,dust_cooling,heatingISRi,dust_gas) + gas_temp = Ui/cvi mui = eos_vars(imu,i) xnH2 = rhoi*unit_density/(mui*mass_proton_cgs) ! Mike: Check units endif @@ -887,7 +897,7 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& ! (<1 K), then we abandon the gas-dust coupling term. ! call set_heating_cooling_low_rhoT(i,EU0(1,i),EU0(2,i),origEU(1,i),origEU(2,i),& - radprop(icv,i),dti,diffusion_denominator,& + EU0(3,i),dti,diffusion_denominator,& pres_numerator,radpresdenom,rhoi,xnH2,heatingISRi,e_planetesimali,& metallicity,gas_temp,ieqtype,betaval,betaval_d,gammaval,& chival,tfour,dust_tempi,gas_dust_val,dustgammaval,gas_dust_cooling,& @@ -918,18 +928,19 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& ! !--Now solve those equations... (these are eqns 22 in Whitehouse, Bate & Monaghan 2005) ! - Tgas4 = (EU0(2,i)/radprop(icv,i))**4 - Trad4 = rhoi*EU0(1,i)/a_code - ck = c_code*radprop(ikappa,i) + Tgas = Ui/cvi + Tgas4 = Tgas**4 + Trad4 = rhoi*Ei/a_code + ck = c_code*opacityi ack = a_code*ck betaval = ck*rhoi*dti - chival = dti*(diffusion_denominator-radpresdenom/EU0(1,i))-betaval - gammaval = ack/radprop(icv,i)**4 + chival = dti*(diffusion_denominator-radpresdenom/Ei)-betaval + gammaval = ack/cvi**4 tfour = ack*(Trad4 - Tgas4) - u4term = gammaval*dti*(dti*(diffusion_denominator-radpresdenom/EU0(1,i)) - 1.) - u1term = (chival-1.)*(1.-dti*pres_denominator + dti*gas_dust_val/radprop(icv,i)) & - - betaval*dti*gas_dust_val/radprop(icv,i) + u4term = gammaval*dti*(dti*(diffusion_denominator-radpresdenom/Ei) - 1.) + u1term = (chival-1.)*(1.-dti*pres_denominator + dti*gas_dust_val/cvi) & + - betaval*dti*gas_dust_val/cvi u0term = betaval*(origEU(1,i) - dti*gas_dust_val*dust_tempi + dti*dust_heating) + & (chival-1.)*(-origEU(2,i) - dti*pres_numerator - dti*e_planetesimali & - dti*gas_dust_val*dust_tempi - dti*cosmic_ray + dti*cooling_line - dti*photoelectric & @@ -939,10 +950,10 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& if (u1term > 0. .and. u0term > 0. .or. u1term < 0. .and. u0term < 0.) then !$omp critical(quart) print *,"ngs ",u4term,u1term,u0term,betaval,chival,gammaval - print *," ",radprop(ikappa,i),rhoi,dti + print *," ",EU0(4,i),rhoi,dti print *," ",diffusion_denominator,diffusion_numerator print *," ",pres_denominator,pres_numerator !,uradconst - print *," ",radpresdenom,EU0(1,i),EU0(2,i) !,ekcle(3,i) + print *," ",radpresdenom,Ei,Ui print *," ",c_code,origEU(1,i),origEU(2,i) !$omp end critical(quart) !$omp critical (moresweepset) @@ -955,33 +966,33 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& u1term = u1term/u4term u0term = u0term/u4term moresweep2 = .false. - call solve_quartic(u1term,u0term,EU0(2,i),U1i,moresweep2,ierr) ! U1i is the quartic solution + call solve_quartic(u1term,u0term,Ui,U1i,moresweep2,ierr) ! U1i is the quartic solution if (ierr /= 0) then print*,'Error in solve_quartic' - print*,'i=',i,'u1term=',u1term,'u0term=',u0term,'EU0(2,i)=',EU0(2,i),'U1i=',U1i,'moresweep=',moresweep - print*,"info: ",EU0(2,i)/radprop(icv,i) - print*,"info2: ",u0term,u1term,u4term,gammaval,radprop(ikappa,i),radprop(icv,i) + print*,'i=',i,'u1term=',u1term,'u0term=',u0term,'EU0(2,i)=',Ui,'U1i=',U1i,'moresweep=',moresweep + print*,"info: ",Tgas + print*,"info2: ",u0term,u1term,u4term,gammaval,opacityi,cvi print*,"info3: ",chival,betaval,dti,rhoi print*,"info4: ",pres_denominator,origEU(1,i),pres_numerator print*,"info5: ",diffusion_numerator,stellarradiation,diffusion_denominator - print*,"info6: ",radpresdenom,EU0(1,i) - print*,"Tgas: ",EU0(2,i)/radprop(icv,i)," Trad:",(rhoi*EU0(1,i)/a_code)**0.25,' ack*(Tgas^4 - Trad^4): ',tfour + print*,"info6: ",radpresdenom,Ei + print*,"Tgas: ",Tgas," Trad:",Trad4**0.25,' ack*(Tgas^4 - Trad^4): ',tfour call fatal('solve_quartic','Fail to solve') endif if (moresweep2) then -!$omp critical (moresweepset) + !$omp critical (moresweepset) moresweep = .true. - print*,"info: ",EU0(2,i)/radprop(icv,i) - print*,"info2: ",u0term,u1term,u4term,gammaval,radprop(ikappa,i),radprop(icv,i) + print*,"info: ",Tgas + print*,"info2: ",u0term,u1term,u4term,gammaval,opacityi,cvi print*,"info3: ",chival,betaval,dti print*,"info4: ",pres_denominator,origeu(1,i),pres_numerator print*,"info5: ",diffusion_numerator,stellarradiation,diffusion_denominator - print*,"info6: ",radpresdenom,EU0(1,i) + print*,"info6: ",radpresdenom,Ei print*,"info7: ",cosmic_ray,heatingisri print*,"info8: ",cooling_line,photoelectric,h2form -!$omp end critical (moresweepset) + !$omp end critical (moresweepset) cycle main_loop endif endif @@ -989,66 +1000,66 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& E1i = (origEU(1,i) + dti*diffusion_numerator & + gammaval*dti*U1i**4 & + dustgammaval*dti & - + dti*gas_dust_val*(U1i/radprop(icv,i) - dust_tempi) & + + dti*gas_dust_val*(U1i/cvi - dust_tempi) & + dti*dust_heating & + stellarradiation)/(1.-chival) - dUcomb = pres_numerator + pres_denominator*EU0(2,i) + tfour & + dUcomb = pres_numerator + pres_denominator*Ui + tfour & - gas_dust_cooling + cosmic_ray - cooling_line & + photoelectric + h2form + e_planetesimali + pcoleni - dEcomb = diffusion_numerator + diffusion_denominator * EU0(1,i) & + dEcomb = diffusion_numerator + diffusion_denominator * Ei & - tfour - radpresdenom + stellarradiation + dust_heating + gas_dust_cooling ! !--Tests for negativity ! if (U1i <= 0.) then -!$omp critical (moresweepset) - print*, "radiation_implicit: u has gone negative ",i,u1term,u0term,u4term,EU0(2,i),U1i,moresweep,ierr + !$omp critical (moresweepset) + print*, "radiation_implicit: u has gone negative ",i,u1term,u0term,u4term,Ui,U1i,moresweep,ierr moresweep=.true. print*, "radiation_implicit: u has gone negative ",i,U1i print*,'Error in solve_quartic' - print*,'i=',i,'u1term=',u1term,'u0term=',u0term,'EU0(2,i)=',EU0(2,i),'U1i=',U1i,'moresweep=',moresweep - print*,"info: ",EU0(2,i)/radprop(icv,i) - print*,"info2: ",u0term,u1term,u4term,gammaval,radprop(ikappa,i),radprop(icv,i) + print*,'i=',i,'u1term=',u1term,'u0term=',u0term,'EU0(2,i)=',Ui,'U1i=',U1i,'moresweep=',moresweep + print*,"info: ",Tgas + print*,"info2: ",u0term,u1term,u4term,gammaval,opacityi,cvi print*,"info3: ",chival,betaval,dti print*,"info4: ",pres_denominator,origEU(1,i),pres_numerator print*,"info5: ",diffusion_numerator,stellarradiation,diffusion_denominator - print*,"info6: ",radpresdenom,EU0(1,i) -!$omp end critical (moresweepset) + print*,"info6: ",radpresdenom,Ei + !$omp end critical (moresweepset) endif if (E1i <= 0.) then -!$omp critical (moresweepset) + !$omp critical (moresweepset) moresweep=.true. call error(label,'e has gone negative',i) -!$omp end critical (moresweepset) + !$omp end critical (moresweepset) endif ! ! And the error is... ! - Tgas = EU0(2,i)/radprop(icv,i) if (Tgas >= 0.) then - maxerrE2 = max(maxerrE2, 1.*abs((EU0(1,i) - E1i)/E1i)) + maxerrE2i = abs((Ei - E1i)/E1i) residualE = 0. else - xchange = abs((origEU(1,i) + (dEcomb)*dti - E1i)/E1i) - maxerrE2 = max(maxerre2,xchange) + maxerrE2i = abs((origEU(1,i) + (dEcomb)*dti - E1i)/E1i) residualE = origEU(1,i) + (dEcomb)*dti - E1i endif + maxerrE2 = max(maxerrE2, maxerrE2i) if (Tgas >= 2000.) then - maxerrU2 = max(maxerrU2, 1.*abs((EU0(2,i) - U1i)/U1i)) + maxerrU2i = abs((Ui - U1i)/U1i) residualU = 0. else maxerrU2old = maxerrU2 - maxerrU2 = max(maxerrU2, abs((origEU(2,i)+(dUcomb)* dti - U1i)/U1i)) + maxerrU2i = abs((origEU(2,i)+(dUcomb)* dti - U1i)/U1i) residualU = origEU(2,i)+(dUcomb)*dti - U1i endif + maxerrU2 = max(maxerrU2, maxerrU2i) ! !--Copy values ! EU0(1,i) = E1i EU0(2,i) = U1i - radprop(icv,i) = get_cv(rhoi,EU0(2,i),cv_type) - radprop(ikappa,i) = get_kappa(iopacity_type,EU0(2,i),radprop(icv,i),rhoi) + EU0(3,i) = get_cv(rhoi,U1i,cv_type) + EU0(4,i) = get_kappa(iopacity_type,U1i,EU0(3,i),rhoi) if (store_drad) then ! use this for testing drad(iradxi,i) = (E1i - origEU(1,i))/dti ! dxi/dt @@ -1056,7 +1067,7 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& endif if (dustRT) then - dust_temp(i) = dust_temperature(rad(iradxi,i),EU0(2,i),rhoi,dust_kappai,& + dust_temp(i) = dust_temperature(rad(iradxi,i),U1i,rhoi,dust_kappai,& dust_cooling,heatingISRi,dust_gas) nucleation(idkappa,i) = dust_kappai endif @@ -1347,19 +1358,23 @@ subroutine turn_heating_cooling_off(ieqtype,dust_tempi,gas_dust_val,dustgammaval end subroutine turn_heating_cooling_off -subroutine store_radiation_results(ncompactlocal,npart,ivar,EU0,rad,vxyzu) +subroutine store_radiation_results(ncompactlocal,npart,ivar,EU0,rad,radprop,vxyzu) integer, intent(in) :: ncompactlocal,npart,ivar(:,:) - real, intent(in) :: EU0(2,npart) - real, intent(out) :: rad(:,:),vxyzu(:,:) + real, intent(in) :: EU0(6,npart) + real, intent(out) :: rad(:,:),radprop(:,:),vxyzu(:,:) integer :: i,n !$omp parallel do default(none) & - !$omp shared(ncompactlocal,ivar,vxyzu,EU0,rad) & + !$omp shared(ncompactlocal,ivar,vxyzu,EU0,rad,radprop) & !$omp private(n,i) do n = 1,ncompactlocal i = ivar(3,n) rad(iradxi,i) = EU0(1,i) vxyzu(4,i) = EU0(2,i) + radprop(icv,i) = EU0(3,i) + radprop(ikappa,i) = EU0(4,i) + radprop(ilambda,i) = EU0(5,i) + radprop(iedd,i) = EU0(6,i) enddo !$omp end parallel do From d3acaaad7cfa6b46bd2340d71d3ff54b53b9f050 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 17 Jul 2023 22:59:56 +1000 Subject: [PATCH 056/814] (rad-implicit) only iterate particles that have not converged within rad_tol --- src/main/radiation_implicit.f90 | 919 ++++++++++++++++---------------- 1 file changed, 469 insertions(+), 450 deletions(-) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 18af62ba0..88679a543 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -163,6 +163,7 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile integer, allocatable :: ivar(:,:),ijvar(:) integer :: ncompact,ncompactlocal,icompactmax,nneigh_average,its_global,its real, allocatable :: vari(:,:),varij(:,:),varij2(:,:),varinew(:,:) + logical, allocatable :: mask(:) real :: maxerrE2,maxerrU2,maxerrE2last,maxerrU2last real(kind=4) :: tlast,tcpulast,t1,tcpu1 logical :: converged @@ -180,8 +181,8 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile if (ierr/=0) call fatal('radiation_implicit','cannot allocate memory for ivar') allocate(ijvar(icompactmax),stat=ierr) if (ierr/=0) call fatal('radiation_implicit','cannot allocate memory for ijvar') - allocate(vari(2,npart),varij(2,icompactmax),varij2(4,icompactmax),varinew(3,npart),stat=ierr) - if (ierr/=0) call fatal('radiation_implicit','cannot allocate memory for vari, varij, varij2, varinew') + allocate(vari(2,npart),varij(2,icompactmax),varij2(4,icompactmax),varinew(3,npart),mask(npart),stat=ierr) + if (ierr/=0) call fatal('radiation_implicit','cannot allocate memory for vari, varij, varij2, varinew, mask') !dtimax = dt/imaxstep call get_compacted_neighbour_list(xyzh,ivar,ijvar,ncompact,ncompactlocal) @@ -197,12 +198,12 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile !$omp parallel default(none) & !$omp shared(tlast,tcpulast,ncompact,ncompactlocal,npart,icompactmax,dt,its_global) & - !$omp shared(xyzh,vxyzu,ivar,ijvar,varinew,radprop,rad,vari,varij,varij2,origEU,EU0) & + !$omp shared(xyzh,vxyzu,ivar,ijvar,varinew,radprop,rad,vari,varij,varij2,origEU,EU0,mask) & !$omp shared(pdvvisc,dvdx,nucleation,dust_temp,eos_vars,drad,fxyzu,implicit_radiation_store_drad) & !$omp shared(converged,maxerrE2,maxerrU2,maxerrE2last,maxerrU2last,itsmax_rad,moresweep,tol_rad,iverbose,ierr) & !$omp private(t1,tcpu1,its) call fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,& - xyzh,vxyzu,ivar,ijvar,radprop,rad,vari,varij,varij2,EU0) + xyzh,vxyzu,ivar,ijvar,radprop,rad,vari,varij,varij2,EU0,mask) !$omp master call do_timing('radarrays',tlast,tcpulast) @@ -211,6 +212,7 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile !$omp single maxerrE2last = huge(0.) maxerrU2last = huge(0.) + mask = .true. !$omp end single iterations: do its=1,itsmax_rad @@ -218,15 +220,15 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile !$omp master call get_timings(t1,tcpu1) !$omp end master - call compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,varinew,radprop) + call compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,varinew,radprop,mask=mask) !$omp master call do_timing('radflux',t1,tcpu1) !$omp end master - call calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,ierr) + call calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,mask,ierr) !$omp master call do_timing('radlambda',t1,tcpu1) !$omp end master - call calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax,radprop,vari,EU0,varinew,ierr) + call calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax,radprop,vari,EU0,varinew,mask,ierr) !$omp master call do_timing('raddiff',t1,tcpu1) !$omp end master @@ -234,7 +236,7 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile call update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& radprop,rad,origEU,varinew,EU0,& pdvvisc,dvdx,nucleation,dust_temp,eos_vars,drad,fxyzu,& - implicit_radiation_store_drad,moresweep,maxerrE2,maxerrU2) + mask,implicit_radiation_store_drad,moresweep,maxerrE2,maxerrU2) !$omp master call do_timing('radupdate',t1,tcpu1) @@ -242,7 +244,7 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile !$omp single if (iverbose >= 2) then - print*,'iteration: ',its,' error = ',maxerrE2,maxerrU2 + print*,'iteration: ',its,' error = ',maxerrE2,maxerrU2,count(mask) endif converged = (maxerrE2 <= tol_rad .and. maxerrU2 <= tol_rad) maxerrU2last = maxerrU2 @@ -380,12 +382,12 @@ subroutine get_compacted_neighbour_list(xyzh,ivar,ijvar,ncompact,ncompactlocal) enddo loop_over_neigh -!$omp critical(listcompact) + !$omp critical(listcompact) ncompact = ncompact + 1 ncompact_private = ncompact icompact_private = icompact icompact = icompact + nneigh -!$omp end critical (listcompact) + !$omp end critical (listcompact) if (icompact_private+nneigh > icompactmax) then print*,'i=',i,'nneigh=',nneigh,'desired size=',icompact_private+nneigh,' actual size=',icompactmax call fatal('radiation-implicit','not enough memory allocated for neighbour list', & @@ -413,7 +415,7 @@ end subroutine get_compacted_neighbour_list ! fill arrays !+ !--------------------------------------------------------- -subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,ivar,ijvar,radprop,rad,vari,varij,varij2,EU0) +subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,ivar,ijvar,radprop,rad,vari,varij,varij2,EU0,mask) use dim, only:periodic use boundary, only:dxbound,dybound,dzbound use part, only:dust_temp,nucleation,gradh,dvdx @@ -421,6 +423,7 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv use kernel, only:grkern,cnormk integer, intent(in) :: ncompact,ncompactlocal,icompactmax,npart integer, intent(in) :: ivar(:,:),ijvar(:) + logical, intent(in) :: mask(npart) real, intent(in) :: dt,xyzh(:,:),vxyzu(:,:),rad(:,:) real, intent(inout) :: radprop(:,:) real, intent(out) :: vari(:,:),EU0(6,npart),varij(2,icompactmax),varij2(4,icompactmax) @@ -444,146 +447,147 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv do n = 1,ncompact dti = dt i = ivar(3,n) - ! if (iphase(i) == 0) then - rhoi = rhoh(xyzh(4,i), massoftype(igas)) - EU0(1,i) = rad(iradxi,i) - EU0(2,i) = vxyzu(4,i) - EU0(3,i) = get_cv(rhoi,vxyzu(4,i),cv_type) - EU0(4,i) = get_kappa(iopacity_type,vxyzu(4,i),EU0(3,i),rhoi) - ! - !--Diffuse ISM: Set dust temperature and opacity - ! - if (dustRT .and. n<=ncompactlocal) then - dust_temp(i) = dust_temperature(rad(iradxi,i),vxyzu(4,i),rhoi,dust_kappai,dust_cooling,heatingISRi,dust_gas) - nucleation(idkappa,i) = dust_kappai - endif - ! - !--Note that CV and Kappa have already been done in ASS - ! - cv_effective = EU0(3,i)/get_1overmu(rhoi,vxyzu(4,i),cv_type) - dvxdxi = 0. - dvxdyi = 0. - dvxdzi = 0. - dvydxi = 0. - dvydyi = 0. - dvydzi = 0. - dvzdxi = 0. - dvzdyi = 0. - dvzdzi = 0. - - pmi = massoftype(igas) - hi = xyzh(4,i) - hi21 = 1./(hi*hi) - hi41 = hi21*hi21 - rhoi = rhoh(xyzh(4,i), massoftype(igas)) - - do k = 1,ivar(1,n) ! Looping from 1 to nneigh - icompact = ivar(2,n) + k - j = ijvar(icompact) + + if (.true.) then + rhoi = rhoh(xyzh(4,i), massoftype(igas)) + EU0(1,i) = rad(iradxi,i) + EU0(2,i) = vxyzu(4,i) + EU0(3,i) = get_cv(rhoi,vxyzu(4,i),cv_type) + EU0(4,i) = get_kappa(iopacity_type,vxyzu(4,i),EU0(3,i),rhoi) ! - !--Need to make sure that E and U values are loaded for non-active neighbours + !--Diffuse ISM: Set dust temperature and opacity ! - rhoj = rhoh(xyzh(4,j), massoftype(igas)) - EU0(1,j) = rad(iradxi,j) - EU0(2,j) = vxyzu(4,j) - EU0(3,j) = get_cv(rhoj,vxyzu(4,j),cv_type) - EU0(4,j) = get_kappa(iopacity_type,vxyzu(4,j),EU0(3,j),rhoj) + if (dustRT .and. n<=ncompactlocal) then + dust_temp(i) = dust_temperature(rad(iradxi,i),vxyzu(4,i),rhoi,dust_kappai,dust_cooling,heatingISRi,dust_gas) + nucleation(idkappa,i) = dust_kappai + endif ! !--Note that CV and Kappa have already been done in ASS ! - cv_effective = EU0(3,j)/get_1overmu(rhoj,vxyzu(4,j),cv_type) - !dti = dt - ! - !--Calculate other quantities - ! - dx = xyzh(1,i) - xyzh(1,j) - dy = xyzh(2,i) - xyzh(2,j) - dz = xyzh(3,i) - xyzh(3,j) - if (periodic) then - if (abs(dx) > 0.5*dxbound) dx = dx - dxbound*SIGN(1.0,dx) - if (abs(dy) > 0.5*dybound) dy = dy - dybound*SIGN(1.0,dy) - if (abs(dz) > 0.5*dzbound) dz = dz - dzbound*SIGN(1.0,dz) - endif - rij2 = dx*dx + dy*dy + dz*dz + tiny(0.) - rij = sqrt(rij2) - rij1 = 1./rij - dr = rij + cv_effective = EU0(3,i)/get_1overmu(rhoi,vxyzu(4,i),cv_type) + dvxdxi = 0. + dvxdyi = 0. + dvxdzi = 0. + dvydxi = 0. + dvydyi = 0. + dvydzi = 0. + dvzdxi = 0. + dvzdyi = 0. + dvzdzi = 0. + + pmi = massoftype(igas) + hi = xyzh(4,i) + hi21 = 1./(hi*hi) + hi41 = hi21*hi21 + rhoi = rhoh(xyzh(4,i), massoftype(igas)) + + do k = 1,ivar(1,n) ! Looping from 1 to nneigh + icompact = ivar(2,n) + k + j = ijvar(icompact) + ! + !--Need to make sure that E and U values are loaded for non-active neighbours + ! + rhoj = rhoh(xyzh(4,j), massoftype(igas)) + EU0(1,j) = rad(iradxi,j) + EU0(2,j) = vxyzu(4,j) + EU0(3,j) = get_cv(rhoj,vxyzu(4,j),cv_type) + EU0(4,j) = get_kappa(iopacity_type,vxyzu(4,j),EU0(3,j),rhoj) + ! + !--Note that CV and Kappa have already been done in ASS + ! + cv_effective = EU0(3,j)/get_1overmu(rhoj,vxyzu(4,j),cv_type) + !dti = dt + ! + !--Calculate other quantities + ! + dx = xyzh(1,i) - xyzh(1,j) + dy = xyzh(2,i) - xyzh(2,j) + dz = xyzh(3,i) - xyzh(3,j) + if (periodic) then + if (abs(dx) > 0.5*dxbound) dx = dx - dxbound*SIGN(1.0,dx) + if (abs(dy) > 0.5*dybound) dy = dy - dybound*SIGN(1.0,dy) + if (abs(dz) > 0.5*dzbound) dz = dz - dzbound*SIGN(1.0,dz) + endif + rij2 = dx*dx + dy*dy + dz*dz + tiny(0.) + rij = sqrt(rij2) + rij1 = 1./rij + dr = rij - pmj = massoftype(igas) + pmj = massoftype(igas) - hj = xyzh(4,j) - hj21 = 1./(hj*hj) - hj41 = hj21*hj21 + hj = xyzh(4,j) + hj21 = 1./(hj*hj) + hj41 = hj21*hj21 - v2i = rij2*hi21 - vi = rij/hi + v2i = rij2*hi21 + vi = rij/hi - v2j = rij2*hj21 - vj = rij/hj + v2j = rij2*hj21 + vj = rij/hj - dWi = grkern(v2i,vi)*hi41*cnormk*gradh(1,i) - dWj = grkern(v2j,vj)*hj41*cnormk*gradh(1,j) + dWi = grkern(v2i,vi)*hi41*cnormk*gradh(1,i) + dWj = grkern(v2j,vj)*hj41*cnormk*gradh(1,j) - dvx = vxyzu(1,i) - vxyzu(1,j) - dvy = vxyzu(2,i) - vxyzu(2,j) - dvz = vxyzu(3,i) - vxyzu(3,j) + dvx = vxyzu(1,i) - vxyzu(1,j) + dvy = vxyzu(2,i) - vxyzu(2,j) + dvz = vxyzu(3,i) - vxyzu(3,j) - dvdotdr = dvx*dx + dvy*dy + dvz*dz - dv = dvdotdr/dr + dvdotdr = dvx*dx + dvy*dy + dvz*dz + dv = dvdotdr/dr - if (dvdotdr > 0.) then - vmu = 0. - else - vmu = dv - endif + if (dvdotdr > 0.) then + vmu = 0. + else + vmu = dv + endif - ! Coefficients in radiative flux term in radiation energy density equation (e.g. eq 22 & 25, Whitehouse & Bate 2004) - dvdWimj = pmj*dv*dWi - dvdWimi = pmi*dv*dWi - dvdWjmj = pmj*dv*dWj + ! Coefficients in radiative flux term in radiation energy density equation (e.g. eq 22 & 25, Whitehouse & Bate 2004) + dvdWimj = pmj*dv*dWi + dvdWimi = pmi*dv*dWi + dvdWjmj = pmj*dv*dWj - ! Coefficients for p(div(v))/rho term in gas energy equation (e.g. eq 26, Whitehouse & Bate 2004) - dWidrlightrhorhom = c_code*dWi/dr*pmj/(rhoi*rhoj) - dWjdrlightrhorhom = c_code*dWj/dr*pmj/(rhoi*rhoj) + ! Coefficients for p(div(v))/rho term in gas energy equation (e.g. eq 26, Whitehouse & Bate 2004) + dWidrlightrhorhom = c_code*dWi/dr*pmj/(rhoi*rhoj) + dWjdrlightrhorhom = c_code*dWj/dr*pmj/(rhoi*rhoj) - pmjdWrijrhoi = pmj*dWi*rij1/rhoi - pmjdWrunix = pmjdWrijrhoi*dx - pmjdWruniy = pmjdWrijrhoi*dy - pmjdWruniz = pmjdWrijrhoi*dz - ! - !--Calculates density(i) times the gradient of velocity - ! - dvxdxi = dvxdxi - dvx*pmjdWrunix - dvxdyi = dvxdyi - dvx*pmjdWruniy - dvxdzi = dvxdzi - dvx*pmjdWruniz - dvydxi = dvydxi - dvy*pmjdWrunix - dvydyi = dvydyi - dvy*pmjdWruniy - dvydzi = dvydzi - dvy*pmjdWruniz - dvzdxi = dvzdxi - dvz*pmjdWrunix - dvzdyi = dvzdyi - dvz*pmjdWruniy - dvzdzi = dvzdzi - dvz*pmjdWruniz - - varij(1,icompact) = rhoj - varij(2,icompact) = 0.5*(dWidrlightrhorhom+dWjdrlightrhorhom) - - varij2(1,icompact) = pmjdWrunix - varij2(2,icompact) = pmjdWruniy - varij2(3,icompact) = pmjdWruniz - varij2(4,icompact) = rhoj - enddo - dvdx(1,i) = real(dvxdxi,kind=kind(dvdx)) ! convert to real*4 explicitly to avoid warnings - dvdx(2,i) = real(dvxdyi,kind=kind(dvdx)) - dvdx(3,i) = real(dvxdzi,kind=kind(dvdx)) - dvdx(4,i) = real(dvydxi,kind=kind(dvdx)) - dvdx(5,i) = real(dvydyi,kind=kind(dvdx)) - dvdx(6,i) = real(dvydzi,kind=kind(dvdx)) - dvdx(7,i) = real(dvzdxi,kind=kind(dvdx)) - dvdx(8,i) = real(dvzdyi,kind=kind(dvdx)) - dvdx(9,i) = real(dvzdzi,kind=kind(dvdx)) - - vari(1,n) = dti - vari(2,n) = rhoi - ! endif + pmjdWrijrhoi = pmj*dWi*rij1/rhoi + pmjdWrunix = pmjdWrijrhoi*dx + pmjdWruniy = pmjdWrijrhoi*dy + pmjdWruniz = pmjdWrijrhoi*dz + ! + !--Calculates density(i) times the gradient of velocity + ! + dvxdxi = dvxdxi - dvx*pmjdWrunix + dvxdyi = dvxdyi - dvx*pmjdWruniy + dvxdzi = dvxdzi - dvx*pmjdWruniz + dvydxi = dvydxi - dvy*pmjdWrunix + dvydyi = dvydyi - dvy*pmjdWruniy + dvydzi = dvydzi - dvy*pmjdWruniz + dvzdxi = dvzdxi - dvz*pmjdWrunix + dvzdyi = dvzdyi - dvz*pmjdWruniy + dvzdzi = dvzdzi - dvz*pmjdWruniz + + varij(1,icompact) = rhoj + varij(2,icompact) = 0.5*(dWidrlightrhorhom+dWjdrlightrhorhom) + + varij2(1,icompact) = pmjdWrunix + varij2(2,icompact) = pmjdWruniy + varij2(3,icompact) = pmjdWruniz + varij2(4,icompact) = rhoj + enddo + dvdx(1,i) = real(dvxdxi,kind=kind(dvdx)) ! convert to real*4 explicitly to avoid warnings + dvdx(2,i) = real(dvxdyi,kind=kind(dvdx)) + dvdx(3,i) = real(dvxdzi,kind=kind(dvdx)) + dvdx(4,i) = real(dvydxi,kind=kind(dvdx)) + dvdx(5,i) = real(dvydyi,kind=kind(dvdx)) + dvdx(6,i) = real(dvydzi,kind=kind(dvdx)) + dvdx(7,i) = real(dvzdxi,kind=kind(dvdx)) + dvdx(8,i) = real(dvzdyi,kind=kind(dvdx)) + dvdx(9,i) = real(dvzdzi,kind=kind(dvdx)) + + vari(1,n) = dti + vari(2,n) = rhoi + endif enddo !$omp enddo @@ -595,9 +599,10 @@ end subroutine fill_arrays ! compute radiative flux !+ !--------------------------------------------------------- -subroutine compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,varinew,radprop) +subroutine compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,varinew,radprop,mask) integer, intent(in) :: ivar(:,:),ijvar(:),ncompact,npart,icompactmax real, intent(in) :: varij2(4,icompactmax),vari(2,npart),EU0(6,npart) + logical, intent(in) :: mask(npart) real, intent(inout) :: radprop(:,:) real, intent(out) :: varinew(3,npart) ! we use this parallel loop to set varinew to zero integer :: i,j,k,n,icompact @@ -612,32 +617,33 @@ subroutine compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,va varinew(1,i) = 0. varinew(2,i) = 0. !varinew(3,i) = 0. - ! if (iphase(i)==0) then - dedxi = 0. - dedyi = 0. - dedzi = 0. - - rhoi = vari(2,n) - rhoiEU0 = rhoi*EU0(1,i) - - do k = 1,ivar(1,n) - icompact = ivar(2,n) + k - j = ijvar(icompact) - pmjdWrunix = varij2(1,icompact) - pmjdWruniy = varij2(2,icompact) - pmjdWruniz = varij2(3,icompact) - rhoj = varij2(4,icompact) - - ! Calculates the gradient of E (where E=rho*e, and e is xi) - dradenij = rhoj*EU0(1,j) - rhoiEU0 - dedxi = dedxi + dradenij*pmjdWrunix - dedyi = dedyi + dradenij*pmjdWruniy - dedzi = dedzi + dradenij*pmjdWruniz - enddo - - radprop(ifluxx,i) = dedxi - radprop(ifluxy,i) = dedyi - radprop(ifluxz,i) = dedzi + if (mask(i)) then + dedxi = 0. + dedyi = 0. + dedzi = 0. + + rhoi = vari(2,n) + rhoiEU0 = rhoi*EU0(1,i) + + do k = 1,ivar(1,n) + icompact = ivar(2,n) + k + j = ijvar(icompact) + pmjdWrunix = varij2(1,icompact) + pmjdWruniy = varij2(2,icompact) + pmjdWruniz = varij2(3,icompact) + rhoj = varij2(4,icompact) + + ! Calculates the gradient of E (where E=rho*e, and e is xi) + dradenij = rhoj*EU0(1,j) - rhoiEU0 + dedxi = dedxi + dradenij*pmjdWrunix + dedyi = dedyi + dradenij*pmjdWruniy + dedzi = dedzi + dradenij*pmjdWruniz + enddo + + radprop(ifluxx,i) = dedxi + radprop(ifluxy,i) = dedyi + radprop(ifluxz,i) = dedzi + endif enddo !$omp enddo @@ -649,7 +655,7 @@ end subroutine compute_flux ! calculate flux limiter (lambda) and eddington factor !+ !--------------------------------------------------------- -subroutine calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,ierr) +subroutine calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,mask,ierr) use io, only:error use part, only:dust_temp,nucleation use radiation_utils, only:get_rad_R @@ -657,6 +663,7 @@ subroutine calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,i integer, intent(in) :: ivar(:,:),ncompactlocal,npart real, intent(in) :: vari(:,:) real, intent(inout) :: radprop(:,:),EU0(6,npart) + logical, intent(in) :: mask(npart) integer, intent(out) :: ierr integer :: n,i real :: rhoi,gradE1i,opacity,radRi @@ -666,29 +673,31 @@ subroutine calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,i !$omp private(i,n,rhoi,gradE1i,opacity,radRi) & !$omp reduction(max:ierr) do n = 1,ncompactlocal - i = ivar(3,n) - rhoi = vari(2,n) - ! - ! If using diffuse ISM, use Rosseland mean opacity from the frequency - ! dependent opacity when dust temperatures are cold (T_d<100 K). - ! Otherwise use the tabulated grey dust opacities. - ! - opacity = EU0(4,i) - if (dustRT) then - if (dust_temp(i) < Tdust_threshold) opacity = nucleation(idkappa,i) - endif - if (opacity < 0.) then - ierr = max(ierr,ierr_negative_opacity) - call error(label,'Negative opacity',val=opacity) - endif - - if (limit_radiation_flux) then - radRi = get_rad_R(rhoi,EU0(1,i),radprop(ifluxx:ifluxz,i),opacity) - else - radRi = 0. - endif - EU0(5,i) = (2. + radRi ) / (6. + 3.*radRi + radRi**2) ! Levermore & Pomraning's flux limiter (e.g. eq 12, Whitehouse & Bate 2004) - EU0(6,i) = EU0(5,i) + EU0(5,i)**2 * radRi**2 ! e.g., eq 11, Whitehouse & Bate (2004) + i = ivar(3,n) + if (.true.) then + rhoi = vari(2,n) + ! + ! If using diffuse ISM, use Rosseland mean opacity from the frequency + ! dependent opacity when dust temperatures are cold (T_d<100 K). + ! Otherwise use the tabulated grey dust opacities. + ! + opacity = EU0(4,i) + if (dustRT) then + if (dust_temp(i) < Tdust_threshold) opacity = nucleation(idkappa,i) + endif + if (opacity < 0.) then + ierr = max(ierr,ierr_negative_opacity) + call error(label,'Negative opacity',val=opacity) + endif + + if (limit_radiation_flux) then + radRi = get_rad_R(rhoi,EU0(1,i),radprop(ifluxx:ifluxz,i),opacity) + else + radRi = 0. + endif + EU0(5,i) = (2. + radRi ) / (6. + 3.*radRi + radRi**2) ! Levermore & Pomraning's flux limiter (e.g. eq 12, Whitehouse & Bate 2004) + EU0(6,i) = EU0(5,i) + EU0(5,i)**2 * radRi**2 ! e.g., eq 11, Whitehouse & Bate (2004) + endif enddo !$omp enddo @@ -701,11 +710,12 @@ end subroutine calc_lambda_and_eddington !+ !--------------------------------------------------------- subroutine calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax, & - radprop,vari,EU0,varinew,ierr) + radprop,vari,EU0,varinew,mask,ierr) use io, only:error use part, only:dust_temp,nucleation integer, intent(in) :: ivar(:,:),ijvar(:),ncompact,npart,icompactmax real, intent(in) :: vari(:,:),varij(2,icompactmax),EU0(6,npart),radprop(:,:) + logical, intent(in) :: mask(npart) integer, intent(out) :: ierr real, intent(inout) :: varinew(3,npart) integer :: n,i,j,k,icompact @@ -719,57 +729,58 @@ subroutine calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax, & !$omp reduction(max:ierr) do n = 1,ncompact i = ivar(3,n) - ! if (iphase(i) == 0) then - rhoi = vari(2,n) - opacityi = EU0(4,i) - bi = EU0(5,i)/(opacityi*rhoi) - ! - !--NOTE: Needs to do this loop even for boundaryparticles because active - ! boundary particles will need to contribute to the varinew() - ! quantities (i.e. diffusion terms) of particle j due to the way that - ! particle j only finds neighbours inside h_j or non-active particles - ! inside h_i. The varinew() quantities of a boundaryparticle are - ! not used, but its contributions to j are. - ! - !--Initialising counters to zero for this particle - ! - diffusion_numerator = 0. - diffusion_denominator = 0. - ! - !--All the neighbours loop - ! - do k = 1,ivar(1,n) - icompact = ivar(2,n) + k - j = ijvar(icompact) - rhoj = varij(1,icompact) - dWdrlightrhorhom = varij(2,icompact) + if (mask(i)) then + rhoi = vari(2,n) + opacityi = EU0(4,i) + bi = EU0(5,i)/(opacityi*rhoi) ! - !--Set c*lambda/kappa*rho term (radiative diffusion coefficient) for current quantities + !--NOTE: Needs to do this loop even for boundaryparticles because active + ! boundary particles will need to contribute to the varinew() + ! quantities (i.e. diffusion terms) of particle j due to the way that + ! particle j only finds neighbours inside h_j or non-active particles + ! inside h_i. The varinew() quantities of a boundaryparticle are + ! not used, but its contributions to j are. ! - Ej = EU0(1,j) - opacityj = EU0(4,j) - if (dustRT) then - if (dust_temp(i) < Tdust_threshold) opacityi = nucleation(idkappa,i) - if (dust_temp(j) < Tdust_threshold) opacityj = nucleation(idkappa,j) - endif - if ((opacityi <= 0.) .or. (opacityj <= 0.)) then - ierr = max(ierr,ierr_negative_opacity) - call error(label,'Negative or zero opacity',val=min(opacityi,opacityj)) - endif - bj = EU0(5,j)/(opacityj*rhoj) + !--Initialising counters to zero for this particle ! - !--Choose the 'average' diffusion value. The (bi+bj) quantity biased in - ! favour of the particle with the lowest opacity. The other average - ! is that original recommended in Cleary & Monaghan for heat diffusion. - b1 = bi + bj + diffusion_numerator = 0. + diffusion_denominator = 0. ! - !--Diffusion numerator and denominator + !--All the neighbours loop ! - diffusion_numerator = diffusion_numerator - dWdrlightrhorhom*b1*Ej*rhoj - diffusion_denominator = diffusion_denominator + dWdrlightrhorhom*b1*rhoi - enddo - varinew(1,i) = varinew(1,i) + diffusion_numerator - varinew(2,i) = varinew(2,i) + diffusion_denominator + do k = 1,ivar(1,n) + icompact = ivar(2,n) + k + j = ijvar(icompact) + rhoj = varij(1,icompact) + dWdrlightrhorhom = varij(2,icompact) + ! + !--Set c*lambda/kappa*rho term (radiative diffusion coefficient) for current quantities + ! + Ej = EU0(1,j) + opacityj = EU0(4,j) + if (dustRT) then + if (dust_temp(i) < Tdust_threshold) opacityi = nucleation(idkappa,i) + if (dust_temp(j) < Tdust_threshold) opacityj = nucleation(idkappa,j) + endif + ! if ((opacityi <= 0.) .or. (opacityj <= 0.)) then + ! ierr = max(ierr,ierr_negative_opacity) + ! call error(label,'Negative or zero opacity',val=min(opacityi,opacityj)) + ! endif + bj = EU0(5,j)/(opacityj*rhoj) + ! + !--Choose the 'average' diffusion value. The (bi+bj) quantity biased in + ! favour of the particle with the lowest opacity. The other average + ! is that original recommended in Cleary & Monaghan for heat diffusion. + b1 = bi + bj + ! + !--Diffusion numerator and denominator + ! + diffusion_numerator = diffusion_numerator - dWdrlightrhorhom*b1*Ej*rhoj + diffusion_denominator = diffusion_denominator + dWdrlightrhorhom*b1*rhoi + enddo + varinew(1,i) = varinew(1,i) + diffusion_numerator + varinew(2,i) = varinew(2,i) + diffusion_denominator + endif enddo !$omp enddo @@ -783,7 +794,7 @@ end subroutine calc_diffusion_term subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& radprop,rad,origEU,varinew,EU0,& pdvvisc,dvdx,nucleation,dust_temp,eos_vars,drad,fxyzu, & - store_drad,moresweep,maxerrE2,maxerrU2) + mask,store_drad,moresweep,maxerrE2,maxerrU2) use io, only:fatal,error use units, only:get_radconst_code,get_c_code,unit_density use physcon, only:mass_proton_cgs @@ -797,6 +808,7 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& real, intent(out) :: maxerrE2,maxerrU2 logical, intent(in) :: store_drad logical, intent(out):: moresweep + logical, intent(inout):: mask(npart) integer :: i,j,n,ieqtype,ierr logical :: moresweep2,skip_quartic real :: dti,rhoi,diffusion_numerator,diffusion_denominator,gradEi2,gradvPi,rpdiag,rpall @@ -829,249 +841,256 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& main_loop: do n = 1,ncompactlocal i = ivar(3,n) - ! if (iphase(i)==0) then - dti = vari(1,n) - rhoi = vari(2,n) - diffusion_numerator = varinew(1,i) - diffusion_denominator = varinew(2,i) - pres_numerator = pdvvisc(i)/massoftype(igas) ! in phantom pdvvisc->luminosity which is m*du/dt not du/dt - pres_denominator = 0. - Ei = EU0(1,i) - Ui = EU0(2,i) - cvi = EU0(3,i) - opacityi = EU0(4,i) - eddi = EU0(6,i) - ! - !--Radiation pressure... - ! - gradEi2 = dot_product(radprop(ifluxx:ifluxz,i),radprop(ifluxx:ifluxz,i)) + if (mask(i)) then + dti = vari(1,n) + rhoi = vari(2,n) + diffusion_numerator = varinew(1,i) + diffusion_denominator = varinew(2,i) + pres_numerator = pdvvisc(i)/massoftype(igas) ! in phantom pdvvisc->luminosity which is m*du/dt not du/dt + pres_denominator = 0. + Ei = EU0(1,i) + Ui = EU0(2,i) + cvi = EU0(3,i) + opacityi = EU0(4,i) + eddi = EU0(6,i) + ! + !--Radiation pressure... + ! + gradEi2 = dot_product(radprop(ifluxx:ifluxz,i),radprop(ifluxx:ifluxz,i)) - if (gradEi2 < tiny(0.)) then - gradvPi = 0. - else - rpdiag = 0.5*(1.-eddi) ! Diagonal component of Eddington tensor (eq 10, Whitehouse & Bate 2004) - rpall = 0.5*(3.*eddi-1.)/gradEi2 ! n,n-component of Eddington tensor, where n is the direction of grad(E) (or -ve flux) - gradvPi = (((rpdiag+rpall*radprop(ifluxx,i)**2)*dvdx(1,i))+ & - ((rpall*radprop(ifluxx,i)*radprop(ifluxy,i))*dvdx(2,i))+ & - ((rpall*radprop(ifluxx,i)*radprop(ifluxz,i))*dvdx(3,i))+ & - ((rpall*radprop(ifluxy,i)*radprop(ifluxx,i))*dvdx(4,i))+ & - ((rpdiag+rpall*radprop(ifluxy,i)**2)*dvdx(5,i))+ & - ((rpall*radprop(ifluxy,i)*radprop(ifluxz,i))*dvdx(6,i))+ & - ((rpall*radprop(ifluxz,i)*radprop(ifluxx,i))*dvdx(7,i))+ & - ((rpall*radprop(ifluxz,i)*radprop(ifluxy,i))*dvdx(8,i))+ & - ((rpdiag+rpall*radprop(ifluxz,i)**2)*dvdx(9,i))) ! e.g. eq 23, Whitehouse & Bate (2004) - endif + if (gradEi2 < tiny(0.)) then + gradvPi = 0. + else + rpdiag = 0.5*(1.-eddi) ! Diagonal component of Eddington tensor (eq 10, Whitehouse & Bate 2004) + rpall = 0.5*(3.*eddi-1.)/gradEi2 ! n,n-component of Eddington tensor, where n is the direction of grad(E) (or -ve flux) + gradvPi = (((rpdiag+rpall*radprop(ifluxx,i)**2)*dvdx(1,i))+ & + ((rpall*radprop(ifluxx,i)*radprop(ifluxy,i))*dvdx(2,i))+ & + ((rpall*radprop(ifluxx,i)*radprop(ifluxz,i))*dvdx(3,i))+ & + ((rpall*radprop(ifluxy,i)*radprop(ifluxx,i))*dvdx(4,i))+ & + ((rpdiag+rpall*radprop(ifluxy,i)**2)*dvdx(5,i))+ & + ((rpall*radprop(ifluxy,i)*radprop(ifluxz,i))*dvdx(6,i))+ & + ((rpall*radprop(ifluxz,i)*radprop(ifluxx,i))*dvdx(7,i))+ & + ((rpall*radprop(ifluxz,i)*radprop(ifluxy,i))*dvdx(8,i))+ & + ((rpdiag+rpall*radprop(ifluxz,i)**2)*dvdx(9,i))) ! e.g. eq 23, Whitehouse & Bate (2004) + endif - radpresdenom = gradvPi * Ei + radpresdenom = gradvPi * Ei - stellarradiation = 0. ! set to zero - e_planetesimali = 0. - pcoleni = 0. ! specific collision energy from planetesimals + stellarradiation = 0. ! set to zero + e_planetesimali = 0. + pcoleni = 0. ! specific collision energy from planetesimals + ! + !--For idustRT>0, replace the gas-dust coupling term in the u equation + ! by the dust-radiation term, but keep the T_d rather than T_g + ! + if (dustRT) then + radprop(ikappa,i) = get_kappa(iopacity_type,Ui,cvi,rhoi) + dust_tempi = dust_temperature(rad(iradxi,i),Ui,rhoi,dust_kappai,dust_cooling,heatingISRi,dust_gas) + gas_temp = Ui/cvi + mui = eos_vars(imu,i) + xnH2 = rhoi*unit_density/(mui*mass_proton_cgs) ! Mike: Check units + endif - ! - !--For idustRT>0, replace the gas-dust coupling term in the u equation - ! by the dust-radiation term, but keep the T_d rather than T_g - ! - if (dustRT) then - radprop(ikappa,i) = get_kappa(iopacity_type,Ui,cvi,rhoi) - dust_tempi = dust_temperature(rad(iradxi,i),Ui,rhoi,dust_kappai,dust_cooling,heatingISRi,dust_gas) - gas_temp = Ui/cvi - mui = eos_vars(imu,i) - xnH2 = rhoi*unit_density/(mui*mass_proton_cgs) ! Mike: Check units - endif + skip_quartic = .false. + if (dustRT .and. & + ( abs(dust_tempi-(rhoi*EU0(1,i)/a_code)**0.25) > 1. .and. xnH2 < 1.e11/metallicity) ) then + !--For low densities and temperatures, use the form of the equations that + ! includes the gas-dust coupling term. Also explicitly set the gas + ! opacity to zero (i.e. betaval=gammaval=tfour=0). This works well + ! until the gas-dust coupling term gets very large, where upon the + ! convergence fails because even a small difference (<1 K) in the + ! gas and dust temperatures results in a large term. The gas-dust + ! coupling term potentially becomes large for high densities, but + ! a density criterion alone is not sufficient. What we really want + ! to see is that the matter is well coupled with the radiation field + ! already. So if we have high densities AND the difference between + ! the temperatures of the dust and local radiation field is small + ! (<1 K), then we abandon the gas-dust coupling term. + ! + call set_heating_cooling_low_rhoT(i,EU0(1,i),EU0(2,i),origEU(1,i),origEU(2,i),& + EU0(3,i),dti,diffusion_denominator,& + pres_numerator,radpresdenom,rhoi,xnH2,heatingISRi,e_planetesimali,& + metallicity,gas_temp,ieqtype,betaval,betaval_d,gammaval,& + chival,tfour,dust_tempi,gas_dust_val,dustgammaval,gas_dust_cooling,& + cosmic_ray,cooling_line,photoelectric,h2form,dust_heating,dust_term,skip_quartic,U1i,ierr) + if (ierr > 0) then + !$omp critical (moresweepset) + moresweep = .true. + !$omp end critical (moresweepset) + cycle main_loop + endif - skip_quartic = .false. - if (dustRT .and. & - ( abs(dust_tempi-(rhoi*EU0(1,i)/a_code)**0.25) > 1. .and. xnH2 < 1.e11/metallicity) ) then - !--For low densities and temperatures, use the form of the equations that - ! includes the gas-dust coupling term. Also explicitly set the gas - ! opacity to zero (i.e. betaval=gammaval=tfour=0). This works well - ! until the gas-dust coupling term gets very large, where upon the - ! convergence fails because even a small difference (<1 K) in the - ! gas and dust temperatures results in a large term. The gas-dust - ! coupling term potentially becomes large for high densities, but - ! a density criterion alone is not sufficient. What we really want - ! to see is that the matter is well coupled with the radiation field - ! already. So if we have high densities AND the difference between - ! the temperatures of the dust and local radiation field is small - ! (<1 K), then we abandon the gas-dust coupling term. + elseif (dustRT) then + !--Replaces the gas-dust coupling term in the u equation by the dust-radiation + ! term and assumes that T_g=T_d so that the dust-radiation term is + ! actually the gas-radiation term (i.e. uses kappa from opacity tables + ! which is based on the gas temperature, and uses (u/cv) rather than T_d.) + call set_heating_cooling(i,EU0(2,i),radprop(icv,i),rhoi,mui,heatingISRi,metallicity,ieqtype,dust_tempi,& + gas_dust_val,dustgammaval,gas_dust_cooling,& + cosmic_ray,cooling_line,photoelectric,h2form,dust_heating,dust_term) + + else + !--Else, this is the original version of radiative transfer + ! (Whitehouse & Bate 2006), which does not include the + ! diffuse ISM model of Bate (2015). + call turn_heating_cooling_off(ieqtype,dust_tempi,gas_dust_val,dustgammaval,gas_dust_cooling,& + cosmic_ray,cooling_line,photoelectric,h2form,dust_heating,dust_term) + endif + ! + !--Now solve those equations... (these are eqns 22 in Whitehouse, Bate & Monaghan 2005) ! - call set_heating_cooling_low_rhoT(i,EU0(1,i),EU0(2,i),origEU(1,i),origEU(2,i),& - EU0(3,i),dti,diffusion_denominator,& - pres_numerator,radpresdenom,rhoi,xnH2,heatingISRi,e_planetesimali,& - metallicity,gas_temp,ieqtype,betaval,betaval_d,gammaval,& - chival,tfour,dust_tempi,gas_dust_val,dustgammaval,gas_dust_cooling,& - cosmic_ray,cooling_line,photoelectric,h2form,dust_heating,dust_term,skip_quartic,U1i,ierr) - if (ierr > 0) then + Tgas = Ui/cvi + Tgas4 = Tgas**4 + Trad4 = rhoi*Ei/a_code + ck = c_code*opacityi + ack = a_code*ck + + betaval = ck*rhoi*dti + chival = dti*(diffusion_denominator-radpresdenom/Ei)-betaval + gammaval = ack/cvi**4 + tfour = ack*(Trad4 - Tgas4) + u4term = gammaval*dti*(dti*(diffusion_denominator-radpresdenom/Ei) - 1.) + u1term = (chival-1.)*(1.-dti*pres_denominator + dti*gas_dust_val/cvi) & + - betaval*dti*gas_dust_val/cvi + u0term = betaval*(origEU(1,i) - dti*gas_dust_val*dust_tempi + dti*dust_heating) + & + (chival-1.)*(-origEU(2,i) - dti*pres_numerator - dti*e_planetesimali & + - dti*gas_dust_val*dust_tempi - dti*cosmic_ray + dti*cooling_line - dti*photoelectric & + - 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 + !$omp critical(quart) + print *,"ngs ",u4term,u1term,u0term,betaval,chival,gammaval + print *," ",EU0(4,i),rhoi,dti + print *," ",diffusion_denominator,diffusion_numerator + print *," ",pres_denominator,pres_numerator !,uradconst + print *," ",radpresdenom,Ei,Ui + print *," ",c_code,origEU(1,i),origEU(2,i) + !$omp end critical(quart) !$omp critical (moresweepset) moresweep = .true. !$omp end critical (moresweepset) cycle main_loop endif - elseif (dustRT) then - !--Replaces the gas-dust coupling term in the u equation by the dust-radiation - ! term and assumes that T_g=T_d so that the dust-radiation term is - ! actually the gas-radiation term (i.e. uses kappa from opacity tables - ! which is based on the gas temperature, and uses (u/cv) rather than T_d.) - call set_heating_cooling(i,EU0(2,i),radprop(icv,i),rhoi,mui,heatingISRi,metallicity,ieqtype,dust_tempi,& - gas_dust_val,dustgammaval,gas_dust_cooling,& - cosmic_ray,cooling_line,photoelectric,h2form,dust_heating,dust_term) + if (.not. skip_quartic) then + u1term = u1term/u4term + u0term = u0term/u4term + moresweep2 = .false. + call solve_quartic(u1term,u0term,Ui,U1i,moresweep2,ierr) ! U1i is the quartic solution + if (ierr /= 0) then + print*,'Error in solve_quartic' + print*,'i=',i,'u1term=',u1term,'u0term=',u0term,'EU0(2,i)=',Ui,'U1i=',U1i,'moresweep=',moresweep + print*,"info: ",Tgas + print*,"info2: ",u0term,u1term,u4term,gammaval,opacityi,cvi + print*,"info3: ",chival,betaval,dti,rhoi + print*,"info4: ",pres_denominator,origEU(1,i),pres_numerator + print*,"info5: ",diffusion_numerator,stellarradiation,diffusion_denominator + print*,"info6: ",radpresdenom,Ei + print*,"Tgas: ",Tgas," Trad:",Trad4**0.25,' ack*(Tgas^4 - Trad^4): ',tfour + + call fatal('solve_quartic','Fail to solve') + endif - else - !--Else, this is the original version of radiative transfer - ! (Whitehouse & Bate 2006), which does not include the - ! diffuse ISM model of Bate (2015). - call turn_heating_cooling_off(ieqtype,dust_tempi,gas_dust_val,dustgammaval,gas_dust_cooling,& - cosmic_ray,cooling_line,photoelectric,h2form,dust_heating,dust_term) - endif - ! - !--Now solve those equations... (these are eqns 22 in Whitehouse, Bate & Monaghan 2005) - ! - Tgas = Ui/cvi - Tgas4 = Tgas**4 - Trad4 = rhoi*Ei/a_code - ck = c_code*opacityi - ack = a_code*ck - - betaval = ck*rhoi*dti - chival = dti*(diffusion_denominator-radpresdenom/Ei)-betaval - gammaval = ack/cvi**4 - tfour = ack*(Trad4 - Tgas4) - u4term = gammaval*dti*(dti*(diffusion_denominator-radpresdenom/Ei) - 1.) - u1term = (chival-1.)*(1.-dti*pres_denominator + dti*gas_dust_val/cvi) & - - betaval*dti*gas_dust_val/cvi - u0term = betaval*(origEU(1,i) - dti*gas_dust_val*dust_tempi + dti*dust_heating) + & - (chival-1.)*(-origEU(2,i) - dti*pres_numerator - dti*e_planetesimali & - - dti*gas_dust_val*dust_tempi - dti*cosmic_ray + dti*cooling_line - dti*photoelectric & - - 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 - !$omp critical(quart) - print *,"ngs ",u4term,u1term,u0term,betaval,chival,gammaval - print *," ",EU0(4,i),rhoi,dti - print *," ",diffusion_denominator,diffusion_numerator - print *," ",pres_denominator,pres_numerator !,uradconst - print *," ",radpresdenom,Ei,Ui - print *," ",c_code,origEU(1,i),origEU(2,i) - !$omp end critical(quart) - !$omp critical (moresweepset) - moresweep = .true. - !$omp end critical (moresweepset) - cycle main_loop - endif + if (moresweep2) then + !$omp critical (moresweepset) + moresweep = .true. + print*,"info: ",Tgas + print*,"info2: ",u0term,u1term,u4term,gammaval,opacityi,cvi + print*,"info3: ",chival,betaval,dti + print*,"info4: ",pres_denominator,origeu(1,i),pres_numerator + print*,"info5: ",diffusion_numerator,stellarradiation,diffusion_denominator + print*,"info6: ",radpresdenom,Ei + print*,"info7: ",cosmic_ray,heatingisri + print*,"info8: ",cooling_line,photoelectric,h2form + !$omp end critical (moresweepset) + cycle main_loop + endif + endif - if (.not. skip_quartic) then - u1term = u1term/u4term - u0term = u0term/u4term - moresweep2 = .false. - call solve_quartic(u1term,u0term,Ui,U1i,moresweep2,ierr) ! U1i is the quartic solution - if (ierr /= 0) then + E1i = (origEU(1,i) + dti*diffusion_numerator & + + gammaval*dti*U1i**4 & + + dustgammaval*dti & + + dti*gas_dust_val*(U1i/cvi - dust_tempi) & + + dti*dust_heating & + + stellarradiation)/(1.-chival) + dUcomb = pres_numerator + pres_denominator*Ui + tfour & + - gas_dust_cooling + cosmic_ray - cooling_line & + + photoelectric + h2form + e_planetesimali + pcoleni + dEcomb = diffusion_numerator + diffusion_denominator * Ei & + - tfour - radpresdenom + stellarradiation + dust_heating + gas_dust_cooling + ! + !--Tests for negativity + ! + if (U1i <= 0.) then + !$omp critical (moresweepset) + print*, "radiation_implicit: u has gone negative ",i,u1term,u0term,u4term,Ui,U1i,moresweep,ierr + moresweep=.true. + print*, "radiation_implicit: u has gone negative ",i,U1i print*,'Error in solve_quartic' print*,'i=',i,'u1term=',u1term,'u0term=',u0term,'EU0(2,i)=',Ui,'U1i=',U1i,'moresweep=',moresweep print*,"info: ",Tgas print*,"info2: ",u0term,u1term,u4term,gammaval,opacityi,cvi - print*,"info3: ",chival,betaval,dti,rhoi + print*,"info3: ",chival,betaval,dti print*,"info4: ",pres_denominator,origEU(1,i),pres_numerator print*,"info5: ",diffusion_numerator,stellarradiation,diffusion_denominator print*,"info6: ",radpresdenom,Ei - print*,"Tgas: ",Tgas," Trad:",Trad4**0.25,' ack*(Tgas^4 - Trad^4): ',tfour - - call fatal('solve_quartic','Fail to solve') + !$omp end critical (moresweepset) endif - - if (moresweep2) then + if (E1i <= 0.) then !$omp critical (moresweepset) - moresweep = .true. - print*,"info: ",Tgas - print*,"info2: ",u0term,u1term,u4term,gammaval,opacityi,cvi - print*,"info3: ",chival,betaval,dti - print*,"info4: ",pres_denominator,origeu(1,i),pres_numerator - print*,"info5: ",diffusion_numerator,stellarradiation,diffusion_denominator - print*,"info6: ",radpresdenom,Ei - print*,"info7: ",cosmic_ray,heatingisri - print*,"info8: ",cooling_line,photoelectric,h2form + moresweep=.true. + call error(label,'e has gone negative',i) !$omp end critical (moresweepset) - cycle main_loop endif - endif - - E1i = (origEU(1,i) + dti*diffusion_numerator & - + gammaval*dti*U1i**4 & - + dustgammaval*dti & - + dti*gas_dust_val*(U1i/cvi - dust_tempi) & - + dti*dust_heating & - + stellarradiation)/(1.-chival) - dUcomb = pres_numerator + pres_denominator*Ui + tfour & - - gas_dust_cooling + cosmic_ray - cooling_line & - + photoelectric + h2form + e_planetesimali + pcoleni - dEcomb = diffusion_numerator + diffusion_denominator * Ei & - - tfour - radpresdenom + stellarradiation + dust_heating + gas_dust_cooling - ! - !--Tests for negativity - ! - if (U1i <= 0.) then - !$omp critical (moresweepset) - print*, "radiation_implicit: u has gone negative ",i,u1term,u0term,u4term,Ui,U1i,moresweep,ierr - moresweep=.true. - print*, "radiation_implicit: u has gone negative ",i,U1i - print*,'Error in solve_quartic' - print*,'i=',i,'u1term=',u1term,'u0term=',u0term,'EU0(2,i)=',Ui,'U1i=',U1i,'moresweep=',moresweep - print*,"info: ",Tgas - print*,"info2: ",u0term,u1term,u4term,gammaval,opacityi,cvi - print*,"info3: ",chival,betaval,dti - print*,"info4: ",pres_denominator,origEU(1,i),pres_numerator - print*,"info5: ",diffusion_numerator,stellarradiation,diffusion_denominator - print*,"info6: ",radpresdenom,Ei - !$omp end critical (moresweepset) - endif - if (E1i <= 0.) then - !$omp critical (moresweepset) - moresweep=.true. - call error(label,'e has gone negative',i) - !$omp end critical (moresweepset) - endif - ! - ! And the error is... - ! - if (Tgas >= 0.) then - maxerrE2i = abs((Ei - E1i)/E1i) - residualE = 0. - else - maxerrE2i = abs((origEU(1,i) + (dEcomb)*dti - E1i)/E1i) - residualE = origEU(1,i) + (dEcomb)*dti - E1i - endif - maxerrE2 = max(maxerrE2, maxerrE2i) + ! + ! And the error is... + ! + if (Tgas >= 0.) then + maxerrE2i = abs((Ei - E1i)/E1i) + residualE = 0. + else + maxerrE2i = abs((origEU(1,i) + (dEcomb)*dti - E1i)/E1i) + residualE = origEU(1,i) + (dEcomb)*dti - E1i + endif + maxerrE2 = max(maxerrE2, maxerrE2i) - if (Tgas >= 2000.) then - maxerrU2i = abs((Ui - U1i)/U1i) - residualU = 0. - else - maxerrU2old = maxerrU2 - maxerrU2i = abs((origEU(2,i)+(dUcomb)* dti - U1i)/U1i) - residualU = origEU(2,i)+(dUcomb)*dti - U1i - endif - maxerrU2 = max(maxerrU2, maxerrU2i) - ! - !--Copy values - ! - EU0(1,i) = E1i - EU0(2,i) = U1i - EU0(3,i) = get_cv(rhoi,U1i,cv_type) - EU0(4,i) = get_kappa(iopacity_type,U1i,EU0(3,i),rhoi) - - if (store_drad) then ! use this for testing - drad(iradxi,i) = (E1i - origEU(1,i))/dti ! dxi/dt - fxyzu(4,i) = (U1i - origEU(2,i))/dti ! du/dt - endif + if (Tgas >= 2000.) then + maxerrU2i = abs((Ui - U1i)/U1i) + residualU = 0. + else + maxerrU2old = maxerrU2 + maxerrU2i = abs((origEU(2,i)+(dUcomb)* dti - U1i)/U1i) + residualU = origEU(2,i)+(dUcomb)*dti - U1i + endif + maxerrU2 = max(maxerrU2, maxerrU2i) + ! + ! Record convergence of individual particles + ! + if (maxerrE2i < tol_rad .and. maxerrU2i < tol_rad) then + mask(i) = .false. + else + mask(i) = .true. + endif + ! + !--Copy values + ! + EU0(1,i) = E1i + EU0(2,i) = U1i + EU0(3,i) = get_cv(rhoi,U1i,cv_type) + EU0(4,i) = get_kappa(iopacity_type,U1i,EU0(3,i),rhoi) + + if (store_drad) then ! use this for testing + drad(iradxi,i) = (E1i - origEU(1,i))/dti ! dxi/dt + fxyzu(4,i) = (U1i - origEU(2,i))/dti ! du/dt + endif - if (dustRT) then - dust_temp(i) = dust_temperature(rad(iradxi,i),U1i,rhoi,dust_kappai,& - dust_cooling,heatingISRi,dust_gas) - nucleation(idkappa,i) = dust_kappai + if (dustRT) then + dust_temp(i) = dust_temperature(rad(iradxi,i),U1i,rhoi,dust_kappai,& + dust_cooling,heatingISRi,dust_gas) + nucleation(idkappa,i) = dust_kappai + endif endif - enddo main_loop !$omp enddo From 6b196f9a8b3f0d10ebd27b1615a0cfbf94ac98d9 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 17 Jul 2023 18:10:35 +0200 Subject: [PATCH 057/814] (makefiles) fix extensions F90 -> f90 --- build/Makefile | 4 ++-- build/Makefile_setups | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/build/Makefile b/build/Makefile index 3d4d0f7c7..faee485fa 100644 --- a/build/Makefile +++ b/build/Makefile @@ -618,14 +618,14 @@ SRCDUMP= physcon.f90 ${CONFIG} ${SRCKERNEL} utils_omp.F90 io.F90 units.f90 \ utils_dumpfiles.f90 utils_vectors.f90 utils_mathfunc.f90 \ utils_datafiles.f90 utils_filenames.f90 utils_system.f90 utils_tables.f90 datafiles.f90 gitinfo.f90 \ centreofmass.f90 \ - timestep.f90 ${SRCEOS} cullendehnen.f90 dust_formation.F90 \ + timestep.f90 ${SRCEOS} cullendehnen.f90 dust_formation.f90 \ ${SRCGR} ${SRCPOT} \ memory.F90 \ utils_sphNG.f90 \ setup_params.f90 ${SRCFASTMATH} checkoptions.F90 \ viscosity.f90 damping.f90 options.f90 checkconserved.f90 prompting.f90 ${SRCDUST} \ ${SRCREADWRITE_DUMPS} \ - utils_sort.f90 sort_particles.F90 + utils_sort.f90 sort_particles.f90 OBJDUMP1= $(SRCDUMP:.f90=.o) OBJDUMP= $(OBJDUMP1:.F90=.o) diff --git a/build/Makefile_setups b/build/Makefile_setups index a1f3de1ff..86e28b20a 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -757,7 +757,7 @@ ifeq ($(SETUP), dustystar) FPPFLAGS= -DDUST_NUCLEATION -DSTAR SETUPFILE= setup_star.f90 MODFILE= utils_binary.f90 set_binary.f90 moddump_binary.f90 - ANALYSIS= ${SRCNIMHD} utils_summary.o utils_omp.o ptmass.o energies.o analysis_common_envelope.f90 dust_formation.F90 + ANALYSIS= ${SRCNIMHD} utils_summary.o utils_omp.o ptmass.o energies.o analysis_common_envelope.f90 dust_formation.f90 KNOWN_SETUP=yes MAXP=10000000 GRAVITY=yes From 002c5b5b4891ef054cd33a375c8bae5a23bab328 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 17 Jul 2023 18:20:44 +0200 Subject: [PATCH 058/814] (dust_formation) reset dust chemical network properties if they are not valid --- src/main/dust_formation.f90 | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index 25fc703fc..082ff5ca5 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.f90 @@ -42,6 +42,8 @@ module dust_formation real, public :: kappa_gas = 2.d-4 real, public, parameter :: Scrit = 2. ! Critical saturation ratio + real, public :: mass_per_H, eps(nElements) + real, public :: Aw(nElements) = [1.0079, 4.0026, 12.011, 15.9994, 14.0067, 20.17, 28.0855, 32.06, 55.847, 47.867] private @@ -86,9 +88,6 @@ module dust_formation real, parameter :: vfactor = sqrt(kboltz/(2.*pi*atomic_mass_unit*12.01)) !real, parameter :: vfactor = sqrt(kboltz/(8.*pi*atomic_mass_unit*12.01)) - real, public :: mass_per_H, eps(nElements) - real, public :: Aw(nElements) = [1.0079, 4.0026, 12.011, 15.9994, 14.0067, 20.17, 28.0855, 32.06, 55.847, 47.867] - contains subroutine init_nucleation @@ -673,8 +672,8 @@ subroutine write_headeropts_dust_formation(hdr,ierr) ! initial gas composition for dust formation call set_abundances call add_to_rheader(eps,'epsilon',hdr,ierr) ! array - call add_to_rheader(Aw,'Amean',hdr,ierr) ! array - call add_to_rheader(mass_per_H,'mass_per_H',hdr,ierr) ! array + call add_to_rheader(Aw,'Amean',hdr,ierr) ! array + call add_to_rheader(mass_per_H,'mass_per_H',hdr,ierr) ! real end subroutine write_headeropts_dust_formation @@ -687,11 +686,23 @@ subroutine read_headeropts_dust_formation(hdr,ierr) use dump_utils, only:dump_h,extract type(dump_h), intent(in) :: hdr integer, intent(out) :: ierr + real :: dum(nElements) + ierr = 0 - call extract('epsilon',eps(1:nElements),hdr,ierr) ! array - call extract('Amean',Aw(1:nElements),hdr,ierr) ! array - call extract('mass_per_H',mass_per_H,hdr,ierr) ! array + call extract('mass_per_H',mass_per_H,hdr,ierr) ! real + ! it is likely that your dump was generated with an old version of phantom + ! and the chemical properties not stored. restore and save the default values + if (mass_per_H < tiny(0.)) then + print *,'reset dust chemical network properties' + call set_abundances + call extract('epsilon',dum(1:nElements),hdr,ierr) ! array + call extract('Amean',dum(1:nElements),hdr,ierr) ! array + else + call extract('epsilon',eps(1:nElements),hdr,ierr) ! array + call extract('Amean',Aw(1:nElements),hdr,ierr) ! array + endif + end subroutine read_headeropts_dust_formation From 457e341d7f6ee67160d8a58b532344700a9ef72c Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 21 Jul 2023 12:37:39 +1000 Subject: [PATCH 059/814] (rad-implicit) cleaning up --- src/main/radiation_implicit.f90 | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 88679a543..237081080 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -203,7 +203,7 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile !$omp shared(converged,maxerrE2,maxerrU2,maxerrE2last,maxerrU2last,itsmax_rad,moresweep,tol_rad,iverbose,ierr) & !$omp private(t1,tcpu1,its) call fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,& - xyzh,vxyzu,ivar,ijvar,radprop,rad,vari,varij,varij2,EU0,mask) + xyzh,vxyzu,ivar,ijvar,rad,vari,varij,varij2,EU0) !$omp master call do_timing('radarrays',tlast,tcpulast) @@ -228,12 +228,12 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile !$omp master call do_timing('radlambda',t1,tcpu1) !$omp end master - call calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax,radprop,vari,EU0,varinew,mask,ierr) + call calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax,vari,EU0,varinew,mask,ierr) !$omp master call do_timing('raddiff',t1,tcpu1) !$omp end master - call update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& + call update_gas_radiation_energy(ivar,vari,npart,ncompactlocal,& radprop,rad,origEU,varinew,EU0,& pdvvisc,dvdx,nucleation,dust_temp,eos_vars,drad,fxyzu,& mask,implicit_radiation_store_drad,moresweep,maxerrE2,maxerrU2) @@ -415,7 +415,7 @@ end subroutine get_compacted_neighbour_list ! fill arrays !+ !--------------------------------------------------------- -subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,ivar,ijvar,radprop,rad,vari,varij,varij2,EU0,mask) +subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,ivar,ijvar,rad,vari,varij,varij2,EU0) use dim, only:periodic use boundary, only:dxbound,dybound,dzbound use part, only:dust_temp,nucleation,gradh,dvdx @@ -423,9 +423,7 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv use kernel, only:grkern,cnormk integer, intent(in) :: ncompact,ncompactlocal,icompactmax,npart integer, intent(in) :: ivar(:,:),ijvar(:) - logical, intent(in) :: mask(npart) real, intent(in) :: dt,xyzh(:,:),vxyzu(:,:),rad(:,:) - real, intent(inout) :: radprop(:,:) real, intent(out) :: vari(:,:),EU0(6,npart),varij(2,icompactmax),varij2(4,icompactmax) integer :: n,i,j,k,icompact real :: cv_effective,pmi,hi,hi21,hi41,rhoi,dx,dy,dz,rij2,rij,rij1,dr,dti,& @@ -710,11 +708,11 @@ end subroutine calc_lambda_and_eddington !+ !--------------------------------------------------------- subroutine calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax, & - radprop,vari,EU0,varinew,mask,ierr) + vari,EU0,varinew,mask,ierr) use io, only:error use part, only:dust_temp,nucleation integer, intent(in) :: ivar(:,:),ijvar(:),ncompact,npart,icompactmax - real, intent(in) :: vari(:,:),varij(2,icompactmax),EU0(6,npart),radprop(:,:) + real, intent(in) :: vari(:,:),varij(2,icompactmax),EU0(6,npart) logical, intent(in) :: mask(npart) integer, intent(out) :: ierr real, intent(inout) :: varinew(3,npart) @@ -791,7 +789,7 @@ end subroutine calc_diffusion_term ! update gas and radiation energy !+ !--------------------------------------------------------- -subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& +subroutine update_gas_radiation_energy(ivar,vari,npart,ncompactlocal,& radprop,rad,origEU,varinew,EU0,& pdvvisc,dvdx,nucleation,dust_temp,eos_vars,drad,fxyzu, & mask,store_drad,moresweep,maxerrE2,maxerrU2) @@ -799,7 +797,7 @@ subroutine update_gas_radiation_energy(ivar,vari,ncompact,npart,ncompactlocal,& use units, only:get_radconst_code,get_c_code,unit_density use physcon, only:mass_proton_cgs use eos, only:metallicity=>Z_in - integer, intent(in) :: ivar(:,:),ncompact,npart,ncompactlocal + integer, intent(in) :: ivar(:,:),npart,ncompactlocal real, intent(in) :: vari(:,:),varinew(3,npart),rad(:,:),origEU(:,:) real(kind=4), intent(in) :: pdvvisc(:),dvdx(:,:) real, intent(in) :: eos_vars(:,:) From fea011ee1df3732322cd24ebbb2444520f6e223d Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 21 Jul 2023 12:39:01 +1000 Subject: [PATCH 060/814] (rad-implicit) improve memory access in get_compacted_neighbour_list --- src/main/radiation_implicit.f90 | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 237081080..451f48d3d 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -286,7 +286,7 @@ subroutine get_compacted_neighbour_list(xyzh,ivar,ijvar,ncompact,ncompactlocal) use linklist, only:ncells,get_neighbour_list,listneigh,ifirstincell use kdtree, only:inodeparts,inoderange use boundary, only:dxbound,dybound,dzbound - use part, only:iphase,igas,get_partinfo + use part, only:iphase,igas,get_partinfo,isdead_or_accreted use kernel, only:radkern2 use io, only:fatal real, intent(in) :: xyzh(:,:) @@ -296,7 +296,7 @@ subroutine get_compacted_neighbour_list(xyzh,ivar,ijvar,ncompact,ncompactlocal) integer :: icompact_private,icompact,icompactmax,iamtypei,nneigh_trial integer, parameter :: maxcellcache = 10000 integer, save, allocatable :: neighlist(:) - real :: dx,dy,dz,hi21,hj1,rij2,q2i,q2j + real :: dx,dy,dz,xi,yi,zi,hi,hi21,hj1,rij2,q2i,q2j real, save, allocatable :: xyzcache(:,:) !$omp threadprivate(xyzcache,neighlist) logical :: iactivei,iamdusti,iamgasi @@ -315,7 +315,7 @@ subroutine get_compacted_neighbour_list(xyzh,ivar,ijvar,ncompact,ncompactlocal) !$omp shared(ncells,xyzh,inodeparts,inoderange,iphase,dxbound,dybound,dzbound,ifirstincell)& !$omp shared(ivar,ijvar,ncompact,icompact,icompactmax,maxphase,maxp)& !$omp private(icell,i,j,k,n,ip,iactivei,iamgasi,iamdusti,iamtypei,dx,dy,dz,rij2,q2i,q2j)& - !$omp private(hi21,hj1,ncompact_private,icompact_private,nneigh_trial,nneigh) + !$omp private(hi,xi,yi,zi,hi21,hj1,ncompact_private,icompact_private,nneigh_trial,nneigh) over_cells: do icell=1,int(ncells) i = ifirstincell(icell) @@ -343,8 +343,16 @@ subroutine get_compacted_neighbour_list(xyzh,ivar,ijvar,ncompact,ncompactlocal) if (.not.iactivei .or. .not.iamgasi) then ! skip if particle is inactive or not gas cycle over_parts endif + + xi = xyzh(1,i) + yi = xyzh(2,i) + zi = xyzh(3,i) + hi = xyzh(4,i) + if (isdead_or_accreted(hi)) then + cycle over_parts + endif nneigh = 0 - hi21 = 1./xyzh(4,i)**2 + hi21 = 1./hi**2 loop_over_neigh: do n = 1,nneigh_trial @@ -354,14 +362,14 @@ subroutine get_compacted_neighbour_list(xyzh,ivar,ijvar,ncompact,ncompactlocal) if (n <= maxcellcache) then ! positions from cache are already mod boundary - dx = xyzh(1,i) - xyzcache(n,1) - dy = xyzh(2,i) - xyzcache(n,2) - dz = xyzh(3,i) - xyzcache(n,3) + dx = xi - xyzcache(n,1) + dy = yi - xyzcache(n,2) + dz = zi - xyzcache(n,3) hj1 = xyzcache(n,4) else - dx = xyzh(1,i) - xyzh(1,j) - dy = xyzh(2,i) - xyzh(2,j) - dz = xyzh(3,i) - xyzh(3,j) + dx = xi - xyzh(1,j) + dy = yi - xyzh(2,j) + dz = zi - xyzh(3,j) hj1 = 1./xyzh(4,j) endif if (periodic) then From 835571e91d86eef1d0b1c96d62b8bd0f583aa3b9 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 21 Jul 2023 12:41:17 +1000 Subject: [PATCH 061/814] (rad-implicit) remove redundant dv/dx calculation in fill_arrays --- src/main/radiation_implicit.f90 | 118 +++++++++----------------------- 1 file changed, 33 insertions(+), 85 deletions(-) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 451f48d3d..5b0031a52 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -424,9 +424,9 @@ end subroutine get_compacted_neighbour_list !+ !--------------------------------------------------------- subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,ivar,ijvar,rad,vari,varij,varij2,EU0) - use dim, only:periodic + use dim, only:periodic,ind_timesteps use boundary, only:dxbound,dybound,dzbound - use part, only:dust_temp,nucleation,gradh,dvdx + use part, only:dust_temp,nucleation,gradh use units, only:get_c_code use kernel, only:grkern,cnormk integer, intent(in) :: ncompact,ncompactlocal,icompactmax,npart @@ -434,20 +434,18 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv real, intent(in) :: dt,xyzh(:,:),vxyzu(:,:),rad(:,:) real, intent(out) :: vari(:,:),EU0(6,npart),varij(2,icompactmax),varij2(4,icompactmax) integer :: n,i,j,k,icompact - real :: cv_effective,pmi,hi,hi21,hi41,rhoi,dx,dy,dz,rij2,rij,rij1,dr,dti,& - dvxdxi,dvxdyi,dvxdzi,dvydxi,dvydyi,dvydzi,dvzdxi,dvzdyi,dvzdzi,& - pmj,rhoj,hj,hj21,hj41,v2i,vi,v2j,vj,dWi,dWj,dvx,dvy,dvz,rhomean,& - dvdotdr,dv,vmu,dvdWimj,dvdWimi,dvdWjmj,c_code,& - dWidrlightrhorhom,dWjdrlightrhorhom,& - pmjdWrijrhoi,pmjdWrunix,pmjdWruniy,pmjdWruniz,& + real :: pmi,hi,hi21,hi41,rhoi,dx,dy,dz,rij2,rij,rij1,dr,dti,& + pmj,rhoj,hj,hj21,hj41,v2i,vi,v2j,vj,dWi,dWj,rhomean,& + c_code,dWidrlightrhorhom,dWjdrlightrhorhom,& + xi,yi,zi,gradhi,pmjdWrijrhoi,pmjdWrunix,pmjdWruniy,pmjdWruniz,& dust_kappai,dust_cooling,heatingISRi,dust_gas c_code = get_c_code() !$omp do & - !$omp private(n,i,j,k,rhoi,icompact,pmi,dvxdxi,dvxdyi,dvxdzi,dvydxi,dvydyi,dvydzi,dti) & - !$omp private(dvzdxi,dvzdyi,dvzdzi,dx,dy,dz,rij2,rij,rij1,dr,pmj,rhoj,hi,hj,hi21,hj21,hi41,hj41) & - !$omp private(v2i,vi,v2j,vj,dWi,dWj,dvx,dvy,dvz,rhomean,dvdotdr,dv,vmu,dvdWimj,dvdWimi,dvdWjmj) & - !$omp private(dWidrlightrhorhom,pmjdWrijrhoi,dWjdrlightrhorhom,cv_effective) & + !$omp private(n,i,j,k,rhoi,icompact,pmi,dti) & + !$omp private(dx,dy,dz,rij2,rij,rij1,dr,pmj,rhoj,hi,hj,hi21,hj21,hi41,hj41) & + !$omp private(v2i,vi,v2j,vj,dWi,dWj,rhomean) & + !$omp private(xi,yi,zi,gradhi,dWidrlightrhorhom,pmjdWrijrhoi,dWjdrlightrhorhom) & !$omp private(pmjdWrunix,pmjdWruniy,pmjdWruniz,dust_kappai,dust_cooling,heatingISRi,dust_gas) do n = 1,ncompact @@ -455,7 +453,16 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv i = ivar(3,n) if (.true.) then - rhoi = rhoh(xyzh(4,i), massoftype(igas)) + pmi = massoftype(igas) + xi = xyzh(1,i) + yi = xyzh(2,i) + zi = xyzh(3,i) + hi = xyzh(4,i) + hi21 = 1./(hi*hi) + hi41 = hi21*hi21 + rhoi = rhoh(hi, massoftype(igas)) + gradhi = gradh(1,i) + EU0(1,i) = rad(iradxi,i) EU0(2,i) = vxyzu(4,i) EU0(3,i) = get_cv(rhoi,vxyzu(4,i),cv_type) @@ -467,25 +474,6 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv dust_temp(i) = dust_temperature(rad(iradxi,i),vxyzu(4,i),rhoi,dust_kappai,dust_cooling,heatingISRi,dust_gas) nucleation(idkappa,i) = dust_kappai endif - ! - !--Note that CV and Kappa have already been done in ASS - ! - cv_effective = EU0(3,i)/get_1overmu(rhoi,vxyzu(4,i),cv_type) - dvxdxi = 0. - dvxdyi = 0. - dvxdzi = 0. - dvydxi = 0. - dvydyi = 0. - dvydzi = 0. - dvzdxi = 0. - dvzdyi = 0. - dvzdzi = 0. - - pmi = massoftype(igas) - hi = xyzh(4,i) - hi21 = 1./(hi*hi) - hi41 = hi21*hi21 - rhoi = rhoh(xyzh(4,i), massoftype(igas)) do k = 1,ivar(1,n) ! Looping from 1 to nneigh icompact = ivar(2,n) + k @@ -493,22 +481,21 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv ! !--Need to make sure that E and U values are loaded for non-active neighbours ! - rhoj = rhoh(xyzh(4,j), massoftype(igas)) - EU0(1,j) = rad(iradxi,j) - EU0(2,j) = vxyzu(4,j) - EU0(3,j) = get_cv(rhoj,vxyzu(4,j),cv_type) - EU0(4,j) = get_kappa(iopacity_type,vxyzu(4,j),EU0(3,j),rhoj) - ! - !--Note that CV and Kappa have already been done in ASS - ! - cv_effective = EU0(3,j)/get_1overmu(rhoj,vxyzu(4,j),cv_type) + if (ind_timesteps) then + EU0(1,j) = rad(iradxi,j) + EU0(2,j) = vxyzu(4,j) + EU0(3,j) = get_cv(rhoj,vxyzu(4,j),cv_type) + EU0(4,j) = get_kappa(iopacity_type,vxyzu(4,j),EU0(3,j),rhoj) + endif !dti = dt ! !--Calculate other quantities ! - dx = xyzh(1,i) - xyzh(1,j) - dy = xyzh(2,i) - xyzh(2,j) - dz = xyzh(3,i) - xyzh(3,j) + dx = xi - xyzh(1,j) + dy = yi - xyzh(2,j) + dz = zi - xyzh(3,j) + hj = xyzh(4,j) + if (periodic) then if (abs(dx) > 0.5*dxbound) dx = dx - dxbound*SIGN(1.0,dx) if (abs(dy) > 0.5*dybound) dy = dy - dybound*SIGN(1.0,dy) @@ -520,8 +507,8 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv dr = rij pmj = massoftype(igas) + rhoj = rhoh(hj, pmj) - hj = xyzh(4,j) hj21 = 1./(hj*hj) hj41 = hj21*hj21 @@ -531,27 +518,9 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv v2j = rij2*hj21 vj = rij/hj - dWi = grkern(v2i,vi)*hi41*cnormk*gradh(1,i) + dWi = grkern(v2i,vi)*hi41*cnormk*gradhi dWj = grkern(v2j,vj)*hj41*cnormk*gradh(1,j) - dvx = vxyzu(1,i) - vxyzu(1,j) - dvy = vxyzu(2,i) - vxyzu(2,j) - dvz = vxyzu(3,i) - vxyzu(3,j) - - dvdotdr = dvx*dx + dvy*dy + dvz*dz - dv = dvdotdr/dr - - if (dvdotdr > 0.) then - vmu = 0. - else - vmu = dv - endif - - ! Coefficients in radiative flux term in radiation energy density equation (e.g. eq 22 & 25, Whitehouse & Bate 2004) - dvdWimj = pmj*dv*dWi - dvdWimi = pmi*dv*dWi - dvdWjmj = pmj*dv*dWj - ! Coefficients for p(div(v))/rho term in gas energy equation (e.g. eq 26, Whitehouse & Bate 2004) dWidrlightrhorhom = c_code*dWi/dr*pmj/(rhoi*rhoj) dWjdrlightrhorhom = c_code*dWj/dr*pmj/(rhoi*rhoj) @@ -560,18 +529,6 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv pmjdWrunix = pmjdWrijrhoi*dx pmjdWruniy = pmjdWrijrhoi*dy pmjdWruniz = pmjdWrijrhoi*dz - ! - !--Calculates density(i) times the gradient of velocity - ! - dvxdxi = dvxdxi - dvx*pmjdWrunix - dvxdyi = dvxdyi - dvx*pmjdWruniy - dvxdzi = dvxdzi - dvx*pmjdWruniz - dvydxi = dvydxi - dvy*pmjdWrunix - dvydyi = dvydyi - dvy*pmjdWruniy - dvydzi = dvydzi - dvy*pmjdWruniz - dvzdxi = dvzdxi - dvz*pmjdWrunix - dvzdyi = dvzdyi - dvz*pmjdWruniy - dvzdzi = dvzdzi - dvz*pmjdWruniz varij(1,icompact) = rhoj varij(2,icompact) = 0.5*(dWidrlightrhorhom+dWjdrlightrhorhom) @@ -581,15 +538,6 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv varij2(3,icompact) = pmjdWruniz varij2(4,icompact) = rhoj enddo - dvdx(1,i) = real(dvxdxi,kind=kind(dvdx)) ! convert to real*4 explicitly to avoid warnings - dvdx(2,i) = real(dvxdyi,kind=kind(dvdx)) - dvdx(3,i) = real(dvxdzi,kind=kind(dvdx)) - dvdx(4,i) = real(dvydxi,kind=kind(dvdx)) - dvdx(5,i) = real(dvydyi,kind=kind(dvdx)) - dvdx(6,i) = real(dvydzi,kind=kind(dvdx)) - dvdx(7,i) = real(dvzdxi,kind=kind(dvdx)) - dvdx(8,i) = real(dvzdyi,kind=kind(dvdx)) - dvdx(9,i) = real(dvzdzi,kind=kind(dvdx)) vari(1,n) = dti vari(2,n) = rhoi From e785a9c35ec4aab09285041965416f6a45064ef2 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 21 Jul 2023 12:43:47 +1000 Subject: [PATCH 062/814] (rad-implicit) put calculation of lambda and eddington in compute_flux loop --- src/main/radiation_implicit.f90 | 117 ++++++++++++-------------------- src/main/utils_deriv.f90 | 4 +- src/main/utils_timing.f90 | 18 +++-- 3 files changed, 51 insertions(+), 88 deletions(-) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 5b0031a52..a5dee47b7 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -224,10 +224,6 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile !$omp master call do_timing('radflux',t1,tcpu1) !$omp end master - call calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,mask,ierr) - !$omp master - call do_timing('radlambda',t1,tcpu1) - !$omp end master call calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax,vari,EU0,varinew,mask,ierr) !$omp master call do_timing('raddiff',t1,tcpu1) @@ -554,30 +550,37 @@ end subroutine fill_arrays !+ !--------------------------------------------------------- subroutine compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,varinew,radprop,mask) + use io, only:error + use part, only:dust_temp,nucleation + use radiation_utils, only:get_rad_R + use options, only:limit_radiation_flux integer, intent(in) :: ivar(:,:),ijvar(:),ncompact,npart,icompactmax - real, intent(in) :: varij2(4,icompactmax),vari(2,npart),EU0(6,npart) + real, intent(in) :: varij2(4,icompactmax),vari(2,npart) logical, intent(in) :: mask(npart) - real, intent(inout) :: radprop(:,:) + real, intent(inout) :: radprop(:,:),EU0(6,npart) real, intent(out) :: varinew(3,npart) ! we use this parallel loop to set varinew to zero - integer :: i,j,k,n,icompact - real :: rhoi,rhoj,pmjdWrunix,pmjdWruniy,pmjdWruniz,dedxi,dedyi,dedzi,dradenij,rhoiEU0 + integer :: i,j,k,n,icompact,ierr + real :: rhoi,rhoj,pmjdWrunix,pmjdWruniy,pmjdWruniz,dedx(3),dradenij,rhoiEU0 + real :: gradE1i,opacity,radRi,EU01i !$omp do schedule(runtime)& - !$omp private(i,j,k,n,dedxi,dedyi,dedzi,rhoi,rhoj,icompact)& - !$omp private(pmjdWrunix,pmjdWruniy,pmjdWruniz,dradenij) + !$omp private(i,j,k,n,dedx,rhoi,rhoj,icompact)& + !$omp private(pmjdWrunix,pmjdWruniy,pmjdWruniz,dradenij)& + !$omp private(gradE1i,opacity,radRi,EU01i)& + !$omp reduction(max:ierr) do n = 1,ncompact i = ivar(3,n) varinew(1,i) = 0. varinew(2,i) = 0. - !varinew(3,i) = 0. if (mask(i)) then - dedxi = 0. - dedyi = 0. - dedzi = 0. + dedx(1) = 0. + dedx(2) = 0. + dedx(3) = 0. rhoi = vari(2,n) - rhoiEU0 = rhoi*EU0(1,i) + EU01i = EU0(1,i) + rhoiEU0 = rhoi*EU01i do k = 1,ivar(1,n) icompact = ivar(2,n) + k @@ -589,73 +592,37 @@ subroutine compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,va ! Calculates the gradient of E (where E=rho*e, and e is xi) dradenij = rhoj*EU0(1,j) - rhoiEU0 - dedxi = dedxi + dradenij*pmjdWrunix - dedyi = dedyi + dradenij*pmjdWruniy - dedzi = dedzi + dradenij*pmjdWruniz + dedx(1) = dedx(1) + dradenij*pmjdWrunix + dedx(2) = dedx(2) + dradenij*pmjdWruniy + dedx(3) = dedx(3) + dradenij*pmjdWruniz enddo - radprop(ifluxx,i) = dedxi - radprop(ifluxy,i) = dedyi - radprop(ifluxz,i) = dedzi - endif - enddo - !$omp enddo - -end subroutine compute_flux - + radprop(ifluxx,i) = dedx(1) + radprop(ifluxy,i) = dedx(2) + radprop(ifluxz,i) = dedx(3) -!--------------------------------------------------------- -!+ -! calculate flux limiter (lambda) and eddington factor -!+ -!--------------------------------------------------------- -subroutine calc_lambda_and_eddington(ivar,ncompactlocal,npart,vari,EU0,radprop,mask,ierr) - use io, only:error - use part, only:dust_temp,nucleation - use radiation_utils, only:get_rad_R - use options, only:limit_radiation_flux - integer, intent(in) :: ivar(:,:),ncompactlocal,npart - real, intent(in) :: vari(:,:) - real, intent(inout) :: radprop(:,:),EU0(6,npart) - logical, intent(in) :: mask(npart) - integer, intent(out) :: ierr - integer :: n,i - real :: rhoi,gradE1i,opacity,radRi + ! Calculate lambda and eddington + opacity = EU0(4,i) + if (dustRT) then + if (dust_temp(i) < Tdust_threshold) opacity = nucleation(idkappa,i) + endif + if (opacity < 0.) then + ierr = max(ierr,ierr_negative_opacity) + call error(label,'Negative opacity',val=opacity) + endif - ierr = 0 - !$omp do schedule(runtime)& - !$omp private(i,n,rhoi,gradE1i,opacity,radRi) & - !$omp reduction(max:ierr) - do n = 1,ncompactlocal - i = ivar(3,n) - if (.true.) then - rhoi = vari(2,n) - ! - ! If using diffuse ISM, use Rosseland mean opacity from the frequency - ! dependent opacity when dust temperatures are cold (T_d<100 K). - ! Otherwise use the tabulated grey dust opacities. - ! - opacity = EU0(4,i) - if (dustRT) then - if (dust_temp(i) < Tdust_threshold) opacity = nucleation(idkappa,i) - endif - if (opacity < 0.) then - ierr = max(ierr,ierr_negative_opacity) - call error(label,'Negative opacity',val=opacity) - endif - - if (limit_radiation_flux) then - radRi = get_rad_R(rhoi,EU0(1,i),radprop(ifluxx:ifluxz,i),opacity) - else - radRi = 0. - endif - EU0(5,i) = (2. + radRi ) / (6. + 3.*radRi + radRi**2) ! Levermore & Pomraning's flux limiter (e.g. eq 12, Whitehouse & Bate 2004) - EU0(6,i) = EU0(5,i) + EU0(5,i)**2 * radRi**2 ! e.g., eq 11, Whitehouse & Bate (2004) - endif + if (limit_radiation_flux) then + radRi = get_rad_R(rhoi,EU01i,dedx,opacity) + else + radRi = 0. + endif + EU0(5,i) = (2. + radRi ) / (6. + 3.*radRi + radRi**2) ! Levermore & Pomraning's flux limiter (e.g. eq 12, Whitehouse & Bate 2004) + EU0(6,i) = EU0(5,i) + EU0(5,i)**2 * radRi**2 ! e.g., eq 11, Whitehouse & Bate (2004) + endif enddo !$omp enddo -end subroutine calc_lambda_and_eddington +end subroutine compute_flux !--------------------------------------------------------- diff --git a/src/main/utils_deriv.f90 b/src/main/utils_deriv.f90 index c83bbb762..46dc44ae8 100644 --- a/src/main/utils_deriv.f90 +++ b/src/main/utils_deriv.f90 @@ -18,7 +18,7 @@ module derivutils ! use timing, only: timers,itimer_dens,itimer_force,itimer_link,itimer_extf,itimer_balance,itimer_cons2prim,& itimer_radiation,itimer_rad_save,itimer_rad_neighlist,itimer_rad_arrays,itimer_rad_its,& - itimer_rad_flux,itimer_rad_lambda,itimer_rad_diff,itimer_rad_update,itimer_rad_store + itimer_rad_flux,itimer_rad_diff,itimer_rad_update,itimer_rad_store implicit none @@ -69,8 +69,6 @@ subroutine do_timing(label,tlast,tcpulast,start,lunit) itimer = itimer_rad_its case ('radflux') itimer = itimer_rad_flux - case ('radlambda') - itimer = itimer_rad_lambda case ('raddiff') itimer = itimer_rad_diff case ('radupdate') diff --git a/src/main/utils_timing.f90 b/src/main/utils_timing.f90 index 935b90e3d..fc1a6f32c 100644 --- a/src/main/utils_timing.f90 +++ b/src/main/utils_timing.f90 @@ -56,15 +56,14 @@ module timing itimer_rad_arrays = 15, & itimer_rad_its = 16, & itimer_rad_flux = 17, & - itimer_rad_lambda = 18, & - itimer_rad_diff = 19, & - itimer_rad_update = 20, & - itimer_rad_store = 21, & - itimer_cons2prim = 22, & - itimer_extf = 23, & - itimer_ev = 24, & - itimer_io = 25 - integer, public, parameter :: ntimers = 25 ! should be equal to the largest itimer index + itimer_rad_diff = 18, & + itimer_rad_update = 19, & + itimer_rad_store = 20, & + itimer_cons2prim = 21, & + itimer_extf = 22, & + itimer_ev = 23, & + itimer_io = 24 + integer, public, parameter :: ntimers = 24 ! should be equal to the largest itimer index type(timer), public :: timers(ntimers) private @@ -97,7 +96,6 @@ subroutine setup_timers call init_timer(itimer_rad_arrays , 'arrays', itimer_radiation ) call init_timer(itimer_rad_its , 'its', itimer_radiation ) call init_timer(itimer_rad_flux , 'flux', itimer_rad_its ) - call init_timer(itimer_rad_lambda , 'lambda', itimer_rad_its ) call init_timer(itimer_rad_diff , 'diff', itimer_rad_its ) call init_timer(itimer_rad_update , 'update', itimer_rad_its ) call init_timer(itimer_rad_store , 'store', itimer_radiation ) From 49b517cbe2057ab9bd2525cf5a18a78425704524 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 25 Jul 2023 11:24:17 +1000 Subject: [PATCH 063/814] (implicit-radiation) lower tol_rad to pass diffusion test with individual pcle masking --- src/tests/test_radiation.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/test_radiation.f90 b/src/tests/test_radiation.f90 index dc7501c9f..26d8c606b 100644 --- a/src/tests/test_radiation.f90 +++ b/src/tests/test_radiation.f90 @@ -66,7 +66,7 @@ subroutine test_radiation(ntests,npass) if (.not.mpi) then implicit_radiation = .true. - tol_rad = 1.e-5 + tol_rad = 1.e-6 call test_radiation_diffusion(ntests,npass) endif endif From d0cdaf3f6d6e5c3bfa3828c9971ca64a06a272b4 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 25 Jul 2023 11:27:05 +1000 Subject: [PATCH 064/814] (implicit-radiation) remove test for dv/dx given the calculation is same as in density --- src/tests/test_radiation.f90 | 18 ++---------------- 1 file changed, 2 insertions(+), 16 deletions(-) diff --git a/src/tests/test_radiation.f90 b/src/tests/test_radiation.f90 index 26d8c606b..45bd857b5 100644 --- a/src/tests/test_radiation.f90 +++ b/src/tests/test_radiation.f90 @@ -218,7 +218,7 @@ end subroutine test_exchange_terms !+ !--------------------------------------------------------- subroutine test_implicit_matches_explicit(ntests,npass) - use part, only:dvdx,npart,xyzh,vxyzu,dvdx_label,rad,radprop,drad,& + use part, only:npart,xyzh,vxyzu,rad,radprop,drad,& xyzh_label,init_part,radprop_label use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax use options, only:implicit_radiation,tolh @@ -228,12 +228,11 @@ subroutine test_implicit_matches_explicit(ntests,npass) use timestep, only:dtmax use radiation_implicit, only:do_radiation_implicit integer, intent(inout) :: ntests,npass - real(kind=kind(dvdx)), allocatable :: dvdx_explicit(:,:) real(kind=kind(radprop)), allocatable :: flux_explicit(:,:) real :: kappa_code,c_code,xi0,rho0,errmax_e,tol_e,tolh_old,pmassi !,exact(9) integer :: i,j,itry,nerr_e(9),ierr - if (id==master) write(*,"(/,a)") '--> checking implicit routine matches explicit for dvdx/flux terms' + if (id==master) write(*,"(/,a)") '--> checking implicit routine matches explicit for flux terms' implicit_radiation = .false. iverbose = 0 @@ -255,30 +254,17 @@ subroutine test_implicit_matches_explicit(ntests,npass) if (itry==1) then call get_derivs_global() ! twice to get density on neighbours correct - !--allocate and copy dvdx (note: dvdx_explicit = dvdx works - ! but gives compiler warnings so we do this with source=) - allocate(dvdx_explicit, source=dvdx) - !--allocate and copy flux allocate(flux_explicit(3,npart)) flux_explicit = radprop(ifluxx:ifluxz,1:npart) - dvdx = 0. else - dvdx = 0. radprop = 0. call do_radiation_implicit(1.e-24,npart,rad,xyzh,vxyzu,radprop,drad,ierr) endif enddo ! now check that things match - nerr_e = 0 - errmax_e = 0. tol_e = 1.e-15 - do j=1,9 - call checkval(npart,dvdx(j,:),dvdx_explicit(j,:),tol_e,nerr_e(j),dvdx_label(j)) - enddo - call update_test_scores(ntests,nerr_e,npass) - nerr_e = 0 errmax_e = 0. do j=1,3 From 6f367cacd5738bb2fcc15de1c6a87dcb6cd0bc20 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 25 Jul 2023 11:38:34 +1000 Subject: [PATCH 065/814] (radiation-implicit) move memory allocation of neighlist into new module utils_implicit.f90 --- build/Makefile | 2 +- src/main/radiation_implicit.f90 | 17 +++------- src/main/utils_implicit.f90 | 57 +++++++++++++++++++++++++++++++++ 3 files changed, 62 insertions(+), 14 deletions(-) create mode 100644 src/main/utils_implicit.f90 diff --git a/build/Makefile b/build/Makefile index 3d4d0f7c7..532385571 100644 --- a/build/Makefile +++ b/build/Makefile @@ -538,7 +538,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ utils_filenames.f90 utils_summary.F90 ${SRCCHEM} ${SRCDUST} \ mpi_memory.f90 mpi_derivs.F90 mpi_tree.F90 kdtree.F90 linklist_kdtree.F90 utils_healpix.f90 utils_raytracer.f90 \ partinject.F90 utils_inject.f90 dust_formation.f90 ptmass_radiation.f90 ptmass_heating.f90 \ - utils_deriv.f90 radiation_implicit.f90 ${SRCTURB} \ + utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ ${SRCKROME} memory.F90 ${SRCREADWRITE_DUMPS} \ quitdump.f90 ptmass.F90 \ diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index a5dee47b7..f7a4b9790 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -149,21 +149,19 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile use io, only:fatal,error,iverbose,warning use part, only:hfact use part, only:pdvvisc=>luminosity,dvdx,nucleation,dust_temp,eos_vars,drad,iradxi,fxyzu - use physcon, only:pi use kernel, only:radkern use timing, only:get_timings use derivutils, only:do_timing use options, only:implicit_radiation_store_drad + use implicit, only:allocate_memory_implicit,icompactmax,ivar,ijvar,ncompact,ncompactlocal,& + varij,varij2,varinew,vari,mask real, intent(in) :: dt,xyzh(:,:),origEU(:,:) integer, intent(in) :: npart real, intent(inout) :: radprop(:,:),rad(:,:),vxyzu(:,:) logical, intent(out) :: failed,moresweep integer, intent(out) :: nit,ierr real, intent(out) :: errorE,errorU,EU0(6,npart) - integer, allocatable :: ivar(:,:),ijvar(:) - integer :: ncompact,ncompactlocal,icompactmax,nneigh_average,its_global,its - real, allocatable :: vari(:,:),varij(:,:),varij2(:,:),varinew(:,:) - logical, allocatable :: mask(:) + integer :: its_global,its real :: maxerrE2,maxerrU2,maxerrE2last,maxerrU2last real(kind=4) :: tlast,tcpulast,t1,tcpu1 logical :: converged @@ -175,14 +173,7 @@ subroutine do_radiation_onestep(dt,npart,rad,xyzh,vxyzu,radprop,origEU,EU0,faile errorU = 0. ierr = 0 - nneigh_average = int(4./3.*pi*(radkern*hfact)**3) + 1 - icompactmax = int(1.2*10.*nneigh_average*npart) - allocate(ivar(3,npart),stat=ierr) - if (ierr/=0) call fatal('radiation_implicit','cannot allocate memory for ivar') - allocate(ijvar(icompactmax),stat=ierr) - if (ierr/=0) call fatal('radiation_implicit','cannot allocate memory for ijvar') - allocate(vari(2,npart),varij(2,icompactmax),varij2(4,icompactmax),varinew(3,npart),mask(npart),stat=ierr) - if (ierr/=0) call fatal('radiation_implicit','cannot allocate memory for vari, varij, varij2, varinew, mask') + call allocate_memory_implicit(npart,radkern,hfact,ierr) !dtimax = dt/imaxstep call get_compacted_neighbour_list(xyzh,ivar,ijvar,ncompact,ncompactlocal) diff --git a/src/main/utils_implicit.f90 b/src/main/utils_implicit.f90 new file mode 100644 index 000000000..b7f0399ed --- /dev/null +++ b/src/main/utils_implicit.f90 @@ -0,0 +1,57 @@ +!--------------------------------------------------------------------------! +! 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 implicit +! +! Utility routines for implicit radiative diffusion +! +! :References: +! +! :Owner: Mike Lau +! +! :Runtime parameters: None +! +! :Dependencies: +! + implicit none + integer :: ncompact,ncompactlocal,icompactmax,nneigh_average + real, allocatable :: vari(:,:),varij(:,:),varij2(:,:),varinew(:,:) + integer, allocatable :: ivar(:,:),ijvar(:) + logical, allocatable :: mask(:) + logical :: done_allocation = .false. + +contains + +!--------------------------------------------------------- +!+ +! allocate arrays for compacted neighbour lists +!+ +!--------------------------------------------------------- +subroutine allocate_memory_implicit(npart,radkern,hfact,ierr) + use io, only:fatal + use physcon, only:pi + integer, intent(in) :: npart + real, intent(in) :: radkern,hfact + integer, intent(out) :: ierr + + if (done_allocation) then + return + else + nneigh_average = int(4./3.*pi*(radkern*hfact)**3) + 1 + icompactmax = int(1.2*10.*nneigh_average*npart) + allocate(ivar(3,npart),stat=ierr) + if (ierr/=0) call fatal('radiation_implicit','cannot allocate memory for ivar') + allocate(ijvar(icompactmax),stat=ierr) + if (ierr/=0) call fatal('radiation_implicit','cannot allocate memory for ijvar') + allocate(vari(2,npart),varij(2,icompactmax),varij2(4,icompactmax),varinew(3,npart),mask(npart),stat=ierr) + if (ierr/=0) call fatal('radiation_implicit','cannot allocate memory for vari, varij, varij2, varinew, mask') + done_allocation = .true. + endif + +end subroutine allocate_memory_implicit + + +end module implicit From a3a85d558bb76ad0acd4ce2875b671d20789b05a Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 25 Jul 2023 12:46:58 +1000 Subject: [PATCH 066/814] (implicit-radiation) fix truncation error --- src/main/radiation_implicit.f90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index f7a4b9790..8454a17c1 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -820,11 +820,11 @@ subroutine update_gas_radiation_energy(ivar,vari,npart,ncompactlocal,& ! (<1 K), then we abandon the gas-dust coupling term. ! call set_heating_cooling_low_rhoT(i,EU0(1,i),EU0(2,i),origEU(1,i),origEU(2,i),& - EU0(3,i),dti,diffusion_denominator,& - pres_numerator,radpresdenom,rhoi,xnH2,heatingISRi,e_planetesimali,& - metallicity,gas_temp,ieqtype,betaval,betaval_d,gammaval,& - chival,tfour,dust_tempi,gas_dust_val,dustgammaval,gas_dust_cooling,& - cosmic_ray,cooling_line,photoelectric,h2form,dust_heating,dust_term,skip_quartic,U1i,ierr) + EU0(3,i),dti,diffusion_denominator,pres_numerator,radpresdenom,& + rhoi,xnH2,heatingISRi,e_planetesimali,metallicity,gas_temp,ieqtype,& + betaval,betaval_d,gammaval,chival,tfour,dust_tempi,gas_dust_val,& + dustgammaval,gas_dust_cooling,cosmic_ray,cooling_line,photoelectric,& + h2form,dust_heating,dust_term,skip_quartic,U1i,ierr) if (ierr > 0) then !$omp critical (moresweepset) moresweep = .true. From 10b7ca4864ba406dba37f7e111e8d2a6ab2dc25b Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 25 Jul 2023 13:04:38 +1000 Subject: [PATCH 067/814] (implicit-radiation) fix compilation error --- src/main/radiation_implicit.f90 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 8454a17c1..71ff029d9 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -550,15 +550,14 @@ subroutine compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,va logical, intent(in) :: mask(npart) real, intent(inout) :: radprop(:,:),EU0(6,npart) real, intent(out) :: varinew(3,npart) ! we use this parallel loop to set varinew to zero - integer :: i,j,k,n,icompact,ierr + integer :: i,j,k,n,icompact real :: rhoi,rhoj,pmjdWrunix,pmjdWruniy,pmjdWruniz,dedx(3),dradenij,rhoiEU0 real :: gradE1i,opacity,radRi,EU01i !$omp do schedule(runtime)& !$omp private(i,j,k,n,dedx,rhoi,rhoj,icompact)& !$omp private(pmjdWrunix,pmjdWruniy,pmjdWruniz,dradenij)& - !$omp private(gradE1i,opacity,radRi,EU01i)& - !$omp reduction(max:ierr) + !$omp private(gradE1i,opacity,radRi,EU01i) do n = 1,ncompact i = ivar(3,n) @@ -597,10 +596,10 @@ subroutine compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,va if (dustRT) then if (dust_temp(i) < Tdust_threshold) opacity = nucleation(idkappa,i) endif - if (opacity < 0.) then - ierr = max(ierr,ierr_negative_opacity) - call error(label,'Negative opacity',val=opacity) - endif + ! if (opacity < 0.) then + ! ierr = max(ierr,ierr_negative_opacity) + ! call error(label,'Negative opacity',val=opacity) + ! endif if (limit_radiation_flux) then radRi = get_rad_R(rhoi,EU01i,dedx,opacity) From 30b6e2506d13623380cf9728691cc75d2698bd8b Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 27 Jul 2023 13:47:14 +0100 Subject: [PATCH 068/814] minor edit --- src/main/step_leapfrog.F90 | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 1fbc85379..81d7e2085 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -94,7 +94,7 @@ 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 io, only:iprint,fatal,iverbose,id,master,warning - use options, only:iexternalforce,use_dustfrac,implicit_radiation + use options, only:iexternalforce,use_dustfrac,implicit_radiation,icooling 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,& @@ -172,7 +172,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp parallel do default(none) & !$omp shared(npart,xyzh,vxyzu,fxyzu,iphase,hdtsph,store_itype) & - !$omp shared(rad,drad,pxyzu)& + !$omp shared(rad,drad,pxyzu,icooling) & !$omp shared(Bevol,dBevol,dustevol,ddustevol,use_dustfrac) & !$omp shared(dustprop,ddustprop,dustproppred,ufloor) & !$omp shared(ibin,ibin_old,twas,timei) & @@ -197,6 +197,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! if (gr) then pxyzu(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) + elseif (icooling == 8) then + vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) else vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif @@ -308,6 +310,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then ppred(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) + elseif (icooling == 8) then + vpred(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) else vpred(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif @@ -420,7 +424,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp parallel default(none) & !$omp shared(xyzh,vxyzu,vpred,fxyzu,npart,hdtsph,store_itype) & !$omp shared(pxyzu,ppred) & -!$omp shared(Bevol,dBevol,iphase,its) & +!$omp shared(Bevol,dBevol,iphase,its,icooling) & !$omp shared(dustevol,ddustevol,use_dustfrac) & !$omp shared(dustprop,ddustprop,dustproppred) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass,massoftype) & @@ -460,6 +464,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + dti*fxyzu(:,i) + elseif (icooling == 8) then + vxyzu(1:3,i) = vxyzu(1:3,i) + dti*fxyzu(1:3,i) else vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) endif @@ -483,7 +489,11 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) else +<<<<<<< Updated upstream vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) +======= + vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) +>>>>>>> Stashed changes endif !--floor the thermal energy if requested and required @@ -552,7 +562,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (.not.converged .and. npart > 0) then !$omp parallel do default(none)& !$omp private(i) & -!$omp shared(npart,hdtsph)& +!$omp shared(npart,hdtsph,icooling)& !$omp shared(store_itype,vxyzu,fxyzu,vpred,iphase) & !$omp shared(Bevol,dBevol,Bpred,pxyzu,ppred) & !$omp shared(dustprop,ddustprop,dustproppred,use_dustfrac,dustevol,dustpred,ddustevol) & From e7d21dc033eca770b41fb4356e0a0cc7234f2439 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Fri, 28 Jul 2023 12:25:17 +0200 Subject: [PATCH 069/814] reference update --- src/main/utils_healpix.f90 | 2 +- src/main/utils_raytracer.f90 | 2 +- src/utils/analysis_raytracer.f90 | 2 +- src/utils/utils_raytracer_all.f90 | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/utils_healpix.f90 b/src/main/utils_healpix.f90 index 922b7c034..bbad96a3e 100644 --- a/src/main/utils_healpix.f90 +++ b/src/main/utils_healpix.f90 @@ -19,7 +19,7 @@ module healpix ! Mars 2008: i8b same as i4b on machines not supporting 64 bits (NO64BITS flag set) ! Feb 2009: introduce healpix_version ! -! :References: None +! :References: K. M. Górski et al, 2005, ApJ, 622, 759 ! ! :Owner: Lionel Siess ! diff --git a/src/main/utils_raytracer.f90 b/src/main/utils_raytracer.f90 index ee414f1ca..aa1b81eb5 100644 --- a/src/main/utils_raytracer.f90 +++ b/src/main/utils_raytracer.f90 @@ -14,7 +14,7 @@ module raytracer ! ! WARNING: This module has only been tested on phantom wind setup ! -! :References: Esseldeurs M., Siess L. et al, 2023, A&A, in press +! :References: Esseldeurs M., Siess L. et al, 2023, A&A, 674, A122 ! ! :Owner: Lionel Siess ! diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index 69903dae0..e655b06c4 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.f90 @@ -8,7 +8,7 @@ module analysis ! ! Analysis routine which computes optical depths throughout the simulation ! -! :References: Esseldeurs M., Siess L. et al, 2023, A&A, in press +! :References: Esseldeurs M., Siess L. et al, 2023, A&A, 674, A122 ! ! :Owner: Lionel Siess ! diff --git a/src/utils/utils_raytracer_all.f90 b/src/utils/utils_raytracer_all.f90 index 46e4d928c..c6ae3d435 100644 --- a/src/utils/utils_raytracer_all.f90 +++ b/src/utils/utils_raytracer_all.f90 @@ -8,7 +8,7 @@ module raytracer_all ! ! raytracer_all ! -! :References: Esseldeurs M., Siess L. et al, 2023, A&A, in press +! :References: Esseldeurs M., Siess L. et al, 2023, A&A, 674, A122 ! ! :Owner: Lionel Siess ! From 1788ae4727111d338799b7ac860734cdc905eafb Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Tue, 1 Aug 2023 12:46:08 +0200 Subject: [PATCH 070/814] (docs) update docs for wind example --- docs/examples.rst | 1 + docs/wind.rst | 46 ++++++++++++++++++++++++++++++++++++---------- 2 files changed, 37 insertions(+), 10 deletions(-) diff --git a/docs/examples.rst b/docs/examples.rst index 71d34962a..2cf07377f 100644 --- a/docs/examples.rst +++ b/docs/examples.rst @@ -16,3 +16,4 @@ This section contains some examples of physical problems that you can solve with density hierarchicalsystems selfgravity_gravitationalinstability + wind \ No newline at end of file diff --git a/docs/wind.rst b/docs/wind.rst index 40a4153d5..d6a31b739 100644 --- a/docs/wind.rst +++ b/docs/wind.rst @@ -2,7 +2,7 @@ Running a simulation with stellar wind and dust formation ========================================================= -The wind and dust formation algorithms are described in `Siess et al. (2022, in prep)`. +The wind and dust formation algorithms are described in `Siess et al. (2022)`, and algortihms for the radiation field in `Esseldeurs et al. (2023)` If you find a bug, please send me an email at lionel.siess@ulb.be @@ -50,12 +50,13 @@ Content of the .setup file The .setup file contains the stellar properties and sets the mass of the particle (see however ``iwind_resolution``). Each star is considered as a sink particles and its properties, e.g. its luminosity, will be used to calculate the radiation pressure. +Companions can be added using the icompanion_star parameter. Note also that -:: +.. math:: - primary_lum = 4*pi*primary_Reff**2*sigma*primary_Teff**4 + \textrm{primary_lum} = 4\pi\times\textrm{primary_Reff}^2\times\sigma\times\textrm{primary_Teff}^4 so you only need to provide 2 out of these 3 variables. @@ -69,6 +70,9 @@ so you only need to provide 2 out of these 3 variables. Content of the .in file ----------------------- +Options controlling particle injection +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + :: # options controlling particle injection @@ -83,7 +87,7 @@ Content of the .in file iboundary_spheres = 5 ! number of boundary spheres (integer) outer_boundary = 50. ! delete gas particles outside this radius (au) -Here’s a brief description of each of them (remember that technical details can be found in `Siess et al. (in prep) +Here’s a brief description of each of them (remember that technical details can be found in `Siess et al. (2023)` :: @@ -150,6 +154,10 @@ set the number of shells that serve as inner boundary condition for the wind To limit the number of particles, delete from the memory the particles that go beyond ``outer_boundary`` (in astronomical unit). This option is slightly different from ``rkill`` where in this case the particles are declared dead and remained allocated. + +Options controlling dust +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + :: # options controlling dust @@ -175,12 +183,17 @@ default gas opacity. Only activated if ``idust_opacity > 0`` set the C/O ratio of the ejected wind material. For the moment only C-rich chemistry (C/O > 1) is implemented. Option only available with ``idust_opacity = 2`` + +Options controlling radiation pressure from sink particles +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + :: # options controling radiation pressure from sink particles isink_radiation = 3 ! sink radiation pressure method (0=off,1=alpha,2=dust,3=alpha+dust) alpha_rad = 1.000 ! fraction of the gravitational acceleration imparted to the gas - iget_tdust = 1 ! dust temperature (0:Tdust=Tgas 1:T(r) 2:Lucy (devel) + iget_tdust = 1 ! dust temperature (0:Tdust=Tgas 1:T(r) 2:Flux dilution 3:Lucy 4:MCfost) + iray_resolution = -1 ! set the number of rays to 12*4**iray_resolution (deactivated if <0) tdust_exp = 0.5 ! exponent of the dust temperature profile :: @@ -189,10 +202,12 @@ set the C/O ratio of the ejected wind material. For the moment only C-rich chemi set how radiation pressure is accounted for. The star's effective gravity is given by - g = Gm/r**2 *(1-alpha_rad-Gamma) +.. math:: + + g_\mathrm{eff} = \frac{Gm}{r^2} \times (1-\alpha_\mathrm{rad}-\Gamma) alpha is an ad-hoc parameter that allows the launching of the wind in case of a cool wind for example when dust is not accounted for. -Gamma = is the Eddington factor that depends on the dust opacity. gamma is therefore <> 0 only when nucleation is activated (``idust_opacity = 2``) +Gamma is the Eddington factor that depends on the dust opacity. gamma is therefore <> 0 only when dust is activated (``idust_opacity > 0``) :: @@ -202,9 +217,17 @@ parameter entering in the above equation for the effective gravity :: - iget_tdust = 1 ! dust temperature (0:Tdust=Tgas 1:T(r) 2:Lucy (devel)) + iget_tdust = 1 ! dust temperature (0:Tdust=Tgas 1:T(r) 2:Flux dilution 3:Lucy 4:MCfost) -defines how the dust temperature is calculated. By default one assumes Tdust = Tgas but option (1, under development!) should be available soon. +defines how the dust temperature is calculated. By default one assumes Tdust = Tgas but other options are availabe as well. +Options 1-3 use analytical prescriptions, and option 4 uses full 3D RT using the MCfost code (under development!) + +:: + + iray_resolution = -1 ! set the number of rays to 12*4**iray_resolution (deactivated if <0) + +If ``iget_tdust = 1-3``, the dust temperature profile is then given by an analytical prescription. +In these prescriptions (see `Esseldeurs et al. (2023)`), there is directional dependance, where the resolution of this directional dependance is set by iray_resolution. :: @@ -212,9 +235,12 @@ defines how the dust temperature is calculated. By default one assumes Tdust = T If ``iget_tdust = 1``, the dust temperature profile is then given by - Tdust(r) = T_star*(R_star/r)**tdust_exp +.. math:: + + T_\mathrm{dust}(r) = T_\mathrm{star}*(R_\mathrm{star}/r)^\textrm{tdust_exp} where T_star and R_star are the stellar (effective) temperature and radius as defined in the .setup file + **Have fun :)** From 092fd081095eb12f7e885594d5799333fa62a0ef Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 2 Aug 2023 02:27:25 +1000 Subject: [PATCH 071/814] (docs) added disc example + updated star --- docs/disc.rst | 268 ++++++++++++++++++++++++++++++++++++++++++++++ docs/examples.rst | 3 +- docs/star.rst | 89 ++++++--------- 3 files changed, 304 insertions(+), 56 deletions(-) create mode 100644 docs/disc.rst diff --git a/docs/disc.rst b/docs/disc.rst new file mode 100644 index 000000000..1af44b729 --- /dev/null +++ b/docs/disc.rst @@ -0,0 +1,268 @@ +Protoplanetary discs +============================================ + +We consider the following examples below: + +1. Circumbinary disc +2. Flyby interaction of star with protoplanetary disc +3. Protoplanetary disc with dust, gas and planets +4. Self-gravitating disc + +Circumbinary disc +------------------ + +make a new directory and write a local Makefile +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Make sure your directory is NOT a subdirectory of the code:: + + $ mkdir -p ~/runs/mydisc + $ cd ~/runs/mydisc + $ ~/phantom/scripts/writemake.sh disc > Makefile + +compile phantom and phantomsetup +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +:: + + $ make + $ make setup + $ ls + Makefile phantom* phantomsetup* + +run phantomsetup +~~~~~~~~~~~~~~~~ + +The setup procedure asks some basic questions to get the structure of +the .setup file correct. Answer 2 for the number of stars:: + + ./phantomsetup disc + + ----------------------------------------------------------------- + + Welcome to the New Disc Setup + + ----------------------------------------------------------------- + disc.setup not found: using interactive setup + + =========================== + +++ CENTRAL OBJECT(S) +++ + =========================== + Do you want to use sink particles or an external potential? + 0=potential + 1=sinks + ([0:1], default=1): + How many sinks? ([1:], default=1): 2 + Do you want the binary orbit to be bound (elliptic) or unbound (parabolic/ hyperbolic) [flyby]? + 0=bound + 1=unbound + ([0:1], default=0): + + ================= + +++ DISC(S) +++ + ================= + Do you want a circumbinary disc? (default=yes): + Do you want a circumprimary disc? (default=no): + Do you want a circumsecondary disc? (default=no): + How do you want to set the gas disc mass? + 0=total disc mass + 1=mass within annulus + 2=surface density normalisation + 3=surface density at reference radius + 4=minimum Toomre Q + ([0:4], default=0): + Do you want to exponentially taper the outer gas disc profile? (default=no): + Do you want to warp the disc? (default=no): + + ================= + +++ PLANETS +++ + ================= + How many planets? ([0:9], default=0): + + ================ + +++ OUTPUT +++ + ================ + Enter time between dumps as fraction of binary period ([0.000:], default=0.1000): + Enter number of orbits to simulate ([0:], default=100): + + writing setup options file disc.setup + + >>> please edit disc.setup to set parameters for your problem then rerun phantomsetup <<< + +After answering the questions, this will create a file called sim.setup which contains setup options. Open this file in your favourite text editor to proceed... + +edit the .setup file and rerun phantomsetup +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +After editing the .setup file, run phantomsetup again:: + + ./phantomsetup disc + +You should see output along the lines of:: + + reading setup options from disc.setup + opening database from disc.setup with 38 entries + + writing setup options file disc.setup + + Central objects represented by two sinks + Primary mass: 1.00 solarm + Binary mass ratio: 0.200 + Accretion Radius 1: 1.00 au + Accretion Radius 2: 0.500 au + + ---------- binary parameters ----------- + primary mass : 1.00000 + secondary mass : 0.200000 + mass ratio m2/m1 : 0.200000 + reduced mass : 0.166667 + ... + setting ieos=3 for locally isothermal disc around origin + dust + + ... + # gas disc parameters - this file is NOT read by setup + R_in = 25. ! inner disc boundary + R_ref = 25. ! reference radius + R_out = 125. ! outer disc boundary + + ... + --------> TIME = 0.000 : full dump written to file disc_00000.tmp <-------- + + input file disc.in written successfully. + To start the calculation, use: + + ./phantom disc.in + +The above procedure prints a .discparams file (in the above example would be +called disc.discparams) that contains some of the parameters used to +initialise the disc setup. + +For a circumbinary disc the equation of state is set to a vertically isothermal equation of state (ieos=3) where the radius is taken with respect to *the coordinate origin*. See :doc:`Equations of state available in Phantom ` + +check the .in file and proceed to run phantom +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +:: + + ./phantom disc.in + + +Flyby interaction of star with protoplanetary disc +-------------------------------------------------- +The procedure for a flyby interaction is as above but answering the questions differently:: + + ./phantomsetup flyby + + How many sinks? ([1:], default=1): 2 + Do you want the binary orbit to be bound (elliptic) or unbound (parabolic/hyperbolic) [flyby]? + 0=bound + 1=unbound + ([0:1], default=0): 1 + + ================= + +++ DISC(S) +++ + ================= + Do you want a circumprimary disc? (default=yes): yes + Do you want a circumsecondary disc? (default=no): no + +which produces:: + + writing setup options file flyby.setup + + Central object represented by a sink at the system origin with a perturber sink + Primary mass: 1.00 solarm + Perturber mass: 1.00 solarm + Accretion Radius 1: 1.00 au + Accretion Radius 2: 1.00 au + + ---------- flyby parameters ----------- + primary mass : 1.00 + secondary mass : 1.00 + mass ratio : 1.00 + +For a circumprimary disc the equation of state is set to ieos=6, such that the radius is taken with respect to the first sink particle in the simulation. See :doc:`Equations of state available in Phantom ` + +The Farris et al. (2014) equation of state (ieos=14 for a binary or ieos=13 if there are more than two stars) is also useful for a flyby simulation if one does not want to have excessively cold material around the secondary + + +Protoplanetary disc with embedded planets +----------------------------------------------- +To add planets to a protoplanetary disc simulation, simply amend the line specifying the number of planets you want in the disc:: + + # set planets + nplanets = 3 ! number of planets + +and re-run phantomsetup, which will add the missing parameters to the .setup file:: + + ./phantomsetup disc + +after editing the .setup file, proceed to run phantomsetup again:: + + ./phantomsetup disc + +and finally proceed to run phantom:: + + ./phantom disc.in + +Protoplanetary disc with dust, gas and planets +----------------------------------------------- + +compile phantom and phantomsetup with SETUP=dustydisc +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To add dust you just need to compile with DUST=yes. Rather than having to remember to type 'make DUST=yes' and 'make setup DUST=yes' it's easier to use +the pre-cooked setup configuration *dustydisc* for this:: + + ~/phantom/scripts/writemake.sh dustydisc > Makefile + make setup + make + +run phantomsetup and decide which dust method to use +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The default is to add a single species of dust as a separate set of SPH particles:: + + $ ./phantomsetup disc + + ... + ============== + +++ DUST +++ + ============== + Which dust method do you want? (1=one fluid,2=two fluid,3=Hybrid) ([1:3], default=2): + Enter total dust to gas ratio ([0.000:], default=0.1000E-01): + How many large grain sizes do you want? ([1:11], default=1): + How do you want to set the dust density profile? + 0=equal to the gas + 1=custom + 2=equal to the gas, but with unique cutoffs + ([0:2], default=0): + +setup the desired grain size distribution for multigrain simulations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simplest method for simulating a range of grain sizes is to use +the dust-as-mixture method, where up to 11 grain sizes are allowed by default, simply edit the .setup file as follows:: + + # options for dust + dust_method = 1 ! dust method (1=one fluid,2=two fluid,3=Hybrid) + dust_to_gas = 0.010 ! dust to gas ratio + ndusttypesinp = 11 ! number of grain sizes + ilimitdustfluxinp = T ! limit dust diffusion using Ballabio et al. (2018) + igrainsize = 0 ! grain size distribution (0=log- space,1=manually) + igrainsizelog = 0 ! select parameters to fix (0=smin,smax|1=s1,sN|2=s1,logds|3=sN,logds|4=s1,sN,logds) + smincgs = 1.000E-04 ! min grain size (in cm) + smaxcgs = 1.000 ! max grain size (in cm) + sindex = 3.500 ! grain size power-law index (e.g. MRN = 3.5) + igraindens = 0 ! grain density input (0=equal,1=manually) + graindensinp = 3.000 ! intrinsic grain density (in g/cm^3) + isetdust = 0 ! how to set dust density profile (0=equal to gas,1=custom,2=equal to gas with cutoffs) + +then run phantomsetup again:: + + $ ./phantomsetup disc + +The 'limit dust diffusion' makes the simulation inaccurate for the very largest grains but ensures that the simulations do not become prohibitively slow by ensuring that decoupled dust species do not control the simulation timestep. If you want to simulate such species accurately and cheaply you should add these species using separate sets of dust particles. + +check the .in file and proceed to run phantom +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Assuming setup has completed correctly, you can run phantom as previously:: + + $ ./phantom disc.in diff --git a/docs/examples.rst b/docs/examples.rst index 71d34962a..d0db723b1 100644 --- a/docs/examples.rst +++ b/docs/examples.rst @@ -8,9 +8,10 @@ This section contains some examples of physical problems that you can solve with :caption: Contents: mdot - softstar + disc binary star + softstar dustsettle dustgrowth density diff --git a/docs/star.rst b/docs/star.rst index 41c85c3ff..978bf81b4 100644 --- a/docs/star.rst +++ b/docs/star.rst @@ -5,10 +5,10 @@ Setting up and relaxing a star ------------------------------ First, follow the usual procedure for initiating a new simulation with -phantom. We’ll use the “polytrope” setup, but you can also use the -“star” or “neutronstar” configurations (the first two use self-gravity -for the star, the last one uses an external potential). For TDEs use -“tde”. That is: +phantom. We’ll use the “star” setup, but you can also use the +“polytrope” or “neutronstar” configurations (the first two use self-gravity +for the star, the last one uses an external potential). For tidal disruption +events in general relativity use“grtde”. That is: make a new directory and write a local Makefile ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -38,22 +38,22 @@ run phantomsetup star.setup not found: using interactive setup - 1) Uniform density profile - 2) Polytrope + 1) Uniform density profile + 2) Polytrope 3) Density vs r from ascii file - 4) KEPLER star from file - 5) MESA star from file - 6) Piecewise polytrope - 7) Evrard collapse + 4) KEPLER star from file + 5) MESA star from file + 6) Piecewise polytrope + 7) Evrard collapse Enter which density profile to use ([1:7], default=1): 2 Setting up Polytrope - Enter mass unit (e.g. solarm,jupiterm,earthm) (blank="blank",default="solarm"): - Enter distance unit (e.g. au,pc,kpc,0.1pc) (blank="blank",default="solarr"): - Enter the approximate number of particles in the sphere ([0:], default=100000): - Enter the desired EoS for setup (default=2): - Enter gamma (adiabatic index) ([1.000:7.000], default=1.667): - Enter the mass of the star (code units) ([0.000:], default=1.000): - Enter the radius of the star (code units) ([0.000:], default=1.000): + Enter mass unit (e.g. solarm,jupiterm,earthm) (blank="blank",default="solarm"): + Enter distance unit (e.g. au,pc,kpc,0.1pc) (blank="blank",default="solarr"): + Enter the approximate number of particles in the sphere ([0:], default=100000): + Enter the desired EoS for setup (default=2): + Enter gamma (adiabatic index) ([1.000:7.000], default=1.667): + Enter the mass of the star (code units) ([0.000:], default=1.000): + Enter the radius of the star (code units) ([0.000:], default=1.000): Relax star automatically during setup? (default=no): y Writing star.setup STOP please check and edit .setup file and rerun phantomsetup @@ -72,10 +72,10 @@ Open the star.setup file and make sure the parameter “relax_star” to True:: Then run phantomsetup:: ./phantomsetup star.setup - + Which will generate a sequence of snapshots of the relaxation process:: - RELAX-A-STAR-O-MATIC: Etherm: 0.499 Epot: -0.854 R*: 1.00 + RELAX-A-STAR-O-MATIC: Etherm: 0.499 Epot: -0.854 R*: 1.00 WILL stop WHEN: dens error < 1.00% AND Ekin/Epot < 1.000E-07 OR Iter=0 --------> TIME = 0.000 : full dump written to file relax_00000 <-------- @@ -98,7 +98,7 @@ Once complete, you should obtain a relaxed initial conditions snapshot with the input file poly.in written successfully. - To start the calculation, use: + To start the calculation, use: ./phantom star.in @@ -121,21 +121,15 @@ check the output Putting the star on an orbit for a tidal disruption event --------------------------------------------------------- -If you used the “tde” setup then simply compile moddump: - -:: +If you used the “tde” or "grtde" setup then simply compile :doc:`moddump `:: $ make moddump -otherwise you need to specify the tidal moddump file - -:: +otherwise you need to specify the tidal moddump file:: $ make moddump MODFILE=moddump_tidal.f90 -Then run moddump on your relaxed star - -:: +Then run moddump on your relaxed star:: $ ./phantommoddump star_00000 tde 0.0 ... @@ -146,9 +140,7 @@ Then run moddump on your relaxed star When you first run this, a “tde.tdeparams” file will be created. Edit this to set the star on your desired orbit, and then rerun -phantommoddump. - -:: +phantommoddump:: # parameters file for a TDE phantommodump beta = 1.000 ! penetration factor @@ -159,9 +151,7 @@ phantommoddump. phi = 0.000 ! stellar rotation with respect to y-axis (in degrees) r0 = 490. ! starting distance -After this you can simply run phantom - -:: +After this you can simply run phantom:: $ ./phantom tde.in @@ -173,18 +163,14 @@ compile phantommoddump The module used to compile this utility is specified using MODFILE= in phantom/build/Makefile. The default for the “polytrope” setup is -currently moddump_spheres.f90 - -:: +currently moddump_spheres.f90:: MODFILE=moddump_spheres.f90 Change this to moddump_default.f90. You can do this temporarily on the -command line by compiling phantommoddump as follows: +command line by compiling phantommoddump as follows:: -:: - - $ make moddump MODFILE=moddump_default.f90 MHD=yes + make moddump MODFILE=moddump_default.f90 MHD=yes run phantommoddump ~~~~~~~~~~~~~~~~~~ @@ -192,25 +178,19 @@ run phantommoddump :: $ ./phantommoddump - PhantomSPH: (c) 2007-2017 The Authors + PhantomSPH: (c) 2007-2023 The Authors Usage: moddump dumpfilein dumpfileout [time] [outformat] -in our case we want: - -:: +in our case we want:: ./phantommoddump star_00010 magstar_00000 -which will give some errors: - -:: +which will give some errors:: ERROR! MHD arrays not found in Phantom dump file: got 0 -but then prompt you to add magnetic fields: - -:: +but then prompt you to add magnetic fields:: add/reset magnetic fields? (default=no): yes @@ -220,6 +200,5 @@ routine. now implement something decent in src/setup/set_Bfield.f90 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -you can either implement a general magnetic field setup in this routine, -or you can just make a new moddump module that sets up the magnetic -field in a custom way. +you can either use the pre-cooked magnetic field setups in this routine, +or you can just make a new :doc:`moddump ` module that sets up the magnetic field in a custom way. From 96e460f45c57269a37365728ad540d164ef542a5 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 2 Aug 2023 02:37:19 +1000 Subject: [PATCH 072/814] Update disc.rst [skip ci] --- docs/disc.rst | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/docs/disc.rst b/docs/disc.rst index 1af44b729..e64c67f58 100644 --- a/docs/disc.rst +++ b/docs/disc.rst @@ -89,7 +89,7 @@ the .setup file correct. Answer 2 for the number of stars:: >>> please edit disc.setup to set parameters for your problem then rerun phantomsetup <<< -After answering the questions, this will create a file called sim.setup which contains setup options. Open this file in your favourite text editor to proceed... +After answering the questions, this will create a file called sim.setup which contains setup options. Open this file in your favourite text editor to proceed... edit the .setup file and rerun phantomsetup ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -138,7 +138,7 @@ The above procedure prints a .discparams file (in the above example would be called disc.discparams) that contains some of the parameters used to initialise the disc setup. -For a circumbinary disc the equation of state is set to a vertically isothermal equation of state (ieos=3) where the radius is taken with respect to *the coordinate origin*. See :doc:`Equations of state available in Phantom ` +For a circumbinary disc the equation of state is set to a vertically isothermal equation of state (ieos=3) where the radius is taken with respect to *the coordinate origin*. See :doc:`Equations of state available in Phantom ` check the .in file and proceed to run phantom ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -181,9 +181,9 @@ which produces:: secondary mass : 1.00 mass ratio : 1.00 -For a circumprimary disc the equation of state is set to ieos=6, such that the radius is taken with respect to the first sink particle in the simulation. See :doc:`Equations of state available in Phantom ` +For a circumprimary disc the equation of state is set to ieos=6, such that the radius is taken with respect to the first sink particle in the simulation. See :doc:`Equations of state available in Phantom ` -The Farris et al. (2014) equation of state (ieos=14 for a binary or ieos=13 if there are more than two stars) is also useful for a flyby simulation if one does not want to have excessively cold material around the secondary +The Farris et al. (2014) :doc:`equation of state ` (ieos=14 for a binary or ieos=13 if there are more than two stars) is also useful for a flyby simulation if one does not want to have excessively cold material around the secondary Protoplanetary disc with embedded planets From ddc9a7ed5e7b36fc3a7b67852ab97e7156508402 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 1 Aug 2023 14:38:46 -0400 Subject: [PATCH 073/814] (build) fix issues with SYSTEM=rusty --- build/Makefile_defaults_ifort | 2 +- build/Makefile_systems | 9 ++++----- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/build/Makefile_defaults_ifort b/build/Makefile_defaults_ifort index 6a63367b4..62dfc5299 100644 --- a/build/Makefile_defaults_ifort +++ b/build/Makefile_defaults_ifort @@ -14,7 +14,7 @@ LIBCXX = -cxxlib KNOWN_SYSTEM=yes # for ifort version 18+ -openmp flag is obsolete -IFORT_VERSION_MAJOR=${shell ifort -v 2>&1 | cut -d' ' -f 3 | cut -d'.' -f 1} +IFORT_VERSION_MAJOR=${shell ifort -v 2>&1 | head -1 | cut -d' ' -f 3 | cut -d'.' -f 1} ifeq ($(shell [ $(IFORT_VERSION_MAJOR) -gt 17 ] && echo true),true) OMPFLAGS= -qopenmp else diff --git a/build/Makefile_systems b/build/Makefile_systems index c603407eb..c5d648787 100644 --- a/build/Makefile_systems +++ b/build/Makefile_systems @@ -113,11 +113,10 @@ endif ifeq ($(SYSTEM), rusty) # Flatiron CCA rusty cluster rome node, AMD EPYC 7742 include Makefile_defaults_ifort - FFLAGS= -Ofast -mcmodel=medium -march=znver2 + OMPFLAGS=-qopenmp NOMP=64 - QSYS = slurm - QNAME='rome' - QPARTITION='cca' + QSYS=slurm + QPARTITION='gen' WALLTIME='168:00:00' endif @@ -128,7 +127,7 @@ ifeq ($(SYSTEM), ipopeyearch) NOMP=64 QSYS = slurm QNAME='icelake' - QPARTITION='cca' + QPARTITION='gen' WALLTIME='168:00:00' endif From ffdf00949642452d5e070221d2062aa165fc483c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 2 Aug 2023 05:12:24 +1000 Subject: [PATCH 074/814] (docs) added getting started docs for Flatiron cluster [skip ci] --- docs/flatiron.rst | 167 +++++++++++++++++++++++++++++++++++++++ docs/getting-started.rst | 1 + 2 files changed, 168 insertions(+) create mode 100644 docs/flatiron.rst diff --git a/docs/flatiron.rst b/docs/flatiron.rst new file mode 100644 index 000000000..1aa0c3c50 --- /dev/null +++ b/docs/flatiron.rst @@ -0,0 +1,167 @@ +Getting started on Rusty (Flatiron cluster) +=========================================== + +See also general instructions for :doc:`running phantom on a remote cluster `. + +We assume you already have a Flatiron username and account + +First time you log in +--------------------- + +Make sure you log in with the -Y flag to enable X-Windows forwarding:: + + $ ssh -Y -p 61022 @gateway.flatironinstitute.org + $ ssh -Y rusty + +show available software:: + + $ module avail + +load intel compilers and splash:: + + $ module load intel-oneapi-compilers/2023.0.0 + $ module load splash/3.8.3 + +Get phantom +~~~~~~~~~~~ + +Clone a copy of phantom into your home directory:: + + $ git clone https://github.com/danieljprice/phantom.git + +Set your username and email address +----------------------------------- + +Ensure that your name and email address are set, as follows: + +:: + + cd phantom + git config --global user.name "Joe Bloggs" + git config --global user.email "joe.bloggs@monash.edu" + +Please use your full name in the format above, as this is what appears +in the commit logs (and in the AUTHORS file). + +edit your .bashrc file +---------------------- + +I put the “module load” commands in a file called ~/.modules which +contains the modules I want every time I log in. For example:: + + $ cat .modules + module load intel-oneapi-compilers/2023.0.0 + +Then, add the following lines to your ~/.bashrc:: + + source ~/.modules + export SYSTEM=rusty + ulimit -s unlimited + export OMP_STACKSIZE=512M + export OMP_SCHEDULE=dynamic + +Now, when you login again, all these should be set automatically. + +Performing a calculation +------------------------ + +You should *not* perform calculations in your home space - this is for +code and small files. Calculations should be run in the “ceph” area +in /mnt/ceph/users/$USER/ + +On other machines I usually make a soft link / shortcut called “runs” pointing to the directory where I want to run my calculations:: + + $ cd + $ ln -s /mnt/ceph/users/$USER runs + $ cd runs + $ pwd -P + /mnt/ceph/users/USERNAME + +However on the Flatiron machines there is already a shortcut called "ceph" in your homespace. + +Then make a subdirectory for the name of the calculation you want to run +(e.g. shock):: + + $ mkdir shock + $ cd shock + $ ~/phantom/scripts/writemake.sh shock > Makefile + $ make shock + $ make + $ ./phantomsetup shock + +To run the code, you need to write a slurm script. You can get an +example by typing “make qscript”:: + + $ make qscript NOMP=10 INFILE=shock.in > run.q + +should produce something like:: + + $ cat run.q + #!/bin/bash + #SBATCH --ntasks=1 + #SBATCH --cpus-per-task=10 + #SBATCH --job-name=audiencia + #SBATCH --partition=gen + #SBATCH --output=shock.in.qout + #SBATCH --mail-type=BEGIN + #SBATCH --mail-type=FAIL + #SBATCH --mail-type=END + #SBATCH --mail-user=daniel.price@monash.edu + #SBATCH --time=0-168:00:00 + #SBATCH --mem=16G + echo "HOSTNAME = $HOSTNAME" + echo "HOSTTYPE = $HOSTTYPE" + echo Time is `date` + echo Directory is `pwd` + + ulimit -s unlimited + export OMP_SCHEDULE="dynamic" + export OMP_NUM_THREADS=10 + export OMP_STACKSIZE=1024m + + echo "starting phantom run..." + export outfile=`grep logfile "shock.in" | sed "s/logfile =//g" | sed "s/ \\!.*//g" | sed "s/\s//g"` + echo "writing output to $outfile" + ./phantom shock.in >& $outfile + +You can then submit this to the "temp" queue using:: + + $ sbatch -p temp run.q + Submitted batch job 2547013 + +check status using:: + + $ squeue -u $USER + JOBID PARTITION NAME USER ST TIME NODES NODELIST(REASON) + 2547013 temp audienci dprice R 0:02 1 worker3109 + +Once the job is running, follow the output log using the tail -f command:: + + $ tail -f shock01.log + +splash on rusty +~~~~~~~~~~~~~~~~ + +There is a version of splash you can get by loading the relevant module:: + + module load splash/3.8.3 + +(module load splash). Alternatively, you can also +install splash in your home space:: + + cd + git clone https://github.com/danieljprice/splash + cd splash; git clone https://github.com/danieljprice/giza + make withgiza SYSTEM=ifort + +You can add this directory in your path by putting the following lines +in your ~/.bashrc file:: + + export PATH=$HOME/splash/bin:${PATH} + export LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:$HOME/splash/giza/lib + +more info +~~~~~~~~~ + +For more information on the actual machine `read the +userguide `__ diff --git a/docs/getting-started.rst b/docs/getting-started.rst index 1df50bc22..2d8505cfa 100644 --- a/docs/getting-started.rst +++ b/docs/getting-started.rst @@ -29,6 +29,7 @@ Contents DiAL ozstar monarch + flatiron pawsey kennedy running-mac From fa33d5c5fdf0153eba8a0cc51b1d79e74ab125ab Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 2 Aug 2023 12:01:29 +1000 Subject: [PATCH 075/814] (github) fix actions hang using sudo apt-get update: https://github.com/actions/runner-images/issues/675 --- .github/workflows/build.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 28ab94a82..4c10e8bdd 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -67,6 +67,9 @@ jobs: - name: "Nuke the github workspace before doing anything" run: rm -r ${{ github.workspace }} && mkdir ${{ github.workspace }} + - name: Update package list + run: sudo apt-get update + - name: Setup Intel repo if: matrix.system == 'ifort' id: intel-repo @@ -75,7 +78,6 @@ jobs: sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB rm GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB sudo echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list - sudo apt-get update INTELVERSION=$(apt-cache show intel-oneapi-compiler-fortran | grep Version | head -1) echo "::set-output name=intelversion::$INTELVERSION" From 4eb41fb772676edb4ba1f06f0af400d4015c9b7c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 2 Aug 2023 12:01:47 +1000 Subject: [PATCH 076/814] (docs) updated flatiron info --- docs/flatiron.rst | 165 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 165 insertions(+) create mode 100644 docs/flatiron.rst diff --git a/docs/flatiron.rst b/docs/flatiron.rst new file mode 100644 index 000000000..083658c2c --- /dev/null +++ b/docs/flatiron.rst @@ -0,0 +1,165 @@ +Getting started on Rusty (Flatiron cluster) +=========================================== + +See also :doc:`general instructions for running phantom on a remote cluster `. + +We assume you already have a Flatiron username and account + +First time you log in +--------------------- + +Make sure you log in with the -Y flag to enable X-Windows forwarding:: + + $ ssh -Y -p 61022 @gateway.flatironinstitute.org + $ ssh -Y rusty + +show available software:: + + $ module avail + +load intel compilers and splash:: + + $ module load intel-oneapi-compilers/2023.0.0 + $ module load splash/3.8.3 + +Get phantom +~~~~~~~~~~~ + +Clone a copy of phantom into your home directory:: + + $ git clone https://github.com/danieljprice/phantom.git + +Set your username and email address +----------------------------------- + +Ensure that your name and email address are set, as follows:: + + cd phantom + git config --global user.name "Joe Bloggs" + git config --global user.email "joe.bloggs@monash.edu" + +Please use your full name in the format above, as this is what appears +in the commit logs (and in the AUTHORS file). + +edit your .bashrc file +---------------------- + +I put the “module load” commands in a file called ~/.modules which +contains the modules I want every time I log in. For example:: + + $ cat .modules + module load intel-oneapi-compilers/2023.0.0 + +Then, add the following lines to your ~/.bashrc:: + + source ~/.modules + export SYSTEM=rusty + ulimit -s unlimited + export OMP_STACKSIZE=512M + export OMP_SCHEDULE=dynamic + +Now, when you login again, all these should be set automatically. + +Performing a calculation +------------------------ + +You should *not* perform calculations in your home space - this is for +code and small files. Calculations should be run in the “ceph” area +in /mnt/ceph/users/$USER/ + +On other machines I usually make a soft link / shortcut called “runs” pointing to the directory where I want to run my calculations:: + + $ cd + $ ln -s /mnt/ceph/users/$USER runs + $ cd runs + $ pwd -P + /mnt/ceph/users/USERNAME + +However on the Flatiron machines there is already a shortcut called "ceph" in your homespace. + +Then make a subdirectory for the name of the calculation you want to run +(e.g. shock):: + + $ mkdir shock + $ cd shock + $ ~/phantom/scripts/writemake.sh shock > Makefile + $ make shock + $ make + $ ./phantomsetup shock + +To run the code, you need to write a slurm script. You can get an +example by typing “make qscript”:: + + $ make qscript NOMP=10 INFILE=shock.in > run.q + +should produce something like:: + + $ cat run.q + #!/bin/bash + #SBATCH --ntasks=1 + #SBATCH --cpus-per-task=10 + #SBATCH --job-name=audiencia + #SBATCH --partition=gen + #SBATCH --output=shock.in.qout + #SBATCH --mail-type=BEGIN + #SBATCH --mail-type=FAIL + #SBATCH --mail-type=END + #SBATCH --mail-user=daniel.price@monash.edu + #SBATCH --time=0-168:00:00 + #SBATCH --mem=16G + echo "HOSTNAME = $HOSTNAME" + echo "HOSTTYPE = $HOSTTYPE" + echo Time is `date` + echo Directory is `pwd` + + ulimit -s unlimited + export OMP_SCHEDULE="dynamic" + export OMP_NUM_THREADS=10 + export OMP_STACKSIZE=1024m + + echo "starting phantom run..." + export outfile=`grep logfile "shock.in" | sed "s/logfile =//g" | sed "s/ \\!.*//g" | sed "s/\s//g"` + echo "writing output to $outfile" + ./phantom shock.in >& $outfile + +You can then submit this to the "temp" queue using:: + + $ sbatch -p temp run.q + Submitted batch job 2547013 + +check status using:: + + $ squeue -u $USER + JOBID PARTITION NAME USER ST TIME NODES NODELIST(REASON) + 2547013 temp audienci dprice R 0:02 1 worker3109 + +Once the job is running, follow the output log using the tail -f command:: + + $ tail -f shock01.log + +splash on rusty +~~~~~~~~~~~~~~~~ + +There is a version of splash you can get by loading the relevant module:: + + module load splash/3.8.3 + +(module load splash). Alternatively, you can also +install splash in your home space:: + + cd + git clone https://github.com/danieljprice/splash + cd splash; git clone https://github.com/danieljprice/giza + make withgiza SYSTEM=ifort + +You can add this directory in your path by putting the following lines +in your ~/.bashrc file:: + + export PATH=$HOME/splash/bin:${PATH} + export LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:$HOME/splash/giza/lib + +more info +~~~~~~~~~ + +For more information on the actual machine `read the +userguide `__ From baacbe7a3dc4ccda89b27ba3cf9adead8d977316 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 2 Aug 2023 12:02:57 +1000 Subject: [PATCH 077/814] (build) preliminary attempt to test option ranges in .setup file --- scripts/buildbot.sh | 39 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 37 insertions(+), 2 deletions(-) diff --git a/scripts/buildbot.sh b/scripts/buildbot.sh index 74ce14c8a..60be99ac9 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='analysis' +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 )) @@ -195,14 +196,15 @@ check_phantomsetup () # # run phantomsetup up to 3 times to successfully create/rewrite the .setup file # + infile="${prefix}.in" ./phantomsetup $prefix < myinput.txt > /dev/null; ./phantomsetup $prefix < myinput.txt > /dev/null; if [ -e "$prefix.setup" ]; then print_result "creates .setup file" $pass; + #test_setupfile_options "$prefix" "$prefix.setup" $infile; else print_result "no .setup file" $warn; fi - infile="${prefix}.in" if [ -e "$infile" ]; then print_result "creates .in file" $pass; # @@ -247,6 +249,39 @@ check_phantomsetup () fi } # +# check that all possible values of certain +# variables in the .setup file work +# +test_setupfile_options() +{ + myfail=0; + setup=$1; + setupfile=$2; + infile=$3; + range='' + if [ "X$setup"=="Xstar" ]; then + param='iprofile' + range='1 2 3 4 5 6 7' + fi + for x in $range; do + valstring="$param = $x" + echo "checking $valstring" + sed "s/$param.*=.*$/$valstring/" $setupfile > ${setupfile}.tmp + cp ${setupfile}.tmp $setupfile + rm $infile + ./phantomsetup $setupfile < /dev/null > /dev/null; + ./phantomsetup $setupfile < /dev/null; + + if [ -e $infile ]; then + print_result "successful phantomsetup with $valstring" $pass; + else + print_result "FAIL: failed to create .in file with $valstring" $fail; + myfail=$(( myfail + 1 )); + echo $setup $valstring >> $faillogsetup; + fi + done +} +# # unit tests for phantomanalysis utility # (currently only exist for SETUP=star) # From a6a948ec25b6b10de05073f3f4bc25dcafdd7042 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 2 Aug 2023 12:10:09 +1000 Subject: [PATCH 078/814] (buildbot) remove accidentally committed overrides --- scripts/buildbot.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/buildbot.sh b/scripts/buildbot.sh index 60be99ac9..0b503882c 100755 --- a/scripts/buildbot.sh +++ b/scripts/buildbot.sh @@ -72,12 +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' +#allsetups='star' setuparr=($allsetups) batchsize=$(( ${#setuparr[@]} / $nbatch + 1 )) offset=$(( ($batch-1) * $batchsize )) From a02690878284c2d80112b79b212e033a30f0064d Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 2 Aug 2023 23:34:59 +1000 Subject: [PATCH 079/814] (build) put back sudo apt-get update in intel installation --- .github/workflows/build.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 4c10e8bdd..2acd7ba98 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -78,6 +78,7 @@ jobs: sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB rm GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB sudo echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list + sudo apt-get update INTELVERSION=$(apt-cache show intel-oneapi-compiler-fortran | grep Version | head -1) echo "::set-output name=intelversion::$INTELVERSION" From 1030b05ca610888fe4bfad795e75fb26a23218b6 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 01:35:33 +1000 Subject: [PATCH 080/814] (docs) updated flatiron tutorial [skip ci] --- docs/flatiron.rst | 110 +++++++++++++++++++++++++++++++++++++++------- 1 file changed, 94 insertions(+), 16 deletions(-) diff --git a/docs/flatiron.rst b/docs/flatiron.rst index 1aa0c3c50..bb97238f4 100644 --- a/docs/flatiron.rst +++ b/docs/flatiron.rst @@ -10,24 +10,25 @@ First time you log in Make sure you log in with the -Y flag to enable X-Windows forwarding:: - $ ssh -Y -p 61022 @gateway.flatironinstitute.org - $ ssh -Y rusty + ssh -Y -p 61022 @gateway.flatironinstitute.org + ssh -Y rusty show available software:: - $ module avail + module avail load intel compilers and splash:: - $ module load intel-oneapi-compilers/2023.0.0 - $ module load splash/3.8.3 + module load intel-oneapi-compilers/2023.0.0 + module use ~yjiang/modulefiles + module load splash/3.8.3 Get phantom ~~~~~~~~~~~ Clone a copy of phantom into your home directory:: - $ git clone https://github.com/danieljprice/phantom.git + git clone https://github.com/danieljprice/phantom.git Set your username and email address ----------------------------------- @@ -82,17 +83,17 @@ However on the Flatiron machines there is already a shortcut called "ceph" in yo Then make a subdirectory for the name of the calculation you want to run (e.g. shock):: - $ mkdir shock - $ cd shock - $ ~/phantom/scripts/writemake.sh shock > Makefile - $ make shock - $ make - $ ./phantomsetup shock + mkdir shock + cd shock + ~/phantom/scripts/writemake.sh shock > Makefile + make shock + make + ./phantomsetup shock To run the code, you need to write a slurm script. You can get an example by typing “make qscript”:: - $ make qscript NOMP=10 INFILE=shock.in > run.q + make qscript NOMP=10 INFILE=shock.in > run.q should produce something like:: @@ -137,17 +138,17 @@ check status using:: Once the job is running, follow the output log using the tail -f command:: - $ tail -f shock01.log + tail -f shock01.log splash on rusty ~~~~~~~~~~~~~~~~ There is a version of splash you can get by loading the relevant module:: + module use ~yjiang/modulefiles module load splash/3.8.3 -(module load splash). Alternatively, you can also -install splash in your home space:: +Alternatively, you can also install a local copy of splash in your home space:: cd git clone https://github.com/danieljprice/splash @@ -160,6 +161,83 @@ in your ~/.bashrc file:: export PATH=$HOME/splash/bin:${PATH} export LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:$HOME/splash/giza/lib +visualising the shock problem +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Simple plots with splash can be launched from the command line, e.g.:: + + splash shock_0* -y density -x x + +then press space to step through the snapshots. You can plot the exact solution +for the shock tube by switching it on from the o) menu:: + + Please enter your selection now (y axis or option):o + ------------- particle plot options ------------------- + 8) plot exact solution ( 3 ) + ... + enter option ([0:9], default=0): 8 + ... + 3) shock tube + ... + enter exact solution to plot ([0:18], default=3): + plotting exact solution number 3 + no file sod.shk + >> read sod.setup + rhoL, rho_R = 1.0000000000000000 0.12500000000000000 + pr_L, pr_R = 1.0000000000000000 0.10000000000000001 + v_L, v_R = 0.0000000000000000 0.0000000000000000 + set adiabatic gamma manually? (no=read from dumps) (default=no): + +then press 's' from the main menu to save, and remake your plot:: + + Please enter your selection now (y axis or option):6 + (x axis) (default=1): + (render) (0=none) ([0:16], default=0): + Graphics device/type (? to see list, default /xw): + +To make an offline version of the same plot from the command line, use:: + + splash shock_0* -y density -x x -dev shock.pdf + +read the `splash userguide `__ for more + +more interesting examples +~~~~~~~~~~~~~~~~~~~~~~~~~ +To proceed to a more interesting calculation, just change the name of the :doc:`SETUP +parameter `_ when you created the Makefile in the run directory, as per +the :doc:`examples `_:: + + cd ~/ceph + mkdir disc + cd disc + ~/phantom/scripts/writemake.sh disc > Makefile + make setup + make + ./phantomsetup disc + +after editing the .setup file as desired, then finish the setup and run the calculation:: + + ./phantomsetup disc + make qscript NOMP=10 INFILE=disc.in > run.q + sbatch -p temp run.q + +...and you're off and rolling. + +more examples of test problems, e.g. Orszag-Tang vortex +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To run your own version of standardised test problems shown in the `code paper `_, +you can clone the `phantom-examples run.q + sbatch -p temp run.q + more info ~~~~~~~~~ From 9570ed7b4c58f549fb8180de968082f3b24ee4bd Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 01:54:08 +1000 Subject: [PATCH 081/814] (docs) updated flatiron tutorial [skip ci] --- docs/flatiron.rst | 34 +++++++++++++++++++--------------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/docs/flatiron.rst b/docs/flatiron.rst index bb97238f4..ffa4f48db 100644 --- a/docs/flatiron.rst +++ b/docs/flatiron.rst @@ -17,21 +17,23 @@ show available software:: module avail -load intel compilers and splash:: +load intel compilers and splash +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +:: module load intel-oneapi-compilers/2023.0.0 module use ~yjiang/modulefiles module load splash/3.8.3 -Get phantom -~~~~~~~~~~~ - +get phantom +~~~~~~~~~~~~ Clone a copy of phantom into your home directory:: git clone https://github.com/danieljprice/phantom.git -Set your username and email address ------------------------------------ +set your username and email address +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Ensure that your name and email address are set, as follows: @@ -45,7 +47,7 @@ Please use your full name in the format above, as this is what appears in the commit logs (and in the AUTHORS file). edit your .bashrc file ----------------------- +~~~~~~~~~~~~~~~~~~~~~~ I put the “module load” commands in a file called ~/.modules which contains the modules I want every time I log in. For example:: @@ -141,7 +143,7 @@ Once the job is running, follow the output log using the tail -f command:: tail -f shock01.log splash on rusty -~~~~~~~~~~~~~~~~ +---------------- There is a version of splash you can get by loading the relevant module:: @@ -162,7 +164,7 @@ in your ~/.bashrc file:: export LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:$HOME/splash/giza/lib visualising the shock problem -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +------------------------------ Simple plots with splash can be launched from the command line, e.g.:: splash shock_0* -y density -x x @@ -201,7 +203,7 @@ To make an offline version of the same plot from the command line, use:: read the `splash userguide `__ for more more interesting examples -~~~~~~~~~~~~~~~~~~~~~~~~~ +------------------------- To proceed to a more interesting calculation, just change the name of the :doc:`SETUP parameter `_ when you created the Makefile in the run directory, as per the :doc:`examples `_:: @@ -210,8 +212,10 @@ the :doc:`examples `_:: mkdir disc cd disc ~/phantom/scripts/writemake.sh disc > Makefile - make setup - make + make setup; make + +followed by:: + ./phantomsetup disc after editing the .setup file as desired, then finish the setup and run the calculation:: @@ -223,9 +227,9 @@ after editing the .setup file as desired, then finish the setup and run the calc ...and you're off and rolling. more examples of test problems, e.g. Orszag-Tang vortex -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +---------------------------------------------------------- To run your own version of standardised test problems shown in the `code paper `_, -you can clone the `phantom-examples `_ repository:: cd ~/ceph git clone https://github.com/phantomSPH/phantom-examples @@ -239,7 +243,7 @@ followed by:: sbatch -p temp run.q more info -~~~~~~~~~ +--------- For more information on the actual machine `read the userguide `__ From 3e63501c505df416c4e2955b31c8e3969713a2cb Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 02:19:51 +1000 Subject: [PATCH 082/814] Update flatiron.rst [skip ci] --- docs/flatiron.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/flatiron.rst b/docs/flatiron.rst index bbd6d3a6a..3553a13d5 100644 --- a/docs/flatiron.rst +++ b/docs/flatiron.rst @@ -203,8 +203,8 @@ read the `splash userguide `__ for more more interesting examples ------------------------- To proceed to a more interesting calculation, just change the name of the :doc:`SETUP -parameter `_ when you created the Makefile in the run directory, as per -the :doc:`examples `_:: +parameter ` when you created the Makefile in the run directory, as per +the :doc:`examples `:: cd ~/ceph mkdir disc From f7e45956ebda7825e30d8491979ec93915952996 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 04:57:08 +1000 Subject: [PATCH 083/814] Update flatiron.rst [skip ci] --- docs/flatiron.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/flatiron.rst b/docs/flatiron.rst index 3553a13d5..0296e3109 100644 --- a/docs/flatiron.rst +++ b/docs/flatiron.rst @@ -86,7 +86,7 @@ Then make a subdirectory for the name of the calculation you want to run mkdir shock cd shock ~/phantom/scripts/writemake.sh shock > Makefile - make shock + make setup make ./phantomsetup shock From bbf9e7ae1d1d07501e35ce78c178812be8ff8290 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 14:33:58 -0400 Subject: [PATCH 084/814] (docs) updated flatiron tutorial [skip ci] --- docs/flatiron.rst | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/docs/flatiron.rst b/docs/flatiron.rst index bbd6d3a6a..c9cf24466 100644 --- a/docs/flatiron.rst +++ b/docs/flatiron.rst @@ -158,8 +158,9 @@ Alternatively, you can also install a local copy of splash in your home space:: You can add this directory in your path by putting the following lines in your ~/.bashrc file:: - export PATH=$HOME/splash/bin:${PATH} - export LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:$HOME/splash/giza/lib + export SPLASH_DIR=/mnt/home/dprice/splash + export PATH=${SPLASH_DIR}/bin:${PATH} + export LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:${SPLASH_DIR}/giza/lib visualising the shock problem ------------------------------ From 64de8441a3e8fbce836922d0423227efda06bfd7 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 22:50:27 -0400 Subject: [PATCH 085/814] Update fork.rst [skip ci] --- docs/fork.rst | 76 +++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 67 insertions(+), 9 deletions(-) diff --git a/docs/fork.rst b/docs/fork.rst index 4b4310960..e02db4cd8 100644 --- a/docs/fork.rst +++ b/docs/fork.rst @@ -16,9 +16,7 @@ github.com/USERNAME/phantom How to work on your fork ------------------------ -Clone a copy of your fork onto a local machine - -:: +Clone a copy of your fork onto a local machine:: git clone https://github.com/USERNAME/phantom @@ -28,17 +26,77 @@ repository How to update your fork with the latest from the main phantom repo ------------------------------------------------------------------ -First, make a remote branch that tracks the main repo: - -:: +First, make a remote branch that tracks the main repo:: git remote add upstream https://github.com/danieljprice/phantom git fetch upstream -Then every time you want to update, in your forked copy, type: - -:: +Then every time you want to update, in your forked copy, type:: git checkout master git fetch upstream git merge upstream/master + +How to push changes to your fork when you originally cloned the main phantom repo +--------------------------------------------------------------------------------- + +A common situation is to have checked out a copy from the original repository:: + + git clone https://github.com/danieljprice/phantom + +and you then make some changes to some files, which you commit to the local repo:: + + cd phantom + ...make some amazing code changes... + git commit -m 'my amazing code change' file.f90 + +How should you contribute these back so everyone can benefit? First, you should +*create your fork* as described above. Then you can simply add your new +fork as a remote branch of the current repository:: + + git remote add myfork git@github.com/USERNAME/phantom + +Notice that in the above we used the ssh address for github, because you need WRITE +permission which is only possible over ssh. If you haven't already done it, you +will need to add your public ssh key to github. To do this go to your .ssh directory:: + + cd ~/.ssh + cat id_rsa.pub + ... some long key is printed ... + +copy everything that was printed above and paste it into the relevant box under +github->settings->SSH and GPG keys, with a name like "my-laptop" or whatever the +machine you are currently working on is called. You will need to do this once +from every machine you want to push changes from. + +If the key exchange was done successfully you should now be able to push your +local changes back to your fork:: + + git push myfork + +And finally, you can click the "contribute" button which will create a pull request +for your changes to go back to the main phantom repository. Please do this, we +are a community code and everyone benefits when you contribute even small things... + +I only have a one line change, should I really issue a whole pull request? +--------------------------------------------------------------------------------- + +Yes, yes and yes. The easiest pull requests to merge are frequent small changes. +If you complete an entire PhD worth of work and THEN submit a giant pull request +built on changes to a copy of the code you checked out three years ago, it is +difficult (but not impossible) to merge. Frequent, small contributions +are a much better strategy. + +What if I break the code? +------------------------- + +That's why we have a comprehensive test suite that runs on every pull request. +Nearly every pull request fails the first time, and requires some tweaking +and improvement to pass all of the integration requirements. But this +process can only begin once you open your pull request! + + + + + + From 0814b577ba80b885f53dd41d2e7eca1e04059495 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 22:52:21 -0400 Subject: [PATCH 086/814] Update staging.rst [skip ci] --- docs/staging.rst | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/docs/staging.rst b/docs/staging.rst index d88828121..087ba33b3 100644 --- a/docs/staging.rst +++ b/docs/staging.rst @@ -7,10 +7,10 @@ Procedure is: - set the version number in phantom/docs/conf.py - update the :doc:`release notes ` - use git to tag the code version for the release:: -``` -git tag 'v2055.0.1' -``` -- push the tag and let the github actions do the rest:: -``` -git push -v tags -``` + + git tag 'v2055.0.1' + +- push the tag and let the github actions do the rest:: + + git push -v tags + From dafed97a0c0253c10432e3ac6a33fbe73e3d90a0 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 22:55:45 -0400 Subject: [PATCH 087/814] Update bots.rst [skip ci] --- docs/bots.rst | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/docs/bots.rst b/docs/bots.rst index 880e4f4ad..fcf1b698b 100644 --- a/docs/bots.rst +++ b/docs/bots.rst @@ -15,7 +15,7 @@ or when looking at who wrote particular lines in VSCode. Otherwise a small adjustment in indentation means the lines will be attributed to someone else... performing a dry run -~~~~~~~~~~~~~~~~~~~~~ +--------------------- By default the bots perform a dry run, making no changes but showing you what will be changed when you apply the changes. @@ -26,7 +26,7 @@ You can run the bots yourself as follows:: ./bots.sh doing it for real -~~~~~~~~~~~~~~~~~~~~~ +--------------------- If you are happy with the dry run, and you have a clean repository (i.e. everything is committed onto the current branch you are working on), proceed to ACTUALLY @@ -41,7 +41,7 @@ of phantom your push will be disallowed. Instead you should push the changes to your fork and issue a pull request. apply but do not commit -~~~~~~~~~~~~~~~~~~~~~~~~ +----------------------- In some circumstances you want to apply the changes to the files but leave them as "modified" in the current directory, which means that the can be reversed @@ -51,7 +51,7 @@ with "git restore" and/or committed manually:: ./bots.sh --apply running only specific bots -~~~~~~~~~~~~~~~~~~~~~~~~~~ +-------------------------- You can run specific bots using the --only flag, e.g.:: @@ -64,7 +64,7 @@ or, to run multiple (or all):: ./bots.sh --apply --only "tabs gt shout header whitespace authors endif" fixing merge conflicts in the AUTHORS file -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +------------------------------------------- you can easily recreate/update the AUTHORS file using the authors bot:: From 5a57aeacccdb227b8c6f48c4495dfca01c6e3772 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 22:57:18 -0400 Subject: [PATCH 088/814] Update staging.rst [skip ci] --- docs/staging.rst | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/docs/staging.rst b/docs/staging.rst index 087ba33b3..750537b35 100644 --- a/docs/staging.rst +++ b/docs/staging.rst @@ -6,11 +6,15 @@ Procedure is: - set the version number in phantom/build/Makefile - set the version number in phantom/docs/conf.py - update the :doc:`release notes ` -- use git to tag the code version for the release:: +- use git to tag the code version for the release - git tag 'v2055.0.1' +:: -- push the tag and let the github actions do the rest:: + git tag 'v2055.0.1' - git push -v tags +- push the tag and let the github actions do the rest + +:: + + git push -v tags From 0dc559be1cd9dc20414879c2c0a0c04f0446dd32 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 23:05:47 -0400 Subject: [PATCH 089/814] Update config.rst [skip ci] --- docs/config.rst | 113 ++++++++++++++++++++++-------------------------- 1 file changed, 51 insertions(+), 62 deletions(-) diff --git a/docs/config.rst b/docs/config.rst index 69fc35e42..4134f0950 100644 --- a/docs/config.rst +++ b/docs/config.rst @@ -13,13 +13,11 @@ number of particles use: make SETUP=disc MAXP=10000000 Setup block -~~~~~~~~~~~ +----------- The compile-time configuration of Phantom is specified using the SETUP block in `build/Makefile_setups `__. For example the default disc setup is -“disc”: - -:: +“disc”:: ifeq ($(SETUP), disc) # locally isothermal gas disc @@ -37,59 +35,59 @@ particular physics. Otherwise these are specified using variables in this block as follows: Pre-cooked setups -~~~~~~~~~~~~~~~~~ +----------------- For many applications a :doc:`pre-cooked SETUP block ` already exists. View the full list :doc:`here `. You can also override any of the compile-time settings manually, using the options below. Code modules ------------ -+-----------------+-----------------+-----------------+-----------------+ -| *Variable* | *Setting* | *Default value* | *Description* | -+=================+=================+=================+=================+ -| SETUPFILE | .f90 file(s) | setup_unifdis.F | The setup | -| | | 90 | routine and any | -| | | | auxiliary | -| | | | routines needed | -| | | | by phantomsetup | -+-----------------+-----------------+-----------------+-----------------+ -| LINKLIST | .f90 file(s) | linklist.F90 | The neighbour | -| | | | finding | -| | | | algorithm | -| | | | (fixed grid, | -| | | | fixed | -| | | | cylindrical | -| | | | grid or kdtree) | -+-----------------+-----------------+-----------------+-----------------+ -| ANALYSIS | .f90 file(s) | analysis_dthead | (optional) The | -| | | er.f90 | analysis | -| | | | routine and any | -| | | | auxiliary | -| | | | routines used | -| | | | by the | -| | | | phantomanalysis | -| | | | utility | -+-----------------+-----------------+-----------------+-----------------+ -| SRCTURB | .f90 file(s) | forcing_ouproce | (optional) | -| | | ss.f90 | Turbulence | -| | | | driving routine | -| | | | (triggers | -| | | | -DDRIVING) | -+-----------------+-----------------+-----------------+-----------------+ -| SRCINJECT | .f90 file(s) | inject_rochelob | (optional) | -| | | e.f90 | Module handling | -| | | | particle | -| | | | injection | -| | | | (triggers | -| | | | -DINJECT_PARTIC | -| | | | LES) | -+-----------------+-----------------+-----------------+-----------------+ -| MODFILE | .f90 file(s) | moddump.f90 | (optional) | -| | | | Routine used by | -| | | | moddump utility | -| | | | (to modify an | -| | | | existing dump | -| | | | file) | -+-----------------+-----------------+-----------------+-----------------+ ++-----------------+-----------------+-----------------------+-----------------+ +| *Variable* | *Setting* | *Default value* | *Description* | ++=================+=================+=======================+=================+ +| SETUPFILE | .f90 file(s) | setup_unifdis.F90 | The setup | +| | | | routine and any | +| | | | auxiliary | +| | | | routines needed | +| | | | by phantomsetup | ++-----------------+-----------------+-----------------------+-----------------+ +| LINKLIST | .f90 file(s) | linklist.F90 | The neighbour | +| | | | finding | +| | | | algorithm | +| | | | (fixed grid, | +| | | | fixed | +| | | | cylindrical | +| | | | grid or kdtree) | ++-----------------+-----------------+-----------------------+-----------------+ +| ANALYSIS | .f90 file(s) | analysis_dtheader.f90 | (optional) The | +| | | | analysis | +| | | | routine and any | +| | | | auxiliary | +| | | | routines used | +| | | | by the | +| | | | phantomanalysis | +| | | | utility | ++-----------------+-----------------+-----------------------+-----------------+ +| SRCTURB | .f90 file(s) | forcing.f90 | (optional) | +| | | | Turbulence | +| | | | driving routine | +| | | | (triggers | +| | | | -DDRIVING) | ++-----------------+-----------------+-----------------------+-----------------+ +| SRCINJECT | .f90 file(s) | inject_rochelobe.f90 | (optional) | +| | | | Module handling | +| | | | particle | +| | | | injection | +| | | | (triggers | +| | | | -DINJECT_PARTIC | +| | | | LES) | ++-----------------+-----------------+-----------------------+-----------------+ +| MODFILE | .f90 file(s) | moddump.f90 | (optional) | +| | | | Routine used by | +| | | | moddump utility | +| | | | (to modify an | +| | | | existing dump | +| | | | file) | ++-----------------+-----------------+-----------------------+-----------------+ Code performance and accuracy ----------------------------- @@ -250,15 +248,6 @@ or put this in the SETUP block: :: - ifeq ($(SETUP), isodisc) - FPPFLAGS= -DDISC_VISCOSITY -DSORT_RADIUS_INIT -DISOTHERMAL + ifeq ($(SETUP), disc) ... IND_TIMESTEPS=yes - -or add it as a preprocessor flag: - -:: - - ifeq ($(SETUP), isodisc) - FPPFLAGS= -DDISC_VISCOSITY -DSORT_RADIUS_INIT -DISOTHERMAL -DIND_TIMESTEPS - ... From 3b358b653257f2b9f15cac613daf7dc8945733db Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 23:13:39 -0400 Subject: [PATCH 090/814] Update fork.rst [skip ci] --- docs/fork.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/fork.rst b/docs/fork.rst index e02db4cd8..9839fad7d 100644 --- a/docs/fork.rst +++ b/docs/fork.rst @@ -18,7 +18,7 @@ How to work on your fork Clone a copy of your fork onto a local machine:: - git clone https://github.com/USERNAME/phantom + git clone git@github.com:USERNAME/phantom push and pull from your fork as you would with the regular phantom repository @@ -54,7 +54,7 @@ How should you contribute these back so everyone can benefit? First, you should *create your fork* as described above. Then you can simply add your new fork as a remote branch of the current repository:: - git remote add myfork git@github.com/USERNAME/phantom + git remote add myfork git@github.com:USERNAME/phantom Notice that in the above we used the ssh address for github, because you need WRITE permission which is only possible over ssh. If you haven't already done it, you From 66bed8cd7f7d4d4711947b31f1494c3e9f2f6b7b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 23:14:57 -0400 Subject: [PATCH 091/814] Update testing.rst --- docs/testing.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/testing.rst b/docs/testing.rst index 68659c4e6..19584a5b6 100644 --- a/docs/testing.rst +++ b/docs/testing.rst @@ -3,7 +3,7 @@ Getting your code to pass the github actions On every pull request a sequence of continuous integration tests are performed to check that code is safe to merge into master. -The scripts in the .github/workflows directory are as follows: +The scripts in the `.github/workflows `_ directory are as follows: - |build|_: checks that phantom, phantomsetup, phantomanalysis and phantommoddump compile with every possible SETUP= flag - |test|_: runs the test suite [see below] From 4903b93ce02ce3ac3d6e73c07dedb7b7ce9eddf9 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 3 Aug 2023 23:18:18 -0400 Subject: [PATCH 092/814] Update testing.rst [skip ci] --- docs/testing.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/testing.rst b/docs/testing.rst index 19584a5b6..9d9fc9f03 100644 --- a/docs/testing.rst +++ b/docs/testing.rst @@ -105,8 +105,8 @@ A non-exhaustive list of possible arguments are as follows: The buildbot ~~~~~~~~~~~~ -The buildbot also runs in an action and checks that the code compiles in all of -the possible SETUP configurations in the Makefile. You can run this +The buildbot also runs in `an action `_ and checks that the code compiles in :doc:`all of +the possible SETUP configurations in the Makefile `. You can run this offline as follows:: cd phantom/scripts From f4b0994936810674a0f4bf41529181558f64083a Mon Sep 17 00:00:00 2001 From: Farzana Meru Date: Fri, 4 Aug 2023 20:33:50 +0100 Subject: [PATCH 093/814] (cooling) Calculate the Gammie cooling from stellar origin --- src/main/checksetup.F90 | 2 +- src/main/cooling_gammie.f90 | 9 +++++++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index 6251c415b..219e06bc8 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.F90 @@ -422,7 +422,7 @@ subroutine check_setup(nerror,nwarn,restart) ! call get_centreofmass(xcom,vcom,npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) - if (.not.h2chemistry .and. maxvxyzu >= 4 .and. icooling == 3 .and. iexternalforce/=iext_corotate) then + if (.not.h2chemistry .and. maxvxyzu >= 4 .and. icooling == 3 .and. iexternalforce/=iext_corotate .and. nptmass==0) then if (dot_product(xcom,xcom) > 1.e-2) then print*,'ERROR: Gammie (2001) cooling (icooling=3) assumes Omega = 1./r^1.5' print*,' but the centre of mass is not at the origin!' diff --git a/src/main/cooling_gammie.f90 b/src/main/cooling_gammie.f90 index 6b44a079e..4b96fe76a 100644 --- a/src/main/cooling_gammie.f90 +++ b/src/main/cooling_gammie.f90 @@ -29,13 +29,18 @@ module cooling_gammie !+ !----------------------------------------------------------------------- subroutine cooling_Gammie_explicit(xi,yi,zi,ui,dudti) - + use part, only:xyzmh_ptmass, nptmass real, intent(in) :: ui,xi,yi,zi real, intent(inout) :: dudti real :: omegai,r2,tcool1 - r2 = xi*xi + yi*yi + zi*zi + if (nptmass > 0) then + r2 = (xi-xyzmh_ptmass(1,1))**2 + (yi-xyzmh_ptmass(2,1))**2 + (zi-xyzmh_ptmass(3,1))**2 + else + r2 = xi*xi + yi*yi + zi*zi + endif + Omegai = r2**(-0.75) tcool1 = Omegai/beta_cool dudti = dudti - ui*tcool1 From 1995191aa840ecad61c25bf7cf3af8281660f4fe Mon Sep 17 00:00:00 2001 From: Farzana Meru Date: Fri, 4 Aug 2023 20:44:33 +0100 Subject: [PATCH 094/814] [header-bot] updated file headers --- src/main/cooling_gammie.f90 | 2 +- src/main/radiation_implicit.f90 | 5 +++-- src/main/utils_implicit.f90 | 4 ++-- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/main/cooling_gammie.f90 b/src/main/cooling_gammie.f90 index 4b96fe76a..505806b2e 100644 --- a/src/main/cooling_gammie.f90 +++ b/src/main/cooling_gammie.f90 @@ -17,7 +17,7 @@ module cooling_gammie ! :Runtime parameters: ! - beta_cool : *beta factor in Gammie (2001) cooling* ! -! :Dependencies: infile_utils, io +! :Dependencies: infile_utils, io, part ! implicit none real, private :: beta_cool = 3. diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 71ff029d9..f93abf079 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -18,8 +18,9 @@ module radiation_implicit ! ! :Runtime parameters: None ! -! :Dependencies: boundary, dim, eos, io, kdtree, kernel, linklist, options, -! part, physcon, quartic, radiation_utils, units +! :Dependencies: boundary, derivutils, dim, eos, implicit, io, kdtree, +! kernel, linklist, options, part, physcon, quartic, radiation_utils, +! timing, units ! use part, only:ikappa,ilambda,iedd,idkappa,iradxi,icv,ifluxx,ifluxy,ifluxz,igas,rhoh,massoftype,imu use eos, only:iopacity_type diff --git a/src/main/utils_implicit.f90 b/src/main/utils_implicit.f90 index b7f0399ed..2f16f68ed 100644 --- a/src/main/utils_implicit.f90 +++ b/src/main/utils_implicit.f90 @@ -7,14 +7,14 @@ module implicit ! ! Utility routines for implicit radiative diffusion -! +! ! :References: ! ! :Owner: Mike Lau ! ! :Runtime parameters: None ! -! :Dependencies: +! :Dependencies: io, physcon ! implicit none integer :: ncompact,ncompactlocal,icompactmax,nneigh_average From ed5fdfdb20be2bf3d6eb918c3431f272774da61f Mon Sep 17 00:00:00 2001 From: Farzana Meru Date: Fri, 4 Aug 2023 20:45:49 +0100 Subject: [PATCH 095/814] [author-bot] updated AUTHORS file --- AUTHORS | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/AUTHORS b/AUTHORS index b7461cb69..73d749b5b 100644 --- a/AUTHORS +++ b/AUTHORS @@ -17,9 +17,9 @@ Mark Hutchison Fitz Hu Megha Sharma Rebecca Nealon +Elisabeth Borchert Ward Homan Christophe Pinte -Elisabeth Borchert Fangyi (Fitz) Hu Megha Sharma Terrence Tricco @@ -27,8 +27,8 @@ Mats Esseldeurs Stephane Michoulier Simone Ceppi MatsEsseldeurs -Enrico Ragusa Caitlyn Hardiman +Enrico Ragusa fhu Sergei Biriukov Cristiano Longarini @@ -37,12 +37,12 @@ Roberto Iaconi Hauke Worpel Alison Young Simone Ceppi -Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Amena Faruqi +Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi -Simon Glover Sahl Rowther +Simon Glover Thomas Reichardt Jean-François Gonzalez Christopher Russell @@ -52,24 +52,25 @@ Jolien Malfait Phantom benchmark bot Kieran Hirsh Nicole Rodrigues -David Trevascus Amena Faruqi +David Trevascus +Chris Nixon Megha Sharma Nicolas Cuello -Chris Nixon -Orsola De Marco -Joe Fisher +Benoit Commercon +Farzana Meru Giulia Ballabio -s-neilson <36410751+s-neilson@users.noreply.github.com> -Megha Sharma +Joe Fisher Maxime Lombart +Megha Sharma +Orsola De Marco Terrence Tricco -Benoit Commercon Zachary Pellow +s-neilson <36410751+s-neilson@users.noreply.github.com> +Alison Young Cox, Samuel -mats esseldeurs -Nicolás Cuello Jorge Cuadra +Nicolás Cuello Steven Rieder Stéven Toupin -Alison Young +mats esseldeurs From a7a316b2cb38339952020d6e4895371c7835775a Mon Sep 17 00:00:00 2001 From: Farzana Meru Date: Fri, 4 Aug 2023 21:07:04 +0100 Subject: [PATCH 096/814] (combineddustdumps) Bug fixes --- src/utils/combinedustdumps.f90 | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) mode change 100644 => 100755 src/utils/combinedustdumps.f90 diff --git a/src/utils/combinedustdumps.f90 b/src/utils/combinedustdumps.f90 old mode 100644 new mode 100755 index f7b1c8d9a..64440eb05 --- a/src/utils/combinedustdumps.f90 +++ b/src/utils/combinedustdumps.f90 @@ -28,7 +28,7 @@ program combinedustdumps use part, only:xyzh,vxyzu,npart,hfact,iphase,npartoftype,massoftype,& igas,idust,ndusttypes,ndustsmall,ndustlarge,set_particle_type,& grainsize,graindens,iamtype,isdead_or_accreted - use readwrite_dumps, only:read_dump,write_fulldump + use readwrite_dumps, only:read_dump,write_fulldump,init_readwrite_dumps use units, only:set_units,select_unit,umass,udist,utime use memory, only:allocate_memory use checksetup, only:check_setup @@ -39,9 +39,10 @@ program combinedustdumps real, allocatable :: grainsize_tmp(:),graindens_tmp(:) integer, allocatable :: npartofdust_tmp(:) integer :: i,j,counter,ipart,itype,ierr,nargs,idust_tmp,ninpdumps - integer :: nwarn,nerror + integer :: nwarn,nerror,ndust real :: time real(kind=8) :: utime_tmp,udist_tmp,umass_tmp + logical :: first_gas_only call set_io_unit_numbers iprint = 6 @@ -70,6 +71,8 @@ program combinedustdumps ! read first dumpfile HEADER ONLY: check idust, check MAXP ! we assume all dumps are from the same phantom version ! + + call init_readwrite_dumps() counter = 0 idust_tmp = idust ! new dumps, location of first dust particle type do i=1,ninpdumps @@ -81,6 +84,11 @@ program combinedustdumps endif counter = counter + npartoftype(idust_tmp) enddo + ! + ! save the number of dust particles for later + ! + ndust = npartoftype(idust_tmp) + ! !--sanity check array sizes ! @@ -91,17 +99,21 @@ program combinedustdumps ! ! allocate memory ! - call allocate_memory(int(counter,kind=8)) + call allocate_memory(counter) ! ! read gas particles from first file ! + call read_dump(trim(indumpfiles(1)),time,hfact,idisk1,iprint,0,1,ierr) + ! ! allocate temporary arrays ! - allocate (xyzh_tmp(ninpdumps,4,npartoftype(idust_tmp)),stat=ierr) + + allocate (xyzh_tmp(ninpdumps,4,ndust),stat=ierr) + print*,shape(xyzh_tmp),npartoftype(idust_tmp),idust_tmp if (ierr /= 0) stop 'error allocating memory to store positions' - allocate (vxyzu_tmp(ninpdumps,maxvxyzu,npartoftype(idust_tmp)),stat=ierr) + allocate (vxyzu_tmp(ninpdumps,maxvxyzu,ndust),stat=ierr) if (ierr /= 0) stop 'error allocating memory to store velocities' allocate (npartofdust_tmp(ninpdumps),stat=ierr) if (ierr /= 0) stop 'error allocating memory to store number of dust particles' @@ -115,6 +127,7 @@ program combinedustdumps ! !--read dumps and get dust particle information ! + first_gas_only = .false. do i=1,ninpdumps call read_dump(trim(indumpfiles(i)),time,hfact,idisk1,iprint,0,1,ierr) if (ierr /= 0) stop 'error reading dumpfile' @@ -123,6 +136,7 @@ program combinedustdumps grainsize_tmp(i) = grainsize(1) graindens_tmp(i) = graindens(1) counter = 0 + if (i == 1 .and. npartoftype(idust_tmp) == 0) first_gas_only = .true. do j=1,maxp if (iphase(j)==idust_tmp) then counter = counter + 1 @@ -156,6 +170,7 @@ program combinedustdumps ! do i=2,ninpdumps itype = idust + i - 1 + if (first_gas_only) itype = idust + i - 2 npartoftype(itype) = npartofdust_tmp(i) massoftype(itype) = massofdust_tmp(i) grainsize(i) = grainsize_tmp(i) @@ -176,6 +191,7 @@ program combinedustdumps !--dust properties ! ndusttypes = ninpdumps + if (first_gas_only) ndusttypes = ninpdumps - 1 ndustlarge = ndusttypes ndustsmall = 0 From 19f25953ece116033d2159d7d5a1372118856786 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 8 Aug 2023 01:34:17 +1000 Subject: [PATCH 097/814] (combinedustdumps) build failure fixed --- src/utils/combinedustdumps.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/utils/combinedustdumps.f90 b/src/utils/combinedustdumps.f90 index 64440eb05..d12b32677 100755 --- a/src/utils/combinedustdumps.f90 +++ b/src/utils/combinedustdumps.f90 @@ -38,7 +38,8 @@ program combinedustdumps real, allocatable :: xyzh_tmp(:,:,:),vxyzu_tmp(:,:,:),massofdust_tmp(:) real, allocatable :: grainsize_tmp(:),graindens_tmp(:) integer, allocatable :: npartofdust_tmp(:) - integer :: i,j,counter,ipart,itype,ierr,nargs,idust_tmp,ninpdumps + integer :: i,j,ipart,itype,ierr,nargs,idust_tmp,ninpdumps + integer(kind=8) :: counter integer :: nwarn,nerror,ndust real :: time real(kind=8) :: utime_tmp,udist_tmp,umass_tmp From 2ee6dcd8ca0876d0831072ee3df530281d24ca9c Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 18 Aug 2023 11:20:30 +1000 Subject: [PATCH 098/814] (CE-analysis) divv output choice of 0 gives no output --- src/utils/analysis_common_envelope.f90 | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 3c70d694f..b9594dd3d 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -1411,10 +1411,10 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) '13) JstarS' !option to calculate JstarS quantities_to_calculate = (/1,2,4,5/) - call prompt('Choose first quantity to compute ',quantities_to_calculate(1),1,Nquantities) - call prompt('Choose second quantity to compute ',quantities_to_calculate(2),1,Nquantities) - call prompt('Choose third quantity to compute ',quantities_to_calculate(3),1,Nquantities) - call prompt('Choose fourth quantity to compute ',quantities_to_calculate(4),1,Nquantities) + 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) endif ! Calculations performed outside loop over particles @@ -1424,7 +1424,7 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) com_vxyz = 0. do k=1,4 select case (quantities_to_calculate(k)) - case(1,2,3,6,8,9,13) ! Nothing to do + case(0,1,2,3,6,8,9,13) ! 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)) & @@ -1501,6 +1501,9 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) 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)) @@ -2508,7 +2511,7 @@ subroutine planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) real, dimension(3) :: planet_com,planet_vcom,vnorm,ri,Rvec real, allocatable :: R(:),z(:),rho(:) - call get_planetIDs(nplanet,planetIDs) + if (dump_number ==0 ) call get_planetIDs(nplanet,planetIDs) allocate(R(nplanet),z(nplanet),rho(nplanet)) ! Find highest density in planet @@ -2526,7 +2529,7 @@ subroutine planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) vnorm = planet_vcom / sqrt(dot_product(planet_vcom,planet_vcom)) ! Write to file - file_name = trim(dumpfile)//".dist" + file_name = trim(dumpfile)//".planetpart" open(newunit=iu, file=file_name, status='replace') ! Record R and z cylindrical coordinates w.r.t. planet_com @@ -2535,7 +2538,8 @@ subroutine planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) z(i) = dot_product(ri, vnorm) Rvec = ri - z(i)*vnorm R(i) = sqrt(dot_product(Rvec,Rvec)) - write(iu,"(es13.6,2x,es13.6,2x,es13.6)") R(i),z(i),rho(i) + ! write(iu,"(es13.6,2x,es13.6,2x,es13.6)") R(i),z(i),rho(i) + write(iu,"(es13.6,2x,es13.6,2x,es13.6,2x,es13.6,2x,es13.6)") xyzh(1,i),xyzh(2,i),xyzh(3,i),rho(i),vxyzu(4,i) enddo close(unit=iu) From ad57a52a9ac5952ff05885ebe1a010f59efeccc7 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 29 Aug 2023 12:00:11 +1000 Subject: [PATCH 099/814] Hopefully fixed build errors in testsuite --- src/main/cons2primsolver.f90 | 1 - src/main/readwrite_dumps_fortran.F90 | 5 ++++- src/main/step_leapfrog.F90 | 3 +-- src/main/utils_gr.F90 | 2 +- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/main/cons2primsolver.f90 b/src/main/cons2primsolver.f90 index 0055e14df..ee101a69b 100644 --- a/src/main/cons2primsolver.f90 +++ b/src/main/cons2primsolver.f90 @@ -163,7 +163,6 @@ subroutine conservative2primitive(x,metrici,v,dens,u,P,temp,gamma,rho,pmom,en,ie ! Retrieve sqrt(g) call get_sqrtg(gcov,sqrtg) sqrtg_inv = 1./sqrtg - pmom2 = 0. do i=1,3 pmom2 = pmom2 + pmom(i)*dot_product(gammaijUP(:,i),pmom(:)) diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index f5097a086..7e34a9e6e 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -217,7 +217,10 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) VrelVf_label,dustgasprop,dustgasprop_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,metrics,metricderivs,tmunus + luminosity,eta_nimhd,eta_nimhd_label +#ifdef GR + use part, only:metrics,metricderivs,tmunus +#endif use options, only:use_dustfrac,use_var_comp,icooling use dump_utils, only:tag,open_dumpfile_w,allocate_header,& free_header,write_header,write_array,write_block_header diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 17c30609b..97007d555 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -577,7 +577,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) enddo corrector !$omp enddo !$omp end parallel - print*, "after corrector" if (use_dustgrowth) call check_dustprop(npart,dustprop(1,:)) if (gr) then @@ -660,7 +659,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif endif enddo iterations - print*, "after iterations" + ! MPI reduce summary variables nwake = int(reduceall_mpi('+', nwake)) nvfloorp = int(reduceall_mpi('+', nvfloorp)) diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index d03ec9d7c..c3cbcfdeb 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.F90 @@ -237,7 +237,7 @@ subroutine get_sqrt_gamma(gcov,sqrt_gamma) sqrt_gamma = sqrt(det) else - sqrt_gamma = -1. + sqrt_gamma = 1. endif From 2f65a3063c124e7fc9a897be72a4b9e8d2b9ab1e Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 29 Aug 2023 21:27:07 +1000 Subject: [PATCH 100/814] windtunnel setup --- build/Makefile_setups | 11 ++- src/setup/setup_windtunnel.f90 | 126 +++++++++++++++++++++++++++++++++ 2 files changed, 136 insertions(+), 1 deletion(-) create mode 100644 src/setup/setup_windtunnel.f90 diff --git a/build/Makefile_setups b/build/Makefile_setups index 613f126e7..2f0af9e6e 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -597,7 +597,7 @@ ifeq ($(SETUP), blob) # Blob evaporation problem PERIODIC=yes SETUPFILE= setup_blob.f90 - DOUBLEPRECISION= no + DOUBLEPRECISION=no KNOWN_SETUP=yes endif @@ -831,6 +831,15 @@ ifeq ($(SETUP), BHL) IND_TIMESTEPS=yes endif +ifeq ($(SETUP), windtunnel) +# Wind tunnel setup + SETUPFILE= setup_windtunnel.f90 + SRCINJECT= inject_BHL.f90 + GRAVITY=yes + KNOWN_SETUP=yes + IND_TIMESTEPS=yes +endif + ifeq ($(SETUP), jet) # Jet simulation from Price, Tricco & Bate (2012) SETUPFILE= velfield_fromcubes.f90 setup_sphereinbox.f90 diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 new file mode 100644 index 000000000..b3e6e264b --- /dev/null +++ b/src/setup/setup_windtunnel.f90 @@ -0,0 +1,126 @@ +!--------------------------------------------------------------------------! +! 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 does setup +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: inject, part, physcon, units +! + use io, only:master + + implicit none + public :: setpart + + private + +contains + +!---------------------------------------------------------------- +!+ +! setup for gas sphere inside wind tunnel +!+ +!---------------------------------------------------------------- +subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) + use part, only:ihsoft,igas + use eos, only:ieos,gmw + use setstar_utils,only:set_star_density + use rho_profile, only:rho_polytrope + use extern_densprofile, only:nrhotab + use physcon, only:solarm,solarr + use units, only:udist,umass,utime,set_units + use inject, only:init_inject,BHL_r_star,BHL_m_star,BHL_mach,BHL_pmass,BHL_closepacked,BHL_handled_layers,& + BHL_wind_cylinder_radius,BHL_wind_injection_x,BHL_wind_length,BHL_psep + use mpidomain, only:i_belong + use timestep, only:dtmax,tmax + integer, intent(in) :: id + integer, intent(inout) :: npart + integer, intent(out) :: npartoftype(:) + real, intent(out) :: xyzh(:,:),vxyzu(:,:),massoftype(:),polyk,gamma,hfact + real, intent(inout) :: time + character(len=20), intent(in) :: fileprefix + real :: m,hacc,rhocentre,rmin,tcrush,rho_inf,v_inf,pres_inf,cs_inf,& + pmass,element_volume,rho_star + real, allocatable :: r(:),den(:) + integer :: ierr,npts,nstar + logical :: use_exactN + character(len=30) :: lattice + + call set_units(mass=solarm,dist=solarr,G=1.d0) + ! + !--general parameters + ! + time = 0. + polyk = 1. ! not used but needs to be initialised to non-zero value + gamma = 5./3. + ieos = 2 + gmw = 0.6 + + ! Wind parameters (see inject_BHL module) + BHL_mach = 1.31 + rho_inf = 6.8e-5 + pres_inf = 5.9e-6 + cs_inf = sqrt(gamma*pres_inf/rho_inf) + v_inf = BHL_mach*cs_inf + + ! Star parameters + BHL_r_star = 0.1 + BHL_m_star = 1.e-3 + nstar = 10000 + pmass = BHL_m_star / real(nstar) + massoftype(igas) = pmass + lattice = 'closepacked' + use_exactN = .true. + + ! Wind injection settings + BHL_closepacked = 1. ! do not change, this is hardwired at the moment + BHL_handled_layers = 4. + BHL_wind_cylinder_radius = 5. ! in units of Rstar + BHL_wind_injection_x = -5. ! in units of Rstar + BHL_wind_length = 20. ! in units of Rstar + + ! Calculate particle separation between layers given rho_inf, depending on lattice type + element_volume = pmass / rho_inf + if (BHL_closepacked == 1.) then + BHL_psep = (sqrt(2.)*element_volume)**(1./3.) + else + BHL_psep = element_volume**(1./3.) + endif + BHL_psep = BHL_psep / BHL_r_star ! need to provide in units of Rstar, separation between layers of wind particle + + ! Set default tmax and dtmax + rho_star = BHL_m_star/BHL_r_star**3 + tcrush = 2.*BHL_r_star*sqrt(rho_star/rho_inf)/v_inf + dtmax = 1.6*0.05*tcrush + tmax = 1.6*2.5*tcrush + + ! Set star +! allocate(r(nrhotab),den(nrhotab)) +! call rho_polytrope(gamma,polyk,BHL_m_star,r,den,npts,rhocentre,set_polyk=.true.,Rstar=BHL_r_star) +! rmin = r(1) +! call set_star_density(lattice,id,master,rmin,BHL_r_star,BHL_m_star,hfact,& +! npts,den,r,npart,npartoftype,massoftype,xyzh,use_exactN,np,i_belong) +! deallocate(r,den) + + + call init_inject(ierr) + npart = 0 + npartoftype(:) = 0 + xyzh(:,:) = 0. + vxyzu(:,:) = 0. + + print *, "udist = ", udist, "; umass = ", umass, "; utime = ", utime + +end subroutine setpart + +end module setup + \ No newline at end of file From e5efd4d466170072f4332e52dad79bca748df282 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Wed, 30 Aug 2023 11:35:47 +1000 Subject: [PATCH 101/814] Fixed precision errors in blob test setup and build --- src/setup/setup_flrwpspec.f90 | 2 +- src/utils/interpolate3D.F90 | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index 322d7cb3b..8cb8a272d 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -59,7 +59,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use dim, only:maxvxyzu,gr use setup_params, only:npart_total use io, only:master - use unifdis, only:set_unifdis,rho_func,mass_func + use unifdis, only:set_unifdis,rho_func!,mass_func use boundary, only:xmin,ymin,zmin,xmax,ymax,zmax,dxbound,dybound,dzbound,set_boundary,cross_boundary use part, only:periodic use physcon, only:years,pc,solarm diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index 076d594bf..5e1196284 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -74,10 +74,10 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& real, intent(in), dimension(npart) :: weight,dat integer, intent(in), dimension(npart) :: itype real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz -real(doub_prec), intent(out), dimension(npixx,npixy,npixz) :: datsmooth +real, intent(out), dimension(npixx,npixy,npixz) :: datsmooth logical, intent(in) :: normalise,periodicx,periodicy,periodicz !logical, intent(in), exact_rendering -real(doub_prec), allocatable :: datnorm(:,:,:) +real, allocatable :: datnorm(:,:,:) integer :: i,ipix,jpix,kpix integer :: iprintinterval,iprintnext @@ -436,10 +436,10 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& real, intent(in),dimension(npart,ilendat) :: dat integer, intent(in), dimension(npart) :: itype real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz - real(doub_prec), intent(out), dimension(ilendat,npixx,npixy,npixz) :: datsmooth + real, intent(out), dimension(ilendat,npixx,npixy,npixz) :: datsmooth logical, intent(in) :: normalise,periodicx,periodicy,periodicz !logical, intent(in), exact_rendering - real(doub_prec), allocatable :: datnorm(:,:,:) + real, allocatable :: datnorm(:,:,:) integer :: i,ipix,jpix,kpix,lockindex,smoothindex integer :: iprintinterval,iprintnext From ec658ced8cbd0d13bb07a74e7381f198cd401fb2 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Thu, 31 Aug 2023 15:33:49 +1000 Subject: [PATCH 102/814] Fixed unused variable warning --- src/setup/setup_flrwpspec.f90 | 34 +++++++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index 8cb8a272d..4a02a41e7 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -81,14 +81,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real, intent(out) :: vxyzu(:,:) character(len=40) :: filename,lattice,pspec_filename1,pspec_filename2,pspec_filename3 real :: totmass,deltax,pi - integer :: i,j,k,ierr,ncross + integer :: i,ierr,ncross logical :: iexist,isperiodic(3) - real :: kwave,denom,length, c1,c3,lambda - real :: perturb_rho0,xval - real :: Vup(0:3),v(0:3),const,phi,rhoprim,sqrtg,u0,x,gcov(0:3,0:3),alpha,hub + real :: length, c1,c3 + real :: hub real :: last_scattering_temp - real :: u - real :: scale_factor,gradphi(3),Hubble_param,vxyz(3),dxgrid,gridorigin + real :: scale_factor,gradphi(3),vxyz(3),dxgrid,gridorigin integer :: nghost, gridres, gridsize real, allocatable :: vxgrid(:,:,:),vygrid(:,:,:),vzgrid(:,:,:) ! procedure(rho_func), pointer :: density_func @@ -249,6 +247,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, pspec_filename1 = 'init_vel1_64.dat' pspec_filename2 = 'init_vel2_64.dat' pspec_filename3 = 'init_vel3_64.dat' + + ! Check if files exist otherwise skip and return flat space + if (.not. check_files(pspec_filename1,pspec_filename2,pspec_filename3)) then + print*, "Velocity files not found..." + print*, "Setting up flat space!" + return + endif + + ! Read in velocities from vel file here ! Should be made into a function at some point ! open(unit=444,file=pspec_filename,status='old') @@ -537,7 +544,7 @@ subroutine interpolate_val(position,valgrid,gridsize,gridorigin,dxgrid,val) integer, intent(in) :: gridsize real, intent(out) :: val integer :: xupper,yupper,zupper,xlower,ylower,zlower - real :: xlowerpos,ylowerpos,zlowerpos,xupperpos,yupperpos,zupperpos + real :: xlowerpos,ylowerpos,zlowerpos!,xupperpos,yupperpos,zupperpos real :: interptmp(7) real :: xd,yd,zd @@ -612,4 +619,17 @@ subroutine get_grid_neighbours(position,gridorigin,dx,xlower,ylower,zlower) end subroutine get_grid_neighbours +logical function check_files(file1,file2,file3) + character(len=40), intent(in) :: file1,file2,file3 + logical :: file1_exist, file2_exist, file3_exist + + INQUIRE(file=file1,exist=file1_exist) + INQUIRE(file=file2,exist=file2_exist) + INQUIRE(file=file3,exist=file3_exist) + + if ((.not. file1_exist) .or. (.not. file2_exist) .or. (.not. file3_exist)) then + check_files = .false. + endif +end function check_files + end module setup From 8344f028ac530c8d0b1838d61d0ee0b53090ab2a Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 6 Sep 2023 13:52:47 +0200 Subject: [PATCH 103/814] update inject_BHL to allow for embedding gas-particle object --- src/main/inject_BHL.f90 | 13 +++++----- src/setup/set_star_utils.f90 | 4 ++-- src/setup/setup_windtunnel.f90 | 43 +++++++++++++++++++--------------- 3 files changed, 33 insertions(+), 27 deletions(-) diff --git a/src/main/inject_BHL.f90 b/src/main/inject_BHL.f90 index 31fc559d6..644936368 100644 --- a/src/main/inject_BHL.f90 +++ b/src/main/inject_BHL.f90 @@ -38,6 +38,7 @@ module inject real, public :: BHL_mach = 3. real, public :: BHL_r_star = .1 real, public :: BHL_m_star + integer, public :: nstar = 0 ! Particle-related parameters real, public :: BHL_closepacked = 1. @@ -150,7 +151,7 @@ subroutine init_inject(ierr) layer_odd(:,:) = layer_even(:,:) endif max_layers = int(BHL_wind_length*BHL_r_star/distance_between_layers) - max_particles = int(max_layers*(nodd+neven)/2) + max_particles = int(max_layers*(nodd+neven)/2) + nstar print *, 'BHL maximum layers: ', max_layers print *, 'BHL maximum particles: ', max_particles if (max_particles > maxp) call fatal('BHL', 'maxp too small for this simulation, please increase MAXP!') @@ -188,11 +189,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& endif last_time = time-dtlast - outer_layer = ceiling(last_time/time_between_layers) - inner_layer = ceiling(time/time_between_layers)-1 + handled_layers + outer_layer = ceiling(last_time/time_between_layers) ! No. of layers present at t - dt + inner_layer = ceiling(time/time_between_layers)-1 + handled_layers ! No. of layers ought to be present at t ! Inject layers - do i=outer_layer,inner_layer - local_time = time - i*time_between_layers + do i=outer_layer,inner_layer ! loop over layers + local_time = time - i*time_between_layers ! time at which layer was injected i_limited = mod(i,max_layers) i_part = int(i_limited/2)*(nodd+neven)+mod(i_limited,2)*neven if (mod(i,2) == 0) then @@ -222,7 +223,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+1, np, xyz, vxyz, h, u, .false.) + call inject_or_update_particles(i_part+nstar+1, np, xyz, vxyz, h, u, .false.) deallocate(xyz, vxyz, h, u) enddo diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 5bcfbfef2..acc0de210 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -269,10 +269,10 @@ subroutine set_star_density(lattice,id,master,rmin,Rstar,Mstar,hfact,& npart_old = npart n = np mass_is_set = .false. - if (npart_old /= 0 .and. massoftype(igas) > tiny(0.)) then + if (massoftype(igas) > tiny(0.)) then n = nint(Mstar/massoftype(igas)) mass_is_set = .true. - !print "(a,i0)",' WARNING: particle mass is already set, using np = ',n + print "(a,i0)",' WARNING: particle mass is already set, using np = ',n endif ! ! place particles in sphere diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index b3e6e264b..08795bba1 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -38,24 +38,27 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use extern_densprofile, only:nrhotab use physcon, only:solarm,solarr use units, only:udist,umass,utime,set_units - use inject, only:init_inject,BHL_r_star,BHL_m_star,BHL_mach,BHL_pmass,BHL_closepacked,BHL_handled_layers,& + use inject, only:init_inject,nstar,BHL_r_star,BHL_mach,BHL_closepacked,BHL_handled_layers,& BHL_wind_cylinder_radius,BHL_wind_injection_x,BHL_wind_length,BHL_psep use mpidomain, only:i_belong use timestep, only:dtmax,tmax + use unifdis, only:mask_prototype + use setup_params,only:rhozero,npart_total + use mpidomain, only:i_belong integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) real, intent(out) :: xyzh(:,:),vxyzu(:,:),massoftype(:),polyk,gamma,hfact real, intent(inout) :: time character(len=20), intent(in) :: fileprefix - real :: m,hacc,rhocentre,rmin,tcrush,rho_inf,v_inf,pres_inf,cs_inf,& - pmass,element_volume,rho_star + real :: rhocentre,rmin,tcrush,rho_inf,v_inf,pres_inf,cs_inf,& + pmass,element_volume,rho_star,Mstar real, allocatable :: r(:),den(:) - integer :: ierr,npts,nstar + integer :: ierr,npts,np logical :: use_exactN character(len=30) :: lattice - call set_units(mass=solarm,dist=solarr,G=1.d0) + call set_units(mass=1.,dist=1.,G=1.) ! !--general parameters ! @@ -74,9 +77,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Star parameters BHL_r_star = 0.1 - BHL_m_star = 1.e-3 - nstar = 10000 - pmass = BHL_m_star / real(nstar) + Mstar = 1.e-3 + nstar = 1000 + pmass = Mstar / real(nstar) massoftype(igas) = pmass lattice = 'closepacked' use_exactN = .true. @@ -98,27 +101,29 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, BHL_psep = BHL_psep / BHL_r_star ! need to provide in units of Rstar, separation between layers of wind particle ! Set default tmax and dtmax - rho_star = BHL_m_star/BHL_r_star**3 + rho_star = Mstar/BHL_r_star**3 tcrush = 2.*BHL_r_star*sqrt(rho_star/rho_inf)/v_inf dtmax = 1.6*0.05*tcrush tmax = 1.6*2.5*tcrush - ! Set star -! allocate(r(nrhotab),den(nrhotab)) -! call rho_polytrope(gamma,polyk,BHL_m_star,r,den,npts,rhocentre,set_polyk=.true.,Rstar=BHL_r_star) -! rmin = r(1) -! call set_star_density(lattice,id,master,rmin,BHL_r_star,BHL_m_star,hfact,& -! npts,den,r,npart,npartoftype,massoftype,xyzh,use_exactN,np,i_belong) -! deallocate(r,den) - - + ! Initialise particle injection call init_inject(ierr) npart = 0 + np = 0 npartoftype(:) = 0 xyzh(:,:) = 0. vxyzu(:,:) = 0. + + ! Set star + allocate(r(nrhotab),den(nrhotab)) + call rho_polytrope(gamma,polyk,Mstar,r,den,npts,rhocentre,set_polyk=.true.,Rstar=BHL_r_star) + rmin = r(1) + call set_star_density(lattice,id,master,rmin,BHL_r_star,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 + deallocate(r,den) - print *, "udist = ", udist, "; umass = ", umass, "; utime = ", utime + print*, "udist = ", udist, "; umass = ", umass, "; utime = ", utime end subroutine setpart From d9639d6cd9db541f5724d70eeb808a9e1c510494 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 8 Sep 2023 01:36:58 +1000 Subject: [PATCH 104/814] add injection module for gas sphere in windtunnel --- build/Makefile_setups | 2 +- src/main/inject_windtunnel.f90 | 347 +++++++++++++++++++++++++++++++++ src/setup/setup_windtunnel.f90 | 78 ++++---- 3 files changed, 389 insertions(+), 38 deletions(-) create mode 100644 src/main/inject_windtunnel.f90 diff --git a/build/Makefile_setups b/build/Makefile_setups index 2f0af9e6e..9c4ba967a 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -834,7 +834,7 @@ endif ifeq ($(SETUP), windtunnel) # Wind tunnel setup SETUPFILE= setup_windtunnel.f90 - SRCINJECT= inject_BHL.f90 + SRCINJECT= inject_windtunnel.f90 GRAVITY=yes KNOWN_SETUP=yes IND_TIMESTEPS=yes diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 new file mode 100644 index 000000000..85a43f9f7 --- /dev/null +++ b/src/main/inject_windtunnel.f90 @@ -0,0 +1,347 @@ +!--------------------------------------------------------------------------! +! 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 inject +! +! Handles injection for gas sphere in wind tunnel +! +! +! :Owner: Mike Lau +! +! :Runtime parameters: +! - lattice_type : *0: cubic distribution, 1: closepacked distribution* +! - BHL_handled_layers : *(integer) number of handled BHL wind layers* +! - mach_inf : *BHL wind mach number* +! - Rstar : *BHL star radius (in accretion radii)* +! - BHL_radius : *radius of the wind cylinder (in star radii)* +! - BHL_wind_injection_x : *x position of the wind injection boundary (in star radii)* +! - BHL_wind_length : *crude wind length (in star radii)* +! +! :Dependencies: dim, eos, infile_utils, io, part, partinject, physcon, +! units +! + implicit none + character(len=*), parameter, public :: inject_type = 'windtunnel' + + public :: init_inject,inject_particles,write_options_inject,read_options_inject,& + set_default_options_inject +! +!--runtime settings for this module +! + ! Main parameters: model MS6 from Ruffert & Arnett (1994) + real, public :: mach_inf = 1. + real, public :: rho_inf = 1. + real, public :: cs_inf = 1. + real, public :: Rstar = .1 + integer, public :: nstar = 0 + + ! Particle-related parameters + integer, public :: lattice_type = 1 + real, public :: BHL_handled_layers = 4. + real, public :: BHL_wind_cylinder_radius = 30. + real, public :: BHL_wind_injection_x = -10. + real, public :: BHL_wind_length = 100. + + private + integer :: handled_layers + real :: wind_cylinder_radius,wind_injection_x,psep,distance_between_layers,& + time_between_layers,h_inf,u_inf,v_inf + integer :: max_layers,max_particles,nodd,neven + logical :: first_run = .true. + real, allocatable :: layer_even(:,:),layer_odd(:,:) + + logical, parameter :: verbose = .false. + +contains +!----------------------------------------------------------------------- +!+ +! Initialize global variables or arrays needed for injection routine +!+ +!----------------------------------------------------------------------- +subroutine init_inject(ierr) + use physcon, only:gg,pi + use eos, only:gamma + use part, only:hfact,massoftype,igas + use dim, only:maxp + use io, only:fatal + integer, intent(out) :: ierr + real :: pmass,element_volume,y,z + integer :: size_y, size_z, pass, i, j + + ierr = 0 + + v_inf = mach_inf*cs_inf + u_inf = cs_inf**2 / (gamma*(gamma-1.)) + handled_layers = int(BHL_handled_layers) + wind_cylinder_radius = BHL_wind_cylinder_radius * Rstar + wind_injection_x = BHL_wind_injection_x * Rstar + pmass = massoftype(igas) + + ! Calculate particle separation between layers given rho_inf, depending on lattice type + element_volume = pmass / rho_inf + if (lattice_type == 1) then + psep = (sqrt(2.)*element_volume)**(1./3.) + elseif (lattice_type == 0) then + psep = element_volume**(1./3.) + else + call fatal("init_inject",'unknown lattice_type (must be 0 or 1)') + endif + + if (lattice_type == 1) then + distance_between_layers = psep*sqrt(6.)/3. + size_y = ceiling(3.*wind_cylinder_radius/psep) + size_z = ceiling(3.*wind_cylinder_radius/(sqrt(3.)*psep/2.)) + do pass=1,2 + if (pass == 2) then + if (allocated(layer_even)) deallocate(layer_even) + if (allocated(layer_odd)) deallocate(layer_odd) + allocate(layer_even(2,neven), layer_odd(2,nodd)) + endif + neven = 0 + nodd = 0 + do i=1,size_y + do j=1,size_z + ! Even layer + y = -1.5*wind_cylinder_radius + (i-1)*psep + z = -1.5*wind_cylinder_radius + (j-1)*psep*sqrt(3.)/2. + if (mod(j,2) == 0) y = y + .5*psep + if (y**2+z**2 < wind_cylinder_radius**2) then + neven = neven + 1 + if (pass == 2) layer_even(:,neven) = (/ y,z /) + endif + ! Odd layer + y = y + psep*.5 + z = z + psep*sqrt(3.)/6. + if (y**2+z**2 < wind_cylinder_radius**2) then + nodd = nodd + 1 + if (pass == 2) layer_odd(:,nodd) = (/ y,z /) + endif + enddo + enddo + enddo + else + distance_between_layers = psep + size_y = ceiling(3.*wind_cylinder_radius/psep) + size_z = size_y + do pass=1,2 + if (pass == 2) allocate(layer_even(2,neven), layer_odd(2,neven)) + neven = 0 + do i=1,size_y + do j=1,size_z + y = -1.5*wind_cylinder_radius+(i-1)*psep + z = -1.5*wind_cylinder_radius+(j-1)*psep + if (y**2+z**2 < wind_cylinder_radius**2) then + neven = neven + 1 + if (pass == 2) layer_even(:,neven) = (/ y,z /) + endif + enddo + enddo + enddo + layer_odd(:,:) = layer_even(:,:) + endif + max_layers = int(BHL_wind_length*Rstar/distance_between_layers) + max_particles = int(max_layers*(nodd+neven)/2) + nstar + print *, 'BHL maximum layers: ', max_layers + print *, 'BHL maximum particles: ', max_particles + print *, 'nstar: ',nstar + if (max_particles > maxp) call fatal('BHL', 'maxp too small for this simulation, please increase MAXP!') + time_between_layers = distance_between_layers/v_inf + print *, 'distance_between_layers: ',distance_between_layers + print *, 'time_between_layers: ',time_between_layers + print *, 'pmass: ',pmass + h_inf = hfact*(pmass/rho_inf)**(1./3.) + !if (setup) then +! tmax = (100.*abs(wind_injection_x)/v_inf)/utime +! endif + +end subroutine init_inject + +!----------------------------------------------------------------------- +!+ +! Main routine handling wind injection. +!+ +!----------------------------------------------------------------------- +subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + npart,npartoftype,dtinject) + use physcon, only:gg,pi + use units, only:utime + real, intent(in) :: time, dtlast + real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) + integer, intent(inout) :: npart + integer, intent(inout) :: npartoftype(:) + real, intent(out) :: dtinject + + real :: last_time, local_time, x, irrational_number_close_to_one + integer :: inner_layer, outer_layer, i, i_limited, i_part, np, ierr + real, allocatable :: xyz(:,:), vxyz(:,:), h(:), u(:) + + if (first_run) then + call init_inject(ierr) + first_run = .false. + endif + + last_time = time-dtlast + outer_layer = ceiling(last_time/time_between_layers) ! No. of layers present at t - dt + inner_layer = ceiling(time/time_between_layers)-1 + handled_layers ! No. of layers ought to be present at t + ! Inject layers + do i=outer_layer,inner_layer ! loop over layers + local_time = time - i*time_between_layers ! time at which layer was injected + i_limited = mod(i,max_layers) + i_part = int(i_limited/2)*(nodd+neven)+mod(i_limited,2)*neven + if (mod(i,2) == 0) then + allocate(xyz(3,neven), vxyz(3,neven), h(neven), u(neven)) + xyz(2:3,:) = layer_even(:,:) + np = neven + else + allocate(xyz(3,nodd), vxyz(3,nodd), h(nodd), u(nodd)) + xyz(2:3,:) = layer_odd(:,:) + np = nodd + endif + x = wind_injection_x + local_time*v_inf + xyz(1,:) = x + vxyz(1,:) = v_inf + vxyz(2:3,:) = 0. + h(:) = h_inf + u(:) = u_inf + if (verbose) then + if (i_part < npart) then + if (i > max_layers) then + print *, 'Recycling (i=', i, ', max_layers=', max_layers, ', i_part=', i_part, '):' + else + print *, 'Moving:' + endif + else + print *, 'Injecting:' + endif + print *, np, ' particles (npart=', npart, '/', max_particles, ')' + endif + call inject_or_update_particles(i_part+nstar+1, np, xyz, vxyz, h, u, .false.) + deallocate(xyz, vxyz, h, u) + enddo + + irrational_number_close_to_one = 3./pi + dtinject = (irrational_number_close_to_one*time_between_layers)/utime + +end subroutine inject_particles + +! +! Inject gas or boundary particles +! +subroutine inject_or_update_particles(ifirst, n, position, velocity, h, u, boundary) + use part, only:igas,iboundary,npart,npartoftype,xyzh,vxyzu + use partinject, only:add_or_update_particle + implicit none + integer, intent(in) :: ifirst, n + double precision, intent(in) :: position(3,n), velocity(3,n), h(n), u(n) + logical, intent(in) :: boundary + + integer :: i, itype + real :: position_u(3), velocity_u(3) + + if (boundary) then + itype = iboundary + else + itype = igas + endif + + do i=1,n + position_u(:) = position(:,i) + velocity_u(:) = velocity(:,i) + call add_or_update_particle(itype,position_u,velocity_u,h(i),u(i),& + ifirst+i-1,npart,npartoftype,xyzh,vxyzu) + enddo + +end subroutine inject_or_update_particles + +!----------------------------------------------------------------------- +!+ +! Writes input options to the input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_inject(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + call write_inopt(mach_inf,'mach_inf','BHL wind mach number',iunit) + call write_inopt(cs_inf,'cs_inf','ambient sound speed',iunit) + call write_inopt(rho_inf,'rho_inf','ambient density',iunit) + call write_inopt(Rstar,'Rstar','BHL star radius (in accretion radii)',iunit) + call write_inopt(nstar,'nstar','No. of particles making up star',iunit) + call write_inopt(lattice_type,'lattice_type','0: cubic distribution, 1: closepacked distribution',iunit) + call write_inopt(BHL_handled_layers,'BHL_handled_layers','(integer) number of handled BHL wind layers',iunit) + call write_inopt(BHL_wind_cylinder_radius,'BHL_radius','radius of the wind cylinder (in star radii)',iunit) + call write_inopt(BHL_wind_injection_x,'BHL_wind_injection_x','x position of the wind injection boundary (in star radii)',iunit) + call write_inopt(BHL_wind_length,'BHL_wind_length','crude wind length (in star radii)',iunit) + +end subroutine write_options_inject + +!----------------------------------------------------------------------- +!+ +! Reads input options from the input file. +!+ +!----------------------------------------------------------------------- +subroutine read_options_inject(name,valstring,imatch,igotall,ierr) + use io, only: fatal, error, warning + 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_inject' + + imatch = .true. + igotall = .false. + select case(trim(name)) + case('mach_inf') + read(valstring,*,iostat=ierr) mach_inf + ngot = ngot + 1 + if (mach_inf <= 0.) call fatal(label,'invalid setting for mach_inf (<=0)') + case('cs_inf') + read(valstring,*,iostat=ierr) cs_inf + ngot = ngot + 1 + if (cs_inf <= 0.) call fatal(label,'cs_inf must be positive') + case('rho_inf') + read(valstring,*,iostat=ierr) rho_inf + ngot = ngot + 1 + if (rho_inf <= 0.) call fatal(label,'rho_inf must be positive') + case('nstar') + read(valstring,*,iostat=ierr) nstar + ngot = ngot + 1 + case('Rstar') + read(valstring,*,iostat=ierr) Rstar + ngot = ngot + 1 + if (Rstar <= 0.) call fatal(label,'invalid setting for Rstar (<=0)') + case('lattice_type') + read(valstring,*,iostat=ierr) lattice_type + ngot = ngot + 1 + if (lattice_type/=0 .and. lattice_type/=1) call fatal(label,'lattice_type must be 0 or 1') + case('BHL_handled_layers') + read(valstring,*,iostat=ierr) BHL_handled_layers + ngot = ngot + 1 + if (dble(int(BHL_handled_layers)) /= BHL_handled_layers) call fatal(label,'BHL_handled_layers must be integer') + if (int(BHL_handled_layers) < 0) call fatal(label,'BHL_handled_layers must be positive or zero') + case('BHL_radius') + read(valstring,*,iostat=ierr) BHL_wind_cylinder_radius + ngot = ngot + 1 + if (BHL_wind_cylinder_radius <= 0.) call fatal(label,'BHL_wind_cylinder_radius must be >0') + case('BHL_wind_injection_x') + read(valstring,*,iostat=ierr) BHL_wind_injection_x + ngot = ngot + 1 + case('BHL_wind_length') + read(valstring,*,iostat=ierr) BHL_wind_length + ngot = ngot + 1 + if (BHL_wind_length <= 0.) call fatal(label,'BHL_wind_length must be positive') + end select + + igotall = (ngot >= 10) +end subroutine read_options_inject + +subroutine set_default_options_inject(flag) + + integer, optional, intent(in) :: flag +end subroutine set_default_options_inject + +end module inject diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index 08795bba1..ddd88137a 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -27,7 +27,7 @@ module setup !---------------------------------------------------------------- !+ -! setup for gas sphere inside wind tunnel +! setup for polytropic gas sphere inside wind tunnel !+ !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) @@ -38,27 +38,29 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use extern_densprofile, only:nrhotab use physcon, only:solarm,solarr use units, only:udist,umass,utime,set_units - use inject, only:init_inject,nstar,BHL_r_star,BHL_mach,BHL_closepacked,BHL_handled_layers,& - BHL_wind_cylinder_radius,BHL_wind_injection_x,BHL_wind_length,BHL_psep + use inject, only:init_inject,nstar,Rstar,mach_inf,lattice_type,BHL_handled_layers,& + BHL_wind_cylinder_radius,BHL_wind_injection_x,BHL_wind_length,& + cs_inf,rho_inf use mpidomain, only:i_belong use timestep, only:dtmax,tmax use unifdis, only:mask_prototype + use kernel, only:hfact_default use setup_params,only:rhozero,npart_total - use mpidomain, only:i_belong + use mpidomain, only:i_belong + use table_utils, only:yinterp integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) real, intent(out) :: xyzh(:,:),vxyzu(:,:),massoftype(:),polyk,gamma,hfact real, intent(inout) :: time character(len=20), intent(in) :: fileprefix - real :: rhocentre,rmin,tcrush,rho_inf,v_inf,pres_inf,cs_inf,& - pmass,element_volume,rho_star,Mstar - real, allocatable :: r(:),den(:) - integer :: ierr,npts,np + real :: rhocentre,rmin,tcrush,v_inf,pres_inf,pmass,rho_star,Mstar,densi,presi,ri + real, allocatable :: r(:),den(:),pres(:) + integer :: ierr,npts,np,i logical :: use_exactN character(len=30) :: lattice - call set_units(mass=1.,dist=1.,G=1.) + call set_units(mass=solarm,dist=solarr,G=1.) ! !--general parameters ! @@ -67,43 +69,35 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, gamma = 5./3. ieos = 2 gmw = 0.6 + hfact = hfact_default ! Wind parameters (see inject_BHL module) - BHL_mach = 1.31 - rho_inf = 6.8e-5 + mach_inf = 1.31 + rho_inf = 6.8e-5 pres_inf = 5.9e-6 - cs_inf = sqrt(gamma*pres_inf/rho_inf) - v_inf = BHL_mach*cs_inf + cs_inf = sqrt(gamma*pres_inf/rho_inf) + v_inf = mach_inf*cs_inf ! Star parameters - BHL_r_star = 0.1 + Rstar = 0.1 Mstar = 1.e-3 - nstar = 1000 - pmass = Mstar / real(nstar) - massoftype(igas) = pmass + nstar = 1000000 lattice = 'closepacked' use_exactN = .true. + pmass = Mstar / real(nstar) + massoftype(igas) = pmass ! Wind injection settings - BHL_closepacked = 1. ! do not change, this is hardwired at the moment + lattice_type = 1 BHL_handled_layers = 4. - BHL_wind_cylinder_radius = 5. ! in units of Rstar + BHL_wind_cylinder_radius = 10. ! in units of Rstar BHL_wind_injection_x = -5. ! in units of Rstar - BHL_wind_length = 20. ! in units of Rstar - - ! Calculate particle separation between layers given rho_inf, depending on lattice type - element_volume = pmass / rho_inf - if (BHL_closepacked == 1.) then - BHL_psep = (sqrt(2.)*element_volume)**(1./3.) - else - BHL_psep = element_volume**(1./3.) - endif - BHL_psep = BHL_psep / BHL_r_star ! need to provide in units of Rstar, separation between layers of wind particle + BHL_wind_length = 50. ! in units of Rstar ! Set default tmax and dtmax - rho_star = Mstar/BHL_r_star**3 - tcrush = 2.*BHL_r_star*sqrt(rho_star/rho_inf)/v_inf - dtmax = 1.6*0.05*tcrush + rho_star = Mstar/Rstar**3 + tcrush = 2.*Rstar*sqrt(rho_star/rho_inf)/v_inf + dtmax = 0.1!1.6*0.05*tcrush tmax = 1.6*2.5*tcrush ! Initialise particle injection @@ -114,14 +108,24 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, xyzh(:,:) = 0. vxyzu(:,:) = 0. - ! Set star - allocate(r(nrhotab),den(nrhotab)) - call rho_polytrope(gamma,polyk,Mstar,r,den,npts,rhocentre,set_polyk=.true.,Rstar=BHL_r_star) + ! 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,BHL_r_star,Mstar,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 - deallocate(r,den) + ! 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 + nstar = npart + + deallocate(r,den,pres) print*, "udist = ", udist, "; umass = ", umass, "; utime = ", utime From a5ee42a1afaf39b622aa60fd46476250738a530d Mon Sep 17 00:00:00 2001 From: Elisabeth Borchert Date: Tue, 12 Sep 2023 12:17:24 +1000 Subject: [PATCH 105/814] BUGFIX - fixes #434 --- src/setup/set_disc.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/setup/set_disc.F90 b/src/setup/set_disc.F90 index 6d37bf634..b1f981f49 100644 --- a/src/setup/set_disc.F90 +++ b/src/setup/set_disc.F90 @@ -323,6 +323,13 @@ subroutine set_disc(id,master,mixture,nparttot,npart,npart_start,rmin,rmax, & ! sigma_normdust = 1.d0 if (do_mixture) then + if (present(r_grid)) then + rad_tmp = r_grid + else + do i=1,maxbins + rad_tmp(i) = R_indust + (i-1) * (R_outdust-R_indust)/real(maxbins-1) + enddo + endif !--sigma_normdust set from dust disc mass call get_disc_mass(disc_mdust,enc_m_tmp,rad_tmp,Q_tmp,sigmaprofiledust, & sigma_normdust,star_m,p_indexdust,q_inddust, & From b757b2811cec454004b581b355c8ab14cced97ca Mon Sep 17 00:00:00 2001 From: Miguel Gonzalez-Bolivar Date: Wed, 13 Sep 2023 17:05:11 +1000 Subject: [PATCH 106/814] Fix NaN values in Roche option in CE_analysis --- src/utils/analysis_common_envelope.f90 | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index b9594dd3d..c28178265 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -1162,8 +1162,19 @@ subroutine roche_lobe_values(time,npart,particlemass,xyzh,vxyzu) endif enddo - MRL(iR1T) = MRL(iR1T) / real(nR1T) - MRL(iFBV) = MRL(iFBV) / real(nFB) + if (nR1T == 0) then + MRL(iR1T) = 0 + else + MRL(iR1T) = MRL(iR1T) / real(nR1T) + endif + + if (nFB == 0) then + MRL(iFBV) = 0 + else + MRL(iFBV) = MRL(iFBV) / real(nFB) + endif + + MRL(iMRL1) = MRL(iMRL1) + xyzmh_ptmass(4,1) MRL(iMRL2) = MRL(iMRL2) + xyzmh_ptmass(4,2) From 234d00ddda960a5169234a0ba063a08528f32d22 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Sun, 17 Sep 2023 01:49:42 +1000 Subject: [PATCH 107/814] (windtunnel) tweak setup parameters --- build/Makefile_setups | 1 + src/setup/setup_windtunnel.f90 | 12 ++++++------ 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/build/Makefile_setups b/build/Makefile_setups index 9c4ba967a..c4a301da2 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -838,6 +838,7 @@ ifeq ($(SETUP), windtunnel) GRAVITY=yes KNOWN_SETUP=yes IND_TIMESTEPS=yes + ANALYSIS=analysis_common_envelope.f90 endif ifeq ($(SETUP), jet) diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index ddd88137a..2e6e5fc1f 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -72,16 +72,16 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, hfact = hfact_default ! Wind parameters (see inject_BHL module) - mach_inf = 1.31 - rho_inf = 6.8e-5 - pres_inf = 5.9e-6 + mach_inf = 1.55 + rho_inf = 0.0068 + pres_inf = 5.64e-4 cs_inf = sqrt(gamma*pres_inf/rho_inf) v_inf = mach_inf*cs_inf ! Star parameters Rstar = 0.1 Mstar = 1.e-3 - nstar = 1000000 + nstar = 10000000 lattice = 'closepacked' use_exactN = .true. pmass = Mstar / real(nstar) @@ -92,13 +92,13 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, BHL_handled_layers = 4. BHL_wind_cylinder_radius = 10. ! in units of Rstar BHL_wind_injection_x = -5. ! in units of Rstar - BHL_wind_length = 50. ! in units of Rstar + BHL_wind_length = 20. ! in units of Rstar ! Set default tmax and dtmax rho_star = Mstar/Rstar**3 tcrush = 2.*Rstar*sqrt(rho_star/rho_inf)/v_inf dtmax = 0.1!1.6*0.05*tcrush - tmax = 1.6*2.5*tcrush + tmax = 45.2!1.6*2.5*tcrush ! Initialise particle injection call init_inject(ierr) From 7d22e0e2089a0840022bacaccfe6ae2d8eb2c40e Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Wed, 20 Sep 2023 11:55:01 +1000 Subject: [PATCH 108/814] Added documentation for phantomNR and fixed rad dom setup --- docs/phantomNR.rst | 79 ++++++++++++++++++++++++++++++++++++++++ src/main/config.F90 | 9 +++++ src/setup/setup_flrw.f90 | 18 ++++++--- 3 files changed, 101 insertions(+), 5 deletions(-) create mode 100644 docs/phantomNR.rst diff --git a/docs/phantomNR.rst b/docs/phantomNR.rst new file mode 100644 index 000000000..00bc1d662 --- /dev/null +++ b/docs/phantomNR.rst @@ -0,0 +1,79 @@ +PhantomNR +========= + +Using PhantomNR to simulate general relativistic hydrodynamics on dynamical spacetimes +-------------------------------------------------------------------------------------- + +About phantomNR +~~~~~~~~~~~~~~~ + +`phantomNR `__ is +an extension to the General Relativistic Smoothed Particle Hydrodynamics code Phantom, +that allows for the evolution of relativistic fluids with evolving spacetime metrics. +This is acomplished via coupling with the numerical relativity framework Einstein Toolkit (ET). +phantomNR's current usage is as a fully relativistic N-Body code for the simulation of inhomogenous +cosmologies (see `Magnall et al. 2023 `__). +Einstein Toolkit acts as a "driver" for both the spacetime evolution, and the hydrodynamic evolution. +As a consquence, simulations are started and mointered entirely within ET, and are setup using a .par +parameter file which describes the parameters of the simulation. In addition, phantomNR also requires +particle information, which is provided via the standard phantom dump file. + + +Compilation and linking +~~~~~~~~~~~~~~~~~~~~~~~ +You will first need to compile phantom and phantomsetup +using the flrw setup + +:: + + scripts/writemake.sh flrw > Makefile + + make; make setup + +which compiles the libphantom.a static library which is +required for linking and the phantom and phantomsetup binaries. + +You will also need to set the include directory of phantom in Einstein Toolkit +e.g: + +:: + + PHANTOM_DIR = /Users/smag0001/phantom/phantomET/bin + +Generating a phantom dump file from phantom setup +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Particles can be setup using phantomsetup in two ways: + +1. **Using a regular .setup file** + e.g ./phantomsetup flrw.setup will produce a dump file and .in file using an interactive setup routine. + + +3. **Using a .par file** By appending .setup to the end of an Einstein Toolkit parameter file, phantomsetup + will automatically read in (most) relevant quantities about the simulation setup and generate an appropriate + distribution of particles + + +Troubleshooting +--------------- + +**Issue**: Large Constraint Violations + + + +**Solution**: Generally, this is indicative of a mismatch between the spacetime setup by Einstein Toolkit +and the particle distribution which is setup by Phantom. A large raw constraint violation, may not always be indicative +of a poorly initialised setup however. It is important to check the relative constraint violations (TODO insert equations) + +In many cases, a poor initial constraint is simply a consquence of not setting spacetime and consistently (e.g phi=1e-4 for particles, but phi=1e-6 for spacetime). +We reccomend that the .in and dumpfiles are generated using the .par file of Einstein Toolkit to alleviate this issue. + +Constraint violations may also occur due to a low particle and/or grid resolution + + + + +Using phantomNR on Ozstar/NT +------------------------------- + + diff --git a/src/main/config.F90 b/src/main/config.F90 index bb548a994..561adf30e 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -270,6 +270,15 @@ module dim logical, parameter :: gr = .false. #endif +!--------------------- +! Numerical relativity +!--------------------- +#ifdef NR + logical, parameter :: nr = .true. +#else + logical, parameter :: nr = .false. +#endif + !-------------------- ! Supertimestepping !-------------------- diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index d3e9851d2..d67e6396f 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -38,6 +38,7 @@ module setup real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,Bzero,ampl,phaseoffset character(len=20) :: dist_unit,mass_unit,perturb_direction,perturb,radiation_dominated real :: perturb_wavelength + real :: rho_matter real(kind=8) :: udist,umass !--change default defaults to reproduce the test from Section 5.6.7 of Price+(2018) @@ -132,15 +133,16 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Then it should be set using the Friedmann equation: !!!!!! rhozero = (3H^2)/(8*pi*a*a) - hub = 10.553495658357338!/10.d0 + hub = 10.553495658357338 !hub = 23.588901903912664 !hub = 0.06472086375185665 rhozero = 3.d0 * hub**2 / (8.d0 * pi) phaseoffset = 0. ! Approx Temp of the CMB in Kelvins - last_scattering_temp = 3000 - last_scattering_temp = (rhozero/radconst)**(1./4.)*0.999999999999999d0 + !last_scattering_temp = 3000 + !last_scattering_temp = (rhozero/radconst)**(1./4.)*0.999999999999999d0 + last_scattering_temp = 0. ! Define some parameters for Linear pertubations ! We assume ainit = 1, but this may not always be the case @@ -209,7 +211,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, select case(radiation_dominated) case('"yes"') - rhozero = rhozero - radconst*last_scattering_temp**4 + ! Set a value of rho_matter + rho_matter = 1.e-20 + !rhozero = rhozero - radconst*last_scattering_temp**4 + ! Solve for temperature + last_scattering_temp = ((rhozero-rho_matter)/radconst)**(1./4.) + rhozero = rho_matter end select xval = density_func(0.75) @@ -255,7 +262,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, totmass = rhozero*dxbound*dybound*dzbound - massoftype = totmass/npart_total + massoftype(1) = totmass/npart_total if (id==master) print*,' particle mass = ',massoftype(1) if (id==master) print*,' initial sound speed = ',cs0,' pressure = ',cs0**2/gamma @@ -325,6 +332,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, print*, "Pressure: ", (gamma-1)*rhozero*vxyzu(4,i) print*, "Pressure from energy density: ", 3.d0 * hub**2 / (8.d0 * pi)/3. print*, "Pressure 1/3 \rho u: ",radconst*(last_scattering_temp**4)/3. + print*, "particle mass: ", massoftype end select enddo From e3fce20d1496c80b02c6e3e77b68e53d8c0e5858 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 22 Sep 2023 14:56:02 +1000 Subject: [PATCH 109/814] (analysis_dustformation) added analysis routine to compute time of dust formation --- src/utils/analysis_dustformation.f90 | 91 ++++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) create mode 100644 src/utils/analysis_dustformation.f90 diff --git a/src/utils/analysis_dustformation.f90 b/src/utils/analysis_dustformation.f90 new file mode 100644 index 000000000..489c57789 --- /dev/null +++ b/src/utils/analysis_dustformation.f90 @@ -0,0 +1,91 @@ +!--------------------------------------------------------------------------! +! 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 analysis +! +! Analysis routine computing the time of dust formation for +! each SPH particle +! +! :References: Bermudez-Bustamante et al. (2023), submitted to MNRAS +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: None +! + implicit none + character(len=20), parameter, public :: analysistype = 'dustformation' + public :: do_analysis + + private + real, allocatable :: t_formation(:) + +contains + +subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) + use dim, only:do_nucleation + use part, only:nucleation,idK0,idK1 + use units, only:utime + use physcon, only:years + use fileutils, only:basename + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: num,npart,iunit + real, intent(in) :: xyzh(:,:),vxyzu(:,:) + real, intent(in) :: particlemass,time + integer :: i,n,ntot,iu,j + real :: K0,K1,rdust + character(len=30) :: filename + + if (.not.do_nucleation) then + stop 'ERROR: need DUST_NUCLEATION=yes for this analysis type' + endif + + if (.not.allocated(t_formation)) then + allocate(t_formation(npart)) + t_formation = 0 + endif + + if (npart > size(t_formation)) then + print*,' ERROR npart > npart_in, skipping analysis for '//trim(dumpfile) + return + endif + + n = 0 + ntot = 0 + do i=1,npart + if (t_formation(i) <= 0.) then + K0 = nucleation(idK0,i) + K1 = nucleation(idK1,i) + rdust = 1.28e-04*K1/(K0+tiny(0.)) + if (rdust > 1.e-3) then + t_formation(i) = time*utime/years + n = n + 1 + endif + else + ntot = ntot + 1 + endif + enddo + + print*,' time is ',time*utime/years,' years' + print*,' dust formation just started on ',n,' particles, total particles with dust = ',ntot+n,' / ',npart + if (n > 1) then + filename = trim(basename(dumpfile)) + j = index(filename,'_',back=.true.) - 1 + if (j <= 0) j = len_trim(filename) + filename = filename(1:j)//'.comp' + print*,' writing to '//trim(filename) + open(newunit=iu,file=trim(filename),status='replace') + write(iu,*) '# t_{formation}' + do i=1,npart + write(iu,*) t_formation(i) + enddo + close(iu) + endif + +end subroutine do_analysis + +end module analysis From 46d5a79f10fff0c2f12602aa22804e734ac78705 Mon Sep 17 00:00:00 2001 From: fhu Date: Thu, 17 Aug 2023 11:13:53 +1000 Subject: [PATCH 110/814] (step_leapfrog) schedule omp do loop --- src/main/step_leapfrog.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 5e4ca24b0..c54602fd5 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -823,7 +823,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me ! ! predictor step for external forces, also recompute external forces ! - !$omp parallel do default(none) & + !$omp parallel do default(none) schedule(runtime) & !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype) & !$omp shared(maxphase,maxp,eos_vars) & !$omp shared(dt,hdt,xtol,ptol) & @@ -957,7 +957,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me !$omp reduction(min:dtextforce_min) & !$omp reduction(+:accretedmass,naccreted,nlive) & !$omp shared(idamp,damp_fac) - !$omp do + !$omp do schedule(runtime) accreteloop: do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then if (ntypes > 1 .and. maxphase==maxp) then From 2ad72ff6a97abf993b332fa9c9fb866e04a8fc29 Mon Sep 17 00:00:00 2001 From: fhu Date: Sun, 24 Sep 2023 22:02:55 +1000 Subject: [PATCH 111/814] (analysis_radiotde) analysis file for radio tde --- src/utils/analysis_radiotde.f90 | 303 ++++++++++++++++++++++++++++++++ 1 file changed, 303 insertions(+) create mode 100644 src/utils/analysis_radiotde.f90 diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 new file mode 100644 index 000000000..0a9f24490 --- /dev/null +++ b/src/utils/analysis_radiotde.f90 @@ -0,0 +1,303 @@ +!--------------------------------------------------------------------------! +! 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 analysis +! +! Computes the outflow profile in a TDE simulation +! +! :References: None +! +! :Owner: Fitz Hu +! +! :Runtime parameters: +! - angmax : *max angular momentum* +! - angmin : *min angular momentum* +! - emax : *max energy* +! - emin : *min energy* +! - lummax : *max luminosity* +! - lummin : *min luminosity* +! - mh : *black hole mass in code units* +! - nbins : *number of bins* +! - rmax : *max radius* +! - rmin : *min radius* +! - trmax : *max return time* +! - trmin : *min return time* +! - vmax : *max velocity* +! - vmin : *min velocity* +! +! :Dependencies: dump_utils, infile_utils, io, physcon, prompting, +! readwrite_dumps, sortutils, vectorutils +! + implicit none + character(len=8), parameter, public :: analysistype = 'radiotde' + public :: do_analysis + + private + + real, dimension(:), allocatable :: theta,plot_theta,phi,vr,vtheta,vphi + logical, dimension(:), allocatable :: cap + + !---- These can be changed in the params file + integer :: nbins + !--- If min=max then lims are set dynamically + real :: rad_cap = 1.e16 ! radius where the outflow in captured (in cm) + real :: drad_cap = 4.7267e14 ! thickness of the shell to capture outflow (in cm) + real :: v_min = 0. + real :: v_max = 1. + real :: theta_min = -180. + real :: theta_max = 180. + real :: phi_min = -90. + real :: phi_max = 90. + real :: m_accum, m_cap, vr_accum_mean, vr_cap_mean, v_accum_mean, v_cap_mean, e_accum, e_cap + integer :: n_accum, n_cap + +contains + +subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) + use readwrite_dumps, only: opened_full_dump + use units, only: utime,udist,unit_energ,umass + use physcon, only: solarm,days + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: numfile,npart,iunit + real, intent(in) :: xyzh(:,:),vxyzu(:,:) + real, intent(in) :: pmass,time + character(len=120) :: output,prefile + character(len=30) :: filename + integer :: i,ierr,j + logical :: iexist + real :: val,toMsun,todays + + m_accum = 0. + n_accum = 0 + m_cap = 0. + n_cap = 0 + e_accum = 0. + e_cap = 0. + + toMsun = umass/solarm + todays = utime/days + + if (.not.opened_full_dump) then + write(*,'("SKIPPING FILE -- (Not a full dump)")') + return + endif + +! Print the analysis being done + write(*,'("Performing analysis type ",A)') analysistype + write(*,'("Input file name is ",A)') dumpfile + + write(output,"(a8,i5.5)") 'outflow_',numfile + write(*,'("Output file name is ",A)') output + + ! Read black hole mass from params file + filename = 'analysis_'//trim(analysistype)//'.params' + inquire(file=filename,exist=iexist) + if (iexist) call read_tdeparams(filename,ierr) + if (.not.iexist.or.ierr/=0) then + call write_tdeparams(filename) + print*,' Edit '//trim(filename)//' and rerun phantomanalysis' + stop + endif + + rad_cap = rad_cap/udist + if (drad_cap < 0.) then + drad_cap = huge(0.) + else + drad_cap = drad_cap/udist + endif + print*, 'Capture particles from', rad_cap, 'to', rad_cap+drad_cap + + allocate(theta(npart),plot_theta(npart),phi(npart),vr(npart),vtheta(npart),vphi(npart),cap(npart)) + cap = .false. + + call tde_analysis(npart,pmass,xyzh,vxyzu) + + if (n_cap > 0) then + open(iunit,file=output) + write(iunit,'("# ",es20.12," # TIME")') time + write(iunit,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & + 1,'theta', & + 2,'thetap', & + 3,'phi', & + 4,'vr', & + 5,'vtheta', & + 6,'vphi' + + do i = 1,npart + if (cap(i)) then + write(iunit,'(6(es18.10,1X))') & + theta(i), & + plot_theta(i), & + phi(i), & + vr(i), & + vtheta(i), & + vphi(i) + endif + enddo + close(iunit) + endif + + deallocate(theta(npart),plot_theta(npart),phi(npart),vr(npart),vtheta(npart),vphi(npart),cap(npart)) + + inquire(file='outflows',exist=iexist) + if (iexist) then + open(iunit,file='outflows',status='old',access='append') + else + open(iunit,file='outflows',status='new') + write(iunit,*) '# time, m_cap[msun], m_accum[msun], & + vr_accum_mean[c], vr_cap_mean[c], v_accum_mean[c], & + v_cap_mean[c], e_accum[erg], e_cap[erg]' + endif + write(iunit,'(9(es18.10,1x))') & + time*todays, & + m_cap*toMsun, & + m_accum*toMsun, & + vr_accum_mean, & + vr_cap_mean, & + v_accum_mean, & + v_cap_mean, & + e_accum*unit_energ, & + e_cap*unit_energ + close(iunit) + + write(*,'(I8,1X,A2,1X,I8,1X,A34)') n_cap, 'of', npart, 'particles are in the capture shell' + write(*,'(I8,1X,A2,1X,I8,1X,A40)') n_accum, 'of', npart, 'particles are outside the capture radius' + +end subroutine do_analysis + +!-------------------------------------------------------------------------------------------------------------------- +! +!-- Actual subroutine where the analysis is done! +! +!-------------------------------------------------------------------------------------------------------------------- +subroutine tde_analysis(npart,pmass,xyzh,vxyzu) + integer, intent(in) :: npart + real, intent(in) :: pmass,xyzh(:,:),vxyzu(:,:) + integer :: i + real :: r,v,x,y,z,xyz(1:3),vx,vy,vz,vxyz(1:3) + real :: thetai,phii,vri + real :: vr_accum_add,vr_cap_add,v_accum_add,v_cap_add + + vr_accum_add = 0. + vr_cap_add = 0. + v_accum_add = 0. + v_cap_add = 0. + + do i = 1,npart + x = xyzh(1,i) + y = xyzh(2,i) + z = xyzh(3,i) + xyz = (/x,y,z/) + vx = vxyzu(1,i) + vy = vxyzu(2,i) + vz = vxyzu(3,i) + vxyz = (/vx,vy,vz/) + r = sqrt(dot_product(xyz,xyz)) + v = sqrt(dot_product(vxyz,vxyz)) + !print*, 'x', xyz, r + !print*, 'v', vxyz, sqrt(dot_product(vxyz,vxyz)) + if (r > rad_cap) then + m_accum = m_accum + pmass + n_accum = n_accum + 1 + e_accum = e_accum + 0.5*pmass*v**2 + !print*, dot_product(vxyz,xyz)/r, cosd(phii)*sind(thetai)*vx + sind(phii)*sind(thetai)*vy + cosd(thetai)*vz + vri = dot_product(vxyz,xyz)/r !cosd(phii)*sind(thetai)*vx + sind(phii)*sind(thetai)*vy + cosd(thetai)*vz + if (vri < 0) print*, vxyz, xyz, r + vr_accum_add = vr_accum_add + vri + v_accum_add = v_accum_add + v + if (r-rad_cap < drad_cap .and. (v .ge. v_min .and. v .le. v_max)) then + thetai = atan2d(y,x) + phii = atan2d(z,sqrt(x**2+y**2)) + if ((thetai .ge. theta_min .and. thetai .le. theta_max) .and. (phii .ge. phi_min .and. phii .le. phi_max)) then + m_cap = m_cap + pmass + n_cap = n_cap + 1 + cap(i) = .true. + theta(i) = thetai + phi(i) = phii + plot_theta(i) = theta(i) * sqrt(cosd(phi(i))) + vr(i) = vri + vtheta(i) = -sind(phii)*vx + cosd(phii)*vy + vphi(i) = cosd(thetai)*cosd(phii)*vx + cosd(thetai)*sind(phii)*vy - sind(thetai)*vz + e_cap = e_cap + 0.5*pmass*v**2 + vr_cap_add = vr_cap_add + vri + v_cap_add = v_cap_add + v + endif + endif + endif + enddo + vr_accum_mean = vr_accum_add/n_accum + v_accum_mean = v_accum_add/n_accum + vr_cap_mean = vr_cap_add/n_cap + v_cap_mean = v_cap_add/n_cap + +end subroutine tde_analysis + +!---------------------------------------------------------------- +!+ +! Read/write tde information from/to params file +!+ +!---------------------------------------------------------------- +subroutine write_tdeparams(filename) + use infile_utils, only:write_inopt + character(len=*), intent(in) :: filename + integer, parameter :: iunit = 20 + + print "(a)",' writing analysis options file '//trim(filename) + open(unit=iunit,file=filename,status='replace',form='formatted') + write(iunit,"(a,/)") '# options when performing radio TDE analysis' + + call write_inopt(rad_cap,'rad_cap','capture inner radius (in cm)',iunit) + call write_inopt(drad_cap,'drad_cap','capture thickness (in cm) (-ve for all particles at outer radius)',iunit) + + call write_inopt(v_min,'v_min','min velocity (in c)',iunit) + call write_inopt(v_max,'v_max','max velocity (in c)',iunit) + + call write_inopt(theta_min,'theta_min','min theta (in deg)',iunit) + call write_inopt(theta_max,'theta_max','max theta (in deg)',iunit) + + call write_inopt(phi_min,'phi_min','min phi (in deg)',iunit) + call write_inopt(phi_max,'phi_max','max phi (in deg)',iunit) + + close(iunit) + +end subroutine write_tdeparams + +subroutine read_tdeparams(filename,ierr) + use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db + use io, only:error + character(len=*), intent(in) :: filename + integer, intent(out) :: ierr + integer, parameter :: iunit = 21 + integer :: nerr + type(inopts), allocatable :: db(:) + + print "(a)",'reading analysis options from '//trim(filename) + nerr = 0 + ierr = 0 + call open_db_from_file(db,filename,iunit,ierr) + + call read_inopt(rad_cap,'rad_cap',db,min=0.,errcount=nerr) + call read_inopt(drad_cap,'drad_cap',db,errcount=nerr) + + call read_inopt(v_min,'v_min',db,min=0.,max=1.,errcount=nerr) + call read_inopt(v_max,'v_max',db,min=0.,max=1.,errcount=nerr) + + call read_inopt(theta_min,'theta_min',db,min=-180.,max=180.,errcount=nerr) + call read_inopt(theta_max,'theta_max',db,min=-180.,max=180.,errcount=nerr) + + call read_inopt(phi_min,'phi_min',db,min=-90.,max=90.,errcount=nerr) + call read_inopt(phi_max,'phi_max',db,min=-90.,max=90.,errcount=nerr) + + call close_db(db) + if (nerr > 0) then + print "(1x,i2,a)",nerr,' error(s) during read of params file: re-writing...' + ierr = nerr + endif + +end subroutine read_tdeparams + +end module analysis + From ab6aaa245937f6128f1cc9126b8a515960ea8df2 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 29 Sep 2023 00:54:43 +1000 Subject: [PATCH 112/814] (windtunnel) rename variables in injection module --- src/main/inject_windtunnel.f90 | 166 +++++++++++++++++++-------------- 1 file changed, 95 insertions(+), 71 deletions(-) diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 85a43f9f7..c51be1351 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -12,13 +12,13 @@ module inject ! :Owner: Mike Lau ! ! :Runtime parameters: -! - lattice_type : *0: cubic distribution, 1: closepacked distribution* -! - BHL_handled_layers : *(integer) number of handled BHL wind layers* -! - mach_inf : *BHL wind mach number* -! - Rstar : *BHL star radius (in accretion radii)* -! - BHL_radius : *radius of the wind cylinder (in star radii)* -! - BHL_wind_injection_x : *x position of the wind injection boundary (in star radii)* -! - BHL_wind_length : *crude wind length (in star radii)* +! - lattice_type : *0: cubic distribution, 1: closepacked distribution* +! - handled_layers : *(integer) number of handled BHL wind layers* +! - v_inf : *BHL wind speed* +! - Rstar : *BHL star radius (in accretion radii)* +! - BHL_radius : *radius of the wind cylinder (in star radii)* +! - wind_injection_x : *x position of the wind injection boundary (in star radii)* +! - wind_length : *crude wind length (in star radii)* ! ! :Dependencies: dim, eos, infile_utils, io, part, partinject, physcon, ! units @@ -32,23 +32,22 @@ module inject !--runtime settings for this module ! ! Main parameters: model MS6 from Ruffert & Arnett (1994) - real, public :: mach_inf = 1. + real, public :: v_inf = 1. real, public :: rho_inf = 1. - real, public :: cs_inf = 1. + real, public :: pres_inf = 1. real, public :: Rstar = .1 integer, public :: nstar = 0 ! Particle-related parameters integer, public :: lattice_type = 1 - real, public :: BHL_handled_layers = 4. - real, public :: BHL_wind_cylinder_radius = 30. - real, public :: BHL_wind_injection_x = -10. - real, public :: BHL_wind_length = 100. + real, public :: handled_layers = 4 + real, public :: wind_radius = 30. + real, public :: wind_injection_x = -10. + real, public :: wind_length = 100. private - integer :: handled_layers - real :: wind_cylinder_radius,wind_injection_x,psep,distance_between_layers,& - time_between_layers,h_inf,u_inf,v_inf + real :: wind_rad,wind_x,psep,distance_between_layers,& + time_between_layers,h_inf,u_inf integer :: max_layers,max_particles,nodd,neven logical :: first_run = .true. real, allocatable :: layer_even(:,:),layer_odd(:,:) @@ -68,16 +67,16 @@ subroutine init_inject(ierr) use dim, only:maxp use io, only:fatal integer, intent(out) :: ierr - real :: pmass,element_volume,y,z + real :: pmass,element_volume,y,z,cs_inf,mach integer :: size_y, size_z, pass, i, j ierr = 0 - v_inf = mach_inf*cs_inf - u_inf = cs_inf**2 / (gamma*(gamma-1.)) - handled_layers = int(BHL_handled_layers) - wind_cylinder_radius = BHL_wind_cylinder_radius * Rstar - wind_injection_x = BHL_wind_injection_x * Rstar + u_inf = pres_inf / (rho_inf*(gamma-1.)) + cs_inf = sqrt(gamma*pres_inf/rho_inf) + mach = v_inf/cs_inf + wind_rad = wind_radius * Rstar + wind_x = wind_injection_x * Rstar pmass = massoftype(igas) ! Calculate particle separation between layers given rho_inf, depending on lattice type @@ -92,8 +91,8 @@ subroutine init_inject(ierr) if (lattice_type == 1) then distance_between_layers = psep*sqrt(6.)/3. - size_y = ceiling(3.*wind_cylinder_radius/psep) - size_z = ceiling(3.*wind_cylinder_radius/(sqrt(3.)*psep/2.)) + size_y = ceiling(3.*wind_rad/psep) + size_z = ceiling(3.*wind_rad/(sqrt(3.)*psep/2.)) do pass=1,2 if (pass == 2) then if (allocated(layer_even)) deallocate(layer_even) @@ -105,17 +104,17 @@ subroutine init_inject(ierr) do i=1,size_y do j=1,size_z ! Even layer - y = -1.5*wind_cylinder_radius + (i-1)*psep - z = -1.5*wind_cylinder_radius + (j-1)*psep*sqrt(3.)/2. + y = -1.5*wind_rad + (i-1)*psep + z = -1.5*wind_rad + (j-1)*psep*sqrt(3.)/2. if (mod(j,2) == 0) y = y + .5*psep - if (y**2+z**2 < wind_cylinder_radius**2) then + if (y**2+z**2 < wind_rad**2) then neven = neven + 1 if (pass == 2) layer_even(:,neven) = (/ y,z /) endif ! Odd layer y = y + psep*.5 z = z + psep*sqrt(3.)/6. - if (y**2+z**2 < wind_cylinder_radius**2) then + if (y**2+z**2 < wind_rad**2) then nodd = nodd + 1 if (pass == 2) layer_odd(:,nodd) = (/ y,z /) endif @@ -124,16 +123,16 @@ subroutine init_inject(ierr) enddo else distance_between_layers = psep - size_y = ceiling(3.*wind_cylinder_radius/psep) + size_y = ceiling(3.*wind_rad/psep) size_z = size_y do pass=1,2 if (pass == 2) allocate(layer_even(2,neven), layer_odd(2,neven)) neven = 0 do i=1,size_y do j=1,size_z - y = -1.5*wind_cylinder_radius+(i-1)*psep - z = -1.5*wind_cylinder_radius+(j-1)*psep - if (y**2+z**2 < wind_cylinder_radius**2) then + y = -1.5*wind_rad+(i-1)*psep + z = -1.5*wind_rad+(j-1)*psep + if (y**2+z**2 < wind_rad**2) then neven = neven + 1 if (pass == 2) layer_even(:,neven) = (/ y,z /) endif @@ -142,20 +141,14 @@ subroutine init_inject(ierr) enddo layer_odd(:,:) = layer_even(:,:) endif - max_layers = int(BHL_wind_length*Rstar/distance_between_layers) + 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 - print *, 'BHL maximum layers: ', max_layers - print *, 'BHL maximum particles: ', max_particles - print *, 'nstar: ',nstar - if (max_particles > maxp) call fatal('BHL', 'maxp too small for this simulation, please increase MAXP!') time_between_layers = distance_between_layers/v_inf - print *, 'distance_between_layers: ',distance_between_layers - print *, 'time_between_layers: ',time_between_layers - print *, 'pmass: ',pmass - h_inf = hfact*(pmass/rho_inf)**(1./3.) - !if (setup) then -! tmax = (100.*abs(wind_injection_x)/v_inf)/utime -! endif + + if (max_particles > maxp) call fatal('windtunnel', 'maxp too small for this simulation, please increase MAXP!') + + call print_summary(v_inf,cs_inf,rho_inf,pres_inf,mach,pmass,distance_between_layers,time_between_layers,max_layers,nstar,max_particles) end subroutine init_inject @@ -200,7 +193,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& xyz(2:3,:) = layer_odd(:,:) np = nodd endif - x = wind_injection_x + local_time*v_inf + x = wind_x + local_time*v_inf xyz(1,:) = x vxyz(1,:) = v_inf vxyz(2:3,:) = 0. @@ -256,6 +249,37 @@ subroutine inject_or_update_particles(ifirst, n, position, velocity, h, u, bound end subroutine inject_or_update_particles + +!----------------------------------------------------------------------- +!+ +! Print summary of wind properties (assumes inputs are in code units) +!+ +!----------------------------------------------------------------------- +subroutine print_summary(v_inf,cs_inf,rho_inf,pres_inf,mach,pmass,distance_between_layers,& + time_between_layers,max_layers,nstar,max_particles) + use units, only:unit_velocity,unit_pressure,unit_density + real, intent(in) :: v_inf,cs_inf,rho_inf,pres_inf,mach,pmass,distance_between_layers,time_between_layers + integer, intent(in) :: max_layers,nstar,max_particles + + print*, 'wind speed: ',v_inf * unit_velocity / 1e5," km s^-1" + print*, 'wind cs: ',cs_inf * unit_velocity / 1e5," km s^-1" + print*, 'wind density: ',rho_inf * unit_density," g cm^-3" + print*, 'wind pressure: ',pres_inf * unit_pressure," dyn cm^-2" + print*, 'wind mach number: ', mach + + print*, 'maximum wind layers: ', max_layers + print*, 'pmass: ',pmass + print*, 'nstar: ',nstar + print*, 'nstar + max. wind particles: ', max_particles + print*, 'distance_between_layers: ',distance_between_layers + print*, 'time_between_layers: ',time_between_layers + + print*, 'planet crossing time: ',2*Rstar/v_inf + print*, 'wind impact time: ',(abs(wind_injection_x) - Rstar)/v_inf + +end subroutine print_summary + + !----------------------------------------------------------------------- !+ ! Writes input options to the input file @@ -265,19 +289,20 @@ subroutine write_options_inject(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit - call write_inopt(mach_inf,'mach_inf','BHL wind mach number',iunit) - call write_inopt(cs_inf,'cs_inf','ambient sound speed',iunit) - call write_inopt(rho_inf,'rho_inf','ambient density',iunit) - call write_inopt(Rstar,'Rstar','BHL star radius (in accretion radii)',iunit) - call write_inopt(nstar,'nstar','No. of particles making up star',iunit) + call write_inopt(v_inf,'v_inf','wind speed (code units)',iunit) + call write_inopt(pres_inf,'pres_inf','ambient pressure (code units)',iunit) + call write_inopt(rho_inf,'rho_inf','ambient density (code units)',iunit) + call write_inopt(Rstar,'Rstar','sphere radius (code units)',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(BHL_handled_layers,'BHL_handled_layers','(integer) number of handled BHL wind layers',iunit) - call write_inopt(BHL_wind_cylinder_radius,'BHL_radius','radius of the wind cylinder (in star radii)',iunit) - call write_inopt(BHL_wind_injection_x,'BHL_wind_injection_x','x position of the wind injection boundary (in star radii)',iunit) - call write_inopt(BHL_wind_length,'BHL_wind_length','crude wind length (in star radii)',iunit) + call write_inopt(handled_layers,'handled_layers','(integer) number of handled BHL wind layers',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) end subroutine write_options_inject + !----------------------------------------------------------------------- !+ ! Reads input options from the input file. @@ -295,14 +320,14 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) imatch = .true. igotall = .false. select case(trim(name)) - case('mach_inf') - read(valstring,*,iostat=ierr) mach_inf + case('v_inf') + read(valstring,*,iostat=ierr) v_inf ngot = ngot + 1 - if (mach_inf <= 0.) call fatal(label,'invalid setting for mach_inf (<=0)') - case('cs_inf') - read(valstring,*,iostat=ierr) cs_inf + if (v_inf <= 0.) call fatal(label,'v_inf must be positive') + case('pres_inf') + read(valstring,*,iostat=ierr) pres_inf ngot = ngot + 1 - if (cs_inf <= 0.) call fatal(label,'cs_inf must be positive') + if (pres_inf <= 0.) call fatal(label,'pres_inf must be positive') case('rho_inf') read(valstring,*,iostat=ierr) rho_inf ngot = ngot + 1 @@ -318,22 +343,21 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) lattice_type ngot = ngot + 1 if (lattice_type/=0 .and. lattice_type/=1) call fatal(label,'lattice_type must be 0 or 1') - case('BHL_handled_layers') - read(valstring,*,iostat=ierr) BHL_handled_layers + case('handled_layers') + read(valstring,*,iostat=ierr) handled_layers ngot = ngot + 1 - if (dble(int(BHL_handled_layers)) /= BHL_handled_layers) call fatal(label,'BHL_handled_layers must be integer') - if (int(BHL_handled_layers) < 0) call fatal(label,'BHL_handled_layers must be positive or zero') + if (handled_layers < 0) call fatal(label,'handled_layers must be positive or zero') case('BHL_radius') - read(valstring,*,iostat=ierr) BHL_wind_cylinder_radius + read(valstring,*,iostat=ierr) wind_radius ngot = ngot + 1 - if (BHL_wind_cylinder_radius <= 0.) call fatal(label,'BHL_wind_cylinder_radius must be >0') - case('BHL_wind_injection_x') - read(valstring,*,iostat=ierr) BHL_wind_injection_x + if (wind_radius <= 0.) call fatal(label,'wind_radius must be >0') + case('wind_injection_x') + read(valstring,*,iostat=ierr) wind_injection_x ngot = ngot + 1 - case('BHL_wind_length') - read(valstring,*,iostat=ierr) BHL_wind_length + case('wind_length') + read(valstring,*,iostat=ierr) wind_length ngot = ngot + 1 - if (BHL_wind_length <= 0.) call fatal(label,'BHL_wind_length must be positive') + if (wind_length <= 0.) call fatal(label,'wind_length must be positive') end select igotall = (ngot >= 10) From 6a45826835f7d896b3647595f01c08e0dc61e7d2 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 29 Sep 2023 00:55:29 +1000 Subject: [PATCH 113/814] (windtunnel) use setupfile and take v, rho, pres as inputs --- src/setup/setup_windtunnel.f90 | 207 ++++++++++++++++++++++++++++----- 1 file changed, 179 insertions(+), 28 deletions(-) diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index 2e6e5fc1f..a697514b1 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -16,11 +16,16 @@ module setup ! ! :Dependencies: inject, part, physcon, units ! - use io, only:master + 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 implicit none public :: setpart + real :: Mstar + private contains @@ -37,16 +42,13 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use rho_profile, only:rho_polytrope use extern_densprofile, only:nrhotab use physcon, only:solarm,solarr - use units, only:udist,umass,utime,set_units - use inject, only:init_inject,nstar,Rstar,mach_inf,lattice_type,BHL_handled_layers,& - BHL_wind_cylinder_radius,BHL_wind_injection_x,BHL_wind_length,& - cs_inf,rho_inf + use units, only:udist,umass,utime,set_units,unit_velocity,unit_density,unit_pressure + use setunits, only:mass_unit,dist_unit use mpidomain, only:i_belong use timestep, only:dtmax,tmax use unifdis, only:mask_prototype use kernel, only:hfact_default use setup_params,only:rhozero,npart_total - use mpidomain, only:i_belong use table_utils, only:yinterp integer, intent(in) :: id integer, intent(inout) :: npart @@ -54,16 +56,21 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real, intent(out) :: xyzh(:,:),vxyzu(:,:),massoftype(:),polyk,gamma,hfact real, intent(inout) :: time character(len=20), intent(in) :: fileprefix - real :: rhocentre,rmin,tcrush,v_inf,pres_inf,pmass,rho_star,Mstar,densi,presi,ri + real :: rhocentre,rmin,pmass,densi,presi,ri real, allocatable :: r(:),den(:),pres(:) integer :: ierr,npts,np,i - logical :: use_exactN + logical :: use_exactN,setexists character(len=30) :: lattice + character(len=120) :: setupfile call set_units(mass=solarm,dist=solarr,G=1.) ! - !--general parameters + ! Initialise parameters, including those that will not be included in *.setup ! + ! units + mass_unit = 'solarm' + dist_unit = 'solarr' + time = 0. polyk = 1. ! not used but needs to be initialised to non-zero value gamma = 5./3. @@ -71,35 +78,51 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, gmw = 0.6 hfact = hfact_default - ! Wind parameters (see inject_BHL module) - mach_inf = 1.55 - rho_inf = 0.0068 - pres_inf = 5.64e-4 - cs_inf = sqrt(gamma*pres_inf/rho_inf) - v_inf = mach_inf*cs_inf + ! Wind parameters (see inject_windtunnel module) + v_inf = 230e5 / unit_velocity + rho_inf = 4.e-4 / unit_density + pres_inf = 6.6e10 / unit_pressure ! Star parameters Rstar = 0.1 Mstar = 1.e-3 - nstar = 10000000 + nstar = 1000 lattice = 'closepacked' use_exactN = .true. - pmass = Mstar / real(nstar) - massoftype(igas) = pmass ! Wind injection settings lattice_type = 1 - BHL_handled_layers = 4. - BHL_wind_cylinder_radius = 10. ! in units of Rstar - BHL_wind_injection_x = -5. ! in units of Rstar - BHL_wind_length = 20. ! in units of Rstar + handled_layers = 4 + wind_radius = 10. ! in units of Rstar + wind_injection_x = -2. ! in units of Rstar + wind_length = 15. ! in units of Rstar ! Set default tmax and dtmax - rho_star = Mstar/Rstar**3 - tcrush = 2.*Rstar*sqrt(rho_star/rho_inf)/v_inf - dtmax = 0.1!1.6*0.05*tcrush - tmax = 45.2!1.6*2.5*tcrush + dtmax = 0.1 + tmax = 6.8 + + ! determine if the .setup file exists + setupfile = trim(fileprefix)//'.setup' + inquire(file=setupfile,exist=setexists) + if (setexists) then + call read_setupfile(setupfile,ierr) + if (ierr /= 0) then + 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 default parameters' + call write_setupfile(setupfile) + stop 'please check and edit .setup file and rerun phantomsetup' + endif + call check_setup(pmass,ierr) + if (ierr /= 0) call fatal('windtunnel','errors in setup parameters') + pmass = Mstar / real(nstar) + massoftype(igas) = pmass + + ! Initialise particle injection call init_inject(ierr) npart = 0 @@ -123,13 +146,141 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, presi = yinterp(pres(1:npts),r(1:npts),ri) vxyzu(4,i) = presi / ( (gamma-1.) * densi) enddo - nstar = npart deallocate(r,den,pres) print*, "udist = ", udist, "; umass = ", umass, "; utime = ", utime end subroutine setpart + + + +!----------------------------------------------------------------------- +!+ +! Write setup parameters to input file +!+ +!----------------------------------------------------------------------- +subroutine write_setupfile(filename) + use infile_utils, only:write_inopt + use dim, only:tagline + use eos, only:gamma + use setunits, only:write_options_units + use units, only:unit_density,unit_pressure,unit_velocity + character(len=*), intent(in) :: filename + integer, parameter :: iunit = 20 + + write(*,"(a)") ' Writing '//trim(filename) + open(unit=iunit,file=filename,status='replace',form='formatted') + write(iunit,"(a)") '# '//trim(tagline) + write(iunit,"(a)") '# input file for Phantom wind tunnel setup' + + 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(Mstar,'Mstar','sphere mass in code units',iunit) + call write_inopt(Rstar,'Rstar','sphere radius in code units',iunit) + + write(iunit,"(/,a)") '# wind settings' + call write_inopt(v_inf*unit_velocity/1.e5,'v_inf','wind speed / km s^-1',iunit) + call write_inopt(rho_inf*unit_density,'rho_inf','wind density / g cm^-3',iunit) + call write_inopt(pres_inf*unit_pressure,'pres_inf','wind pressure / dyn cm^2',iunit) + call write_inopt(gamma,'gamma','adiabatic index',iunit) + + write(iunit,"(/,a)") '# wind injection settings' + call write_inopt(lattice_type,'lattice_type','0: cubic, 1: close-packed cubic',iunit) + call write_inopt(handled_layers,'handled_layers','number of handled layers',iunit) + call write_inopt(wind_radius,'wind_radius','injection radius in units of Rstar',iunit) + call write_inopt(wind_injection_x,'wind_injection_x','injection x in units of Rstar',iunit) + call write_inopt(wind_length,'wind_length','wind length in units of Rstar',iunit) + + close(iunit) + +end subroutine write_setupfile + + +!----------------------------------------------------------------------- +!+ +! Read setup parameters from input file +!+ +!----------------------------------------------------------------------- +subroutine read_setupfile(filename,ierr) + use infile_utils, only:open_db_from_file,inopts,close_db,read_inopt + use io, only:error + use units, only:select_unit,unit_density,unit_pressure,unit_velocity + use setunits, only:read_options_and_set_units + use eos, only:gamma + character(len=*), intent(in) :: filename + integer, intent(out) :: ierr + integer, parameter :: lu = 21 + integer :: nerr + type(inopts), allocatable :: db(:) + + call open_db_from_file(db,filename,lu,ierr) + if (ierr /= 0) return + + nerr = 0 + + call read_options_and_set_units(db,nerr) + + call read_inopt(nstar,'nstar',db,errcount=nerr) + call read_inopt(Mstar,'Mstar',db,errcount=nerr) + call read_inopt(Rstar,'Rstar',db,errcount=nerr) + + call read_inopt(v_inf,'v_inf',db,errcount=nerr) + call read_inopt(rho_inf,'rho_inf',db,errcount=nerr) + call read_inopt(pres_inf,'pres_inf',db,errcount=nerr) + call read_inopt(gamma,'gamma',db,errcount=nerr) + + ! Convert wind quantities to code units + v_inf = v_inf / unit_velocity * 1.e5 + rho_inf = rho_inf / unit_density + pres_inf = pres_inf / unit_pressure + + call read_inopt(lattice_type,'lattice_type',db,errcount=nerr) + call read_inopt(handled_layers,'handled_layers',db,errcount=nerr) + call read_inopt(wind_radius,'wind_radius',db,errcount=nerr) + call read_inopt(wind_injection_x,'wind_injection_x',db,errcount=nerr) + call read_inopt(wind_length,'wind_length',db,errcount=nerr) + + if (nerr > 0) then + print "(1x,a,i2,a)",'setup_windtunnel: ',nerr,' error(s) during read of setup file' + ierr = 1 + endif + + call close_db(db) + +end subroutine read_setupfile + + +!----------------------------------------------------------------------- +!+ +! Check that setup is sensible +!+ +!----------------------------------------------------------------------- +subroutine check_setup(pmass,ierr) + real, intent(in) :: pmass + integer, intent(out) :: ierr + real :: min_layer_sep + + ierr = 0 + + min_layer_sep = (pmass / rho_inf)**(1./3.) + + if ( abs(wind_injection_x - 1.)*Rstar < real(handled_layers)*min_layer_sep ) then + print*,'error: Handled layers overlap with sphere. Try decreasing wind_injection_x or handled_layers' + ierr = 1 + endif + if (wind_radius < 1.) then + print*,'error: Wind cross-section should not be smaller than the sphere' + ierr = 1 + endif + if ( wind_injection_x + wind_length < 1. ) then + print*,'error: Wind not long enough to cover initial sphere position. Try increasing wind_injection_x or wind_length' + ierr = 1 + endif + +end subroutine check_setup end module setup - \ No newline at end of file + From 86b003bf07c0830d42a770ad8bf8221dd8b16ba5 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 29 Sep 2023 06:01:17 +1000 Subject: [PATCH 114/814] (windtunnel) tweaks to default parameters --- src/main/inject_windtunnel.f90 | 4 ++-- src/setup/setup_windtunnel.f90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index c51be1351..ee868f5b1 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -146,10 +146,10 @@ subroutine init_inject(ierr) max_particles = int(max_layers*(nodd+neven)/2) + nstar time_between_layers = distance_between_layers/v_inf - if (max_particles > maxp) call fatal('windtunnel', 'maxp too small for this simulation, please increase MAXP!') - call print_summary(v_inf,cs_inf,rho_inf,pres_inf,mach,pmass,distance_between_layers,time_between_layers,max_layers,nstar,max_particles) + if (max_particles > maxp) call fatal('windtunnel', 'maxp too small for this simulation, please increase MAXP!') + end subroutine init_inject !----------------------------------------------------------------------- diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index a697514b1..4064fa553 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -80,7 +80,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Wind parameters (see inject_windtunnel module) v_inf = 230e5 / unit_velocity - rho_inf = 4.e-4 / unit_density + rho_inf = 4.e-2 / unit_density pres_inf = 6.6e10 / unit_pressure ! Star parameters From 416d0cf3635515ffbc46555e97d7b1fef8d882fb Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 28 Sep 2023 22:06:39 +0200 Subject: [PATCH 115/814] (windtunnel) fix some bugs --- src/main/inject_windtunnel.f90 | 5 +++-- src/setup/setup_windtunnel.f90 | 6 +++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index ee868f5b1..7c304db07 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -40,7 +40,7 @@ module inject ! Particle-related parameters integer, public :: lattice_type = 1 - real, public :: handled_layers = 4 + integer, public :: handled_layers = 4 real, public :: wind_radius = 30. real, public :: wind_injection_x = -10. real, public :: wind_length = 100. @@ -146,7 +146,8 @@ subroutine init_inject(ierr) max_particles = int(max_layers*(nodd+neven)/2) + nstar 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) + call print_summary(v_inf,cs_inf,rho_inf,pres_inf,mach,pmass,distance_between_layers,& + time_between_layers,max_layers,nstar,max_particles) if (max_particles > maxp) call fatal('windtunnel', 'maxp too small for this simulation, please increase MAXP!') diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index 4064fa553..2c8e20ba4 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -117,10 +117,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, stop 'please check and edit .setup file and rerun phantomsetup' endif - call check_setup(pmass,ierr) - if (ierr /= 0) call fatal('windtunnel','errors in setup parameters') pmass = Mstar / real(nstar) massoftype(igas) = pmass + call check_setup(pmass,ierr) + if (ierr /= 0) call fatal('windtunnel','errors in setup parameters') ! Initialise particle injection @@ -259,7 +259,7 @@ end subroutine read_setupfile !+ !----------------------------------------------------------------------- subroutine check_setup(pmass,ierr) - real, intent(in) :: pmass + real, intent(in) :: pmass integer, intent(out) :: ierr real :: min_layer_sep From c65883d13a4eb36aa46f46fb3b6055556470bcf6 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 28 Sep 2023 22:08:21 +0200 Subject: [PATCH 116/814] (BHL) revert unintended changes --- src/main/inject_BHL.f90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/main/inject_BHL.f90 b/src/main/inject_BHL.f90 index 644936368..0f55107bc 100644 --- a/src/main/inject_BHL.f90 +++ b/src/main/inject_BHL.f90 @@ -38,7 +38,6 @@ module inject real, public :: BHL_mach = 3. real, public :: BHL_r_star = .1 real, public :: BHL_m_star - integer, public :: nstar = 0 ! Particle-related parameters real, public :: BHL_closepacked = 1. @@ -151,7 +150,7 @@ subroutine init_inject(ierr) layer_odd(:,:) = layer_even(:,:) endif max_layers = int(BHL_wind_length*BHL_r_star/distance_between_layers) - max_particles = int(max_layers*(nodd+neven)/2) + nstar + max_particles = int(max_layers*(nodd+neven)/2) print *, 'BHL maximum layers: ', max_layers print *, 'BHL maximum particles: ', max_particles if (max_particles > maxp) call fatal('BHL', 'maxp too small for this simulation, please increase MAXP!') @@ -223,7 +222,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+1, np, xyz, vxyz, h, u, .false.) deallocate(xyz, vxyz, h, u) enddo From fa750e79991c8450fb05e4b3a04951c17e980cf3 Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 9 Oct 2023 13:08:29 +1100 Subject: [PATCH 117/814] (analysis_radiotde) clean up the code --- src/utils/analysis_radiotde.f90 | 80 ++++++++++++++------------------- 1 file changed, 33 insertions(+), 47 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 0a9f24490..29d2d2b8f 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -13,23 +13,16 @@ module analysis ! :Owner: Fitz Hu ! ! :Runtime parameters: -! - angmax : *max angular momentum* -! - angmin : *min angular momentum* -! - emax : *max energy* -! - emin : *min energy* -! - lummax : *max luminosity* -! - lummin : *min luminosity* -! - mh : *black hole mass in code units* -! - nbins : *number of bins* -! - rmax : *max radius* -! - rmin : *min radius* -! - trmax : *max return time* -! - trmin : *min return time* -! - vmax : *max velocity* -! - vmin : *min velocity* +! - rad_cap : *capture shell radius* +! - drad_cap : *capture shell thickness* +! - v_max : *max velocity* +! - v_min : *min velocity* +! - theta_max : *max azimuthal angle* +! - theta_min : *min azimuthal angle* +! - phi_max : *max altitude angle* +! - phi_min : *min altitude angle* ! -! :Dependencies: dump_utils, infile_utils, io, physcon, prompting, -! readwrite_dumps, sortutils, vectorutils +! :Dependencies: infile_utils, io, physcon, readwrite_dumps, units ! implicit none character(len=8), parameter, public :: analysistype = 'radiotde' @@ -37,21 +30,19 @@ module analysis private - real, dimension(:), allocatable :: theta,plot_theta,phi,vr,vtheta,vphi + real, dimension(:), allocatable :: theta,plot_theta,phi,vr,vtheta,vphi logical, dimension(:), allocatable :: cap !---- These can be changed in the params file - integer :: nbins - !--- If min=max then lims are set dynamically - real :: rad_cap = 1.e16 ! radius where the outflow in captured (in cm) - real :: drad_cap = 4.7267e14 ! thickness of the shell to capture outflow (in cm) - real :: v_min = 0. - real :: v_max = 1. - real :: theta_min = -180. - real :: theta_max = 180. - real :: phi_min = -90. - real :: phi_max = 90. - real :: m_accum, m_cap, vr_accum_mean, vr_cap_mean, v_accum_mean, v_cap_mean, e_accum, e_cap + real :: rad_cap = 1.e16 ! radius where the outflow in captured (in cm) + real :: drad_cap = 4.7267e14 ! thickness of the shell to capture outflow (in cm) + real :: v_min = 0. + real :: v_max = 1. + real :: theta_min = -180. + real :: theta_max = 180. + real :: phi_min = -90. + real :: phi_max = 90. + real :: m_accum, m_cap, vr_accum_mean, vr_cap_mean, v_accum_mean, v_cap_mean, e_accum, e_cap integer :: n_accum, n_cap contains @@ -64,11 +55,11 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) integer, intent(in) :: numfile,npart,iunit real, intent(in) :: xyzh(:,:),vxyzu(:,:) real, intent(in) :: pmass,time - character(len=120) :: output,prefile + character(len=120) :: output character(len=30) :: filename - integer :: i,ierr,j - logical :: iexist - real :: val,toMsun,todays + integer :: i,ierr + logical :: iexist + real :: toMsun,todays m_accum = 0. n_accum = 0 @@ -140,16 +131,15 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) close(iunit) endif - deallocate(theta(npart),plot_theta(npart),phi(npart),vr(npart),vtheta(npart),vphi(npart),cap(npart)) + deallocate(theta,plot_theta,phi,vr,vtheta,vphi,cap) inquire(file='outflows',exist=iexist) if (iexist) then - open(iunit,file='outflows',status='old',access='append') + open(iunit,file='outflows',status='old',position='append') else open(iunit,file='outflows',status='new') - write(iunit,*) '# time, m_cap[msun], m_accum[msun], & - vr_accum_mean[c], vr_cap_mean[c], v_accum_mean[c], & - v_cap_mean[c], e_accum[erg], e_cap[erg]' + write(iunit,*) '# time, m_cap[msun], m_accum[msun], vr_accum_mean[c], vr_cap_mean[c], & + v_accum_mean[c], v_cap_mean[c], e_accum[erg], e_cap[erg]' endif write(iunit,'(9(es18.10,1x))') & time*todays, & @@ -177,9 +167,9 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) integer, intent(in) :: npart real, intent(in) :: pmass,xyzh(:,:),vxyzu(:,:) integer :: i - real :: r,v,x,y,z,xyz(1:3),vx,vy,vz,vxyz(1:3) - real :: thetai,phii,vri - real :: vr_accum_add,vr_cap_add,v_accum_add,v_cap_add + real :: r,v,x,y,z,xyz(1:3),vx,vy,vz,vxyz(1:3) + real :: thetai,phii,vri + real :: vr_accum_add,vr_cap_add,v_accum_add,v_cap_add vr_accum_add = 0. vr_cap_add = 0. @@ -197,15 +187,11 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) vxyz = (/vx,vy,vz/) r = sqrt(dot_product(xyz,xyz)) v = sqrt(dot_product(vxyz,vxyz)) - !print*, 'x', xyz, r - !print*, 'v', vxyz, sqrt(dot_product(vxyz,vxyz)) if (r > rad_cap) then m_accum = m_accum + pmass n_accum = n_accum + 1 e_accum = e_accum + 0.5*pmass*v**2 - !print*, dot_product(vxyz,xyz)/r, cosd(phii)*sind(thetai)*vx + sind(phii)*sind(thetai)*vy + cosd(thetai)*vz - vri = dot_product(vxyz,xyz)/r !cosd(phii)*sind(thetai)*vx + sind(phii)*sind(thetai)*vy + cosd(thetai)*vz - if (vri < 0) print*, vxyz, xyz, r + vri = dot_product(vxyz,xyz)/r vr_accum_add = vr_accum_add + vri v_accum_add = v_accum_add + v if (r-rad_cap < drad_cap .and. (v .ge. v_min .and. v .le. v_max)) then @@ -270,8 +256,8 @@ subroutine read_tdeparams(filename,ierr) use io, only:error character(len=*), intent(in) :: filename integer, intent(out) :: ierr - integer, parameter :: iunit = 21 - integer :: nerr + integer, parameter :: iunit = 21 + integer :: nerr type(inopts), allocatable :: db(:) print "(a)",'reading analysis options from '//trim(filename) From 3a8ce4c38ff176810a70d56f7296fa4a098690a5 Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 9 Oct 2023 13:09:36 +1100 Subject: [PATCH 118/814] (Makefile_setups) default setup for radio tde --- build/Makefile_setups | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/build/Makefile_setups b/build/Makefile_setups index 613f126e7..edd7170cd 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -177,6 +177,18 @@ ifeq ($(SETUP), grtde) ANALYSIS= analysis_gws.f90 endif +ifeq ($(SETUP), radiotde) +# radio tidal disruption event in general relativity + GR=yes + METRIC=minkowski + KNOWN_SETUP=yes + GRAVITY=no + IND_TIMESTEPS=no + ANALYSIS=analysis_radiotde.f90 + MODFILE=moddump_radiotde.f90 + SYSTEM=gfortran +endif + ifeq ($(SETUP), srpolytrope) # polytrope in special relativity FPPFLAGS= -DPRIM2CONS_FIRST From 0cad1947f0e6298014aee24df4ff9b58d2d920aa Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 9 Oct 2023 13:11:46 +1100 Subject: [PATCH 119/814] (moddump_radiotde) set up a circumnuclear gas cloud around tde --- src/utils/moddump_radiotde.f90 | 410 +++++++++++++++++++++++++++++++++ 1 file changed, 410 insertions(+) create mode 100644 src/utils/moddump_radiotde.f90 diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 new file mode 100644 index 000000000..6ef2674e4 --- /dev/null +++ b/src/utils/moddump_radiotde.f90 @@ -0,0 +1,410 @@ +!--------------------------------------------------------------------------! +! 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 moddump +! +! Setup a circumnuclear gas cloud around outflowing TDE +! +! :References: None +! +! :Owner: Fitz Hu +! +! :Runtime parameters: +! - temperature : *Temperature* +! - mu : *mean molecular mass* +! - ieos_in : *equation of state* +! - use_func : *use broken power law or profile date points* +! +! :Dependencies: datafiles, eos, io, stretchmap, kernel, +! mpidomain, part, physcon, setup_params, +! spherical, timestep, units, infile_utils +! + implicit none + public :: modify_dump + private :: rho,rho_tab,get_temp_r,uerg,calc_rhobreak,write_setupfile,read_setupfile + + private + integer :: ieos_in,nprof,nbreak,nbreak_old + real :: temperature,mu,ignore_radius,rad_max,rad_min + character(len=50) :: profile_filename + character(len=3) :: interpolation + real, allocatable :: rhof_n(:),rhof_rbreak(:),rhof_rhobreak(:) + real, allocatable :: rhof_n_in(:),rhof_rbreak_in(:) + real, allocatable :: rad_prof(:),dens_prof(:) + real :: rhof_rho0 + logical :: use_func,use_func_old,remove_overlap + +contains + +!---------------------------------------------------------------- +! +! Sets up a circumnuclear gas cloud +! +!---------------------------------------------------------------- +subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) + use physcon, only:solarm,years,mass_proton_cgs + use setup_params, only:npart_total + use part, only:igas,set_particle_type,delete_particles_inside_radius,delete_particles_outside_sphere + use io, only:fatal,master,id + use units, only:umass,udist,utime,set_units,unit_density + use timestep, only:dtmax,tmax + use eos, only:ieos,gmw + use kernel, only:hfact_default + use stretchmap, only:get_mass_r + use spherical, only:set_sphere + use mpidomain, only:i_belong + integer, intent(inout) :: npart + integer, intent(inout) :: npartoftype(:) + real, intent(inout) :: xyzh(:,:) + real, intent(inout) :: vxyzu(:,:) + real, intent(inout) :: massoftype(:) + integer :: i,ierr,iunit=12,iprof + integer :: np_sphere,npart_old + real :: totmass,delta,r + character(len=120) :: fileset,fileprefix='radio' + logical :: read_temp,setexists + real, allocatable :: masstab(:),temp_prof(:) + character(len=15), parameter :: default_name = 'default_profile' + real, dimension(7), parameter :: dens_prof_default = (/8.9e-21, 5.1e-21, 3.3e-21, 2.6e-21, & + 6.6e-25, 3.4e-25, 8.1e-26/), & + rad_prof_default = (/8.7e16, 1.2e17, 1.4e17, 2.0e17, & + 4.0e17, 4.8e17, 7.1e17/) ! profile from Cendes+2021 + procedure(rho), pointer :: rhof + + !--Check for existence of the .params files + fileset=trim(fileprefix)//'.params' + inquire(file=fileset,exist=setexists) + + !--Set default values + temperature = 10. ! Temperature in Kelvin + mu = 2. ! mean molecular weight + ieos_in = 2 + ignore_radius = 1.e14 ! in cm + use_func = .true. + use_func_old = use_func + remove_overlap = .true. + !--Power law default setups + rad_max = 7.1e16 ! in cm + rad_min = 8.7e15 ! in cm + nbreak = 1 + nbreak_old = nbreak + rhof_rho0 = 1.e4*mu*mass_proton_cgs + allocate(rhof_n(nbreak),rhof_rbreak(nbreak)) + rhof_n = -1.7 + rhof_rbreak = rad_min + !--Profile default setups + read_temp = .false. + profile_filename = default_name + nprof = 7 + interpolation = 'log' + + !--Read values from .setup + if (setexists) call read_setupfile(fileset,ierr) + if (.not. setexists .or. ierr /= 0) then + !--Prompt to get inputs and write to file + call write_setupfile(fileset) + stop + elseif (nbreak /= nbreak_old) then + !--Rewrite setup file + write(*,'(a)') ' [nbreak] changed. Rewriting setup file ...' + deallocate(rhof_n,rhof_rbreak) + allocate(rhof_n(nbreak),rhof_rbreak(nbreak)) + rhof_n = -1.7 + rhof_rbreak = rad_min + call write_setupfile(fileset) + stop + elseif (use_func .neqv. use_func_old) then + !--Rewrite setup fi.e + write(*,'(a)') ' [use_func] changed. Rewriting setup file ...' + call write_setupfile(fileset) + stop + endif + + !--allocate memory + if (use_func) then + rhof => rho + deallocate(rhof_n,rhof_rbreak) + allocate(rhof_n(nbreak),rhof_rbreak(nbreak),rhof_rhobreak(nbreak)) + rhof_n(:) = rhof_n_in(1:nbreak) + rhof_rbreak(:) = rhof_rbreak_in(1:nbreak) + call calc_rhobreak() + else + if (temperature .le. 0) read_temp = .true. + rhof => rho_tab + + deallocate(rhof_n,rhof_rbreak) + allocate(dens_prof(nprof),rad_prof(nprof),masstab(nprof)) + if (read_temp) allocate(temp_prof(nprof)) + + !--Read profile from data + if (profile_filename == default_name) then + rad_prof = rad_prof_default + dens_prof = dens_prof_default + else + open(iunit,file=profile_filename) + if (.not. read_temp) then + do iprof = 1,nprof + read(iunit,*) rad_prof(iprof), dens_prof(iprof) + enddo + else + do iprof = 1,nprof + read(iunit,*) rad_prof(iprof), dens_prof(iprof), temp_prof(iprof) + enddo + endif + endif + endif + ieos = ieos_in + gmw = mu + + !--Everything to code unit + ignore_radius = ignore_radius/udist + if (use_func) then + rad_min = rad_min/udist + rad_max = rad_max/udist + rhof_rbreak = rhof_rbreak/udist + rhof_rhobreak = rhof_rhobreak/unit_density + else + rad_prof = rad_prof/udist + dens_prof = dens_prof/unit_density + rad_min = rad_prof(1) + rad_max = rad_prof(nprof) + endif + + !--remove unwanted particles + npart_old = npart + call delete_particles_inside_radius((/0.,0.,0./),ignore_radius,npart,npartoftype) + write(*,'(I10,1X,A23,1X,E8.2,1X,A14)') npart_old - npart, 'particles inside radius', ignore_radius*udist, 'cm are deleted' + npart_old = npart + if (remove_overlap) then + call delete_particles_outside_sphere((/0.,0.,0./),rad_min,npart) + write(*,'(I10,1X,A24,1X,E8.2,1X,A14)') npart_old - npart, 'particles outside radius', rad_min*udist, 'cm are deleted' + npart_old = npart + endif + + !--setup cloud + totmass = get_mass_r(rhof,rad_max,rad_min) + write(*,'(A42,1X,F5.2,1X,A10)') ' Total mass of the circumnuclear gas cloud:', totmass*umass/solarm, 'solar mass' + np_sphere = nint(totmass/massoftype(igas)) + call set_sphere('random',id,master,rad_min,rad_max,delta,hfact_default,npart,xyzh, & + rhofunc=rhof,nptot=npart_total,exactN=.true.,np_requested=np_sphere,mask=i_belong) + if (ierr /= 0) call fatal('moddump','error setting up the circumnuclear gas cloud') + + npartoftype(igas) = npart + !--Set particle properties + do i = npart_old+1,npart + call set_particle_type(i,igas) + r = dot_product(xyzh(1:3,i),xyzh(1:3,i)) + if (read_temp) temperature = get_temp_r(r,rad_prof,temp_prof) + vxyzu(4,i) = uerg(rhof(r),temperature) + vxyzu(1:3,i) = 0. ! stationary for now + enddo + + !--Set timesteps + tmax = 10.*years/utime + dtmax = tmax/1000. + +end subroutine modify_dump + +!--Functions + +real function rho(r) + real, intent(in) :: r + integer :: i + logical :: found_rad + + found_rad = .false. + do i = 1,nbreak-1 + if (r > rhof_rbreak(i) .and. r < rhof_rbreak(i+1)) then + rho = rhof_rhobreak(i)*(r/rhof_rbreak(i))**rhof_n(i) + found_rad = .true. + endif + enddo + if (.not. found_rad) rho = rhof_rhobreak(nbreak)*(r/rhof_rbreak(nbreak))**rhof_n(nbreak) + +end function rho + +real function rho_tab(r) + real, intent(in) :: r + integer :: i + real :: logr1,logr2,logr + real :: logrho1,logrho2,logrho_tab + real :: gradient + + do i = 1,nprof-1 + if (r > rad_prof(i) .and. r < rad_prof(i+1)) then + select case (interpolation) + case ('log') + logr1 = log10(rad_prof(i)) + logr2 = log10(rad_prof(i+1)) + logrho1 = log10(dens_prof(i)) + logrho2 = log10(dens_prof(i+1)) + logr = log10(r) + gradient = (logrho2-logrho1)/(logr2-logr1) + logrho_tab = logrho1 + gradient*(logr-logr1) + rho_tab = 10**logrho_tab + case ('lin') + gradient = (dens_prof(i+1)-dens_prof(i))/(rad_prof(i+1)-rad_prof(i)) + rho_tab = dens_prof(i) + gradient*(r-rad_prof(i)) + case default + write(*,'(a29,1x,a)') 'Unknown interpolation option:', trim(interpolation) + write(*,'(a53)') "Support only 'lin'ear/'log'arithmic interpolation now" + end select + endif + enddo +end function rho_tab + +real function get_temp_r(r,rad_prof,temp_prof) + real, intent(in) :: r,rad_prof(nprof),temp_prof(nprof) + integer :: i + real :: t1,r1 + + do i = 1,nprof + if (r > rad_prof(i) .and. r < rad_prof(i+1)) then + t1 = temp_prof(i) + r1 = rad_prof(i) + get_temp_r = (temp_prof(i+1)-t1)/(rad_prof(i+1)-r1)*(r-r1) + t1 + exit + endif + enddo + +end function get_temp_r + +real function uerg(rho,T) + use physcon, only:kb_on_mh,radconst + use units, only:unit_density,unit_ergg + real, intent(in) :: rho,T + real :: ucgs_gas,ucgs_rad,rhocgs + + rhocgs = rho*unit_density + ucgs_gas = 1.5*kb_on_mh*T/mu + ucgs_rad = 0. !radconst*T**4/rhocgs + uerg = (ucgs_gas+ucgs_rad)/unit_ergg + +end function uerg + +subroutine calc_rhobreak() + integer :: i + + rhof_rhobreak(1) = rhof_rho0 + if (nbreak > 1) then + do i = 2,nbreak + rhof_rhobreak(i) = rhof_rhobreak(i-1)*(rhof_rbreak(i)/rhof_rbreak(i-1))**rhof_n(i-1) + enddo + endif + +end subroutine calc_rhobreak + +!---------------------------------------------------------------- +!+ +! 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 + character(len=20) :: rstr,nstr + + write(*,"(a)") ' writing setup options file '//trim(filename) + open(unit=iunit,file=filename,status='replace',form='formatted') + write(iunit,"(a)") '# input file for setting up a circumnuclear gas cloud' + + write(iunit,"(/,a)") '# geometry' + call write_inopt(ignore_radius,'ignore_radius','tde particle inside this radius will be ignored',iunit) + call write_inopt(remove_overlap,'remove_overlap','remove outflow particles overlap with circum particles',iunit) + call write_inopt(use_func,'use_func','if use broken power law for density profile',iunit) + if (use_func) then + call write_inopt(rad_min,'rad_min','inner radius of the circumnuclear gas cloud',iunit) + call write_inopt(rad_max,'rad_max','outer radius of the circumnuclear gas cloud',iunit) + write(iunit,"(/,a)") '# density broken power law' + call write_inopt(rhof_rho0,'rhof_rho0','density at rad_min (in g/cm^3)',iunit) + call write_inopt(nbreak,'nbreak','number of broken power laws',iunit) + write(iunit,"(/,a)") '# section 1 (from rad_min)' + call write_inopt(rhof_n(1),'rhof_n_1','power law index of the section',iunit) + if (nbreak > 1) then + do i=2,nbreak + write(iunit,"(a,1x,i1)") '# section',i + write(rstr,'(a12,i1)') 'rhof_rbreak_',i + write(nstr,'(a7,i1)') 'rhof_n_',i + call write_inopt(rhof_rbreak(i),trim(rstr),'inner radius of the section',iunit) + call write_inopt(rhof_n(i),trim(nstr),'power law index of the section',iunit) + enddo + endif + else + call write_inopt(profile_filename,'profile_filename','filename for the cloud profile',iunit) + call write_inopt(nprof,'nprof','number of data points in the cloud profile',iunit) + call write_inopt(interpolation,'interpolation',"use 'lin'ear/'log'arithmic interpolation between data points",iunit) + endif + + write(iunit,"(/,a)") '# eos' + call write_inopt(ieos_in,'ieos','equation of state used',iunit) + call write_inopt(temperature,'temperature','temperature of the gas cloud (-ve = read from file)',iunit) + call write_inopt(mu,'mu','mean molecular density of the cloud',iunit) + + 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 io, only: fatal + character(len=*), intent(in) :: filename + integer, intent(out) :: ierr + integer, parameter :: iunit=21,in_num=50 + integer :: i + type(inopts), allocatable :: db(:) + character(len=20) :: rstr,nstr + real :: use_func_test + + write(*,"(a)")' reading setup options from '//trim(filename) + call open_db_from_file(db,filename,iunit,ierr) + + call read_inopt(ignore_radius,'ignore_radius',db,min=0.,err=ierr) + call read_inopt(remove_overlap,'remove_overlap',db,err=ierr) + call read_inopt(use_func,'use_func',db,err=ierr) + call read_inopt(use_func_test,'nbreak',db,err=ierr) + if (ierr == -1) use_func_old = .false. + if (use_func) then + call read_inopt(rad_min,'rad_min',db,min=ignore_radius,err=ierr) + call read_inopt(rad_max,'rad_max',db,min=rad_min,err=ierr) + call read_inopt(rhof_rho0,'rhof_rho0',db,min=0.,err=ierr) + call read_inopt(nbreak,'nbreak',db,min=1,err=ierr) + allocate(rhof_rbreak_in(in_num),rhof_n_in(in_num)) + call read_inopt(rhof_n_in(1),'rhof_n_1',db,err=ierr) + rhof_rbreak_in(1) = rad_min + do i=2,nbreak+1 + write(rstr,'(a12,i1)') 'rhof_rbreak_',i + write(nstr,'(a7,i1)') 'rhof_n_',i + call read_inopt(rhof_rbreak_in(i),trim(rstr),db,min=rhof_rbreak_in(i-1),max=rad_max,err=ierr) + call read_inopt(rhof_n_in(i),trim(nstr),db,err=ierr) + if (ierr == 0) nbreak_old = i + enddo + else + call read_inopt(profile_filename,'profile_filename',db,err=ierr) + call read_inopt(nprof,'nprof',db,min=1,err=ierr) + call read_inopt(interpolation,'interpolation',db,err=ierr) + endif + + call read_inopt(ieos_in,'ieos',db,err=ierr) + call read_inopt(temperature,'temperature',db,err=ierr) + call read_inopt(mu,'mu',db,err=ierr) + + call close_db(db) + + if (ierr /= 0) then + call fatal('moddump_radiotde','Error in reading setup file') + endif + +end subroutine read_setupfile +!---------------------------------------------------------------- +end module moddump + From 39910803bbab5d3e4158d90d9f90e263574a3a73 Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 9 Oct 2023 21:28:40 +1100 Subject: [PATCH 120/814] (analysis_radiotde) solve compiling warning --- src/utils/analysis_radiotde.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 29d2d2b8f..4d009de92 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -138,8 +138,8 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) open(iunit,file='outflows',status='old',position='append') else open(iunit,file='outflows',status='new') - write(iunit,*) '# time, m_cap[msun], m_accum[msun], vr_accum_mean[c], vr_cap_mean[c], & - v_accum_mean[c], v_cap_mean[c], e_accum[erg], e_cap[erg]' + write(iunit,'(9(A15,1X))') '# time', 'm_cap[msun]', 'm_accum[msun]', 'vr_accum_mean[c]', 'vr_cap_mean[c]', & + 'v_accum_mean[c]', 'v_cap_mean[c]', 'e_accum[erg]', 'e_cap[erg]' endif write(iunit,'(9(es18.10,1x))') & time*todays, & From d067d47b7ae228fe045ad45d5e904837d813043d Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 9 Oct 2023 21:29:02 +1100 Subject: [PATCH 121/814] (moddump_radiotde) solve compiling warning --- src/utils/moddump_radiotde.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 6ef2674e4..d854923a5 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -233,6 +233,7 @@ real function rho_tab(r) real :: logrho1,logrho2,logrho_tab real :: gradient + rho_tab = 0. do i = 1,nprof-1 if (r > rad_prof(i) .and. r < rad_prof(i+1)) then select case (interpolation) @@ -261,6 +262,7 @@ real function get_temp_r(r,rad_prof,temp_prof) integer :: i real :: t1,r1 + get_temp_r = temperature do i = 1,nprof if (r > rad_prof(i) .and. r < rad_prof(i+1)) then t1 = temp_prof(i) From a55262eedd0ac8ba39c411df2b38a20251042978 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 10 Oct 2023 10:53:41 +0200 Subject: [PATCH 122/814] (binary) set default massoftype to zero --- src/setup/setup_binary.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 533de808c..5c646d8f1 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -88,7 +88,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& ! npart = 0 npartoftype(:) = 0 - massoftype = 1d-9 + massoftype = 0. xyzh(:,:) = 0. vxyzu(:,:) = 0. From 09532f95a96161ef1ecdd0edef8b2c857766d907 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 12 Oct 2023 21:18:09 +1100 Subject: [PATCH 123/814] (radiation) signal speed used in tcour should include radiation pressure --- src/main/force.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/main/force.F90 b/src/main/force.F90 index 2e7eb3f58..bff01b4c0 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -2043,6 +2043,10 @@ subroutine get_stress(pri,spsoundi,rhoi,rho1i,xi,yi,zi, & ! pro2i = (pri + radPi)*rho1i*rho1i + stressiso vwavei = spsoundi + + if (do_radiation) then + vwavei = sqrt(vwavei*vwavei + 4.*radPi/(3.*rhoi)) ! Commercon et al. (2011) + endif endif end subroutine get_stress From 3a31b5a5cabc570292b265dbb1586c4e88fff94b Mon Sep 17 00:00:00 2001 From: Miguel Gonzalez-Bolivar Date: Wed, 18 Oct 2023 13:21:48 +1100 Subject: [PATCH 124/814] Include Roche utils in requires_eos_opts list --- 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 c28178265..6cd1c6c27 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -133,7 +133,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) xyzmh_ptmass,vxyz_ptmass,omega_corotate,dump_number) ! List of analysis options that require specifying EOS options - requires_eos_opts = any((/2,3,4,6,8,9,11,13,14,15,20,21,22,23,24,25,26,29,30,31,32,33,35,41/) == analysis_to_perform) + requires_eos_opts = any((/2,3,4,5,6,8,9,11,13,14,15,20,21,22,23,24,25,26,29,30,31,32,33,35,41/) == analysis_to_perform) if (dump_number == 0 .and. requires_eos_opts) call set_eos_options(analysis_to_perform) select case(analysis_to_perform) From 71ec19892256dc6d5f7f6bdfac22488ba2c7cf91 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 20 Oct 2023 17:01:38 +1100 Subject: [PATCH 125/814] (docs) update [skip ci] --- docs/developer-guide.rst | 1 + docs/vscode.rst | 4 ++++ 2 files changed, 5 insertions(+) create mode 100644 docs/vscode.rst diff --git a/docs/developer-guide.rst b/docs/developer-guide.rst index 02d783985..b9d169785 100644 --- a/docs/developer-guide.rst +++ b/docs/developer-guide.rst @@ -8,6 +8,7 @@ Here is the Phantom developer guide. fork fortran + vscode philosophy styleguide setup diff --git a/docs/vscode.rst b/docs/vscode.rst new file mode 100644 index 000000000..47cf461d2 --- /dev/null +++ b/docs/vscode.rst @@ -0,0 +1,4 @@ +Coding Phantom in VSCode or Cursor AI +===================================== + +In VSCode or Cursor there are several helpful settings when editing Phantom source files. After installing a modern Fortran extension, to enforce the indentation conventions in Phantom you should use "findent" as in the indentation engine and pass it the same options as used in phantom/scripts/bots.sh. From db8ffc2f1f6d4f68e3f85edbddae6bdd3cf65061 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 20 Oct 2023 17:07:08 +1100 Subject: [PATCH 126/814] (docs) help added [skip ci] --- docs/images/vscode-findent-flags.png | Bin 0 -> 44635 bytes docs/images/vscode-findent.png | Bin 0 -> 43037 bytes 2 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 docs/images/vscode-findent-flags.png create mode 100644 docs/images/vscode-findent.png diff --git a/docs/images/vscode-findent-flags.png b/docs/images/vscode-findent-flags.png new file mode 100644 index 0000000000000000000000000000000000000000..39595e0c32f67c6ac9de3859b932566b47b35ede GIT binary patch literal 44635 zcmZ^K19%;48*S9sMq@X&Z5xekqd{Xfwynl$Y@>~x#%XL@cY1!D{^#DC>^yt2XTERd z+*A7#Zmq38Ug#`ftL6DLZRR#fp5C#DOMTG_fKKX>X=K}%)yJRUMq9`RILZs+q zZ)Ry@3IZY-mXrdes&atp_x5=Pj}G}DXe~}2gqpY>1Z-MJRTx#0iirXOqqeR&fF?W~ znhLI&DtF@$c32A;u2HNzz*`9OovSYGqT)|D-rm#Bt2G|`@w6vj^V8?6iP4rfE@#kO z2&evE@R~4wvP#KhB;BC|SUG}22%xmNps0f2bch-s%tAs#K}5~wyGGiULDF^XH5CRQ z@9y5zRNcL(u|TL$Hche&q%c8BM82##cqF^Wx1p#f5y6l=FOwC^UxiA^ zXB)A4{Gj|05X^`V!kg9?R|qE9D13ZvWA_0yl=ov`?H|N{#MKVlPy~^3lx(egQ5}jPY-%EI0NS2|E{DnW|h03vA@>`gy9EJs%%@8+UzW%tCB-;n76D zgGm|mn<&J+u1e|S(wZwdSuDcCdCYj{nE2B&dWN(ptM|fRad!4xcHra@vt*K7n~!Xn z)E1bfGTcOD8h)RKe)vd@is>A}75~%O^kB-V&2J)kXaYraVBDdRk-{aU=pe4Aj-R$g zmn0%~ZvyMx{b=?PLp7huV~S_6&BGe4kZNxGr*WHCFBE6?udMRfcrj;397kw$cUa~R z!xO0HK_f2@IG|2#tUSt{9B>bu=64|@pHl~6U~>$+!GwvxykcQE{Sd+Y89+WhV|+{q zu1OBpkPa#hpyftuvGwBC?r*5gUtV5X24(bcD;5alaQk{nCfYZ#-U$J6%wZiN zb}HzN55ju#F=NVn8x{j}@>3E`f{DWNWC9XA5tvvmEUO-Xa&7NCL%_xqJcMumYY#7u>?1dSm)popXTZca!* zm@>C+(zFDs6%Ij=bkcesEi&MH&4&u`jBaN`$kCv{O)7VkOjw3M=M7$W8XZ`TzR(S` zds;7y&Ubfx6Prxvf^mwhiTpos2Lx*s4ND+YVWk7K0zU{Q<(4T$m9VQ)9zvE8-hkbp zM2V?Pxzw{Q;p2aa7I&T+nY5nNo;2ML+&8=SxJI}J@kD>Y5b3cnre(6jW~V?*2>%%U zeJIhuifM=mi?NAOB-KrmHaUcCpw$4p_F|Fs_`@;gv7QZDBmQzAet-0)11CZz`8YUM z$kxU;hlggqW|3x=X1x{UQ}FDdg}&vjmkSto6d&+T2>lp=sIviqff%$z=s^e$VQha1 zO(`mpW6FAzDzp&jEm6~a>Zw3%F)-CSl-|U z*d5q0*bZ0*44Cl2aM^)@aISFj@FDbSnodO$sx+$FL{4ez#2-oWR5#R7)GA3QiG7JI zNljD>H2UfU>OG~YCHJN0s+X!(s^g{b%1WvtA0mDf*%h7^>*XSr8mY;t{VcOA3oZ*) zYg3h&Q=NT3XEdu`l2o3hd{mrgLBYyS7pN}EBi$zV#42Hq=#1z)zRMNm?77#jv7mgX zzE_S_!cn@e{8lKma6Tisuvj&ff1!w0X_?m|=-jf)KL(f1P_Nps($K8+PD`TU)Ut00 za|vasyxzLL+A`)~{}5vTi|g%v=8Q+4%*@Ta+{|j}XDv6;n6kZ6%Gu>oH}NwZ-KgL!DuEV(2#|7+NC;se@O|igSt0l#1>&CKS5Zz;xRIwg zXpuOBU|Xw$S%YVCvT{ap>}mC>@EK(p-{hQS@ni{8l}6h~lhf2PR#}JASw?5Z?$X_~ zyD{Z4!6KX@j*@GN>WU_vs!d}s27k;+o2c2&naeerX_;$tXd*36+6ddQFV-)%XIisz z7@pp?WI1;&asM=1JZDN^1?BOxQvxy3)k zBd=QgAfJ)Ro!QCR#wnADmnESSsS~gBLFW;>EYe{RbC6skvOMNUYayYEa5Z!F+e&on z%ck8)_Nm?(KktMKf$!R@M<4+t!TXpGF+K{d=J9)X*)MvJdhe^Ps)yD>)_Bjf&WdH7 z&2X=fuZm(SWBT`+Cq5_RS+kX|V(s8+11k?WQ(R6Z}j> z!N}?G*?>?xbj)<2Rw7U*KpiRzi2_OjGUc5BVl8xBQ2kiw9@N-6)0ei(=d2F5=3hDWdZdoe`H|AHrJ+Z87O0PQNHcN=24N zcn}`pX}@14XJFQ?H=5cRNRME_ z%+bnk4yxPMM5Ul+FXcaAp^Q`+!;vwg)F6v-`na;Xvd3$`Ccg%~9;iR+oBk_KIg>f_ zFs_xQ%MCWFsI;X?!qZ~Y^R#LvlC2ah3Erf5!?&aK6R$PAW)HO(KWId0sw(R> zTRe7V-oIrMs^@7qYPfD6?p00TYmVvYHb816w0||O++1pJ5IF*y$JbHN$?1GeL1@Ga z=V)KWZmXqJptRRr+u#6QXWgdRmbrXlZ?P|X#(b$fU#=QM%(%08)#|2cR<_XARKE9s za~nxIJMN@;u`{y%F<(Wpm+!q?vn;x7XMeZkQ={3!S?umG^o&2obHD@lsdKf#WMKz& zDE`N4|LV8Zmm=b#%FmIvHp^EnvWlO|SBl$9h1-mr2cA0GJ35})@7UB2RWa3l9`){D zvda9*cC8W)<8f`|K8+>3Fg@}38ayj%lz-ILeA@Bb7kuma61aDyb9i{za1?>N0r|0S zIImx1HPjoaiCv3Booy-|HpY+i8|j3P?Bm7l)J6gR5cUwRFY{~ZFU}ixA(q+pZyxnx zlhfr2ig`=SyVpO-IkY<>70l;2Dqs2fzoio=Sp?>->Fd`um7oih_=zj%CZCSHna4Ov6?e=ZjPONK5%c z>&VT#-NI>Owg+GF=MK+_wet?g3yP=RIqkeAPdkbA&Y6_O1>aCN^Lx9&RgJrEXHo0= zcOX}}8+p@x@e)fhWxi~04W;WXZ?k@9-3>!=F=t3lP&scDFDF-uYiK_b;)^{MjzUgC z6{7EBTm-c5ZT4I4AMPWb*OPp!-7Rk~iv`->n%QwVxUZ!zt$y7kbKu$|w!3;QGhy=I z?(6QhUEIARWaWSVJbb_SKz%zibFq`-m?P7b>TCIg`+UBHrR6+AyG zdk`MZ;TwGtImeouXfZ1x@r3xWFplBlFDy_SGVA^Q?j!yEDOzMdKZDeFWn>>vzKa;W z9C&0TLd*t7+sI+&J9{e{^sO>r2A4RWxKW7P!`ZU&B0mAZu92yxl$o3y$OqsU8Uzd! z6$BhO0tJ3SLM=fc{yGK$p#a`NK)~ZeK%jtkRNzlB7wkW0A%t_m|8oqK2Y!T9M5LsE zcNJqNQ&T%<3wxKxPZ0os2IIF>)pXI6ljSzHx1~2Uu{ScMcei!;T?B;Jof|l`HFYs0 za<{dybLMvEBl+tJZs7R$#|$Jye_i5Y%}1gsr${7X?_^5EPR~fsNWu?GL`1~vWMamx zEGqu*;=q4=Bo;0%4%`e3Zf*2fdCxyi{ZaIH8@LsmEP>k@ z{_aG6CSHdB>$87f&&%+;hyUpDe+}nfp915_56jE&-?_mLd(uLO0|FulA|)!M>JECG z^-dG>Bi2v~aw2k#pkgiDa|PQxW?P%aK=-M7e|Ik;yy|gx72EvjDLsTLG71^Q!Tl=( z*3i$pcMzgtFB5$%pHDmX2A|FJ?y|Y|)|6P7m>vS5U}8c3=k?4BG3%S1=Tt~02=+g( zTp~f1kcl392|-<5UAZWQS9`a0kDmWt(uE2tzw1-f_TBn{*`L|;2R@(Y?*5bt1w~6& zg&YDZ5$Jzj{_s+QEF#h2fj_=LAmVe!k;`Dt#p$-YuZ`PfTD{&)lxkGxRaKovU`?E@ zcTsu{`Qfozz(4#*lCfX+6e&?ENDc`ZB=ogVt2D%3Ed)PF1VgP0Bl8B4w1ynm|yb@t|SI2(3(baSij&gGL#N=0R{Klv&! zV!geHFzE#I`H_tSfz{Q8}Qg|RI79bYiny4s&vyh9anONL^9ZI zPEJm~Jh_Q{ytc4>5MWJWF_)JclZ}gutJd$r<*@62x;tC0KbR~}K?s3jV+AuG zNuo(Cbw z0yGSaU?{Vxe2;tye0*K)WvL?RB%x+4Ny+o+q6qF!&pd9YD|e@>_#AeHlbdP(8E9aD zHh9n^r}4m#Na*RSREpV|n3$$hAMXf_3=MHGZ!d=9M3l{#g*&|-62e7M8yE@4;z-Sz z>AXy*{6Ix&xWVe?Bw`38<=E_2+MV~h37bJC`AIUio_O~k$pl*cZ- z*qSafZVf5K(+g-f9;>UnUhOeVwz+Yb^osgN7}oyhxAKp5kM7Z; zDpbK~us9qjt1x(wY0&I_{sdFOlcK3Om(IJR!6pOYN&O(P;LD{RSL*!y_PRRkqzBve z6bjkx$PW8Q<^ycKvcgyv`X-mMe=OVc7Z|b@6&xFES&j@2d%7rUpsE_f!fgd&hWCKOwG;A%*@Rtm@8vKY$RGt=Ehw^9ld*~!5oaL3j|3S zio{XzygPl}{%%YLhe^w7G0CWeV$Q2{?rO8zio!h<{X(--FkdLOg+-eR4hNc6W4N-q z8iI&lS^B((D?lcbj=vc-AFl3*8^)o3!$Uq9G(60s|1S)c~vbmjBOisqs z7$%mnNd4LREEuwbD1V&5JXX6Ele4ufBiWNB*F>c8>2I@>c?Adv2u4OmIlLYw_V%G% zB?&WH5PKW=?Tw9}o^I*Ly+_}fk7phoK8~*WD1VPnh9+lbWep;}xW5pQDz;mF%;Iqy zfV1BQihI3y?mgb%^-#|?SVPGwe7-#n#Br|H(?v0zZE@xp=JRwBa$8%|d$_`yo}24A zx&qb+pSy#;l_GRAGVQ^jjJK+&yg%4G!~8D?%<=Ag0+#U|rKLD#i)ZUka@oAZZgwo2 zYJ%s}BPplGgH)Jb%*U*nKb=r8H3q}&t+l#}u)gAD*O{?l^V|wp8%Glggl`CfKt%0~ zq-?ASVKW!5_XG|Z8YeQm6=zQSfwJ4#Rb6J@Yei$xX9iA|C?%kh(-Ij(@xzAzOPSqz z9`$Z~R&_HIhqVOgB_`vLmpD?&I9lCS+QE&32QA+E%}vAD;H3->J>m1ayAO$ML@U#Vn{e6ah`g<=y!f^$Zm9@z*K2=%jpWsnO)7aKxjgn zNVqKNqz|N2CF+&ju{5eBK|9FElUc!HrG24DoIKS*LPoZ>q*@6%hCBmCx}=IEkBHaj{trjW(mVl<$< zC}6}DI{bz(;SNGV(pw~e4dMsFBA(0X{TPJ2!E$ly1CC>sH{64hR>ls0S=*F434@3j z0#c5_9ytsHr-Gg1u>HkkB-vKIdJP2pV6m1Z6p{Lv{C#f#s?*Z=*;+@^2NDRBZ>`+y zrmuY~yaMBzsH8U7!!^MUC&=!9hVf@XFey)CMhZ8#J79b_A5)nJ8f|`FLf0+TTfSs+ z!Sy@X+Mrt#d@~yh$6BM)Zlu?$Zyrt=1&L#2{=sj*W<<*jL;+f-AIWr3)(|qS112aV zJ#Wu-B$r2X)?dDtSDt7t!e~_Mg`B9ieOe8KLNb618$fkCTN~7ZQ&5;FQ!6Lre?|(3 z{&coRzZ9B8LJ|y%MXy|E21FDAQrUys6TB}x0ghmMAfp6}x^v|VsN9-?h@clvKfjsw zsm_hkGI$A1Wb=tpP^@SQ(a*NG>)Efh6MRcc!|9DeRwsLK4(dH~9$e5+O}USlqww=H zy+eg1e&c|U+5Dx#rwr}9#0td=lFw}eqp5fvQ`(pulDWT+U5Xj0CpFjyg40-^2o8#e zJ)DsEXN>O@@ZWA{!XB$N4&9*aq3tprqWAIfAt11uMt-`%tG8WVW3y)Okq-04&pz+e zadLqkMCoLe}laP0@sDp0tWO(u)gR=PyDQ&~oTqQ3T@?H)s4<(9GNw4&$M z0Bwpo3niY+$v~PKg9!%AAr}Ub1XgC4@qvhFSdpyjvf}Gk#6ZlbZo=trrd#4shX$20 z`L@C;Y=je$R=ZfvdhPCr_}G^54?!<82BE&SBp81KB|nHxYJY~&liQQ!KsM(2`3^&Y z?(o=<0NeD#*;2QI=?7r%b={woZm&<4-T_lD%oOl#^mz$kv!c==XACm1k!<7L`JSLa zMG69waW0Kf8<@rzid-0^S&hqPW%Qjh*~J+0XX(uPB@tn%G&9(3i|5m=ZQG};nng(M zWJ3-;sTQ|0AI%Ovhg<~p%Wjyf3*#@UiHS;N)QYjtI_>Uy!vzuw-DQ;6sC^+(gRp2O z;SI0xX6eDBX$`@~l$_X4>`-}GQVHnUtPdz?Xi;R@YPH|qeVYtYtkjBPO(g^-tA4$J z>*44?ga)vC9daO1qqDkG{Ea~guLeP+SILuB+T5__n}{G`937qTb-+e3-hZ(Q z%#lEUc%tFuW$dU~6R(oxq6VwM6vQs75xYC)a{1NYvO9)>$7@gtcS|T!re1c5B20l< zVt@of8_DJK{2mNHNvqlW3DapqdAaS5G1*usBu4&NU8COOqCjE-n72Zu(w9;d88_S$~Ev&DMh z7GME%I?d=23RQX?-)xuFw+mDtP&Ol9AY|QUE5cWT7(U#iWU^W%pmt#5>YAnnLBY)=iyy>YJWj#ZBfCXG*Q|Z%3lT_ofhiyfxI!UYt3OU1I6w8`@Z zRzN_1>Px*2)Uv=AHSUu9%1XL2K}vf0>+JKDAFY^NFvcRT$1zRz>vmpaXfYP$>T&~W zg(m0U*s0_Hpi706ploPp39L<_wnH@@Oab4fC&7|CbMp@~v1J}+<_&NMiOM#_c#Iak zyuFhk!OxJtwmX0pwd}0dk?3e{P~(&wAcFGnZ*2;>?cg!Tum`-AzR2YG$KN*vQLd z{*fZxqqInkzTNJ~s$t&L$W>-W@pyXp+t&xibnqFGELzb)e?w^>LNHv1;%9!15gKxT zRg~^eV2grC1lXL;8>YQK2p1V0CV&2n>f=aMo0$i+fY0y{7K6|5Zehk`|6PfH9mJwY`V=##k%;|4qW(HD zj1819iG1o-`ZK%%$Azf?CqpmDC;7Yf-&Y6@0wk5fcm*mt;P1x$-t&kCfQkySF);po zdf)^zBxpJl&KAD|`hSV+zYeG=fQkl6N+kcllK>%(WrDWYKR6)gj;D}I$HT?#^w=V2 zU}I;uo6PpELw^#1{Ay^X*mzP>KbaZrz$Dx4_&^8Y>gq~a%qA}Wv$wBrZg%!?&f2fK7zm$y2;RVA7+SbnjUx?J;s8)7m-DWy z6lrv{{N8xh&lYEG>BLfz|83nl9}Jo0V0VcB%VfL9QO9Sua8T3nOaOV`;bc~xpf57Q zVU2gV9DsQqFW4()ao+%u-f^?HMHK<$lvHQn@y5DJzw1Lar^`NwhqBr@K(_!^S@tkW z{Ev2RLd3HeGd2%KWk{OIwtd3i=^IO=o|!FWfyJZ^kafGmN}z~}2@l6*F%w>Ee_%G9 z4p=vyuduADnm9hemz9$cbU2@{c47U5~BgUV*x7;0opM6n<}R-X)a`EZGOY&g$okmWm~wTxHm`?Y$#gtyY;4x^ z6}l}>NmaT$k_}Y9wvf_zaBL3Iz2rlm)87rx?=kSUAv-jVPp0>p)c zTA;6;iG#smqq{Q@>W)}|sC#|>6Eo(K@d79rpai&{u2@3Pm8n&0)=qzwJ2H?aJ^-}+ z%}q$58$chLFV|qus8H18X|h|jn6G#TUpW**I505q`0ya4SlRpjfA<)FLKz}17D!T_ zPsfVOjrdG;XN$FPUvJ`>Ktf@pf$^HJ(uD$>&)I<2fFCzB%;Vfbww3`9X+&Y$=K$h3 z)zys+gFF}xXb5+IAaZ?qe_&%}71Ei_?@jAOz~>2)XCgHM@D{;tOcN3TA|ghK==Z|% zuaT>ZL8ahq*akdqb_#kqMgQ1(1Twp^MuCm5!E$D5sg;A5;AoyprZ2e1Z~t4RHixj# z4^>oTElfN-?G8`6Ae%g($zO#xBV1oz)+Ho{h~|&heKD3J!i;Z^-)WA0GaZ4v&Jgew zsx|3S%=fO5?{eZIgHZ=pcL9-%v^Y z1em#am|`w2*HZ;KQLu}Y{QUd?o4&lh?oZJK7=99|#4Q2et2*vU8cQ+IaT}y`U#6JZ z*)fW!OFwUPp8`QF2G6_+z$&wcGv@X22YezjSd5x8nwJl)U5eT!*6JVKx1KI| zX(mhCy58)Fk2$E*;fX^LgdL^1V{gsld3zjeJhVi@0w5PaZ$efilMdbu$B@zMx&>yZ zmZ<1mcP56)94RfKHf)GPjOd|ZApDA#rwfY)yQ-+X9aFRreFfhixV-C)&Z z;BO2_3|mJRqW`=9#wtOVq@|{MjcL}{hy#PUzAi8&E*_JOOhB-^-;7*zUa~=x46NkX z#Dr=ZT+u~r8#1+&F8~W}Y)r1tq?lS$$qsY)X7lqK9JqK{Q648NDJf~;d)R+;5RSj# z6Vh72trw8aBED4D)S{ll+d>-?y`R!IqPaDEbUJjkrU ze!{TZaoK;&4noNd>kcOU_uR=_8YPNSDk?AIS<5S3_Yut{|Im-m#lY5AA|HN1|MP?( zSSd+v_6OS!34cJV-+O5{5~U!^ZsT$C@*E<$gmHx2&;Ul;V3md{kt}g^KN2F zN-=LJ^WUiD*%Kn3)i|Bi^7S-p;^s(WXTiqCMyJ7Q3<$OPlG!yp-=tDSASPePtRqh$u4p(05&dvvN3GyBRxk)$1LuKxGu-Db>A<+!KRvvLx5=gU0X_e zJY|AcA^S}eU&`_;ngye%sE3jKtYBe0p6idK9<)@?ir=~6fx?b35 zbF%=y&vQv(tnBpUBvsn9z3Md^xcpVDfvU;(cyd6u%zx*>Ow`?_-4tzU$CVZi==M|1 zip}m9I?U+@YKb%{wb9YhCPLKYGv!!~f8ZJ^l*!R_wxduaLe&VvzKxU5SG$!!455~0 zVhKbjD0|3q=H=r9&ZdUQJ8us^h)~Q}Vp|PXpyJ^8)A`tQs^x^@iu-yzeWN zLYpk`_b2A1+ueP~$~wDg?D$D9ObbxVP}h17X7+g99k3=ccw0OhW_}Hfy&0?@zLw(>Ygk$&;URRfYk<{3wZ9?4eJHm9o_`6aB?`EwsTQ~0K|5Cx{3r2QVWH2 z8im8c%g+Ak^_jd#`sM6L(g+}T&&^yVWv$*fSaY8t>t=>`Vv*lM;UDz>+zq{MjWHA`R}lzS|_L39F;qDs|94xb1k`JTU@1yWI z;-r@wo+ctpMpezm(vN<9Gk?16h>oVY;8wTj-Kw>mxy|CatJZ2jWRF)}{ZU4+D?1GI zwDW4~OGnZWOWwG7mzy)K7{4>1cr+EUhl(D^`5iaIFtg}Ca0kB zR3X;gkvPWlp<{$$dlt}Aj#{Y%Gw9$zSB1xbcNB=GVmnp3 zm5w3a%=T*)z_Y>QFryw_Qp&%Fi!ge5qytu==s~*&A|p5nDd|RAcMO<<43I(r@Czb^ znVH9CQZFeKn+K`_o6~ma;oK$`#5*0t-A5xCkUZawZvMp&?!!BCj*I>o^MaW2Uy<0VGjOWfAa=L)F3d6(~+N>yA{Z-4)eO7 zV^^fR8w#|`0<@rpg~<<4yVOb)Ef1!}ieyr3=gR0t$%YjZC>t7B`lN!ts#ojz=L1ZX zs2RP1Xsg-xji5??nD=kQBbW|jAubw3srGYqwL=s}1{+4@>tZsUHUUEjhpm=?d35h_ zPazZwhHNDw!AdCEuS;87N@Ltmtfth?#ii(hYxJ{?O+1t+4vR@_G+GIXfykjL$Ia;? zn$1jWs=?K-n(yZXY{fexxj|vs)=7_2CsL@&0~)|1~4PTIZk+ZBqSu+@z}7t zm-9>m<_^O^qh5qQm;|mo+BHJbZgDclLC%42Fa`#N(Ilo#5uKTnG6NzgPiqU6!`=@r+_4n}D}jU#FqC*oc9akB@J~&afQFW5YLbYO{+OU`GRrd>li3 znYsSDTW^Sv(%mT^jYbs-Q>YNlL0jvGNKn>j799xXPUOjV6%-JDKNsQs{L56+%RmcG zfpqi^-TmW-+gfNu#JKUAMdI>O>Usl}o~0g^0?B^D>3acFuZONOjpE8m1eY2^#h-nB z2$Etn?ux-EsTKuqub=n(LW$5}^kW&(FSG>_z102v{c9SW_Si98?N?ig?a8Pll~5`s zu@c2l0)7PH7~9z)9;tdd`b{(FQM5}b1|q;nq*);BO&5(o;|NGmC;Xwn6{ZQs%RGxk z3`OHxEjN?f@9Xt508VTW346%_!dK?i5D-%vHF3G+Uxm8tfDRkk>r_uw@;Zn2l{M+oN$2VZ!F1bOK+D{k&7ad$d( zOIK2px49mL?a(mNovwB8SAh75e`6sSFc*hVPprEYAQNwk(PFo z-DM&ja&HW@IGj%m^il7xEEm)7W&y7lVnF4%&2dv{=mX^6)!v4^(eE* zYczq8DWHL9?cRtzjHE(WT(G^=vR6ibn+R4+)zQrt)VRQU0Z|zaS-JCCOb_mgm=-sA zkH~>=(~tyeP#G|SK!e89cqtJu8ZhquYHTz{UY>7teUi^=^{R!%5ZnMFqh?L5#T1Z+ zW$2*{c@IHCAx**i9x~>2v9_`8lWk0Nbn;P2IgR>TADsUrEw81+fI%ozi?A{?ufWV# zu5NW4o=@2DWrefb57dM;?drFs-K?4>bMbRdo<(Wzg$QPQ^VNp>7%kuzrHOU`Z(+&$lgRwPbN&=9FPJt z;$r@FAcj#9?I&a2|AmRs>2Se5Xy97&k)+`^32aRpi(UsJVq`1p!we%5zq2?>@>drk zap<$gDIUyR8VpMdDzoWSy{&ib^U5?y%+%1`4r;>wV->*O5tH%~h06vy2f&PQ%})1* zH!9;*lx!T@vq3@#D#<7SUW$;Wegg!0YHfDXm3LE9#dY~iO5~kCCn)=+Z;lpbmRchY z%dqnjFF{A1gmszNgFbqn9>+|4qgrjS##I4j%r(|~obOqTms3g#UtL&=g- z>h$KYDz#BQgI!8P!|h~g4A7=9tIwx$dAYnFZ8)71`BV4z_k)ta%kbz)$wqtg z(YXf_tw)lhfT$=K1Fg^-A_*tZ(J{yzqEhFi z$j1A|#ly)wHNgI~!wvX|LXW7^@KHonx;AkZYZbEMBWRTni6W_eP{o$q2?`mzL|vz8 zSa!hWJ0yWiOXbM_d(Fatf82l74nc0zT%3ex#-HeaSMitraYu9>O#ZrV41N3uI{g>b zQ5NwtleMx?O8L8Oe<>s2$Us$~c3`3ZP+wwk!B~xzMIu`Np^V`80f`iN2Q*HIzqi=m zVu=6j?}~7>X376oydMVnossd&=qCP$+Fcj|R5Ux8PyfGd5QHSk%_}ZW0S)Q-tAyYq z@^D4v$D?ZD%EOd0#SdqpF(^K-gj04?0bD%nbk0})<~lluo|c+*?q6kb^W$dco`se$ zWcI8-uIGyn1hjsvU(tJd%T;>Lt1e#cy3)rMw9qV^#zyTBlIH%;+UdrEDV)Mn0n8vk zwgjGlw_QAHN&lGC8-teat;uSR8!(+*+a_0%E95$EnE~V~;kBaTki7b>QU(s=1CS25 zbUk9XwzTv;>h$Tj_1z?lQ>Tb(*~+-F(U=kxaOP(z0Q0B|Th>I00IpO$ayUfGp~ql(yNp zO>1DQ`dC@c$5PLq@n7d{UsZpIPSd6cC0#y@Br>XfkUoT@E@k?Uqe-7E_dyIn?VT*4 zoZMJ`e*Wz2EWo1YI=zc8wj>~-pvtX$A~FH(4-b$TaL~}uuIQG`Gr~~!*E%Te++<}d zs1RUbd0h|P^V7@HNF}1@rlzvkZR4$!(w)VlaEq&RZU7VxP&G?CGIETaKn{S~J7_XG z@6H0deNmxZ$h75biDkLE?c?=&waQJygh#o2D0MDBsJ> zGopnmk}G%{wp9-lr&nJq!wvCJeN1=^Eqy|SRH8WZV!Le=rHnsp(OBv zMoi(j>H78crVLBB>nVg6?GmlY4Ik28{f8)XDPCdO_y6ejlG%b~W2s67gMA?%TbzD| zp$$#CoGht>L&BfTm7nE{UB#b;6$$Y8`@Zo3S>`fU9kJ6DGj8sW(~3-KA3oOM>U8a~~*^5qc%lwnF#L&b?4?F#_t3rG-Tzy=alA&8PL` zL(3f0D&y1eea@PWOE*P?vsxTfYNa;(#bYUupUTb5jF53~R=sE0x2;X5->=oRn%1tw zD(HXGZM(t^dNvdHkcB7OW@DS4RR!@ldIHr=#lgeIHS2*x{C>2vc~G4p_Ss*TWq%{J z>G7C_L!Wpnb00yAvvzpg3irEH ze8axnmYHIOB-)R#EM!wIT|VIDYUQOxMK`Z6pWEwwULG-ay~fA!085Nsm5xWVBH&y( z-C%qH+*y+vYE>H5hA{*kKt{~QQ0cci6desG5tFS5AkKS2a|?_8=_0sleT`>U{19K0-OjxF@qN!X2uM=Ez+Xg!`O`BpjJxUSKj%)?TV4Sa*z`wX65r?B zk9A*L+S=sOO_2JqS@Q1AUI25Y->1RIv{*_7y=`o~jG!Qhv!8WW8$IBcGM^lOR+g52 zERt@JPI?7$X9&2NfXE6YSvPV&Uv4vb0?0{>^fLNzzA}bgiN<_f$I#FafQ|=0XCUo5 zhKD67DTjdIo98_jYJ0jeFueiDd$UC{93@eN_IH;>PpM3#ll&&U&lcN2xTjI)%vUX4 z2k`Q+1ieYAk&Vqtop}tP_XH@7Wi*)pen8u3&$`_;ncU6D5!~g+uDl#(3wEL@V_Aif7e&}wS`%`^@EYUA19*M1z zA5;_-^{dt4w{_-3`|MzbGJt`(wj2J}xuSz~DXHE(SG6Thaj(5r=&2#irRGT%>1 zAI1l{ZX&QogNJF(+z3zkZ$qX6h)QHQ_|6%Zk?cXVcScPYa$`{F4z-}YE2?l-I?DEz zb5|u!*~(R>?Ib(+x7+~P413>{V7{(3JNh>G=rn004e3k`d~iAl)K%8$upnP8srNq6 z;b#2ko%MM5*Z!aX^^9(8_ZR(KUfyhRb<#RIISF1*tg4ERnb2-$^gQ3-zXtL+OD4SWB*B#9yvX9&-<- zOJNDsTU!aaCB=P!@@c=@jzWKVS63YCaa&-XWAuz*h3@@2jdg7nBLl)S+lqVmOSAJq zxjWQh8C0Ew+E1jBpo5N?8&~bxwZU3lxncqZmXp#oP_O;ET&;9+{-r7K*9&iyRnp|l znAh6@UMb0c(7$A&;Nkorkf1OEbG-QF`)b~9^Yd4!3T6JyrxWhEQkA#aQnd3?gHBH8 zT^$o)LUGA7X49<9WPtq_J8b6DY1K$cM95~YVnM*}W1dI(-dM8vCF;lU}#DIhsDRh^a9VIjH}XMx7j`*3AmUS3YB zdH}@GngYN=0r(`KUPKAmA2t9F1$m~@a#LF_!*vAZ`&(?tF!Qw^Wp)|tCu&b>xLoli zoB$8zJ(NkIUu$zS2l6XG79naK&WFN6Zl6?7USD6KfsNer_O`Cuw-0g;$n9WJDO&tU z#3>>15v}=zNuL?Pfe5%CX%%ycd^`c?eK0kc5ukiwbZmG5wldiQIyxDl!D>7uXX&m} zAbrro510mmrgpy@)5EunrqxMm2X>!#2NK`F^`V+=M&r}(qeEITKL7$GIBR=lH$Du^ zgP(Q`6Xn}EE1){cra1u~fqntbK&TkOr)j`6w_x5|HIt&>Ei*asiR0B~4`1luh{HeQ zcCFp%si=?|Mk{T$dd-{7X;7dpOWtrzpV5a{?y40twTI!On@`b5k}Z^-gcv16^{tgY z6F0@D$i5z3iBnqv7pz@SFZ_J!MaI73lcCYq?chD5o8kMGP$rOikMmh$rqrDb2I&`A zPlD#qKZu}nS<*#x)+ee3ozsSco`=9`~L+>b%(iAc)RW9-$nYqG9TwPf~R{c7Q z9^V`eEJvZ#&TBHy#HTESKKS%{tOfU%PD+#JFi}?o*M<~5P?3{6{gxN$ZFKetrFy|= za7qHZMQ7vNA2XXMQwU{P5^-Zey62oisk`pNI^)53r%2hJBK)p9?`poto+H7yZu@gYNS>~?9j&y?AOp@By;`Fpxr}-8GWd7z z0lnd35Cx2)4M@@T)g!&}bOCvC3cggo!SeHKaOhdUgy5TRJj$O!uWMqbx6$qIUBeO= zrfp`;gOjjucZNYs1GqWjzK$>g`T18rU-8-C9iqwvM~Bo9+0no{(~%I&(a}rTtS?`_ zcwCtYg!&5W1d{q2L;-%3ayN#bAErh4@69K&g=fabFuap!?kGd}%*SQhnL|C)YmIia8Y%$i zFX+1>pEyzhK%OWEggAwWwl=)WO@&xlu$FW(ng$95AhQF3IXjjC8>(>e3sbF(O0O@% z_)wKcKwur<{N2uTxk9Aa;n6K$cI%yCkN}m0iFfZp#>e-*J;qTY8?VtkFBnOt zdm4z?8_#)Dh|`ga2dqtDUt?KWMy?k0VeC)iRL4TScQ!Zuu`sE`yf)@5+s?s<1kfcZ zZqB>IMJ&fNxft|2O^l5ZJ|1)*Jx`ufX+*7pBBgRj zM`i3X`|((>L5MXcHYP)ke{K2J>Ha_vFyg=bMK2H;9W`2z`F)YAF z;GtP>zW}}h<2scO8weU&epCk}u7tW@FskU<33@Ag1R@<40E>dh&0*9<_!}2-z^RBN z#5b_Oq=E(Y79A90_tR6j;snEaTBAG0#m_7$If6+vO?*0hUc`wXsunSFmvY|GBz=bh z)vhSCXjVhrL0JxFn!1eHr?%0pu`IF9Uh9(sFO79_t z@77BHcEkc-SSlQk6rx4Y>XA`lGHnMeUKA#PiroX}y4|E>*;jWCLx(`rrbrM z!W{t$2Yh{o!%n9UNJ?}S=8{o0P>`dLLdnU#1lv+q3Cmu`A>l!qk9wkbY59PO z1*CQp2?!v%di2I}x^fle4>x+49xIAU--nL7(k{3D^AX;-d!QJc-}Qg{yILur!omDf&tw$R4zrH3{Z|v{B5)Y z)cOrSu&ev!l-z^8Vs{k3zU5`@74^j+At7vK;jPY2dz4@*7iFhG5}Z8s_E;u*xDhQ; z<_{ml7quL`4YH7!H`RL|eq^OM)Ieu-=e|9EdA(x6SYCI#D6xyhKQ=ZN$YdAEGg*he_?1%X6_KJ*(2P&y z&^%*M3mEj>KXnZm!PADNF&QKNN>|p?urNx4`s&G8SW64V1*mI7q~TnSR?AWkeH3QN zrx%^*_YgIf+GURcN04*|MzH3jA9}rnu@{G8VCxW^RVw2AK>A2YNP70A%N*NrLEZqz z6o~;Xbyni`*~$S}Uo~Jq05Y7hNo5AH;83^zYym|KUrzD(Jf9b9Nhho0lzQzz<2T7Z z^y1%<_;?`Aqi>2!e$BG-aX5zxiV4?pxbIfJxqP%Cra}-QtDPPkx8qIRd^(&deycGo zXme45Fe*CpFJ~DpOC8(lj{csGdnoL)hXp?ZX=p}5JN ztw5r!d8>e(EhSv_o%{5*07B41>0u$+P=1NyM(F>c>?^~nXuGxn0qJf;x|A*frMtU3 zMM6rE?vzHPRJuV@6lqC8kdP9j1yMSr<6Ay=`~Ld)!LbjN*?WeW>ssrqrEZbKSQ>B` z^+>CX;1PB6+spkuP7}NE&>O}gvZ%snBTpvI$w<(ptL}?72PcpgYWr_49FE^2yBRls zDdfTN@G?CA74DBeaHcaiWP%Ia7wv29mrrr2gw?Ceb6l6!w|U5T^^B%_J#PkleNX$! zWo=xg>0UT%u+TDid{wpZpc(Nod_^%k!^)bU>EBB(x8 zzy@exqoa0&rKNA8sr19*3GVEi*-l0iSPWe5SZ;_Gf
    yk1}drv6V+uiXbF{Iurs zSFYmdWUSK1VO|M;hCg9cpvb>YHv}ewDiSWA`_r#Q`rAR3+hK)%HDA*~vDfoLR6ilS zO8AUy7^gcspI!}s(m-C46HL9Q+Q?T3X5%wOoXqvmFr{w<2g+Om71{P7^4YD*chM-{ zhAQ&pww)s*Yg~r$wTdY%7@s&=h#9kDE&JLsEsi)W^pCBV_BkXnb z=x!JKVjy+e=@%Z?87h=9q`y?K& z-BNcm>V3#SeqB{sH4dBylulNksJZ<$H55Z7SA?ooyFAoQ)*D{;E!*?xTo>_)W~pCj zb`YmdH7HVCXnAo1)35Rk#v_#{Q(cMioZB>lDqo}h1~W!EqBdr#%HNMpiqE#ZO~+4* zwiEGcDQ()@7V#w^L><0(f{r7iL$&fJ=ok1ru<%YI0r_<@HeFCQbL*0dQ@d9#^~67x zzt3D$;Msg~I5*SiQP+)Sb$QVYT|K_LV6mV5wOmP6ZG*x>bu%!m+4|Jp_KIa2DpnQ#xn&5VcF(vk01CA7S3-;{O|SUsE3BJ`=L?#zf1XymCgz_s zdF2XDf7njhgNx(4@VVK)eKbMKy5b?NuB8>DIGbTVGVZaz{uz_IQ3hX^kQPCCb)HSE z^C##nn!u1NAaHIjI@21UR^f7X)T%Gxzxl<$t1#h>N2I2bD&KyOz+>~+(tJ^UpvR4>X=`<|8cMW)r6dpzFa0=C zUe3Z~D?2^gHvfdi7LX<2L^6dei+HAm%X-53nnp^S`1Q7?9evFDUaQj1*iu$a-R%lh zGW|Cud7ApdH7)~hC1%PnUIq+`a^K>2)GzZ~n(7*kj5l-9*Jrq%b(FGLR`&e)8#79= zw!VAemRe7W?zcp!F-x1%p?46+YmJqT?L@qwtaef2rdht7X&JoWtX+|`M0b64$bC@v zFHbo;U!x!+q2T@rU?1^-DdS0KeH`anAKx|sK4;Dj2?;*Wt^%#LdMLXczIbIaXW6-d zauknY$1}ZtLs7lFF#(X{MPaT1-^;WUEAAe3v+lvi{EH+ zmk3@a*)g@XzgyhOs>)^4pkgJ=K-Wt7B|`bg_sdb5`di~q_3&}VpZHvjY}&(HBYDrf8ijXB9cy?3W3 z2}$W8aa9g3EnmVp=a88QGZ?9Hzr=F+SM3B&UJ*A%CU2#3+zzZ)EI5;XvJ)?dqkkHe z!jyrohQ{`WH9DT2Kv_DBv9vHFYH+6QvDQf_%jm0DeEll1vnME5dz_hRbVesW3H0V% z?y4ZXW_`k=#h82}#b+^Fn9RN*fSpgLBl{0sW1E^Z&DboNt5X`Ph}xpm3X9_L9X7_k zUQX7FDE-S)sV-?_QBt*i9@o65Oz)B?9?vHxB;6zF?1>yPHqlnzx6q`+dCOPLuE} z3xa~qKg6)Vs^{Stg;(shz}>w^rvhVS(jBl>odc+04RlWC5O>J#D zj!*f!t%aQ9Dzu1>;VXep9gS5y;P|+K6pEbo=@nv(t(N8rIhSmtVvF!_>5GNe0^XZ@CqDz4*^B zY<~d4XYa!oMN_o@FgRx%K=_<-Jj$5(i-`E+*Z%(xFMo@dNvlw~BrGZXM#)C-$$#En z9I5qskoGffd;1?pT1XboVr#3zyubkK^r;6))Tq*M z&5ylLzU|z-pJ|rq4C)F6cXxNM!lbhaGaagHE0^bw9wlaRW=RS;&wedsscU2S&nd$7 z2@JGtP+y&EO$AHv^c!cUPln*P-??j<1aeVqb)y#F-sKOZUmpNMQ`#_L8`9?CXjTD#wdn){B6O|VPceGKuQ86*V z_dLJltN>!z%Oj}`C|4i;7}e67u=`x2p|3w#>8HmtHTEvt>+(WmQ(l&mtOqo(30R2i z>@PvQ_9;dI6+ik9VBX&p>HD5P)hFZfiCbJ;$Y>xweUDAShl7qj4#HclLgQN7mv=E&!_{WkP??FoU?(#y0;7;7>Q`e={8!!a7iD@Dj@0Y4l}y2&t}fPIq(v}h`T5SaQ-EhK zw4x&OJyD;6jzRO(JxI&|uhY!TOd&`*E9tB=1K1ED8H4N3fwl3M3K}Xm{78|Y+3Ps8zD7lw`$ov!);B_Qpnta=WuHpe zlJwtyNb>ZyLjfzzuEqC>At3lGHEYd@ieg>t`Fb{u>)hRq#IX}g1aa}T8?$fCX1Tu-Y_U=u#Ya$|k(%B2AMcZ9eVi%Qs zT>9+~^m{ZC-}0o^7*#Sh#JwX($}hL?_Z=%MJp z$uAj%?C*sHzL+nq0r5XbpVwIT1`paVT;2UZIFItDv?K7jIK@Qw`)5amHE#}|VN;HO z%oOqKiF^6VqJ{OxsDLPNuD6_OiV zgY|Uq?F0oqzMdtjvrhId1lgYu$wd`HkVSv;+B{~LM1*EGieF>9V|}L4 z;c#;U5_OhV>*Yr{b;|`sW4$+~h|f&wT}W<=N7B7=bas9Ob|1MOl#GmYKnmA3FOaBY zq@{D^k`>w2X@bl$5i-vZuQ-B>iRq1Xl@4lBl}i;9cIKejbtKM&Kku-w$VW(Osv&L- z_@0L!uR78Cv(eEZamD~NiEjzIVG{Tzgjz(-=Jgi;?8K9l44Io7Nf?6?MB~DEv6g znU6E}f7fU}8n$p>e0<_0S_Hkviw;G*^wrn89%+CZZFk3N6^xhP`VCleKUi83Ka9ZH zpe7=UJOg6lSw_advu}8FQ{Pgm6>hmn*MjAOHZKfxu3cr|Txz94bo3p`mFduZnQ?S{ zeC|Oyi1`EKS=ZDJ+W#pujGaHJEcWrH4JUn!4Y|14Z=w1e)uaKh?F+L-dTC6dtkd7>HCizxAW1GCC%O2m{Q>}Z7X`9Q9k*2 zUUU05)eE&e&6uq+$WeD((;#>f3rAgzDM%vy)`l6hi#8Hz!lnBxz!>&2WYJaVef70diw`dbc zcx8!WQ&Ps^FS7fMGnBIiMA0}E1ilQ?dU}JOy_SGZ00|2z*{YcRC>O)lm$wFm%3i>n zLg>Kp>FF)UNn{<R4o*!FvL6ku$8a81N} z669SiSK|?BqD(3H?2^R-f?&ZPEt{y4i=Tyc^@dps(v-v!FnfU%EmxhLx6JMBA2<8q zpXvVLyS@LVzR(-}|9E>1(DH4f0#^FdtDP#2LJ&igUT|A^1R;e%$GiIV71o^1v)hmG zc`VB8?CrtF48*Zvljpl4>k>w#6|;s13ze;<<0V?SyC4gID}ZK%qGR46Eho3|f%cas zybG>7@Q&Z$;X14R5@xIqf=mO)lA5*?4HPnW?_oy0qyS6L-uqQ64 z`A>0n+by~T66asZLEFrz4=&C=7buaYKO+@%F^6cK(*$z7d2kkz>p~XRW3^hR>DMSL zSCIu}UBFAV1~ntd@W9RW6KpPFA|b7XDn@Nd5+$)Jw{oI5b>Nyb*bOg&e(Z3^D_Ys} zq07Nx05t_gVcwGj>A15r;jxc{gNNYB;oxXoC^o3IeOg_;6Gt_TLw#}8UP3~`s#`f> zO-q#)@n`_d9#BD$GlyABD}z zxt59B9^9-%al zkMGrfRvnDbn zNk0-g@`v;Df|LVnl0uM~liCMQmlAdCv2*R?6$|5q zCd;lQs1SV5$O!Q8fPvR$HOqlb`@a|U8$-6OrDc*S{lv(~`1m*m4$ege>TqOc=Jk}_ zoBX+Xc_Cc97SG$Pu9#up;Z+na?H$fz4vmNq>JBh1RHI)1@Fm-M?z-__DaK==e-~N| z+l2V?5!pQ7?ZHO6&CK|TDH|o=Qko)>lAX);Yp=EN?zRg!U96to7|YHpDM5F}bxN~# zsgC^5r}M`^`u;t(H;pu=`RWbr;{1{l|8E~RlG%!S)AZhH{G);VU*Ro}?C-}b+o1is zW3?4EXy0J*(xGZz=RdtH0{R)zukMuSO;pIg9E!hgjU#2~a_^EP|L01<+Kd4*NdL#v zof3cRZ2vf-FXTO}@M0?d=K_c$iJ|;*ly*5S()_l_ixNV&oQ}fy`)wEul|j~`fNR2U z2g*YKl^fxwS|D!!rQQIbbaQiYj0e2AiokJ$u*axO*94-oZoMG|TP3+`@-@Q$cBtYb z$fL^2%1In5`PSfIgBUb}Mh_i28*!y-&1)bSKZFZL!vq0%m_dLqo$TQm+5X zOL+u>_PMRt*p;xUgr|mvXqcD|K)-Wv-~rKrs;Umn&CRfA=a-c&E$w+M_t|jKiszX$ z;($g89wm42K(XDQKYxOGX%zS|u(mu}8`qdOd~^Rp>*e*S7C(nvcCZSL&Cb3X9pw`c z*o5txOLb-NQ9Tsv;IS=KeW6ihj?cHad0{z{zvHGBos&b$MvkTSz!lu9ay>E-Nhr-T z{J6@+dw=yDQcf_VHPtKBb4F6wDRHjfLGat3EE)_9y5bZZB369BQt5edW+2xSmMi!B z_B|3Ne!{jBflWw7#qXTi5p>0eosDh!)xC&!kTTGYAn1D(Si7f4pXWF}F7O`489WAu z_rbQyGv2!^;JSNE$_Zf;`p>Uu$tfurHROX(Bl1kzC{xHiv%0z$+=~BXImqJwn3^8E zp`N`Rj{R|MqLM>BdnlQeHy@Su==Ag|Dk_Mb{dd29ui}Hd<>QOn8=IRc+Ffi0HEm52 zau7lhA%T*IStlI=APMyDvdV_JB7HYEKi6uBqW1lE^O>p9_%(402+VL12`bDs?F4HT zz`kQ?4P7R94p85^EYLxcMYy?*&Mh9E5g@g`!pCX1%F9W7&RQ_#)^yLJ$*M;HAB%*D zh|jhkd6>#u=;4pffoHc8*i66VDn2cxGZO}LfL&W)&gH4uJwY!=#}g616YD;r>9n*o z>l;&3abbudBym)?M<5Z8Ol*5Q?HTE0YXB#YmZrv!7yok5{CXJ08}I-tC^T!8sIwmn zk_gu4;peXtyJ*W=+}_(G1PAOR-wSFXx35P>+|t&I>swo?ymvWROKuduett8R`&V8V zrpf0$uy(ohmc!=Rl7)4gbm5n!=s%j z;8Wp7FV@F_0c=}YXd2JYd>1|k8qxFZ)9>fyS(&3)3=8@4%VUtL4hDEZ*39G-_7r1>qi`1wf3jl8v1kZ!EYy8VdB3cjvrT5q)X-nfC!tW49K4#FXH15efa(}F0KYe{N-6-+yA6`^cGxuk_ zBW-RdVBepp*xjH;~>+PwzCF!igDT9A+ zg`gMd?k>#boD}#w|H1ck+-G%2L&(i~Yk0}|9s`&&@l>HwTZi(;Dp5I_#-(g%V8Vbrn`zLZQNrVk!b$Tie%7X=fR1$zTCSlLGDj|$_{k8pA4fM-{ z=})R2f<66~dAd05@Z*|y%&&sp&3p6n@qrJAxkgi8gW}3xGP+-)`Cq#EO6G(ggJw)) zj0fb9q}j1zqQDw?24=DL&q%kwLcS&P)0YOdam@1tEAG{c+A z8y(e#tl5L59(1!;%3crcVgDl&Mg8~sBgPs;ZQgyBpYPvn@hRr`=O%0Aze)svAA0?~ zcW+5-ubJ2usRmGsc%ugBhwrbMQ2qPA!8SfpqeWg~ql^S5@prc4I5?j`tRF)xN5LW-sh&8K>;#F3j~4%_O2luV+nJ|+)z;1NmSq?M)M}C)O#1=gIu_mZ+L*HO z6=DW-XsNpnc2X9dQa;gP_x)A;N4I1$gjfL-;|n*nK~ zj+8}D1Oj$TrhoS5GbCid_%XjocQKY5zr7Ym>Z?Iy^kzZLcnm~~G}>jlwZ6w#+?6EqOZmZ0bt^aovOoHJrr;gG(^H6+r^eLZWSaxAyA&68<(!XojQe0w| z%>(eM_;dmLXsxm|tu7)g%;E>z`Zb6YQ-{m%^e$K?j{5SA?#n4ls*mB=)2|_D?DPN| zD2U9=%3pCnxFe$_9@~51i)kMkLaReUI-|N)=;h@#HKhtUpq=1Q0xNDQ1V_a`|Cr8u zrOYoMu`Njbm7Obf)*JN{o@L3tt86E~bmVW{mZ9Qc5&yIIA2}}jo{AoB%|(nPfx2*e zdmE&`^rQBd7kQs+dM_y5R)^5b?+<3a&=ix04eLv1C((eD(?(x1>rI`7&D*zco3*Ti zi2NrAEce$Y+{eq0^;u<`To!y`#o`*|F!7fjBxF{-Y1TqVKoe89KFeNvw*48fN05CYN*6x8R#;w}T86OVQCOm^Cw4NOs zP;yT-d36-2=ufn_Yn}yR1XY-$l%@H0@S`SA-tZ`>H zJqq#{2|S!~1%P8^-#%c3CSps>6Vj^GZS&g$m|wl9A}h1(>Vw7Nt?QC=IgS)G%-;bI z+Sze_SzaE2MScOvs#R57>mROSkp*jnV^an(wuNo|7`uszD#T65a$T?T?)Uyk)F3*dRbhlgR5U^Pg{jVzm5FkYhnlRLqFcLZ)oZXW&er3t4=LydG)67F?m z$-K7q1?)%#sW%c4>J{1Mcl^)rZegy;d`k%W7_&Ag#)*vlMJJ8y>_puS+!{mT?mNZV z$a@kbk4W|_O!h)5g3--;11|lj9%Ij6;pxPi)q3kTM#`B9k-t=rIf!ig$XcDH0$jJxMg97^ z3K04Du$Y~3ByoY)G^{d5_xPG8i``}MX^XPp{JffQw#DxgyzP+wdTY)Dh@T+6uK~g? z8Dj_)&m3ZbRq^U*!trvd*ROS5-t+291X;?-yzDXH6Uu;Ud;R(t;tclZgZevZv%)m! zoNTu)HBG5v2#P!1vU#HD5kuLSY%LPyUX)FKdCPMJlf#Zko2UVtcp~g znUrWg1td;dM&`%b+T7bE&deu}STpsRIPgxt%E1B75R0#`F0D~jwp0+(fn9LG(fh@( zuvIkDgYw3IRbD_q0OE*>O&YH&0znsJ7KUk0yW$QR9H7Xd^(b?irXGBLtdax`I`KZC zb-?*gH2;PBsV79l2Cp6K5~@Mij`ZX$NZ~SF>_pQ7ix)Zn*=CD%tO8LR#W^eQO={qO zdZT83v_0&3j@!!QD6*4D*!AAGyh|%8KR6DJeM=Q-<8wW5%h_h&x<6J zk$p|*lR=Uacd!REr_$69pCVuVRD)2~$T4-<2hSVdw?dtaiYj_;QvY)zs%6GdN%lsY zCN2N)*g2O|iMqR_*F$xNKpbH#3Q=z&{0R)8%JS zrtuvGi=pUzQD4iI@eYsqEy|)Ru~QDBW%%N~w*g{!k5rN?4VJ)7lr9-|E$4GCo^B1` zcS?gX4Xy^Ne~BfwU*H{8p=+7Cz}LHA6j#$9m93jel``^yFH9~%L#2IueAdN)Kzw7_ zWr>yzK@~`oR~A+oq!l4@ss8Su=;Xwr6#49|5)IQF`lqbaHo%qVWyXutF5!lxnMXv$ z3!Ps&f8^_H494IEYR|>c^%sXl#*?Pb=Xi^pYv@vBA2+9)e(Y?8xGnid&H*A^P z{Vpd#zAXSZDk0%lkO6IwQFy>d^*b){p@Ds7Palyq6fm&eV}io^bK{}eC3g_keUaqc z8#<*XExy0T4QM)BSX8?d~wf^m*O!a7Cn@*()DPs zkK}2dBWQ4g@bz+kA^*`2O+BD|n!tXdO6f3K%xe7fS9mk5RvM?XyeujQFh0f3G)J-k zgBXvKHaa5FyAhtj7c?hLCXI2CR1v8e#om`U*ChB9*4EC=@bU2>dpTsP@ES3_bUy9u zn<0%`7RS{L7MI7+d)&#^=Mm#HikQ zh+^;!B#5x-kiz}e#BSDtW|>REL}905Yr8U%{FN~GR*AI#N=ewr*G~j41R>RY+}t_F zZ!s8^gcnHUovvd42niUjimh*GSSSvsy8U{dmEinCEZxK6T89abE}gd( z#Eu3O!RUVhz(HHj136lJiwNGuQME#6Nk;o#kPU6tl3DG#98zNzI$<}|uY?l)BcxnR zs?UGSt541}WA?cwtIxG;t`2orX@lTsfiRd)wJ$hAp(oBs8>h3qQbs(KLq6}>!M3EZ zcL!04^ao_q=8jnPP&K>zbkr0%H0b=OlwTr8w`N(i{SL|x2*>a6om9W-&(n-*SIoIo z3c7}2fIV}tcB@{SwMfLr<7}r#=&bDCr$P~BJV7Kxm3c457jJTMBH~NiT~W{!gJ!db z`oM*$Gj+Rk!6106Sd!V$Rxa+$48RxxC&Q~cR~rcF;H$Lsc zdse}7$HZXwlhUiKs+H=YcttAImqfay31dSWKiB*PKQ{picyxt(Rq~m@OVZselL!g; zyp_`5Fj@r#41K6jop{STve~cU!;Bzg8`OY=Fyco5JdgOA&llj(5C8Mfh|?vsP+S>C z!L;qrn(O=;@*`NPf4=tXQf;X!73p*E%8D)BXUtcI0BQ82lZz;;&k)ochCqzGczR+= zBv)Y5)Z^T;e7twpXTLsH&|iAoVngu7V)K*PTVfAY{}Lj|&#&PR<#)?-oO-Us(4>E^ zC6)ik%*{P~yf?k{go;H%xfQKhoFY{pGebT)xTr;&gP2DGi6J`)p{WUPCBNoI8A*6( z=zLXOd4q68^j{>(d@D`1fPid=xh57?+~f8#%MB`9zWv@(PPKXWu5RDsba&~$?!aH@ z6WoMM4$2L7opL85#CdUG^&uCRwct3`l{Qal<^FN6zl^NTG1O(7yyJ94T$kBMQ*g+$l1 zY^9&=OtL~aXDgQ)PX?Tyl;yf#oHIN7Y2U>7J5$T|4YFPA@qK4MS(5vAQv=!pX`zlU zc8uAz`Jnrh?R&oZ&8Oc!+y#ueA%oxHCK~V!!EU}PIyrZ&KD#b88JqZ6mpc{O+1S|$ zx-LGzD>JM+VOI6*O?pavL%UC(S>U*TB@V*LOn06O)jVZ+ek)aBN=u{CaAD=AqOW6? z&Ex5_$t~5x z@juG(0HL|IDuaaqjm zFW;3_7CYNE2(|mU*G_oObXKZ@o2A4QALcrsh%%t;R=fsFQ*uE;SBX{+fGwlFzA3vF z9kLS9DGgBBE1Vus<+J@$17sy4yyz39?`NCUIavQ3O_b;qur}db?>v`@Rems5mf(Nx z{Wv@&#mjA3QOnc+@|^F&I=h4IlXRwRLv&5u0QL3jukX+Nc)<7+1q*xUyW!^o;{rbg z)ey&VFO`k*e#=FIb*F)0E;c%j8%!-m)4OAR)AXnFu19D5-|}&a;vIdDvx;CZWH(W? z9;|5nHaXC7cQbM-gBVkwRHr;pg~RV0w^G~9dV+c+FI-FG=KHfv%2yVZ)C4*oh*yUz za=)D|UEdTF{5nWQKyur4A?lVZI*QZ4M!A~=O>3+Wku5{8RNm4eVPXOYZ>=$mKbd{& z-l)9`k*bc4SlF@oAKBUWR(k1;P&og3AcF=~#a~iR9ah$ztbhwh>kA^I z^k6#J?|&88%gxhEv)$0IL^Czdtn+`cSD0PIQ7N6c8~JpBp_LNYdDWE1I)?h`>Q)#1PqLf(4nUb zxhuN4?MC8TEexU_`yQ8DS>+vWO#AGw(xSbw8!q)bjoT(tR91#g_dU$=%138mNM_{j zfb7|MqY5bM<)lNwW|aLW{g?g;!JzzOXQwqJO#?aaJXWewX*wev!DR#KsE(i#bLsIu z-VMvM!he7DYAa+=JsQmP!@|M>?iw=x;tAeEpi!&s0CmmXTWGie;1SseBzv@SuGr_% zVe4fJ6eKcic$dgPDq^iYz7xxCBoK35?2m)F@W+e9PL;oglieVuqhV@ z@P{`yU67KHgts?5TmxEStg{oSN?QnXhBO8Ok;u6kMkmxqm9!&Ta(t4DoyUPHtrrh( zb1|^8E=MThc<2`H?&^9egWJa5(sBFECFa_l!WV`qBJSTs`4S#~^f+(S^&uzlTit)L zTi{5AkzZ1`ggWZ}>W!e+MW&AF6I3xGbl+><3qR=Hd8M=nuh>bScsG3W4f&z_=)q<6 zNR3K>D&?4d41cjvM)XXnQ_Hu?JIPE{79AeNx4^0apfW`!clrLetRg`{A|%t*F~9@5 znn?~(290`?J_6j(=yS+%{}VXoATd7m`E!^aQV4l&!onoPxW@pm487eY;LtWtR)Oo?<; zm+dnI^tU^PM#q(uMAg;tKUe{ZuDh%2;g7Ev7J^l@_;`3+0T=6mfsH_G2fHzPZE zY68RZ{1jb7iaG7mKAdI-PY{`BQ=)|89900 z#^%g)_JqXSA9Dd*Y}z2!Lt-q4jXREOL2GJevVEA*d=JRB z*jx5=vy5u@coaj=ksr%>etpJW8^12%zc<)=9kaLnAVuaH8*bLYT+?OcvBSq!zh{$G zw%jEho%vr8O;5)+8+O-iwEZ2@@of_(E($0)>9|4K&7B@Sab00ozCWFpm||(**(FWT z`qy6Gs^=gCt1#WbzBv#>?ykYIiMg2kRCS?T{SYHG8L1Q|pUhz*@U!6OBrJtA z4o*&29K!J+YG%Y++(I~%8#dB!^eTU$`IjM>Klg&e8GpNFjvA*eMUQhTY0iNT1> zMw4$)n}QG)8m)AtX`NJ;o;qvn`t`hQil}hVgrg$X3rReQaI3eCeRBt!kdQYLhD5;- zk`Vy$r3t^2rj#8W36>jXpDsig##4(KHtLeteEs&wrX$=*kkbOZg6|cTo=mkLd2N{@ z)S#8(hbD^po#b=9Zqv80v58I!$F`W0H>kE`9RV-~Qjal~l-1QUL`cH8-bzb%N#)7Q zE6XA=em8xz+1fCFh-az6?Yx8e=9RCP^1Qjn@rhPgG0V3_7}D)66QO8ht!wsPKP@0~ zCaW5R+%;@5KUBWl*3vQ%dj6R%&&ECSah#SA`5k7@Ied}>3Urs+H;)oB^^aDdGh&Kb zsW+GH$P1PZ!yw+d?RUa3Ii6jQL&1l2S%P?6Rkcmdy8^ioWK1^8%ot=#i?i7|_56>v zPON}dsZ127H9WsKCD*S?1n}K@tn}Urn{|O};)={)^>H>MVx4`==*3LqBTv7{e1+PP z0wtv|x}ZxV&@($O_dRq`#K*aTfkaW`Ss8VBvN3%bnr2m>`>qo8vi6bN4Vdw;1(yeI z3mj4$z8?P%9~`cE5V))a)y7V`!k|!uIKB|npO9M2{F(-2u%Y?UN>X|gn}vn8p3KcQ zAG)=QRLw(>q=JU(S3a5`Q@;h3qa*<(zGHoJQ@2Cf^)ezfv^}Lyh3t4SnKx5~*2&Z@ z^YZ8yRvA6I6IvhMRAH{Jt<^H97%Fljq4aaKFQD>JS2qXsWK4|pJJcc5&^sO*@-#?@ zYF(k|PjYm5xH~g0~9PC!sn_5HQ8j$9VihzuMIh-ATDcDk0-E3SmlEosG()*E4lF`w%xxbgAgRQvBUY~pl8-w-_V)KqfcrK=BB2)qwPSF*Z0Y3QlgaD_OR%D-5-&GEX!^hWecQ+ zH$6Nx=dtOqt0q#3$il*5zYKjeRI2jZ(Rcj#Nqr;2_YW^XZh^_R#uDp!XVQevM}YowVgLtea^KUm7_3R zi=D-L;XGaz*!P?=S%$CS_{&GSLdLHf1V3TV)I9#HX&3iFvL7RJd;o&kSQQ4-p%hL| z_iFV+G4rD#QU#GV3?6mz@$%0!;SmHQ)mD^YCE{%ZFK-FMjLB{$2t+&eq-D3hBhn+O zCqdEtPNZXS>&6J9qF_{HG$C`G$M+E`3}OMV$*}b~PWSmljx;o`Ywf7&NQdzSN_y>r zpg>-^F7jpJB9z9liM|I?RGt8lZH2R{V*f$90oj}ZQHlkt_0nG#jlMYB_ZY)GP9*?1 z|KQ;3O@5SDH#A1u*|KYl{j-OL@a))JN*X+OnzV8F(Vav@nAuJ5P}{TnriX6G5G1IH zOURHkYRcnK3TU<{(!PxS3IqvWNtg@g5zg|Ub37W!Fi2W!ZXLR$OxHQw&TJb!T*c5u z2pb-$nW(%(x#U=7Pvtz7T$cI<%#$8_X&${=-rd0#z_K%V?@|QcHIJ>XN-$s^HK9R$ zS_8Zz1yP|JPNs|<#b4Ux!_&rop>s$RWX zpPn#TW-$1BxL7tetoT?IOV8=nJLb=JVL}9emF=pzHF9LamX;%TM5>hVI7}0y4GVnj zvxIkcT(^nLc0@mtB}qo$hf{SDo4bcgrm1gZmVJQyB$$_sTEx`!Om3mYuW|Wyk0>Rj zpdDu}9uffI@p#H2f|h6lTXVQEv9Tb05jLHsmo*NhdwQ&E7=&)3h#J&vR zk@GVV=1DL%BIcS9iO%JjJ5}}f#g?+0sotPOenTCw4y+jE99Pg@8cW0#-1fX-N;bD4 zH5Z~ZG~J+<(DHg|jL#6@2ZNgQq?hLHSV!9tj!cL&wBaGI_C{u6%wna4J+FRM)GhMSshBxlFGz(4a)C=)UKD z?s3?dx^8-97>iO1UQ{zZS1vDSFb%ACVzag zGO)H&jOom%Alo9;U*u9!s-8p8uL7H({L3WWM5aha7&%_#wI`r%tN!5h;H6ZA=tu7; z`Y!+LhL17x6E1vMM6}G?nYIRs9UZ9t+teD%?d=M*k8z z?S$A^KVGkze&d4{&B(KxH%n)4sWtw*k;TF%>SB&-JlY+f6|R`J5*uT6ZPT zy-p8I6cq_n+hy2u8!(AnRw1H8fRT&*;o89yNy6vi^XtYGu0*ihbVP3~bo7|tjhV=W znou|445xPYs*A;Op-9s8as}v18!BrzG%s)=_)Htq=2Q=E$AyS0d z(syEPi#Nj)gQ(3i*7({Xx6967jBp8;{n;hV-)7G4rO3mHO-!@^y~cJoX@*oRg_!we zgLN;`!**(;xS8w9j4)rv|74$48^@QJvU*~3ljqhsp!43|s-2m{5o0$VfXeG$6I%pN zt>3Bb-ETFUn|`3;+Fh&k!CQ^r639kxVYGg*kAOhqs30w&T@m?cjBA7D=Ts;^G6I{RoS!40BBO?zl6i zqLZYN-nJJrm{eS@$&pOG7`rZi#p%&D*>avox1l|g;5`+uq^vg#9HNK;+6Uwm6&t%U zd!eEEr}3|JzGmymmxlEX*Rg6JOD~wdpOdRkSxE8@DXlEuP^we@8+o=Zy`L$y<0s}@8^+cSaFv@0U7?5z@=w^ zZ0#t_BPu)EMlqhv=@%y}5{sTs2XR)rN2n(PeozQ~)%wN;r|FrLzhI#P0&-O?HCHxs z(a0XvGh2oNk4W)_jZcGNVyNU@pCPTx0Md-CC!5a8)}+ z2jA7?Z)y`>%rOPU=v%e)D_XaZ?(9(CCJ}vmUai9Nn;SpjE!wJ0#do*Y|Nhngz2*-e z{0)p3XQCJ9XL>TjrTSluy?mfOR@NU{(!ak4Da!`hD>F4(JpV0S8DWe}^vZ8%CSjwHg9`5>kEVQ=O5!T;-yFXr7^B{d59e4wq zG%!DdSz>C6if7-lTB${SX&B0MUuHgk{s5?#5{urX0!PPn)htmMOe5?vUj+mhcz?Tk zdX7&_u`n^8bf*0&mHp@R1|@&tq_6I|V43Y=M+9f;}**XA_0JHfkp$o*lz9~^Pguk6K0Uq+G@KZ)+W{{QEgG?1# zVcctzcO4uKKdG7205DZub3l-U)#z$fKp)nx`<}8umw= zRtQE*!T6-o_QLV|h#8G;vv=%+u>Z@HOcAQDX*11*fu<6$@Q#iS8L%ne16Mx-A|)jy zD|;4;aXncLry1%8Ql8(&l8GZ_$-@Q7D=N~1z~%ZB1AYBuPBZ)t5KO9J+1}6mFz_;- zuPQTh6CQyAN06<8g88vvdJ^M{#ib?uRZbml;FbPM-DLejqC+Yy9s-UpBgcFUk*>Er z9HF^q?*^Rb`}RUeesxdWPwB|kWOl7W$3(g=yybwkaqP~+4oa0$%fHFzzXq|1z6dnr zNA*a9$e)v=@{>t!i0<*(GHvU5o$IShhd|m1GXo^H!fu=zjE_}WSg~~9{dktLFnjG9 z23WWd?goR`Z)bN|>HC3|tu2VLm1t3|@+!Bo1j{*RbZ?-zeSII40|CK1M>~0Q{Q z?fdN0a(Rm%61a1piTDI1CUO&ntLa&p6Fk3tmC_j@K`BMV}LqhUw$p`9KS*d@3DVqDiD%!RD3jk8>bg6Ho{Ug~6QkJASf718L zOx~^Li>$(_ZF0XP^7H44oTlrs>^_#3?RO1e1VdvEdT3blMe^*IFWw8MF9D@J-|5kX zPN$36*n)GUumdj4YrA2PC9PC-1C`JMz~j`bBx^kLgAbe^G&Pgp`kgJsvx7YB;OzJl zsN2aYDV2E4*jypkE{@8mgXl^JSo-KeNO{~9z9RmwtN0ncxUTzbU(4ue2sZhMS&r|) z`uAL9$~v@@$dw{i`c?{VRJvq=dVHEay0K2o+oN%^&j}uLDpwhBthVd?` zryRcz<3Qn$W(95x?51#Yyg*^k-hPZ8d%7E(>C*Jx9fF{f&MQYTOCXx3A+#w2S|g@A zu%ryrIAXR<{^lPx2uz~G+VjDsus>S`u-xy5?o~o55g9 zOAb_bvE;tCJguOR?Ko;J&hz6Ew?_8`mh;jx2Yc6vkF0WHUq9B;CR=j7M@!hVeH@5b zjFRm`>jYpzNoDH2T>LDG)?M(!D$q<6B;SID>N=;khn=blvGyYZ=}R)r zO2HYYrD1(z03~}dF%$?PO*J+2m~oZk+G=hON#JqvCD*(_27e;@e9bKFZN2a6xw)42hq%3R!5lyE_Tm8{6ilP4lI_-nzVM@HA)cU&y1rqV4(p`neiE6Gjcx(Aw z)E{-vy1-`Im$MgNFHgm z+jL;9k@r=FUE``z?>uCM*wJj}8`nITjPi+vXX;4)k09N^0jfF1W5<@;9;N$F&;*al z=^54`5kR()^OQl4yP8fd-&MHky7OK;d@2e*llipz zGtK0(Oo<@pP1{&+$7xQUR zub7KvJGj!7R-!p$6BEBuwB&$<(vbkR)ivRz$q+|ODDP@WvS_-Xg$x~nYJG0SPa%nz z?I&s{E3-ka)_Z5Ov@0`3P~^$pF5%RicrUl2Uvjc5)d9xYMB+Y-+(L$an@nXtNkNfy zftyLyU$$$;A``#r)O=jIpitWC$pOTN3VSkx(8y6Q>TN~E`zTqE*=znnONrb<# z!$Z*{GH!k>yKhS3SF4E z^AD&C_l0KN9Glv0HE!9>&CS|Gr3_-e9bk}$YT-K1LILv~ypR>SyFb1p2Pq(6qdqZ_ z2#ddZkk@tH`7^oyi$DF<_hsIzLz{M%zX2pr;Q%9{nwHU2L7kne$0ED;#33Q_?`z2aXXCZ}XymybW3dfLDS@6-+)tsH+?ejP(pH_2 zrJ>zu8!YVr0rJ$;6dvyPtOayX6P!*Fh|3uld>4j~<-llwaB>P$gcMt58K0V)Z{2gi zGw`X-Q=%e;l+h=el!W9x5QG$v5ef@SW{QJ-+rM|K+^K)KF))(8E11g4j@|jqj&1)M zSDpkJxwNOd(_ogKp&^ev7E}VcWe%I+;j6HJOGuzmO-)T5Z&(y0cGGQwjTjRX(|C9A zgBI{c3_Md^``@_>Uw0oZHl6U;*}OV=mTUYR0Kuw6DDQ1+YinA^l@KY=FDIZlb;`!Z z=4>!xL0D82?(y*9goE|=zh8ra7y!r03cr5O^uvRt#--N_P6pW!gu^2Gf)8Er1bw^{ zs4|UFzS&hy=S>?H05r+oyVn4$On#j8WVLcrks@RF0y~D(!_R^8*Ol2=D%!p6{-amD ztQ+J0dV?By_XS;WgeAnqr9BVZ;i930Egd-QfgGpepA&M;^QR`jLDLQ~Y=*$V$Cj=Q-J6U*0n-=X@*Y9LfAH z_g`bYr@FaKQah0u2+x?k5h1lw`nAIsF-{3H`S_bpdw~wUc`vVVL}@PO8|YRt#7@>4 zrp_Ctp84QY+@1cM#;meY6 ztyo9*T#jdRX(;Ta5PgH%%D@@$=r(=`kRS$tuL)GzyEreaw}ao?1X*-Q3qwI@cUIvHGt9xnd)dnULn zRWaBl$#1*o*#|OjcXji8vfA@jO?!o2l7T6 zxtU`Jv>F0wcu61l(HYeGB^>^!t%>(VhOJIr*0DWKIe5o=lJC~>@=D{N>-4_aq~JXi zDS6FQ|H5m!>ht`OhM$ew*Yy^<^oqCKYMf02zt=0Ke-yMq3ADx_W~IDMHhl9>NQ-vl zUE{Y%>8hA@xj3#;*Nu&iTs86koEuhmzIdLKYmutwMVS@NVF{!)7cTNlx26|gc~7Mi zee&m_3SIYXiq88}iKEIz*DU1&tc)i3lD+5!=2+PR@OpImb0A#9~=2kBmwz+SvCS|g;SEH|m%lL7+7eRbB0XJM??p)=;Px%re{ad$^Y zzT4DS5Ck1RaUuafEnQ=_-(ms+2SKKT@@V&KeZZ-s_fB=#HO{SZPqgwfcIGC=H9g+K@6vtm^`luQC^1ftxwB0A(_92q<@}GxKf4W8W7g`wGXICzI zV_LdOmPa%i*x1-0mx_s+I@h@tN_p=6JTncEvJ3d&e#hvGdOaI5iSL8S{Wc#PR*y=B9+URZdJ%oWF@dpQCi4z+C!W zmKK);kzB_;Dnohm_AVJL1;%*8DeLk$gFP1&{#YTuK|9Ae^LFvXo>v|ciW}P^4bn<6 zspmN@d~+g*(o!CET5T-0H|C<1PF*-qaYoD0ux9d#6MT&T!|qg6RR0-|HB+T73cX$Qyg+8b{DT$ z7XgoRQ~!HIRko=vHY@J{gaUJoplJ;eF+863qqtStvs4L>e%e@NfUL!k$L!d!Z~0fT z`=ADdiMU6m5?K#&HKBXWp-}aE6Y!b{DhQ`J)O#b}Z>j&@+r~z_#vH~7>lc(jgw<9I3clkv5ocRq~H^aEZ5$D}pv zyTkA8gpxWyV3k?E_M}>D-gup-)r`6kvVDCi)o;rN2a^U$lk1DvZoxGmTxY%vWr8j< zUrbyalqD_TQ9ui2U25wrzyLl2mhD(WbMFf>h6J9g#NQF%)R9+^Me#xLIvDVa%Qi6cL`>?Z_F$;IR3op0(xYS`wT=C6ckie_CgW` zoD+T<-_z~i*n+VZ2@9iWVPRn?;ZC6I9vA>C`1Q%=T96^zy?stEOK z3Nn9P&eIbosF85_lEPWJq97kc5|?XMU!_2R2f?0X`*6+jjjZz+ z51p{3F4_pUB=+_hL6i) zU)`_FB;+TSh618wz+~r?>lGOa=L=_KSnb#EjszeqEerO|x+|z= zK~0)ft3;?;8-3!J!B5PJrzMxOPe98DY1-N4N8kDJC1j4p*$np80|>?1`wy2tRGu$8 zqe6atGxE`X8U_PJ30H0H&%ia4@x~y~6Y7cw7r(9d@{@eUN_A?g3wP++%bFSqHrAcq zBZ}5fF5G!2%Xaqc%3yXFPXMQSoCfOdx}%p{fd%9Zbj26SZNjmqLwz6;|BZE6G~ji3 z>~32KWi*}YZoknzfo2AmXhmy=t?*X%8`d2z`E zh)zp$;+@lpEx+NXAlD6YC*kX}eV;(mXeReL29fMa*fRLqpfZxX}K60gBkeR z$Vp}kq2>ws)1(+mdn9i_Wp+Op=kyEpvv2>1xj)Y$+M)1VOTukoSS^@h22z_goRhoL znvZG>ere^i6bo!>4$%O%`9uH+I;S4u9PNA=qxC>TB>P_cAnHrz_);^9&Ev$Og~NxF zsuq!#1Q{i^oAQJ$o3wK-UR0S{6t-&jzFzHQWmWE&{4MUqv~}|F1lN|pX_&oEa>_cq z^GVzNxxQ4-sX_C=xbvC@BR%GUe$7N+CHTg;xo9o;GJVgv z(o*3kJnUla$NIGKEU6!>N2_{K%@Nqz*1FdDOEPKREF3#YkPMxHUsOdySaZ180xDnI zW=(2j60aKDLb_EeNiP1^psEz^Y@69LttG@;?tg}$4$(sw09KqJe9_i6yCeZeh8j_# zO!d^rM)7k)JRlIvsfbgp4g*2?+}uRem)xa=L3Bo;i$SkGv2z zT5EJav^?3zl_AG~VQZF1)L=h6f&~<*!8-EYtCyyK2d!A|J9^4idS{0I`tMIW>~l?G z%X|ihA%+~TQ4%aF`F%WUMgOLcQucjBy}!Ej{$fPrXt;nHJw9$K@H^D>zwxw;3+Em< zQ{wp?-WBDRdyK*sOg)b0aZJ|Qwr9S2smt>LfU`;w;I*xUd=bUqZ^VgtvtNcvzz!dssk{7Jmn7_th%^TS9-r>Lx)oJ408 z)#&^w1>#wr-WtrB0l^SFEqO#mMPK=hf}wyOt^~-@g{g9N25%^ZLZby?v&I*1J*fy{ z;Ifs4n!|5a0KcYO>^1tTO(412SsXFFy&j%R3+tno=olDYGg&(pePF{}eO>8-r9>vd zG8Hrb=F{6s_8ygVX-_3G2tf8fffwKQsR3eo(*;a7vw<_Hbx-!wouxWN0q%b`o41H| ZShTvbNpFa94IY6XHKogn#qySc{|8+{b3Xt8 literal 0 HcmV?d00001 diff --git a/docs/images/vscode-findent.png b/docs/images/vscode-findent.png new file mode 100644 index 0000000000000000000000000000000000000000..a26de6b40d39e56731c69058271a95d5407e3e3a GIT binary patch literal 43037 zcmb5Vb9^4#`Ue^(jcuEaZ8UCd+qP|^N#itZ!^XCqG`4LuYH+7#pYz*2``r7-P2YSn zeP`CJHA~MI&qON7Ng%-D!h(Q+AV^7yDS?1Mh=72AqQZay-?(8O_(p8s!QDF&=ujjnuW}Vl5BK?=Y`T6tBmNnwI~6OCAN@J#hcYDG~?A$~{tyh8p} z?j~GHF2{(?bA*aED3pl+gfG1}u@FqCLFDw-#*P*>oKG{jB7zE?BrCd#O1*1~#0S-| zY;3G3nJ=aaXPXf!Ajk!pDd`QB^{4$+^4=A9mI}B00y~9=ex6EJx8|dN!@j?aS(wc} zJet@rn3O@EiG1Sgnv^~+y}6>3#UebM=ZtTzNgzFwS6H)>S`YjUS4a1CJ5C-6YZmFP z`RI;Gb%9wLu^`-}#lFK6{1QJg(CVt9)s5o3MHHL2>3NW|Paoi@!MGJV9f) z$1;B$nnX1Z8GU)g0d;C+<5lY5gnQ&NzYiPrP8)a!n`_twCPED6lkko!01+&Z5k&JD zLo+$FDm6-7I;13so(HYj)`v&Cuf95eWo3B>5VkYT%pc~vuo$3IZYgxhCh{v&$w=_TU?0A~vIV?nf-vjCT?9AZL~IKr zf&numhV2XP4}gP^Tt}_K-wpanOoSd}Yk)-!p7I3>A0oV4aSBW>sCJXI3AUx1!GY*D znB)>aCdl0YKZqD#Ebvl(z;+%vH3q6M3pLg<42DR*0*(sg zoUot>)tA~S({Io%a0o(VQ`U!QF+syswB_KLUCxG3VP}i3)6=1V(WCg{l<{zd@+LN(X5L(+Z`0DOHU9#-T!W3{^_> z6YM8S><8r^E_Lk71OyRr;?6%tr>v*6r%Vrn56x~pZxL=mywG1TM7u4F>6z`YIVcg6 zqcr1&2R|8DF%L3hF*P!Yrnzg-r-rfjw-|s|UoEno(w<_T>e-+*5Ud0f^u=vCa3N$- zOn_sB?QGUKJT~z+i8iq|>8&E4gXe@S^sel@T)p!^@dNLG(2p04z33P0k4O6iGXTLU zf*mNKAw^AkN>ztai53R4BW9XU^CKAhgDhDkRVpf8Bvu4cguNtr66kPBT>v?G1zAc` zT*CWAC`qDWS`#>y=q$<9#Kt6~gq30UVS8%ysCWIDNkYTz&Q<=q|Gn!TVmQt3jbn-RNf|8AcAy`d}SGx7%FE$BtL}x_*iGA)^XRm`c z^#!GSwSzLOZ=59?N^gb23zsvJ3yYOM@~;%oDlGGwg`AuB1;*hr80%E(SL>U!Ahjgw z&nO>Xg(!#bZ}JgwEPtK#PUM>^8UpUTshbx7y;@d6cR#Y74q6P(0NBpjK=#1JN7;`?A34(N(%>^oGiyFN%i_rrr74cJjisimX0EXfX0VRU zjNfOtYj!Vy|7Ee|OS1XrH7GAc5PK-{H4z11;c4>^m0OkONdQ4gTiPl1LCDB^e zTFq))%gdJCSg+i+R$)ea?&ClOFzetM7yBVe5Ps zS{Gksoy~A>kZ+3OE8_bOnkKzd@vPa)*0A>QHnlfb_P%aoovH8N4{dY_&UJSCvvtuJ zs0w)#Q!;TmcpDIDhmV^sR7(Ww1gSx1BT+(2Kz)W3M68BM45=FrKY$+JV15(+=J<`e zjsiZUy4Nj)AD$CIAM^DF>@?^Sat|&?Z1KacxQn_*VQ?XaSuZuYq0kulzAM6HhCL8x^UsB*{C;Y_KYmLbw)q- z`ZJ|%@n?h=LHBc#OI7$SLSgB%^$8luLsMN{hoitb1RuA~>*X7n>HiGrX{4=%_ zm9ki}juTtRT*Wpis8QOGYeGzW)GY%oQ!FoLdZ&>JMzfyTIwZatJ%a$B)+#ny6Lz32(pJb{k9PHxBR zXM_g4D9*Mu?AB@qc`AF|^-WID4YpmnU771&9L@Hn&zLV2mn)Uyh?(~`uUcJnO-dHp z8cGkIaPFfi7pEO`FLp-OBlDG{2l>7$RV!jEcJ}wnepMRHTwgsL2A>JWd5?JE+&b3k zO&0c02a`tD`qpaJUW!PHD!gOvY*ucXWfk1YR=>8Dh_o6x_y1~dYj6M6cF(SMtb(cL z_oVmml3f~5x^Ip2C)Zm{aId1wz+{I`kF;lbCP z1033#x)>6B*xJ}R^LX%+{_6@J;Q05~jHJZ>y2QnrpH$8C5pC|uW@LyGG{9Pq86F1YJb^dYckD|Yy zfk)oS5~$AbcP9!k^D+LVJI#>qLe4&sDoYE*W zBO^0CooYLQPQ5aV+nHkfGW)aF&*O#WTH~v2wQDb2HjC*7TW_D;bSFG3+x{rmP&h1< z^o=$+PtD~{LC`}D_IilU$4>vZCDA{+B@hDIIak0}NmR_=rBtAB_Vs&YxRP60l6aoI$*vN>8uj%0U7!?oi z>ecgRKaM^}Q3gT;Xu7FS4eweu}^SGm<~t-|{udmPLe6>O@+e^1)5qR7V+ZDtr0{rDXZhwD$=bNCG z79LPgMl41>hx>Da5)s2qaac_H@`8fkprPU1P7rd~7TQX)(Ny1C3w2{-G>e9X@4*8x zjw8u~Cc8sFns}TFM{CXXdczQcvf0bJulKCQHq0h-{9c|^75Q|t@6UKMxSh@Bv<2MH zW1>f4=ALtNmA_7OwzRa!=L&QmwV-1M}YBhJ^nyz_ky@3+_X2TPqM3_7(o z?MA%>(r=f`^>he$9CowchEwQ1vzU!VY*G5qsy%BfE7yw0YE@NR9Q-_4V4BJ*GL3xs zYV|9DN&)M7ak28=2UCo601&R{%)78}tMG_I_k|5Nqc>~^QR?2o9o9{I_BwjsY4 zsI6%7dK)XNFnk}Y`Emvp^$IPh#Ndm?*B5VcPTW5ij%Bn^&=2g@u+N{>tBurPd}9bs zbXr_AWoxx+&GzanYx@Xzc-#UK*{#(C1vkvbwa{sdNUkYxh?ACT_R^S*&w-YR$Ku9i zO&5&{#m3-;3x#tg6&Dxpji?3$Zu~%Ta&#j^%yu}MhP0rH;k`d!BOoNan-om3Uu#L^ z_eLZl${k55GrCQuioa^G%~XJeRvAfUz%xXrRcZ42nc?WEpN;I^?6_kUi#v}@rKP2n zz(1v{S~ia?r(7Hp9{A|ARBP^kL%G;TPGlq;PslG;{PiFii!ld|Q-1@?dZ9AJ*2rkO zP|BIUGGUv$hvX$II9NX(k5k&O^Yt}~T0)CkL{#+G{YAQ(*Qj3-$h(C9eEMXFnQ?-_ z!jUel=SDCKe6&~GgoTCI*K?E@_`Pn0Z6F*m;18L}=tRRN1&3t<5x3Gg?e(xl>bj_P zny9zAl~9$0hp@$Lm^wbyfr<|#P+WGpU*v>-s6L*n$a_yLh)>{cu*Z)J+^XsuQ9CMB zRG+J8VF%B5-BzoKEXYL+2LIRRrYh4>N~r;%b(gbcQEhF!b`eLK`CHXTc$}c%;17s} zpQej$Q)8l{l8S9;)_BdH>Mdswr&UBn(K0Ug$MF;*fBg92&rfH}T#vr6@OLo_xEf4HrjY(i$R?l1?Qe=?Pq#-K-xQVmwwW*-7AkEWFl`O}xm7~5 zN!Zv~{T?nsd7S$qgki?(ZI+5{{Z^kCvlgKVZmS)HCHFe-s3JW;d=yVH3eSIP*fppfB zP1F{MR*}%CkC_cZ+C##&Fil(5l&~$WjK2HNGalNrVR4&oUFRU7T z%K2i$Z?C`J20*08DL$=M8`I4<8eq4WjY~Hp*@5;d<3CX7EgN!kX`pNc-u8S`KbOUW zK>qYi{d>o4pqDUZ&RPV@dnRP>bS_7mg-QYv-o%j7qZxA$c*g)%!tJM@Wn0bn;dOV z=0A>S)c4`D?&`O=IPQq|BV#tiPr|`dRBwPJ0rS*qx^M|-w!w~&cFjI|d+ddR3;c%` zmm^F}%>AQBbg7cnf!LGf#tSb0*QCS4H1+R#hJ&m+{RD;=?6(jtW$KLm4WQfa4K9Z= zRQ(?=zt0cgb34JH-4QE-m~V-2p0Yp}=ywu&-xCH7D0qz`dl*sXp$>$?9c1%+up8nS(>zELUJ{7m`ZOh2LQl+etc=K2~7Uo3sNyF%hLI zlnT@C9rz4bk*p_0&j1!SE)++fY>{*d$plKBaE;B`V<+v$Jc z)J=61NreG}(zHV~D1Q!)k43LiE7bB?T!<@ihBXL&-%=~Lq3wsmNE$!`0!vJ%i*61k zw}Tt?^1qPBZU*PBUv-<1dxj1H@QG+*Tcg$tQb1n`r;sPH)_9P^r%74HGfTd6Wc3$d=N zV<|1Oj*!j!5|UkW1B^vckOmVt4F#>lTOwm_UxZ-zw{McRXR=9x2!G>4;=o*aVqu)* zPn8B-c=*q6u9Q+Vq>m7gkkSpS3e!y2GJ->4UfpI>r76ac%~q7omvt5lk`+1XvIlVGnB%*JtNzw65o zMkjNE%6lp;F0RS3-(+$Fa4rl8 z5s`yLaBN~=07AlS(4|n$BwVa<^7e9{LX+G8a~cwAc&0>6i_h=Xrc}?&{9~xQ(#yyc z&SvXffpm%$O#%@xhNvH7@Hj2cS3hWorr7EG(Q;kN{>>gb-vNwgV^_HF%ua~GfRSqz zoI`oN!*}CH!Pjau@Fb0spqD|Vy>+HgS^Ap6o|N8jc|vX{TwZzVIiH;Y*Ifg;Jp$f4 z;EA9))+y0(alr~CQKA7<-(WQ-ULv_YOsD?dP@nxlNH~T1O8sg(HEk@60Rok=zwA#G zCYS+YIu=j)d@#${U@c=oFxuu>Tdgm$n&XO7wNGf5_A=M(%zH&kSgjc}9cI7i^()h* z16{@A?qosP0`LU68R^v&AK`ZeLofa%ZbrqkLNUd)>~uGcE4RtyEnlHQn*! zG*048vpsd(*-y9g)v!iSBi42RD@3+RN*{Ep488q{fC^ba*~!QXR4S9^itNEWmJr?i zdexQ%VZhyd1~}Y3;;lr2U=z{WmX%&9m2V+fN2-+czm*rdmje(HAa-GItIe!Ae2V4C z-P=Sc2TP6ilVj=1NqQLke{PdXi6Ex3v^^%O{)`Ue^0(bNHAQFD;cdrs$Y^|odF;XXfOx}A0VK*@x{`suAy=F0ZjV- zJ(=A`$4@w(KFU99+=gMo?PUae=MxN~7xJ{AUqnwIWf(g?SEj!08+^c7x@r370#l(7 z!bvXW(!}|@?%xQpE1s$=d&G~=xZ%%P3mhkuLZIs4%>Zku3qijV z(d+&^o9_*J$%9$)WZsQJCUw9hNBujP()>v08wWO@huF_!_Bed*-Sdv;JsJPi+0|ya ztE4_)EBIP2mrD8vsR6kCLny!uty%%H>yaLott)f-gZ%OKbZK&W8rWLa0>OV3ju9Ce zOzODbn`)@Ux+54Vx@PnItfDkLo_$ASQRaML7Z~^*5q~khhTCbkORr0+#AKcC9*AXj zOEt_i6SpM)s4g7>^%L_H(-hLjjJm~Yrryqt@Z(sifm@|grJTcJD)J-0pD7!@KO7zhfQ-BbLPRBzp>Ur8 zp7}c-?h28qR_b7oGVndG0hs!|4p*by8m3K^cDvVj=Ub(T{f0R0hu}W~761-5-H8(x zQQrXWiid4Nr&Rdu@LRpBZW|rAB5tCKYj&2Pf1YX?pIW6(hM<3UwJ{Yb5#xNwaP&R3h;0o(>4#pjDoUZ6puiLrPK6X~on zdfNMAE!&~o01}P35n?2{Mnk{lCK5pD9v-d=BGS8NdU|Sr)6(}g+Px3f+j$e;_CHqD-eA+u z4_1Opo-bDaygfo=Dpe`b$`k1asuGeWdE6aFv$vPWE|sXaV$TuuZ?H%dIn(L%t9RTf zM%Dsq`E^UfK}`)4W`(ls$$xTWP*Vg3*_U^jlw^&v9Sqi zAQWh0bUI&ag)8uIEMqm7>*>NYA$=RqOaOE!Sl%mEH)Avf|6LyennroJYqn-_aj{g@+F%6p{oMBr zNiLsS8;8r2!$a(`pFAE4)$M6q#d6u9bMzTq=z2DlsvEuOa#*=i(;QrY`2EVC-M!o;9I|S;e!^1<-@K;9KFY;hu zU^X_VK0ZE|l&P;T;k#q$z1?~3O7`+Oe1^8VaEzAS_za?=#*XYXrtTN(^Z6f6P{?#R zY_-Cb)>?kjDty^ot}ojj>9F~cpVD|gQ&n{-92~Zj!U8b*z97t^;^eeGKk%Q&bAz!u zZ61{}pU)SgD$FM<6PP2$G_+EMHirfeoY`n1F{WexvE(GsBy|S*@*jZ>-oS9INCu0T zM9jXA*5CXf4^Wl}1y*s=6%`eo_s0SPWwuK%b?S!B`r$65Q%c1?_-ZuR0NYMwev-#% z6zO)GVQ-7gk`r-~a)S-`E-_cF&tnp=yIuEh#$daAYS@c@W@OKdh1IWTlCP*aliM0d zFkM*2WO8>93(Lp1TK!JAOszt@v7x`lkN))?ENsZiR`0J&&c<|hYrT{C@$Hc-vA-e7 zZ)kAYimbrO!t#{UVXzbv7boZ7;Lw%=PjHNmgTrjUZlm)-4AQ>(bbU?ONv^H@8}iJ+ zmqZm&QZ23J+jhqbPc00Kpv0P{y!@RfOYz>FpK{k&4>ec zQNF}T5i)xHNr8Vi-U;jzbLTTk75JaP3^*Pp15f~;-Yw;S-{@fvg4)>ck<8$qs(6xw z5G%=j7(!;77ly;$2t{)+fCBbL<|cFaLuIa?Lu{a-C5(-eBhdyacN12BE8ff;6LgIA z-uHKDY1p2Kw*TlV!OVY4+rTK))LPSEz2o=3tF5bxitupX?CL0VU}k3@&Ag|ZOZ=o1 z`A}!S@neWu-sSeqb@WF8bZ<`&Dh;V_seY&8%|1h`t8;>r#Xr_`;Rmn`V1EbLTZPp^ zp5g55YzCWUwecXPBRe2yPcfC|2yzb&4w?g^4UGkx`GgLjrYb2UeE5eM;713R0q7j* z0=`LBxx~f^OJ9UVr3QeVX=JUgu5KVU)51Fkxw*bd3jg2 zM>{milznv7yKBg9lR3V0s-;2Vq9P*dk?Nnx`{REm{`v(23wA3%T3$;nAmp&ZFiBINfHwdnf_e~+O_@j2z_BCtN;R#+ud|Vvj`@9dYX{Pt5O1CDOnH7?1QWzhB*ib z_{@a-j3SlwL;e;Y>UJ)XES$uq#&pyV;Bx4L2(XQgJ32u@U_gI08TK{+9+9Y#RR2uM zk8g^smx&wK_8rYV_KSwjH(=@I^HM4MKI{O5>^04>)c@MST>PR2Cy@dreTg(tJbJOY6 z?G`^oX$WBpwMY1T3dMcgzLCb>K0P>~i{Z2vaoQiF=_Ef52ncwGHUPs*N(vSh7#KK< zHul<6&J=?c+WXs0K)KMgz}68NG6f8oken~|Q=HALZ171<1xQ2!fHtY=N29w$z~iDs zntVHs0b=zd-;_(#`IXILV`&TherDLRF7(3{&_gf`B=Ue`w~6=b`SAu_y;2J~Sp?8| zo+G6O2jhQiLxa&ANMPG8*VQ+=YqWcXTFB5ml4+S_|GkkCQ(Yq91UG9iXfL}R&tfE| zV$kswCL!ZtUx_kA5TwIl(uc^z6A99*jZH5uYB-H1?$jb)U3jm;PI*Nk}a``O2*?T zPhop(cK)iYBR>tdKVcg|lbsZ#Bu&{)==FEJ6B>c>5gia>UG4BKP^;icqYX>BQo@Un zGl)}*#;j;-&kYL=MZ#sn?}oJq0G6d%`NRF?)&u~+DuJE&?vz_Z1pNwG*5&aacLd-( zD@~3SDXLO!@@6;tu7hy|iL}pzJAkB_Ha6eZ46xJBfRGo*&Os$lTU&0FuPb^lV#&9oBf93@g5u+u{%cK0RkGD zYYUH6#WgjPrTbp=tFU(~D^_)uV23_G$3(VHTjP zMMU1?eoSLJJ73dAw!hv595CmD_aVy?2=CSi&S(4kF*xJ0S(#E${OO4V#SK3@u!VQx ziglf@x8KZt9H0OwZ5c$KaIm;;>zxp^5Ih=9I09Zo=TbWBn)IiKlkI-E2jkl-&+}~- zr^jn{0GbX^`aQJyzu8^yUcLN63X4?&6#BthWo2b|C#Mp%3d&;iZT;ZhaHNSWZb*Sx zJWkP3K!Pn-?8P0O-W^t}$S`<|U#dO8danc6F5tIWSz!X+`?luh7n@Ui0G~Mw4hu5_ zBAKdv2>0JBAwdi*S3Q7yvmy;I%#(}@5OYC$iMPVI;Njsv5-WxwI1>u`)fAhFV|_;H zIRmKN;x$}w+VPyV5d>M3kfqH=M>Bw|fL?KOIlbEKZr5#fi}32hv6CKdg8v}8!B?fX zH<7K~&|qsmo)O*-0kFxt-C?p%BBA+mir^}M$;hQO=%A1jUpAV`@L^)Mq;?=K`|`Rd z_fq{@xL8bxtFV!^4=N=5A)@Fwo7X)!00J6fkI4X7+T4BQNe|hCc@58xaNEKjUIN{p zp_v@J5QbxL>VcREhfW=F19TPh9IO|}oRNDI5Wn|^62YZZk|?4D@M+a6?>4)A$1v(@ zXcZgJJDv8iRRJ@QNYpt3$FswPs=YU#!RF?2yPwtO;LF#~kRLzOse``6$HeqO3Hvkj2xsD}T(*LA{_J-DC`wwWP*4vjKcLApIr_eo zTOg|BsVG9&@%@dWi2ET>V+QIhXLMAKcW!zHic4mNPUfTZ4IK?UW^2vWV?yfc>v!?! zygizL=masURRvdjiGBb8gsosrYHU_R5L&B*g&67GVa0;5(P+3<`wha<^dU!Af>>d4 zzvV#~DJO-Du3&M%&NmE+4Wxk>&f$+5f7cgS#D2ECv?+1eXfJxjTQ?LEyeeTSzWO=; z=&%zz(#V6>4qGPd@|Kxc+-d4dha~2E9h2$8BbYWxUY8w15+cNiei9>aaJ=p<8#A*w zR#I#ra{$hi%RtB;ew73YnIF(0wC+yd^wH{lnt9#yzv;Hx0TwrjK+uV868s+I3ZywhzFu#%k<~09(!$4NK4+}NQXm7-|*=et5 z4u`dPbM$RX6upB3hLM;sH1ab*p~2A5l6@ki`F)=t?5+zVBd^O0R4)*(h(7h4ZD!Ip zKnS5iH_Qa63Af3Rr%XJ|3GE75&X%e|3Zs%=nMV+#*3ESIN+6qkiZWo0`Iw2`YK>0) zB@GT2|GCB69s2nZ5SgKHi)~lbhE`kenN&VzRl_M314_VD`k_#XlIf*!-}9q0U~{as zdD0D$FFGVs)z`CiyM8RXUC@H>}^ zP6LZ7uCg>fs3Yp7B#=^Uval%K)9J3kkeQrh;V-7;zMj5E{XP z$_TLPfnbst)I+0+Q*Fs8M=YQ>^18+a0|!s&%aS^JKF{t^i(UZ-%Ye0lCKaY7{i#3l zSe)nO{-6qS*vE;(YXwsB4MIjg1SY0&A{hE!IB+K^0`grR^?ZeJdw7UJV~mdHHFk6j zOza3}5(t zv>ua3w@1nR{JE8YapcGDi03V1K-GSE>0WD2x6LO#=jXWPBTY`zS!fa-9&X5jT^uNEGh1?FFEaH>xP~xjn_e_jupKd}Q=9BSm;2UT+w;aBsPOCoXT^%8I+)bYXfMeO;6lYBES-OK$|uec0KgO#0wPT?sX(& zLTSX~D#3Z5WWUkU_z%X}R!PLU0JINn-cjl?ZKVOo9-#k`=!D7)MA7gv zjmqGk45OdFi=)Fu8w&VFeJqsh`Ha4e*7&YD!WNvIlaWy#z*P$;i`8)Oo~Rj^iYzvS z5lo2NHr{vmd@hHDDRcTtnt$Y(T)qHgxg*!mt3)_slYEVdqqfES9?|dgyM8ALCV?Sy zq{oRxR*;bm!AxpZ8y*q1!vl*p?92dR9_moqe8pLf`DB=;Rem0$`3KW{NuByP zLBmRwc*1O6SF6ucvi*hb8ta(2$iBU7WpA9RTW<|bEv_fxpF~{1WY&M6mCP1@#A70Z z>w&u15G&@R2?@!_$fxy;zHaSxDhF&#Lrzu*c|c~}O1hk#8HJrA&t0WBSvgoP%mTP- zxo#`0l*{DoEPh~yfNx8`?u-A7WYlZKQ&CM%0?WZfcBByO9emde3a?v)3?OuOhe3NB zy1AVxiqR}pXj4(+$fAb~b+4o%k9FHw>VGSi{Yc}QAoU-XA9yPV@;&eQc_8IhF6cg2 z2@G3rr=DcG(j`(QxC$if;flwgxvjFY^7cB}!&ixp^@u>O?Za$AOG+qp5IZXjn$(jR zO}b?LqWAdpwAIZ%0$^j?tSvW~j&f*(u{nG(;=$zb@11QG8!6QrNv1;T5mpE*{hX8% zd=Q-tqH+QXim%k6glhd#O%UYMpk0Go^heGGxkvyDB??!Y7?@xt$oe6RK^O8N=ntmU zU-H>JTl?cDf~`b0@qa6Be)hi=l=~aQi)kXzQveY&X=raB9eG}DH}8rYOcOD!Gyg~I z5%MAjL>0nZo{K+ST_B^74fOq${7ig&_MZfkIPg{yXbHc7>-rz917wUsOQ1%}r>p9l zzX8^7ABONF4_kv0SZUUw$C${*Xbl21xk1nh+!Wuj_@tjuHaQV9!0z zS3^BoiS(kr78k2kXd$#=+3yZ@8yXtYe4~Z@08GF{25q+??6%Kjko}q=e?R!|7*1S) zCh5jzHk6P!#q>KTW~Ct|TXz(gT7aVf2=n|E!3J;tP^hM115G510XX6S2!H@>iRR^V z-1fNIrnoGIOFaEi;GRM|cU5x-Kp#MJKktt|0P-LS3Cn;iA*Etj%@Bng0bf4T5r`{V zc+~?Q*H>4E!zVzvmKj9_2tJTgayOMHXFBp}W_H%&?e(`q^IfMoOKqqo_aDzL7$J0> z&pa?NfQx$!Oy;C}v+khgoq<@9xY$@-AhibIWjy8+@E<>pOC=YRp}iuL04}|oyMC4P z!5xrq!e+b7LUJ&c&T2lEhQj!&U1PF!ccy(jTcX|J6AI+bOk}V#(9+iUzmZ(KS^h(F zE0hNtjvfG<0ra#SK2K5uz&V5u#9Aa05CdpDMkyIFvBAZv;JeWSCdJd0^O|3$!m|Df(l7M%(B|uC;^dF~jGZP|- z$~cGrMkE$+tBe}3V}SGnD{Je|^qREpcB14Y91egj!91}|tx=Vb!0hJ-%N)G(mm$y- zvA{h6DFBNQ42}>>cxGjga0d8ti*iCH*UvIAY!*`*+PulLE*2I;fZbKNJIQ%D2c*a< z%$IAnx?g}{yxj066l?dn`M*3N^vNUnuM6O4;jkCS+hmbtPM}>7XOC$;-k4&+7RD4w zrCdXDTy$3Ol*&CTHrQ%CtzvxtG@NGF;Gf%^(Nhz7JJQ{a0*4MH^^_gYG%BainvV15 zLJ#^qnP|>ZW0=ZTp0?QHrfRj{EU#2adbSot<9((#Yjavr^`x{(UVTa#$=L9|J|0?< zxR!axPuz_3A5~KlHgI|h8bABsXCbzMe$$XPLwL45 zso}VVW~t=;B=8u$_9r9D*xH*afK@bD{8*l-%zmal%a!_KJUF3{Bo)w(rnp7 zAlHH={NLLKDpdj>4jLXFfYQ$?KW4;YZ`HV+NrxEO*sg53caLXsen~%B_-?q4RX7B! zeC>LxVD%Ar+*w{e9Z&JVLxr{pXgmtJ5Qv1UfbyP%&Xz$H z9~mdNkB%-|C^=vLq+Y4BTxFa)i7S+g_H%XK-E9dO+)!~oy^Ie( z`qwr*d)8vmrO{E|CHtkyKD5O@AS0v4NvY}D(tSDox(L6P-6);nVypavDSSN#?Veyo zMeKI}$-jd&H49x`alS$7=$hi%%F@!x{P~TpwDi-c{mka~Rqon0zZ<{OU)5NzfR|{J zu{CQkan0&lhEAi;qA#{Ph$ACs2w|V5j8skRS`QCnL`)iDB`QL;-WHpnCGScmUrFB& zN0+~?NRT-d={@w-_6bn&_MaLk1J` zEGN@Y3=vl!Kk3E_l?G?+9sTElD#tMmuj54XFIA3l_n_m1bGM22Wgn~=VH)XMv}(oK zHCwK(_q3zZ1d;w7)g^&F)db#37y>F<_4TDu7)X{)=yUl_CV^hLS+xp9=d;*Y& z3)+3DU~&Kw|M2)|I-K;OX$#-|ONf!3SKGw)wD}-BPAY?Tl$0spRf%*oHk!XaLl()f z`9Xte;IP}RiUA4P$H!LR_1Z<+_U6h!Vy>$>*VbAaE6QJC-@QXb@;5g#3tP8atRg^+ z#bxi-=?18})9w(n=d}lb-}sEE4P!#|IuUVM2j2aJ$J_tJX)mz5d4f(z7&cCLcfQ8Z zxq*P!V2Bh6*kLN=4@hn=;-PYK1H()KMGn(0n)%lUaClt6o#9f z%`q7=!po%3^g1i~mY@Wbgv)0e$r(B4mgTXoWmpw~}q+Qa1PQK#mJCZJ6bJb zcf%X}?NTnh{ShNYVoo!?$4)QrlMX>KI7;E{&iz=%+LJD?DOxHXr)AbN?(g{UmcG zpX*vA^3c`fa?@XK`c+JI+s0Hi-~TNS3hD{QX?tErSNF2r)m=X>vgsjndT#C=j7Ma} z*~NN0xWCvmav~I6U-gc!)WYGbYwZc0AN`@RK8|@gNX<#38kMrR%VddrMY&hHouG&2 zz_f=)JZ>BrhSqy^xpp5C`@5r?WzTiHScRCe8V*=RWc6ZqL`MY{4 zo_4Ash5!_h-5p3u^fp*uZAr^*U_!Q3IsuGupM+D_#3&$+d}#o*5oRUy$3;k;*RzB}*a_Q;vXtq#q5MpH}6FfDp1;1XY8 zmD^bS44CPgD`1+@%vWbCjq?@SkC$7)9lp>;h8S+u!Ce8B*h~fy$umq3KlZnTf(?vOZ`^{(Yo&Cjkt zQBFIZaH8hC^AN%P(a3rO>H4krySF;JRGFDr8ucUKxCP2ogFrHi5mfQwIg*t*ux#ea zw1L+V2>g{7$)~!AdEFL3c<5Dvd(aU;hXmhL8fs_*t6A?z98x9 zN{C(q830Hkh^;VYBcE^-X|}+(0vVxfe!LH%Ffjxq^_4nHxWMCW7M468K1~SwE3%=p z70#^~iFod^v~n24cfOvu>{ePpZgtFQUj5TO(Q4zx7f^67Dc#t}$JueqGToi&IawY2ljCUaD^yGII zlL1Fnx9Y$Bx^8^GiH1_d_X`CVN|_Wu(MnYYhI~t@47Lq6ONC`+(P#Tty$Ti<7U779 z9_6B8w{(j6l2e{9kUA3J z7Ec}$L_i`OsexM|7?SptI7o@=B9vK(kMk+qlKW2(gkMCx^C&Z0oG-Hi z{kVNtH&>HDGQ0fXDdDRhmVdh9o@kL5e$y}?E2B!6OZ1Zr4bF*_6k`mOPaTne2zzll zaSB|k^8l*2Y>9)m-lO*e*FuRB_ROUi|KCEu7inS&7N~lmd_Fk?PmuS9d|#K9+PI}0 z!$_kV=~?|*0s#|aiww74+joC5*Vru8A4r;8M8QjcNL*aI63p}=lNk^+a*lLhBlwfAz)8S+eH%q@;X?}WaH?55za+9HZ+B>4y@)1 z^yiac1FxnCDOmJHbQ`U_g8^@Amh>3G6N!WA=?Vac3c}v&74W>~0uy7ZqRKgL@R-c; z9OXq)g_4(_q_QZJO?NuHtFuhLOy=Iz42AVy_-2TJ0}fr}mPjV}JG*%)EuzlD)033w z3PK8XXpLOEgu}B&A+KjJo~YgJBg$oURaLo))D>$R*FdauH_^o2XhP7+@mv{FUWDIv z(k*((3Xq4TU|1kNE`-XPCm|t`%j2q~gKAEV`OE~oE)(Z`AeYO1Ge^;!X#!-ay;CKz zG)lV9^%r<^iZ8ShxJ_wn`#Lk*yu>7w==X`z!hkIGHY0Mc9yY6W<#iZq!>N!JjbS_F!5BouNaS#5iNBn_Qb7dQN zUktxUM`s|?OX1yZKvl{zM*6g-i-rZZiC()GjyWr<^RV!+Lg`0oqd0s%=3A^~rPWaE zLo)pc{}?Y6wqSI{Qstb!@>=N>bT9D#hqbqis&eh#cq!@bl#uT34ke`(L^?#IySoJm zX_4-bP!MTp1OZVI5NV|wl@iY6-Fv&^{6CxzXN-63ca1&Ru-1B>=f3B>=5_t5xIXymB&*0_W%O%hjg}QWVe4k`h;MQVtqVyADw|BF zAR5N6$HxULkKF5pbjLP)m284TeBqK}425ZAg?%}kgee3t{MwRA5l(V=G|pNO6X!?yT_SK;7ED}Cx5KAN{O+KzG3VRdVtweJbr>( zUB`=W??p>sO5z?zy9}P|ta$e69hj&1Xe}gX8aW#iGdp!-%D;lDB!Xv zIQ&4>*Ki?5%#3{9+$Jj;F)J&}k~N0U#dSmFq|w{LYK??UO->yG_{kqhihqxZcQnxB87;%As$7uv=5joX$5+VavWgLC!P$l<2HPT~&_ z>pO3;hu(xb8pjSaa^4oF)v+WPkjb}9)d$RS$r9cypzCtcTuS?Cra^EuoN-IGXV;Wy<+!-jeT?mBX?z271(qc`GRU-JbiQ@p=Pq{lgHaEjlJd=b;a@J zAj*ty>CtWs>6{PABU=M_i0`yIzPx%QQqS$Vku&!+>f%C;EN5YdBtOUgL_DL2h3Axe z5gA|Zi~li(d>~)>56hjr^bm6cm++&}h4+J}B8=q@V}D42^9k2>k1xi8W&-vi14R+B z-|;qsuR#BJpQKjQ3X-fx3#RHVI(AgZzrapsW|0vYX~F*JtTU0=(wCZ?35KbPfow59 zz~)m}XjzMW=~D&W`g!BCYqO3iJ&VatR*hb~Y4qM7K||vRWUev#Y063bnvx3pJ&Ss0 zSERf_bFlu7WuJPY9T94Cc!P*4a=`GCd=$a)>tDAj^scm^Pfj&N-RWF?1tG%32ncSz zZb`*|s#BrCM$s?R+1H2rejPtkPHHtQIYE+woE%}qV3kK+f1C+jSy2WWoA77&n2OCP z$PdrI%#fNdzHfMtPS7jAin&@f0 zFYUDIy`tV^tTBG{pZ}n+i8@iIBo@wD>vsEML?0_7u;E_tG8={5>mBx#H|bmtY$_S9 zvGSt4GtG) zN`*a*jq2t03Kiu0+ivjiVL6(8vfJ%Ee)%p;Jh`=D~H;cv`Nz;$B^%ue>4>9CkY)q~M=TzXi{W;x~y(z1klc#|+ z$S}Vw=sx{o3Z^B6#GZ^qHP~Iw)G98d4O^3S#ojI)ar+=RMfo2yRfTp=c#?BiS|#iW zdfp?nX3FJJ_&6#Mq!{5!i(Lgj^pK{FSu^L6&iQ%Z(QA`!x>(jbzxLhs(#1(`?+(2f z(6lv@^jWFJi(tQ zyhUV=l(GBTFfjU5%5zisiSSmf65{gvrxLlJ*f3r~!*6lrc@O?pm|g zI*fHy{;!clv*rOF@dpb)gd8+uYH9xzur|BnAvWKAgk}Ta@6Q}`J5bUd4V!p2YxckC+L$j#v*|-Mcs-X_a)liO9rI!IQE-js zU5(iBim3jQp=*AIEt>W*YIst}bu*^>AEE}F*n)Y&Q2I5Ww*~Dx*@78Mz;8_HI>Y=|_r2OVZ z)3NKLD{)qAFXoJ9kfx!p*qJB(Y(_hr$Vq0m{|)KsH|t%*w5Xh#<a!aWJne8_&H z8u;kfvS?&QX5RUA@?Gx@nF=xR6$tlmlENa#5cwpyXBqZvkT{VzU%!66XQKZmoQ2tU zFalhKeGdII#Sa7I@d)0rY>t;49?{9y4k4vAL^JPpv2MO_w0uvjQC42ACQJB+tk`+T zfbp^SO6pNzp#54TYy5b1u_K}Om5bZ?s{CjgW}nR7OQMdR$rEN~G3{V<#pBCNddqGi z(siIv1xZZKBOb7)?k{Qd1xUHdZ}s~L&8jQP=gstuNQGvaS==&cb*#wr{(_^IJ^?Zr|9BFy z`HyY3NDL{iujti{AD=zQkzI}rBxldfXQ~9z(`KA82r$?(Es$mImo`=D@y>qVPe+xV-@5t+mY*`8-^;FxG^-Y>l!pUvrR0UC0&=NL~Sr968k7l zv|eFHRAAqF-1N0a2>T8DUP2|y)Pr2T(_HUIrok42E$bm%h^_w8H5s?tDzcCp9!JZZ zJBNmm92_RQ_5?^J=bIOaU%Mv5sMeilW>#xam$r_W8tTDWajYez+I9US%Ph4zBZuKI zxtgQ+3)Y8axI*f!DH$sNb3)_ufKAxDj`uN&P6$Hd+csaJx?=S5u|BWcE(=|+pq&V~ zXvyF<7EefDDDz~=_t)3_RwRySUqwxQBF(UV(C%Mua`E$aG>H(h_-!mdvY6Cg8(wo~ z=a`0n7@K8J=sQ)c*H#P18W4^!n;_eQzBxoAu@bI{)dd7-Z#*cD*kpKo-|r)pG&xo+jBT_&CE^uL`gez3^TaD36-%roNylEk57iIV9S=7&lFR$DlKwsA8`@Nf!Uoev=m+f0} z!-IPesIqJorRKNUoe$h2ef?Ps{6_bNojFWey(6*hK%6VnuYAK9-0p6qUV8TUhs;I2QYB6a;U05)O@f?h^?$0#6f;8>keoID%t&9w9 zt0~fmvjFcvnijz_3_CY!I#lg!Z5QLe7eye?gg?LQ`2?2TLMwIo z`EY)f)e4<<1LQC!!GWC*8Yttuupn!HQU+Qsj$iC(#pwdYT^y$)|z)Glx2H>C-RIAsjjXL z*1?5^1(~wITWWt^fR032OzSv^>Nz5RMdxj><$K2oA$6q|R$*^!}sj%dsyeA{SRR z1eCSvZ4Qw$%rA{-F4{ zxVBcw(QGkDljT-XuKp+Au)9KVRBesze0q9XeW&4UbZJE5KdC=uKE!RQR10^`|J>fY z43*Fg)q1mr?u4x5;#7eu}-v+1d>p|K~O>2qMS)Lx?T`D;j#T`G* z9dY{d(t2oO`Rx-tW02xjLF=!oen7^mRi;LE3h4<*H2z%wI23eY%qA{=GMxEXx0Idu zQH}}euq@zNh@Ei6U6=FRohSrsviZ7kc+llXfOUh0w|%;|bSXGOTUTCQ{&mojnv}HB zygLi@)}|JoAuzJry1-EXrPEw8JA`3^BoV2oJ{z|*R<=h7Lk|L}2w3@*pe|^oa zNZESKrE(G!D9jp^D=RCfVC}rOVh&H{a57V6PR`XgFm;s8%*f1C_zX7MkJHUJ^W`Iw z@Ng_GlD*b+ejXpJe5g9U@X7!eDIV_j_Q75VU%<&-(L!NS%k-_m$NhlWfk>0%KsIPS zva+(u(FMJ*rZGgJVH6P|q057-u(#VXJ}oWnEG^$WjmPw%T2|JXhAM949~r#PT+Lwq zZ=*qdGOM_d5ZOQfbqZ!OgvpKl{KBh&tADe7g4=ol6?L0j^#5~rIAchS54;ZCR4{fkf#>Somle*|v zgrH)a?V;?x-T64g2Qs-UQ&=^BVtCiuL^TmZZjdC(EZv`X*#O2anxq)cbouppm`{C( zIJN{;?&$U8usWZ@=4{)AA~Jl9_>tx1VsXCTDL+&j(W3f0gJFPUWM?)Y?K)&5l-Ji? zRj_$?l{-*!WPSpS;-Eljh|aj#vjHvIdg#{DPS?A-!Xr1e4qNY)KeoKJWZ8Oa^)S@< zJ)*oGc0s}AqrGc7`z%zTWkb-cGZ---(6z;$`xT16zeyhY)d_HVn-jC?=zV}d2K7P~ zgajb)A^pl@JQro03h|7_V`sb8dk>S9!ox#IeF^+Y3R+rbzDu2_fAO^Nl^f&MChG(O z`4eJdNR9$S<6f_S{Pxz!bK@J`9coE$QD*Hp2%4(I1=o%8B+TU^*tE{0SwaS2GD{3x z`*_-i6bo7DJioTKBo@+bWMpJmSkfUI2vJ(be2K0ua`l_tD9Te=MeF|;ktY1I+1 z#(5)#zXbT$+pA|sVw{9IrMsR)kK6XJ{aAcBk8nExz zEn1H=erjqt3VK`6ROZkTspPr z^K7iFijp%8`bsn;phd`Iw5;_RX>uWY`xeV0ryI~1`0TGWcm6Q7z+}n6`ulBV<=sSj zWXYKW=gXfIC*)DT>Y1VojAVe0B!P+3Tbbb%Di*SaxxMxN5t z*&*%a0@*?#>W9&tG+q&r8yAU+956Bv5gDE92&(zRArqTA2ZH$xsj`{34x}@+Z=isR zt*hg^KAdrO>$%MqM1h=-o=hS?+M&#Vt)b70Y03u*1~8=1(-rCwZrtM?l3`u_EW>5_ z5<#@mkv&h3{xRHkbY>P7i(6Y7#D7*@u$n6m-n7o-x9&32^Y7WtC1SbxHn#&fE|p)t zkgaZPXy!hfjKaKgh3CP`7caWhWWIsG%4FE}*5TXn!96I(T)}r^wxof68P>#fvdvgs zO#m@_s?84#v(f(kb8z0kL>^5J|Tu%WN8BR{0gRC&j{tLPj_ z$&4fA;+gul!6^_WBt@OQTTNz{piRu}8?gzp#UJWC~FL4a#y#4?Y;q~q3EeY?w& z_y8Wc#VK3Wa=Y`w477(}{`NiEm0P9o2R#In37PgrKW-P%LB|uJ2iir^y=h!ekdRCm zh_q=g=}a9#wE2YxVlmXme2&>zw^}UbW?>3Vul3x1icmqJ8;lVaQKn51k&(Dm-xzN2hwqR2I7Co`j_L6mI+@y*l%x48(b3tmkE5M24Tw1n&{z5s9{)=AP`t_e zcJu65fJR~(cukW0`+jpya62HY=r-8l?1h7uhY>sHzh$LhNQ$CmiX*uW;z9eJ7q(xw zehG4N`h%2)9x3U2s5Q)>>w1$hMx0`P18!&os5u+U(}QJ!0?bYqkrDc{vW3aIYta|r zvWL*BqHF&nF3|)E0Ys`DRi60c<~vHM__sxQ?koc#quy($YpxX|Q}BLvO3m*4KkI}` zAD=K(?%iJ%9d*^zjEsypI5{~9a-B@%nY@LB()Kxg)>l`}vNG{mq9^HYg$=|dC)l~J zYLyNQL|+ymIxih3(_dYk4T+D>(U;16jE)Gw4o*AyL@oka6R53@zMz}23_=kp39v1% z4f0ckKX0WuO*#_hRF$Wlr?R_A$!r2z3eL`wsRK$_J#mtm$_lfyCe=otFU3S@s4=2{ zXmvA&a^$N401E$ur9AF17#ELlFy?br&maDzk|y(v`QKwir;lD_Bgm{Tp0b{5wiB}d zmBY@iVy@Na8r#r)oi^mE#J?Z5|G5c0FwTzonLT{!g#UAoncfV3AO3&GPQfDS)4KYf zCt`O9YP_@k8=bhntJ6PTFeU(eW8eGTlYjr^`Si>3>}x_W&A<9mL_+1O&?qnO6^Q(+ zf=uk>VUeXc7@|d#fD87||0PO-H*;`F$?5;~0b~_4HF*r5+K%P9xVyW<-DQ<}5|FKy z!a7x;R0$8?#>R%9uk^3Owf8&kMSlF(XUT^00d$z;MV4dx=@(0okb#vj$#p#OUEz(L zI}PjCuV06h7`<9r)$7+ar-y6jP!0;ZV{Nkk`)$jLXX%wZdu9S_J~-zlKfhd?nF{4jGTjx^K#c!%uj8bMZ}rxmrRv8(yq%JKwZErF+S_^b<3}c8;fXH+uR1zv04rf^ z{1ozqAms&z%en~*J3x>&iA}de#3?i>7nmQ2$R{ss-!+3<3y@Q>=T!!E+YpL*B3zyD z@>`YR^XBH808M%n|H~ch{LznLFS^_2D`wdjx74S>sg=je{-?{ur>M8H6G0XA3y}uI z;RC?}0K23D|7@t1C@!ust#qr?eM2OeE#AKS((&VLTgyTMX^Y3k$Cj6t29rh~Nxxo! zE<^|-P=k;>)iJPH8y@$MZh%%SVSq7A(|45G)xjE#-aga6#6uG4+d^HL z-N*H;EJ}PO){S*>v7mGL%3D5FcV7txori++CWSqmfSQ_`kZ`=-dV|lBS@u2<2C}6C zx`u`X@edUTlK!p?EQ|7jhIP%lLU z2nm#H7m}i2d`pHd#(E$)VG$h@lQ6QQBj|2mBvgm(eq`MIF1Wb3Z&Ep4rsxUjJph&} zzGHhkPxy26($0}5BD5okDnbt?Lg}-*;~M@)rV!XH*JbJCN4LE32tt)lo7kMKjN4LH3$1t>RX-3xu@2 z2IKS;6yLzs&FbYq6n=LD6BbR88l8 zm|%-QfU#-n|0gu=0DRTxPp~P7cT#$sY5UUydoYpZGR(VC8*R;zal$?_E5#BEfq6|0 zNf$ zs}Lowbp3jCd|ch03($(1y}UZFTNMy@$(7wueN#y&Jn_QnZAHQn9_i1an!x9IGlq_( zO?j=!xlRI<2M3wYmHx5ITwZ-Ue&(3A*JF@9NcHt?Mt@*-NJ~Q_WfMm?b^hKExmj0H6>vMj|Lz}LwjR#?sqS;*??pH9COYGf z^+EU0;Fo`>(Z4s)#70ncimF$7XaCL||4*{9%8Oe_|4YOB^S+^rzeHMC;>CUWt0(>Q zQ^3!9{eS=2W8@BGh^^q!h{q(fwRO{a`?WIt^XqWeloj|wbmWF0_+X+Q=4QGj>fm4> z%iz1&#J9YY2;9nV)mBy4pcP^h~!09c)v3!Me*nL4!ILi59@B@v26}U35!%ow=jrA(@){>cqS_7zJBO%z~dA#3y zZ?yH`n~+joBw{8lip<(afE7eUMX`L5>CG{GzW#7WHuiy;+~1%6=qUyxtL4~z4UPDB zg)G<<<2zpMh(9#&4O+eFk$6C_Y4SNhm1b}oN{hdw5dkpb)yUJWjwt;wR1JQcv-QtV z=|0QI$k-`Ah)Vl~BViBy(|FPSz(8q*C|vbwKQQsyKp=U4`ev@Q;s5x|67b*!yesel z|NIodh!{*>TJ(+s$(3dKas8S7R6RI2koUfQ6XviMswMvWA?#6`uM8;%28nDiWbCff zgV>W~N+~=%*u%I3S$#nB0vHwoA|@{eaBv4;6q;L7Vgv4=YYYse-0mAQQ+!5^o3zsY z&R)4_B0fwnbdwO$_Koh`SwK4iA27oYi~EKJrZU(mA4xegfTjEv0A2n^yLCn{bHI@_ zRcr3>X4>KNgo(yhWdQ`)Z~B^<&q{g`Z-0K-e_Q`-pvTKowAYwQc=(mAHWoyj0|VR3 z6mzg~aAM-({P((8dQ&S&;d7&%&nzDwJwDvqi;0z282x%2GYNH_7R+Xs)q7a-)hQVpenuVkgD698D1vS-G&{Xa4SuK6!`1n`_2ly30 z3|j`Y)N>mRV57bPuoFO>K#oE_J~BV*iLr#`bL;)R&iRW5FH$pY>mAzCBz$~ie5D?w zUPpD_36s=@x)!60*ocrC83TCY{zGeUg9Myl7sMqY*!Un31e=)X);7s7Fi@xBk@NQS z-viL2jI-HJwUG$m86dY0MyAdc>Cxf$JAc?^`a_v5+e4vvm{_Y12UkCJhN zJWYYdoyhVPUx+ma93oq%O458DZPP7Y=}q5xJ88dE-hLezc<%$nJqPI=T`MhfSZ8}a z0{!Fst@j6P-(qP@nRZd zV=5Z4eIo2|B2)~5ffrVT@!nGKYsjvJ)H$I%NpwHhlhvn`DG47 z^uR;fpMu#R__h}MnmcV;oLU3m0?`5GJ5fCdluup+`tI}S&LPCSS)ncb!7s2POc-V%*#wH{!^{>2L*F0Ss* z%YqwJ1f$Ok8xzOUfoJ3e#aj9DFnxI)@Qyi|w?Q)$hNL}si?NnD) z!HSRb)6&3z{M*+sG`t%e*KRy|jgQ~u^?jX0p<8klBfK9*oB$F^s04ws!(}OJoULT3 zjMU+^?3YzYGbAKg*g}Xqq=cW3uP<$?*6GU$uwm}{{!E*jJ4AC-4MDoH7l!f-Nm{Qm zGqaWcgPEfvt|1bQt(jT0FTNzIfaWO0SiEK~s^X0s?Ax+Uu3yD(+$d$yJj-Y0byh?! zct0jwhQEjzGz378-nU)e+G6&3nJ#C?D-rO%Sv{~_0tUnaPVSA#y6ox8;hu!)&KQoh z0J7r+rg$(tkX1F%sXEcDGR%E60ZSPc76uIE_zPP6;nf5kBFW!1#y|s#^g=u$*{~ds z@kyo1xG*=#Lpd! zeu5kR`t>(2c}_Qxb)D7il=i@75BL1t7Ej~sn;E>6r64qCiM?+zR}iVzqbzdW0{WUj*jv9V`JF` z66iweS%QvxizFFIme(-tg`eJH{qAKW(dzfJ5zau!tIY^faF^@8#%VW@NMMk@^Ytr+ z(!$bnj571*?rRJI0bzKwgn5|rFG6H6E51R~-teG>7(fU>O4rO8Fs6-I?oSr6)kebneeoTwFy(+3)t+oU)LD13Us}?{p4?v;B zE0`P~|2Fgr7%y5Fpa1jlU&1eeBYyL<(Si!EX&7V+~4=I z2>cO(31nvWSTxi(pK6xsd@L-I$Jm|kcFu+7T{B0xh#9#3>8|Z6Rld2|{KC7!>+#dm z_qipSgo?y5s$0S;O3a1b0@HPmPkQE z6Q(IjzsJ^$p>d@FSu;XU(dg9jW$|zv(b^3(dPMgzUe=>cLxjXwWHr+?o(pYbhspe# z_HnpQD!x>#h_>X*-9M2uEFj-wZ5{Fc^UDjMDG12-rEqP;QDbAem@X1ZKYhx9PI1|R zC1GqPLR!{UB&iv>{o0YUv&WZajm43!`=~dviAketDp|3vL|=_{8d~Z_Ph9Cz!kn@9bAGI6-7#8Olvr>imHC(CXW$Dd$_>*|vv$ zmCCzx)M6QD4s-1kHp)whWXfy|gluaG$2!bJhHCR&5px7e6CD?Hw?Fk6>>{9{BO&db zQJDws7AnVB)Qz$)0s?rj#g z78d9#=;-Ld_hbj@!gSH12)90aMaRS#H>&p%UtmdO%e6GYd=77b>nNSKEl14l>RqDP zAI>yZ&K2G&Y&1kf@rf0XWS(hqY11w&x&P+opz1Mkg}#eJ-2PYhl`(+>sy<%N2=pua;K*XpBUP{MP3?Snrq;)|t6o30vkCo6#H9N~sKsF^?qOGo&O|q_ z0-S?l>S23S?A7>rT6MXi{>oUqQxa36I;T1AGiB?{BT5uF1R%0pAWilVIPvRxJe-!w zF@4AIFx8lMU#F4qG*Et9?h86WEHz)}iUlGs|6lWj;kWhRJ!4Lb76%pr$P zpcmO-1(Uko67$$nc}doZMCpL#0eVp%faQe?iR}(6qk61==+4R>O1~i9cv^Hes+KKt zA(574ri3{$p-^Ton@3lO~nINZf?>I|9Rdi2ul~< zC?B$PCK^ifi1c;wa$5r7ug^;gMD`%>000q;yxqZK!w}fOq7*m3rm3iZLhD2HN~} z9HOtuGZ_Q`d;3Ne&5e|-rj#FSHFB=lCAZS|IT#o$j&?&59oBC5q6?H`l&3V~ax^kg z3|ZYLFm~3=~^S+b;TW&(ct>M}jrlo`~P`wIz3U8v8Hi{HOEA9zb_q(@C-A{+Cz zo*+LeVD?sx395h#2{&aKvw#3rxnC@X_LG#t$%7R2@`G{=lo(*nQ*R{Ia%DW$6`MgS z-yF;Tm2WjqwYR$(QBC<{b1K9ssmwH=q+Grlda`S@cBGZTMXGdnYJZ?s9x(kn7~;8S z7C9#5ugUA%YZ5|E?SgLKZ9{*s0;@t#Vp2?wSt);+>E`vz)fqsKOVlNz95ov-O!g232@G=+AY z`!ou30MJxMtWC}~qnK=@vL+a2hlWdi3;I#;qFmlSi}llu9#L3GMs#`T3^hGS8Q8J+ zeh@ZtbQTb=q85ibqbwwU3$Z)mUf_bDudO#Gk4A57DrCS=%8|EF?h%{JOmzflYE$1N zKU6%p?PE8|`u2Bg?kXNKn#3m-Fud78m#EJlDfv7R!IQf0+lX^(w0M35WITV4%7{F# zjoG}V4_Ita)|hc9_@V@CyvO&Fzc>>89>Gk-!)(H{<=WgcnH0XcM;hne!p!syKg~2@fY|o^^E>ahP{{C zB>i8F;pMRIExP|Z!l1WVc_e@JJpU6{K(er6f-y%`(O~oMPxZ%(c0~C1P6(MA|CBZU z|NVI>4~N4w0fe1VTue+=Rn@bV+zv2wFmUeqws%E5q@{0BIK77&GsG_bu{_fr7=^unZtvmaETZUZ3VY&(y z_kkpXRzI?8R!g(_&AYSj-eI8n`uYwIUV}p@{LjyJk^^jr2KTQ$kFeGJ&p-&OsZ>7x z%*_wwkD;XTRQ%H`50)NI250#z=WUKlj&1y0TC4soci2-r#)IYv1T(n|h(@ zAt@IcpNFZj$Cb?A*E7)p!~afS-Ucv3#t5P7T#F*0p`pRw?U`sSb03_Ukv{`Blu9N$ z5tOe33DMD=FR;HG85*7*Rl&?`ZaC8oCStuP8xvRNCqh7Uyv42t67(H|nPlsBCZuI*R9UTEDveMyb({CF4OT9 zi1@Vynol*-mJ_JOaM|xv*g-3@y-ic3%lvzxsZR`^&f}+{xs(R3y}%}V3I$ccAbhTJ zd-5S0)im{|Bx~#I_LH?r8Riz#b(TiO47{r!D{0wzZjXST)&eQR?$K-Zl2R=4m2~mb zXJ;dTQX{#4qu&*@ghbJR6KGeY=*j>kuT^ER*Bx~sq}j!Z|F+tojyNq^(CC#bO|}5! zgLkH$d&N^W>@V|$524?Hvs@g%G{;Ei2^;JW5F?h!xfD_f!JK_8L_L+H&uKOsn|ks_ z5v1tN9CO&c15e-L$>eG;1eHWH#B1VW`q|I(Si|W%xi8e6%&e>!9v!9&jt*Lu-81H` zsZO10X~Of2;L_sdWZ+&m_W$Xb`ar+2d+qVcf{f#lafS29^%v^z-#zfo z{7;Wwoi5rvt?12~;4uEsM;(-!+!oTly_>`RRn?Gw<)s>;5w3|sflYCN)aTpZ&-Ol) z&3bG-T*kt9nAyJUZa))c5y53&J#4Pk(}xsF5%Vekoy%T~vT{^r<}vi^aQ(Ty`WJ`C z$Hyln)#>>_;uMQGF(DM~uT4TWjR>mCvE=gmCW@!F_Xkbd{p;?Hj(`iM!v5-`M}Rhm z`$P&tA4%ivTe|BXViOWhw_dsdq9)NkJd#aEaeLCm?ZM{yG&;s6cd(|nF^m!+K=BjY zV!eHR3;R6&|85tuPd_#RD%C7aBKj(r{*R?b8=wG-jHNp{f z@;$WgN z{h z4BVPWc)>CSK$JZ?eo7(~JsNvcxZAfW`ml;`A7SKukmSsd_wg;~^eQTY9+gv{?|jvN z@sizax+;)Om#DjA=ZX>8z~@&Uy>3BLkx1q1_7Y`A)wk*2^`C9u<~Evax2>ppDmeM^ z^~nA(Z9)}hmhdy9@e7~Th{{pU;kf-QN_m2{b=!+Twmfr(s9703qlT@~sik%z2b`@O zN{f}}8{@RMb5v<2>#aqWHNZy(MCFJb^6T&os)H)liDfM1waq#6z{PYoz|GaQ-FxpR z8s61;VKCpr@nNd`hU1{u>^h;C+}&fkbV#vlUc}3za9({oPw0qKp`^tzU46So4rIfV z!#(BupRl&A$x%>H0Lw?BX_Yc<+;*~bp-_II{<};nW6ZnNXSU6nc2vp9Y(4#1qEp26 zr{j9p-A$^&F zvk>XE*|x_P%;PT|e{F5vy*hdWhCRe2Bx1gYD8p=Unp3G&pRNYFpyL@x-8Ffnyc-Um zwxc{YmNy>dnO9X~DaiEn_j~Tls#V-DZh!WSTdyD3#`uA^8tmdP9Ya{U!2D7_(jwJu zGkpHdlFD(_2t@)8L!+RFquYiDo_zW+JuUt<tm8f?ZCw9A9}$3tsc(C zsl8#E#GnNK1Y4`|-F3NKj(4)dS8YatlkN9Q+3L|Q{a%C}upvgjZ=@?pUk^dJ z8IIKW;1eRp`_|SH1`8Y{0F#|U{_eqSt4FRhGBQ%m{Edp0_3HHQd(=7nFW#Mo_e5+2 zDFmu#OB!rUSIeGt>WB8SC)X*O3FSU&95-Vc+>8dE$M zQ@Z4UfKOjKg76rCX833o;7Z*Xn+xwaL`9GKX;&^eh!>%krz7#$o$Op~e_`2wp4;C3 z`c10Z?hG89VyIg(+!S=N4d&^0+knsA+}e8S@Hs9|byFfi?R}{qdjp5~u;%YpLjxU3 zUJ7DiVPO~wV&>=rhv{Q)F?T`Nttx};kbn|yIqBE>&5b4~zbLlH4=`HeFDdf(!*6d(h4-jm$51go8VhI7$RPoC_gRS64ny zPcLdW>$v2Ah*#o%1&g%H^8O6n@Bw}W8b#R3)NXgSs0)fr8DcmZZiAHuCi+$K{E9T4ZZn0G11%{;~DhV>6@m!1-u?O_X_0*|g2~$_QyMFN;-)3><&r zw!iGM49{%<*bI`c?aTJVl8j7DxXZd|-my!0eDaJ|$nNgi_@e^CXlndm_HIkR=x)HD zu#fW!356Mg9?ori@?aqGyde4z1BaHDHcA`I9Wv2=V15O0lQ;Mt96M{g>v>h0Gq*-f z;qe=J+E{(_F_}S{sFbLv+B?gX$maJWFf$lBH}~JBtNN8lq$k}l|M<+#v|65k(aiFG z5*mh!cg=oSq@1`gH@%aIk96o1L*dte=-5ZPQxyK1yR-;uYl#RV5)yuER9JYt?P|Nj z(Qg*6ci+Bpe}LRyUZ(pc>VmlY>Hst|!TtsYqQdBG+65>kfvM+ISK`L{SXmu$mN}X! zDNk-mipa4Y<$~J)H;msp+ipVL3RzN7NKyTwRhKRn z_)6+L{I&*95t%7sizTJ{f#r|#9?Pmd=pt}!TxpTr2EmpfA#=2}&F(t8*RPY0Uh{hj>WPc$V}lgpEQ+@V@uF=cEGW;2KW)7T08}!He1S_-I2#% zQ`k&)(F(ZsNX945o7&~;s=C@Rn$H5@gag7KyL^jJ*v7|PcSq@P z$nd4}5f!DSX{f0cDJfAg(B=KP-iZv#G6K33JPDb?4l@L!sAP+gI2(DIDfUIW0s;@A zs(7fYSRO*yTDYi3nPpYQ4^A`2{dXME`bBWG0{Bq4zEgYG{fc~3pLMT2kcunrH73S~ zomDOTn4zGd@9ell*M7YSpZOW#Zyw{W_(pnUalLZvgI@}x+Qj*%4jiB2F6J;zswZ8w zp`#j;ve66+%X+u6F>$VuL`BL`o>1g=36YVJJ$BWX2y;r&yUS<(fFs>%_sPeao!IbI zwj2};s$x$PEdJl#&AdmK{du{rM5=Wp9&HgnZKkwzG({cwDvvW_(75&nvu*|3OLT7v*pI96F9q+fXYtDXf{U+8nIP(gHVgd7jzqV(=h>BGW~Ma$)w22ZOvg6qG`s z%)Rcv_mMW}3^xkF?`%N+z1XmpB&aSy(oznfYiLqM`{>x$~!7rFP`)9%uGHIhA48?c)p6S>w6CA5U1kn`OqR z*aFcNt+N~H?RWk@&%^d6UEx&Rw+4S4HObjq44q=T zxkj|Ann$J&_II_`|}31&|+1y*n=_z5|#_gIju0;$F&n)oIVP9v}2X`xTHatI6K z-mXj1%hIT*J1QRMug>}4o8Q8$c{SlHt3g3LSzL5oo~U~l$V2#5=n+fvS`60i4Bi-5 z-k+pUeqeUuVsh2Vfpw0uhtp$wCSWi*)gUi|M07E!bw+tXx$curQAjlsA>ks-?;Fg! zCql1OPgI|hr!l{IpZvKN0fCZRMNv-Ae3KBj>X%~$BfQ=0ZG31O@WKKu?(1}Mh64^FY@0{$}ggq1swcEZD8UX=;ZhpM`0nvI-n*9e6J3mwc>+MCnu+;YV_u-rTOMLqXyjw zbx}gX`T0)c3EJg;qWVQ4(z04HOcZNesjg#~UF%&sKU8lu7wr@Cxei<~nr!L^(+7>K zTN6>*P=0+UA~>f1N|5&RQ**u`1I6{MGR<4jZxJ>zpG1ZCv2N*=)aQkS#rHF1$d%#0~jtycLX6F9SOCW>7-=Ej%{Ml!3)Mv03u4 zfGbGIrgz)VK9NaR+^)zj{ioV%c!^HNGXGXv!D{I`iDT*YTl)mzX&l`-CWsQ_{BIoj zr8-VHKo4Xc*MWEok$?X1|9&1^iAnSS_4HF;f}*2lSUn&A{YEckExJn`|Ns2;habK_ z*UUxqrZCmg($djcl({$q!#|NZ5Xl`fIoE)0p(DpqS}!cz2#%#)e$iH+Ur?!ge>d{? zzl;mni(STQ z36k^5=3PYo5(BjTDv-9Q1HM1vH$=6A~-{UpNq}~M}~pbo;?e?BRd?Cdwa{r#5t9quuIrJ#Q&L5^IJ?5wdXB0m+&A&YQv zO@Uqxqc9&xR=t~r*FfiGZ;)~+U`abtD+Muy)39Ff)-f2#u{KT#;+c&teh<0+GNra> zL!E;xGYrObu!Zw~?n_}KqLuQ^n9_OiF97)EU5SI??;Fz*N%Ai4-!~b!{Bc66Quz1{ z_g}6F8vW;F(Sf%pFRH7n-42f24kmH1v0V>##XNuaXK)f-wi+Er8=qJ@lHbk$%qzms z%ZwLu!}>a(1v((vJaRbrbhYq7%FY9kl_T8OANQ&3~`A419AhY{#ceQf)~c^$G=#_3OvA^uIl!v}<7F5m?v|Pc_?1`THAp<$(2P z#&@OTyy^7Sz`8i&OI8lusg#^YX%R_j5q0}YsmGphGUBZ?!zY76qXVca7oQkaUXhRf zb0Kjhy8IpPFFO_tzPmT5k|tK-e$uJ19=`XpcUpZ&yrv#+<@p0kxqp6P*~+pSJqc;I zKyrY&bZBU3ax&q?@yZU&VQi&a8y*CR*cnCUvWK?ZEj@L51U*2TT(tKv#=*>7HQRuhR;Mp-xJd9&>Bx|2(W7U}s>UHihLJ)kE{m_PI|O!qVH{fXS-ksbotU+Wu`!{)zkgr= z)_MZ4>oiN5b~tqGSZVMQS4c<*C_UI7FH$~0LhW1JuAD}?VKO!t z%u_H@e?7%AuJFxY%fgmd1FAZ$#c-QCFS7-8O%~VjWW}&4uII*A=A=Ar^#i9z4fcuk zzuUXx_|Rk#c^IgUNbNAmQyqOA_d3d;4Nz@P>B}G;Q4XL1=TQh9RFsoDcd>E9R!SrWv@Dp(UTW8df4hjP*79 z4vi6`E)oS9Y`N}R%q4k(&?jjpp*T9*IEKo|bH}O6cu!_Tp~BSqNB!*(rbXwZFrBek zJ9+X+sr1FmttTT+{(F6Q7EZ;^3>l2F_XQzLH^Af?eq;m>p>)s(C|xk^Z%eVaw`6Ox z=NrLnAPH+-9T{aHLqii$Uj8ywJb{UcNk{yht?l#|fPO_p{QAT(5RH4}0Q;r4Z^Kts z#EgyO0S~RdGV&DqvBMaH_hLQR+qN%H$Q<*WmS{%ZeC3TtAtf&`9pc?m_It_9GR2nM z80jXt)Y2cXVfrfFVsU&$DECgw5`xa4(~~7GIZWF?YoIO!W4+&GGIy8sF{zmWewW0( zF33W&x7ScrRYjpts;Xr`vBUQRZUV)?w)Sf8;2<3mW*F-Vr;-|TY|c{AsTtT{xH=|# zgUeVu(5R!J7-?*-&H=8~5W=nKL8vLvn@jR`ax%l({({UGSS3l@t9L9J`zoF<^985NTT?%(!xk@uKPOdE?ctbS^!=J@pqrDfnsd1{Z}t1o)3#d` zr?nsLC|VnI+y4ltwg{z`Liw&>S^)IXmNUS^yz@cf;>}25tqm(%+p-9q4*2-iwl z)jb(`s^7yPBjOe$+Lb`lbHwg>QCxNPaSq@f2Ce-lN&MhZ2nbV^Kjmg|_Hmm~U)aa` zjJ+8-d0*=MQ!N@x(IB!dHT_KIqbHO8T9ltvdK+%RDaW`BBN1e;_>E;5D(~tsgvWj# z!+?B;xAmQ&0eeLzsu>@2jr_%`UFA(XeL~`>=XsOBUs*~PB!X|!Db+Imr92kyfQ8Ke zEj%@;x7ew9gPn~}Eh$|hSwOG>EW3k3KGcD2B<+paA@)lTES?chco2BdTQJH!N!dG& z*S!g(HnloNU36DdlZfoX-FCbM71*S#tgyH%<%ET{MTfg#cWd@)Bb}DNBb6aVaZW~SL#vQ!}D?rwTdID}t zR{V=#s0_VAD%Pz`6V&5nWo38eY}NGjTT`AUdpL}1XzqD^=vczIZ?RHSz3vy1+V$Y2 zOE*pun%rDJQhCRBLTAo@46W#3dI~3a-Dg#k{qur)Lhg?$#!S(u*7j=$8^a-jNX~@a zTl~W*nI>HmJ6p)`90StC5&!P>n~*UIY^GRl8Q+anQ&UMP<9QQzVihmf%i>ZB zg7WyKn0IfKVNO8t<>V$9FkMNRUv}`A!glnHl@I zyk34UgJ`T%ks04-7c0>tEA|$(_&#srJwMUSTxgb#dK-szoHXvRSoY4+9jZW`wbEMU zN!bLdcy)CEgguuM&~=XbM-jh|rvH7Wxv;HiXT8~Okh&RMtXp9hBcQgHiW!p$3XlKN z-6IbX$gxa=ik%scq85U4+Zr`+!suO}bdDOL#EY^#z@mc$CtC|1zs-<%ewfP6Zt{2w zA;64FD6g%y^4^5XqvqY0mWv9gL~~!; zSY2DQvdX+RGk_imf};Tx9T4jr1iO#`r7;zu@vi>rZ8!7UYu^Y@PX81N%kg&4YA{T7 z8>`{(35S9N7gD&|rtqX`qiTQ=)=~eSK&4wZ<5!M9r?+gjGcyUvjLsrAA&(Jj7jj?1 zlp_mAj`k+&Vknf}Wn9z7zQ-3!Hb(oMDs1e+AE)x!Kv2loTMF0+mj@w|G?*)IC4GK8HPJ zFl0oNA+}jdcw2qC%tHd#BhI<3KS%ORP5n`xlEP-3ZHPa37kMBW_jxxzDL&#(@P&$=gwgThCw;zu$H0CuZI~?vTO7j3V zI~WyTm*&WT9!`)j8)zA{RnoJDK#&w8?8zSki)KH6ZAmHB$~ZmH4x*zq`;ypvnj8{3 zzcpZ(=z|KdB=Bcv;;giW)V{T4&*M^ya3iuTgRRpbkqE}WlZ%rY!1@VWnGFUuKk=3S zvCB|JuLpM@@Z#m=1<5B2i3@P@D0vYJC?&Zkf9=cX;O34BO+Nq3Iw6Yno6Z7>(B6(G z5X^fs-FGzDaNvcX=4fx{?<+PV9+^i=;^Ps1PaJ=_+M1Km?uS<>LBOtusQ@U&pG*2Gb=-Acbcb_mx znr_<~Gq75sqA)a7gxsS% zz_Css7QR-?Mf0xzqD-{Ja_Wd?8jFYgUJHm~u`6$+$;$!>7$l_Hl~jO;U0kfgEIs+Y z?p|)@a@3^4)iQokfw3TE7Y1U#Bl?Rq5giLGO;Tp{ti>Ee+k*7kF&C%la?5T5&r zJmj62rP6!gxfee_M17NAU+!>O95jm6l(KrCr9e|krgX2fhlJIKValCaIDF5=5TyjV4a&0PoIdKeXpu(YOoF;-*a6VDl`+#%KZ`}a?TN>|S^%3BV> zfPKAp($bbY)6|2gSaJ{rhpt*pEBJwlFB=yZluO;{D%D_SZmA@4)<+w~vmw#}v@u|t zm@lakivQx~o?*tMt@3H;pvkAWPt;Ddi>$Pus%VU)b5Gy+-`4EEt(XzCV#GBC2Zy7o zx4X;vt!Q1l-@PNH$HWBxysKp9J4<5b-Ght1AAv{Mge%D^D74K}JNe6&Twc5F(+*xe zY&Hc)6%TW=GsFw3r!tT3ed>byTmk`nQ~CEb!_Fv8yuW1i%19wz+f{wH0i^JQ1FOco zsoe%G^X`C$>K`zw+KENANA5krDA^VH+wD(hOuyp*huDV9AbocISM4R+AnbImbHlFN z5fly&<2$Nf=F#jz$ij1s0E2xpid@-k=<9pr-s%92yu12~k5LkrEPT$j z3oJ@Y>#qxrtFNyI;lb*swCLN#;7dLUy3gcf)1o4AP+tKlR|OJFvC=j#YJD7sfzEfh zuf2V0aT3kMef@}#vueO}Ar6;F_yO?>_6;m~@~#E literal 0 HcmV?d00001 From d61d427b220ea1f07e7f1941bd21a51b0067acca Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 20 Oct 2023 17:11:50 +1100 Subject: [PATCH 127/814] Update vscode.rst [skip ci] --- docs/vscode.rst | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/docs/vscode.rst b/docs/vscode.rst index 47cf461d2..8863f567c 100644 --- a/docs/vscode.rst +++ b/docs/vscode.rst @@ -1,4 +1,15 @@ Coding Phantom in VSCode or Cursor AI ===================================== -In VSCode or Cursor there are several helpful settings when editing Phantom source files. After installing a modern Fortran extension, to enforce the indentation conventions in Phantom you should use "findent" as in the indentation engine and pass it the same options as used in phantom/scripts/bots.sh. +In VSCode or Cursor there are several helpful settings when editing Phantom source files. After installing a modern Fortran extension, to enforce the indentation conventions in Phantom you should use `findent `_ as in the indentation engine: + +.. image:: images/vscode-findent.png + :width: 800 + :alt: findent option in VSCode + +and pass it the same options as used in `the bots script `_: + +.. image:: images/vscode-findent-flags.png + :width: 800 + :alt: findent flags in VSCode + From 97c73f03c0a4c3f7550a8ff67c5f42f3db3626b7 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 20 Oct 2023 17:17:23 +1100 Subject: [PATCH 128/814] (docs) attempt to fix docs build failure [skip ci] --- docs/requirements.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/requirements.txt b/docs/requirements.txt index 466e7c4a5..c0e137066 100644 --- a/docs/requirements.txt +++ b/docs/requirements.txt @@ -1,3 +1,4 @@ numpy +six sphinx-fortran From cef5581c01bfed069314897d90b9f680813d3956 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 20 Oct 2023 17:21:56 +1100 Subject: [PATCH 129/814] (docs) attempt to fix build failure [skip ci] --- docs/requirements.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/requirements.txt b/docs/requirements.txt index c0e137066..c88896051 100644 --- a/docs/requirements.txt +++ b/docs/requirements.txt @@ -1,3 +1,4 @@ +sphinx-rtd-theme numpy six sphinx-fortran From dbc5a7495dd369988d301eeb859ed001815bba90 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 23 Oct 2023 16:29:00 +1100 Subject: [PATCH 130/814] (#463) bug fixes with particle mass setting in asteroidwind --- src/setup/setup_asteroidwind.f90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index 0b2215f9d..aff62f942 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -30,6 +30,7 @@ module setup ! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, ! io, options, part, physcon, setbinary, spherical, timestep, units ! + use inject, only:mdot implicit none public :: setpart @@ -44,7 +45,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,idust,set_particle_type,igas use setbinary, only:set_binary,get_a_from_period use spherical, only:set_sphere - use units, only:set_units,umass,udist,unit_velocity + use units, only:set_units,umass,udist,utime,unit_velocity use physcon, only:solarm,au,pi,solarr,ceresm,km,kboltz,mass_proton_cgs use externalforces, only:iext_binary, iext_einsteinprec, update_externalforce, & mass1,accradius1 @@ -54,6 +55,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use eos, only:gmw use options, only:iexternalforce use extern_lensethirring, only:blackhole_spin + use kernel, only:hfact_default integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -80,7 +82,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, rasteroid = 2338.3 ! (km) gastemp = 5000. ! (K) norbits = 1000. - !mdot = 5.e8 ! Mass injection rate (g/s) + mdot = 5.e8 ! Mass injection rate (g/s) npart_at_end = 1.0e6 ! Number of particles after norbits dumpsperorbit = 1 @@ -175,10 +177,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, xyzmh_ptmass(ihsoft,1) = rasteroid ! asteroid radius softening endif - ! both of these are reset in the first call to inject_particles - !massoftype(igas) = tmax*mdot/(umass/utime)/npart_at_end - massoftype(igas) = 1.e-12 - hfact = 1.2 + ! we use the estimated injection rate and the final time to set the particle mass + massoftype(igas) = tmax*mdot/(umass/utime)/npart_at_end + hfact = hfact_default !call inject_particles(time,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,dtinj) ! @@ -215,7 +216,7 @@ subroutine write_setupfile(filename) call write_inopt(norbits, 'norbits', 'number of orbits', iunit) call write_inopt(dumpsperorbit,'dumpsperorbit','number of dumps per orbit', iunit) call write_inopt(npart_at_end,'npart_at_end','number of particles injected after norbits',iunit) - !call write_inopt(mdot,'mdot','mass injection rate (g/s)',iunit) + call write_inopt(mdot,'mdot','mass injection rate (g/s)',iunit) close(iunit) end subroutine write_setupfile @@ -244,7 +245,7 @@ subroutine read_setupfile(filename,ierr) call read_inopt(norbits, 'norbits', db,min=0.,errcount=nerr) call read_inopt(dumpsperorbit,'dumpsperorbit',db,min=0 ,errcount=nerr) call read_inopt(npart_at_end, 'npart_at_end', db,min=0 ,errcount=nerr) - !call read_inopt(mdot, 'mdot', db,min=0.,errcount=nerr) + call read_inopt(mdot, 'mdot', db,min=0.,errcount=nerr) call close_db(db) if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' From 9989ffa958ca711788d4af4a7671bd3325523787 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 23 Oct 2023 16:40:16 +1100 Subject: [PATCH 131/814] (asteroidwind) delete unused scaling_set variable --- src/main/inject_asteroidwind.f90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/main/inject_asteroidwind.f90 b/src/main/inject_asteroidwind.f90 index dd2d6c25e..758784144 100644 --- a/src/main/inject_asteroidwind.f90 +++ b/src/main/inject_asteroidwind.f90 @@ -36,7 +36,6 @@ module inject real :: npartperorbit = 1000. ! particle injection rate in particles per orbit real :: vlag = 0.0 ! percentage lag in velocity of wind integer :: mdot_type = 2 ! injection rate (0=const, 1=cos(t), 2=r^(-2)) - logical,save :: scaling_set ! has the scaling been set (initially false) contains !----------------------------------------------------------------------- @@ -47,7 +46,6 @@ module inject subroutine init_inject(ierr) integer, intent(inout) :: ierr - scaling_set = .false. ierr = 0 end subroutine init_inject @@ -225,8 +223,8 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) end subroutine read_options_inject subroutine set_default_options_inject(flag) - integer, optional, intent(in) :: flag + end subroutine set_default_options_inject end module inject From f177e5881bdd66c5666833b5baf01f0f06e6644e Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Thu, 26 Oct 2023 10:50:21 +1100 Subject: [PATCH 132/814] (flrw) fixed complier warnings --- src/main/extern_gr.F90 | 24 ++++++------ src/main/utils_cpuinfo.f90 | 2 + src/setup/setup_flrw.f90 | 64 ++++++++++++-------------------- src/utils/einsteintk_wrapper.f90 | 2 + 4 files changed, 39 insertions(+), 53 deletions(-) diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index e52a99f36..939d7b301 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -81,30 +81,28 @@ end subroutine get_grforce_all !--- Subroutine to calculate the timestep constraint from the 'external force' ! this is multiplied by the safety factor C_force elsewhere subroutine dt_grforce(xyzh,fext,dtf) -#ifdef FINVSQRT - use fastmath, only:finvsqrt -#endif use physcon, only:pi - use metric_tools, only:imet_minkowski,imetric + use metric_tools, only:imetric,imet_schwarzschild,imet_kerr real, intent(in) :: xyzh(4),fext(3) real, intent(out) :: dtf real :: r,r2,dtf1,dtf2,f2i integer, parameter :: steps_per_orbit = 100 - + f2i = fext(1)*fext(1) + fext(2)*fext(2) + fext(3)*fext(3) -#ifdef FINVSQRT - dtf1 = sqrt(xyzh(4)*finvsqrt(f2i)) -#else - dtf1 = sqrt(xyzh(4)/sqrt(f2i)) ! This is not really accurate since fi is a component of dp/dt, not da/dt -#endif + if (f2i > 0.) then + dtf1 = sqrt(xyzh(4)/sqrt(f2i)) ! This is not really accurate since fi is a component of dp/dt, not da/dt + else + dtf1 = huge(dtf1) + endif - if (imetric /= imet_minkowski) then + select case (imetric) + case (imet_schwarzschild,imet_kerr) r2 = xyzh(1)*xyzh(1) + xyzh(2)*xyzh(2) + xyzh(3)*xyzh(3) r = sqrt(r2) dtf2 = (2.*pi*sqrt(r*r2))/steps_per_orbit - else + case default dtf2 = huge(dtf2) - endif + end select dtf = min(dtf1,dtf2) diff --git a/src/main/utils_cpuinfo.f90 b/src/main/utils_cpuinfo.f90 index 4fa898b6a..317a6c18b 100644 --- a/src/main/utils_cpuinfo.f90 +++ b/src/main/utils_cpuinfo.f90 @@ -83,6 +83,8 @@ subroutine get_cpuinfo(ncpu,ncpureal,cpuspeed,cpumodel,cachesize,ierr) ncpu = 0 ncpureal = 0 cpuspeed = 0. + cachesizel2 = 0. + cachesizel3 = 0. cpumodel = '' cachesize = '' inquire(file='/proc/cpuinfo',exist=iexist) diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index d67e6396f..ffc8b98d2 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -63,7 +63,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use unifdis, only:set_unifdis,rho_func!,mass_func use boundary, only:xmin,ymin,zmin,xmax,ymax,zmax,dxbound,dybound,dzbound,set_boundary use part, only:periodic - use physcon, only:years,pc,solarm + use physcon, only:years,pc,solarm,pi use units, only:set_units use mpidomain, only:i_belong use stretchmap, only:set_density_profile @@ -81,7 +81,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, character(len=20), intent(in) :: fileprefix real, intent(out) :: vxyzu(:,:) character(len=40) :: filename,lattice - real :: totmass,deltax,pi + real :: totmass,deltax integer :: i,ierr logical :: iexist real :: kwave,denom,length, c1,c3,lambda @@ -89,15 +89,14 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real :: Vup(0:3),phi,sqrtg,gcov(0:3,0:3),alpha,hub real :: last_scattering_temp procedure(rho_func), pointer :: density_func - !procedure(mass_func), pointer :: mass_function density_func => rhofunc ! desired density function - !mass_function => massfunc ! desired mass funciton + ! !--general parameters ! - perturb_wavelength = 1. + perturb_wavelength = 1.0 time = 0. if (maxvxyzu < 4) then gamma = 1. @@ -106,8 +105,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! irrelevant for gamma = 4./3. endif - ! Redefinition of pi to fix numerical error - pi = 4.D0*Datan(1.0D0) + ! ! default units ! @@ -133,11 +131,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Then it should be set using the Friedmann equation: !!!!!! rhozero = (3H^2)/(8*pi*a*a) - hub = 10.553495658357338 + hub = 10.553495658357338!/10. !hub = 23.588901903912664 !hub = 0.06472086375185665 - rhozero = 3.d0 * hub**2 / (8.d0 * pi) + rhozero = 3. * hub**2 / (8. * pi) phaseoffset = 0. + ampl = 0. ! Approx Temp of the CMB in Kelvins !last_scattering_temp = 3000 @@ -146,9 +145,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Define some parameters for Linear pertubations ! We assume ainit = 1, but this may not always be the case - c1 = 1.d0/(4.d0*PI*rhozero) + c1 = 1./(4.*pi*rhozero) !c2 = We set g(x^i) = 0 as we only want to extract the growing mode - c3 = - sqrt(1.d0/(6.d0*PI*rhozero)) + c3 = - sqrt(1./(6.*pi*rhozero)) !c3 = hub/(4.d0*PI*rhozero) @@ -203,8 +202,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, lambda = perturb_wavelength*length kwave = (2.d0*pi)/lambda denom = length - ampl/kwave*(cos(kwave*length)-1.0) - ! Hardcode to ensure double precision, that is requried - !rhozero = 13.294563008157013D0 rhozero = 3.d0 * hub**2 / (8.d0 * pi) print*, rhozero @@ -212,7 +209,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, case('"yes"') ! Set a value of rho_matter - rho_matter = 1.e-20 + rho_matter = 1.e-40 !rhozero = rhozero - radconst*last_scattering_temp**4 ! Solve for temperature last_scattering_temp = ((rhozero-rho_matter)/radconst)**(1./4.) @@ -221,7 +218,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, xval = density_func(0.75) xval = density_func(0.5) - !stop select case(ilattice) case(2) @@ -277,11 +273,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, select case(perturb_direction) case ('"x"') - ! should not be zero, for a pertrubed wave - !vxyzu(1,i) = ampl*sin(kwave*(xyzh(1,i)-xmin)) - vxyzu(1,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(1,i))/lambda - phaseoffset) + ! should not be zero, for a perturbed wave + vxyzu(1,i) = kwave*c3*ampl*cos((2.*pi*xyzh(1,i))/lambda - phaseoffset) phi = ampl*sin(kwave*xyzh(1,i)-phaseoffset) - Vup(1) = kwave*c3*ampl*cos(2.d0*pi*xyzh(1,i) - phaseoffset) + Vup(1) = kwave*c3*ampl*cos(2.*pi*xyzh(1,i) - phaseoffset) Vup(2:3) = 0. call perturb_metric(phi,gcov) call get_sqrtg(gcov,sqrtg) @@ -290,10 +285,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, vxyzu(1,i) = Vup(1)*alpha vxyzu(2:3,i) = 0. case ('"y"') - vxyzu(2,i) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) + vxyzu(2,i) = kwave*c3*ampl*cos((2.*pi*xyzh(2,i))/lambda - phaseoffset) phi = ampl*sin(kwave*xyzh(2,i)-phaseoffset) Vup = 0. - Vup(2) = kwave*c3*ampl*cos(2.d0*pi*xyzh(2,i) - phaseoffset) + Vup(2) = kwave*c3*ampl*cos(2.*pi*xyzh(2,i) - phaseoffset) call perturb_metric(phi,gcov) call get_sqrtg(gcov,sqrtg) @@ -304,9 +299,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, case ('"all"') phi = ampl*(sin(kwave*xyzh(1,i)-phaseoffset) - sin(kwave*xyzh(2,i)-phaseoffset) - sin(kwave*xyzh(3,i)-phaseoffset)) - Vup(1) = kwave*c3*ampl*cos((2.d0*pi*xyzh(1,i))/lambda - phaseoffset) - Vup(2) = kwave*c3*ampl*cos((2.d0*pi*xyzh(2,i))/lambda - phaseoffset) - Vup(3) = kwave*c3*ampl*cos((2.d0*pi*xyzh(3,i))/lambda - phaseoffset) + Vup(1) = kwave*c3*ampl*cos((2.*pi*xyzh(1,i))/lambda - phaseoffset) + Vup(2) = kwave*c3*ampl*cos((2.*pi*xyzh(2,i))/lambda - phaseoffset) + Vup(3) = kwave*c3*ampl*cos((2.*pi*xyzh(3,i))/lambda - phaseoffset) call perturb_metric(phi,gcov) call get_sqrtg(gcov,sqrtg) @@ -330,7 +325,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, if (maxvxyzu >= 4 .and. gamma > 1.) vxyzu(4,i) = (radconst*(last_scattering_temp**4))/rhozero !vxyzu(4,i) = cs0**2/(gamma*(gamma-1.)) ! Check that the pressure is correct print*, "Pressure: ", (gamma-1)*rhozero*vxyzu(4,i) - print*, "Pressure from energy density: ", 3.d0 * hub**2 / (8.d0 * pi)/3. + print*, "Pressure from energy density: ", 3. * hub**2 / (8. * pi)/3. print*, "Pressure 1/3 \rho u: ",radconst*(last_scattering_temp**4)/3. print*, "particle mass: ", massoftype end select @@ -345,7 +340,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !---------------------------------------------------- real function rhofunc(x) use utils_gr, only:perturb_metric, get_u0, get_sqrtg - !use metric_tools, only:unpack_metric real, intent(in) :: x real :: const, phi, rhoprim, gcov(0:3,0:3), sqrtg,u0,v(3),Vup(3) real :: alpha @@ -355,7 +349,7 @@ real function rhofunc(x) !rhofunc = ampl*sin(kwave*(x-xmin)) ! Eq 28. in Macpherson+ 2017 ! Although it is missing a negative sign - const = -kwave*kwave*c1 - 2.d0 + const = -kwave*kwave*c1 - 2. phi = ampl*sin(kwave*x-phaseoffset) !rhofunc = rhozero*(1.d0 + const*ampl*sin(kwave*x)) ! Get the primative density from the linear perb @@ -368,7 +362,7 @@ real function rhofunc(x) ! Define the 3 velocities to calculate u0 ! Three velocity will need to be converted from big V to small v ! - Vup(1) = kwave*c3*ampl*cos((2.d0*pi*x)/lambda-phaseoffset) + Vup(1) = kwave*c3*ampl*cos((2.*pi*x)/lambda-phaseoffset) Vup(2:3) = 0. alpha = sqrt(-gcov(0,0)) v(1) = Vup(1)*alpha @@ -376,10 +370,6 @@ real function rhofunc(x) ! calculate u0 ! TODO Should probably handle this error at some point call get_u0(gcov,v,u0,ierr) - !print*,"u0: ", u0 - !print*, alpha - !print*,"gcov: ", gcov - !print*, "sqrtg: ", sqrtg ! Perform a prim2cons rhofunc = rhoprim*u0*sqrtg @@ -393,7 +383,7 @@ real function massfunc(x,xmin) real :: lorrentz, bigv2 ! The value inside the bracket - const = -kwave*kwave*c1 - 2.d0 + const = -kwave*kwave*c1 - 2. phi = ampl*sin(kwave*x-phaseoffset) !expr = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*x)/lambda) !exprmin = ampl*(-(1./kwave))*cos(phaseoffset - (2.d0*pi*xmin)/lambda) @@ -411,7 +401,7 @@ real function massfunc(x,xmin) ! Define the 3 velocities to calculate u0 ! Three velocity will need to be converted from big V to small v ! - Vup(1) = kwave*c3*ampl*cos((2.d0*pi*x)/lambda-phaseoffset) + Vup(1) = kwave*c3*ampl*cos((2.*pi*x)/lambda-phaseoffset) Vup(2:3) = 0. alpha = sqrt(-gcov(0,0)) !v(0) = 1 @@ -422,12 +412,6 @@ real function massfunc(x,xmin) call get_u0(gcov,v,u0,ierr) massfunc = (massprim)!*lorrentz massfunc = massprim!*sqrtg*u0 -! print*,u0 -! print*,sqrtg -! print*, massfunc -! print*, massprim - !stop - end function massfunc diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 072508797..61995f5cd 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -424,7 +424,9 @@ subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) use evwrite, only:write_evfile,write_evlog use readwrite_dumps, only:write_smalldump,write_fulldump use fileutils, only:getnextfilename + use tmunu2grid, only:check_conserved_dens real, intent(in) :: time, dt_et + real(kind=16) :: cfac !logical, intent(in), optional :: checkpoint !integer, intent(in) :: checkpointno character(*),optional, intent(in) :: checkpointfile From 5c1f127818fb290e987c3fbb6170de250529a9b1 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Thu, 26 Oct 2023 10:54:16 +1100 Subject: [PATCH 133/814] (einsteintk_wrapper) fixed compiler warning --- src/utils/einsteintk_wrapper.f90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 61995f5cd..f7b5282e2 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -239,7 +239,7 @@ subroutine et2phantom_tmunu() ! Correct Tmunu ! Convert to 8byte real to stop compiler warning tmunugrid = real(cfac)*tmunugrid - + end subroutine et2phantom_tmunu @@ -418,15 +418,13 @@ end subroutine phantom2et_momentum ! Subroutine for performing a phantom dump from einstein toolkit subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) - use cons2prim, only:cons2primall - !use part, only:npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars use einsteintk_utils use evwrite, only:write_evfile,write_evlog use readwrite_dumps, only:write_smalldump,write_fulldump use fileutils, only:getnextfilename use tmunu2grid, only:check_conserved_dens real, intent(in) :: time, dt_et - real(kind=16) :: cfac + !real(kind=16) :: cfac !logical, intent(in), optional :: checkpoint !integer, intent(in) :: checkpointno character(*),optional, intent(in) :: checkpointfile @@ -437,10 +435,7 @@ subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) else createcheckpoint = .false. endif - !character(len=20) :: logfile,evfile,dumpfile - ! Call cons2prim since values are updated with MoL - !call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) ! Write EV_file if (.not. createcheckpoint) then call write_evfile(time,dt_et) @@ -451,14 +446,19 @@ subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) call write_fulldump(time,dumpfilestor) endif - !print*, "Evfile: ", evfilestor - !print*, "logfile: ", logfilestor - !print*, "dumpfle: ", dumpfilestor ! Write full dump if (createcheckpoint) then call write_fulldump(time,checkpointfile) endif + + ! Quick and dirty write cfac to txtfile + ! Density check vs particles +! call check_conserved_dens(rhostargrid,cfac) +! open(unit=777, file="cfac.txt", action='write', position='append') +! print*, time, cfac +! write(777,*) time, cfac +! close(unit=777) end subroutine et2phantom_dumphydro From 4cc40b0f06199ad3c652dce6f9968a0a8131cb2e Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Thu, 26 Oct 2023 11:09:57 +1100 Subject: [PATCH 134/814] (AUTHORS) fixed authors file with bots --- AUTHORS | 42 ++++-------------------------------------- 1 file changed, 4 insertions(+), 38 deletions(-) diff --git a/AUTHORS b/AUTHORS index eed8d5bed..d0b207025 100644 --- a/AUTHORS +++ b/AUTHORS @@ -27,15 +27,9 @@ Mats Esseldeurs Stephane Michoulier Simone Ceppi MatsEsseldeurs -Enrico Ragusa -<<<<<<< HEAD Caitlyn Hardiman -Sergei Biriukov -Giovanni Dipierro -Roberto Iaconi -Cristiano Longarini -======= ->>>>>>> upstream/master +Enrico Ragusa +Spencer Magnall fhu Sergei Biriukov Cristiano Longarini @@ -44,11 +38,6 @@ Roberto Iaconi Hauke Worpel Alison Young Simone Ceppi -<<<<<<< HEAD -Stephane Michoulier -Spencer Magnall -======= ->>>>>>> upstream/master Amena Faruqi Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani @@ -62,31 +51,15 @@ Alessia Franchini Alex Pettitt Jolien Malfait Phantom benchmark bot -<<<<<<< HEAD -Nicole Rodrigues -Kieran Hirsh -David Trevascus -Amena Faruqi -Nicolas Cuello -Megha Sharma -Chris Nixon -Orsola De Marco -s-neilson <36410751+s-neilson@users.noreply.github.com> -Megha Sharma -Maxime Lombart -Joe Fisher -Giulia Ballabio -======= Kieran Hirsh Nicole Rodrigues Amena Faruqi David Trevascus +Farzana Meru Chris Nixon Megha Sharma Nicolas Cuello ->>>>>>> upstream/master Benoit Commercon -Farzana Meru Giulia Ballabio Joe Fisher Maxime Lombart @@ -94,19 +67,12 @@ Megha Sharma Orsola De Marco Terrence Tricco Zachary Pellow -<<<<<<< HEAD -Steven Rieder -mats esseldeurs -Cox, Samuel -Jorge Cuadra -Alison Young -======= s-neilson <36410751+s-neilson@users.noreply.github.com> Alison Young Cox, Samuel Jorge Cuadra +Miguel Gonzalez-Bolivar Nicolás Cuello Steven Rieder ->>>>>>> upstream/master Stéven Toupin mats esseldeurs From 02d1b2b0699531558161bae2e4efd803bfd4f418 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Thu, 26 Oct 2023 17:33:13 +1100 Subject: [PATCH 135/814] (flrwpspec) fixed compile/runtime issues --- src/setup/setup_flrwpspec.f90 | 36 +++++++++++++++++------------------ 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index 4a02a41e7..b3290245f 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -89,16 +89,11 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real :: scale_factor,gradphi(3),vxyz(3),dxgrid,gridorigin integer :: nghost, gridres, gridsize real, allocatable :: vxgrid(:,:,:),vygrid(:,:,:),vzgrid(:,:,:) -! procedure(rho_func), pointer :: density_func -! procedure(mass_func), pointer :: mass_function - -! density_func => rhofunc ! desired density function -! mass_function => massfunc ! desired mass funciton - + ! !--general parameters ! - !perturb_wavelength = 1. + perturb_wavelength = 0. time = 0. if (maxvxyzu < 4) then gamma = 1. @@ -108,7 +103,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, gamma = 4./3. endif ! Redefinition of pi to fix numerical error - pi = 4.D0*Datan(1.0D0) + pi = 4.*atan(1.) ! ! default units ! @@ -124,10 +119,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! set default values for input parameters ! npartx = 64 + length = 0. ilattice = 1 perturb = '"no"' perturb_direction = '"none"' radiation_dominated = '"no"' + ampl = 0. ! Ideally this should read the values of the box length ! and initial Hubble parameter from the par file. @@ -135,7 +132,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !!!!!! rhozero = (3H^2)/(8*pi*a*a) hub = 10.553495658357338 - rhozero = 3.d0 * hub**2 / (8.d0 * pi) + rhozero = 3. * hub**2 / (8. * pi) phaseoffset = 0. ! Set some default values for the grid @@ -151,9 +148,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, isperiodic = .true. ncross = 0 - allocate(vxgrid(gridsize,gridsize,gridsize)) - allocate(vygrid(gridsize,gridsize,gridsize)) - allocate(vzgrid(gridsize,gridsize,gridsize)) + ! Approx Temp of the CMB in Kelvins last_scattering_temp = 3000 @@ -161,9 +156,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Define some parameters for Linear pertubations ! We assume ainit = 1, but this may not always be the case - c1 = 1.d0/(4.d0*PI*rhozero) + c1 = 1./(4.*PI*rhozero) !c2 = We set g(x^i) = 0 as we only want to extract the growing mode - c3 = - sqrt(1.d0/(6.d0*PI*rhozero)) + c3 = - sqrt(1./(6.*PI*rhozero)) if (gr) then @@ -195,11 +190,16 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! set units and boundaries ! if (gr) then - call set_units(dist=udist,c=1.d0,G=1.d0) + call set_units(dist=udist,c=1.,G=1.) else - call set_units(dist=udist,mass=umass,G=1.d0) + call set_units(dist=udist,mass=umass,G=1.) endif call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) + + + allocate(vxgrid(gridsize,gridsize,gridsize)) + allocate(vygrid(gridsize,gridsize,gridsize)) + allocate(vzgrid(gridsize,gridsize,gridsize)) ! ! setup particles ! @@ -216,9 +216,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! lambda = perturb_wavelength*length ! kwave = (2.d0*pi)/lambda ! denom = length - ampl/kwave*(cos(kwave*length)-1.0) - ! Hardcode to ensure double precision, that is requried - !rhozero = 13.294563008157013D0 - rhozero = 3.d0 * hub**2 / (8.d0 * pi) + rhozero = 3. * hub**2 / (8. * pi) lattice = 'cubic' From 5227b267e44f1627e7eedcf8839bcd5e7b7de55d Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Thu, 26 Oct 2023 16:36:12 +0200 Subject: [PATCH 136/814] fix heck on sink luminosity --- src/main/checksetup.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index 6251c415b..ca5b002ad 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.F90 @@ -589,7 +589,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) ! ! check that radiation properties are sensible ! - if (isink_radiation > 1 .and. xyzmh_ptmass(ilum,1) < 1e-10) then + if (isink_radiation > 1 .and. xyzmh_ptmass(ilum,1) < 1e-15) then nerror = nerror + 1 print*,'ERROR: isink_radiation > 1 and sink particle has no luminosity' return From 38c76c540b096b96f6bb27dc91bf5ff49a552708 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Thu, 26 Oct 2023 20:54:42 +0200 Subject: [PATCH 137/814] H2cooling : remove ifdef H2CHEM and replace it by an icooling value --- build/Makefile | 6 +- src/main/checkoptions.F90 | 4 +- src/main/checksetup.F90 | 4 +- src/main/config.F90 | 10 +-- src/main/cooling.f90 | 108 +++++++++++++-------------- src/main/cooling_ism.f90 | 1 - src/main/force.F90 | 4 +- src/main/inject_wind.f90 | 8 +- src/main/part.F90 | 2 +- src/main/readwrite_dumps_common.F90 | 4 +- src/main/readwrite_dumps_fortran.F90 | 8 +- src/main/readwrite_infile.F90 | 2 +- src/main/step_leapfrog.F90 | 6 +- src/main/writeheader.F90 | 6 +- src/setup/setup_wind.f90 | 3 +- 15 files changed, 79 insertions(+), 97 deletions(-) diff --git a/build/Makefile b/build/Makefile index d3aef2983..436fa6d45 100644 --- a/build/Makefile +++ b/build/Makefile @@ -244,10 +244,6 @@ ifeq ($(NONIDEALMHD), yes) FPPFLAGS += -DNONIDEALMHD endif -ifeq ($(H2CHEM), yes) - FPPFLAGS += -DH2CHEM -endif - ifeq ($(DISC_VISCOSITY), yes) FPPFLAGS += -DDISC_VISCOSITY endif @@ -1323,7 +1319,7 @@ getdims: @echo $(MAXP) get_setup_opts: - @echo "${GR:yes=GR} ${METRIC} ${MHD:yes=MHD} ${NONIDEALMHD:yes=non-ideal} ${DUST:yes=dust} ${GRAVITY:yes=self-gravity} ${RADIATION:yes=radiation} ${H2CHEM:yes=H2_Chemistry} ${DISC_VISCOSITY:yes=disc_viscosity} ${ISOTHERMAL:yes=isothermal} ${PERIODIC:yes=periodic}" | xargs | sed -e 's/ /, /g' -e 's/_/ /g' + @echo "${GR:yes=GR} ${METRIC} ${MHD:yes=MHD} ${NONIDEALMHD:yes=non-ideal} ${DUST:yes=dust} ${GRAVITY:yes=self-gravity} ${RADIATION:yes=radiation} ${DISC_VISCOSITY:yes=disc_viscosity} ${ISOTHERMAL:yes=isothermal} ${PERIODIC:yes=periodic}" | xargs | sed -e 's/ /, /g' -e 's/_/ /g' get_setup_file: @echo "$(SETUPFILE)" diff --git a/src/main/checkoptions.F90 b/src/main/checkoptions.F90 index 18073c2b3..ff7de8cc9 100644 --- a/src/main/checkoptions.F90 +++ b/src/main/checkoptions.F90 @@ -30,8 +30,8 @@ module checkoptions ! !------------------------------------------------------------------- subroutine check_compile_time_settings(ierr) - use part, only:mhd,gravity,ngradh,h2chemistry,maxvxyzu,use_dust,gr - use dim, only:use_dustgrowth,maxtypes,mpi,inject_parts + use part, only:mhd,gravity,ngradh,maxvxyzu,use_dust,gr + use dim, only:use_dustgrowth,maxtypes,mpi,inject_parts,h2chemistry use io, only:error,id,master,fatal,warning use mpiutils, only:barrier_mpi #ifdef GR diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index 0768b2ed9..376b58968 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.F90 @@ -37,10 +37,10 @@ module checksetup !+ !------------------------------------------------------------------ subroutine check_setup(nerror,nwarn,restart) - use dim, only:maxp,maxvxyzu,periodic,use_dust,ndim,mhd,use_dustgrowth, & + use dim, only:maxp,maxvxyzu,periodic,use_dust,ndim,mhd,use_dustgrowth,h2chemistry, & do_radiation,n_nden_phantom,mhd_nonideal,do_nucleation,use_krome use part, only:xyzh,massoftype,hfact,vxyzu,npart,npartoftype,nptmass,gravity, & - iphase,maxphase,isetphase,labeltype,igas,h2chemistry,maxtypes,& + iphase,maxphase,isetphase,labeltype,igas,maxtypes,& idust,xyzmh_ptmass,vxyz_ptmass,iboundary,isdeadh,ll,ideadhead,& kill_particle,shuffle_part,iamtype,iamdust,Bxyz,rad,radprop, & remove_particle_from_npartoftype,ien_type,ien_etotal,gr diff --git a/src/main/config.F90 b/src/main/config.F90 index bb548a994..78c2bc806 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -241,12 +241,8 @@ module dim ! H2 Chemistry !-------------------- integer :: maxp_h2 = 0 -#ifdef H2CHEM - logical, parameter :: h2chemistry = .true. -#else - logical, parameter :: h2chemistry = .false. -#endif integer, parameter :: nabundances = 5 + logical :: h2chemistry = .false. !-------------------- ! Self-gravity @@ -407,10 +403,6 @@ subroutine update_max_sizes(n,ntot) #endif #endif -#ifdef H2CHEM - maxp_h2 = maxp -#endif - #ifdef GRAVITY maxgrav = maxp #endif diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 462394f0d..a5a06554d 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -58,7 +58,7 @@ module cooling !+ !----------------------------------------------------------------------- subroutine init_cooling(id,master,iprint,ierr) - use dim, only:maxvxyzu,h2chemistry + use dim, only:maxvxyzu use units, only:unit_ergg use physcon, only:mass_proton_cgs,kboltz use io, only:error @@ -74,30 +74,28 @@ subroutine init_cooling(id,master,iprint,ierr) cooling_in_step = .true. ierr = 0 - if (h2chemistry) then - if (id==master) write(iprint,*) 'initialising cooling function...' + select case(icooling) + case(8) + if (id==master) write(iprint,*) 'initialising ISM cooling function...' call init_chem() call init_cooling_ism() - else - select case(icooling) - case(6) - call init_cooling_KI02(ierr) - case(5) - call init_cooling_KI02(ierr) - cooling_in_step = .false. - case(4) - ! Initialise molecular cooling - call init_cooling_molec - case(3) - ! Gammie - cooling_in_step = .false. - case(7) - ! Gammie PL - cooling_in_step = .false. - case default - call init_cooling_solver(ierr) - end select - endif + case(6) + call init_cooling_KI02(ierr) + case(5) + call init_cooling_KI02(ierr) + cooling_in_step = .false. + case(4) + ! Initialise molecular cooling + call init_cooling_molec + case(3) + ! Gammie + cooling_in_step = .false. + case(7) + ! Gammie PL + cooling_in_step = .false. + case default + call init_cooling_solver(ierr) + end select !--calculate the energy floor in code units if (Tfloor > 0.) then @@ -172,7 +170,6 @@ end subroutine energ_cooling !----------------------------------------------------------------------- subroutine write_options_cooling(iunit) use infile_utils, only:write_inopt - use part, only:h2chemistry use cooling_ism, only:write_options_cooling_ism use cooling_gammie, only:write_options_cooling_gammie use cooling_gammie_PL, only:write_options_cooling_gammie_PL @@ -182,23 +179,20 @@ subroutine write_options_cooling(iunit) write(iunit,"(/,a)") '# options controlling cooling' call write_inopt(C_cool,'C_cool','factor controlling cooling timestep',iunit) - if (h2chemistry) then - call write_inopt(icooling,'icooling','cooling function (0=off, 1=on)',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)',iunit) - select case(icooling) - case(0,4,5,6) + call write_inopt(icooling,'icooling','cooling function (0=off, 1=library (step), 2=library (force),'// & + '3=Gammie, 5,6=KI02, 7=powerlaw, 8=ISM)',iunit) + select case(icooling) + case(0,4,5,6) ! do nothing - case(3) - call write_options_cooling_gammie(iunit) - case(7) - call write_options_cooling_gammie_PL(iunit) - case default - call write_options_cooling_solver(iunit) - end select - endif + case(8) + call write_options_cooling_ism(iunit) + case(3) + call write_options_cooling_gammie(iunit) + case(7) + call write_options_cooling_gammie_PL(iunit) + case default + call write_options_cooling_solver(iunit) + end select if (icooling > 0) call write_inopt(Tfloor,'Tfloor','temperature floor (K); on if > 0',iunit) end subroutine write_options_cooling @@ -209,10 +203,10 @@ end subroutine write_options_cooling !+ !----------------------------------------------------------------------- subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) - use part, only:h2chemistry use io, only:fatal + use dim, only:maxp_h2,h2chemistry,maxp use cooling_gammie, only:read_options_cooling_gammie - use cooling_gammie_PL, only:read_options_cooling_gammie_PL + use cooling_gammie_PL, only:read_options_cooling_gammie_PL use cooling_ism, only:read_options_cooling_ism use cooling_molecular, only:read_options_molecular_cooling use cooling_solver, only:read_options_cooling_solver @@ -241,25 +235,23 @@ subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) Tfloor case default imatch = .false. - if (h2chemistry) then + select case(icooling) + case(0,4,5,6) + ! do nothing + case(8) call read_options_cooling_ism(name,valstring,imatch,igotallism,ierr) - else - select case(icooling) - case(0,4,5,6) - ! do nothing - case(3) - call read_options_cooling_gammie(name,valstring,imatch,igotallgammie,ierr) - case(7) - call read_options_cooling_gammie_PL(name,valstring,imatch,igotallgammiePL,ierr) - case default - call read_options_cooling_solver(name,valstring,imatch,igotallfunc,ierr) - end select - endif + h2chemistry = .true. + maxp_h2 = maxp + case(3) + call read_options_cooling_gammie(name,valstring,imatch,igotallgammie,ierr) + case(7) + call read_options_cooling_gammie_PL(name,valstring,imatch,igotallgammiePL,ierr) + case default + call read_options_cooling_solver(name,valstring,imatch,igotallfunc,ierr) + end select end select ierr = 0 - if (h2chemistry .and. igotallism .and. ngot >= 2) then - igotall = .true. - elseif (icooling >= 0 .and. ngot >= 2 .and. igotallgammie .and. igotallfunc) then + if (icooling >= 0 .and. ngot >= 2 .and. igotallgammie .and. igotallfunc .and. igotallism) then igotall = .true. else igotall = .false. diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index 3b1b2313b..4d163cf1d 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.f90 @@ -196,7 +196,6 @@ end subroutine write_options_cooling_ism !+ !----------------------------------------------------------------------- subroutine read_options_cooling_ism(name,valstring,imatch,igotall,ierr) - use part, only:h2chemistry character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr diff --git a/src/main/force.F90 b/src/main/force.F90 index bff01b4c0..2c831c5a5 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -207,7 +207,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& #else use timestep, only:C_cour,C_force #endif - use part, only:divBsymm,isdead_or_accreted,h2chemistry,ngradh,gravity,ibin_wake + use part, only:divBsymm,isdead_or_accreted,ngradh,gravity,ibin_wake use mpiutils, only:reduce_mpi,reduceall_mpi,reduceloc_mpi,bcast_mpi #ifdef GRAVITY use kernel, only:kernel_softening @@ -2492,7 +2492,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv use eos, only:gamma,ieos,iopacity_type use options, only:alpha,ipdv_heating,ishock_heating,psidecayfac,overcleanfac,hdivbbmax_max, & use_dustfrac,damp,icooling,implicit_radiation - use part, only:h2chemistry,rhoanddhdrho,iboundary,igas,maxphase,maxvxyzu,nptmass,xyzmh_ptmass, & + use part, only:rhoanddhdrho,iboundary,igas,maxphase,maxvxyzu,nptmass,xyzmh_ptmass, & massoftype,get_partinfo,tstop,strain_from_dvdx,ithick,iradP,sinks_have_heating,luminosity, & nucleation,idK2,idmu,idkappa,idgamma,dust_temp,pxyzu,ndustsmall use cooling, only:energ_cooling,cooling_in_step diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index 4e40ad475..a6078361e 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.f90 @@ -664,7 +664,7 @@ subroutine write_options_inject(iunit) use infile_utils, only: write_inopt integer, intent(in) :: iunit - if (sonic_type < 0) call set_default_options_inject + !if (sonic_type < 0) call set_default_options_inject call write_inopt(sonic_type,'sonic_type','find transonic solution (1=yes,0=no)',iunit) call write_inopt(wind_velocity_km_s,'wind_velocity','injection wind velocity (km/s, if sonic_type = 0)',iunit) !call write_inopt(pulsation_period_days,'pulsation_period','stellar pulsation period (days)',iunit) @@ -695,9 +695,13 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) integer, save :: ngot = 0 integer :: noptions - logical :: isowind = .true. + logical :: isowind = .true., init_opt = .false. character(len=30), parameter :: label = 'read_options_inject' + if (.not.init_opt) then + init_opt = .true. + call set_default_options_inject() + endif imatch = .true. igotall = .false. select case(trim(name)) diff --git a/src/main/part.F90 b/src/main/part.F90 index 9a95e47f5..a22fb6059 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -27,7 +27,7 @@ module part use dim, only:ndim,maxp,maxsts,ndivcurlv,ndivcurlB,maxvxyzu,maxalpha,& maxptmass,maxdvdx,nsinkproperties,mhd,maxmhd,maxBevol,& maxp_h2,maxindan,nabundances,periodic,ind_timesteps,& - maxgrav,ngradh,maxtypes,h2chemistry,gravity,maxp_dustfrac,& + maxgrav,ngradh,maxtypes,gravity,maxp_dustfrac,& use_dust,use_dustgrowth,lightcurve,maxlum,nalpha,maxmhdni, & maxp_growth,maxdusttypes,maxdustsmall,maxdustlarge, & maxphase,maxgradh,maxan,maxdustan,maxmhdan,maxneigh,maxprad,maxp_nucleation,& diff --git a/src/main/readwrite_dumps_common.F90 b/src/main/readwrite_dumps_common.F90 index c68246def..6bb8e6d8b 100644 --- a/src/main/readwrite_dumps_common.F90 +++ b/src/main/readwrite_dumps_common.F90 @@ -29,9 +29,9 @@ module readwrite_dumps_common !+ !-------------------------------------------------------------------- character(len=lenid) function fileident(firstchar,codestring) - use part, only:h2chemistry,mhd,npartoftype,idust,gravity,lightcurve + use part, only:mhd,npartoftype,idust,gravity,lightcurve use options, only:use_dustfrac - use dim, only:use_dustgrowth,phantom_version_string,use_krome,store_dust_temperature,do_nucleation + use dim, only:use_dustgrowth,phantom_version_string,use_krome,store_dust_temperature,do_nucleation,h2chemistry use gitinfo, only:gitsha character(len=2), intent(in) :: firstchar character(len=*), intent(in), optional :: codestring diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 10181a8e4..2d00153ff 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -204,14 +204,14 @@ end subroutine get_dump_size 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 + ind_timesteps,mhd_nonideal,use_krome,h2chemistry 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 use part, only:xyzh,xyzh_label,vxyzu,vxyzu_label,Bevol,Bevol_label,Bxyz,Bxyz_label,npart,maxtypes, & npartoftypetot,update_npartoftypetot, & alphaind,rhoh,divBsymm,maxphase,iphase,iamtype_int1,iamtype_int11, & nptmass,nsinkproperties,xyzmh_ptmass,xyzmh_ptmass_label,vxyz_ptmass,vxyz_ptmass_label,& - maxptmass,get_pmass,h2chemistry,nabundances,abundance,abundance_label,mhd,& + maxptmass,get_pmass,nabundances,abundance,abundance_label,mhd,& divcurlv,divcurlv_label,divcurlB,divcurlB_label,poten,dustfrac,deltav,deltav_label,tstop,& dustfrac_label,tstop_label,dustprop,dustprop_label,eos_vars,eos_vars_label,ndusttypes,ndustsmall,VrelVf,& VrelVf_label,dustgasprop,dustgasprop_label,dust_temp,pxyzu,pxyzu_label,dens,& !,dvdx,dvdx_label @@ -494,11 +494,11 @@ end subroutine write_fulldump_fortran !------------------------------------------------------------------- subroutine write_smalldump_fortran(t,dumpfile) - use dim, only:maxp,maxtypes,use_dust,lightcurve,use_dustgrowth + use dim, only:maxp,maxtypes,use_dust,lightcurve,use_dustgrowth,h2chemistry use io, only:idump,iprint,real4,id,master,error,warning,nprocs use part, only:xyzh,xyzh_label,npart,Bxyz,Bxyz_label,& npartoftypetot,update_npartoftypetot,& - maxphase,iphase,h2chemistry,nabundances,& + maxphase,iphase,nabundances,& nptmass,nsinkproperties,xyzmh_ptmass,xyzmh_ptmass_label,& abundance,abundance_label,mhd,dustfrac,iamtype_int11,& dustprop,dustprop_label,dustfrac_label,ndusttypes,& diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 79f98765a..c5378e43a 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -119,7 +119,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) 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 part, only:h2chemistry,maxp,mhd,maxalpha,nptmass + use part, only:maxp,mhd,maxalpha,nptmass use boundary_dyn, only:write_options_boundary character(len=*), intent(in) :: infile,logfile,evfile,dumpfile integer, intent(in) :: iwritein,iprint diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index c54602fd5..c2c828a36 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -1070,7 +1070,7 @@ end subroutine step_extern_sph !---------------------------------------------------------------- subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time,nptmass, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nbinmax,ibin_wake) - use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome,itau_alloc,do_nucleation + use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome,itau_alloc,do_nucleation,h2chemistry use io, only:iverbose,id,master,iprint,warning,fatal use externalforces, only:externalforce,accrete_particles,update_externalforce, & update_vdependent_extforce_leapfrog,is_velocity_dependent @@ -1080,7 +1080,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, idvxmsi,idvymsi,idvzmsi,idfxmsi,idfymsi,idfzmsi, & ndptmass,update_ptmass use options, only:iexternalforce,icooling - use part, only:maxphase,abundance,nabundances,h2chemistry,eos_vars,epot_sinksink,& + use part, only:maxphase,abundance,nabundances,eos_vars,epot_sinksink,& isdead_or_accreted,iamboundary,igas,iphase,iamtype,massoftype,rhoh,divcurlv, & fxyz_ptmass_sinksink,dust_temp,tau,nucleation,idK2,idmu,idkappa,idgamma use chem, only:update_abundances,get_dphot @@ -1205,7 +1205,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, !$omp shared(xyzmh_ptmass,vxyz_ptmass,idamp,damp_fac) & !$omp shared(nptmass,nsubsteps,C_force,divcurlv,dphotflag,dphot0) & !$omp shared(abundc,abundo,abundsi,abunde) & - !$omp shared(nucleation,do_nucleation) & + !$omp shared(nucleation,do_nucleation,h2chemistry) & #ifdef KROME !$omp shared(gamma_chem,mu_chem,dudt_chem) & #endif diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index b634f2a10..0e17564b7 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -75,13 +75,13 @@ 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 + use dim, only:maxp,maxvxyzu,maxalpha,ndivcurlv,mhd_nonideal,nalpha,use_dust,& + use_dustgrowth,gr,h2chemistry use io, only:iprint use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax use boundary_dyn, only:dynamic_bdy,rho_thresh_bdy,width_bkg use options, only:tolh,alpha,alphau,alphaB,ieos,alphamax,use_dustfrac - use part, only:hfact,massoftype,mhd,& - gravity,h2chemistry,periodic,massoftype,npartoftypetot,& + use part, only:hfact,massoftype,mhd,gravity,periodic,massoftype,npartoftypetot,& labeltype,maxtypes use mpiutils, only:reduceall_mpi use eos, only:eosinfo diff --git a/src/setup/setup_wind.f90 b/src/setup/setup_wind.f90 index 7c86957ce..86cdbef63 100644 --- a/src/setup/setup_wind.f90 +++ b/src/setup/setup_wind.f90 @@ -132,7 +132,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use part, only: xyzmh_ptmass, vxyz_ptmass, nptmass, igas, iTeff, iLum, iReff use physcon, only: au, solarm, mass_proton_cgs, kboltz, solarl use units, only: umass,set_units,unit_velocity,utime,unit_energ,udist - use inject, only: init_inject,set_default_options_inject + use inject, only: init_inject use setbinary, only: set_binary use sethierarchical, only: set_multiple use io, only: master @@ -168,7 +168,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif endif - call set_default_options_inject() ! !--space available for injected gas particles ! From 28db4e11769c4b1c7a84b3e1574a41a9977f5b75 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 27 Oct 2023 09:00:32 +0200 Subject: [PATCH 138/814] fix setting of maxp_h2 --- src/main/config.F90 | 1 + src/main/cooling.f90 | 3 +-- src/main/cooling_ism.f90 | 2 +- src/main/h2chem.f90 | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/config.F90 b/src/main/config.F90 index 78c2bc806..c915bc505 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -355,6 +355,7 @@ subroutine update_max_sizes(n,ntot) #ifdef KROME maxp_krome = maxp #endif + if (h2chemistry) maxp_h2 = maxp #ifdef SINK_RADIATION store_dust_temperature = .true. diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index a5a06554d..b2e42b862 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -204,7 +204,7 @@ end subroutine write_options_cooling !----------------------------------------------------------------------- subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) use io, only:fatal - use dim, only:maxp_h2,h2chemistry,maxp + use dim, only:h2chemistry use cooling_gammie, only:read_options_cooling_gammie use cooling_gammie_PL, only:read_options_cooling_gammie_PL use cooling_ism, only:read_options_cooling_ism @@ -241,7 +241,6 @@ subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) case(8) call read_options_cooling_ism(name,valstring,imatch,igotallism,ierr) h2chemistry = .true. - maxp_h2 = maxp case(3) call read_options_cooling_gammie(name,valstring,imatch,igotallgammie,ierr) case(7) diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index 4d163cf1d..368eba97b 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.f90 @@ -59,7 +59,7 @@ module cooling_ism ! Number of different quantities stored in cooling look-up table integer, parameter :: ncltab = 54 -! These varables are initialised in init_cooling_ism +! These variables are initialised in init_cooling_ism real :: temptab(nmd) real :: cltab(ncltab, nmd),dtcltab(ncltab, nmd) real :: dtlog, tmax, tmin diff --git a/src/main/h2chem.f90 b/src/main/h2chem.f90 index 4e9b11f9e..02aaa8f9a 100644 --- a/src/main/h2chem.f90 +++ b/src/main/h2chem.f90 @@ -294,7 +294,7 @@ subroutine evolve_abundances(ui,rhoi,chemarrays,nchem,dphot,dt) ! End of updating H2/CO ratio. Now to update HI/HII/e- ratio. !------------------------------------------------------------------------------------ !--If were not including H2, could set h2ratio to a small value (e.g. 1.e-7) and just -!--have this part to calculate heating and cooloing (need nh1 and np1 though). +!--have this part to calculate heating and cooling (need nh1 and np1 though). ! ! column density of HI excluding protons ! From d07e466b58a6b329e196980eccdad13a153da94e Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 27 Oct 2023 10:56:16 +0200 Subject: [PATCH 139/814] fix merge --- src/main/utils_raytracer.f90 | 4 ---- src/utils/analysis_raytracer.f90 | 32 ++------------------------------ 2 files changed, 2 insertions(+), 34 deletions(-) diff --git a/src/main/utils_raytracer.f90 b/src/main/utils_raytracer.f90 index 666a7e8e2..2f3eec04b 100644 --- a/src/main/utils_raytracer.f90 +++ b/src/main/utils_raytracer.f90 @@ -12,13 +12,9 @@ module raytracer ! - interpolate optical depths to all SPH particles ! Applicable both for single and binary star wind simulations ! -<<<<<<< HEAD -! :References: None -======= ! WARNING: This module has only been tested on phantom wind setup ! ! :References: Esseldeurs M., Siess L. et al, 2023, A&A, 674, A122 ->>>>>>> 1788ae4727111d338799b7ac860734cdc905eafb ! ! :Owner: Mats Esseldeurs ! diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index 25fa8b681..328a65284 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.f90 @@ -8,7 +8,7 @@ module analysis ! ! Analysis routine which computes optical depths throughout the simulation ! -! :References: Esseldeurs M., Siess L. et al, 2023, A&A, 674, A122 +! :References: Esseldeurs M., Siess L. et al, 2023, A&A, 674, A122 ! ! :Owner: Mats Esseldeurs ! @@ -22,11 +22,7 @@ module analysis use part, only:rhoh,isdead_or_accreted,nsinkproperties,iReff use dump_utils, only:read_array_from_file use getneighbours, only:generate_neighbour_lists, read_neighbours, write_neighbours, & -<<<<<<< HEAD neighcount,neighb,neighmax -======= - neighcount,neighb,neighmax ->>>>>>> 1788ae4727111d338799b7ac860734cdc905eafb use dust_formation, only:calc_kappa_bowen use physcon, only:kboltz,mass_proton_cgs,au,solarm use linklist, only:set_linklist,allocate_linklist,deallocate_linklist @@ -55,11 +51,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) character(100) :: neighbourfile character(100) :: jstring, kstring real :: primsec(4,2), rho(npart), kappa(npart), temp(npart), u(npart), & -<<<<<<< HEAD xyzh2(4,npart), vxyzu2(4,npart), xyzmh_ptmass(nsinkproperties,2) -======= - xyzh2(4,npart), vxyzu2(4,npart), xyzmh_ptmass(nsinkproperties,2) ->>>>>>> 1788ae4727111d338799b7ac860734cdc905eafb real, dimension(:), allocatable :: tau integer :: i,j,k,ierr,iu1,iu2,iu3,iu4, npart2!,iu integer :: start, finish, method, analyses, minOrder, maxOrder, order, raypolation, refineScheme @@ -408,11 +400,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) close(iu4) totalTime = totalTime + timeTau open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & -<<<<<<< HEAD status='replace', action='write') -======= - status='replace', action='write') ->>>>>>> 1788ae4727111d338799b7ac860734cdc905eafb do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -447,11 +435,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) times(k+1) = timeTau totalTime = totalTime + timeTau open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & -<<<<<<< HEAD status='replace', action='write') -======= - status='replace', action='write') ->>>>>>> 1788ae4727111d338799b7ac860734cdc905eafb do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -484,11 +468,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) else call system_clock(start) call get_all_tau_adaptive(npart2, primsec(1:3,1), xyzh2, kappa, Rstar, j, k, refineScheme,& -<<<<<<< HEAD - tau, primsec(1:3,2), Rcomp) -======= - tau, primsec(1:3,2), Rcomp) ->>>>>>> 1788ae4727111d338799b7ac860734cdc905eafb + tau, primsec(1:3,2), Rcomp) call system_clock(finish) endif timeTau = (finish-start)/1000. @@ -496,11 +476,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) times(k-minOrder+1) = timeTau totalTime = totalTime + timeTau open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & -<<<<<<< HEAD '_'//trim(kstring)//'.txt', status='replace', action='write') -======= - '_'//trim(kstring)//'.txt', status='replace', action='write') ->>>>>>> 1788ae4727111d338799b7ac860734cdc905eafb do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -648,11 +624,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) print*,'Time = ',timeTau,' seconds.' totalTime = totalTime + timeTau open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & -<<<<<<< HEAD '_'//trim(kstring)//'.txt', status='replace', action='write') -======= - '_'//trim(kstring)//'.txt', status='replace', action='write') ->>>>>>> 1788ae4727111d338799b7ac860734cdc905eafb do i=1, size(tau) write(iu2, *) tau(i) enddo From 87c53cc1a754eea56c95cbedf897877411d28c49 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Mon, 30 Oct 2023 11:40:27 +1100 Subject: [PATCH 140/814] Implemented requested for pull request --- build/Makefile_setups | 3 ++ src/main/initial.F90 | 13 ------- src/main/readwrite_dumps_fortran.F90 | 12 ++---- src/main/step_leapfrog.F90 | 2 +- src/main/utils_gr.F90 | 5 +-- src/setup/setup_flrw.f90 | 35 ++--------------- src/setup/setup_flrwpspec.f90 | 56 ++++++++-------------------- src/setup/stretchmap.f90 | 4 +- src/utils/einsteintk_utils.f90 | 39 ------------------- 9 files changed, 28 insertions(+), 141 deletions(-) diff --git a/build/Makefile_setups b/build/Makefile_setups index 6dc3f1b02..7d41d92be 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -1015,6 +1015,7 @@ ifeq ($(SETUP), testgr) endif ifeq ($(SETUP), flrw) +# constant density FLRW cosmology with perturbations GR=yes KNOWN_SETUP=yes IND_TIMESTEPS=no @@ -1022,7 +1023,9 @@ ifeq ($(SETUP), flrw) SETUPFILE= setup_flrw.f90 PERIODIC=yes endif + ifeq ($(SETUP), flrwpspec) +# FLRW universe using a CMB powerspectrum and the Zeldovich approximation GR=yes KNOWN_SETUP=yes IND_TIMESTEPS=no diff --git a/src/main/initial.F90 b/src/main/initial.F90 index a7c46410b..3784e7431 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -424,26 +424,13 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) endif #ifndef PRIM2CONS_FIRST - !print*, "Before init metric!" call init_metric(npart,xyzh,metrics,metricderivs) - !print*, "metric val is: ", metrics(:,:,:,1) - !print*, "Before prims2consall" - !print*, "Density value before prims2cons: ", dens(1) call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) - !print*, "Density value after prims2cons: ", dens(1) - !print*, "internal energy is: ", vxyzu(4,1) - !print*, "initial entropy is : ", pxyzu(4,1) #endif if (iexternalforce > 0 .and. imetric /= imet_minkowski) then call initialise_externalforces(iexternalforce,ierr) if (ierr /= 0) call fatal('initial','error in external force settings/initialisation') - !print*, "Before get_grforce_all" call get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtextforce) - !print*, "Before get_tmunu_all" - !call get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - !call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - !print*, "get_tmunu_all finished!" - !call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac=.true.) endif #else if (iexternalforce > 0) then diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 7e34a9e6e..cbe7212ad 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -218,9 +218,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) 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 -#ifdef GR - use part, only:metrics,metricderivs,tmunus -#endif + use part, only:metrics,metricderivs,tmunus use options, only:use_dustfrac,use_var_comp,icooling use dump_utils, only:tag,open_dumpfile_w,allocate_header,& free_header,write_header,write_array,write_block_header @@ -230,9 +228,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) #ifdef PRDRAG use lumin_nsdisc, only:beta #endif -#ifdef GR use metric_tools, only:imetric, imet_et -#endif real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer, intent(in), optional :: iorder(:) @@ -369,8 +365,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) endif if (gr) then call write_array(1,pxyzu,pxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,dens,'dens prim',npart,k,ipass,idump,nums,ierrs(8)) -#ifdef GR + call write_array(1,dens,'dens prim',npart,k,ipass,idump,nums,ierrs(8)) if (imetric==imet_et) then ! Output metric if imetric=iet call write_array(1,metrics(1,1,1,:), 'gtt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) @@ -389,7 +384,6 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) call write_array(1,tmunus(1,1,:), 'tmunutt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) endif -#endif endif if (eos_is_non_ideal(ieos) .or. (.not.store_dust_temperature .and. icooling > 0)) then call write_array(1,eos_vars(itemp,:),eos_vars_label(itemp),npart,k,ipass,idump,nums,ierrs(12)) @@ -411,7 +405,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) 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=8,index=4) + call write_array(1,xyzh,xyzh_label,1,npart,k,ipass,idump,nums,ierrs(14),use_kind=4,index=4) if (maxalpha==maxp) call write_array(1,alphaind,(/'alpha'/),1,npart,k,ipass,idump,nums,ierrs(15)) !if (maxalpha==maxp) then ! (uncomment this to write alphaloc to the full dumps) ! call write_array(1,alphaind,(/'alpha ','alphaloc'/),2,npart,k,ipass,idump,nums,ierrs(10)) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 97007d555..172ff8340 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -794,7 +794,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me ! if (dtextforce < dtsph) then dt = dtextforce - last_step = .true. ! Just to check if things are working + last_step = .false. else dt = dtsph last_step = .true. diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index c3cbcfdeb..550b340ec 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.F90 @@ -116,8 +116,7 @@ subroutine rho2dens(dens,rho,position,metrici,v) integer :: ierror real :: gcov(0:3,0:3), sqrtg, U0 - ! Hard coded sqrtg=1 since phantom is always in cartesian coordinates - !sqrtg = 1. + call unpack_metric(metrici,gcov=gcov) call get_sqrtg(gcov, sqrtg) call get_u0(gcov,v,U0,ierror) @@ -197,8 +196,6 @@ subroutine get_sqrtg(gcov, sqrtg) a13*a21*a32*a44 - a11*a23*a32*a44 - a12*a21*a33*a44 + a11*a22*a33*a44 sqrtg = sqrt(-det) - !print*, "sqrtg: ", sqrtg - !stop else ! If we are not using an evolving metric then ! Sqrtg = 1 diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index ffc8b98d2..7cdc8c868 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -6,17 +6,16 @@ !--------------------------------------------------------------------------! module setup ! -! Setup routine for uniform distribution +! Setup routine for a constant density + petrubtations FLRW universe +! as described in Magnall et al. 2023 ! ! :References: None ! ! :Owner: Spencer Magnall ! ! :Runtime parameters: -! - Bzero : *magnetic field strength in code units* ! - cs0 : *initial sound speed in code units* ! - dist_unit : *distance unit (e.g. au)* -! - dust_to_gas : *dust-to-gas ratio* ! - ilattice : *lattice type (1=cubic, 2=closepacked)* ! - mass_unit : *mass unit (e.g. solarm)* ! - nx : *number of particles in x direction* @@ -27,26 +26,19 @@ module setup ! options, part, physcon, prompting, setup_params, stretchmap, unifdis, ! units, utils_gr ! - use dim, only:use_dust,mhd - use options, only:use_dustfrac + use dim, only:use_dust use setup_params, only:rhozero use physcon, only:radconst implicit none public :: setpart integer :: npartx,ilattice - real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,Bzero,ampl,phaseoffset + real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,ampl,phaseoffset character(len=20) :: dist_unit,mass_unit,perturb_direction,perturb,radiation_dominated real :: perturb_wavelength real :: rho_matter real(kind=8) :: udist,umass - !--change default defaults to reproduce the test from Section 5.6.7 of Price+(2018) - logical :: BalsaraKim = .false. - - !--dust - real :: dust_to_gas - private contains @@ -481,19 +473,6 @@ subroutine setup_interactive(id,polyk) endif call bcast_mpi(cs0) ! - ! dust to gas ratio - ! - if (use_dustfrac) then - call prompt('Enter dust to gas ratio',dust_to_gas,0.) - call bcast_mpi(dust_to_gas) - endif - ! - ! magnetic field strength - if (mhd .and. balsarakim) then - call prompt('Enter magnetic field strength in code units ',Bzero,0.) - call bcast_mpi(Bzero) - endif - ! ! type of lattice ! if (id==master) then @@ -545,12 +524,6 @@ subroutine write_setupfile(filename) call write_inopt(perturb_direction, 'FLRWSolver::FLRW_perturb_direction','Pertubation direction',iunit) call write_inopt(radiation_dominated, 'radiation_dominated','Radiation dominated universe (yes/no)',iunit) call write_inopt(perturb_wavelength,'FLRWSolver::single_perturb_wavelength','Perturbation wavelength',iunit) - if (use_dustfrac) then - call write_inopt(dust_to_gas,'dust_to_gas','dust-to-gas ratio',iunit) - endif - if (mhd .and. balsarakim) then - call write_inopt(Bzero,'Bzero','magnetic field strength in code units',iunit) - endif call write_inopt(ilattice,'ilattice','lattice type (1=cubic, 2=closepacked)',iunit) close(iunit) diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index b3290245f..eef12efc8 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -6,17 +6,17 @@ !--------------------------------------------------------------------------! module setup ! -! Setup routine for uniform distribution +! Setup routine for realistic cosmological initial conditions based +! on the Zeldovich approximation. +! Requries velocity files generated from a powerspectrum. ! ! :References: None ! ! :Owner: Spencer Magnall ! ! :Runtime parameters: -! - Bzero : *magnetic field strength in code units* ! - cs0 : *initial sound speed in code units* ! - dist_unit : *distance unit (e.g. au)* -! - dust_to_gas : *dust-to-gas ratio* ! - ilattice : *lattice type (1=cubic, 2=closepacked)* ! - mass_unit : *mass unit (e.g. solarm)* ! - nx : *number of particles in x direction* @@ -25,27 +25,20 @@ module setup ! ! :Dependencies: boundary, dim, eos_shen, infile_utils, io, mpidomain, ! mpiutils, options, part, physcon, prompting, setup_params, stretchmap, -! unifdis, units, utils_gr +! unifdis, units, utils_gr ! - use dim, only:use_dust,mhd - use options, only:use_dustfrac + use dim, only:use_dust use setup_params, only:rhozero use physcon, only:radconst implicit none public :: setpart integer :: npartx,ilattice - real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,Bzero,ampl,phaseoffset + real :: cs0,xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,ampl,phaseoffset character(len=20) :: dist_unit,mass_unit,perturb_direction,perturb,radiation_dominated real :: perturb_wavelength real(kind=8) :: udist,umass - !--change default defaults to reproduce the test from Section 5.6.7 of Price+(2018) - logical :: BalsaraKim = .false. - - !--dust - real :: dust_to_gas - private contains @@ -366,19 +359,7 @@ subroutine setup_interactive(id,polyk) call prompt(' enter sound speed in code units (sets polyk)',cs0,0.) endif call bcast_mpi(cs0) - ! - ! dust to gas ratio - ! - if (use_dustfrac) then - call prompt('Enter dust to gas ratio',dust_to_gas,0.) - call bcast_mpi(dust_to_gas) - endif - ! - ! magnetic field strength - if (mhd .and. balsarakim) then - call prompt('Enter magnetic field strength in code units ',Bzero,0.) - call bcast_mpi(Bzero) - endif + ! ! type of lattice ! @@ -431,12 +412,6 @@ subroutine write_setupfile(filename) call write_inopt(perturb_direction, 'FLRWSolver::FLRW_perturb_direction','Pertubation direction',iunit) call write_inopt(radiation_dominated, 'radiation_dominated','Radiation dominated universe (yes/no)',iunit) call write_inopt(perturb_wavelength,'FLRWSolver::single_perturb_wavelength','Perturbation wavelength',iunit) - if (use_dustfrac) then - call write_inopt(dust_to_gas,'dust_to_gas','dust-to-gas ratio',iunit) - endif - if (mhd .and. balsarakim) then - call write_inopt(Bzero,'Bzero','magnetic field strength in code units',iunit) - endif call write_inopt(ilattice,'ilattice','lattice type (1=cubic, 2=closepacked)',iunit) close(iunit) @@ -515,19 +490,18 @@ subroutine read_setupfile(filename,ierr) end subroutine read_setupfile subroutine read_veldata(velarray,vfile,gridsize) - ! TODO ERROR HANDLING?? integer, intent(in) :: gridsize character(len=20),intent(in) :: vfile real,intent(out) :: velarray(:,:,:) - integer :: i,j,k + integer :: i,j,k,iu - open(unit=444,file=vfile,status='old') + open(newunit=iu,file=vfile,status='old') do k=1,gridsize do j=1,gridsize - read(444,*) (velarray(i,j,k), i=1, gridsize) + read(iu,*) (velarray(i,j,k), i=1, gridsize) enddo enddo - close(444) + close(iu) print*, "Finished reading ", vfile end subroutine read_veldata @@ -618,12 +592,12 @@ subroutine get_grid_neighbours(position,gridorigin,dx,xlower,ylower,zlower) end subroutine get_grid_neighbours logical function check_files(file1,file2,file3) - character(len=40), intent(in) :: file1,file2,file3 + character(len=*), intent(in) :: file1,file2,file3 logical :: file1_exist, file2_exist, file3_exist - INQUIRE(file=file1,exist=file1_exist) - INQUIRE(file=file2,exist=file2_exist) - INQUIRE(file=file3,exist=file3_exist) + inquire(file=file1,exist=file1_exist) + inquire(file=file2,exist=file2_exist) + inquire(file=file3,exist=file3_exist) if ((.not. file1_exist) .or. (.not. file2_exist) .or. (.not. file3_exist)) then check_files = .false. diff --git a/src/setup/stretchmap.f90 b/src/setup/stretchmap.f90 index aff9664fd..733c14497 100644 --- a/src/setup/stretchmap.f90 +++ b/src/setup/stretchmap.f90 @@ -118,7 +118,7 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,massfunc,rhotab,xtab,star if (present(verbose)) isverbose = verbose if (present(rhotab)) use_rhotab = .true. if (present(massfunc)) use_massfunc = .true. - print*,"Use mass func?: ", use_massfunc + if (use_massfunc) print "(a)", 'Using massfunc rather than numerically-integrated table' if (present(rhofunc) .or. present(rhotab)) then if (isverbose) print "(a)",' >>>>>> s t r e t c h m a p p i n g <<<<<<' ! @@ -327,8 +327,6 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,massfunc,rhotab,xtab,star xyzh(2,i) = x(2) xyzh(3,i) = x(3) xyzh(4,i) = hi*(rhozero/rhoi)**(1./3.) - !print*, "Rho value for particle is: ", rhoi - !print*, "Smoothing length for particle is: ", xyzh(4,i) if (its >= maxits) nerr = nerr + 1 endif enddo diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index 7c28cf89c..880ac3096 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -60,7 +60,6 @@ subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) allocate(rhostargrid(nx,ny,nz)) - ! TODO Toggle for this to save memory allocate(entropygrid(nx,ny,nz)) ! metric derivs are stored in the form @@ -94,13 +93,6 @@ subroutine get_particle_rhs(i,vx,vy,vz,fx,fy,fz,e_rhs) vy = vxyzu(2,i) vz = vxyzu(3,i) - ! dp/dt - !print*, "fext: ", fext(:,i) - !print*, "fxyzu: ", fxyzu(:,i) - !fx = fxyzu(1,i) + fext(1,i) - !print*, "fx: ", fx - !fy = fxyzu(2,i) + fext(2,i) - !fz = fxyzu(3,i) + fext(3,i) fx = fext(1,i) fy = fext(2,i) fz = fext(3,i) @@ -177,35 +169,4 @@ subroutine set_rendering(flag) end subroutine set_rendering - ! Do I move this to tmunu2grid?? - ! I think yes - - - ! Moved to einsteintk_wrapper.f90 to fix dependency issues - - ! subroutine get_metricderivs_all(dtextforce_min) - ! use part, only:npart, xyzh,vxyzu,metrics,metricderivs,dens,fext - ! use timestep, only:bignumber,C_force - ! use extern_gr, only:get_grforce - ! use metric_tools, only:pack_metricderivs - ! real, intent(out) :: dtextforce_min - ! integer :: i - ! real :: pri,dtf - - ! pri = 0. - ! dtextforce_min = bignumber - - ! !$omp parallel do default(none) & - ! !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & - ! !$omp firstprivate(pri) & - ! !$omp private(i,dtf) & - ! !$omp reduction(min:dtextforce_min) - ! do i=1, npart - ! call pack_metricderivs(xyzh(1:3,i),metricderivs(:,:,:,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) - ! dtextforce_min = min(dtextforce_min,C_force*dtf) - ! enddo - ! !$omp end parallel do - ! end subroutine get_metricderivs_all end module einsteintk_utils From dd1ead43ab997a6b70ae44878dd6fcfc85925c60 Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 1 Nov 2023 15:44:39 +1100 Subject: [PATCH 141/814] (Makefile) compile injection sources after readwrite dumps --- build/Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/build/Makefile b/build/Makefile index 6da744192..9494e279a 100644 --- a/build/Makefile +++ b/build/Makefile @@ -539,8 +539,8 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ mpi_memory.f90 mpi_derivs.F90 mpi_tree.F90 kdtree.F90 linklist_kdtree.F90 utils_healpix.f90 utils_raytracer.f90 \ partinject.F90 utils_inject.f90 dust_formation.f90 ptmass_radiation.f90 ptmass_heating.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ - ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ - ${SRCKROME} memory.F90 ${SRCREADWRITE_DUMPS} \ + ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 \ + ${SRCKROME} memory.F90 ${SRCREADWRITE_DUMPS} ${SRCINJECT} \ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ From bd6994ab108c89129424d67d9e9de366d95eaedd Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 1 Nov 2023 15:45:22 +1100 Subject: [PATCH 142/814] (Makefile_setups) injection file for radiotde --- build/Makefile_setups | 1 + 1 file changed, 1 insertion(+) diff --git a/build/Makefile_setups b/build/Makefile_setups index 7d0c65beb..c9f4ecba8 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -186,6 +186,7 @@ ifeq ($(SETUP), radiotde) IND_TIMESTEPS=no ANALYSIS=analysis_radiotde.f90 MODFILE=moddump_radiotde.f90 + SRCINJECT=inject_sim.f90 SYSTEM=gfortran endif From bd54bbdf09ce640c3a9fd33195cd5c8949d04e7d Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 1 Nov 2023 15:47:27 +1100 Subject: [PATCH 143/814] (inject_sim) inject particles from other simulations (for tde outflow only right now but could be extended to a general tool) --- src/main/inject_sim.f90 | 273 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 273 insertions(+) create mode 100644 src/main/inject_sim.f90 diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 new file mode 100644 index 000000000..dac625bb7 --- /dev/null +++ b/src/main/inject_sim.f90 @@ -0,0 +1,273 @@ +!--------------------------------------------------------------------------! +! 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 inject +! +! Handles TDE outflow particle injection +! +! :References: None +! +! :Owner: Fitz Hu +! +! :Runtime parameters: +! - iboundary_spheres : *number of boundary spheres (integer)* +! - iwind_resolution : *if<>0 set number of particles on the sphere, reset particle mass* +! - nfill_domain : *number of spheres used to set the background density profile* +! - outer_boundary : *delete gas particles outside this radius (au)* +! - sonic_type : *find transonic solution (1=yes,0=no)* +! - wind_inject_radius : *wind injection radius (au, if 0 takes Rstar)* +! - wind_mass_rate : *wind mass loss rate (Msun/yr)* +! - wind_shell_spacing : *desired ratio of sphere spacing to particle spacing* +! - wind_temperature : *wind temperature at injection radius (K, if 0 takes Teff)* +! - wind_velocity : *injection wind velocity (km/s, if sonic_type = 0)* +! +! :Dependencies: cooling_molecular, dim, dust_formation, eos, icosahedron, +! infile_utils, injectutils, io, options, part, partinject, physcon, +! ptmass_radiation, setbinary, timestep, units, wind, wind_equations +! + use fileutils, only:getnextfilename + + implicit none + character(len=*), parameter, public :: inject_type = 'sim' + + public :: init_inject,inject_particles,write_options_inject,read_options_inject + private +! +!--runtime settings for this module +! + +! global variables + + character(len=120) :: start_dump,pre_dump,next_dump + integer :: npart_sim + real :: r_inject,next_time + real, allocatable :: xyzh_pre(:,:),xyzh_next(:,:),vxyzu_next(:,:) + + character(len=*), parameter :: label = 'inject_tdeoutflow' + +contains + +!----------------------------------------------------------------------- +!+ +! Initialize -- find the start dump to inject +!+ +!----------------------------------------------------------------------- +subroutine init_inject(ierr) + use io, only:error + use timestep, only:time + use fileutils, only:getnextfilename + + integer, intent(out) :: ierr + integer, parameter :: max_niter=5000, idisk=23 + integer :: niter + + ! + !--find the tde dump at the right time + ! + next_dump = start_dump + call get_dump_time_npart(trim(next_dump),next_time,ierr,npart_out=npart_sim) + ierr = 0 + niter = 0 + + do while (next_time < time .and. niter < max_niter) + call get_dump_time_npart(trim(next_dump),next_time,ierr) + next_dump = getnextfilename(pre_dump) + if (ierr /= 0) then + ierr = 0 + call error('inject','error reading time and npart from '//trim(next_dump)) + cycle + endif + niter = niter + 1 + enddo + + write(*,'(a,1x,es10.2)') ' Start read sims and inject particle from '//trim(next_dump)//' at t =',next_time + allocate(xyzh_pre(4,npart_sim),xyzh_next(4,npart_sim),vxyzu_next(4,npart_sim)) + xyzh_pre = 0. + +end subroutine init_inject + +!----------------------------------------------------------------------- +!+ +! Main routine handling wind injection. +!+ +!----------------------------------------------------------------------- +subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + npart,npartoftype,dtinject) + real, intent(in) :: time, dtlast + real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) + integer, intent(inout) :: npart + integer, intent(inout) :: npartoftype(:) + real, intent(out) :: dtinject + integer :: ierr + + ! + !--inject particles only if time has reached + ! + if (time >= next_time) then + ! read next dump + next_dump = getnextfilename(pre_dump) + call read_dump(next_dump,xyzh_next,ierr,vxyzu_dump=vxyzu_next) + + call inject_required_part(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next) + + ! copy to pre for next injection use + pre_dump = next_dump + xyzh_pre = xyzh_next + + call find_next_dump(next_dump,next_time,ierr) + endif + + ! update time to next inject + dtinject = next_time - time +end subroutine inject_particles + + subroutine read_dump(filename,xyzh_dump,ierr,vxyzu_dump) + use dump_utils, only: read_array_from_file + character(len=*), intent(in) :: filename + real, intent(out) :: xyzh_dump(:,:) + integer, intent(out) :: ierr + real, intent(out), optional :: vxyzu_dump(:,:) + integer, parameter :: iunit = 578 + + ! + !--read xyzh + ! + call read_array_from_file(iunit,filename,'x',xyzh_dump(1,:),ierr) + call read_array_from_file(iunit,filename,'y',xyzh_dump(2,:),ierr) + call read_array_from_file(iunit,filename,'z',xyzh_dump(3,:),ierr) + call read_array_from_file(iunit,filename,'h',xyzh_dump(4,:),ierr) + + ! + !--read vxyzu + ! + if (present(vxyzu_dump)) then + call read_array_from_file(iunit,filename,'vx',vxyzu_dump(1,:),ierr) + call read_array_from_file(iunit,filename,'vy',vxyzu_dump(2,:),ierr) + call read_array_from_file(iunit,filename,'vz',vxyzu_dump(3,:),ierr) + call read_array_from_file(iunit,filename,'u',vxyzu_dump(4,:),ierr) + endif + + end subroutine read_dump + + subroutine get_dump_time_npart(filename,time,ierr,npart_out) + use io, only:iprint,id,nprocs + use dump_utils, only:dump_h,open_dumpfile_r,read_header,free_header + use part, only:maxtypes + use readwrite_dumps_fortran, only:unfill_header + use readwrite_dumps_common, only:get_options_from_fileid + + character(len=*), intent(in) :: filename + real, intent(out) :: time + integer, intent(out) :: ierr + integer, intent(out), optional :: npart_out + integer, parameter :: idisk=389 + character(len=120) :: fileid + logical :: tagged,phantomdump,smalldump,use_dustfrac + type(dump_h) :: hdr + integer(kind=8) :: nparttot + integer :: nblocks,npartoftype(maxtypes),npart + real :: hfactfile,alphafile + + call open_dumpfile_r(idisk,filename,fileid,ierr) + call get_options_from_fileid(fileid,tagged,phantomdump,smalldump,use_dustfrac,ierr) + call read_header(idisk,hdr,ierr,tagged=tagged) + call unfill_header(hdr,phantomdump,tagged,nparttot, & + nblocks,npart,npartoftype, & + time,hfactfile,alphafile,iprint,id,nprocs,ierr) + call free_header(hdr,ierr) + close(idisk) + + if (present(npart_out)) npart_out = npart + + end subroutine get_dump_time_npart + + subroutine find_next_dump(next_dump,next_time,ierr) + character(len=*), intent(inout) :: next_dump + real, intent(out) :: next_time + integer, intent(out) :: ierr + + next_dump = getnextfilename(next_dump) + call get_dump_time_npart(next_dump,next_time,ierr) + + end subroutine find_next_dump + + subroutine inject_required_part(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next) + use part, only:igas + use partinject, only:add_or_update_particle + integer, intent(inout) :: npart, npartoftype(:) + real, intent(inout) :: xyzh(:,:), vxyzu(:,:) + real, intent(in) :: xyzh_pre(:,:), xyzh_next(:,:), vxyzu_next(:,:) + integer :: i,partid + real :: r_next,r_pre,vr_next + + ! + !--check all the particles + ! + do i=1,npart_sim + r_next = sqrt(dot_product(xyzh_next(1:3,i),xyzh_next(1:3,i))) + r_pre = sqrt(dot_product(xyzh_pre(1:3,i),xyzh_pre(1:3,i))) + vr_next = (dot_product(xyzh_next(1:3,i),vxyzu_next(1:3,i)))/r_next + + if (r_next > r_inject .and. r_pre < r_inject .and. vr_next > 0.) then + ! inject particle by copy the data into position + partid = npart+1 + call add_or_update_particle(igas,xyzh_next(1:3,i),vxyzu_next(1:3,i),xyzh_next(4,i), & + vxyzu(4,i),partid,npart,npartoftype,xyzh,vxyzu) + endif + enddo + + end subroutine inject_required_part + + +!----------------------------------------------------------------------- +!+ +! Writes input options to the input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_inject(iunit) + use infile_utils, only: write_inopt + integer, intent(in) :: iunit + + write(iunit,"(/,a)") '# options controlling particle injection' + !call write_inopt(direc,'direc','directory of the tde dumpfiles',iunit) + call write_inopt(start_dump,'start_dump','prefix of the tde dumpfiles',iunit) + call write_inopt(r_inject,'r_inject','radius to inject tde outflow',iunit) + +end subroutine write_options_inject + +!----------------------------------------------------------------------- +!+ +! Reads input options from the input file. +!+ +!----------------------------------------------------------------------- +subroutine read_options_inject(name,valstring,imatch,igotall,ierr) + use io, only:fatal + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer,intent(out) :: ierr + character(len=30), parameter :: label = 'read_options_inject' + integer, save :: ngot + + imatch = .true. + igotall = .false. + select case(trim(name)) + !case('direc') +! read(valstring,*,iostat=ierr) direc +! ngot = ngot + 1 + case('start_dump') + read(valstring,*,iostat=ierr) start_dump + ngot = ngot + 1 + case('r_inject') + read(valstring,*,iostat=ierr) r_inject + ngot = ngot + 1 + if (r_inject < 0.) call fatal(label,'invalid setting for r_inject (<0)') + end select + + igotall = (ngot >= 2) + +end subroutine read_options_inject + +end module inject From 42185aa5d5846f4c4b163dfbf3cb26704bc58b71 Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 1 Nov 2023 15:48:16 +1100 Subject: [PATCH 144/814] (readwrite_dumps_fortran) make unfill_header public which is used in inject_sim --- 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 10181a8e4..e3f9387c1 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -28,7 +28,7 @@ module readwrite_dumps_fortran use readwrite_dumps_common, only:check_arrays,fileident,get_options_from_fileid implicit none - public :: write_smalldump_fortran,write_fulldump_fortran,read_smalldump_fortran,read_dump_fortran + public :: write_smalldump_fortran,write_fulldump_fortran,read_smalldump_fortran,read_dump_fortran,unfill_header logical, target, public :: opened_full_dump_fortran ! for use in analysis files if user wishes to skip small dumps logical, target, public :: dt_read_in_fortran ! to determine if dt has been read in so that ibin & ibinold can be set on restarts From 807b8dfe5f227f3994841077fbe2e018fd4db2aa Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 1 Nov 2023 16:17:18 +1100 Subject: [PATCH 145/814] (moddump_radiotde) add option to ignore all tde particles for later injection --- src/utils/moddump_radiotde.f90 | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index d854923a5..9edc5a3de 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -47,7 +47,8 @@ module moddump subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) use physcon, only:solarm,years,mass_proton_cgs use setup_params, only:npart_total - use part, only:igas,set_particle_type,delete_particles_inside_radius,delete_particles_outside_sphere + use part, only:igas,set_particle_type,delete_particles_inside_radius, & + delete_particles_outside_sphere,kill_particle,shuffle_part use io, only:fatal,master,id use units, only:umass,udist,utime,set_units,unit_density use timestep, only:dtmax,tmax @@ -174,14 +175,22 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) endif !--remove unwanted particles - npart_old = npart - call delete_particles_inside_radius((/0.,0.,0./),ignore_radius,npart,npartoftype) - write(*,'(I10,1X,A23,1X,E8.2,1X,A14)') npart_old - npart, 'particles inside radius', ignore_radius*udist, 'cm are deleted' - npart_old = npart - if (remove_overlap) then - call delete_particles_outside_sphere((/0.,0.,0./),rad_min,npart) - write(*,'(I10,1X,A24,1X,E8.2,1X,A14)') npart_old - npart, 'particles outside radius', rad_min*udist, 'cm are deleted' + if (ignore_radius > 0) then npart_old = npart + call delete_particles_inside_radius((/0.,0.,0./),ignore_radius,npart,npartoftype) + write(*,'(I10,1X,A23,1X,E8.2,1X,A14)') npart_old - npart, 'particles inside radius', ignore_radius*udist, 'cm are deleted' + npart_old = npart + if (remove_overlap) then + call delete_particles_outside_sphere((/0.,0.,0./),rad_min,npart) + write(*,'(I10,1X,A24,1X,E8.2,1X,A14)') npart_old - npart, 'particles outside radius', rad_min*udist, 'cm are deleted' + npart_old = npart + endif + else + write(*,'(a)') ' Ignore all TDE particles' + do i = 1,npart + call kill_particle(i,npartoftype) + enddo + call shuffle_part(npart) endif !--setup cloud @@ -316,7 +325,7 @@ subroutine write_setupfile(filename) write(iunit,"(a)") '# input file for setting up a circumnuclear gas cloud' write(iunit,"(/,a)") '# geometry' - call write_inopt(ignore_radius,'ignore_radius','tde particle inside this radius will be ignored',iunit) + call write_inopt(ignore_radius,'ignore_radius','tde particle inside this radius will be ignored (-ve = ignore tde particles for later injection)',iunit) call write_inopt(remove_overlap,'remove_overlap','remove outflow particles overlap with circum particles',iunit) call write_inopt(use_func,'use_func','if use broken power law for density profile',iunit) if (use_func) then From 13eb954b082c34b02101ed9973f873685cb93075 Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 25 Oct 2023 15:08:41 +1100 Subject: [PATCH 146/814] (moddump_radiotde) take mass and solve for inner density --- src/utils/moddump_radiotde.f90 | 55 ++++++++++++++++++++++++++++++---- 1 file changed, 50 insertions(+), 5 deletions(-) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 9edc5a3de..87e3b015a 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -24,7 +24,7 @@ module moddump ! implicit none public :: modify_dump - private :: rho,rho_tab,get_temp_r,uerg,calc_rhobreak,write_setupfile,read_setupfile + private :: rho,rho_tab,get_temp_r,uerg,calc_rhobreak,calc_rho0,write_setupfile,read_setupfile private integer :: ieos_in,nprof,nbreak,nbreak_old @@ -34,7 +34,7 @@ module moddump real, allocatable :: rhof_n(:),rhof_rbreak(:),rhof_rhobreak(:) real, allocatable :: rhof_n_in(:),rhof_rbreak_in(:) real, allocatable :: rad_prof(:),dens_prof(:) - real :: rhof_rho0 + real :: rhof_rho0,m_target,m_threshold logical :: use_func,use_func_old,remove_overlap contains @@ -96,6 +96,8 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) allocate(rhof_n(nbreak),rhof_rbreak(nbreak)) rhof_n = -1.7 rhof_rbreak = rad_min + m_target = dot_product(npartoftype,massoftype)*umass/solarm + m_threshold = 1.e-3 !--Profile default setups read_temp = .false. profile_filename = default_name @@ -131,7 +133,6 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) allocate(rhof_n(nbreak),rhof_rbreak(nbreak),rhof_rhobreak(nbreak)) rhof_n(:) = rhof_n_in(1:nbreak) rhof_rbreak(:) = rhof_rbreak_in(1:nbreak) - call calc_rhobreak() else if (temperature .le. 0) read_temp = .true. rhof => rho_tab @@ -167,6 +168,8 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) rad_max = rad_max/udist rhof_rbreak = rhof_rbreak/udist rhof_rhobreak = rhof_rhobreak/unit_density + m_target = m_target*solarm/umass + m_threshold = m_threshold*solarm/umass else rad_prof = rad_prof/udist dens_prof = dens_prof/unit_density @@ -174,6 +177,17 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) rad_max = rad_prof(nprof) endif + !--Calc rho0 and rhobreak + if (use_func) then + if (rhof_rho0 < 0.) then + call calc_rho0(rhof) + elseif (m_target < 0.) then + call calc_rhobreak() + else + call fatal('moddump','Must give rho0 or m_target') + endif + endif + !--remove unwanted particles if (ignore_radius > 0) then npart_old = npart @@ -308,6 +322,33 @@ subroutine calc_rhobreak() end subroutine calc_rhobreak +subroutine calc_rho0(rhof) + use units, only:unit_density + use stretchmap, only:get_mass_r + procedure(rho), pointer, intent(in) :: rhof + real :: rho0_min,rho0_max,totmass + integer :: iter + + rho0_min = 0. + rho0_max = 1. + totmass = -1. + iter = 0 + + do while (abs(totmass - m_target) > m_threshold) + rhof_rho0 = 0.5*(rho0_min + rho0_max) + call calc_rhobreak() + totmass = get_mass_r(rhof,rad_max,rad_min) + if (totmass > m_target) then + rho0_max = rhof_rho0 + else + rho0_min = rhof_rho0 + endif + iter = iter + 1 + enddo + write(*,'(a11,1x,es10.2,1x,a12,1x,i3,1x,a10)') ' Get rho0 =', rhof_rho0*unit_density, 'g/cm^-3 with', iter, 'iterations' + +end subroutine + !---------------------------------------------------------------- !+ ! write parameters to setup file @@ -332,7 +373,9 @@ subroutine write_setupfile(filename) call write_inopt(rad_min,'rad_min','inner radius of the circumnuclear gas cloud',iunit) call write_inopt(rad_max,'rad_max','outer radius of the circumnuclear gas cloud',iunit) write(iunit,"(/,a)") '# density broken power law' - call write_inopt(rhof_rho0,'rhof_rho0','density at rad_min (in g/cm^3)',iunit) + call write_inopt(rhof_rho0,'rhof_rho0','density at rad_min (in g/cm^3) (-ve = ignore and calc for m_target)',iunit) + call write_inopt(m_target,'m_target','target mass in circumnuclear gas cloud (in Msun) (-ve = ignore and use rho0)',iunit) + call write_inopt(m_threshold,'m_threshold','threshold in solving rho0 for m_target (in Msun)',iunit) call write_inopt(nbreak,'nbreak','number of broken power laws',iunit) write(iunit,"(/,a)") '# section 1 (from rad_min)' call write_inopt(rhof_n(1),'rhof_n_1','power law index of the section',iunit) @@ -387,7 +430,9 @@ subroutine read_setupfile(filename,ierr) if (use_func) then call read_inopt(rad_min,'rad_min',db,min=ignore_radius,err=ierr) call read_inopt(rad_max,'rad_max',db,min=rad_min,err=ierr) - call read_inopt(rhof_rho0,'rhof_rho0',db,min=0.,err=ierr) + call read_inopt(rhof_rho0,'rhof_rho0',db,err=ierr) + call read_inopt(m_target,'m_target',db,err=ierr) + call read_inopt(m_threshold,'m_threshold',db,err=ierr) call read_inopt(nbreak,'nbreak',db,min=1,err=ierr) allocate(rhof_rbreak_in(in_num),rhof_n_in(in_num)) call read_inopt(rhof_n_in(1),'rhof_n_1',db,err=ierr) From e28d949d8419fa77d3f8a38d4441e0e28df9c4d8 Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 25 Oct 2023 15:11:24 +1100 Subject: [PATCH 147/814] (analysis_radiotde) shock detection and analysis --- src/utils/analysis_radiotde.f90 | 300 +++++++++++++++++++++++--------- 1 file changed, 214 insertions(+), 86 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 4d009de92..331cfa04a 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -30,8 +30,17 @@ module analysis private + character(len=7) :: ana + real, dimension(:), allocatable :: rad_all,vr_all,v_all real, dimension(:), allocatable :: theta,plot_theta,phi,vr,vtheta,vphi logical, dimension(:), allocatable :: cap + real :: m_accum, m_cap + real :: vr_accum_mean, vr_accum_max, vr_cap_mean, vr_cap_max + real :: r_accum_maxv, r_cap_maxv + real :: v_accum_mean, v_cap_mean + real :: e_accum, e_cap + integer :: n_accum, n_cap + real :: shock_v, shock_r, shock_e, shock_m, shock_rho !---- These can be changed in the params file real :: rad_cap = 1.e16 ! radius where the outflow in captured (in cm) @@ -42,15 +51,14 @@ module analysis real :: theta_max = 180. real :: phi_min = -90. real :: phi_max = 90. - real :: m_accum, m_cap, vr_accum_mean, vr_cap_mean, v_accum_mean, v_cap_mean, e_accum, e_cap - integer :: n_accum, n_cap contains subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) use readwrite_dumps, only: opened_full_dump - use units, only: utime,udist,unit_energ,umass + use units, only: utime,udist,unit_energ,umass,unit_density use physcon, only: solarm,days + use part, only: pxyzu character(len=*), intent(in) :: dumpfile integer, intent(in) :: numfile,npart,iunit real, intent(in) :: xyzh(:,:),vxyzu(:,:) @@ -67,6 +75,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) n_cap = 0 e_accum = 0. e_cap = 0. + ana = 'outflow' toMsun = umass/solarm todays = utime/days @@ -92,82 +101,139 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) print*,' Edit '//trim(filename)//' and rerun phantomanalysis' stop endif + + allocate(rad_all(npart),vr_all(npart),v_all(npart)) + call to_rad(npart,xyzh,vxyzu,rad_all,vr_all,v_all) + + select case (trim(ana)) + case ('outflow') + write(*,'(a)') ' Analysing the outflow ...' + + rad_cap = rad_cap/udist + if (drad_cap < 0.) then + drad_cap = huge(0.) + else + drad_cap = drad_cap/udist + endif + print*, 'Capture particles from', rad_cap, 'to', rad_cap+drad_cap + + allocate(theta(npart),plot_theta(npart),phi(npart),vr(npart),vtheta(npart), & + vphi(npart),cap(npart)) + cap = .false. + + call outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all) + + if (n_cap > 0) then + open(iunit,file=output) + write(iunit,'("# ",es20.12," # TIME")') time + write(iunit,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & + 1,'theta', & + 2,'thetap', & + 3,'phi', & + 4,'vr', & + 5,'vtheta', & + 6,'vphi' + + do i = 1,npart + if (cap(i)) then + write(iunit,'(6(es18.10,1X))') & + theta(i), & + plot_theta(i), & + phi(i), & + vr(i), & + vtheta(i), & + vphi(i) + endif + enddo + close(iunit) + endif - rad_cap = rad_cap/udist - if (drad_cap < 0.) then - drad_cap = huge(0.) - else - drad_cap = drad_cap/udist - endif - print*, 'Capture particles from', rad_cap, 'to', rad_cap+drad_cap + deallocate(theta,plot_theta,phi,vr,vtheta,vphi,cap,rad_all,vr_all,v_all) - allocate(theta(npart),plot_theta(npart),phi(npart),vr(npart),vtheta(npart),vphi(npart),cap(npart)) - cap = .false. + inquire(file='outflows',exist=iexist) + if (iexist) then + open(iunit,file='outflows',status='old',position='append') + else + open(iunit,file='outflows',status='new') + write(iunit,'(14(A,1X))') '#', 'time', 'm_cap[msun]', 'm_accum[msun]', 'vr_accum_mean[c]', 'vr_accum_max[c]', & + 'r_accum_maxv[cm]', 'vr_cap_mean[c]', 'vr_cap_max[c]', 'r_cap_maxv[cm]', & + 'v_accum_mean[c]', 'v_cap_mean[c]', 'e_accum[erg]', 'e_cap[erg]' + endif + write(iunit,'(13(es18.10,1x))') & + time*todays, & + m_cap*toMsun, & + m_accum*toMsun, & + vr_accum_mean, & + vr_accum_max, & + r_accum_maxv*udist, & + vr_cap_mean, & + vr_cap_max, & + r_cap_maxv*udist, & + v_accum_mean, & + v_cap_mean, & + e_accum*unit_energ, & + e_cap*unit_energ + close(iunit) + + write(*,'(I8,1X,A2,1X,I8,1X,A34)') n_cap, 'of', npart, 'particles are in the capture shell' + write(*,'(I8,1X,A2,1X,I8,1X,A40)') n_accum, 'of', npart, 'particles are outside the capture radius' + + case ('shock') + write(*,'(a)') ' Analysing the shock ...' + + call shock_analysis(npart,pmass,rad_all,vr_all,pxyzu(4,:)) + + deallocate(rad_all,vr_all,v_all) + + inquire(file='shock',exist=iexist) + if (iexist) then + open(iunit,file='shock',status='old',position='append') + else + open(iunit,file='shock',status='new') + write(iunit,'(7(A,1x))') '#', 'time', 'radius[cm]', 'velocity[c]', 'mass[Msun]', 'energy[erg]', 'density[g/cm-3]' + endif + write(iunit,'(6(es18.10,1x))') & + time*todays, & + shock_r*udist, & + shock_v, & + shock_m*umass/solarm, & + shock_e*unit_energ, & + shock_rho*unit_density + close(iunit) + + case default + write(*,'(a)') " Unknown analysis type. Do 'outflow' or 'shock'" + stop + end select - call tde_analysis(npart,pmass,xyzh,vxyzu) +end subroutine do_analysis - if (n_cap > 0) then - open(iunit,file=output) - write(iunit,'("# ",es20.12," # TIME")') time - write(iunit,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & - 1,'theta', & - 2,'thetap', & - 3,'phi', & - 4,'vr', & - 5,'vtheta', & - 6,'vphi' +subroutine to_rad(npart,xyzh,vxyzu,rad,vr,v) + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:),vxyzu(:,:) + real, intent(out) :: rad(:),vr(:),v(:) + integer :: i + real :: xyz(1:3),vxyz(1:3) do i = 1,npart - if (cap(i)) then - write(iunit,'(6(es18.10,1X))') & - theta(i), & - plot_theta(i), & - phi(i), & - vr(i), & - vtheta(i), & - vphi(i) - endif + xyz = xyzh(1:3,i) + vxyz = vxyzu(1:3,i) + rad(i) = sqrt(dot_product(xyz,xyz)) + vr(i) = dot_product(xyz,vxyz)/rad(i) + v(i) = sqrt(dot_product(vxyz,vxyz)) enddo - close(iunit) - endif - - deallocate(theta,plot_theta,phi,vr,vtheta,vphi,cap) - - inquire(file='outflows',exist=iexist) - if (iexist) then - open(iunit,file='outflows',status='old',position='append') - else - open(iunit,file='outflows',status='new') - write(iunit,'(9(A15,1X))') '# time', 'm_cap[msun]', 'm_accum[msun]', 'vr_accum_mean[c]', 'vr_cap_mean[c]', & - 'v_accum_mean[c]', 'v_cap_mean[c]', 'e_accum[erg]', 'e_cap[erg]' - endif - write(iunit,'(9(es18.10,1x))') & - time*todays, & - m_cap*toMsun, & - m_accum*toMsun, & - vr_accum_mean, & - vr_cap_mean, & - v_accum_mean, & - v_cap_mean, & - e_accum*unit_energ, & - e_cap*unit_energ - close(iunit) - - write(*,'(I8,1X,A2,1X,I8,1X,A34)') n_cap, 'of', npart, 'particles are in the capture shell' - write(*,'(I8,1X,A2,1X,I8,1X,A40)') n_accum, 'of', npart, 'particles are outside the capture radius' - -end subroutine do_analysis +end subroutine to_rad !-------------------------------------------------------------------------------------------------------------------- ! !-- Actual subroutine where the analysis is done! ! !-------------------------------------------------------------------------------------------------------------------- -subroutine tde_analysis(npart,pmass,xyzh,vxyzu) +subroutine outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all) integer, intent(in) :: npart - real, intent(in) :: pmass,xyzh(:,:),vxyzu(:,:) + real, intent(in) :: pmass,xyzh(:,:),vxyzu(:,:),rad_all(:),vr_all(:),v_all(:) integer :: i - real :: r,v,x,y,z,xyz(1:3),vx,vy,vz,vxyz(1:3) + real :: r,v,x,y,z,vx,vy,vz real :: thetai,phii,vri real :: vr_accum_add,vr_cap_add,v_accum_add,v_cap_add @@ -175,25 +241,29 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) vr_cap_add = 0. v_accum_add = 0. v_cap_add = 0. + vr_accum_max = 0. + vr_cap_max = 0. do i = 1,npart x = xyzh(1,i) y = xyzh(2,i) z = xyzh(3,i) - xyz = (/x,y,z/) vx = vxyzu(1,i) vy = vxyzu(2,i) vz = vxyzu(3,i) - vxyz = (/vx,vy,vz/) - r = sqrt(dot_product(xyz,xyz)) - v = sqrt(dot_product(vxyz,vxyz)) + r = rad_all(i) + v = v_all(i) if (r > rad_cap) then m_accum = m_accum + pmass n_accum = n_accum + 1 e_accum = e_accum + 0.5*pmass*v**2 - vri = dot_product(vxyz,xyz)/r + vri = vr_all(i) vr_accum_add = vr_accum_add + vri v_accum_add = v_accum_add + v + if (vri > vr_accum_max) then + vr_accum_max = vri + r_accum_maxv = r + endif if (r-rad_cap < drad_cap .and. (v .ge. v_min .and. v .le. v_max)) then thetai = atan2d(y,x) phii = atan2d(z,sqrt(x**2+y**2)) @@ -210,6 +280,10 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) e_cap = e_cap + 0.5*pmass*v**2 vr_cap_add = vr_cap_add + vri v_cap_add = v_cap_add + v + if (vri > vr_cap_max) then + vr_cap_max = vri + r_cap_maxv = r + endif endif endif endif @@ -219,7 +293,48 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) vr_cap_mean = vr_cap_add/n_cap v_cap_mean = v_cap_add/n_cap -end subroutine tde_analysis +end subroutine outflow_analysis + +subroutine shock_analysis(npart,pmass,rad_all,vr_all,ents) + use units, only: udist + use physcon, only: au,pi + integer, intent(in) :: npart + real, intent(in) :: pmass,rad_all(:),vr_all(:),ents(:) + integer :: imin,i,n + real :: rad_max,ri,half_m,rad_min,v_add + ! + !------Determine the radius range of the shock + ! + imin = maxloc(ents(:),dim=1) + rad_min = rad_all(imin) + shock_v = vr_all(imin) + + rad_max = 0. + do i = 1,npart + ri = rad_all(i) + if (ents(i) > 3.5e5 .and. ri < 6.5e6 .and. ri > rad_max) rad_max = ri + enddo + write(*,'(a25,1x,es8.1,1x,a5,1x,es8.1,1x,a2)') ' Shock is determined from', shock_r*udist/au, 'au to', rad_max*udist/au, 'au' + shock_r = 0.5*(rad_min + rad_max) + + n = 0 + !shock_e = 0. + !v_add = 0. + half_m = pmass*0.5 + do i = 1,npart + ri = rad_all(i) + if (ri > rad_min .and. ri < rad_max .and. ents(i) > 3.5e5) then + n = n + 1 + !shock_e = half_m*vr_all(i)**2 + !v_add = v_add + vr_all(i) + endif + enddo + !shock_v = v_add/n + shock_m = pmass*n + shock_e = 0.5*shock_m*shock_v**2 + shock_rho = shock_m*4./3.*pi*(rad_max**3-rad_min**3) + +end subroutine !---------------------------------------------------------------- !+ @@ -234,18 +349,24 @@ subroutine write_tdeparams(filename) print "(a)",' writing analysis options file '//trim(filename) open(unit=iunit,file=filename,status='replace',form='formatted') write(iunit,"(a,/)") '# options when performing radio TDE analysis' + call write_inopt(ana,'analysis',"analysis type: 'outflow' or 'shock'",iunit) - call write_inopt(rad_cap,'rad_cap','capture inner radius (in cm)',iunit) - call write_inopt(drad_cap,'drad_cap','capture thickness (in cm) (-ve for all particles at outer radius)',iunit) + select case (trim(ana)) + case ('outflow') + call write_inopt(rad_cap,'rad_cap','capture inner radius (in cm)',iunit) + call write_inopt(drad_cap,'drad_cap','capture thickness (in cm) (-ve for all particles at outer radius)',iunit) - call write_inopt(v_min,'v_min','min velocity (in c)',iunit) - call write_inopt(v_max,'v_max','max velocity (in c)',iunit) + call write_inopt(v_min,'v_min','min velocity (in c)',iunit) + call write_inopt(v_max,'v_max','max velocity (in c)',iunit) - call write_inopt(theta_min,'theta_min','min theta (in deg)',iunit) - call write_inopt(theta_max,'theta_max','max theta (in deg)',iunit) + call write_inopt(theta_min,'theta_min','min theta (in deg)',iunit) + call write_inopt(theta_max,'theta_max','max theta (in deg)',iunit) - call write_inopt(phi_min,'phi_min','min phi (in deg)',iunit) - call write_inopt(phi_max,'phi_max','max phi (in deg)',iunit) + call write_inopt(phi_min,'phi_min','min phi (in deg)',iunit) + call write_inopt(phi_max,'phi_max','max phi (in deg)',iunit) + case ('shock') + case default + end select close(iunit) @@ -265,17 +386,24 @@ subroutine read_tdeparams(filename,ierr) ierr = 0 call open_db_from_file(db,filename,iunit,ierr) - call read_inopt(rad_cap,'rad_cap',db,min=0.,errcount=nerr) - call read_inopt(drad_cap,'drad_cap',db,errcount=nerr) + call read_inopt(ana,'analysis',db,errcount=nerr) + + select case (trim(ana)) + case ('outflow') + call read_inopt(rad_cap,'rad_cap',db,min=0.,errcount=nerr) + call read_inopt(drad_cap,'drad_cap',db,errcount=nerr) - call read_inopt(v_min,'v_min',db,min=0.,max=1.,errcount=nerr) - call read_inopt(v_max,'v_max',db,min=0.,max=1.,errcount=nerr) + call read_inopt(v_min,'v_min',db,min=0.,max=1.,errcount=nerr) + call read_inopt(v_max,'v_max',db,min=0.,max=1.,errcount=nerr) - call read_inopt(theta_min,'theta_min',db,min=-180.,max=180.,errcount=nerr) - call read_inopt(theta_max,'theta_max',db,min=-180.,max=180.,errcount=nerr) + call read_inopt(theta_min,'theta_min',db,min=-180.,max=180.,errcount=nerr) + call read_inopt(theta_max,'theta_max',db,min=-180.,max=180.,errcount=nerr) - call read_inopt(phi_min,'phi_min',db,min=-90.,max=90.,errcount=nerr) - call read_inopt(phi_max,'phi_max',db,min=-90.,max=90.,errcount=nerr) + call read_inopt(phi_min,'phi_min',db,min=-90.,max=90.,errcount=nerr) + call read_inopt(phi_max,'phi_max',db,min=-90.,max=90.,errcount=nerr) + case ('shock') + case default + end select call close_db(db) if (nerr > 0) then From 59fbcdd0ec1405acac24748c54f74f98f940811a Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 1 Nov 2023 16:27:07 +1100 Subject: [PATCH 148/814] (moddump_radiotde) calculate entropy for cnm particles --- src/utils/moddump_radiotde.f90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 87e3b015a..b0987a909 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -45,12 +45,12 @@ module moddump ! !---------------------------------------------------------------- subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) - use physcon, only:solarm,years,mass_proton_cgs + use physcon, only:solarm,years,mass_proton_cgs,kb_on_mh,kboltz,radconst use setup_params, only:npart_total use part, only:igas,set_particle_type,delete_particles_inside_radius, & delete_particles_outside_sphere,kill_particle,shuffle_part use io, only:fatal,master,id - use units, only:umass,udist,utime,set_units,unit_density + use units, only:umass,udist,utime,set_units,unit_density,unit_ergg use timestep, only:dtmax,tmax use eos, only:ieos,gmw use kernel, only:hfact_default @@ -219,10 +219,11 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) !--Set particle properties do i = npart_old+1,npart call set_particle_type(i,igas) - r = dot_product(xyzh(1:3,i),xyzh(1:3,i)) + r = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) if (read_temp) temperature = get_temp_r(r,rad_prof,temp_prof) vxyzu(4,i) = uerg(rhof(r),temperature) vxyzu(1:3,i) = 0. ! stationary for now + pxyzu(4,i) = (kb_on_mh / mu * log(temperature**1.5/rhof(r)) + 4.*radconst*temperature**3 / (3.*rhof(r))) / kboltz/ unit_ergg enddo !--Set timesteps From 3fc2bccd4d92fb4d9eeeeeee1c0f90a2f7d6a997 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 2 Nov 2023 10:01:26 +0100 Subject: [PATCH 149/814] (shock) set units in interactive setup --- src/setup/setup_shock.F90 | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/setup/setup_shock.F90 b/src/setup/setup_shock.F90 index 943e3ef2c..a5dfe3306 100644 --- a/src/setup/setup_shock.F90 +++ b/src/setup/setup_shock.F90 @@ -406,6 +406,7 @@ subroutine choose_shock (gamma,polyk,dtg,iexist) use physcon, only:pi,Rg,au,solarm use prompting, only:prompt use units, only:udist,utime,unit_density,unit_pressure + use setunits, only:set_units_interactive real, intent(inout) :: gamma,polyk real, intent(out) :: dtg logical, intent(in) :: iexist @@ -436,6 +437,9 @@ subroutine choose_shock (gamma,polyk,dtg,iexist) yright = 0.0 zright = 0.0 const = sqrt(4.*pi) + + call set_units_interactive(gr) + ! !--list of shocks ! @@ -679,6 +683,8 @@ end function get_conserved_density subroutine write_setupfile(filename,iprint,numstates,gamma,polyk,dtg) use infile_utils, only:write_inopt use dim, only:tagline + use setunits, only:write_options_units + use part, only:gr integer, intent(in) :: iprint,numstates real, intent(in) :: gamma,polyk,dtg character(len=*), intent(in) :: filename @@ -690,6 +696,8 @@ subroutine write_setupfile(filename,iprint,numstates,gamma,polyk,dtg) write(lu,"(a)") '# '//trim(tagline) write(lu,"(a)") '# input file for Phantom shock tube setup' + call write_options_units(lu,gr) + write(lu,"(/,a)") '# shock tube' do i=1,numstates call write_inopt(leftstate(i), trim(var_label(i))//'left', trim(var_label(i))//' (left)', lu,ierr1) @@ -754,6 +762,8 @@ end subroutine write_setupfile !------------------------------------------ subroutine read_setupfile(filename,iprint,numstates,gamma,polyk,dtg,ierr) use infile_utils, only:open_db_from_file,inopts,close_db,read_inopt + use setunits, only:read_options_and_set_units + use part, only:gr character(len=*), intent(in) :: filename integer, parameter :: lu = 21 integer, intent(in) :: iprint,numstates @@ -767,6 +777,10 @@ subroutine read_setupfile(filename,iprint,numstates,gamma,polyk,dtg,ierr) write(iprint, '(1x,2a)') 'Setup_shock: Reading setup options from ',trim(filename) nerr = 0 + + ! units + call read_options_and_set_units(db,nerr,gr) + do i=1,numstates call read_inopt(leftstate(i), trim(var_label(i))//'left',db,errcount=nerr) call read_inopt(rightstate(i),trim(var_label(i))//'right',db,errcount=nerr) From ee54ee7278ef88cc85f8542afc8bdb6cd7861345 Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 6 Nov 2023 17:09:23 +1100 Subject: [PATCH 150/814] (inject_sim) small fixes --- src/main/inject_sim.f90 | 108 ++++++++++++++++++++++++++-------------- 1 file changed, 72 insertions(+), 36 deletions(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index dac625bb7..695f81de6 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -43,8 +43,7 @@ module inject character(len=120) :: start_dump,pre_dump,next_dump integer :: npart_sim - real :: r_inject,next_time - real, allocatable :: xyzh_pre(:,:),xyzh_next(:,:),vxyzu_next(:,:) + real :: r_inject,r_inject_cgs,next_time character(len=*), parameter :: label = 'inject_tdeoutflow' @@ -59,6 +58,7 @@ subroutine init_inject(ierr) use io, only:error use timestep, only:time use fileutils, only:getnextfilename + use units, only:udist integer, intent(out) :: ierr integer, parameter :: max_niter=5000, idisk=23 @@ -73,19 +73,21 @@ subroutine init_inject(ierr) niter = 0 do while (next_time < time .and. niter < max_niter) + niter = niter + 1 + pre_dump = next_dump + next_dump = getnextfilename(next_dump) call get_dump_time_npart(trim(next_dump),next_time,ierr) - next_dump = getnextfilename(pre_dump) if (ierr /= 0) then ierr = 0 call error('inject','error reading time and npart from '//trim(next_dump)) cycle endif - niter = niter + 1 enddo + start_dump = next_dump write(*,'(a,1x,es10.2)') ' Start read sims and inject particle from '//trim(next_dump)//' at t =',next_time - allocate(xyzh_pre(4,npart_sim),xyzh_next(4,npart_sim),vxyzu_next(4,npart_sim)) - xyzh_pre = 0. + + r_inject = r_inject_cgs/udist ! to code unit end subroutine init_inject @@ -101,53 +103,76 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& integer, intent(inout) :: npart integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject - integer :: ierr + real, allocatable :: xyzh_pre(:,:),xyzh_next(:,:),vxyzu_next(:,:),pxyzu_next(:,:) + integer :: npart_old,ierr + real :: tfac + allocate(xyzh_pre(4,npart_sim),xyzh_next(4,npart_sim),vxyzu_next(4,npart_sim),pxyzu_next(4,npart_sim)) + xyzh_pre = 0. ! !--inject particles only if time has reached ! + tfac = 1. if (time >= next_time) then ! read next dump next_dump = getnextfilename(pre_dump) - call read_dump(next_dump,xyzh_next,ierr,vxyzu_dump=vxyzu_next) + call read_dump(next_dump,xyzh_next,ierr,vxyzu_dump=vxyzu_next,pxyzu_dump=pxyzu_next) - call inject_required_part(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next) + npart_old = npart + call inject_required_part(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next,pxyzu_next) ! copy to pre for next injection use pre_dump = next_dump xyzh_pre = xyzh_next call find_next_dump(next_dump,next_time,ierr) + start_dump = next_dump + + write(*,'(i5,1x,a22)') npart-npart_old, 'particles are injected' + + tfac = 1.d-10 ! set a tiny timestep so the code has time to adjust for timestep endif ! update time to next inject - dtinject = next_time - time + dtinject = tfac*(next_time - time) end subroutine inject_particles - subroutine read_dump(filename,xyzh_dump,ierr,vxyzu_dump) + subroutine read_dump(filename,xyzh_dump,ierr,vxyzu_dump,pxyzu_dump) use dump_utils, only: read_array_from_file character(len=*), intent(in) :: filename real, intent(out) :: xyzh_dump(:,:) integer, intent(out) :: ierr - real, intent(out), optional :: vxyzu_dump(:,:) + real, intent(out), optional :: vxyzu_dump(:,:),pxyzu_dump(:,:) integer, parameter :: iunit = 578 + real(kind=4) :: h(npart_sim) ! !--read xyzh ! - call read_array_from_file(iunit,filename,'x',xyzh_dump(1,:),ierr) - call read_array_from_file(iunit,filename,'y',xyzh_dump(2,:),ierr) - call read_array_from_file(iunit,filename,'z',xyzh_dump(3,:),ierr) - call read_array_from_file(iunit,filename,'h',xyzh_dump(4,:),ierr) + call read_array_from_file(iunit,filename,'x',xyzh_dump(1,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'y',xyzh_dump(2,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'z',xyzh_dump(3,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'h',h,ierr,iprint_in=.false.) + xyzh_dump(4,:) = h ! !--read vxyzu ! if (present(vxyzu_dump)) then - call read_array_from_file(iunit,filename,'vx',vxyzu_dump(1,:),ierr) - call read_array_from_file(iunit,filename,'vy',vxyzu_dump(2,:),ierr) - call read_array_from_file(iunit,filename,'vz',vxyzu_dump(3,:),ierr) - call read_array_from_file(iunit,filename,'u',vxyzu_dump(4,:),ierr) + call read_array_from_file(iunit,filename,'vx',vxyzu_dump(1,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'vy',vxyzu_dump(2,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'vz',vxyzu_dump(3,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'u',vxyzu_dump(4,:),ierr,iprint_in=.false.) + endif + + ! + !--read vxyzu + ! + if (present(pxyzu_dump)) then + call read_array_from_file(iunit,filename,'px',pxyzu_dump(1,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'py',pxyzu_dump(2,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'pz',pxyzu_dump(3,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'entropy',pxyzu_dump(4,:),ierr,iprint_in=.false.) endif end subroutine read_dump @@ -194,12 +219,12 @@ subroutine find_next_dump(next_dump,next_time,ierr) end subroutine find_next_dump - subroutine inject_required_part(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next) - use part, only:igas + subroutine inject_required_part(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next,pxyzu_next) + use part, only:igas,pxyzu,isdead_or_accreted use partinject, only:add_or_update_particle integer, intent(inout) :: npart, npartoftype(:) real, intent(inout) :: xyzh(:,:), vxyzu(:,:) - real, intent(in) :: xyzh_pre(:,:), xyzh_next(:,:), vxyzu_next(:,:) + real, intent(in) :: xyzh_pre(:,:), xyzh_next(:,:), vxyzu_next(:,:), pxyzu_next(:,:) integer :: i,partid real :: r_next,r_pre,vr_next @@ -207,15 +232,18 @@ subroutine inject_required_part(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next, !--check all the particles ! do i=1,npart_sim - r_next = sqrt(dot_product(xyzh_next(1:3,i),xyzh_next(1:3,i))) - r_pre = sqrt(dot_product(xyzh_pre(1:3,i),xyzh_pre(1:3,i))) - vr_next = (dot_product(xyzh_next(1:3,i),vxyzu_next(1:3,i)))/r_next - - if (r_next > r_inject .and. r_pre < r_inject .and. vr_next > 0.) then - ! inject particle by copy the data into position - partid = npart+1 - call add_or_update_particle(igas,xyzh_next(1:3,i),vxyzu_next(1:3,i),xyzh_next(4,i), & - vxyzu(4,i),partid,npart,npartoftype,xyzh,vxyzu) + if (.not. isdead_or_accreted(xyzh_next(4,i))) then + r_next = sqrt(dot_product(xyzh_next(1:3,i),xyzh_next(1:3,i))) + r_pre = sqrt(dot_product(xyzh_pre(1:3,i),xyzh_pre(1:3,i))) + vr_next = (dot_product(xyzh_next(1:3,i),vxyzu_next(1:3,i)))/r_next + + if (r_next > r_inject .and. r_pre < r_inject .and. vr_next > 0.) then + ! inject particle by copy the data into position + partid = npart+1 + call add_or_update_particle(igas,xyzh_next(1:3,i),vxyzu_next(1:3,i),xyzh_next(4,i), & + vxyzu_next(4,i),partid,npart,npartoftype,xyzh,vxyzu) + pxyzu(:,partid) = pxyzu_next(:,i) + endif endif enddo @@ -230,11 +258,19 @@ end subroutine inject_required_part subroutine write_options_inject(iunit) use infile_utils, only: write_inopt integer, intent(in) :: iunit + character(len=10), parameter :: start_dump_default = 'dump_00000' + real, parameter :: r_inject_default = 5.e14 + + ! write something meaningful in infile + if (r_inject_cgs < tiny(0.)) then + start_dump = start_dump_default + r_inject_cgs = r_inject_default + endif write(iunit,"(/,a)") '# options controlling particle injection' !call write_inopt(direc,'direc','directory of the tde dumpfiles',iunit) - call write_inopt(start_dump,'start_dump','prefix of the tde dumpfiles',iunit) - call write_inopt(r_inject,'r_inject','radius to inject tde outflow',iunit) + call write_inopt(trim(start_dump),'start_dump','dumpfile to start for injection',iunit) + call write_inopt(r_inject_cgs,'r_inject','radius to inject tde outflow (in cm)',iunit) end subroutine write_options_inject @@ -261,9 +297,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) start_dump ngot = ngot + 1 case('r_inject') - read(valstring,*,iostat=ierr) r_inject + read(valstring,*,iostat=ierr) r_inject_cgs ngot = ngot + 1 - if (r_inject < 0.) call fatal(label,'invalid setting for r_inject (<0)') + if (r_inject_cgs < 0.) call fatal(label,'invalid setting for r_inject (<0)') end select igotall = (ngot >= 2) From f3ef51544acef14be5ee0d3bd2214c1e4b04c01e Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 6 Nov 2023 17:10:14 +1100 Subject: [PATCH 151/814] (partinject) setup pxyzu if gr --- src/main/partinject.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/main/partinject.F90 b/src/main/partinject.F90 index 8e3b7e0d8..eb7b79faa 100644 --- a/src/main/partinject.F90 +++ b/src/main/partinject.F90 @@ -43,7 +43,7 @@ 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 use part, only:maxalpha,alphaind,maxgradh,gradh,fxyzu,fext,set_particle_type - use part, only:mhd,Bevol,dBevol,Bxyz,divBsymm!,dust_temp + use part, only:mhd,Bevol,dBevol,Bxyz,divBsymm,gr,pxyzu!,dust_temp use part, only:divcurlv,divcurlB,ndivcurlv,ndivcurlB,ntot,ibin use io, only:fatal use dim, only:ind_timesteps @@ -99,6 +99,8 @@ subroutine add_or_update_particle(itype,position,velocity,h,u,particle_number,np divBsymm(particle_number) = 0. endif + if (gr) pxyzu(:,particle_number) = 0. + if (ndivcurlv > 0) divcurlv(:,particle_number) = 0. if (ndivcurlB > 0) divcurlB(:,particle_number) = 0. if (maxalpha==maxp) alphaind(:,particle_number) = 0. From 668bccebb211a0ede05f6cbf990315e6d24dbf5c Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 6 Nov 2023 17:11:15 +1100 Subject: [PATCH 152/814] (utils_dumpfiles) option in read_array_from_file to not print the tags --- src/main/utils_dumpfiles.f90 | 34 +++++++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/src/main/utils_dumpfiles.f90 b/src/main/utils_dumpfiles.f90 index 7e443fdbe..5eae2e455 100644 --- a/src/main/utils_dumpfiles.f90 +++ b/src/main/utils_dumpfiles.f90 @@ -154,7 +154,7 @@ module dump_utils ! generic interface for reading arrays from dumpfile interface read_array_from_file - module procedure read_array_from_file_r8, read_array_from_file_r4 + module procedure read_array_from_file_r4, read_array_from_file_r8 end interface read_array_from_file private @@ -2299,17 +2299,19 @@ end subroutine open_dumpfile_rh ! in the file !+ !----------------------------------------------------- -subroutine read_array_from_file_r8(iunit,filename,tag,array,ierr,use_block) +subroutine read_array_from_file_r8(iunit,filename,tag,array,ierr,use_block,iprint_in) integer, intent(in) :: iunit character(len=*), intent(in) :: filename character(len=*), intent(in) :: tag real(kind=8), intent(out) :: array(:) integer, intent(out) :: ierr integer, intent(in), optional :: use_block + logical, intent(in), optional :: iprint_in integer, parameter :: maxarraylengths = 12 integer(kind=8) :: number8(maxarraylengths) integer :: i,j,k,iblock,nums(ndatatypes,maxarraylengths) integer :: nblocks,narraylengths,my_block + logical :: iprint character(len=lentag) :: mytag @@ -2318,6 +2320,14 @@ subroutine read_array_from_file_r8(iunit,filename,tag,array,ierr,use_block) else my_block = 1 ! match from block 1 by default endif + + ! if printing the tags + if (present(iprint_in)) then + iprint = iprint_in + else + iprint = .true. + endif + array = 0. ! open file for read and get minimal information from header @@ -2335,9 +2345,9 @@ subroutine read_array_from_file_r8(iunit,filename,tag,array,ierr,use_block) read(iunit, iostat=ierr) mytag if (trim(mytag)==trim(tag)) then read(iunit, iostat=ierr) array(1:min(int(number8(j)),size(array))) - print*,'->',mytag + if (iprint) print*,'->',mytag else - print*,' ',mytag + if (iprint) print*,' ',mytag read(iunit, iostat=ierr) endif else @@ -2361,24 +2371,34 @@ end subroutine read_array_from_file_r8 ! in the file !+ !----------------------------------------------------- -subroutine read_array_from_file_r4(iunit,filename,tag,array,ierr,use_block) +subroutine read_array_from_file_r4(iunit,filename,tag,array,ierr,use_block,iprint_in) integer, intent(in) :: iunit character(len=*), intent(in) :: filename character(len=*), intent(in) :: tag real(kind=4), intent(out) :: array(:) integer, intent(out) :: ierr integer, intent(in), optional :: use_block + logical, intent(in), optional :: iprint_in integer, parameter :: maxarraylengths = 12 integer(kind=8) :: number8(maxarraylengths) integer :: i,j,k,iblock,nums(ndatatypes,maxarraylengths) integer :: nblocks,narraylengths,my_block character(len=lentag) :: mytag + logical :: iprint if (present(use_block)) then my_block = use_block else my_block = 1 ! match from block 1 by default endif + + ! if printing the tags + if (present(iprint_in)) then + iprint = iprint_in + else + iprint = .true. + endif + array = 0. ! open file for read @@ -2396,9 +2416,9 @@ subroutine read_array_from_file_r4(iunit,filename,tag,array,ierr,use_block) read(iunit, iostat=ierr) mytag if (trim(mytag)==trim(tag)) then read(iunit, iostat=ierr) array(1:min(int(number8(j)),size(array))) - print*,'->',mytag + if (iprint) print*,'->',mytag else - print*,' ',mytag + if (iprint) print*,' ',mytag read(iunit, iostat=ierr) endif else From 4fcbb8bb0e6684e621bb6f500cb7f211c2ea1cdf Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 6 Nov 2023 17:13:34 +1100 Subject: [PATCH 153/814] (moddump_radiotde) update setupfile comment --- src/utils/moddump_radiotde.f90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index b0987a909..51f96345b 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -47,7 +47,7 @@ module moddump subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) use physcon, only:solarm,years,mass_proton_cgs,kb_on_mh,kboltz,radconst use setup_params, only:npart_total - use part, only:igas,set_particle_type,delete_particles_inside_radius, & + use part, only:igas,set_particle_type,pxyzu,delete_particles_inside_radius, & delete_particles_outside_sphere,kill_particle,shuffle_part use io, only:fatal,master,id use units, only:umass,udist,utime,set_units,unit_density,unit_ergg @@ -205,6 +205,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call kill_particle(i,npartoftype) enddo call shuffle_part(npart) + npart_old = npart endif !--setup cloud @@ -367,7 +368,7 @@ subroutine write_setupfile(filename) write(iunit,"(a)") '# input file for setting up a circumnuclear gas cloud' write(iunit,"(/,a)") '# geometry' - call write_inopt(ignore_radius,'ignore_radius','tde particle inside this radius will be ignored (-ve = ignore tde particles for later injection)',iunit) + call write_inopt(ignore_radius,'ignore_radius','ignore tde particle inside this radius (-ve = ignore all for injection)',iunit) call write_inopt(remove_overlap,'remove_overlap','remove outflow particles overlap with circum particles',iunit) call write_inopt(use_func,'use_func','if use broken power law for density profile',iunit) if (use_func) then From 1a36c2229ec16190ec05c6bc27c669e10168e4be Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 6 Nov 2023 17:16:06 +1100 Subject: [PATCH 154/814] (analysis_radiotde) use min rad as shock rad; use total particle kinetic energy --- src/utils/analysis_radiotde.f90 | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 331cfa04a..79f10a5e3 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -315,23 +315,19 @@ subroutine shock_analysis(npart,pmass,rad_all,vr_all,ents) if (ents(i) > 3.5e5 .and. ri < 6.5e6 .and. ri > rad_max) rad_max = ri enddo write(*,'(a25,1x,es8.1,1x,a5,1x,es8.1,1x,a2)') ' Shock is determined from', shock_r*udist/au, 'au to', rad_max*udist/au, 'au' - shock_r = 0.5*(rad_min + rad_max) + shock_r = rad_min n = 0 - !shock_e = 0. - !v_add = 0. + shock_e = 0. half_m = pmass*0.5 do i = 1,npart ri = rad_all(i) if (ri > rad_min .and. ri < rad_max .and. ents(i) > 3.5e5) then n = n + 1 - !shock_e = half_m*vr_all(i)**2 - !v_add = v_add + vr_all(i) + shock_e = shock_e + half_m*vr_all(i)**2 endif enddo - !shock_v = v_add/n shock_m = pmass*n - shock_e = 0.5*shock_m*shock_v**2 shock_rho = shock_m*4./3.*pi*(rad_max**3-rad_min**3) end subroutine From 2ea772abf91e98faeab18c90f5c54518ae5a3f5b Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 6 Nov 2023 17:27:45 +1100 Subject: [PATCH 155/814] (inject_sim) update comments --- src/main/inject_sim.f90 | 20 +++++--------------- 1 file changed, 5 insertions(+), 15 deletions(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index 695f81de6..0d0b28366 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -6,27 +6,18 @@ !--------------------------------------------------------------------------! module inject ! -! Handles TDE outflow particle injection +! Handles particle injections from another simulations (for TDE outflow only currently) ! ! :References: None ! ! :Owner: Fitz Hu ! ! :Runtime parameters: -! - iboundary_spheres : *number of boundary spheres (integer)* -! - iwind_resolution : *if<>0 set number of particles on the sphere, reset particle mass* -! - nfill_domain : *number of spheres used to set the background density profile* -! - outer_boundary : *delete gas particles outside this radius (au)* -! - sonic_type : *find transonic solution (1=yes,0=no)* -! - wind_inject_radius : *wind injection radius (au, if 0 takes Rstar)* -! - wind_mass_rate : *wind mass loss rate (Msun/yr)* -! - wind_shell_spacing : *desired ratio of sphere spacing to particle spacing* -! - wind_temperature : *wind temperature at injection radius (K, if 0 takes Teff)* -! - wind_velocity : *injection wind velocity (km/s, if sonic_type = 0)* +! - start_dump : *dump to start looking for particles to inject* +! - r_inject : *radius to inject particles* ! -! :Dependencies: cooling_molecular, dim, dust_formation, eos, icosahedron, -! infile_utils, injectutils, io, options, part, partinject, physcon, -! ptmass_radiation, setbinary, timestep, units, wind, wind_equations +! :Dependencies: fileutils, io, timestep, units, dump_utils, part, +! readwrite_dumps_fortran, readwrite_dumps_common, partinject, infile_utils ! use fileutils, only:getnextfilename @@ -57,7 +48,6 @@ module inject subroutine init_inject(ierr) use io, only:error use timestep, only:time - use fileutils, only:getnextfilename use units, only:udist integer, intent(out) :: ierr From 2747924e8436b3ce83d9aa56bf60b45f63207f55 Mon Sep 17 00:00:00 2001 From: Miguel Gonzalez-Bolivar Date: Thu, 16 Nov 2023 17:25:52 +1100 Subject: [PATCH 156/814] Add v_esc option for .divv files --- src/utils/analysis_common_envelope.f90 | 42 +++++++++++++++++++++++--- 1 file changed, 37 insertions(+), 5 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 6cd1c6c27..bc16bcc17 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -1400,13 +1400,14 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) 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, parameter :: Scrit = 2. ! Critical saturation ratio logical :: verbose = .false. allocate(quant(4,npart)) - Nquantities = 13 + Nquantities = 14 if (dump_number == 0) then - print "(13(a,/))",& + print "(14(a,/))",& '1) Total energy (kin + pot + therm)', & '2) Mach number', & '3) Opacity from MESA tables', & @@ -1419,7 +1420,8 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) '10) Mass coordinate', & '11) Gas omega w.r.t. CoM', & '12) Gas omega w.r.t. sink 1',& - '13) JstarS' !option to calculate JstarS + '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) @@ -1435,7 +1437,7 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) com_vxyz = 0. do k=1,4 select case (quantities_to_calculate(k)) - case(0,1,2,3,6,8,9,13) ! Nothing to do + 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)) & @@ -1582,6 +1584,9 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) 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 case default print*,"Error: Requested quantity is invalid." stop @@ -3868,7 +3873,8 @@ subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phii,epo epoti = 2.*poten + particlemass * phii ! For individual particles, need to multiply 2 to poten to get \sum_j G*mi*mj/r ekini = particlemass * 0.5 * dot_product(vxyzu(1:3),vxyzu(1:3)) einti = particlemass * vxyzu(4) - etoti = epoti + ekini + einti + etoti = epoti + ekini + einti + end subroutine calc_gas_energies @@ -4557,4 +4563,30 @@ subroutine set_eos_options(analysis_to_perform) end subroutine set_eos_options + +!---------------------------------------------------------------- +!+ +! Calculates escape velocity for all SPH particles given the potential energy +! of the system at that time +!+ +!---------------------------------------------------------------- +subroutine calc_escape_velocities(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phii,epoti,v_esc) + use ptmass, only:get_accel_sink_gas + use part, only:nptmass + real, intent(in) :: particlemass + real(4), intent(in) :: poten + real, dimension(4), intent(in) :: xyzh,vxyzu + real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass + real :: phii,epoti + real :: fxi,fyi,fzi + real, intent(out) :: v_esc + + phii = 0.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 + v_esc = sqrt(2*abs(epoti/particlemass)) + +end subroutine calc_escape_velocities + end module analysis From 3a15cbaee056405fbd3904656585357fdaca2eb8 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 23 Oct 2023 16:29:00 +1100 Subject: [PATCH 157/814] (#463) bug fixes with particle mass setting in asteroidwind --- src/setup/setup_asteroidwind.f90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index 0b2215f9d..aff62f942 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -30,6 +30,7 @@ module setup ! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, ! io, options, part, physcon, setbinary, spherical, timestep, units ! + use inject, only:mdot implicit none public :: setpart @@ -44,7 +45,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,idust,set_particle_type,igas use setbinary, only:set_binary,get_a_from_period use spherical, only:set_sphere - use units, only:set_units,umass,udist,unit_velocity + use units, only:set_units,umass,udist,utime,unit_velocity use physcon, only:solarm,au,pi,solarr,ceresm,km,kboltz,mass_proton_cgs use externalforces, only:iext_binary, iext_einsteinprec, update_externalforce, & mass1,accradius1 @@ -54,6 +55,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use eos, only:gmw use options, only:iexternalforce use extern_lensethirring, only:blackhole_spin + use kernel, only:hfact_default integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -80,7 +82,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, rasteroid = 2338.3 ! (km) gastemp = 5000. ! (K) norbits = 1000. - !mdot = 5.e8 ! Mass injection rate (g/s) + mdot = 5.e8 ! Mass injection rate (g/s) npart_at_end = 1.0e6 ! Number of particles after norbits dumpsperorbit = 1 @@ -175,10 +177,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, xyzmh_ptmass(ihsoft,1) = rasteroid ! asteroid radius softening endif - ! both of these are reset in the first call to inject_particles - !massoftype(igas) = tmax*mdot/(umass/utime)/npart_at_end - massoftype(igas) = 1.e-12 - hfact = 1.2 + ! we use the estimated injection rate and the final time to set the particle mass + massoftype(igas) = tmax*mdot/(umass/utime)/npart_at_end + hfact = hfact_default !call inject_particles(time,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,dtinj) ! @@ -215,7 +216,7 @@ subroutine write_setupfile(filename) call write_inopt(norbits, 'norbits', 'number of orbits', iunit) call write_inopt(dumpsperorbit,'dumpsperorbit','number of dumps per orbit', iunit) call write_inopt(npart_at_end,'npart_at_end','number of particles injected after norbits',iunit) - !call write_inopt(mdot,'mdot','mass injection rate (g/s)',iunit) + call write_inopt(mdot,'mdot','mass injection rate (g/s)',iunit) close(iunit) end subroutine write_setupfile @@ -244,7 +245,7 @@ subroutine read_setupfile(filename,ierr) call read_inopt(norbits, 'norbits', db,min=0.,errcount=nerr) call read_inopt(dumpsperorbit,'dumpsperorbit',db,min=0 ,errcount=nerr) call read_inopt(npart_at_end, 'npart_at_end', db,min=0 ,errcount=nerr) - !call read_inopt(mdot, 'mdot', db,min=0.,errcount=nerr) + call read_inopt(mdot, 'mdot', db,min=0.,errcount=nerr) call close_db(db) if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' From badffbe7ec438f657b58d56e6e68ffa9d494293f Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 23 Oct 2023 16:40:16 +1100 Subject: [PATCH 158/814] (asteroidwind) delete unused scaling_set variable --- src/main/inject_asteroidwind.f90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/main/inject_asteroidwind.f90 b/src/main/inject_asteroidwind.f90 index dd2d6c25e..758784144 100644 --- a/src/main/inject_asteroidwind.f90 +++ b/src/main/inject_asteroidwind.f90 @@ -36,7 +36,6 @@ module inject real :: npartperorbit = 1000. ! particle injection rate in particles per orbit real :: vlag = 0.0 ! percentage lag in velocity of wind integer :: mdot_type = 2 ! injection rate (0=const, 1=cos(t), 2=r^(-2)) - logical,save :: scaling_set ! has the scaling been set (initially false) contains !----------------------------------------------------------------------- @@ -47,7 +46,6 @@ module inject subroutine init_inject(ierr) integer, intent(inout) :: ierr - scaling_set = .false. ierr = 0 end subroutine init_inject @@ -225,8 +223,8 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) end subroutine read_options_inject subroutine set_default_options_inject(flag) - integer, optional, intent(in) :: flag + end subroutine set_default_options_inject end module inject From b026c03a03cb24342afce54f62bcbbebece468fa Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Sun, 19 Nov 2023 19:00:14 +0100 Subject: [PATCH 159/814] (star) set units from units module --- src/setup/setup_star.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 8107fceca..f40fbe6ee 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -40,6 +40,7 @@ module setup use externalforces, only:iext_densprofile use extern_densprofile, only:nrhotab use setstar, only:ibpwpoly,ievrard,imesa,star_t,need_polyk + use setunits, only:dist_unit,mass_unit implicit none ! ! Input parameters @@ -49,7 +50,6 @@ module setup real :: maxvxyzu logical :: iexist logical :: relax_star_in_setup,write_rho_to_file - character(len=20) :: dist_unit,mass_unit type(star_t) :: star public :: setpart From 26b843cd6250ce5d4a9ed779219702405b5f0fa8 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Sun, 19 Nov 2023 19:05:17 +0100 Subject: [PATCH 160/814] (star) add iopacity_type as setup option --- src/setup/set_star.f90 | 6 ++++-- src/setup/setup_star.f90 | 4 ++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 24071d154..8ffca3b24 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -445,7 +445,7 @@ 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,polyk,iopacity_type) 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 @@ -453,7 +453,7 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk) type(star_t), intent(out) :: star integer, intent(in) :: id,master logical, intent(out) :: use_var_comp - integer, intent(out) :: need_iso + integer, intent(out) :: need_iso,iopacity_type integer, intent(inout) :: ieos real, intent(inout) :: polyk integer :: i @@ -571,6 +571,7 @@ end subroutine set_star_interactive !+ !----------------------------------------------------------------------- subroutine write_options_star(star,iunit,label) + use eos, only:iopacity_type 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 @@ -664,6 +665,7 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) use setstar_utils, only:need_inputprofile,need_rstar,nprofile_opts use units, only:umass,udist,unit_luminosity use physcon, only:solarm,solarr,solarl + use eos, only:iopacity_type type(star_t), intent(out) :: star type(inopts), allocatable, intent(inout) :: db(:) integer, intent(out) :: need_iso diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index f40fbe6ee..8364af026 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -194,7 +194,7 @@ end subroutine setpart subroutine setup_interactive(polyk,gamma,iexist,id,master,ierr) use prompting, only:prompt use units, only:select_unit - use eos, only:X_in,Z_in,gmw + use eos, only:X_in,Z_in,gmw,iopacity_type use eos_gasradrec, only:irecomb use setstar, only:set_star_interactive use setunits, only:set_units_interactive @@ -209,7 +209,7 @@ 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) + call set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk,iopacity_type) ! equation of state call prompt('Enter the desired EoS (1=isothermal,2=adiabatic,10=MESA,12=idealplusrad)',ieos) From f2e57de38c037be91765dd7b63ce08ce72b17d55 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Sun, 19 Nov 2023 19:11:35 +0100 Subject: [PATCH 161/814] (star) write gmw into input file when using ieos=12 --- src/setup/setup_star.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 8364af026..c51f6da83 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -290,7 +290,7 @@ subroutine write_setupfile(filename,gamma,polyk) endif case(12) call write_inopt(gamma,'gamma','Adiabatic index',iunit) - if (.not. use_var_comp) call write_inopt(gmw,'mu','mean molecular weight',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) From b8494914a46702d5161af7e4b4759366b2a31e8f Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Sun, 19 Nov 2023 19:15:12 +0100 Subject: [PATCH 162/814] (setfixedentropycore) clean up and make shooting more robust --- src/setup/set_fixedentropycore.f90 | 78 +++++++++++++++++++++--------- 1 file changed, 56 insertions(+), 22 deletions(-) diff --git a/src/setup/set_fixedentropycore.f90 b/src/setup/set_fixedentropycore.f90 index 6bf31ec59..e520a013a 100644 --- a/src/setup/set_fixedentropycore.f90 +++ b/src/setup/set_fixedentropycore.f90 @@ -6,9 +6,9 @@ !--------------------------------------------------------------------------! module setfixedentropycore ! -! This module softens the core of a MESA stellar profile with a constant -! entropy profile, given a core radius and mass, in preparation -! for adding a sink particle core. +! This module replaces the core of a MESA stellar profile with a flat- +! entropy profile that is in hydrostatic equilibrium with an added sink +! particle. ! ! :References: ! @@ -20,6 +20,10 @@ module setfixedentropycore ! implicit none integer :: ientropy + public :: set_fixedS_softened_core,calc_mass_from_rho,gcore + + private + integer, parameter :: ierr_pres=1,ierr_rho=2,ierr_mass=3 contains @@ -39,17 +43,14 @@ subroutine set_fixedS_softened_core(mcore,rcore,rho,r,pres,m,Xcore,Ycore,ierr) real, intent(in) :: rcore,Xcore,Ycore integer, intent(out) :: ierr real :: mc,msoft,rc - integer :: icore + integer :: icore,iverbose ierr = 0 rc = rcore*solarr ! convert to cm mc = mcore*solarm ! convert to g call interpolator(r,rc,icore) ! find index in r closest to rc msoft = m(icore) - mc - if (msoft<0.) then - print *,'mcore=',mcore,', rcore=',rcore,', icore=',icore,', m(icore) =',m(icore)/solarm - call fatal('setup','mcore cannot exceed m(r=h)') - endif + if (msoft<0.) call fatal('setup','mcore cannot exceed m(r=h)') if (do_radiation) then ientropy = 2 @@ -73,7 +74,8 @@ subroutine set_fixedS_softened_core(mcore,rcore,rho,r,pres,m,Xcore,Ycore,ierr) rho_alloc(icore) = rho(icore) allocate(pres_alloc(0:icore+1)) pres_alloc(icore:icore+1) = pres(icore:icore+1) - call calc_rho_and_pres(r_alloc,mc,m(icore),rho_alloc,pres_alloc,Xcore,Ycore) + iverbose = 0 + call calc_rho_and_pres(r_alloc,mc,m(icore),rho_alloc,pres_alloc,Xcore,Ycore,iverbose) mcore = mc / solarm write(*,'(1x,a,f12.5,a)') 'Obtained core mass of ',mcore,' Msun' write(*,'(1x,a,f12.5,a)') 'Softened mass is ',m(icore)/solarm-mcore,' Msun' @@ -90,13 +92,14 @@ end subroutine set_fixedS_softened_core ! Returns softened core profile with fixed entropy !+ !----------------------------------------------------------------------- -subroutine calc_rho_and_pres(r,mcore,mh,rho,pres,Xcore,Ycore) +subroutine calc_rho_and_pres(r,mcore,mh,rho,pres,Xcore,Ycore,iverbose) use eos, only:entropy,get_mean_molecular_weight real, allocatable, dimension(:), intent(in) :: r + integer, intent(in) :: iverbose real, intent(in) :: mh,Xcore,Ycore real, intent(inout) :: mcore real, allocatable, dimension(:), intent(inout) :: rho,pres - integer :: Nmax + integer :: Nmax,it,ierr real :: Sc,mass,mold,msoft,fac,mu ! INSTRUCTIONS @@ -117,24 +120,31 @@ subroutine calc_rho_and_pres(r,mcore,mh,rho,pres,Xcore,Ycore) ! Start shooting method fac = 0.05 mass = msoft + it = 0 do mold = mass - call one_shot(Sc,r,mcore,msoft,mu,rho,pres,mass) ! returned mass is m(r=0) + call one_shot(Sc,r,mcore,msoft,mu,rho,pres,mass,iverbose,ierr) ! returned mass is m(r=0) + it = it + 1 + if (mass < 0.) then mcore = mcore * (1. - fac) - msoft = mh - mcore - elseif (mass/msoft < 1d-10) then - exit ! Happy when m(r=0) is sufficiently close to zero + elseif (mass/msoft < 1d-10) then ! m(r=0) sufficiently close to zero + exit else mcore = mcore * (1. + fac) - msoft = mh - mcore endif + msoft = mh - mcore if (mold * mass < 0.) fac = fac * 0.5 - if (abs(mold-mass) < tiny(0.)) then - write(*,'(/,1x,a,f12.5)') 'WARNING: Setting fixed entropy for m(r=0)/msoft = ',mass/msoft + + if (abs(mold-mass) < tiny(0.) .and. ierr /= ierr_pres .and. ierr /= ierr_mass) then + write(*,'(/,1x,a,e12.5)') 'WARNING: Converged on mcore without reaching tolerance on zero & + ¢ral mass. m(r=0)/msoft = ',mass/msoft + write(*,'(/,1x,a,i4,a,e12.5)') 'Reached iteration ',it,', fac=',fac exit endif + + if (iverbose > 0) write(*,'(1x,i5,4(2x,a,e12.5))') it,'m(r=0) = ',mass,'mcore = ',mcore,'fac = ',fac enddo end subroutine calc_rho_and_pres @@ -145,13 +155,15 @@ end subroutine calc_rho_and_pres ! Calculate a hydrostatic structure for a given entropy !+ !----------------------------------------------------------------------- -subroutine one_shot(Sc,r,mcore,msoft,mu,rho,pres,mass) - use physcon, only:gg,pi - use eos, only:get_rho_from_p_s +subroutine one_shot(Sc,r,mcore,msoft,mu,rho,pres,mass,iverbose,ierr) + use physcon, only:gg,pi,solarm + use eos, only:get_rho_from_p_s real, intent(in) :: Sc,mcore,msoft,mu + integer, intent(in) :: iverbose real, allocatable, dimension(:), intent(in) :: r real, allocatable, dimension(:), intent(inout) :: rho,pres real, intent(out) :: mass + integer, intent(out) :: ierr integer :: i,Nmax real :: rcore,rhoguess real, allocatable, dimension(:) :: dr,dvol @@ -159,6 +171,7 @@ subroutine one_shot(Sc,r,mcore,msoft,mu,rho,pres,mass) Nmax = size(rho)-1 allocate(dr(1:Nmax+1),dvol(1:Nmax+1)) + ! Pre-fill arrays do i = 1,Nmax+1 dr(i) = r(i)-r(i-1) dvol(i) = 4.*pi/3. * (r(i)**3 - r(i-1)**3) @@ -175,7 +188,28 @@ subroutine one_shot(Sc,r,mcore,msoft,mu,rho,pres,mass) rhoguess = rho(i) call get_rho_from_p_s(pres(i-1),Sc,rho(i-1),mu,rhoguess,ientropy) mass = mass - 0.5*(rho(i)+rho(i-1)) * dvol(i) - if (mass < 0.) return ! m(r) < 0 encountered, exit and decrease mcore + + if (iverbose > 2) print*,Nmax-i+1,pres(i-1),rhoguess,rho(i-1),mass + if (mass < 0.) then ! m(r) < 0 encountered, exit and decrease mcore + if (iverbose > 1) print*,'WARNING: Negative mass reached at i = ',i, 'm = ',mass/solarm + ierr = ierr_mass + return + endif + if (rho(i-1) 1) then + print*,'WARNING: Density inversion at i = ',i, 'm = ',mass/solarm + write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4)') i,rho(i),rho(i-1),mass + endif + ierr = ierr_rho + endif + if (pres(i-1) 1) then + print*,'WARNING: Pressure inversion at i = ',i, 'm = ',mass/solarm + write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4)') i,pres(i-1),rho(i),mass + endif + ierr = ierr_pres + return + endif enddo end subroutine one_shot From 659c9b0ced8314b29c7cc34ed7b118f1e60b9090 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Sun, 19 Nov 2023 19:23:28 +0100 Subject: [PATCH 163/814] (star) new core-softening module that prescribes temperature profile in equilibrium with heating --- build/Makefile | 2 +- src/main/eos.f90 | 44 +++++- src/main/eos_idealplusrad.f90 | 17 +- src/setup/set_fixedlumcore.f90 | 271 ++++++++++++++++++++++++++++++++ src/setup/set_softened_core.f90 | 22 ++- src/setup/set_star.f90 | 24 +-- src/setup/set_star_utils.f90 | 6 +- 7 files changed, 367 insertions(+), 19 deletions(-) create mode 100644 src/setup/set_fixedlumcore.f90 diff --git a/build/Makefile b/build/Makefile index 6da744192..50494cc6e 100644 --- a/build/Makefile +++ b/build/Makefile @@ -658,7 +658,7 @@ SRCSETUP= prompting.f90 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_cubic_core.f90 set_fixedentropycore.f90 set_softened_core.f90 \ + set_cubic_core.f90 set_fixedentropycore.f90 set_fixedlumcore.f90 set_softened_core.f90 \ set_star_utils.f90 relax_star.f90 set_star.f90 set_hierarchical.f90 \ set_vfield.f90 set_Bfield.f90 \ ${SETUPFILE} diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 30ca4f2e6..c4f6711df 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -58,7 +58,7 @@ module eos public :: eos_is_non_ideal,eos_outputs_mu,eos_outputs_gasP public :: get_local_u_internal public :: calc_rec_ene,calc_temp_and_ene,entropy,get_rho_from_p_s,get_u_from_rhoT - public :: get_entropy,get_p_from_rho_s + public :: calc_rho_from_PT,get_entropy,get_p_from_rho_s public :: init_eos,finish_eos,write_options_eos,read_options_eos public :: write_headeropts_eos, read_headeropts_eos @@ -797,6 +797,48 @@ subroutine calc_temp_and_ene(eos_type,rho,pres,ene,temp,ierr,guesseint,mu_local, end subroutine calc_temp_and_ene +!----------------------------------------------------------------------- +!+ +! Calculate density from pressure and temperature. Inputs and outputs +! are in cgs units. +! +! Note on composition: +! For ieos=2 and 12, mu_local is an input, X & Z are not used +! For ieos=10, mu_local is not used +! For ieos=20, mu_local is not used but available as an output +!+ +!----------------------------------------------------------------------- +subroutine calc_rho_from_PT(eos_type,pres,temp,rho,ierr,mu_local,X_local,Z_local) + use physcon, only:kb_on_mh + 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 + integer, intent(in) :: eos_type + real, intent(in) :: pres,temp + real, intent(inout) :: rho + real, intent(in), optional :: X_local,Z_local + real, intent(inout), optional :: mu_local + integer, intent(out) :: ierr + real :: mu,X,Z + + ierr = 0 + mu = gmw + X = X_in + Z = Z_in + if (present(mu_local)) mu = mu_local + if (present(X_local)) X = X_local + if (present(Z_local)) Z = Z_local + select case(eos_type) + case(2) ! Ideal gas + rho = pres / (temp * kb_on_mh) * mu + case(12) ! Ideal gas + radiation + call get_idealplusrad_rhofrompresT(pres,temp,mu,rho) + case default + ierr = 1 + end select + +end subroutine calc_rho_from_PT + !----------------------------------------------------------------------- !+ ! Calculates specific entropy (gas + radiation + recombination) diff --git a/src/main/eos_idealplusrad.f90 b/src/main/eos_idealplusrad.f90 index 5fbe0b0ff..357d49acf 100644 --- a/src/main/eos_idealplusrad.f90 +++ b/src/main/eos_idealplusrad.f90 @@ -23,7 +23,8 @@ module eos_idealplusrad real, parameter :: tolerance = 1e-15 public :: get_idealplusrad_temp,get_idealplusrad_pres,get_idealplusrad_spsoundi,& - get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp + get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp,& + get_idealplusrad_rhofrompresT private @@ -130,4 +131,18 @@ subroutine get_idealplusrad_enfromtemp(densi,tempi,mu,gamma,eni) end subroutine get_idealplusrad_enfromtemp + +!---------------------------------------------------------------- +!+ +! Calculates density from pressure and temperature +!+ +!---------------------------------------------------------------- +subroutine get_idealplusrad_rhofrompresT(presi,tempi,mu,densi) + real, intent(in) :: presi,tempi,mu + real, intent(out) :: densi + + densi = (presi - 1./3.*radconst*tempi**4) * mu / (Rg*tempi) + +end subroutine get_idealplusrad_rhofrompresT + end module eos_idealplusrad diff --git a/src/setup/set_fixedlumcore.f90 b/src/setup/set_fixedlumcore.f90 new file mode 100644 index 000000000..e8e3cc691 --- /dev/null +++ b/src/setup/set_fixedlumcore.f90 @@ -0,0 +1,271 @@ +!--------------------------------------------------------------------------! +! 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 setfixedlumcore +! +! This module softens the core of a MESA stellar profile with a specified +! temperature profile that is in equilibrium with a luminosity function (see +! options in the function "luminosity"). This assumes the softened region is +! radiative and so the temperature gradient provides the flux needed to +! transport this luminosity. +! +! :References: +! +! :Owner: Mike Lau +! +! :Runtime parameters: None +! +! :Dependencies: dim, eos, io, kernel, physcon, table_utils +! + implicit none + public :: set_fixedlum_softened_core + + private + integer, parameter :: ierr_pres=1,ierr_rho=2,ierr_mass=3 + +contains + +!----------------------------------------------------------------------- +!+ +! Main subroutine that calculates the softened profile +! Lstar in erg/s +!+ +!----------------------------------------------------------------------- +subroutine set_fixedlum_softened_core(rcore,Lstar,mcore,rho,r,pres,m,Xcore,Ycore,ierr) + use eos, only:ieos,calc_temp_and_ene,get_mean_molecular_weight,iopacity_type + use io, only:fatal + use physcon, only:solarm,solarr + use table_utils, only:interpolator + use setfixedentropycore, only:calc_mass_from_rho + real, intent(in) :: rcore,Lstar,Xcore,Ycore + real, intent(inout) :: r(:),rho(:),m(:),pres(:),mcore + real, allocatable :: r_alloc(:),rho_alloc(:),pres_alloc(:),T_alloc(:) + integer, intent(out) :: ierr + real :: mc,msoft,rc,eni,mu + integer :: i,icore,iverbose + + ierr = 0 + if (Lstar<=tiny(0.)) then + print *,'Lstar=',Lstar + call fatal('setfixedlumcore','Lstar must be positive') + endif + if (iopacity_type/=1 .and. iopacity_type/=2) then + print *,'iopacity_type=',iopacity_type + call fatal('setfixedlumcore','only iopacity_type = 1,2 are supported') + endif + + rc = rcore*solarr ! convert to cm + mc = mcore*solarm ! convert to g + call interpolator(r,rc,icore) ! find index in r closest to rc + msoft = m(icore) - mc + if (msoft<0.) call fatal('setfixedlumcore','mcore cannot exceed m(r=h)') + + ! Make allocatable copies, see instructions of calc_rho_and_pres + allocate(r_alloc(0:icore+1)) + r_alloc(0) = 0. + r_alloc(1:icore+1) = r(1:icore+1) + allocate(rho_alloc(0:icore)) + rho_alloc(icore) = rho(icore) + allocate(pres_alloc(0:icore+1)) + pres_alloc(icore:icore+1) = pres(icore:icore+1) + + ! Allocate and fill in temperature array + allocate(T_alloc(0:icore+1)) + do i = icore,icore+1 + mu = get_mean_molecular_weight(Xcore,1.-Xcore-Ycore) + call calc_temp_and_ene(ieos,rho(i),pres(i),eni,T_alloc(i),ierr,mu_local=mu, & + X_local=Xcore,Z_local=1.-Xcore-Ycore) + enddo + + iverbose = 0 + call shoot_for_mcore(r_alloc,mc,m(icore),Lstar,rho_alloc,pres_alloc,T_alloc,Xcore,Ycore,iverbose) + mcore = mc / solarm + write(*,'(1x,a,f12.5,a)') 'Obtained core mass of ',mcore,' Msun' + write(*,'(1x,a,f12.5,a)') 'Softened mass is ',m(icore)/solarm-mcore,' Msun' + rho(1:icore) = rho_alloc(1:icore) + pres(1:icore) = pres_alloc(1:icore) + call calc_mass_from_rho(r(1:icore),rho(1:icore),m(1:icore)) + m(1:icore) = m(1:icore) + mc + +end subroutine set_fixedlum_softened_core + + +!----------------------------------------------------------------------- +!+ +! Returns softened core profile +!+ +!----------------------------------------------------------------------- +subroutine shoot_for_mcore(r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) + use eos, only:get_mean_molecular_weight + real, allocatable, dimension(:), intent(in) :: r + integer, intent(in) :: iverbose + real, intent(in) :: Lstar,mh,Xcore,Ycore + real, intent(inout) :: mcore + real, allocatable, dimension(:), intent(inout) :: rho,pres,temp + integer :: Nmax,it,ierr + real :: mass,mold,msoft,fac,mu,mcore_old,fac_new + +! INSTRUCTIONS + +! Input variables should be given in the following format: + +! r(0:Nmax+1): Array of radial grid to be softened, satisfying r(0)=0 and r(Nmax)=rcore +! mcore: Core particle mass, need to provide initial guess +! mh: Mass coordinate at rcore, m(r=rcore) +! rho(0:Nmax): Give rho(Nmax)=(rho at rcore) as input. Outputs density profile. +! p(0:Nmax+1): Give p(Nmax:Nmax+1)=(p at r(Nmax:Nmax+1)) as input. Outputs pressure profile. + + msoft = mh - mcore + Nmax = size(rho)-1 ! Index corresponding to r = h + mu = get_mean_molecular_weight(Xcore,1.-Xcore-Ycore) + + ! Start shooting method + fac = 0.0005 + mass = msoft + it = 0 + do + mold = mass + mcore_old = mcore + call one_shot(r,mcore,msoft,Lstar,mu,rho,pres,temp,mass,iverbose,ierr) ! returned mass is m(r=0) + it = it + 1 + + if (mass < 0.) then + mcore = mcore * (1. - fac) + elseif (mass/msoft < 1d-10) then ! m(r=0) sufficiently close to zero + write(*,'(/,1x,a,i5,a,e12.5)') 'Tolerance on central mass reached on iteration no.',it,', fac=',fac + exit + else + mcore = mcore * (1. + fac) + endif + msoft = mh - mcore + if (mold * mass < 0.) then + fac_new = fac * 0.99 + if (fac_new > tiny(0.)) fac = fac_new + endif + + if (abs(mold-mass) < tiny(0.) .and. ierr /= ierr_pres .and. ierr /= ierr_mass) then + write(*,'(/,1x,a,e12.5)') 'WARNING: Converged on mcore without reaching tolerance on zero & + ¢ral mass. m(r=0)/msoft = ',mass/msoft + write(*,'(/,1x,a,i4,a,e12.5)') 'Reached iteration ',it,', fac=',fac + exit + endif + + if (iverbose > 0) write(*,'(1x,i5,4(2x,a,e12.5))') it,'m(r=0) = ',mass,'mcore_old = ',mcore_old,'mcore = ',mcore,'fac = ',fac + enddo + +end subroutine shoot_for_mcore + + +!----------------------------------------------------------------------- +!+ +! One shot: Solve structure for given guess for msoft/mcore +!+ +!----------------------------------------------------------------------- +subroutine one_shot(r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ierr) + use physcon, only:gg,pi,radconst,c,solarm + use eos, only:ieos,calc_rho_from_PT,iopacity_type + use radiation_utils, only:get_opacity + use setfixedentropycore, only:gcore + use units, only:unit_density,unit_opacity + real, intent(in) :: mcore,msoft,Lstar,mu + integer, intent(in) :: iverbose + real, allocatable, dimension(:), intent(in) :: r + real, allocatable, dimension(:), intent(inout) :: rho,pres,T + real, intent(out) :: mass + integer, intent(out) :: ierr + integer :: i,Nmax + real :: kappai,kappa_code,rcore,mu_local,rho_code + real, allocatable, dimension(:) :: dr,dvol,lum + + Nmax = size(rho)-1 + allocate(dr(1:Nmax+1),dvol(1:Nmax+1),lum(1:Nmax)) + + ! Pre-fill arrays + do i = 1,Nmax+1 + dr(i) = r(i)-r(i-1) + dvol(i) = 4.*pi/3. * (r(i)**3 - r(i-1)**3) + enddo + + rcore = r(Nmax) + mass = msoft + lum(Nmax) = Lstar + mu_local = mu + + do i = Nmax, 1, -1 + pres(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & + * rho(i) * gg * (mass/r(i)**2 + mcore * gcore(r(i),rcore)) & + + dr(i)**2 * pres(i+1) & + + ( dr(i+1)**2 - dr(i)**2) * pres(i) ) / dr(i+1)**2 + rho_code = rho(i) / unit_density + call get_opacity(iopacity_type,rho_code,T(i),kappa_code) + kappai = kappa_code * unit_opacity + kappai = 0.32 !!!!! CONSTANT OPACITY + T(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & + * 3./(16.*pi*radconst*c) * rho(i)*kappai*lum(i) / (r(i)**2*T(i)**3) & + + dr(i)**2 * T(i+1) & + + ( dr(i+1)**2 - dr(i)**2) * T(i) ) / dr(i+1)**2 + call calc_rho_from_PT(ieos,pres(i-1),T(i-1),rho(i-1),ierr,mu_local) + mass = mass - 0.5*(rho(i)+rho(i-1)) * dvol(i) + lum(i-1) = luminosity(mass,msoft,Lstar) + + if (iverbose > 2) print*,Nmax-i+1,rho(i-1),mass,pres(i-1),T(i-1),kappai + if (mass < 0.) then ! m(r) < 0 encountered, exit and decrease mcore + if (iverbose > 1) print*,'WARNING: Negative mass reached at i = ',i, 'm = ',mass/solarm + ierr = ierr_mass + return + endif + if (rho(i-1) 1) then + print*,'WARNING: Density inversion at i = ',i, 'm = ',mass/solarm + write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4)') i,rho(i),rho(i-1),mass + endif + ierr = ierr_rho + endif + if (pres(i-1) 1) then + print*,'WARNING: Pressure inversion at i = ',i, 'm = ',mass/solarm + write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4)') i,pres(i-1),rho(i),mass + endif + ierr = ierr_pres + return + endif + enddo +end subroutine one_shot + + +!----------------------------------------------------------------------- +!+ +! Luminosity that is linear with mass, reaching Lstar at mcore +!+ +!----------------------------------------------------------------------- +function luminosity(m,mcore,Lstar,hsoft) +! use kernel, only:wkern,cnormk,radkern2 + real, intent(in) :: m,mcore,Lstar + real, intent(in), optional :: hsoft + real :: luminosity,q + integer :: ilum + + ilum = 0 + q = m/mcore + + select case(ilum) + case(1) ! smooth step + luminosity = (3.*q**2 - 2.*q**3)*Lstar +! case(2) ! sink kernel +! q2 = q*q +! if (q2 < radkern2) then +! luminosity = cnormk*wkern(q2,q)/hsoft**3 * Lstar +! else +! luminosity = Lstar +! endif + case default ! constant heating rate + luminosity = q*Lstar + end select + +end function luminosity + + +end module setfixedlumcore diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index dd3648941..bda8973c8 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -30,19 +30,23 @@ module setsoftenedcore ! Main subroutine that sets a softened core profile !+ !----------------------------------------------------------------------- -subroutine set_softened_core(isoftcore,isofteningopt,rcore,mcore,r,den,pres,m,X,Y,ierr) - use eos, only:ieos,X_in,Z_in,init_eos,get_mean_molecular_weight +subroutine set_softened_core(isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,m,X,Y,ierr) + use eos, only:ieos,X_in,Z_in,init_eos,gmw,get_mean_molecular_weight,iopacity_type + use eos_mesa, only:init_eos_mesa use io, only:fatal use table_utils, only:interpolator,yinterp,flip_array use setcubiccore, only:set_cubic_core,find_mcore_given_rcore,& find_rcore_given_mcore,check_rcore_and_mcore use setfixedentropycore, only:set_fixedS_softened_core + use setfixedlumcore, only:set_fixedlum_softened_core use physcon, only:solarr,solarm + use units, only:unit_luminosity integer, intent(in) :: isoftcore,isofteningopt + real, intent(in) :: Lstar real, intent(inout) :: rcore,mcore real, intent(inout) :: r(:),den(:),m(:),pres(:),X(:),Y(:) integer :: core_index,ierr - real :: Xcore,Zcore,rc + real :: Xcore,Zcore,rc,Lstar_cgs logical :: isort_decreasing,iexclude_core_mass ! Output data to be sorted from stellar surface to interior? @@ -72,9 +76,10 @@ subroutine set_softened_core(isoftcore,isofteningopt,rcore,mcore,r,den,pres,m,X, rc = rcore*solarr Xcore = yinterp(X,r,rc) Zcore = 1.-Xcore-yinterp(Y,r,rc) + gmw = get_mean_molecular_weight(Xcore,Zcore) write(*,'(1x,a,f7.5,a,f7.5,a,f7.5)') 'Using composition at core boundary: X = ',Xcore,', Z = ',Zcore,& - ', mu = ',get_mean_molecular_weight(Xcore,Zcore) + ', mu = ',gmw call interpolator(r,rc,core_index) ! find index of core X(1:core_index) = Xcore Y(1:core_index) = yinterp(Y,r,rc) @@ -93,6 +98,15 @@ subroutine set_softened_core(isoftcore,isofteningopt,rcore,mcore,r,den,pres,m,X, case(2) call set_fixedS_softened_core(mcore,rcore,den,r,pres,m,Xcore,1.-Xcore-Zcore,ierr) if (ierr /= 0) call fatal('setup','could not set fixed entropy softened core') + case(3) + if (iopacity_type==1) then + call init_eos_mesa(Xcore,Zcore,ierr) ! Need to initialise MESA opacity tables + elseif (iopacity_type /= 2) then + call fatal('set_softened_core','Cannot use zero opacity (iopacity_type<1) with a fixed-luminosity core') + endif + Lstar_cgs = Lstar * unit_luminosity + call set_fixedlum_softened_core(rcore,Lstar_cgs,mcore,den,r,pres,m,Xcore,1.-Xcore-Zcore,ierr) + if (ierr /= 0) call fatal('setup','could not set fixed entropy softened core') end select ! Reverse arrays so that data is sorted from stellar surface to stellar centre. diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 8ffca3b24..5a2f15c19 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -162,7 +162,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& 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,& + star%hsoft,star%lcore,star%outputfilename,composition,& comp_label,ncols_compo) ! ! set up particles to represent the desired stellar profile @@ -504,10 +504,11 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk, 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', & + print "(4(/,a))",'0: Do not soften profile', & '1: Use cubic softened density profile', & - '2: Use constant entropy softened profile' - call prompt('Select option above : ',star%isoftcore,0,2) + '2: Use constant entropy softened profile', & + '3: Use linear luminosity softened profile' + call prompt('Select option above : ',star%isoftcore,0,3) select case(star%isoftcore) case(0) @@ -546,12 +547,13 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk, call prompt('Enter sink particle luminosity [Lsun]',lcore_lsun,0.) star%lcore = lcore_lsun*real(solarl/unit_luminosity) - case(2) + case(2,3) 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.) + if (star%isoftcore == 3) call prompt('Enter opacity method (0=inf,1=mesa,2=constant,-1=preserve): ',iopacity_type,1) 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) @@ -603,7 +605,7 @@ subroutine write_options_star(star,iunit,label) select case(star%iprofile) case(imesa) call write_inopt(star%isoftcore,'isoftcore'//trim(c),& - '0=no core softening, 1=cubic, 2=const. entropy',iunit) + '0=no core softening, 1=cubic, 2=const. entropy, 3=const. lum',iunit) if (star%isoftcore > 0) then call write_inopt(star%input_profile,'input_profile'//trim(c),& @@ -621,7 +623,7 @@ subroutine write_options_star(star,iunit,label) call write_inopt(in_solarm(star%mcore),'mcore'//trim(c),& 'Mass of point mass stellar core [Msun]',iunit) endif - elseif (star%isoftcore == 2) then + elseif (star%isoftcore == 2 .or. star%isoftcore == 3) 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),& @@ -629,6 +631,9 @@ subroutine write_options_star(star,iunit,label) endif call write_inopt(in_solarl(star%lcore),'lcore'//trim(c),& 'Luminosity of point mass stellar core [Lsun]',iunit) + if (star%isoftcore == 3) call write_inopt(iopacity_type,'iopacity_type',& + 'opacity method (1=mesa,2=constant,-1=preserve)',iunit) + else call write_inopt(star%isinkcore,'isinkcore'//trim(c),& 'Add a sink particle stellar core',iunit) @@ -702,7 +707,7 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) case(imesa) ! core softening options call read_inopt(star%isoftcore,'isoftcore'//trim(c),db,errcount=nerr,min=0) - if (star%isoftcore==2) star%isofteningopt=3 + if (star%isoftcore==2 .or. star%isoftcore==3) star%isofteningopt=3 if (star%isoftcore <= 0) then ! sink particle core without softening call read_inopt(star%isinkcore,'isinkcore'//trim(c),db,errcount=nerr) @@ -723,11 +728,12 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) star%rcore = rcore_rsun*real(solarr/udist) endif if ((star%isofteningopt==2) .or. (star%isofteningopt==3) & - .or. (star%isoftcore==2)) then + .or. (star%isoftcore==2) .or. (star%isoftcore==3)) then call read_inopt(mcore_msun,'mcore'//trim(c),db,errcount=nerr,min=0.) star%mcore = mcore_msun*real(solarm/umass) endif call read_inopt(lcore_lsun,'lcore'//trim(c),db,errcount=nerr,min=0.) + if (star%isoftcore==3) call read_inopt(iopacity_type,'iopacity_type'//trim(c),db,errcount=nerr,min=1) star%lcore = lcore_lsun*real(solarl/unit_luminosity) endif case(ievrard) diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index acc0de210..623c4b378 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -64,7 +64,7 @@ module setstar_utils subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& r,den,pres,temp,en,mtab,X_in,Z_in,Xfrac,Yfrac,mu,& npts,rmin,Rstar,Mstar,rhocentre,& - isoftcore,isofteningopt,rcore,mcore,hsoft,outputfilename,& + isoftcore,isofteningopt,rcore,mcore,hsoft,Lstar,outputfilename,& composition,comp_label,columns_compo) use extern_densprofile, only:read_rhotab_wrapper use eos_piecewise, only:get_dPdrho_piecewise @@ -78,7 +78,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& integer, intent(in) :: iprofile,ieos character(len=*), intent(in) :: input_profile,outputfilename real, intent(in) :: ui_coef - real, intent(inout) :: gamma,polyk,hsoft + real, intent(inout) :: gamma,polyk,hsoft,Lstar real, intent(in) :: X_in,Z_in real, allocatable, intent(out) :: r(:),den(:),pres(:),temp(:),en(:),mtab(:) real, allocatable, intent(out) :: Xfrac(:),Yfrac(:),mu(:),composition(:,:) @@ -127,7 +127,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& allocate(mu(size(den))) mu = 0. if (ierr /= 0) call fatal('setup','error in reading stellar profile from'//trim(input_profile)) - call set_softened_core(isoftcore,isofteningopt,rcore,mcore,r,den,pres,mtab,Xfrac,Yfrac,ierr) ! sets mcore, rcore + call set_softened_core(isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,mtab,Xfrac,Yfrac,ierr) ! sets mcore, rcore hsoft = 0.5 * rcore ! solve for temperature and energy profile do i=1,size(r) From b17a283876eaa93f87e2450ab83c25c9159dbe88 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 20 Nov 2023 10:09:08 +0100 Subject: [PATCH 164/814] (shock) only allow setting units when using radiation --- src/setup/setup_shock.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/setup/setup_shock.F90 b/src/setup/setup_shock.F90 index a5dfe3306..c39e04ed5 100644 --- a/src/setup/setup_shock.F90 +++ b/src/setup/setup_shock.F90 @@ -438,7 +438,7 @@ subroutine choose_shock (gamma,polyk,dtg,iexist) zright = 0.0 const = sqrt(4.*pi) - call set_units_interactive(gr) + if (do_radiation) call set_units_interactive(gr) ! !--list of shocks @@ -682,7 +682,7 @@ end function get_conserved_density !------------------------------------------ subroutine write_setupfile(filename,iprint,numstates,gamma,polyk,dtg) use infile_utils, only:write_inopt - use dim, only:tagline + use dim, only:tagline,do_radiation use setunits, only:write_options_units use part, only:gr integer, intent(in) :: iprint,numstates @@ -696,7 +696,7 @@ subroutine write_setupfile(filename,iprint,numstates,gamma,polyk,dtg) write(lu,"(a)") '# '//trim(tagline) write(lu,"(a)") '# input file for Phantom shock tube setup' - call write_options_units(lu,gr) + if (do_radiation) call write_options_units(lu,gr) write(lu,"(/,a)") '# shock tube' do i=1,numstates @@ -764,6 +764,7 @@ subroutine read_setupfile(filename,iprint,numstates,gamma,polyk,dtg,ierr) use infile_utils, only:open_db_from_file,inopts,close_db,read_inopt use setunits, only:read_options_and_set_units use part, only:gr + use dim, only:do_radiation character(len=*), intent(in) :: filename integer, parameter :: lu = 21 integer, intent(in) :: iprint,numstates @@ -779,7 +780,7 @@ subroutine read_setupfile(filename,iprint,numstates,gamma,polyk,dtg,ierr) nerr = 0 ! units - call read_options_and_set_units(db,nerr,gr) + if (do_radiation) call read_options_and_set_units(db,nerr,gr) do i=1,numstates call read_inopt(leftstate(i), trim(var_label(i))//'left',db,errcount=nerr) From e1bd640d90730f2f00de878ce6ddaa511d0499be Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 20 Nov 2023 12:05:25 +0100 Subject: [PATCH 165/814] fix cooling prescriptions --- src/main/cooling_functions.f90 | 42 ++++++++++++++++++++-------------- src/main/cooling_ism.f90 | 2 +- src/main/h2chem.f90 | 10 ++++---- 3 files changed, 31 insertions(+), 23 deletions(-) diff --git a/src/main/cooling_functions.f90 b/src/main/cooling_functions.f90 index 04ff47305..a5f1b724f 100644 --- a/src/main/cooling_functions.f90 +++ b/src/main/cooling_functions.f90 @@ -249,7 +249,7 @@ real function n_e(T_gas, rho_gas, mu, nH, nHe) else KH = cst/X * exp(-H_ion /(kboltz*T_gas)) ! solution to quadratic SAHA equations (Eq. 16 in D'Angelo et al 2013) - xx = (1./2.) * (-KH + sqrt(KH**2+4.*KH)) + xx = 0.5 * (-KH + sqrt(KH**2+4.*KH)) endif if (T_gas > 3.d5) then z1 = 1. @@ -288,7 +288,7 @@ end function v_th ! ADDITIONAL PHYSICS: compute fraction of gas that has speeds lower than v_crit ! from the cumulative distribution function of the ! Maxwell-Boltzmann distribution -!+ +! doi : 10.4236/ijaa.2020.103010 !----------------------------------------------------------------------- real function MaxBol_cumul(T_gas, mu, v_crit) @@ -298,8 +298,8 @@ real function MaxBol_cumul(T_gas, mu, v_crit) real :: a - a = sqrt( kboltz*T_gas/(mu*mass_proton_cgs) ) - MaxBol_cumul = erf(v_crit/(sqrt(2.)*a)) - sqrt(2./pi) * (v_crit*exp(-v_crit**2/(2.*a**2))) / a + a = sqrt(2.*kboltz*T_gas/(mu*mass_proton_cgs)) + MaxBol_cumul = erf(v_crit/a) - 2./sqrt(pi) * v_crit/a *exp(-(v_crit/a)**2) end function MaxBol_cumul @@ -489,7 +489,7 @@ real function cool_coulomb(T_gas, rho_gas, mu, nH, nHe) real, parameter :: G=1.68 ! ratio of true background UV field to Habing field real, parameter :: D0=0.4255, D1=2.457, D2=-6.404, D3=1.513, D4=0.05343 ! see Table 3 in Weingartner & Draine 2001, last line - if (T_gas > 1000.) then + if (T_gas > 1000.) then !. .and. T_gas < 1.e4) then ne = n_e(T_gas, rho_gas, mu, nH, nHe) x = log(G*sqrt(T_gas)/ne) cool_coulomb = 1.d-28*ne*nH*T_gas**(D0+D1/x)*exp(D2+D3*x-D4*x**2) @@ -588,6 +588,7 @@ end function cool_He_ionisation !----------------------------------------------------------------------- !+ ! CHEMICAL: Cooling due to ro-vibrational excitation of H2 (Lepp & Shull 1983) +! (Smith & Rosen, 2003, MNRAS, 339) !+ !----------------------------------------------------------------------- real function cool_H2_rovib(T_gas, nH, nH2) @@ -604,8 +605,8 @@ real function cool_H2_rovib(T_gas, nH, nH2) kH_01 = 1.0d-12*sqrt(T_gas)*exp(-1000./T_gas) endif kH2_01 = 1.45d-12*sqrt(T_gas)*exp(-28728./(T_gas+1190.)) - Lvh = 1.1d-13*exp(-6744./T_gas) - Lvl = 8.18d-13*(nH*kH_01+nH2*kH2_01) + Lvh = 1.1d-18*exp(-6744./T_gas) + Lvl = 8.18d-13*(nH*kH_01+nH2*kH2_01)*exp(-6840./T_gas) x = log10(T_gas/1.0d4) if (T_gas < 1087.) then @@ -627,7 +628,7 @@ end function cool_H2_rovib !----------------------------------------------------------------------- !+ -! CHEMICAL: H2 dissociation cooling (Shapiro & Kang 1987) +! CHEMICAL: H2 dissociation cooling (Shapiro & Kang 1987, Smith & Rosen 2003) !+ !----------------------------------------------------------------------- real function cool_H2_dissociation(T_gas, rho_gas, mu, nH, nH2) @@ -655,7 +656,7 @@ end function cool_H2_dissociation !----------------------------------------------------------------------- !+ ! CHEMICAL: H2 recombination heating (Hollenbach & Mckee 1979) -! for an overview, see Valentine Wakelama et al. 2017 +! for an overview, see Wakelam et al. 2017, Smith & Rosen 2003 !+ !----------------------------------------------------------------------- real function heat_H2_recombination(T_gas, rho_gas, mu, nH, nH2, T_dust) @@ -675,8 +676,8 @@ real function heat_H2_recombination(T_gas, rho_gas, mu, nH, nH2, T_dust) beta = 1./(1.+n_gas*(2.*nH2/n_gas*((1./n2)-(1./n1))+1./n1)) xi = 7.18d-12*n_gas*nH*(1.-beta) - fa = (1.+1.0d4*exp(-600./T_dust))**(-1.) ! eq 3.4 - k_rec = 3.0d-1*(sqrt(T_gas)*fa)/(1.+0.04*sqrt(T_gas+T_dust)+2.0d-3*T_gas+8.0d-6*T_gas**2) ! eq 3.8 + fa = 1./(1.+1.d4*exp(-600./T_dust)) ! eq 3.4 + k_rec = 3.d-18*(sqrt(T_gas)*fa)/(1.+0.04*sqrt(T_gas+T_dust)+2.d-3*T_gas+8.d-6*T_gas**2) ! eq 3.8 heat_H2_recombination = k_rec*xi @@ -701,16 +702,22 @@ real function cool_CO_rovib(T_gas, rho_gas, mu, nH, nH2, nCO) ! use cumulative distribution of Maxwell-Boltzmann ! to account for collisions that destroy CO + if (T_gas > 3000. .or. T_gas < 250.) then + cool_CO_rovib = 0. + return + endif v_crit = sqrt( 2.*1.78d-11/(mu*mass_proton_cgs) ) ! kinetic energy nfCO = MaxBol_cumul(T_gas, mu, v_crit) * nCO n_gas = rho_gas/(mu*mass_proton_cgs) - n_crit = 3.3d6*(T_gas/1000.)**0.75 !McKee et al. 1982 eq. 5.3 - sigma = 3.0d-16*(T_gas/1000.)**(-1./4.) !McKee et al. 1982 eq. 5.4 - Qrot = n_gas*nfCO*0.5*(kboltz*T_gas*sigma*v_th(T_gas, mu)) / (1. + (n_gas/n_crit) + 1.5*sqrt(n_gas/n_crit)) !McKee et al. 1982 eq. 5.2 + n_crit = 3.3d6*(T_gas/1000.)**0.75 !McKee et al. 1982 eq. 5.3 + sigma = 3.d-16*(T_gas/1000.)**(-0.25) !McKee et al. 1982 eq. 5.4 + !v_th = sqrt((8.*kboltz*T_gas)/(pi*mH2_cgs)) !3.1 + Qrot = 0.5*n_gas*nfCO*kboltz*T_gas*sigma*v_th(T_gas, mu) / (1. + (n_gas/n_crit) + 1.5*sqrt(n_gas/n_crit)) +!McKee et al. 1982 eq. 5.2 - QvibH2 = 1.83d-26*nH2*nfCO*exp(-3080./T_gas)*exp(-68./(T_gas**(1./3.))) !Neufeld & Kaufman 1993 - QvibH = 1.28d-24*nH *nfCO*exp(-3080./T_gas)*exp(-(2000./T_gas)**3.43) !Neufeld & Kaufman 1993 + QvibH2 = 1.83d-26*nH2*nfCO*T_gas*exp(-3080./T_gas)*exp(-68./(T_gas**(1./3.))) !Smith & Rosen + QvibH = 1.28d-24*nH *nfCO*sqrt(T)*exp(-3080./T_gas)*exp(-(2000./T_gas)**3.43) !Smith & Rosen cool_CO_rovib = Qrot+QvibH+QvibH2 @@ -772,7 +779,8 @@ real function cool_OH_rot(T_gas, rho_gas, mu, nOH) n_gas = rho_gas/(mu*mass_proton_cgs) sigma = 2.0d-16 - n_crit = 1.33d7*sqrt(T_gas) + !n_crit = 1.33d7*sqrt(T_gas) + n_crit = 1.5d10*sqrt(T_gas/1000.) !table 3 Hollenbach & McKee 1989 cool_OH_rot = n_gas*nfOH*(kboltz*T_gas*sigma*v_th(T_gas, mu)) / (1 + n_gas/n_crit + 1.5*sqrt(n_gas/n_crit)) !McKee et al. 1982 eq. 5.2 diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index 368eba97b..cad122d85 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.f90 @@ -359,7 +359,7 @@ subroutine cool_func(temp, yn, dl, divv, abundances, ylam, rates) , dtcl41 , dtcl42 , dtcl43 , dtcl44 , dtcl45 & , dtcl46 , dtcl47 , dtcl48 , dtcl49 , dtcl50 & , dtcl51 , dtcl52 , dtcl53 , dtcl54 - ! +! ! --------------------------------------------------------------------- ! ! Read out tables. diff --git a/src/main/h2chem.f90 b/src/main/h2chem.f90 index 02aaa8f9a..2578707cf 100644 --- a/src/main/h2chem.f90 +++ b/src/main/h2chem.f90 @@ -134,9 +134,9 @@ subroutine evolve_abundances(ui,rhoi,chemarrays,nchem,dphot,dt) real :: tstep10,totH2rate,tempiso,np1 integer :: i,j,nstep,nstep2 -!--------------------------------------------------------------------- -! Setup chemistry, read in ab., calulate temp, densities and constants -!--------------------------------------------------------------------- +!---------------------------------------------------------------------- +! Setup chemistry, read in ab., calculate temp, densities and constants +!---------------------------------------------------------------------- h2ratio = chemarrays(ih2ratio) abHIq = chemarrays(iHI) abhpq = chemarrays(iproton) @@ -165,7 +165,7 @@ subroutine evolve_abundances(ui,rhoi,chemarrays,nchem,dphot,dt) ! nh1 =number density of HI inclusive of protons ! nh21=number density of H2 - np1=(rhoi*udens/mp)*5.d0/7.d0 ! n = (5/7)*(rho/mp), gamma=7/5? + np1=(rhoi*udens/mp)*5.d0/7.d0 ! n = (5/7)*(rho/mp), gamma=7/5? dnp1 = 1.d0/np1 !Inverse for calculations @@ -191,7 +191,7 @@ subroutine evolve_abundances(ui,rhoi,chemarrays,nchem,dphot,dt) k0_np1sq = k0*np1*np1 !--------------------------------------------------------------------- -!H2 timsetpping set-up for formation/destruction +!H2 time stepping set-up for formation/destruction !--------------------------------------------------------------------- th2=10000.d0 !Timestep for H2 initially nstep = 5000 From be354826d9f4b6f4a534472a20621eefd5976afc Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 20 Nov 2023 16:06:34 +0100 Subject: [PATCH 166/814] (star) use more robust mass coordinate calculation in softened core shooting --- src/setup/set_fixedlumcore.f90 | 31 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/src/setup/set_fixedlumcore.f90 b/src/setup/set_fixedlumcore.f90 index e8e3cc691..530b049eb 100644 --- a/src/setup/set_fixedlumcore.f90 +++ b/src/setup/set_fixedlumcore.f90 @@ -83,8 +83,8 @@ subroutine set_fixedlum_softened_core(rcore,Lstar,mcore,rho,r,pres,m,Xcore,Ycore iverbose = 0 call shoot_for_mcore(r_alloc,mc,m(icore),Lstar,rho_alloc,pres_alloc,T_alloc,Xcore,Ycore,iverbose) mcore = mc / solarm - write(*,'(1x,a,f12.5,a)') 'Obtained core mass of ',mcore,' Msun' - write(*,'(1x,a,f12.5,a)') 'Softened mass is ',m(icore)/solarm-mcore,' Msun' + write(*,'(1x,a,f8.5,a)') 'Obtained core mass of ',mcore,' Msun' + write(*,'(1x,a,f8.5,a)') 'Softened mass is ',m(icore)/solarm-mcore,' Msun' rho(1:icore) = rho_alloc(1:icore) pres(1:icore) = pres_alloc(1:icore) call calc_mass_from_rho(r(1:icore),rho(1:icore),m(1:icore)) @@ -99,7 +99,8 @@ end subroutine set_fixedlum_softened_core !+ !----------------------------------------------------------------------- subroutine shoot_for_mcore(r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) - use eos, only:get_mean_molecular_weight + use eos, only:get_mean_molecular_weight + use physcon, only:solarm real, allocatable, dimension(:), intent(in) :: r integer, intent(in) :: iverbose real, intent(in) :: Lstar,mh,Xcore,Ycore @@ -135,16 +136,13 @@ subroutine shoot_for_mcore(r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) if (mass < 0.) then mcore = mcore * (1. - fac) elseif (mass/msoft < 1d-10) then ! m(r=0) sufficiently close to zero - write(*,'(/,1x,a,i5,a,e12.5)') 'Tolerance on central mass reached on iteration no.',it,', fac=',fac + write(*,'(/,1x,a,i5,a,e12.5)') 'Tolerance on central mass reached on iteration no.',it,', fac =',fac exit else mcore = mcore * (1. + fac) endif msoft = mh - mcore - if (mold * mass < 0.) then - fac_new = fac * 0.99 - if (fac_new > tiny(0.)) fac = fac_new - endif + if (mold * mass < 0.) fac = fac * 0.99 if (abs(mold-mass) < tiny(0.) .and. ierr /= ierr_pres .and. ierr /= ierr_mass) then write(*,'(/,1x,a,e12.5)') 'WARNING: Converged on mcore without reaching tolerance on zero & @@ -153,7 +151,8 @@ subroutine shoot_for_mcore(r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) exit endif - if (iverbose > 0) write(*,'(1x,i5,4(2x,a,e12.5))') it,'m(r=0) = ',mass,'mcore_old = ',mcore_old,'mcore = ',mcore,'fac = ',fac + if (iverbose > 0) write(*,'(1x,i5,4(2x,a,e15.8))') it,'m(r=0) = ',mass/solarm,'mcore_old = ',& + mcore_old/solarm,'mcore = ',mcore/solarm,'fac = ',fac enddo end subroutine shoot_for_mcore @@ -193,6 +192,7 @@ subroutine one_shot(r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ierr) mass = msoft lum(Nmax) = Lstar mu_local = mu + ierr = 0 do i = Nmax, 1, -1 pres(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & @@ -202,13 +202,12 @@ subroutine one_shot(r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ierr) rho_code = rho(i) / unit_density call get_opacity(iopacity_type,rho_code,T(i),kappa_code) kappai = kappa_code * unit_opacity - kappai = 0.32 !!!!! CONSTANT OPACITY T(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & * 3./(16.*pi*radconst*c) * rho(i)*kappai*lum(i) / (r(i)**2*T(i)**3) & + dr(i)**2 * T(i+1) & + ( dr(i+1)**2 - dr(i)**2) * T(i) ) / dr(i+1)**2 call calc_rho_from_PT(ieos,pres(i-1),T(i-1),rho(i-1),ierr,mu_local) - mass = mass - 0.5*(rho(i)+rho(i-1)) * dvol(i) + mass = mass - rho(i)*dvol(i) lum(i-1) = luminosity(mass,msoft,Lstar) if (iverbose > 2) print*,Nmax-i+1,rho(i-1),mass,pres(i-1),T(i-1),kappai @@ -220,14 +219,14 @@ subroutine one_shot(r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ierr) if (rho(i-1) 1) then print*,'WARNING: Density inversion at i = ',i, 'm = ',mass/solarm - write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4)') i,rho(i),rho(i-1),mass + write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4,2x,e12.7)') i,rho(i),rho(i-1),mass,kappai endif ierr = ierr_rho endif if (pres(i-1) 1) then print*,'WARNING: Pressure inversion at i = ',i, 'm = ',mass/solarm - write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4)') i,pres(i-1),rho(i),mass + write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4,2x,e12.7)') i,pres(i-1),rho(i),mass,kappai endif ierr = ierr_pres return @@ -241,15 +240,15 @@ end subroutine one_shot ! Luminosity that is linear with mass, reaching Lstar at mcore !+ !----------------------------------------------------------------------- -function luminosity(m,mcore,Lstar,hsoft) +function luminosity(m,msoft,Lstar,hsoft) ! use kernel, only:wkern,cnormk,radkern2 - real, intent(in) :: m,mcore,Lstar + real, intent(in) :: m,msoft,Lstar real, intent(in), optional :: hsoft real :: luminosity,q integer :: ilum ilum = 0 - q = m/mcore + q = m/msoft select case(ilum) case(1) ! smooth step From f485f0139e0be1a43667a69a4d6dfe501ffa5a66 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 20 Nov 2023 16:10:57 +0100 Subject: [PATCH 167/814] (star) add warnings about density inversion in softened core shooting solution --- src/setup/set_fixedlumcore.f90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/setup/set_fixedlumcore.f90 b/src/setup/set_fixedlumcore.f90 index 530b049eb..eff27554e 100644 --- a/src/setup/set_fixedlumcore.f90 +++ b/src/setup/set_fixedlumcore.f90 @@ -107,7 +107,7 @@ subroutine shoot_for_mcore(r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) real, intent(inout) :: mcore real, allocatable, dimension(:), intent(inout) :: rho,pres,temp integer :: Nmax,it,ierr - real :: mass,mold,msoft,fac,mu,mcore_old,fac_new + real :: mass,mold,msoft,fac,mu,mcore_old ! INSTRUCTIONS @@ -137,6 +137,7 @@ subroutine shoot_for_mcore(r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) mcore = mcore * (1. - fac) elseif (mass/msoft < 1d-10) then ! m(r=0) sufficiently close to zero write(*,'(/,1x,a,i5,a,e12.5)') 'Tolerance on central mass reached on iteration no.',it,', fac =',fac + if (ierr == ierr_rho) write(*,'(a)') 'WARNING: Profile contains density inversion' exit else mcore = mcore * (1. + fac) @@ -147,6 +148,7 @@ subroutine shoot_for_mcore(r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) if (abs(mold-mass) < tiny(0.) .and. ierr /= ierr_pres .and. ierr /= ierr_mass) then write(*,'(/,1x,a,e12.5)') 'WARNING: Converged on mcore without reaching tolerance on zero & ¢ral mass. m(r=0)/msoft = ',mass/msoft + if (ierr == ierr_rho) write(*,'(1x,a)') 'WARNING: Profile contains density inversion' write(*,'(/,1x,a,i4,a,e12.5)') 'Reached iteration ',it,', fac=',fac exit endif From 57ee24eb310e7308f5e286abd2975e4947f7246e Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 10:56:07 +0100 Subject: [PATCH 168/814] (eos) fixed bug where using radiation with non-ideal EoS does not fail when iopacity_type=1 --- src/main/eos.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index c4f6711df..dee597837 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -445,6 +445,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 ierr = 0 ! @@ -521,7 +522,11 @@ subroutine init_eos(eos_type,ierr) end select done_init_eos = .true. - if (do_radiation .and. iopacity_type==1) call init_eos_mesa(X_in,Z_in,ierr) + if (do_radiation .and. iopacity_type==1) then + write(*,'(1x,a,f7.5,a,f7.5)') 'Using radiation with MESA opacities. Initialising MESA EoS with X = ',X_in,', Z = ',Z_in + call init_eos_mesa(X_in,Z_in,ierr_mesakapp) + ierr = max(ierr,ierr_mesakapp) + endif end subroutine init_eos From 9df54a92113e0d7e9c83d93444d87132c8ebab59 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 11:07:07 +0100 Subject: [PATCH 169/814] (read_star_profile) set hsoft=rcore/radkern instead of hardwiring radkern=2 --- src/setup/set_star_utils.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 623c4b378..c0cefc0b3 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -69,6 +69,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& use extern_densprofile, only:read_rhotab_wrapper use eos_piecewise, only:get_dPdrho_piecewise use eos, only:get_mean_molecular_weight,calc_temp_and_ene,init_eos + use kernel, only:radkern use rho_profile, only:rho_uniform,rho_polytrope,rho_piecewise_polytrope,rho_evrard,func use readwrite_mesa, only:read_mesa,write_mesa use readwrite_kepler, only:read_kepler_file @@ -128,7 +129,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& mu = 0. if (ierr /= 0) call fatal('setup','error in reading stellar profile from'//trim(input_profile)) call set_softened_core(isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,mtab,Xfrac,Yfrac,ierr) ! sets mcore, rcore - hsoft = 0.5 * rcore + hsoft = rcore/radkern ! solve for temperature and energy profile do i=1,size(r) mu(i) = get_mean_molecular_weight(Xfrac(i),1.-Xfrac(i)-Yfrac(i)) ! only used in u, T calculation if ieos==2,12 From d29b0eac8ff6def84a40fc0c7021e1a643a3cb59 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 11:09:02 +0100 Subject: [PATCH 170/814] (read_star_profile) for mesa profile, calculate u and T using ieos=12 instead of ieos=2 when using radiation --- src/setup/set_star_utils.f90 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index c0cefc0b3..2b31891ea 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -70,6 +70,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& use eos_piecewise, only:get_dPdrho_piecewise use eos, only:get_mean_molecular_weight,calc_temp_and_ene,init_eos use kernel, only:radkern + use part, only:do_radiation use rho_profile, only:rho_uniform,rho_polytrope,rho_piecewise_polytrope,rho_evrard,func use readwrite_mesa, only:read_mesa,write_mesa use readwrite_kepler, only:read_kepler_file @@ -89,7 +90,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& real, intent(inout) :: rcore,mcore integer, intent(out) :: columns_compo character(len=20), allocatable, intent(out) :: comp_label(:) - integer :: ierr,i + integer :: ierr,i,eos_type logical :: calc_polyk,iexist real :: eni,tempi,guessene procedure(func), pointer :: get_dPdrho @@ -131,6 +132,11 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& call set_softened_core(isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,mtab,Xfrac,Yfrac,ierr) ! sets mcore, rcore hsoft = rcore/radkern ! solve for temperature and energy profile + if (do_radiation) then + eos_type = 12 + else + eos_type = ieos + endif do i=1,size(r) 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 @@ -140,7 +146,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& guessene = en(i-1) tempi = temp(i-1) endif - call calc_temp_and_ene(ieos,den(i),pres(i),eni,tempi,ierr,guesseint=guessene,mu_local=mu(i)) ! for ieos==20, mu is outputted here + call calc_temp_and_ene(eos_type,den(i),pres(i),eni,tempi,ierr,guesseint=guessene,mu_local=mu(i)) ! for ieos==20, mu is outputted here en(i) = eni temp(i) = tempi enddo From 93c6e678df21e5ff31afd774b176344d660b0ed5 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 11:18:29 +0100 Subject: [PATCH 171/814] (fixedlumcore) remove redundant MESA EoS initialisation to read opacity tables --- src/setup/set_softened_core.f90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index bda8973c8..d0bd5be54 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -99,9 +99,7 @@ subroutine set_softened_core(isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pre call set_fixedS_softened_core(mcore,rcore,den,r,pres,m,Xcore,1.-Xcore-Zcore,ierr) if (ierr /= 0) call fatal('setup','could not set fixed entropy softened core') case(3) - if (iopacity_type==1) then - call init_eos_mesa(Xcore,Zcore,ierr) ! Need to initialise MESA opacity tables - elseif (iopacity_type /= 2) then + if (iopacity_type < 1) then call fatal('set_softened_core','Cannot use zero opacity (iopacity_type<1) with a fixed-luminosity core') endif Lstar_cgs = Lstar * unit_luminosity From 083d1380d4c2964f11fd8503f2a1e62c19441b48 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 11:24:12 +0100 Subject: [PATCH 172/814] (set_softened_core) take eos_type from input instead of using ieos from eos module --- src/setup/set_softened_core.f90 | 14 +++++++------- src/setup/set_star_utils.f90 | 7 ++++--- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index d0bd5be54..eb7e85266 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -30,8 +30,8 @@ module setsoftenedcore ! Main subroutine that sets a softened core profile !+ !----------------------------------------------------------------------- -subroutine set_softened_core(isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,m,X,Y,ierr) - use eos, only:ieos,X_in,Z_in,init_eos,gmw,get_mean_molecular_weight,iopacity_type +subroutine set_softened_core(eos_type,isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,m,X,Y,ierr) + use eos, only:X_in,Z_in,init_eos,gmw,get_mean_molecular_weight,iopacity_type use eos_mesa, only:init_eos_mesa use io, only:fatal use table_utils, only:interpolator,yinterp,flip_array @@ -41,7 +41,7 @@ subroutine set_softened_core(isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pre use setfixedlumcore, only:set_fixedlum_softened_core use physcon, only:solarr,solarm use units, only:unit_luminosity - integer, intent(in) :: isoftcore,isofteningopt + integer, intent(in) :: eos_type,isoftcore,isofteningopt real, intent(in) :: Lstar real, intent(inout) :: rcore,mcore real, intent(inout) :: r(:),den(:),m(:),pres(:),X(:),Y(:) @@ -49,6 +49,7 @@ subroutine set_softened_core(isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pre real :: Xcore,Zcore,rc,Lstar_cgs logical :: isort_decreasing,iexclude_core_mass + write(*,'(/,1x,a)') 'Setting softened core profile' ! Output data to be sorted from stellar surface to interior? isort_decreasing = .true. ! Needs to be true if to be read by Phantom ! @@ -78,17 +79,16 @@ subroutine set_softened_core(isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pre Zcore = 1.-Xcore-yinterp(Y,r,rc) gmw = get_mean_molecular_weight(Xcore,Zcore) - write(*,'(1x,a,f7.5,a,f7.5,a,f7.5)') 'Using composition at core boundary: X = ',Xcore,', Z = ',Zcore,& - ', mu = ',gmw + write(*,'(1x,3(a,f7.5))') 'Using composition at core boundary: X = ',Xcore,', Z = ',Zcore,', mu = ',gmw call interpolator(r,rc,core_index) ! find index of core X(1:core_index) = Xcore Y(1:core_index) = yinterp(Y,r,rc) - if (ieos==10) then + if (eos_type==10) then X_in = Xcore Z_in = Zcore + call init_eos(eos_type,ierr) ! need to initialise EoS again with newfound composition endif - call init_eos(ieos,ierr) if (ierr /= 0) call fatal('set_softened_core','could not initialise equation of state') ! call core-softening subroutines diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 2b31891ea..97241c36b 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -129,14 +129,15 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& allocate(mu(size(den))) mu = 0. if (ierr /= 0) call fatal('setup','error in reading stellar profile from'//trim(input_profile)) - call set_softened_core(isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,mtab,Xfrac,Yfrac,ierr) ! sets mcore, rcore - hsoft = rcore/radkern - ! solve for temperature and energy profile if (do_radiation) then eos_type = 12 else eos_type = ieos endif + call set_softened_core(eos_type,isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,mtab,Xfrac,Yfrac,ierr) ! sets mcore, rcore + hsoft = rcore/radkern + + ! solve for temperature and energy profile do i=1,size(r) 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 From 8a6d87e2e858c9f23e86dc008b294a4234a2d5a3 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 11:27:58 +0100 Subject: [PATCH 173/814] (setfixedlumcore) take eos_type as input instead of using ieos from eos module --- src/setup/set_fixedlumcore.f90 | 38 ++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/src/setup/set_fixedlumcore.f90 b/src/setup/set_fixedlumcore.f90 index eff27554e..28ab2a99f 100644 --- a/src/setup/set_fixedlumcore.f90 +++ b/src/setup/set_fixedlumcore.f90 @@ -34,12 +34,13 @@ module setfixedlumcore ! Lstar in erg/s !+ !----------------------------------------------------------------------- -subroutine set_fixedlum_softened_core(rcore,Lstar,mcore,rho,r,pres,m,Xcore,Ycore,ierr) - use eos, only:ieos,calc_temp_and_ene,get_mean_molecular_weight,iopacity_type +subroutine set_fixedlum_softened_core(eos_type,rcore,Lstar,mcore,rho,r,pres,m,Xcore,Ycore,ierr) + use eos, only:calc_temp_and_ene,get_mean_molecular_weight,iopacity_type use io, only:fatal use physcon, only:solarm,solarr use table_utils, only:interpolator use setfixedentropycore, only:calc_mass_from_rho + integer, intent(in) :: eos_type real, intent(in) :: rcore,Lstar,Xcore,Ycore real, intent(inout) :: r(:),rho(:),m(:),pres(:),mcore real, allocatable :: r_alloc(:),rho_alloc(:),pres_alloc(:),T_alloc(:) @@ -76,12 +77,12 @@ subroutine set_fixedlum_softened_core(rcore,Lstar,mcore,rho,r,pres,m,Xcore,Ycore allocate(T_alloc(0:icore+1)) do i = icore,icore+1 mu = get_mean_molecular_weight(Xcore,1.-Xcore-Ycore) - call calc_temp_and_ene(ieos,rho(i),pres(i),eni,T_alloc(i),ierr,mu_local=mu, & + call calc_temp_and_ene(eos_type,rho(i),pres(i),eni,T_alloc(i),ierr,mu_local=mu, & X_local=Xcore,Z_local=1.-Xcore-Ycore) enddo iverbose = 0 - call shoot_for_mcore(r_alloc,mc,m(icore),Lstar,rho_alloc,pres_alloc,T_alloc,Xcore,Ycore,iverbose) + call shoot_for_mcore(eos_type,r_alloc,mc,m(icore),Lstar,rho_alloc,pres_alloc,T_alloc,Xcore,Ycore,iverbose) mcore = mc / solarm write(*,'(1x,a,f8.5,a)') 'Obtained core mass of ',mcore,' Msun' write(*,'(1x,a,f8.5,a)') 'Softened mass is ',m(icore)/solarm-mcore,' Msun' @@ -98,16 +99,16 @@ end subroutine set_fixedlum_softened_core ! Returns softened core profile !+ !----------------------------------------------------------------------- -subroutine shoot_for_mcore(r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) +subroutine shoot_for_mcore(eos_type,r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) use eos, only:get_mean_molecular_weight use physcon, only:solarm - real, allocatable, dimension(:), intent(in) :: r - integer, intent(in) :: iverbose - real, intent(in) :: Lstar,mh,Xcore,Ycore - real, intent(inout) :: mcore - real, allocatable, dimension(:), intent(inout) :: rho,pres,temp - integer :: Nmax,it,ierr - real :: mass,mold,msoft,fac,mu,mcore_old + integer, intent(in) :: eos_type,iverbose + real, allocatable, dimension(:), intent(in) :: r + real, intent(in) :: Lstar,mh,Xcore,Ycore + real, intent(inout) :: mcore + real, allocatable, dimension(:), intent(inout) :: rho,pres,temp + integer :: Nmax,it,ierr + real :: mass,mold,msoft,fac,mu,mcore_old ! INSTRUCTIONS @@ -130,7 +131,8 @@ subroutine shoot_for_mcore(r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) do mold = mass mcore_old = mcore - call one_shot(r,mcore,msoft,Lstar,mu,rho,pres,temp,mass,iverbose,ierr) ! returned mass is m(r=0) + ierr = 0 + call one_shot(eos_type,r,mcore,msoft,Lstar,mu,rho,pres,temp,mass,iverbose,ierr) ! returned mass is m(r=0) it = it + 1 if (mass < 0.) then @@ -153,8 +155,8 @@ subroutine shoot_for_mcore(r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) exit endif - if (iverbose > 0) write(*,'(1x,i5,4(2x,a,e15.8))') it,'m(r=0) = ',mass/solarm,'mcore_old = ',& - mcore_old/solarm,'mcore = ',mcore/solarm,'fac = ',fac + if (iverbose > 0) write(*,'(1x,i5,4(2x,a,e15.8),2x,a,i1)') it,'m(r=0) = ',mass/solarm,'mcore_old = ',& + mcore_old/solarm,'mcore = ',mcore/solarm,'fac = ',fac,'ierr = ',ierr enddo end subroutine shoot_for_mcore @@ -165,9 +167,9 @@ end subroutine shoot_for_mcore ! One shot: Solve structure for given guess for msoft/mcore !+ !----------------------------------------------------------------------- -subroutine one_shot(r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ierr) +subroutine one_shot(eos_type,r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ierr) use physcon, only:gg,pi,radconst,c,solarm - use eos, only:ieos,calc_rho_from_PT,iopacity_type + use eos, only:calc_rho_from_PT,iopacity_type use radiation_utils, only:get_opacity use setfixedentropycore, only:gcore use units, only:unit_density,unit_opacity @@ -208,7 +210,7 @@ subroutine one_shot(r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ierr) * 3./(16.*pi*radconst*c) * rho(i)*kappai*lum(i) / (r(i)**2*T(i)**3) & + dr(i)**2 * T(i+1) & + ( dr(i+1)**2 - dr(i)**2) * T(i) ) / dr(i+1)**2 - call calc_rho_from_PT(ieos,pres(i-1),T(i-1),rho(i-1),ierr,mu_local) + call calc_rho_from_PT(eos_type,pres(i-1),T(i-1),rho(i-1),ierr,mu_local) mass = mass - rho(i)*dvol(i) lum(i-1) = luminosity(mass,msoft,Lstar) From 27a4101e927cbd9a4f2fccdcaceeb48174f600f2 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 15:59:36 +0100 Subject: [PATCH 174/814] (star) when reading profile from MESA, move solving for u,T profiles to separate subroutine --- src/setup/set_star_utils.f90 | 53 +++++++++++++++++++++++++----------- 1 file changed, 37 insertions(+), 16 deletions(-) diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 97241c36b..ba2b00da5 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -68,7 +68,6 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& composition,comp_label,columns_compo) use extern_densprofile, only:read_rhotab_wrapper use eos_piecewise, only:get_dPdrho_piecewise - use eos, only:get_mean_molecular_weight,calc_temp_and_ene,init_eos use kernel, only:radkern use part, only:do_radiation use rho_profile, only:rho_uniform,rho_polytrope,rho_piecewise_polytrope,rho_evrard,func @@ -76,7 +75,6 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& use readwrite_kepler, only:read_kepler_file use setsoftenedcore, only:set_softened_core use io, only:fatal - use physcon, only:kb_on_mh,radconst integer, intent(in) :: iprofile,ieos character(len=*), intent(in) :: input_profile,outputfilename real, intent(in) :: ui_coef @@ -137,20 +135,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& call set_softened_core(eos_type,isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,mtab,Xfrac,Yfrac,ierr) ! sets mcore, rcore hsoft = rcore/radkern - ! solve for temperature and energy profile - do i=1,size(r) - 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 - else - guessene = en(i-1) - tempi = temp(i-1) - endif - call calc_temp_and_ene(eos_type,den(i),pres(i),eni,tempi,ierr,guesseint=guessene,mu_local=mu(i)) ! for ieos==20, mu is outputted here - en(i) = eni - temp(i) = tempi - enddo + call solve_uT_profiles(eos_type,r,den,pres,Xfrac,Yfrac,regrid_core,temp,en,mu) call write_mesa(outputfilename,mtab,pres,temp,r,den,en,Xfrac,Yfrac,mu=mu) ! now read the softened profile instead call read_mesa(outputfilename,den,r,pres,mtab,en,temp,X_in,Z_in,Xfrac,Yfrac,Mstar,ierr) @@ -463,4 +448,40 @@ 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 +!+ +!----------------------------------------------------------------------- +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 + integer, intent(in) :: eos_type + real, intent(in) :: r(:),den(:),pres(:),Xfrac(:),Yfrac(:) + logical, intent(in) :: regrid_core + real, intent(inout) :: temp(:),en(:),mu(:) + integer :: i,ierr + real :: guessene,tempi,eni + + if (regrid_core) then ! lengths of rho, P arrays have changed, so need to resize temp, en, and mu + deallocate(temp,en,mu) + allocate(temp(size(r)),en(size(r)),mu(size(r))) + endif + + do i=1,size(r) + 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 + else + guessene = en(i-1) + tempi = temp(i-1) + endif + call calc_temp_and_ene(eos_type,den(i),pres(i),eni,tempi,ierr,guesseint=guessene,mu_local=mu(i)) ! for ieos==20, mu is outputted here + en(i) = eni + temp(i) = tempi + enddo +end subroutine + end module setstar_utils From 95807fdab4a6fa91c4cb24c3861ec95d01bce857 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 16:03:47 +0100 Subject: [PATCH 175/814] (star) add option to re-bin core region of MESA profile when solving for softened profile --- src/setup/set_softened_core.f90 | 65 +++++++++++++++++++++++++++++++-- src/setup/set_star_utils.f90 | 6 +-- 2 files changed, 65 insertions(+), 6 deletions(-) diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index eb7e85266..215853ac6 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -30,7 +30,7 @@ module setsoftenedcore ! Main subroutine that sets a softened core profile !+ !----------------------------------------------------------------------- -subroutine set_softened_core(eos_type,isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,m,X,Y,ierr) +subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore,mcore,Lstar,r,den,pres,m,X,Y,ierr) use eos, only:X_in,Z_in,init_eos,gmw,get_mean_molecular_weight,iopacity_type use eos_mesa, only:init_eos_mesa use io, only:fatal @@ -43,11 +43,13 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,rcore,mcore,Lstar, use units, only:unit_luminosity integer, intent(in) :: eos_type,isoftcore,isofteningopt real, intent(in) :: Lstar + logical, intent(in) :: regrid_core real, intent(inout) :: rcore,mcore - real, intent(inout) :: r(:),den(:),m(:),pres(:),X(:),Y(:) - integer :: core_index,ierr + real, intent(inout), allocatable :: r(:),den(:),m(:),pres(:),X(:),Y(:) + integer :: core_index,ierr,npts real :: Xcore,Zcore,rc,Lstar_cgs logical :: isort_decreasing,iexclude_core_mass + real, allocatable :: r1(:),den1(:),pres1(:),m1(:),X1(:),Y1(:) write(*,'(/,1x,a)') 'Setting softened core profile' ! Output data to be sorted from stellar surface to interior? @@ -83,6 +85,23 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,rcore,mcore,Lstar, call interpolator(r,rc,core_index) ! find index of core X(1:core_index) = Xcore Y(1:core_index) = yinterp(Y,r,rc) + + if (regrid_core) then + ! make copy of original arrays + npts = size(r) + allocate(r1(npts),den1(npts),pres1(npts),m1(npts),X1(npts),Y1(npts)) + r1 = r + den1 = den + pres1 = pres + m1 = m + X1 = X + Y1 = Y + Ncore = 5000 ! number of grid points in softened region (hardwired for now) + call regrid_core(Ncore,rcore*solarr,core_index,r1,den1,pres1,m1,X1,Y1,r,den,pres,m,X,Y) + X(:) = X(size(X)) + Y(:) = Y(size(Y)) + endif + if (eos_type==10) then X_in = Xcore Z_in = Zcore @@ -123,4 +142,44 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,rcore,mcore,Lstar, end subroutine set_softened_core + +!----------------------------------------------------------------------- +!+ +! Increase number of grid points in softened region to help converge in +! shooting. Currently, use linear grid points +! +! Ncore: No. of grid points to use in softened region +!+ +!----------------------------------------------------------------------- +subroutine regrid_core(Ncore,rcore_cm,icore,r1,den1,pres1,m1,X1,Y1,r2,den2,pres2,m2,X2,Y2) + integer, intent(in) :: Ncore + real, intent(in) :: rcore_cm + integer, intent(inout) :: icore + real, intent(in), dimension(:) :: r1,den1,pres1,m1,X1,Y1 + real, intent(out), dimension(:), allocatable :: r2,den2,pres2,m2,X2,Y2 + integer :: Ncore,npts,npts_old,i + real :: dr + + npts_old = size(r1) + npts = npts_old - icore + Ncore + + allocate(r2(npts),den2(npts),pres2(npts),m2(npts),X2(npts),Y2(npts)) + r2(Ncore:npts) = r1(icore:npts_old) + den2(Ncore:npts) = den1(icore:npts_old) + pres2(Ncore:npts) = pres1(icore:npts_old) + m2(Ncore:npts) = m1(icore:npts_old) + X2(Ncore:npts) = X1(icore:npts_old) + Y2(Ncore:npts) = Y1(icore:npts_old) + + ! Set uniform r grid in softened region + dr = rcore_cm/real(Ncore) + do i = 1,Ncore-1 + r2(i) = real(i)*dr + enddo + r2(Ncore) = rcore_cm + + icore = Ncore + +end subroutine regrid_core + end module setsoftenedcore diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index ba2b00da5..debf966dd 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -89,8 +89,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& integer, intent(out) :: columns_compo character(len=20), allocatable, intent(out) :: comp_label(:) integer :: ierr,i,eos_type - logical :: calc_polyk,iexist - real :: eni,tempi,guessene + logical :: calc_polyk,iexist,regrid_core procedure(func), pointer :: get_dPdrho ! ! set up tabulated density profile @@ -132,7 +131,8 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& else eos_type = ieos endif - call set_softened_core(eos_type,isoftcore,isofteningopt,rcore,mcore,Lstar,r,den,pres,mtab,Xfrac,Yfrac,ierr) ! sets mcore, rcore + regrid_core = .true. + call set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore,mcore,Lstar,r,den,pres,mtab,Xfrac,Yfrac,ierr) hsoft = rcore/radkern call solve_uT_profiles(eos_type,r,den,pres,Xfrac,Yfrac,regrid_core,temp,en,mu) From f033c9d0e8cf8623d8eb2ad6c220c898fc82c488 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 16:04:58 +0100 Subject: [PATCH 176/814] (star) core softening subroutines take eos_type as input instead of using ieos from eos module --- src/setup/set_fixedentropycore.f90 | 8 ++++---- src/setup/set_softened_core.f90 | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/setup/set_fixedentropycore.f90 b/src/setup/set_fixedentropycore.f90 index e520a013a..77404f2da 100644 --- a/src/setup/set_fixedentropycore.f90 +++ b/src/setup/set_fixedentropycore.f90 @@ -32,12 +32,12 @@ module setfixedentropycore ! Main subroutine that calculates the constant entropy softened profile !+ !----------------------------------------------------------------------- -subroutine set_fixedS_softened_core(mcore,rcore,rho,r,pres,m,Xcore,Ycore,ierr) - use eos, only:ieos +subroutine set_fixedS_softened_core(eos_type,mcore,rcore,rho,r,pres,m,Xcore,Ycore,ierr) use dim, only:do_radiation use physcon, only:pi,gg,solarm,solarr use table_utils, only:interpolator use io, only:fatal + integer, intent(in) :: eos_type real, intent(inout) :: r(:),rho(:),m(:),pres(:),mcore real, allocatable :: r_alloc(:),rho_alloc(:),pres_alloc(:) real, intent(in) :: rcore,Xcore,Ycore @@ -55,14 +55,14 @@ subroutine set_fixedS_softened_core(mcore,rcore,rho,r,pres,m,Xcore,Ycore,ierr) if (do_radiation) then ientropy = 2 else - select case(ieos) + select case(eos_type) case(2) ientropy = 1 case(10,12,20) ientropy = 2 case default call fatal('setfixedentropycore',& - 'ieos not one of 2 (adiabatic), 12 (ideal plus rad.), 10 (MESA), or 20 (gas+rad+recombination)') + 'eos_type not one of 2 (adiabatic), 12 (ideal plus rad.), 10 (MESA), or 20 (gas+rad+recombination)') end select endif diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index 215853ac6..90ddd966d 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -115,14 +115,14 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore, case(1) call set_cubic_core(mcore,rcore,den,r,pres,m) case(2) - call set_fixedS_softened_core(mcore,rcore,den,r,pres,m,Xcore,1.-Xcore-Zcore,ierr) + call set_fixedS_softened_core(eos_type,mcore,rcore,den,r,pres,m,Xcore,1.-Xcore-Zcore,ierr) if (ierr /= 0) call fatal('setup','could not set fixed entropy softened core') case(3) if (iopacity_type < 1) then call fatal('set_softened_core','Cannot use zero opacity (iopacity_type<1) with a fixed-luminosity core') endif Lstar_cgs = Lstar * unit_luminosity - call set_fixedlum_softened_core(rcore,Lstar_cgs,mcore,den,r,pres,m,Xcore,1.-Xcore-Zcore,ierr) + call set_fixedlum_softened_core(eos_type,rcore,Lstar_cgs,mcore,den,r,pres,m,Xcore,1.-Xcore-Zcore,ierr) if (ierr /= 0) call fatal('setup','could not set fixed entropy softened core') end select From aa4c40301504c0e630cde0f0d192f4c381d4866f Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 16:06:53 +0100 Subject: [PATCH 177/814] (fixedlumcore) enhancements to luminosity function --- src/setup/set_fixedlumcore.f90 | 66 +++++++++++++++++++--------------- 1 file changed, 38 insertions(+), 28 deletions(-) diff --git a/src/setup/set_fixedlumcore.f90 b/src/setup/set_fixedlumcore.f90 index 28ab2a99f..7b53aa8ce 100644 --- a/src/setup/set_fixedlumcore.f90 +++ b/src/setup/set_fixedlumcore.f90 @@ -24,7 +24,7 @@ module setfixedlumcore public :: set_fixedlum_softened_core private - integer, parameter :: ierr_pres=1,ierr_rho=2,ierr_mass=3 + integer, parameter :: ierr_rho=1,ierr_pres=2,ierr_mass=3 contains @@ -135,9 +135,12 @@ subroutine shoot_for_mcore(eos_type,r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,i call one_shot(eos_type,r,mcore,msoft,Lstar,mu,rho,pres,temp,mass,iverbose,ierr) ! returned mass is m(r=0) it = it + 1 + if (iverbose > 0) write(*,'(1x,i5,4(2x,a,e15.8),2x,a,i1)') it,'m(r=0) = ',mass/solarm,'mcore_old = ',& + mcore_old/solarm,'mcore = ',mcore/solarm,'fac = ',fac,'ierr = ',ierr + if (mass < 0.) then mcore = mcore * (1. - fac) - elseif (mass/msoft < 1d-10) then ! m(r=0) sufficiently close to zero + elseif (mass/msoft < 1d-10 .and. ierr <= ierr_pres) then ! m(r=0) sufficiently close to zero write(*,'(/,1x,a,i5,a,e12.5)') 'Tolerance on central mass reached on iteration no.',it,', fac =',fac if (ierr == ierr_rho) write(*,'(a)') 'WARNING: Profile contains density inversion' exit @@ -145,9 +148,14 @@ subroutine shoot_for_mcore(eos_type,r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,i mcore = mcore * (1. + fac) endif msoft = mh - mcore - if (mold * mass < 0.) fac = fac * 0.99 - if (abs(mold-mass) < tiny(0.) .and. ierr /= ierr_pres .and. ierr /= ierr_mass) then + if (abs(mold-mass) < tiny(0.)) then + fac = fac * 1.02 + elseif (mold * mass < 0.) then + fac = fac * 0.99 + endif + + if (abs(mold-mass) < tiny(0.) .and. ierr <= ierr_rho) then write(*,'(/,1x,a,e12.5)') 'WARNING: Converged on mcore without reaching tolerance on zero & ¢ral mass. m(r=0)/msoft = ',mass/msoft if (ierr == ierr_rho) write(*,'(1x,a)') 'WARNING: Profile contains density inversion' @@ -155,8 +163,7 @@ subroutine shoot_for_mcore(eos_type,r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,i exit endif - if (iverbose > 0) write(*,'(1x,i5,4(2x,a,e15.8),2x,a,i1)') it,'m(r=0) = ',mass/solarm,'mcore_old = ',& - mcore_old/solarm,'mcore = ',mcore/solarm,'fac = ',fac,'ierr = ',ierr + enddo end subroutine shoot_for_mcore @@ -173,8 +180,8 @@ subroutine one_shot(eos_type,r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ier use radiation_utils, only:get_opacity use setfixedentropycore, only:gcore use units, only:unit_density,unit_opacity + integer, intent(in) :: eos_type,iverbose real, intent(in) :: mcore,msoft,Lstar,mu - integer, intent(in) :: iverbose real, allocatable, dimension(:), intent(in) :: r real, allocatable, dimension(:), intent(inout) :: rho,pres,T real, intent(out) :: mass @@ -212,7 +219,7 @@ subroutine one_shot(eos_type,r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ier + ( dr(i+1)**2 - dr(i)**2) * T(i) ) / dr(i+1)**2 call calc_rho_from_PT(eos_type,pres(i-1),T(i-1),rho(i-1),ierr,mu_local) mass = mass - rho(i)*dvol(i) - lum(i-1) = luminosity(mass,msoft,Lstar) + lum(i-1) = luminosity(mass/msoft,Lstar) if (iverbose > 2) print*,Nmax-i+1,rho(i-1),mass,pres(i-1),T(i-1),kappai if (mass < 0.) then ! m(r) < 0 encountered, exit and decrease mcore @@ -241,32 +248,35 @@ end subroutine one_shot !----------------------------------------------------------------------- !+ -! Luminosity that is linear with mass, reaching Lstar at mcore +! Normalised luminosity function. q can be m/msoft or r/rcore +! Note: For point mass heating, q = r/(radkern*hsoft), not r/hsoft, so +! that luminosity reaches target value at r = radkern*hsoft !+ !----------------------------------------------------------------------- -function luminosity(m,msoft,Lstar,hsoft) -! use kernel, only:wkern,cnormk,radkern2 - real, intent(in) :: m,msoft,Lstar +function luminosity(q,Lstar,hsoft) +! use kernel, only:radkern,wkern,cnormk + real, intent(in) :: q,Lstar real, intent(in), optional :: hsoft - real :: luminosity,q + real :: luminosity integer :: ilum ilum = 0 - q = m/msoft - - select case(ilum) - case(1) ! smooth step - luminosity = (3.*q**2 - 2.*q**3)*Lstar -! case(2) ! sink kernel -! q2 = q*q -! if (q2 < radkern2) then -! luminosity = cnormk*wkern(q2,q)/hsoft**3 * Lstar -! else -! luminosity = Lstar -! endif - case default ! constant heating rate - luminosity = q*Lstar - end select + + if (q > 1) then + luminosity = 1. + else + select case(ilum) + case(1) ! smooth step + luminosity = 3.*q**2 - 2.*q**3 + ! case(2) ! kernel softening + ! r_on_hsoft = q*radkern + ! luminosity = cnormk*wkern(r_on_hsoft*r_on_hsoft,r_on_hsoft)/hsoft**3 + case default ! linear (constant heating rate) + luminosity = q + end select + endif + + luminosity = luminosity * Lstar end function luminosity From 6dd1f579307ec3dcca2da21ddbacd9e2ab463ef5 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 16:11:09 +0100 Subject: [PATCH 178/814] (set_softened_core) bug fixes --- src/setup/set_softened_core.f90 | 10 +++++----- src/setup/set_star_utils.f90 | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index 90ddd966d..19e950d11 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -46,7 +46,7 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore, logical, intent(in) :: regrid_core real, intent(inout) :: rcore,mcore real, intent(inout), allocatable :: r(:),den(:),m(:),pres(:),X(:),Y(:) - integer :: core_index,ierr,npts + integer :: core_index,ierr,npts,Ncore real :: Xcore,Zcore,rc,Lstar_cgs logical :: isort_decreasing,iexclude_core_mass real, allocatable :: r1(:),den1(:),pres1(:),m1(:),X1(:),Y1(:) @@ -97,7 +97,7 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore, X1 = X Y1 = Y Ncore = 5000 ! number of grid points in softened region (hardwired for now) - call regrid_core(Ncore,rcore*solarr,core_index,r1,den1,pres1,m1,X1,Y1,r,den,pres,m,X,Y) + call calc_regrid_core(Ncore,rcore*solarr,core_index,r1,den1,pres1,m1,X1,Y1,r,den,pres,m,X,Y) X(:) = X(size(X)) Y(:) = Y(size(Y)) endif @@ -151,13 +151,13 @@ end subroutine set_softened_core ! Ncore: No. of grid points to use in softened region !+ !----------------------------------------------------------------------- -subroutine regrid_core(Ncore,rcore_cm,icore,r1,den1,pres1,m1,X1,Y1,r2,den2,pres2,m2,X2,Y2) +subroutine calc_regrid_core(Ncore,rcore_cm,icore,r1,den1,pres1,m1,X1,Y1,r2,den2,pres2,m2,X2,Y2) integer, intent(in) :: Ncore real, intent(in) :: rcore_cm integer, intent(inout) :: icore real, intent(in), dimension(:) :: r1,den1,pres1,m1,X1,Y1 real, intent(out), dimension(:), allocatable :: r2,den2,pres2,m2,X2,Y2 - integer :: Ncore,npts,npts_old,i + integer :: npts,npts_old,i real :: dr npts_old = size(r1) @@ -180,6 +180,6 @@ subroutine regrid_core(Ncore,rcore_cm,icore,r1,den1,pres1,m1,X1,Y1,r2,den2,pres2 icore = Ncore -end subroutine regrid_core +end subroutine calc_regrid_core end module setsoftenedcore diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index debf966dd..b13fed568 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -88,7 +88,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& real, intent(inout) :: rcore,mcore integer, intent(out) :: columns_compo character(len=20), allocatable, intent(out) :: comp_label(:) - integer :: ierr,i,eos_type + integer :: ierr,eos_type logical :: calc_polyk,iexist,regrid_core procedure(func), pointer :: get_dPdrho ! @@ -131,7 +131,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& else eos_type = ieos endif - regrid_core = .true. + regrid_core = .false. ! hardwired to be false for now call set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore,mcore,Lstar,r,den,pres,mtab,Xfrac,Yfrac,ierr) hsoft = rcore/radkern @@ -460,7 +460,7 @@ subroutine solve_uT_profiles(eos_type,r,den,pres,Xfrac,Yfrac,regrid_core,temp,en integer, intent(in) :: eos_type real, intent(in) :: r(:),den(:),pres(:),Xfrac(:),Yfrac(:) logical, intent(in) :: regrid_core - real, intent(inout) :: temp(:),en(:),mu(:) + real, allocatable, intent(inout) :: temp(:),en(:),mu(:) integer :: i,ierr real :: guessene,tempi,eni From b80946eb36049ded1ac8718ed42c9455fd457e3c Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 21 Nov 2023 16:20:41 +0100 Subject: [PATCH 179/814] (setfixedentropycore) add initialisation of ierr --- src/setup/set_fixedentropycore.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/setup/set_fixedentropycore.f90 b/src/setup/set_fixedentropycore.f90 index 77404f2da..8bfe0909c 100644 --- a/src/setup/set_fixedentropycore.f90 +++ b/src/setup/set_fixedentropycore.f90 @@ -124,6 +124,7 @@ subroutine calc_rho_and_pres(r,mcore,mh,rho,pres,Xcore,Ycore,iverbose) do mold = mass + ierr = 0 call one_shot(Sc,r,mcore,msoft,mu,rho,pres,mass,iverbose,ierr) ! returned mass is m(r=0) it = it + 1 From 17c0c6b90188dd9fa705d15f1dcd87d0b719f732 Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 22 Nov 2023 13:38:02 +1100 Subject: [PATCH 180/814] (inject_sim) set flag for injected particles --- src/main/inject_sim.f90 | 54 +++++++++++++++++++++++++---------------- 1 file changed, 33 insertions(+), 21 deletions(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index 0d0b28366..eb8aa0f0f 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -15,6 +15,7 @@ module inject ! :Runtime parameters: ! - start_dump : *dump to start looking for particles to inject* ! - r_inject : *radius to inject particles* +! - final_dump : *stop injection after reaching this dump* ! ! :Dependencies: fileutils, io, timestep, units, dump_utils, part, ! readwrite_dumps_fortran, readwrite_dumps_common, partinject, infile_utils @@ -32,9 +33,11 @@ module inject ! global variables - character(len=120) :: start_dump,pre_dump,next_dump + character(len=120) :: start_dump,final_dump,pre_dump,next_dump integer :: npart_sim - real :: r_inject,r_inject_cgs,next_time + real :: r_inject,r_inject_cgs,next_time!,e_inject + real, allocatable :: xyzh_pre(:,:),xyzh_next(:,:),vxyzu_next(:,:),pxyzu_next(:,:) + logical, allocatable :: injected(:) character(len=*), parameter :: label = 'inject_tdeoutflow' @@ -57,11 +60,11 @@ subroutine init_inject(ierr) ! !--find the tde dump at the right time ! - next_dump = start_dump + next_dump = getnextfilename(start_dump) call get_dump_time_npart(trim(next_dump),next_time,ierr,npart_out=npart_sim) ierr = 0 niter = 0 - + do while (next_time < time .and. niter < max_niter) niter = niter + 1 pre_dump = next_dump @@ -78,6 +81,10 @@ subroutine init_inject(ierr) write(*,'(a,1x,es10.2)') ' Start read sims and inject particle from '//trim(next_dump)//' at t =',next_time r_inject = r_inject_cgs/udist ! to code unit + allocate(xyzh_pre(4,npart_sim),xyzh_next(4,npart_sim),vxyzu_next(4,npart_sim),pxyzu_next(4,npart_sim),injected(npart_sim)) + xyzh_pre = 0. + injected = .false. + !e_inject = -1./r_inject end subroutine init_inject @@ -93,23 +100,19 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& integer, intent(inout) :: npart integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject - real, allocatable :: xyzh_pre(:,:),xyzh_next(:,:),vxyzu_next(:,:),pxyzu_next(:,:) integer :: npart_old,ierr real :: tfac - allocate(xyzh_pre(4,npart_sim),xyzh_next(4,npart_sim),vxyzu_next(4,npart_sim),pxyzu_next(4,npart_sim)) - xyzh_pre = 0. ! !--inject particles only if time has reached ! tfac = 1. if (time >= next_time) then ! read next dump - next_dump = getnextfilename(pre_dump) call read_dump(next_dump,xyzh_next,ierr,vxyzu_dump=vxyzu_next,pxyzu_dump=pxyzu_next) npart_old = npart - call inject_required_part(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next,pxyzu_next) + call inject_required_part_tde(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next,pxyzu_next) ! copy to pre for next injection use pre_dump = next_dump @@ -118,8 +121,13 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& call find_next_dump(next_dump,next_time,ierr) start_dump = next_dump - write(*,'(i5,1x,a22)') npart-npart_old, 'particles are injected' + write(*,'(i5,1x,a27,1x,a)') npart-npart_old, 'particles are injected from', trim(pre_dump) + if (pre_dump == final_dump) then + write(*,'(a)') ' Reach the final dumpfile. Stop injecting ...' + next_time = huge(0.) + endif + tfac = 1.d-10 ! set a tiny timestep so the code has time to adjust for timestep endif @@ -209,35 +217,37 @@ subroutine find_next_dump(next_dump,next_time,ierr) end subroutine find_next_dump - subroutine inject_required_part(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next,pxyzu_next) + subroutine inject_required_part_tde(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next,pxyzu_next) use part, only:igas,pxyzu,isdead_or_accreted use partinject, only:add_or_update_particle integer, intent(inout) :: npart, npartoftype(:) real, intent(inout) :: xyzh(:,:), vxyzu(:,:) real, intent(in) :: xyzh_pre(:,:), xyzh_next(:,:), vxyzu_next(:,:), pxyzu_next(:,:) integer :: i,partid - real :: r_next,r_pre,vr_next + real :: r_next,r_pre,vr_next!,e_next ! !--check all the particles ! do i=1,npart_sim - if (.not. isdead_or_accreted(xyzh_next(4,i))) then + if (.not. isdead_or_accreted(xyzh_next(4,i)) .and. .not. injected(i)) then r_next = sqrt(dot_product(xyzh_next(1:3,i),xyzh_next(1:3,i))) r_pre = sqrt(dot_product(xyzh_pre(1:3,i),xyzh_pre(1:3,i))) vr_next = (dot_product(xyzh_next(1:3,i),vxyzu_next(1:3,i)))/r_next + !e_next = 0.5*vr_next**2 - 1./r_next - if (r_next > r_inject .and. r_pre < r_inject .and. vr_next > 0.) then + if (r_next > r_inject .and. r_pre < r_inject .and. vr_next > 0.) then! .and. e_next > e_inject) then ! inject particle by copy the data into position partid = npart+1 call add_or_update_particle(igas,xyzh_next(1:3,i),vxyzu_next(1:3,i),xyzh_next(4,i), & vxyzu_next(4,i),partid,npart,npartoftype,xyzh,vxyzu) pxyzu(:,partid) = pxyzu_next(:,i) + injected(i) = .true. endif endif enddo - end subroutine inject_required_part + end subroutine inject_required_part_tde !----------------------------------------------------------------------- @@ -248,19 +258,21 @@ end subroutine inject_required_part subroutine write_options_inject(iunit) use infile_utils, only: write_inopt integer, intent(in) :: iunit - character(len=10), parameter :: start_dump_default = 'dump_00000' + character(len=10), parameter :: start_dump_default = 'dump_00000', & + final_dump_default = 'dump_02000' real, parameter :: r_inject_default = 5.e14 ! write something meaningful in infile if (r_inject_cgs < tiny(0.)) then start_dump = start_dump_default r_inject_cgs = r_inject_default + final_dump = final_dump_default endif write(iunit,"(/,a)") '# options controlling particle injection' - !call write_inopt(direc,'direc','directory of the tde dumpfiles',iunit) call write_inopt(trim(start_dump),'start_dump','dumpfile to start for injection',iunit) call write_inopt(r_inject_cgs,'r_inject','radius to inject tde outflow (in cm)',iunit) + call write_inopt(trim(final_dump),'final_dump','stop injection after this dump',iunit) end subroutine write_options_inject @@ -280,9 +292,6 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) imatch = .true. igotall = .false. select case(trim(name)) - !case('direc') -! read(valstring,*,iostat=ierr) direc -! ngot = ngot + 1 case('start_dump') read(valstring,*,iostat=ierr) start_dump ngot = ngot + 1 @@ -290,9 +299,12 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) r_inject_cgs ngot = ngot + 1 if (r_inject_cgs < 0.) call fatal(label,'invalid setting for r_inject (<0)') + case('final_dump') + read(valstring,*,iostat=ierr) final_dump + ngot = ngot + 1 end select - igotall = (ngot >= 2) + igotall = (ngot >= 3) end subroutine read_options_inject From 372ce62f35fd2c28644cd41989ae485cef292336 Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 22 Nov 2023 13:39:57 +1100 Subject: [PATCH 181/814] (analysis_radiotde) record initial entropy as background; analyse shock in outflow part and cnm part --- src/utils/analysis_radiotde.f90 | 147 +++++++++++++++++++++++--------- 1 file changed, 108 insertions(+), 39 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 79f10a5e3..996ed2153 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -40,7 +40,9 @@ module analysis real :: v_accum_mean, v_cap_mean real :: e_accum, e_cap integer :: n_accum, n_cap - real :: shock_v, shock_r, shock_e, shock_m, shock_rho + real :: shock_v, rad_min, rad_max, shock_e, shock_m!, shock_rho + real :: shock_v_tde, rad_min_tde, rad_max_tde, shock_e_tde, shock_m_tde!, shock_rho + real :: shock_v_cnm, rad_min_cnm, rad_max_cnm, shock_e_cnm, shock_m_cnm!, shock_rho !---- These can be changed in the params file real :: rad_cap = 1.e16 ! radius where the outflow in captured (in cm) @@ -52,6 +54,10 @@ module analysis real :: phi_min = -90. real :: phi_max = 90. + !--- shock detection global var + integer :: npart_cnm = -1, npart_tde = -1 + real, allocatable :: ent_bg(:) + contains subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) @@ -65,7 +71,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) real, intent(in) :: pmass,time character(len=120) :: output character(len=30) :: filename - integer :: i,ierr + integer :: i,ierr,npart_new,npart_tde_old logical :: iexist real :: toMsun,todays @@ -75,7 +81,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) n_cap = 0 e_accum = 0. e_cap = 0. - ana = 'outflow' + ana = 'shock' toMsun = umass/solarm todays = utime/days @@ -86,11 +92,8 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) endif ! Print the analysis being done - write(*,'("Performing analysis type ",A)') analysistype - write(*,'("Input file name is ",A)') dumpfile - - write(output,"(a8,i5.5)") 'outflow_',numfile - write(*,'("Output file name is ",A)') output + write(*,'(" Performing analysis type ",A)') analysistype + write(*,'(" Input file name is ",A)') dumpfile ! Read black hole mass from params file filename = 'analysis_'//trim(analysistype)//'.params' @@ -101,13 +104,31 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) print*,' Edit '//trim(filename)//' and rerun phantomanalysis' stop endif - + + ! read background entropy + if (npart_cnm < 0) then + if (npart_tde < 0) npart_tde = 10*npart + allocate(ent_bg(npart_tde)) ! save more memory for later injection + npart_cnm = npart + call record_background(pxyzu(4,:),0,npart,ent_bg) + write(*,'(I9,1x,a16)') npart_cnm, 'particles in CNM' + npart_tde = 0 + endif +! not meaningful and will not do anything if cut-and-put + npart_tde_old = npart_tde + npart_tde = npart - npart_cnm + npart_new = npart_tde - npart_tde_old + if (npart_new > 0) call record_background(pxyzu(4,:),npart_tde_old+npart_cnm,npart_new,ent_bg) + + ! allocate memory allocate(rad_all(npart),vr_all(npart),v_all(npart)) call to_rad(npart,xyzh,vxyzu,rad_all,vr_all,v_all) select case (trim(ana)) case ('outflow') write(*,'(a)') ' Analysing the outflow ...' + write(output,"(a8,i5.5)") 'outflow_',numfile + write(*,'(" Output file name is ",A)') output rad_cap = rad_cap/udist if (drad_cap < 0.) then @@ -190,15 +211,17 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) open(iunit,file='shock',status='old',position='append') else open(iunit,file='shock',status='new') - write(iunit,'(7(A,1x))') '#', 'time', 'radius[cm]', 'velocity[c]', 'mass[Msun]', 'energy[erg]', 'density[g/cm-3]' + write(iunit,'(17(A,1x))') '#', 'time', 'rad_min[cm]', 'rad_max[cm]', 'velocity[c]', 'mass[Msun]', 'energy[erg]', & !'density[g/cm-3]' + 'rad_min_tde[cm]', 'rad_max_tde[cm]', 'vel_tde[c]', 'mass_tde[Msun]', 'ene_tde[erg]', & + 'rad_min_cnm[cm]', 'rad_max_cnm[cm]', 'vel_cnm[c]', 'mass_cnm[Msun]', 'ene_cnm[erg]' endif - write(iunit,'(6(es18.10,1x))') & + if (rad_max > 0.) then + write(iunit,'(16(es18.10,1x))') & time*todays, & - shock_r*udist, & - shock_v, & - shock_m*umass/solarm, & - shock_e*unit_energ, & - shock_rho*unit_density + rad_min*udist, rad_max*udist, shock_v, shock_m*umass/solarm, shock_e*unit_energ, & + rad_min_tde*udist, rad_max_tde*udist, shock_v_tde, shock_m_tde*umass/solarm, shock_e_tde*unit_energ, & + rad_min_cnm*udist, rad_max_cnm*udist, shock_v_cnm, shock_m_cnm*umass/solarm, shock_e_cnm*unit_energ !shock_rho*unit_density + endif close(iunit) case default @@ -295,42 +318,86 @@ subroutine outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all) end subroutine outflow_analysis -subroutine shock_analysis(npart,pmass,rad_all,vr_all,ents) +subroutine record_background(ent,npart_old,npart_new,ent_bg) + real, intent(in) :: ent(:) + integer, intent(in) :: npart_old,npart_new + real, intent(inout) :: ent_bg(:) + integer, parameter :: iunit=235 + integer :: ierr,i + + print*, 'Record background entropy of ', npart_new, ' particles' + + do i=1,npart_new + ent_bg(npart_old+i) = ent(npart_old+i)*1.1 ! give some range for self evolution + !(is there a reasonable choice instead of arbitrary?) + enddo + +end subroutine record_background + +subroutine shock_analysis(npart,pmass,rad_all,vr_all,ent) use units, only: udist use physcon, only: au,pi integer, intent(in) :: npart - real, intent(in) :: pmass,rad_all(:),vr_all(:),ents(:) - integer :: imin,i,n - real :: rad_max,ri,half_m,rad_min,v_add + real, intent(in) :: pmass,rad_all(:),vr_all(:),ent(:) + integer :: imin,i,n,n_cnm,n_tde + real :: ri,half_m,ei,vi ! - !------Determine the radius range of the shock + !------Determine the shock ! - imin = maxloc(ents(:),dim=1) - rad_min = rad_all(imin) - shock_v = vr_all(imin) - - rad_max = 0. - do i = 1,npart - ri = rad_all(i) - if (ents(i) > 3.5e5 .and. ri < 6.5e6 .and. ri > rad_max) rad_max = ri - enddo - write(*,'(a25,1x,es8.1,1x,a5,1x,es8.1,1x,a2)') ' Shock is determined from', shock_r*udist/au, 'au to', rad_max*udist/au, 'au' - shock_r = rad_min - n = 0 + n_cnm = 0. + n_tde = 0. shock_e = 0. + shock_e_cnm = 0. + shock_e_tde = 0. + shock_v = 0. ! take max vel + shock_v_cnm = 0. + shock_v_tde = 0. + rad_max = 0. + rad_max_cnm = 0. + rad_max_tde = 0. + rad_min = huge(0.) + rad_min_cnm = huge(0.) + rad_min_tde = huge(0.) half_m = pmass*0.5 + do i = 1,npart - ri = rad_all(i) - if (ri > rad_min .and. ri < rad_max .and. ents(i) > 3.5e5) then + if (ent(i) > ent_bg(i)) then + ri = rad_all(i) + vi = vr_all(i) + ei = half_m*vi**2 n = n + 1 - shock_e = shock_e + half_m*vr_all(i)**2 + if (vi > shock_v) shock_v = vi + if (ri < rad_min) rad_min = ri + if (ri > rad_max) rad_max = ri + shock_e = shock_e + ei + + if (i > npart_cnm) then + ! tde outflow + n_tde = n_tde + 1 + if (vi > shock_v_tde) shock_v_tde = vi + if (ri < rad_min_tde) rad_min_tde = ri + if (ri > rad_max_tde) rad_max_tde = ri + shock_e_tde = shock_e_tde + ei + else + ! cnm + n_cnm = n_cnm + 1 + if (vi > shock_v_cnm) shock_v_cnm = vi + if (ri < rad_min_cnm) rad_min_cnm = ri + if (ri > rad_max_cnm) rad_max_cnm = ri + shock_e_cnm = shock_e_cnm + ei + endif endif enddo + + write(*,'(a14,1x,es8.1,1x,a5,1x,es8.1,1x,a2)') ' Shock is from', rad_min*udist/au, 'au to', rad_max*udist/au, 'au' + shock_m = pmass*n - shock_rho = shock_m*4./3.*pi*(rad_max**3-rad_min**3) + shock_m_cnm = pmass*n_cnm + shock_m_tde = pmass*n_tde + !shock_rho = shock_m*4./3.*pi*(rad_max**3-rad_min**3) -end subroutine +end subroutine shock_analysis !---------------------------------------------------------------- !+ @@ -361,6 +428,7 @@ subroutine write_tdeparams(filename) call write_inopt(phi_min,'phi_min','min phi (in deg)',iunit) call write_inopt(phi_max,'phi_max','max phi (in deg)',iunit) case ('shock') + call write_inopt(npart_tde,'npart_tde','npart in tde sims',iunit) case default end select @@ -377,7 +445,7 @@ subroutine read_tdeparams(filename,ierr) integer :: nerr type(inopts), allocatable :: db(:) - print "(a)",'reading analysis options from '//trim(filename) + print "(a)",' reading analysis options from '//trim(filename) nerr = 0 ierr = 0 call open_db_from_file(db,filename,iunit,ierr) @@ -398,6 +466,7 @@ subroutine read_tdeparams(filename,ierr) call read_inopt(phi_min,'phi_min',db,min=-90.,max=90.,errcount=nerr) call read_inopt(phi_max,'phi_max',db,min=-90.,max=90.,errcount=nerr) case ('shock') + call read_inopt(npart_tde,'npart_tde',db,min=0,errcount=nerr) case default end select From f2722900bce4bc1da79471ac161d7ea00798d807 Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 22 Nov 2023 13:40:42 +1100 Subject: [PATCH 182/814] (moddump_radiotde) change default tmax to three years --- src/utils/moddump_radiotde.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 51f96345b..27a246149 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -228,7 +228,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) enddo !--Set timesteps - tmax = 10.*years/utime + tmax = 3.*years/utime dtmax = tmax/1000. end subroutine modify_dump From cbe865267f07e0137abd82465c7e2cedeae461eb Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 22 Nov 2023 15:31:08 +0100 Subject: [PATCH 183/814] (set_softened_core) initialise ierr --- src/setup/set_softened_core.f90 | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index 19e950d11..9fea7e0b4 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -51,6 +51,7 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore, logical :: isort_decreasing,iexclude_core_mass real, allocatable :: r1(:),den1(:),pres1(:),m1(:),X1(:),Y1(:) + ierr = 0 write(*,'(/,1x,a)') 'Setting softened core profile' ! Output data to be sorted from stellar surface to interior? isort_decreasing = .true. ! Needs to be true if to be read by Phantom @@ -85,7 +86,13 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore, call interpolator(r,rc,core_index) ! find index of core X(1:core_index) = Xcore Y(1:core_index) = yinterp(Y,r,rc) - + if (eos_type==10) then + X_in = Xcore + Z_in = Zcore + if (ierr /= 0) call fatal('set_softened_core','could not initialise equation of state') + endif + call init_eos(eos_type,ierr) ! need to initialise EoS again with newfound composition (also needed for iopacity_type = 1) + if (regrid_core) then ! make copy of original arrays npts = size(r) From 544f299f9945e99b9a81f664a1b8f45f52cc9664 Mon Sep 17 00:00:00 2001 From: fhu Date: Thu, 23 Nov 2023 12:24:07 +1100 Subject: [PATCH 184/814] (inject_sim) add subroutine set_default_options_inject --- src/main/inject_sim.f90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index eb8aa0f0f..974c13afe 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -308,4 +308,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) end subroutine read_options_inject +subroutine set_default_options_inject(flag) + integer, optional, intent(in) :: flag + +end subroutine set_default_options_inject + end module inject From b6cf1d167665ca0204fac4a2affc1810c977d8b8 Mon Sep 17 00:00:00 2001 From: fhu Date: Thu, 23 Nov 2023 12:24:44 +1100 Subject: [PATCH 185/814] (analysis_radiotde) remove unused variables --- src/utils/analysis_radiotde.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 996ed2153..d710923d1 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -62,7 +62,7 @@ module analysis subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) use readwrite_dumps, only: opened_full_dump - use units, only: utime,udist,unit_energ,umass,unit_density + use units, only: utime,udist,unit_energ,umass!,unit_density use physcon, only: solarm,days use part, only: pxyzu character(len=*), intent(in) :: dumpfile @@ -323,7 +323,7 @@ subroutine record_background(ent,npart_old,npart_new,ent_bg) integer, intent(in) :: npart_old,npart_new real, intent(inout) :: ent_bg(:) integer, parameter :: iunit=235 - integer :: ierr,i + integer :: i print*, 'Record background entropy of ', npart_new, ' particles' @@ -339,7 +339,7 @@ subroutine shock_analysis(npart,pmass,rad_all,vr_all,ent) use physcon, only: au,pi integer, intent(in) :: npart real, intent(in) :: pmass,rad_all(:),vr_all(:),ent(:) - integer :: imin,i,n,n_cnm,n_tde + integer :: i,n,n_cnm,n_tde real :: ri,half_m,ei,vi ! !------Determine the shock From 39ec84e319e20cbda54fecf9e362c6770bc4b164 Mon Sep 17 00:00:00 2001 From: fhu Date: Thu, 23 Nov 2023 15:24:44 +1100 Subject: [PATCH 186/814] (inject_sim) make set_default_options_inject public --- src/main/inject_sim.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index 974c13afe..bf33f0e89 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -25,7 +25,8 @@ module inject implicit none character(len=*), parameter, public :: inject_type = 'sim' - public :: init_inject,inject_particles,write_options_inject,read_options_inject + public :: init_inject,inject_particles,write_options_inject,read_options_inject, & + set_default_options_inject private ! !--runtime settings for this module From f88ee8c2c7cde1ea9a153400394151116346898e Mon Sep 17 00:00:00 2001 From: fhu Date: Thu, 23 Nov 2023 15:26:04 +1100 Subject: [PATCH 187/814] (analysis_radiotde) use different var names for background entropy memory allocation --- src/utils/analysis_radiotde.f90 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index d710923d1..ca682ec80 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -55,7 +55,7 @@ module analysis real :: phi_max = 90. !--- shock detection global var - integer :: npart_cnm = -1, npart_tde = -1 + integer :: npart_cnm = -1, npart_tde, npart_tde_reserve=-1 real, allocatable :: ent_bg(:) contains @@ -107,12 +107,11 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) ! read background entropy if (npart_cnm < 0) then - if (npart_tde < 0) npart_tde = 10*npart - allocate(ent_bg(npart_tde)) ! save more memory for later injection + if (npart_tde_reserve < 0) npart_tde_reserve = 10*npart + allocate(ent_bg(npart_tde_reserve+npart)) ! save more memory for later injection npart_cnm = npart call record_background(pxyzu(4,:),0,npart,ent_bg) write(*,'(I9,1x,a16)') npart_cnm, 'particles in CNM' - npart_tde = 0 endif ! not meaningful and will not do anything if cut-and-put npart_tde_old = npart_tde @@ -428,7 +427,7 @@ subroutine write_tdeparams(filename) call write_inopt(phi_min,'phi_min','min phi (in deg)',iunit) call write_inopt(phi_max,'phi_max','max phi (in deg)',iunit) case ('shock') - call write_inopt(npart_tde,'npart_tde','npart in tde sims',iunit) + call write_inopt(npart_tde_reserve,'npart_tde','npart in tde sims (-ve=10*npart of cnm)',iunit) case default end select @@ -466,7 +465,7 @@ subroutine read_tdeparams(filename,ierr) call read_inopt(phi_min,'phi_min',db,min=-90.,max=90.,errcount=nerr) call read_inopt(phi_max,'phi_max',db,min=-90.,max=90.,errcount=nerr) case ('shock') - call read_inopt(npart_tde,'npart_tde',db,min=0,errcount=nerr) + call read_inopt(npart_tde_reserve,'npart_tde',db,min=0,errcount=nerr) case default end select From f80b5ec543c3014b2530db14dabe1d3ff6f10eb9 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 10:09:12 +1100 Subject: [PATCH 188/814] (build) use -g not -gdwarf-2 in default gfortran debugging flags --- build/Makefile_defaults_gfortran | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build/Makefile_defaults_gfortran b/build/Makefile_defaults_gfortran index 78de58f33..02a0dfdfe 100644 --- a/build/Makefile_defaults_gfortran +++ b/build/Makefile_defaults_gfortran @@ -12,7 +12,7 @@ # endif # FC= gfortran -FFLAGS+= -O3 -Wall -Wno-unused-dummy-argument -frecord-marker=4 -gdwarf-2 \ +FFLAGS+= -O3 -Wall -Wno-unused-dummy-argument -frecord-marker=4 -g \ -finline-functions-called-once -finline-limit=1500 -funroll-loops -ftree-vectorize \ -std=f2008 -fall-intrinsics DBLFLAG= -fdefault-real-8 -fdefault-double-8 From 75c952747541096d3d25523cf6172a9e2872ac03 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 10:19:44 +1100 Subject: [PATCH 189/814] (radiation) unused variable warnings fixed --- src/main/radiation_implicit.f90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index f93abf079..450956569 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -423,7 +423,7 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv real, intent(out) :: vari(:,:),EU0(6,npart),varij(2,icompactmax),varij2(4,icompactmax) integer :: n,i,j,k,icompact real :: pmi,hi,hi21,hi41,rhoi,dx,dy,dz,rij2,rij,rij1,dr,dti,& - pmj,rhoj,hj,hj21,hj41,v2i,vi,v2j,vj,dWi,dWj,rhomean,& + pmj,rhoj,hj,hj21,hj41,v2i,vi,v2j,vj,dWi,dWj,& c_code,dWidrlightrhorhom,dWjdrlightrhorhom,& xi,yi,zi,gradhi,pmjdWrijrhoi,pmjdWrunix,pmjdWruniy,pmjdWruniz,& dust_kappai,dust_cooling,heatingISRi,dust_gas @@ -432,7 +432,7 @@ subroutine fill_arrays(ncompact,ncompactlocal,npart,icompactmax,dt,xyzh,vxyzu,iv !$omp do & !$omp private(n,i,j,k,rhoi,icompact,pmi,dti) & !$omp private(dx,dy,dz,rij2,rij,rij1,dr,pmj,rhoj,hi,hj,hi21,hj21,hi41,hj41) & - !$omp private(v2i,vi,v2j,vj,dWi,dWj,rhomean) & + !$omp private(v2i,vi,v2j,vj,dWi,dWj) & !$omp private(xi,yi,zi,gradhi,dWidrlightrhorhom,pmjdWrijrhoi,dWjdrlightrhorhom) & !$omp private(pmjdWrunix,pmjdWruniy,pmjdWruniz,dust_kappai,dust_cooling,heatingISRi,dust_gas) @@ -553,12 +553,12 @@ subroutine compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,va real, intent(out) :: varinew(3,npart) ! we use this parallel loop to set varinew to zero integer :: i,j,k,n,icompact real :: rhoi,rhoj,pmjdWrunix,pmjdWruniy,pmjdWruniz,dedx(3),dradenij,rhoiEU0 - real :: gradE1i,opacity,radRi,EU01i + real :: opacity,radRi,EU01i !$omp do schedule(runtime)& !$omp private(i,j,k,n,dedx,rhoi,rhoj,icompact)& !$omp private(pmjdWrunix,pmjdWruniy,pmjdWruniz,dradenij)& - !$omp private(gradE1i,opacity,radRi,EU01i) + !$omp private(opacity,radRi,EU01i) do n = 1,ncompact i = ivar(3,n) @@ -632,12 +632,12 @@ subroutine calc_diffusion_term(ivar,ijvar,varij,ncompact,npart,icompactmax, & real, intent(inout) :: varinew(3,npart) integer :: n,i,j,k,icompact real :: rhoi,rhoj,opacityi,opacityj,Ej,bi,bj,b1,dWdrlightrhorhom - real :: diffusion_numerator,diffusion_denominator,tempval1,tempval2 + real :: diffusion_numerator,diffusion_denominator ierr = 0 !$omp do schedule(runtime)& !$omp private(i,j,k,n,rhoi,rhoj,opacityi,opacityj,Ej,bi,bj,b1,diffusion_numerator,diffusion_denominator)& - !$omp private(dWdrlightrhorhom,tempval1,tempval2,icompact)& + !$omp private(dWdrlightrhorhom,icompact)& !$omp reduction(max:ierr) do n = 1,ncompact i = ivar(3,n) @@ -721,7 +721,7 @@ subroutine update_gas_radiation_energy(ivar,vari,npart,ncompactlocal,& logical, intent(in) :: store_drad logical, intent(out):: moresweep logical, intent(inout):: mask(npart) - integer :: i,j,n,ieqtype,ierr + integer :: i,n,ieqtype,ierr logical :: moresweep2,skip_quartic real :: dti,rhoi,diffusion_numerator,diffusion_denominator,gradEi2,gradvPi,rpdiag,rpall real :: radpresdenom,stellarradiation,gas_temp,xnH2,betaval,gammaval,tfour,betaval_d,chival @@ -729,7 +729,7 @@ subroutine update_gas_radiation_energy(ivar,vari,npart,ncompactlocal,& real :: cosmic_ray,cooling_line,photoelectric,h2form,dust_heating,dust_term,e_planetesimali real :: u4term,u1term,u0term,pcoleni,dust_cooling,heatingISRi,dust_gas real :: pres_numerator,pres_denominator,mui,U1i,E1i,Tgas,dUcomb,dEcomb - real :: residualE,residualU,xchange,maxerrU2old,Tgas4,Trad4,ck,ack + real :: residualE,residualU,maxerrU2old,Tgas4,Trad4,ck,ack real :: Ei,Ui,cvi,opacityi,eddi real :: maxerrE2i,maxerrU2i @@ -742,12 +742,12 @@ subroutine update_gas_radiation_energy(ivar,vari,npart,ncompactlocal,& !$omp end single !$omp do schedule(runtime)& - !$omp private(i,j,n,rhoi,dti,diffusion_numerator,diffusion_denominator,U1i,skip_quartic,Tgas,E1i,dUcomb,dEcomb) & + !$omp private(i,n,rhoi,dti,diffusion_numerator,diffusion_denominator,U1i,skip_quartic,Tgas,E1i,dUcomb,dEcomb) & !$omp private(gradEi2,gradvPi,rpdiag,rpall,radpresdenom,stellarradiation,dust_tempi,dust_kappai,xnH2) & !$omp private(dust_cooling,heatingISRi,dust_gas,gas_dust_val,dustgammaval,gas_dust_cooling,cosmic_ray) & !$omp private(cooling_line,photoelectric,h2form,dust_heating,dust_term,betaval,chival,gammaval,betaval_d,tfour) & !$omp private(e_planetesimali,u4term,u1term,u0term,pcoleni,pres_numerator,pres_denominator,moresweep2,mui,ierr) & - !$omp private(residualE,residualU,xchange,maxerrU2old,gas_temp,ieqtype,unit_density,Tgas4,Trad4,ck,ack) & + !$omp private(residualE,residualU,maxerrU2old,gas_temp,ieqtype,unit_density,Tgas4,Trad4,ck,ack) & !$omp private(maxerrE2i,maxerrU2i) & !$omp reduction(max:maxerrE2,maxerrU2) main_loop: do n = 1,ncompactlocal From 8b42870aa5930f8d39e0c9eb0dbed374f991c83d Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 10:50:11 +1100 Subject: [PATCH 190/814] (test_gravity) maybe-unused warning fixed --- src/tests/test_gravity.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/test_gravity.f90 b/src/tests/test_gravity.f90 index ec23df777..ee2bb7069 100644 --- a/src/tests/test_gravity.f90 +++ b/src/tests/test_gravity.f90 @@ -263,6 +263,7 @@ subroutine test_directsum(ntests,npass) real :: epoti,tree_acc_prev real, allocatable :: fgrav(:,:),fxyz_ptmass_gas(:,:) + maxvxyzu = size(vxyzu(:,1)) tree_acc_prev = tree_accuracy do k = 1,6 if (labeltype(k)/='bound') then @@ -282,7 +283,6 @@ subroutine test_directsum(ntests,npass) ! call init_part() np = 1000 - maxvxyzu = size(vxyzu(:,1)) totvol = 4./3.*pi*rmax**3 nx = int(np**(1./3.)) psep = totvol**(1./3.)/real(nx) From 3caee7a95b3f01851238518456979a8ded058152 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 10:50:34 +1100 Subject: [PATCH 191/814] (test_sedov; #55) remove ifdefs --- src/tests/test_sedov.F90 | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/src/tests/test_sedov.F90 b/src/tests/test_sedov.F90 index 268ad74e3..a70797345 100644 --- a/src/tests/test_sedov.F90 +++ b/src/tests/test_sedov.F90 @@ -30,7 +30,7 @@ module testsedov !+ !----------------------------------------------------------------------- subroutine test_sedov(ntests,npass) - use dim, only:maxp,maxvxyzu,maxalpha,use_dust,periodic,do_radiation + use dim, only:maxp,maxvxyzu,maxalpha,use_dust,periodic,do_radiation,ind_timesteps use io, only:id,master,iprint,ievfile,iverbose,real4 use boundary, only:set_boundary,xmin,xmax,ymin,ymax,zmin,zmax,dxbound,dybound,dzbound use unifdis, only:set_unifdis @@ -43,9 +43,7 @@ subroutine test_sedov(ntests,npass) use deriv, only:get_derivs_global use timestep, only:time,tmax,dtmax,C_cour,C_force,dt,tolv,bignumber use units, only:set_units -#ifndef IND_TIMESTEPS use timestep, only:dtcourant,dtforce,dtrad -#endif use testutils, only:checkval,update_test_scores use evwrite, only:init_evfile,write_evfile use energies, only:etot,totmom,angtot,mdust @@ -67,10 +65,10 @@ subroutine test_sedov(ntests,npass) real :: temp character(len=20) :: logfile,evfile,dumpfile -#ifndef PERIODIC - if (id==master) write(*,"(/,a)") '--> SKIPPING Sedov blast wave (needs -DPERIODIC)' - return -#endif + if (.not.periodic) then + if (id==master) write(*,"(/,a)") '--> SKIPPING Sedov blast wave (needs -DPERIODIC)' + return + endif #ifdef DISC_VISCOSITY if (id==master) write(*,"(/,a)") '--> SKIPPING Sedov blast wave (cannot use -DDISC_VISCOSITY)' return @@ -154,9 +152,7 @@ subroutine test_sedov(ntests,npass) ! !--now call evolve ! -#ifndef IND_TIMESTEPS - dt = min(dtcourant,dtforce,dtrad) -#endif + if (.not.ind_timesteps) dt = min(dtcourant,dtforce,dtrad) call init_step(npart,time,dtmax) iprint = 6 logfile = 'test01.log' From 45860c0892b989a16b67f6ff2d1fd7a1f10a59d2 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 10:52:08 +1100 Subject: [PATCH 192/814] (#484) fix slow tests on github actions --- .github/workflows/mpi.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/mpi.yml b/.github/workflows/mpi.yml index 9bbf3e6df..acd28d60c 100644 --- a/.github/workflows/mpi.yml +++ b/.github/workflows/mpi.yml @@ -43,7 +43,7 @@ jobs: env: OMP_STACKSIZE: 512M - OMP_NUM_THREADS: 4 + OMP_NUM_THREADS: 2 steps: From d0c1870284fc32b6511362978856f49ab274d749 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 10:58:24 +1100 Subject: [PATCH 193/814] (interp3D) cleanup --- src/utils/interpolate3D.F90 | 315 +----------------------------------- 1 file changed, 4 insertions(+), 311 deletions(-) diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index 5e1196284..00503ad41 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -16,19 +16,14 @@ module interpolations3D ! ! :Dependencies: einsteintk_utils, kernel ! - !---------------------------------------------------------------------- ! ! Module containing all of the routines required for interpolation ! from 3D data to a 3D grid (SLOW!) ! !---------------------------------------------------------------------- - use einsteintk_utils, only:exact_rendering - use kernel, only:radkern2,radkern,cnormk,wkern!,wallint ! Moved to this module - !use interpolation, only:iroll ! Moved to this module - - !use timing, only:wall_time,print_time ! Using cpu_time for now + use kernel, only:radkern2,radkern,cnormk,wkern implicit none integer, parameter :: doub_prec = kind(0.d0) real :: cnormk3D = cnormk @@ -70,7 +65,6 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& integer, intent(in) :: npart,npixx,npixy,npixz real, intent(in) :: xyzh(4,npart) -!real, intent(in), dimension(npart) :: x,y,z,hh ! change to xyzh() real, intent(in), dimension(npart) :: weight,dat integer, intent(in), dimension(npart) :: itype real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz @@ -97,7 +91,6 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !logical, parameter :: exact_rendering = .true. ! use exact rendering y/n integer :: usedpart, negflag - !$ integer :: omp_get_num_threads,omp_get_thread_num integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits @@ -106,16 +99,9 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& y(:) = xyzh(2,:) z(:) = xyzh(3,:) hh(:) = xyzh(4,:) -!print*, "smoothing length: ", hh(1:10) -! cnormk3D set the value from the kernel routine cnormk3D = cnormk radkernel = radkern radkernel2 = radkern2 -! print*, "radkern: ", radkern -! print*, "radkernel: ",radkernel -! print*, "radkern2: ", radkern2 - -! print*, "npix: ", npixx, npixy,npixz if (exact_rendering) then print "(1x,a)",'interpolating to 3D grid (exact/Petkova+2018 on subgrid) ...' @@ -160,11 +146,6 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& xminpix = xmin !- 0.5*pixwidthx yminpix = ymin !- 0.5*pixwidthy zminpix = zmin !- 0.5*pixwidthz -! print*, "xminpix: ", xminpix -! print*, "yminpix: ", yminpix -! print*, "zminpix: ", zminpix -! print*, "dat: ", dat(1:10) -! print*, "weights: ", weight(1:10) pixwidthmax = max(pixwidthx,pixwidthy,pixwidthz) ! !--use a minimum smoothing length on the grid to make @@ -277,15 +258,12 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& ! !--precalculate an array of dx2 for this particle (optimisation) ! -! Check the x position of the grid cells -!open(unit=677,file="posxgrid.txt",action='write',position='append') nxpix = 0 do ipix=ipixmin,ipixmax nxpix = nxpix + 1 ipixi = ipix if (periodicx) ipixi = iroll(ipix,npixx) xpixi = xminpix + ipix*pixwidthx - !write(677,*) ipix, xpixi !--watch out for errors with periodic wrapping... if (nxpix <= size(dx2i)) then dx2i(nxpix) = ((xpixi - xi)**2)*hi21 @@ -415,13 +393,6 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& call cpu_time(t_end) t_used = t_end - t_start print*, 'Interpolate3D completed in ',t_end-t_start,'s' -!if (t_used > 10.) call print_time(t_used) - -!print*, 'Number of particles in the volume: ', usedpart -! datsmooth(1,1,1) = 3.14159 -! datsmooth(32,32,32) = 3.145159 -! datsmooth(11,11,11) = 3.14159 -! datsmooth(10,10,10) = 3.145159 end subroutine interpolate3D @@ -441,7 +412,7 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !logical, intent(in), exact_rendering real, allocatable :: datnorm(:,:,:) - integer :: i,ipix,jpix,kpix,lockindex,smoothindex + integer :: i,ipix,jpix,kpix,smoothindex integer :: iprintinterval,iprintnext integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax integer :: ipixi,jpixi,kpixi,nxpix,nwarn,threadid @@ -561,7 +532,7 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & !$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & - !$omp private(pixint,wint,negflag,dfac,threadid,lockindex,smoothindex) & + !$omp private(pixint,wint,negflag,dfac,threadid,smoothindex) & !$omp firstprivate(iprintnext) & !$omp reduction(+:nwarn,usedpart) !$omp master @@ -644,15 +615,12 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& ! !--precalculate an array of dx2 for this particle (optimisation) ! - ! Check the x position of the grid cells - !open(unit=677,file="posxgrid.txt",action='write',position='append') nxpix = 0 do ipix=ipixmin,ipixmax nxpix = nxpix + 1 ipixi = ipix if (periodicx) ipixi = iroll(ipix,npixx) xpixi = xminpix + ipix*pixwidthx - !write(677,*) ipix, xpixi !--watch out for errors with periodic wrapping... if (nxpix <= size(dx2i)) then dx2i(nxpix) = ((xpixi - xi)**2)*hi21 @@ -732,24 +700,14 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& ! !--calculate data value at this pixel using the summation interpolant ! - ! Find out where this pixel sits in the lock array - ! lockindex = (k-1)*nx*ny + (j-1)*nx + i - !lockindex = (kpixi-1)*npixx*npixy + (jpixi-1)*npixx + ipixi - !!$call omp_set_lock(ilock(lockindex)) - !!$omp critical (datsmooth) do smoothindex=1, ilendat !$omp atomic datsmooth(smoothindex,ipixi,jpixi,kpixi) = datsmooth(smoothindex,ipixi,jpixi,kpixi) + term(smoothindex)*wab enddo - !!$omp end critical (datsmooth) if (normalise) then !$omp atomic - !!$omp critical (datnorm) datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - !!$omp end critical (datnorm) - endif - - !!$call omp_unset_lock(ilock(lockindex)) + endif endif else if (q2 < radkernel2) then @@ -761,25 +719,14 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& ! !--calculate data value at this pixel using the summation interpolant ! - !!$omp atomic ! Atomic statmements only work with scalars - !!$omp set lock ! Does this work with an array? - ! Find out where this pixel sits in the lock array - ! lockindex = (k-1)*nx*ny + (j-1)*nx + i - !lockindex = (kpixi-1)*npixx*npixy + (jpixi-1)*npixx + ipixi - !!$call omp_set_lock(ilock(lockindex)) - !!$omp critical (datsmooth) do smoothindex=1,ilendat !$omp atomic datsmooth(smoothindex,ipixi,jpixi,kpixi) = datsmooth(smoothindex,ipixi,jpixi,kpixi) + term(smoothindex)*wab enddo - !!$omp end critical (datsmooth) if (normalise) then !$omp atomic - !!$omp critical (datnorm) datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - !!$omp end critical (datnorm) endif - !!$call omp_unset_lock(ilock(lockindex)) endif endif @@ -790,11 +737,6 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !$omp enddo !$omp end parallel -!!$ do i=1,npixx*npixy*npixz -!!$ call omp_destroy_lock(ilock(i)) -!!$ enddo -!!$ if (allocated(ilock)) deallocate(ilock) - if (nwarn > 0) then print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& ' that wrap periodic boundaries more than once' @@ -812,261 +754,12 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& endif if (allocated(datnorm)) deallocate(datnorm) - !call wall_time(t_end) call cpu_time(t_end) t_used = t_end - t_start print*, 'Interpolate3DVec completed in ',t_end-t_start,'s' - !if (t_used > 10.) call print_time(t_used) - - !print*, 'Number of particles in the volume: ', usedpart - ! datsmooth(1,1,1) = 3.14159 - ! datsmooth(32,32,32) = 3.145159 - ! datsmooth(11,11,11) = 3.14159 - ! datsmooth(10,10,10) = 3.145159 end subroutine interpolate3D_vecexact - ! subroutine interpolate3D_vec(x,y,z,hh,weight,datvec,itype,npart,& - ! xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& - ! normalise,periodicx,periodicy,periodicz) - - ! integer, intent(in) :: npart,npixx,npixy,npixz - ! real, intent(in), dimension(npart) :: x,y,z,hh,weight - ! real, intent(in), dimension(npart,3) :: datvec - ! integer, intent(in), dimension(npart) :: itype - ! real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz - ! real(doub_prec), intent(out), dimension(3,npixx,npixy,npixz) :: datsmooth - ! logical, intent(in) :: normalise,periodicx,periodicy,periodicz - ! real(doub_prec), dimension(npixx,npixy,npixz) :: datnorm - - ! integer :: i,ipix,jpix,kpix - ! integer :: iprintinterval,iprintnext - ! integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax - ! integer :: ipixi,jpixi,kpixi,nxpix,nwarn - ! real :: xminpix,yminpix,zminpix - ! real, dimension(npixx) :: dx2i - ! real :: xi,yi,zi,hi,hi1,hi21,radkern,wab,q2,const,dyz2,dz2 - ! real :: termnorm,dy,dz,ypix,zpix,xpixi,ddatnorm - ! real, dimension(3) :: term - ! !real :: t_start,t_end - ! logical :: iprintprogress - ! !$ integer :: omp_get_num_threads - ! integer(kind=selected_int_kind(10)) :: iprogress ! up to 10 digits - - ! datsmooth = 0. - ! datnorm = 0. - ! if (normalise) then - ! print "(1x,a)",'interpolating to 3D grid (normalised) ...' - ! else - ! print "(1x,a)",'interpolating to 3D grid (non-normalised) ...' - ! endif - ! if (pixwidthx <= 0. .or. pixwidthy <= 0. .or. pixwidthz <= 0.) then - ! print "(1x,a)",'interpolate3D: error: pixel width <= 0' - ! return - ! endif - ! if (any(hh(1:npart) <= tiny(hh))) then - ! print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' - ! endif - - ! ! - ! !--print a progress report if it is going to take a long time - ! ! (a "long time" is, however, somewhat system dependent) - ! ! - ! iprintprogress = (npart >= 100000) .or. (npixx*npixy > 100000) - ! !$ iprintprogress = .false. - ! ! - ! !--loop over particles - ! ! - ! iprintinterval = 25 - ! if (npart >= 1e6) iprintinterval = 10 - ! iprintnext = iprintinterval - ! ! - ! !--get starting CPU time - ! ! - ! !call cpu_time(t_start) - - ! xminpix = xmin - 0.5*pixwidthx - ! yminpix = ymin - 0.5*pixwidthy - ! zminpix = zmin - 0.5*pixwidthz - - ! const = cnormk3D ! normalisation constant (3D) - ! nwarn = 0 - - ! !$omp parallel default(none) & - ! !$omp shared(hh,z,x,y,weight,datvec,itype,datsmooth,npart) & - ! !$omp shared(xmin,ymin,zmin,radkernel,radkernel2) & - ! !$omp shared(xminpix,yminpix,zminpix,pixwidthx,pixwidthy,pixwidthz) & - ! !$omp shared(npixx,npixy,npixz,const) & - ! !$omp shared(iprintprogress,iprintinterval) & - ! !$omp shared(datnorm,normalise,periodicx,periodicy,periodicz) & - ! !$omp private(hi,xi,yi,zi,radkern,hi1,hi21) & - ! !$omp private(term,termnorm,xpixi) & - ! !$omp private(iprogress,iprintnext) & - ! !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) & - ! !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi) & - ! !$omp private(dx2i,nxpix,zpix,dz,dz2,dyz2,dy,ypix,q2,wab) & - ! !$omp reduction(+:nwarn) - ! !$omp master - ! !$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' - ! !$omp end master - ! ! - ! !--loop over particles - ! ! - ! !$omp do schedule (guided, 2) - ! over_parts: do i=1,npart - ! ! - ! !--report on progress - ! ! - ! if (iprintprogress) then - ! iprogress = 100*i/npart - ! if (iprogress >= iprintnext) then - ! write(*,"('(',i3,'% -',i12,' particles done)')") iprogress,i - ! iprintnext = iprintnext + iprintinterval - ! endif - ! endif - ! ! - ! !--skip particles with itype < 0 - ! ! - ! if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts - - ! hi = hh(i) - ! if (hi <= 0.) cycle over_parts - - ! ! - ! !--set kernel related quantities - ! ! - ! xi = x(i) - ! yi = y(i) - ! zi = z(i) - - ! hi1 = 1./hi - ! hi21 = hi1*hi1 - ! radkern = radkernel*hi ! radius of the smoothing kernel - ! termnorm = const*weight(i) - ! term(:) = termnorm*datvec(i,:) - ! ! - ! !--for each particle work out which pixels it contributes to - ! ! - ! ipixmin = int((xi - radkern - xmin)/pixwidthx) - ! jpixmin = int((yi - radkern - ymin)/pixwidthy) - ! kpixmin = int((zi - radkern - zmin)/pixwidthz) - ! ipixmax = int((xi + radkern - xmin)/pixwidthx) + 1 - ! jpixmax = int((yi + radkern - ymin)/pixwidthy) + 1 - ! kpixmax = int((zi + radkern - zmin)/pixwidthz) + 1 - - ! if (.not.periodicx) then - ! if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute - ! if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image - ! endif - ! if (.not.periodicy) then - ! if (jpixmin < 1) jpixmin = 1 - ! if (jpixmax > npixy) jpixmax = npixy - ! endif - ! if (.not.periodicz) then - ! if (kpixmin < 1) kpixmin = 1 - ! if (kpixmax > npixz) kpixmax = npixz - ! endif - ! ! - ! !--precalculate an array of dx2 for this particle (optimisation) - ! ! - ! nxpix = 0 - ! do ipix=ipixmin,ipixmax - ! nxpix = nxpix + 1 - ! ipixi = ipix - ! if (periodicx) ipixi = iroll(ipix,npixx) - ! xpixi = xminpix + ipix*pixwidthx - ! !--watch out for errors with perioic wrapping... - ! if (nxpix <= size(dx2i)) then - ! dx2i(nxpix) = ((xpixi - xi)**2)*hi21 - ! endif - ! enddo - - ! !--if particle contributes to more than npixx pixels - ! ! (i.e. periodic boundaries wrap more than once) - ! ! truncate the contribution and give warning - ! if (nxpix > npixx) then - ! nwarn = nwarn + 1 - ! ipixmax = ipixmin + npixx - 1 - ! endif - ! ! - ! !--loop over pixels, adding the contribution from this particle - ! ! - ! do kpix = kpixmin,kpixmax - ! kpixi = kpix - ! if (periodicz) kpixi = iroll(kpix,npixz) - ! zpix = zminpix + kpix*pixwidthz - ! dz = zpix - zi - ! dz2 = dz*dz*hi21 - - ! do jpix = jpixmin,jpixmax - ! jpixi = jpix - ! if (periodicy) jpixi = iroll(jpix,npixy) - ! ypix = yminpix + jpix*pixwidthy - ! dy = ypix - yi - ! dyz2 = dy*dy*hi21 + dz2 - - ! nxpix = 0 - ! do ipix = ipixmin,ipixmax - ! ipixi = ipix - ! if (periodicx) ipixi = iroll(ipix,npixx) - ! nxpix = nxpix + 1 - ! q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 - ! ! - ! !--SPH kernel - standard cubic spline - ! ! - ! if (q2 < radkernel2) then - ! wab = wkernel(q2) - ! ! - ! !--calculate data value at this pixel using the summation interpolant - ! ! - ! !$omp atomic - ! datsmooth(1,ipixi,jpixi,kpixi) = datsmooth(1,ipixi,jpixi,kpixi) + term(1)*wab - ! !$omp atomic - ! datsmooth(2,ipixi,jpixi,kpixi) = datsmooth(2,ipixi,jpixi,kpixi) + term(2)*wab - ! !$omp atomic - ! datsmooth(3,ipixi,jpixi,kpixi) = datsmooth(3,ipixi,jpixi,kpixi) + term(3)*wab - ! if (normalise) then - ! !$omp atomic - ! datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - ! endif - ! endif - ! enddo - ! enddo - ! enddo - ! enddo over_parts - ! !$omp enddo - ! !$omp end parallel - - ! if (nwarn > 0) then - ! print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& - ! ' that wrap periodic boundaries more than once' - ! endif - ! ! - ! !--normalise dat array - ! ! - ! if (normalise) then - ! !$omp parallel do default(none) schedule(static) & - ! !$omp shared(datsmooth,datnorm,npixz,npixy,npixx) & - ! !$omp private(kpix,jpix,ipix,ddatnorm) - ! do kpix=1,npixz - ! do jpix=1,npixy - ! do ipix=1,npixx - ! if (datnorm(ipix,jpix,kpix) > tiny(datnorm)) then - ! ddatnorm = 1./datnorm(ipix,jpix,kpix) - ! datsmooth(1,ipix,jpix,kpix) = datsmooth(1,ipix,jpix,kpix)*ddatnorm - ! datsmooth(2,ipix,jpix,kpix) = datsmooth(2,ipix,jpix,kpix)*ddatnorm - ! datsmooth(3,ipix,jpix,kpix) = datsmooth(3,ipix,jpix,kpix)*ddatnorm - ! endif - ! enddo - ! enddo - ! enddo - ! !$omp end parallel do - ! endif - - ! return - - ! end subroutine interpolate3D_vec - !------------------------------------------------------------ ! interface to kernel routine to avoid problems with openMP !----------------------------------------------------------- From b16fb767657d3551f4bdf0cbfbf6fd661bbe50b6 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 11:01:04 +1100 Subject: [PATCH 194/814] [format-bot] obsolete .gt. .lt. .ge. .le. .eq. .ne. replaced --- src/utils/analysis_radiotde.f90 | 4 ++-- src/utils/moddump_radiotde.f90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 4d009de92..2dd7105b0 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -194,10 +194,10 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) vri = dot_product(vxyz,xyz)/r vr_accum_add = vr_accum_add + vri v_accum_add = v_accum_add + v - if (r-rad_cap < drad_cap .and. (v .ge. v_min .and. v .le. v_max)) then + if (r-rad_cap < drad_cap .and. (v >= v_min .and. v <= v_max)) then thetai = atan2d(y,x) phii = atan2d(z,sqrt(x**2+y**2)) - if ((thetai .ge. theta_min .and. thetai .le. theta_max) .and. (phii .ge. phi_min .and. phii .le. phi_max)) then + if ((thetai >= theta_min .and. thetai <= theta_max) .and. (phii >= phi_min .and. phii <= phi_max)) then m_cap = m_cap + pmass n_cap = n_cap + 1 cap(i) = .true. diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index d854923a5..22784d0a0 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -132,7 +132,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) rhof_rbreak(:) = rhof_rbreak_in(1:nbreak) call calc_rhobreak() else - if (temperature .le. 0) read_temp = .true. + if (temperature <= 0) read_temp = .true. rhof => rho_tab deallocate(rhof_n,rhof_rbreak) From 0f02abfea9c0999c8b57087f821cb58a61114d8c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 11:02:31 +1100 Subject: [PATCH 195/814] [header-bot] updated file headers --- src/main/extern_gr.F90 | 3 +-- src/main/initial.F90 | 15 ++++++++------- src/main/inject_windtunnel.f90 | 13 +++++++++---- src/main/interp_metric.F90 | 2 +- src/main/metric_et.f90 | 2 +- src/main/metric_flrw.f90 | 2 +- src/main/readwrite_dumps_fortran.F90 | 4 ++-- src/main/tmunu2grid.f90 | 2 +- src/setup/set_star.f90 | 14 +------------- src/setup/setup_asteroidwind.f90 | 4 +++- src/setup/setup_flrw.f90 | 6 +++--- src/setup/setup_flrwpspec.f90 | 6 +++--- src/setup/setup_windtunnel.f90 | 22 ++++++++++++++++++---- src/utils/analysis_dustformation.f90 | 2 +- src/utils/analysis_radiotde.f90 | 20 ++++++++++---------- src/utils/einsteintk_utils.f90 | 2 +- src/utils/einsteintk_wrapper.f90 | 2 +- src/utils/interpolate3D.F90 | 8 +------- src/utils/interpolate3Dold.F90 | 2 +- src/utils/moddump_radiotde.f90 | 26 +++++++++++++++++--------- 20 files changed, 84 insertions(+), 73 deletions(-) diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 939d7b301..17a80ea47 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -14,8 +14,7 @@ module extern_gr ! ! :Runtime parameters: None ! -! :Dependencies: eos, fastmath, io, metric_tools, part, physcon, timestep, -! utils_gr +! :Dependencies: eos, io, metric_tools, part, physcon, timestep, utils_gr ! implicit none diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 3784e7431..35906e82a 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -16,13 +16,14 @@ module initial ! ! :Dependencies: analysis, boundary, boundary_dyn, centreofmass, ! checkconserved, checkoptions, checksetup, cons2prim, cooling, cpuinfo, -! damping, densityforce, deriv, dim, dust, dust_formation, energies, eos, -! evwrite, extern_gr, externalforces, fastmath, fileutils, forcing, -! growth, inject, io, io_summary, krome_interface, linklist, -! metric_tools, mf_write, mpibalance, mpidomain, mpimemory, mpitree, -! mpiutils, nicil, nicil_sup, omputils, options, part, partinject, -! ptmass, radiation_utils, readwrite_dumps, readwrite_infile, timestep, -! timestep_ind, timestep_sts, timing, units, writeheader +! 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_tools, mf_write, mpibalance, +! mpidomain, mpimemory, mpitree, mpiutils, nicil, nicil_sup, omputils, +! options, part, partinject, ptmass, radiation_utils, readwrite_dumps, +! readwrite_infile, timestep, timestep_ind, timestep_sts, timing, +! tmunu2grid, units, writeheader ! implicit none diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 7c304db07..0245f9337 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -9,14 +9,19 @@ module inject ! Handles injection for gas sphere in wind tunnel ! ! +! :References: None +! ! :Owner: Mike Lau ! ! :Runtime parameters: -! - lattice_type : *0: cubic distribution, 1: closepacked distribution* -! - handled_layers : *(integer) number of handled BHL wind layers* -! - v_inf : *BHL wind speed* -! - Rstar : *BHL star radius (in accretion radii)* ! - BHL_radius : *radius of the wind cylinder (in star radii)* +! - Rstar : *sphere radius (code units)* +! - handled_layers : *(integer) number of handled BHL wind layers* +! - lattice_type : *0: cubic distribution, 1: closepacked distribution* +! - nstar : *No. of particles making up sphere* +! - pres_inf : *ambient pressure (code units)* +! - rho_inf : *ambient density (code units)* +! - v_inf : *wind speed (code units)* ! - wind_injection_x : *x position of the wind injection boundary (in star radii)* ! - wind_length : *crude wind length (in star radii)* ! diff --git a/src/main/interp_metric.F90 b/src/main/interp_metric.F90 index fc4dd62bf..0d1cb7080 100644 --- a/src/main/interp_metric.F90 +++ b/src/main/interp_metric.F90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module metric_interp ! diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index ca792fc92..a15d185e6 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module metric ! diff --git a/src/main/metric_flrw.f90 b/src/main/metric_flrw.f90 index 68152b86d..3685131b8 100644 --- a/src/main/metric_flrw.f90 +++ b/src/main/metric_flrw.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module metric ! diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index cbe7212ad..696128036 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -20,8 +20,8 @@ module readwrite_dumps_fortran ! ! :Dependencies: boundary, boundary_dyn, checkconserved, dim, dump_utils, ! dust, dust_formation, eos, externalforces, fileutils, io, lumin_nsdisc, -! memory, mpi, mpiutils, options, part, readwrite_dumps_common, -! setup_params, sphNGutils, timestep, units +! memory, metric_tools, mpi, mpiutils, options, part, +! readwrite_dumps_common, setup_params, sphNGutils, timestep, units ! use dump_utils, only:lenid,ndatatypes,i_int,i_int1,i_int2,i_int4,i_int8,& i_real,i_real4,i_real8,int1,int2,int1o,int2o,dump_h,lentag diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index c2ff7ab27..21b5e620b 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module tmunu2grid ! diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 66a5d476c..24071d154 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -15,19 +15,7 @@ module setstar ! ! :Owner: Daniel Price ! -! :Runtime parameters: -! - Mstar : *mass of star* -! - Rstar : *radius of star* -! - hsoft : *Softening length of sink particle stellar core* -! - input_profile : *Path to input profile* -! - isinkcore : *Add a sink particle stellar core* -! - isoftcore : *0=no core softening, 1=cubic core, 2=constant entropy core* -! - isofteningopt : *1=supply rcore, 2=supply mcore, 3=supply both* -! - mcore : *Mass of sink particle stellar core* -! - np : *number of particles* -! - outputfilename : *Output path for softened MESA profile* -! - rcore : *Radius of core softening* -! - ui_coef : *specific internal energy (units of GM/R)* +! :Runtime parameters: None ! ! :Dependencies: centreofmass, dim, eos, extern_densprofile, infile_utils, ! io, mpiutils, part, physcon, prompting, radiation_utils, relaxstar, diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index aff62f942..44f098ea0 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -22,13 +22,15 @@ module setup ! - ipot : *wd modelled by 0=sink or 1=externalforce* ! - m1 : *mass of white dwarf (solar mass)* ! - m2 : *mass of asteroid (ceres mass)* +! - mdot : *mass injection rate (g/s)* ! - norbits : *number of orbits* ! - npart_at_end : *number of particles injected after norbits* ! - rasteroid : *radius of asteroid (km)* ! - semia : *semi-major axis (solar radii)* ! ! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, -! io, options, part, physcon, setbinary, spherical, timestep, units +! inject, io, kernel, options, part, physcon, setbinary, spherical, +! timestep, units ! use inject, only:mdot implicit none diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 7cdc8c868..0d577a3df 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! @@ -23,8 +23,8 @@ module setup ! - rhozero : *initial density in code units* ! ! :Dependencies: boundary, dim, infile_utils, io, mpidomain, mpiutils, -! options, part, physcon, prompting, setup_params, stretchmap, unifdis, -! units, utils_gr +! part, physcon, prompting, setup_params, stretchmap, unifdis, units, +! utils_gr ! use dim, only:use_dust use setup_params, only:rhozero diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index eef12efc8..ff8db10e9 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! @@ -24,8 +24,8 @@ module setup ! - rhozero : *initial density in code units* ! ! :Dependencies: boundary, dim, eos_shen, infile_utils, io, mpidomain, -! mpiutils, options, part, physcon, prompting, setup_params, stretchmap, -! unifdis, units, utils_gr +! mpiutils, part, physcon, prompting, setup_params, stretchmap, unifdis, +! units, utils_gr ! use dim, only:use_dust use setup_params, only:rhozero diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index 2c8e20ba4..29251e287 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! @@ -10,11 +10,25 @@ module setup ! ! :References: None ! -! :Owner: Daniel Price +! :Owner: Mike Lau ! -! :Runtime parameters: None +! :Runtime parameters: +! - Mstar : *sphere mass in code units* +! - Rstar : *sphere radius in code units* +! - gamma : *adiabatic index* +! - handled_layers : *number of handled layers* +! - lattice_type : *0: cubic, 1: close-packed cubic* +! - nstar : *number of particles resolving gas sphere* +! - pres_inf : *wind pressure / dyn cm^2* +! - rho_inf : *wind density / g cm^-3* +! - v_inf : *wind speed / km s^-1* +! - wind_injection_x : *injection x in units of Rstar* +! - wind_length : *wind length in units of Rstar* +! - wind_radius : *injection radius in units of Rstar* ! -! :Dependencies: inject, part, physcon, units +! :Dependencies: dim, eos, extern_densprofile, infile_utils, inject, io, +! kernel, mpidomain, part, physcon, rho_profile, setstar_utils, setunits, +! setup_params, table_utils, timestep, unifdis, units ! use io, only:master,fatal use inject, only:init_inject,nstar,Rstar,lattice_type,handled_layers,& diff --git a/src/utils/analysis_dustformation.f90 b/src/utils/analysis_dustformation.f90 index 489c57789..353a39b1b 100644 --- a/src/utils/analysis_dustformation.f90 +++ b/src/utils/analysis_dustformation.f90 @@ -15,7 +15,7 @@ module analysis ! ! :Runtime parameters: None ! -! :Dependencies: None +! :Dependencies: dim, fileutils, part, physcon, units ! implicit none character(len=20), parameter, public :: analysistype = 'dustformation' diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 2dd7105b0..cd17076f9 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! @@ -10,17 +10,17 @@ module analysis ! ! :References: None ! -! :Owner: Fitz Hu +! :Owner: fhu ! ! :Runtime parameters: -! - rad_cap : *capture shell radius* -! - drad_cap : *capture shell thickness* -! - v_max : *max velocity* -! - v_min : *min velocity* -! - theta_max : *max azimuthal angle* -! - theta_min : *min azimuthal angle* -! - phi_max : *max altitude angle* -! - phi_min : *min altitude angle* +! - drad_cap : *capture thickness (in cm) (-ve for all particles at outer radius)* +! - phi_max : *max phi (in deg)* +! - phi_min : *min phi (in deg)* +! - rad_cap : *capture inner radius (in cm)* +! - theta_max : *max theta (in deg)* +! - theta_min : *min theta (in deg)* +! - v_max : *max velocity (in c)* +! - v_min : *min velocity (in c)* ! ! :Dependencies: infile_utils, io, physcon, readwrite_dumps, units ! diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index 880ac3096..7d436fd0a 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module einsteintk_utils ! diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index f7b5282e2..7541e5974 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module einsteintk_wrapper ! diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index 00503ad41..e97ee8c4a 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module interpolations3D ! @@ -16,12 +16,6 @@ module interpolations3D ! ! :Dependencies: einsteintk_utils, kernel ! -!---------------------------------------------------------------------- -! -! Module containing all of the routines required for interpolation -! from 3D data to a 3D grid (SLOW!) -! -!---------------------------------------------------------------------- use einsteintk_utils, only:exact_rendering use kernel, only:radkern2,radkern,cnormk,wkern implicit none diff --git a/src/utils/interpolate3Dold.F90 b/src/utils/interpolate3Dold.F90 index d1344fd96..c7fff7ca7 100644 --- a/src/utils/interpolate3Dold.F90 +++ b/src/utils/interpolate3Dold.F90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module interpolations3D ! diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 22784d0a0..fa8c8ad96 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! @@ -10,17 +10,25 @@ module moddump ! ! :References: None ! -! :Owner: Fitz Hu +! :Owner: fhu ! ! :Runtime parameters: -! - temperature : *Temperature* -! - mu : *mean molecular mass* -! - ieos_in : *equation of state* -! - use_func : *use broken power law or profile date points* +! - ieos : *equation of state used* +! - ignore_radius : *tde particle inside this radius will be ignored* +! - mu : *mean molecular density of the cloud* +! - nbreak : *number of broken power laws* +! - nprof : *number of data points in the cloud profile* +! - profile_filename : *filename for the cloud profile* +! - rad_max : *outer radius of the circumnuclear gas cloud* +! - rad_min : *inner radius of the circumnuclear gas cloud* +! - remove_overlap : *remove outflow particles overlap with circum particles* +! - rhof_n_1 : *power law index of the section* +! - rhof_rho0 : *density at rad_min (in g/cm^3)* +! - temperature : *temperature of the gas cloud (-ve = read from file)* +! - use_func : *if use broken power law for density profile* ! -! :Dependencies: datafiles, eos, io, stretchmap, kernel, -! mpidomain, part, physcon, setup_params, -! spherical, timestep, units, infile_utils +! :Dependencies: eos, infile_utils, io, kernel, mpidomain, part, physcon, +! setup_params, spherical, stretchmap, timestep, units ! implicit none public :: modify_dump From 2a8b7784bece7acaf8a16b0884250b82e49df1f5 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 11:02:47 +1100 Subject: [PATCH 196/814] [space-bot] whitespace at end of lines removed --- src/main/config.F90 | 2 +- src/main/extern_gr.F90 | 8 +++--- src/main/inject_windtunnel.f90 | 10 +++---- src/main/metric_et.f90 | 2 +- src/main/readwrite_dumps_fortran.F90 | 4 +-- src/main/step_leapfrog.F90 | 2 +- src/main/tmunu2grid.f90 | 16 ++++++------ src/setup/setup_flrw.f90 | 16 ++++++------ src/setup/setup_flrwpspec.f90 | 36 +++++++++++++------------- src/setup/setup_windtunnel.f90 | 14 +++++----- src/utils/analysis_common_envelope.f90 | 2 +- src/utils/analysis_radiotde.f90 | 8 +++--- src/utils/einsteintk_wrapper.f90 | 28 ++++++++++---------- src/utils/interpolate3D.F90 | 18 ++++++------- src/utils/moddump_radiotde.f90 | 12 ++++----- 15 files changed, 89 insertions(+), 89 deletions(-) diff --git a/src/main/config.F90 b/src/main/config.F90 index 561adf30e..020e43a42 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -277,7 +277,7 @@ module dim logical, parameter :: nr = .true. #else logical, parameter :: nr = .false. -#endif +#endif !-------------------- ! Supertimestepping diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 17a80ea47..b118c17b6 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -86,9 +86,9 @@ subroutine dt_grforce(xyzh,fext,dtf) real, intent(out) :: dtf real :: r,r2,dtf1,dtf2,f2i integer, parameter :: steps_per_orbit = 100 - + f2i = fext(1)*fext(1) + fext(2)*fext(2) + fext(3)*fext(3) - if (f2i > 0.) then + if (f2i > 0.) then dtf1 = sqrt(xyzh(4)/sqrt(f2i)) ! This is not really accurate since fi is a component of dp/dt, not da/dt else dtf1 = huge(dtf1) @@ -99,9 +99,9 @@ subroutine dt_grforce(xyzh,fext,dtf) r2 = xyzh(1)*xyzh(1) + xyzh(2)*xyzh(2) + xyzh(3)*xyzh(3) r = sqrt(r2) dtf2 = (2.*pi*sqrt(r*r2))/steps_per_orbit - case default + case default dtf2 = huge(dtf2) - end select + end select dtf = min(dtf1,dtf2) diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 0245f9337..5888f288e 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -89,7 +89,7 @@ subroutine init_inject(ierr) if (lattice_type == 1) then psep = (sqrt(2.)*element_volume)**(1./3.) elseif (lattice_type == 0) then - psep = element_volume**(1./3.) + psep = element_volume**(1./3.) else call fatal("init_inject",'unknown lattice_type (must be 0 or 1)') endif @@ -268,16 +268,16 @@ subroutine print_summary(v_inf,cs_inf,rho_inf,pres_inf,mach,pmass,distance_betwe integer, intent(in) :: max_layers,nstar,max_particles print*, 'wind speed: ',v_inf * unit_velocity / 1e5," km s^-1" - print*, 'wind cs: ',cs_inf * unit_velocity / 1e5," km s^-1" - print*, 'wind density: ',rho_inf * unit_density," g cm^-3" - print*, 'wind pressure: ',pres_inf * unit_pressure," dyn cm^-2" + print*, 'wind cs: ',cs_inf * unit_velocity / 1e5," km s^-1" + print*, 'wind density: ',rho_inf * unit_density," g cm^-3" + print*, 'wind pressure: ',pres_inf * unit_pressure," dyn cm^-2" print*, 'wind mach number: ', mach print*, 'maximum wind layers: ', max_layers print*, 'pmass: ',pmass print*, 'nstar: ',nstar print*, 'nstar + max. wind particles: ', max_particles - print*, 'distance_between_layers: ',distance_between_layers + print*, 'distance_between_layers: ',distance_between_layers print*, 'time_between_layers: ',time_between_layers print*, 'planet crossing time: ',2*Rstar/v_inf diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index a15d185e6..d13454ce1 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -20,7 +20,7 @@ module metric character(len=*), parameter :: metric_type = 'et' integer, parameter :: imetric = 6 ! This are dummy parameters to stop the compiler complaing - ! Not used anywhere in the code - Needs a fix! + ! Not used anywhere in the code - Needs a fix! real, public :: mass1 = 1. ! mass of central object real, public :: a = 0.0 ! spin of central object contains diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 696128036..03b755cc4 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -218,7 +218,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) 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 - use part, only:metrics,metricderivs,tmunus + use part, only:metrics,metricderivs,tmunus use options, only:use_dustfrac,use_var_comp,icooling use dump_utils, only:tag,open_dumpfile_w,allocate_header,& free_header,write_header,write_array,write_block_header @@ -365,7 +365,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) endif if (gr) then call write_array(1,pxyzu,pxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,dens,'dens prim',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,dens,'dens prim',npart,k,ipass,idump,nums,ierrs(8)) if (imetric==imet_et) then ! Output metric if imetric=iet call write_array(1,metrics(1,1,1,:), 'gtt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 68abc8bc9..5f8e468b8 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -659,7 +659,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif endif enddo iterations - + ! MPI reduce summary variables nwake = int(reduceall_mpi('+', nwake)) nvfloorp = int(reduceall_mpi('+', nvfloorp)) diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index 21b5e620b..2777e9a7d 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -104,10 +104,10 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) tmunugrid = 0. datsmooth = 0. - ! Vectorized tmunu calculation - + ! Vectorized tmunu calculation + ! Put tmunu into an array of form - ! tmunu(npart,16) + ! tmunu(npart,16) do k=1, 4 do j=1,4 do i=1,npart @@ -116,8 +116,8 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) ! print*, "Index in array is: ", (k-1)*4 + j ! print*,tmunus(k,j,1) dat(i, (k-1)*4 + j) = tmunus(k,j,i) - enddo - enddo + enddo + enddo enddo !stop ilendat = 16 @@ -139,17 +139,17 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) !print*, datsmooth((i-1)*4 + j, 10,10,10) enddo enddo -!stop +!stop ! do k=1,4 ! do j=1,4 ! do i=1,4 ! print*, "Lock index is: ", (k-1)*16+ (j-1)*4 + i ! enddo ! enddo -! enddo +! enddo ! tmunugrid(0,0,:,:,:) = datsmooth(1,:,:,:) - + ! TODO Unroll this loop for speed + using symmetries ! Possiblly cleanup the messy indexing ! do k=1,4 diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 0d577a3df..e16173d2f 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -6,8 +6,8 @@ !--------------------------------------------------------------------------! module setup ! -! Setup routine for a constant density + petrubtations FLRW universe -! as described in Magnall et al. 2023 +! Setup routine for a constant density + petrubtations FLRW universe +! as described in Magnall et al. 2023 ! ! :References: None ! @@ -83,7 +83,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, procedure(rho_func), pointer :: density_func density_func => rhofunc ! desired density function - + ! !--general parameters @@ -97,7 +97,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! irrelevant for gamma = 4./3. endif - + ! ! default units ! @@ -139,7 +139,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! We assume ainit = 1, but this may not always be the case c1 = 1./(4.*pi*rhozero) !c2 = We set g(x^i) = 0 as we only want to extract the growing mode - c3 = - sqrt(1./(6.*pi*rhozero)) + c3 = - sqrt(1./(6.*pi*rhozero)) !c3 = hub/(4.d0*PI*rhozero) @@ -189,7 +189,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! general parameters ! ! time should be read in from the par file - !time = 0.08478563386065302 + !time = 0.08478563386065302 time = 0.18951066686763596 ! z~1000 lambda = perturb_wavelength*length kwave = (2.d0*pi)/lambda @@ -200,10 +200,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, select case(radiation_dominated) case('"yes"') - ! Set a value of rho_matter + ! Set a value of rho_matter rho_matter = 1.e-40 !rhozero = rhozero - radconst*last_scattering_temp**4 - ! Solve for temperature + ! Solve for temperature last_scattering_temp = ((rhozero-rho_matter)/radconst)**(1./4.) rhozero = rho_matter end select diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index ff8db10e9..f493a2766 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -7,8 +7,8 @@ module setup ! ! Setup routine for realistic cosmological initial conditions based -! on the Zeldovich approximation. -! Requries velocity files generated from a powerspectrum. +! on the Zeldovich approximation. +! Requries velocity files generated from a powerspectrum. ! ! :References: None ! @@ -82,7 +82,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real :: scale_factor,gradphi(3),vxyz(3),dxgrid,gridorigin integer :: nghost, gridres, gridsize real, allocatable :: vxgrid(:,:,:),vygrid(:,:,:),vzgrid(:,:,:) - + ! !--general parameters ! @@ -117,7 +117,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, perturb = '"no"' perturb_direction = '"none"' radiation_dominated = '"no"' - ampl = 0. + ampl = 0. ! Ideally this should read the values of the box length ! and initial Hubble parameter from the par file. @@ -141,7 +141,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, isperiodic = .true. ncross = 0 - + ! Approx Temp of the CMB in Kelvins last_scattering_temp = 3000 @@ -188,8 +188,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_units(dist=udist,mass=umass,G=1.) endif call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) - - + + allocate(vxgrid(gridsize,gridsize,gridsize)) allocate(vygrid(gridsize,gridsize,gridsize)) allocate(vzgrid(gridsize,gridsize,gridsize)) @@ -238,14 +238,14 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, pspec_filename1 = 'init_vel1_64.dat' pspec_filename2 = 'init_vel2_64.dat' pspec_filename3 = 'init_vel3_64.dat' - + ! Check if files exist otherwise skip and return flat space - if (.not. check_files(pspec_filename1,pspec_filename2,pspec_filename3)) then + if (.not. check_files(pspec_filename1,pspec_filename2,pspec_filename3)) then print*, "Velocity files not found..." print*, "Setting up flat space!" - return - endif - + return + endif + ! Read in velocities from vel file here ! Should be made into a function at some point @@ -359,7 +359,7 @@ subroutine setup_interactive(id,polyk) call prompt(' enter sound speed in code units (sets polyk)',cs0,0.) endif call bcast_mpi(cs0) - + ! ! type of lattice ! @@ -597,11 +597,11 @@ logical function check_files(file1,file2,file3) inquire(file=file1,exist=file1_exist) inquire(file=file2,exist=file2_exist) - inquire(file=file3,exist=file3_exist) - - if ((.not. file1_exist) .or. (.not. file2_exist) .or. (.not. file3_exist)) then - check_files = .false. - endif + inquire(file=file3,exist=file3_exist) + + if ((.not. file1_exist) .or. (.not. file2_exist) .or. (.not. file3_exist)) then + check_files = .false. + endif end function check_files end module setup diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index 29251e287..91e0ce7c6 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -76,7 +76,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, logical :: use_exactN,setexists character(len=30) :: lattice character(len=120) :: setupfile - + call set_units(mass=solarm,dist=solarr,G=1.) ! ! Initialise parameters, including those that will not be included in *.setup @@ -130,7 +130,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call write_setupfile(setupfile) stop 'please check and edit .setup file and rerun phantomsetup' endif - + pmass = Mstar / real(nstar) massoftype(igas) = pmass call check_setup(pmass,ierr) @@ -160,9 +160,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, presi = yinterp(pres(1:npts),r(1:npts),ri) vxyzu(4,i) = presi / ( (gamma-1.) * densi) enddo - + deallocate(r,den,pres) - + print*, "udist = ", udist, "; umass = ", umass, "; utime = ", utime end subroutine setpart @@ -194,7 +194,7 @@ subroutine write_setupfile(filename) call write_inopt(nstar,'nstar','number of particles resolving gas sphere',iunit) call write_inopt(Mstar,'Mstar','sphere mass in code units',iunit) call write_inopt(Rstar,'Rstar','sphere radius in code units',iunit) - + write(iunit,"(/,a)") '# wind settings' call write_inopt(v_inf*unit_velocity/1.e5,'v_inf','wind speed / km s^-1',iunit) call write_inopt(rho_inf*unit_density,'rho_inf','wind density / g cm^-3',iunit) @@ -295,6 +295,6 @@ subroutine check_setup(pmass,ierr) endif end subroutine check_setup - + end module setup - + diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 6cd1c6c27..c64b92bbe 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -1167,7 +1167,7 @@ subroutine roche_lobe_values(time,npart,particlemass,xyzh,vxyzu) else MRL(iR1T) = MRL(iR1T) / real(nR1T) endif - + if (nFB == 0) then MRL(iFBV) = 0 else diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index cd17076f9..d4e99725c 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -151,7 +151,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) v_cap_mean, & e_accum*unit_energ, & e_cap*unit_energ - close(iunit) + close(iunit) write(*,'(I8,1X,A2,1X,I8,1X,A34)') n_cap, 'of', npart, 'particles are in the capture shell' write(*,'(I8,1X,A2,1X,I8,1X,A40)') n_accum, 'of', npart, 'particles are outside the capture radius' @@ -175,7 +175,7 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) vr_cap_add = 0. v_accum_add = 0. v_cap_add = 0. - + do i = 1,npart x = xyzh(1,i) y = xyzh(2,i) @@ -188,7 +188,7 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) r = sqrt(dot_product(xyz,xyz)) v = sqrt(dot_product(vxyz,vxyz)) if (r > rad_cap) then - m_accum = m_accum + pmass + m_accum = m_accum + pmass n_accum = n_accum + 1 e_accum = e_accum + 0.5*pmass*v**2 vri = dot_product(vxyz,xyz)/r @@ -264,7 +264,7 @@ subroutine read_tdeparams(filename,ierr) nerr = 0 ierr = 0 call open_db_from_file(db,filename,iunit,ierr) - + call read_inopt(rad_cap,'rad_cap',db,min=0.,errcount=nerr) call read_inopt(drad_cap,'drad_cap',db,errcount=nerr) diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 7541e5974..4414c3142 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -239,7 +239,7 @@ subroutine et2phantom_tmunu() ! Correct Tmunu ! Convert to 8byte real to stop compiler warning tmunugrid = real(cfac)*tmunugrid - + end subroutine et2phantom_tmunu @@ -286,7 +286,7 @@ subroutine phantom2et_consvar() ! Correct momentum and Density ! Conversion of cfac to 8byte real to avoid - ! compiler warning + ! compiler warning rhostargrid = real(cfac)*rhostargrid pxgrid = real(cfac)*pxgrid entropygrid = real(cfac)*entropygrid @@ -426,37 +426,37 @@ subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) real, intent(in) :: time, dt_et !real(kind=16) :: cfac !logical, intent(in), optional :: checkpoint - !integer, intent(in) :: checkpointno + !integer, intent(in) :: checkpointno character(*),optional, intent(in) :: checkpointfile - logical :: createcheckpoint + logical :: createcheckpoint - if (present(checkpointfile)) then + if (present(checkpointfile)) then createcheckpoint = .true. - else + else createcheckpoint = .false. - endif + endif ! Write EV_file - if (.not. createcheckpoint) then + if (.not. createcheckpoint) then call write_evfile(time,dt_et) evfilestor = getnextfilename(evfilestor) logfilestor = getnextfilename(logfilestor) dumpfilestor = getnextfilename(dumpfilestor) call write_fulldump(time,dumpfilestor) - endif + endif ! Write full dump - if (createcheckpoint) then - call write_fulldump(time,checkpointfile) - endif + if (createcheckpoint) then + call write_fulldump(time,checkpointfile) + endif ! Quick and dirty write cfac to txtfile - + ! Density check vs particles ! call check_conserved_dens(rhostargrid,cfac) ! open(unit=777, file="cfac.txt", action='write', position='append') -! print*, time, cfac +! print*, time, cfac ! write(777,*) time, cfac ! close(unit=777) diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index e97ee8c4a..80789b06f 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -695,13 +695,13 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !--calculate data value at this pixel using the summation interpolant ! do smoothindex=1, ilendat - !$omp atomic + !$omp atomic datsmooth(smoothindex,ipixi,jpixi,kpixi) = datsmooth(smoothindex,ipixi,jpixi,kpixi) + term(smoothindex)*wab - enddo + enddo if (normalise) then !$omp atomic datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - endif + endif endif else if (q2 < radkernel2) then @@ -714,14 +714,14 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !--calculate data value at this pixel using the summation interpolant ! do smoothindex=1,ilendat - !$omp atomic + !$omp atomic datsmooth(smoothindex,ipixi,jpixi,kpixi) = datsmooth(smoothindex,ipixi,jpixi,kpixi) + term(smoothindex)*wab - enddo + enddo if (normalise) then !$omp atomic datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab endif - + endif endif enddo @@ -741,10 +741,10 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& if (normalise) then do i=1, ilendat where (datnorm > tiny(datnorm)) - - datsmooth(i,:,:,:) = datsmooth(i,:,:,:)/datnorm(:,:,:) + + datsmooth(i,:,:,:) = datsmooth(i,:,:,:)/datnorm(:,:,:) end where - enddo + enddo endif if (allocated(datnorm)) deallocate(datnorm) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index fa8c8ad96..5e12a738e 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -90,7 +90,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) temperature = 10. ! Temperature in Kelvin mu = 2. ! mean molecular weight ieos_in = 2 - ignore_radius = 1.e14 ! in cm + ignore_radius = 1.e14 ! in cm use_func = .true. use_func_old = use_func remove_overlap = .true. @@ -141,7 +141,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call calc_rhobreak() else if (temperature <= 0) read_temp = .true. - rhof => rho_tab + rhof => rho_tab deallocate(rhof_n,rhof_rbreak) allocate(dens_prof(nprof),rad_prof(nprof),masstab(nprof)) @@ -199,17 +199,17 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call set_sphere('random',id,master,rad_min,rad_max,delta,hfact_default,npart,xyzh, & rhofunc=rhof,nptot=npart_total,exactN=.true.,np_requested=np_sphere,mask=i_belong) if (ierr /= 0) call fatal('moddump','error setting up the circumnuclear gas cloud') - + npartoftype(igas) = npart !--Set particle properties do i = npart_old+1,npart call set_particle_type(i,igas) r = dot_product(xyzh(1:3,i),xyzh(1:3,i)) - if (read_temp) temperature = get_temp_r(r,rad_prof,temp_prof) + if (read_temp) temperature = get_temp_r(r,rad_prof,temp_prof) vxyzu(4,i) = uerg(rhof(r),temperature) vxyzu(1:3,i) = 0. ! stationary for now enddo - + !--Set timesteps tmax = 10.*years/utime dtmax = tmax/1000. @@ -318,7 +318,7 @@ subroutine write_setupfile(filename) integer, parameter :: iunit = 20 integer :: i character(len=20) :: rstr,nstr - + write(*,"(a)") ' writing setup options file '//trim(filename) open(unit=iunit,file=filename,status='replace',form='formatted') write(iunit,"(a)") '# input file for setting up a circumnuclear gas cloud' From 2c73a466619a99235c8ce69ce09f32ca936a5d6b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 11:02:47 +1100 Subject: [PATCH 197/814] [author-bot] updated AUTHORS file --- AUTHORS | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/AUTHORS b/AUTHORS index d0b207025..a647036c4 100644 --- a/AUTHORS +++ b/AUTHORS @@ -27,10 +27,10 @@ Mats Esseldeurs Stephane Michoulier Simone Ceppi MatsEsseldeurs +fhu +Spencer Magnall Caitlyn Hardiman Enrico Ragusa -Spencer Magnall -fhu Sergei Biriukov Cristiano Longarini Giovanni Dipierro @@ -38,12 +38,12 @@ Roberto Iaconi Hauke Worpel Alison Young Simone Ceppi -Amena Faruqi Stephen Neilson <36410751+s-neilson@users.noreply.github.com> +Amena Faruqi Martina Toscani Benedetta Veronesi -Sahl Rowther Simon Glover +Sahl Rowther Thomas Reichardt Jean-François Gonzalez Christopher Russell @@ -51,28 +51,28 @@ Alessia Franchini Alex Pettitt Jolien Malfait Phantom benchmark bot -Kieran Hirsh Nicole Rodrigues +Kieran Hirsh Amena Faruqi David Trevascus Farzana Meru -Chris Nixon -Megha Sharma Nicolas Cuello -Benoit Commercon -Giulia Ballabio -Joe Fisher -Maxime Lombart +Megha Sharma +Chris Nixon Megha Sharma +s-neilson <36410751+s-neilson@users.noreply.github.com> Orsola De Marco Terrence Tricco +Miguel Gonzalez-Bolivar +Benoit Commercon Zachary Pellow -s-neilson <36410751+s-neilson@users.noreply.github.com> -Alison Young -Cox, Samuel +Maxime Lombart +Joe Fisher +Giulia Ballabio Jorge Cuadra -Miguel Gonzalez-Bolivar -Nicolás Cuello -Steven Rieder Stéven Toupin +Nicolás Cuello mats esseldeurs +Alison Young +Cox, Samuel +Steven Rieder From b6f263a636a4b0e9ed4d95dfafebe58592448470 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 11:03:26 +1100 Subject: [PATCH 198/814] [indent-bot] standardised indentation --- src/main/extern_gr.F90 | 4 +- src/main/radiation_implicit.f90 | 8 +- src/main/tmunu2grid.f90 | 44 +-- src/setup/setup_flrw.f90 | 4 +- src/setup/setup_flrwpspec.f90 | 22 +- src/utils/analysis_common_envelope.f90 | 10 +- src/utils/analysis_radiotde.f90 | 18 +- src/utils/einsteintk_wrapper.f90 | 16 +- src/utils/interpolate3D.F90 | 496 ++++++++++++------------- src/utils/moddump_radiotde.f90 | 4 +- 10 files changed, 313 insertions(+), 313 deletions(-) diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index b118c17b6..17d050f42 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -89,9 +89,9 @@ subroutine dt_grforce(xyzh,fext,dtf) f2i = fext(1)*fext(1) + fext(2)*fext(2) + fext(3)*fext(3) if (f2i > 0.) then - dtf1 = sqrt(xyzh(4)/sqrt(f2i)) ! This is not really accurate since fi is a component of dp/dt, not da/dt + dtf1 = sqrt(xyzh(4)/sqrt(f2i)) ! This is not really accurate since fi is a component of dp/dt, not da/dt else - dtf1 = huge(dtf1) + dtf1 = huge(dtf1) endif select case (imetric) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 450956569..719111842 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -597,10 +597,10 @@ subroutine compute_flux(ivar,ijvar,ncompact,npart,icompactmax,varij2,vari,EU0,va if (dustRT) then if (dust_temp(i) < Tdust_threshold) opacity = nucleation(idkappa,i) endif - ! if (opacity < 0.) then - ! ierr = max(ierr,ierr_negative_opacity) - ! call error(label,'Negative opacity',val=opacity) - ! endif + ! if (opacity < 0.) then + ! ierr = max(ierr,ierr_negative_opacity) + ! call error(label,'Negative opacity',val=opacity) + ! endif if (limit_radiation_flux) then radRi = get_rad_R(rhoi,EU01i,dedx,opacity) diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index 2777e9a7d..bc5269940 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -109,36 +109,36 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) ! Put tmunu into an array of form ! tmunu(npart,16) do k=1, 4 - do j=1,4 - do i=1,npart - ! Check that this is correct!!! - ! print*,"i j is: ", k, j - ! print*, "Index in array is: ", (k-1)*4 + j - ! print*,tmunus(k,j,1) - dat(i, (k-1)*4 + j) = tmunus(k,j,i) - enddo - enddo -enddo + do j=1,4 + do i=1,npart + ! Check that this is correct!!! + ! print*,"i j is: ", k, j + ! print*, "Index in array is: ", (k-1)*4 + j + ! print*,tmunus(k,j,1) + dat(i, (k-1)*4 + j) = tmunus(k,j,i) + enddo + enddo + enddo !stop -ilendat = 16 + ilendat = 16 -call interpolate3D_vecexact(xyzh,weights,dat,ilendat,itype,npart,& + call interpolate3D_vecexact(xyzh,weights,dat,ilendat,itype,npart,& xmininterp(1),xmininterp(2),xmininterp(3), & datsmooth(:,ilower:iupper,jlower:jupper,klower:kupper),& ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& normalise,periodicx,periodicy,periodicz) ! Put the smoothed array into tmunugrid -do i=1,4 - do j=1,4 - ! Check this is correct too! - !print*,"i j is: ", i, j - !print*, "Index in array is: ", (i-1)*4 + j - tmunugrid(i-1,j-1,:,:,:) = datsmooth((i-1)*4 + j, :,:,:) - !print*, "tmunugrid: ", tmunugrid(i-1,j-1,10,10,10) - !print*, datsmooth((i-1)*4 + j, 10,10,10) - enddo -enddo + do i=1,4 + do j=1,4 + ! Check this is correct too! + !print*,"i j is: ", i, j + !print*, "Index in array is: ", (i-1)*4 + j + tmunugrid(i-1,j-1,:,:,:) = datsmooth((i-1)*4 + j, :,:,:) + !print*, "tmunugrid: ", tmunugrid(i-1,j-1,10,10,10) + !print*, datsmooth((i-1)*4 + j, 10,10,10) + enddo + enddo !stop ! do k=1,4 ! do j=1,4 diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index e16173d2f..875c44de2 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.f90 @@ -408,9 +408,9 @@ real function massfunc(x,xmin) end function massfunc real function deltaint(x) - real, intent(in) :: x + real, intent(in) :: x - deltaint = (1./kwave)*(kwave*kwave*c1 - 2)*ampl*cos(2*pi*x/lambda) + deltaint = (1./kwave)*(kwave*kwave*c1 - 2)*ampl*cos(2*pi*x/lambda) end function deltaint diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index f493a2766..2392255ac 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.f90 @@ -241,9 +241,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! Check if files exist otherwise skip and return flat space if (.not. check_files(pspec_filename1,pspec_filename2,pspec_filename3)) then - print*, "Velocity files not found..." - print*, "Setting up flat space!" - return + print*, "Velocity files not found..." + print*, "Setting up flat space!" + return endif @@ -592,16 +592,16 @@ subroutine get_grid_neighbours(position,gridorigin,dx,xlower,ylower,zlower) end subroutine get_grid_neighbours logical function check_files(file1,file2,file3) - character(len=*), intent(in) :: file1,file2,file3 - logical :: file1_exist, file2_exist, file3_exist + character(len=*), intent(in) :: file1,file2,file3 + logical :: file1_exist, file2_exist, file3_exist - inquire(file=file1,exist=file1_exist) - inquire(file=file2,exist=file2_exist) - inquire(file=file3,exist=file3_exist) + inquire(file=file1,exist=file1_exist) + inquire(file=file2,exist=file2_exist) + inquire(file=file3,exist=file3_exist) - if ((.not. file1_exist) .or. (.not. file2_exist) .or. (.not. file3_exist)) then - check_files = .false. - endif + if ((.not. file1_exist) .or. (.not. file2_exist) .or. (.not. file3_exist)) then + check_files = .false. + endif end function check_files end module setup diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index c64b92bbe..02991276f 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -1163,15 +1163,15 @@ subroutine roche_lobe_values(time,npart,particlemass,xyzh,vxyzu) enddo if (nR1T == 0) then - MRL(iR1T) = 0 + MRL(iR1T) = 0 else - MRL(iR1T) = MRL(iR1T) / real(nR1T) + MRL(iR1T) = MRL(iR1T) / real(nR1T) endif if (nFB == 0) then - MRL(iFBV) = 0 + MRL(iFBV) = 0 else - MRL(iFBV) = MRL(iFBV) / real(nFB) + MRL(iFBV) = MRL(iFBV) / real(nFB) endif @@ -2549,7 +2549,7 @@ subroutine planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) z(i) = dot_product(ri, vnorm) Rvec = ri - z(i)*vnorm R(i) = sqrt(dot_product(Rvec,Rvec)) - ! write(iu,"(es13.6,2x,es13.6,2x,es13.6)") R(i),z(i),rho(i) + ! write(iu,"(es13.6,2x,es13.6,2x,es13.6)") R(i),z(i),rho(i) write(iu,"(es13.6,2x,es13.6,2x,es13.6,2x,es13.6,2x,es13.6)") xyzh(1,i),xyzh(2,i),xyzh(3,i),rho(i),vxyzu(4,i) enddo diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index d4e99725c..e18da12f1 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -107,9 +107,9 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) call tde_analysis(npart,pmass,xyzh,vxyzu) if (n_cap > 0) then - open(iunit,file=output) - write(iunit,'("# ",es20.12," # TIME")') time - write(iunit,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & + open(iunit,file=output) + write(iunit,'("# ",es20.12," # TIME")') time + write(iunit,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & 1,'theta', & 2,'thetap', & 3,'phi', & @@ -117,18 +117,18 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) 5,'vtheta', & 6,'vphi' - do i = 1,npart - if (cap(i)) then - write(iunit,'(6(es18.10,1X))') & + do i = 1,npart + if (cap(i)) then + write(iunit,'(6(es18.10,1X))') & theta(i), & plot_theta(i), & phi(i), & vr(i), & vtheta(i), & vphi(i) - endif - enddo - close(iunit) + endif + enddo + close(iunit) endif deallocate(theta,plot_theta,phi,vr,vtheta,vphi,cap) diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 4414c3142..ede060fcf 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -431,24 +431,24 @@ subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) logical :: createcheckpoint if (present(checkpointfile)) then - createcheckpoint = .true. + createcheckpoint = .true. else - createcheckpoint = .false. + createcheckpoint = .false. endif ! Write EV_file if (.not. createcheckpoint) then - call write_evfile(time,dt_et) + call write_evfile(time,dt_et) - evfilestor = getnextfilename(evfilestor) - logfilestor = getnextfilename(logfilestor) - dumpfilestor = getnextfilename(dumpfilestor) - call write_fulldump(time,dumpfilestor) + evfilestor = getnextfilename(evfilestor) + logfilestor = getnextfilename(logfilestor) + dumpfilestor = getnextfilename(dumpfilestor) + call write_fulldump(time,dumpfilestor) endif ! Write full dump if (createcheckpoint) then - call write_fulldump(time,checkpointfile) + call write_fulldump(time,checkpointfile) endif ! Quick and dirty write cfac to txtfile diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index 80789b06f..ba9eac4c7 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.F90 @@ -57,102 +57,102 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& xmin,ymin,zmin,datsmooth,npixx,npixy,npixz,pixwidthx,pixwidthy,pixwidthz,& normalise,periodicx,periodicy,periodicz) -integer, intent(in) :: npart,npixx,npixy,npixz -real, intent(in) :: xyzh(4,npart) -real, intent(in), dimension(npart) :: weight,dat -integer, intent(in), dimension(npart) :: itype -real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz -real, intent(out), dimension(npixx,npixy,npixz) :: datsmooth -logical, intent(in) :: normalise,periodicx,periodicy,periodicz + integer, intent(in) :: npart,npixx,npixy,npixz + real, intent(in) :: xyzh(4,npart) + real, intent(in), dimension(npart) :: weight,dat + integer, intent(in), dimension(npart) :: itype + real, intent(in) :: xmin,ymin,zmin,pixwidthx,pixwidthy,pixwidthz + real, intent(out), dimension(npixx,npixy,npixz) :: datsmooth + logical, intent(in) :: normalise,periodicx,periodicy,periodicz !logical, intent(in), exact_rendering -real, allocatable :: datnorm(:,:,:) - -integer :: i,ipix,jpix,kpix -integer :: iprintinterval,iprintnext -integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax -integer :: ipixi,jpixi,kpixi,nxpix,nwarn,threadid -real :: xminpix,yminpix,zminpix,hmin !,dhmin3 -real, dimension(npixx) :: dx2i -real :: xi,yi,zi,hi,hi1,hi21,wab,q2,const,dyz2,dz2 -real :: term,termnorm,dy,dz,ypix,zpix,xpixi,pixwidthmax,dfac -real :: t_start,t_end,t_used -logical :: iprintprogress -real, dimension(npart) :: x,y,z,hh -real :: radkernel, radkernel2, radkernh + real, allocatable :: datnorm(:,:,:) + + integer :: i,ipix,jpix,kpix + integer :: iprintinterval,iprintnext + integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax + integer :: ipixi,jpixi,kpixi,nxpix,nwarn,threadid + real :: xminpix,yminpix,zminpix,hmin !,dhmin3 + real, dimension(npixx) :: dx2i + real :: xi,yi,zi,hi,hi1,hi21,wab,q2,const,dyz2,dz2 + real :: term,termnorm,dy,dz,ypix,zpix,xpixi,pixwidthmax,dfac + real :: t_start,t_end,t_used + logical :: iprintprogress + real, dimension(npart) :: x,y,z,hh + real :: radkernel, radkernel2, radkernh ! Exact rendering -real :: pixint, wint + real :: pixint, wint !logical, parameter :: exact_rendering = .true. ! use exact rendering y/n -integer :: usedpart, negflag + integer :: usedpart, negflag !$ integer :: omp_get_num_threads,omp_get_thread_num -integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits + integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits ! Fill the particle data with xyzh -x(:) = xyzh(1,:) -y(:) = xyzh(2,:) -z(:) = xyzh(3,:) -hh(:) = xyzh(4,:) -cnormk3D = cnormk -radkernel = radkern -radkernel2 = radkern2 - -if (exact_rendering) then -print "(1x,a)",'interpolating to 3D grid (exact/Petkova+2018 on subgrid) ...' -elseif (normalise) then -print "(1x,a)",'interpolating to 3D grid (normalised) ...' -else -print "(1x,a)",'interpolating to 3D grid (non-normalised) ...' -endif -if (pixwidthx <= 0. .or. pixwidthy <= 0 .or. pixwidthz <= 0) then -print "(1x,a)",'interpolate3D: error: pixel width <= 0' -return -endif -if (any(hh(1:npart) <= tiny(hh))) then -print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' -endif + x(:) = xyzh(1,:) + y(:) = xyzh(2,:) + z(:) = xyzh(3,:) + hh(:) = xyzh(4,:) + cnormk3D = cnormk + radkernel = radkern + radkernel2 = radkern2 + + if (exact_rendering) then + print "(1x,a)",'interpolating to 3D grid (exact/Petkova+2018 on subgrid) ...' + elseif (normalise) then + print "(1x,a)",'interpolating to 3D grid (normalised) ...' + else + print "(1x,a)",'interpolating to 3D grid (non-normalised) ...' + endif + if (pixwidthx <= 0. .or. pixwidthy <= 0 .or. pixwidthz <= 0) then + print "(1x,a)",'interpolate3D: error: pixel width <= 0' + return + endif + if (any(hh(1:npart) <= tiny(hh))) then + print*,'interpolate3D: WARNING: ignoring some or all particles with h < 0' + endif !call wall_time(t_start) -datsmooth = 0. -if (normalise) then -allocate(datnorm(npixx,npixy,npixz)) -datnorm = 0. -endif + datsmooth = 0. + if (normalise) then + allocate(datnorm(npixx,npixy,npixz)) + datnorm = 0. + endif ! !--print a progress report if it is going to take a long time ! (a "long time" is, however, somewhat system dependent) ! -iprintprogress = (npart >= 100000) .or. (npixx*npixy > 100000) !.or. exact_rendering + iprintprogress = (npart >= 100000) .or. (npixx*npixy > 100000) !.or. exact_rendering ! !--loop over particles ! -iprintinterval = 25 -if (npart >= 1e6) iprintinterval = 10 -iprintnext = iprintinterval + iprintinterval = 25 + if (npart >= 1e6) iprintinterval = 10 + iprintnext = iprintinterval ! !--get starting CPU time ! -call cpu_time(t_start) + call cpu_time(t_start) -usedpart = 0 + usedpart = 0 -xminpix = xmin !- 0.5*pixwidthx -yminpix = ymin !- 0.5*pixwidthy -zminpix = zmin !- 0.5*pixwidthz -pixwidthmax = max(pixwidthx,pixwidthy,pixwidthz) + xminpix = xmin !- 0.5*pixwidthx + yminpix = ymin !- 0.5*pixwidthy + zminpix = zmin !- 0.5*pixwidthz + pixwidthmax = max(pixwidthx,pixwidthy,pixwidthz) ! !--use a minimum smoothing length on the grid to make ! sure that particles contribute to at least one pixel ! -hmin = 0.5*pixwidthmax + hmin = 0.5*pixwidthmax !dhmin3 = 1./(hmin*hmin*hmin) -const = cnormk3D ! normalisation constant (3D) + const = cnormk3D ! normalisation constant (3D) !print*, "const: ", const -nwarn = 0 -j = 0_8 -threadid = 1 + nwarn = 0 + j = 0_8 + threadid = 1 ! !--loop over particles ! @@ -177,216 +177,216 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !$omp end master !$omp do schedule (guided, 2) -over_parts: do i=1,npart + over_parts: do i=1,npart ! !--report on progress ! -if (iprintprogress) then - !$omp atomic - j=j+1_8 + if (iprintprogress) then + !$omp atomic + j=j+1_8 !$ threadid = omp_get_thread_num() - iprogress = 100*j/npart - if (iprogress >= iprintnext .and. threadid==1) then - write(*,"(i3,'%.')",advance='no') iprogress - iprintnext = iprintnext + iprintinterval - endif -endif + iprogress = 100*j/npart + if (iprogress >= iprintnext .and. threadid==1) then + write(*,"(i3,'%.')",advance='no') iprogress + iprintnext = iprintnext + iprintinterval + endif + endif ! !--skip particles with itype < 0 ! -if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts - -hi = hh(i) -if (hi <= 0.) then - cycle over_parts -elseif (hi < hmin) then - ! - !--use minimum h to capture subgrid particles - ! (get better results *without* adjusting weights) - ! - termnorm = const*weight(i) !*(hi*hi*hi)*dhmin3 - if (.not.exact_rendering) hi = hmin -else - termnorm = const*weight(i) -endif + if (itype(i) < 0 .or. weight(i) < tiny(0.)) cycle over_parts + + hi = hh(i) + if (hi <= 0.) then + cycle over_parts + elseif (hi < hmin) then + ! + !--use minimum h to capture subgrid particles + ! (get better results *without* adjusting weights) + ! + termnorm = const*weight(i) !*(hi*hi*hi)*dhmin3 + if (.not.exact_rendering) hi = hmin + else + termnorm = const*weight(i) + endif ! !--set kernel related quantities ! -xi = x(i) -yi = y(i) -zi = z(i) + xi = x(i) + yi = y(i) + zi = z(i) -hi1 = 1./hi -hi21 = hi1*hi1 -radkernh = radkernel*hi ! radius of the smoothing kernel + hi1 = 1./hi + hi21 = hi1*hi1 + radkernh = radkernel*hi ! radius of the smoothing kernel !termnorm = const*weight(i) -term = termnorm*dat(i) -dfac = hi**3/(pixwidthx*pixwidthy*pixwidthz*const) + term = termnorm*dat(i) + dfac = hi**3/(pixwidthx*pixwidthy*pixwidthz*const) !dfac = hi**3/(pixwidthx*pixwidthy*const) ! !--for each particle work out which pixels it contributes to ! -ipixmin = int((xi - radkernh - xmin)/pixwidthx) -jpixmin = int((yi - radkernh - ymin)/pixwidthy) -kpixmin = int((zi - radkernh - zmin)/pixwidthz) -ipixmax = int((xi + radkernh - xmin)/pixwidthx) + 1 -jpixmax = int((yi + radkernh - ymin)/pixwidthy) + 1 -kpixmax = int((zi + radkernh - zmin)/pixwidthz) + 1 - -if (.not.periodicx) then - if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute - if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image -endif -if (.not.periodicy) then - if (jpixmin < 1) jpixmin = 1 - if (jpixmax > npixy) jpixmax = npixy -endif -if (.not.periodicz) then - if (kpixmin < 1) kpixmin = 1 - if (kpixmax > npixz) kpixmax = npixz -endif - -negflag = 0 + ipixmin = int((xi - radkernh - xmin)/pixwidthx) + jpixmin = int((yi - radkernh - ymin)/pixwidthy) + kpixmin = int((zi - radkernh - zmin)/pixwidthz) + ipixmax = int((xi + radkernh - xmin)/pixwidthx) + 1 + jpixmax = int((yi + radkernh - ymin)/pixwidthy) + 1 + kpixmax = int((zi + radkernh - zmin)/pixwidthz) + 1 + + if (.not.periodicx) then + if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute + if (ipixmax > npixx) ipixmax = npixx ! to pixels in the image + endif + if (.not.periodicy) then + if (jpixmin < 1) jpixmin = 1 + if (jpixmax > npixy) jpixmax = npixy + endif + if (.not.periodicz) then + if (kpixmin < 1) kpixmin = 1 + if (kpixmax > npixz) kpixmax = npixz + endif + + negflag = 0 ! !--precalculate an array of dx2 for this particle (optimisation) ! -nxpix = 0 -do ipix=ipixmin,ipixmax - nxpix = nxpix + 1 - ipixi = ipix - if (periodicx) ipixi = iroll(ipix,npixx) - xpixi = xminpix + ipix*pixwidthx - !--watch out for errors with periodic wrapping... - if (nxpix <= size(dx2i)) then - dx2i(nxpix) = ((xpixi - xi)**2)*hi21 - endif -enddo + nxpix = 0 + do ipix=ipixmin,ipixmax + nxpix = nxpix + 1 + ipixi = ipix + if (periodicx) ipixi = iroll(ipix,npixx) + xpixi = xminpix + ipix*pixwidthx + !--watch out for errors with periodic wrapping... + if (nxpix <= size(dx2i)) then + dx2i(nxpix) = ((xpixi - xi)**2)*hi21 + endif + enddo !--if particle contributes to more than npixx pixels ! (i.e. periodic boundaries wrap more than once) ! truncate the contribution and give warning -if (nxpix > npixx) then - nwarn = nwarn + 1 - ipixmax = ipixmin + npixx - 1 -endif + if (nxpix > npixx) then + nwarn = nwarn + 1 + ipixmax = ipixmin + npixx - 1 + endif ! !--loop over pixels, adding the contribution from this particle ! -do kpix = kpixmin,kpixmax - kpixi = kpix - if (periodicz) kpixi = iroll(kpix,npixz) - - zpix = zminpix + kpix*pixwidthz - dz = zpix - zi - dz2 = dz*dz*hi21 - - do jpix = jpixmin,jpixmax - jpixi = jpix - if (periodicy) jpixi = iroll(jpix,npixy) - - ypix = yminpix + jpix*pixwidthy - dy = ypix - yi - dyz2 = dy*dy*hi21 + dz2 - - nxpix = 0 - do ipix = ipixmin,ipixmax - if ((kpix==kpixmin).and.(jpix==jpixmin).and.(ipix==ipixmin)) then - usedpart = usedpart + 1 - endif - - nxpix = nxpix + 1 - ipixi = ipix - if (periodicx) ipixi = iroll(ipix,npixx) - - q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 - - if (exact_rendering .and. ipixmax-ipixmin <= 4) then - if (q2 < radkernel2 + 3.*pixwidthmax**2*hi21) then - xpixi = xminpix + ipix*pixwidthx - - ! Contribution of the cell walls in the xy-plane - pixint = 0.0 - wint = wallint(zpix-zi+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) - pixint = pixint + wint - - wint = wallint(zi-zpix+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) - pixint = pixint + wint - - ! Contribution of the cell walls in the xz-plane - wint = wallint(ypix-yi+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) - pixint = pixint + wint - - wint = wallint(yi-ypix+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) - pixint = pixint + wint - - ! Contribution of the cell walls in the yz-plane - wint = wallint(xpixi-xi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) - pixint = pixint + wint - - wint = wallint(xi-xpixi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) - pixint = pixint + wint - - wab = pixint*dfac ! /(pixwidthx*pixwidthy*pixwidthz*const)*hi**3 - - if (pixint < -0.01d0) then - print*, "Error: (",ipixi,jpixi,kpixi,") -> ", pixint, term*wab - endif - - ! - !--calculate data value at this pixel using the summation interpolant - ! - !$omp atomic - datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab - if (normalise) then - !$omp atomic - datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - endif - endif - else - if (q2 < radkernel2) then - - ! - !--SPH kernel - standard cubic spline - ! - wab = wkernel(q2) - ! - !--calculate data value at this pixel using the summation interpolant - ! - !$omp atomic - datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab - if (normalise) then - !$omp atomic - datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - endif - endif - endif - enddo - enddo -enddo -enddo over_parts + do kpix = kpixmin,kpixmax + kpixi = kpix + if (periodicz) kpixi = iroll(kpix,npixz) + + zpix = zminpix + kpix*pixwidthz + dz = zpix - zi + dz2 = dz*dz*hi21 + + do jpix = jpixmin,jpixmax + jpixi = jpix + if (periodicy) jpixi = iroll(jpix,npixy) + + ypix = yminpix + jpix*pixwidthy + dy = ypix - yi + dyz2 = dy*dy*hi21 + dz2 + + nxpix = 0 + do ipix = ipixmin,ipixmax + if ((kpix==kpixmin).and.(jpix==jpixmin).and.(ipix==ipixmin)) then + usedpart = usedpart + 1 + endif + + nxpix = nxpix + 1 + ipixi = ipix + if (periodicx) ipixi = iroll(ipix,npixx) + + q2 = dx2i(nxpix) + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 + + if (exact_rendering .and. ipixmax-ipixmin <= 4) then + if (q2 < radkernel2 + 3.*pixwidthmax**2*hi21) then + xpixi = xminpix + ipix*pixwidthx + + ! Contribution of the cell walls in the xy-plane + pixint = 0.0 + wint = wallint(zpix-zi+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) + pixint = pixint + wint + + wint = wallint(zi-zpix+0.5*pixwidthz,xi,yi,xpixi,ypix,pixwidthx,pixwidthy,hi) + pixint = pixint + wint + + ! Contribution of the cell walls in the xz-plane + wint = wallint(ypix-yi+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) + pixint = pixint + wint + + wint = wallint(yi-ypix+0.5*pixwidthy,xi,zi,xpixi,zpix,pixwidthx,pixwidthz,hi) + pixint = pixint + wint + + ! Contribution of the cell walls in the yz-plane + wint = wallint(xpixi-xi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) + pixint = pixint + wint + + wint = wallint(xi-xpixi+0.5*pixwidthx,zi,yi,zpix,ypix,pixwidthz,pixwidthy,hi) + pixint = pixint + wint + + wab = pixint*dfac ! /(pixwidthx*pixwidthy*pixwidthz*const)*hi**3 + + if (pixint < -0.01d0) then + print*, "Error: (",ipixi,jpixi,kpixi,") -> ", pixint, term*wab + endif + + ! + !--calculate data value at this pixel using the summation interpolant + ! + !$omp atomic + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + if (normalise) then + !$omp atomic + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + endif + endif + else + if (q2 < radkernel2) then + + ! + !--SPH kernel - standard cubic spline + ! + wab = wkernel(q2) + ! + !--calculate data value at this pixel using the summation interpolant + ! + !$omp atomic + datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab + if (normalise) then + !$omp atomic + datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab + endif + endif + endif + enddo + enddo + enddo + enddo over_parts !$omp enddo !$omp end parallel -if (nwarn > 0) then -print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& + if (nwarn > 0) then + print "(a,i11,a,/,a)",' interpolate3D: WARNING: contributions truncated from ',nwarn,' particles',& ' that wrap periodic boundaries more than once' -endif + endif ! !--normalise dat array ! -if (normalise) then -where (datnorm > tiny(datnorm)) - datsmooth = datsmooth/datnorm -end where -endif -if (allocated(datnorm)) deallocate(datnorm) + if (normalise) then + where (datnorm > tiny(datnorm)) + datsmooth = datsmooth/datnorm + end where + endif + if (allocated(datnorm)) deallocate(datnorm) !call wall_time(t_end) -call cpu_time(t_end) -t_used = t_end - t_start -print*, 'Interpolate3D completed in ',t_end-t_start,'s' + call cpu_time(t_end) + t_used = t_end - t_start + print*, 'Interpolate3D completed in ',t_end-t_start,'s' end subroutine interpolate3D @@ -695,8 +695,8 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !--calculate data value at this pixel using the summation interpolant ! do smoothindex=1, ilendat - !$omp atomic - datsmooth(smoothindex,ipixi,jpixi,kpixi) = datsmooth(smoothindex,ipixi,jpixi,kpixi) + term(smoothindex)*wab + !$omp atomic + datsmooth(smoothindex,ipixi,jpixi,kpixi) = datsmooth(smoothindex,ipixi,jpixi,kpixi) + term(smoothindex)*wab enddo if (normalise) then !$omp atomic @@ -714,8 +714,8 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !--calculate data value at this pixel using the summation interpolant ! do smoothindex=1,ilendat - !$omp atomic - datsmooth(smoothindex,ipixi,jpixi,kpixi) = datsmooth(smoothindex,ipixi,jpixi,kpixi) + term(smoothindex)*wab + !$omp atomic + datsmooth(smoothindex,ipixi,jpixi,kpixi) = datsmooth(smoothindex,ipixi,jpixi,kpixi) + term(smoothindex)*wab enddo if (normalise) then !$omp atomic @@ -739,12 +739,12 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& !--normalise dat array ! if (normalise) then - do i=1, ilendat - where (datnorm > tiny(datnorm)) + do i=1, ilendat + where (datnorm > tiny(datnorm)) - datsmooth(i,:,:,:) = datsmooth(i,:,:,:)/datnorm(:,:,:) - end where - enddo + datsmooth(i,:,:,:) = datsmooth(i,:,:,:)/datnorm(:,:,:) + end where + enddo endif if (allocated(datnorm)) deallocate(datnorm) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 5e12a738e..774536628 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -94,7 +94,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) use_func = .true. use_func_old = use_func remove_overlap = .true. - !--Power law default setups + !--Power law default setups rad_max = 7.1e16 ! in cm rad_min = 8.7e15 ! in cm nbreak = 1 @@ -103,7 +103,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) allocate(rhof_n(nbreak),rhof_rbreak(nbreak)) rhof_n = -1.7 rhof_rbreak = rad_min - !--Profile default setups + !--Profile default setups read_temp = .false. profile_filename = default_name nprof = 7 From 482376134f9f20ac6768fe164585fdac76fa0265 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 11:04:51 +1100 Subject: [PATCH 199/814] (interpolate) remove obsolete routine --- src/utils/interpolate3Dold.F90 | 367 --------------------------------- 1 file changed, 367 deletions(-) delete mode 100644 src/utils/interpolate3Dold.F90 diff --git a/src/utils/interpolate3Dold.F90 b/src/utils/interpolate3Dold.F90 deleted file mode 100644 index c7fff7ca7..000000000 --- a/src/utils/interpolate3Dold.F90 +++ /dev/null @@ -1,367 +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.github.io/ ! -!--------------------------------------------------------------------------! -module interpolations3D -! -! Module containing routine for interpolation from PHANTOM data -! to 3D adaptive mesh -! -! Requires adaptivemesh.f90 module -! -! :References: None -! -! :Owner: Spencer Magnall -! -! :Runtime parameters: None -! -! :Dependencies: kernel -! - - implicit none - real, parameter, private :: dpi = 1./3.1415926536d0 - public :: interpolate3D -!$ integer(kind=8), dimension(:), private, allocatable :: ilock - -contains -!-------------------------------------------------------------------------- -! subroutine to interpolate from particle data to even grid of pixels -! -! The data is interpolated according to the formula -! -! datsmooth(pixel) = sum_b weight_b dat_b W(r-r_b, h_b) -! -! where _b is the quantity at the neighbouring particle b and -! W is the smoothing kernel, for which we use the usual cubic spline. -! -! For a standard SPH smoothing the weight function for each particle should be -! -! weight = pmass/(rho*h^3) -! -! this version is written for slices through a rectangular volume, ie. -! assumes a uniform pixel size in x,y, whilst the number of pixels -! in the z direction can be set to the number of cross-section slices. -! -! Input: particle coordinates and h : xyzh(4,npart) -! weight for each particle : weight [ same on all parts in PHANTOM ] -! scalar data to smooth : dat (npart) -! -! Output: smoothed data : datsmooth (npixx,npixy,npixz) -! -! Daniel Price, Monash University 2010 -! daniel.price@monash.edu -!-------------------------------------------------------------------------- - -subroutine interpolate3D(xyzh,weight,npart, & - xmin,datsmooth,nnodes,dxgrid,normalise,dat,ngrid,vertexcen) - use kernel, only:wkern, radkern, radkern2, cnormk - !use adaptivemesh, only:ifirstlevel,nsub,ndim,gridnodes - integer, intent(in) :: npart,nnodes,ngrid(3) - real, intent(in) :: xyzh(:,:)! ,vxyzu(:,:) - real, intent(in) :: weight !,pmass - real, intent(in) :: xmin(3),dxgrid(3) - real, intent(out) :: datsmooth(:,:,:) - logical, intent(in) :: normalise, vertexcen - real, intent(in), optional :: dat(:) - real, allocatable :: datnorm(:,:,:) -! real, dimension(nsub**ndim,nnodes) :: datnorm - integer, parameter :: ndim = 3, nsub=1 - integer :: i,ipix,jpix,kpix,isubmesh,imesh,level,icell - integer :: iprintinterval,iprintnext - integer :: ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax - integer :: ipixi,jpixi,kpixi,npixx,npixy,npixz - real :: xi,yi,zi,hi,hi1,hi21,radkernh,qq,wab,q2,const,dyz2,dz2 - real :: xorigi,yorigi,zorigi,xpix,ypix,zpix,dx,dy,dz - real :: dxcell(ndim),xminnew(ndim), dxmax(ndim) - real :: t_start,t_end - real :: termnorm - real :: term - logical :: iprintprogress -!$ integer :: omp_get_num_threads,j -#ifndef _OPENMP - integer(kind=8) :: iprogress -#endif - - print*, "size: ", size(datsmooth) - print*, "datsmooth out of bounds: ", datsmooth(35,1,1) - datsmooth = 0. - dxmax(:) = dxgrid(:) - !datnorm = 0. - if (normalise) then - print "(1x,a)",'interpolating from particles to Einstein toolkit grid (normalised) ...' - else - print "(1x,a)",'interpolating from particles to Einstein toolkit grid (non-normalised) ...' - endif -! if (any(dxmax(:) <= 0.)) then -! print "(1x,a)",'interpolate3D: error: grid size <= 0' -! return -! endif -! if (ilendat /= 0) then -! print "(1x,a)",'interpolate3D: error in interface: dat has non-zero length but is not present' -! return -! endif - if (normalise) then - allocate(datnorm(ngrid(1),ngrid(2),ngrid(3))) - datnorm = 0. - endif - -!$ allocate(ilock(0:nnodes)) -!$ do i=0,nnodes -!$ call omp_init_lock(ilock(i)) -!$ enddo - - ! - !--print a progress report if it is going to take a long time - ! (a "long time" is, however, somewhat system dependent) - ! - iprintprogress = (npart >= 100000) .or. (nnodes > 10000) - ! - !--loop over particles - ! - iprintinterval = 25 - if (npart >= 1e6) iprintinterval = 10 - iprintnext = iprintinterval - ! - !--get starting CPU time - ! - call cpu_time(t_start) - - imesh = 1 - level = 1 - dxcell(:) = dxgrid(:)/real(nsub**level) -! xminpix(:) = xmin(:) - 0.5*dxcell(:) - npixx = ngrid(1) - npixy = ngrid(2) - npixz = ngrid(3) - print "(3(a,i4))",' root grid: ',npixx,' x ',npixy,' x ',npixz - print*, "position of i cell is: ", 1*dxcell(1) + xmin(1) - print*, "npart: ", npart - - const = cnormk ! kernel normalisation constant (3D) - print*,"const: ", const - !stop - - ! - !--loop over particles - ! - !$omp parallel default(none) & - !$omp shared(npart,xyzh,dat,datsmooth,datnorm,vertexcen,const,weight) & - !$omp shared(xmin,imesh,nnodes,level) & - !$omp shared(npixx,npixy,npixz,dxmax,dxcell,normalise) & - !$omp private(i,j,hi,hi1,hi21,termnorm,term) & - !$omp private(xpix,ypix,zpix,dx,dy,dz,dz2,dyz2,qq,q2,wab,radkernh) & - !$omp private(xi,yi,zi,xorigi,yorigi,zorigi,xminnew) & - !$omp private(ipix,jpix,kpix,ipixi,jpixi,kpixi,icell,isubmesh) & - !$omp private(ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax) - !$omp master -!$ print "(1x,a,i3,a)",'Using ',omp_get_num_threads(),' cpus' - !$omp end master - !$omp do schedule(guided,10) - over_parts: do i=1,npart - ! - !--report on progress - ! - !print*, i -#ifndef _OPENMP - if (iprintprogress) then - iprogress = nint(100.*i/npart) - if (iprogress >= iprintnext) then - write(*,"('(',i3,'% -',i12,' particles done)')") iprogress,i - iprintnext = iprintnext + iprintinterval - endif - endif -#endif - ! - !--set kernel related quantities - ! - xi = xyzh(1,i); xorigi = xi - yi = xyzh(2,i); yorigi = yi - zi = xyzh(3,i); zorigi = zi - hi = xyzh(4,i) - radkernh = radkern*hi - !print*, "hi: ", hi - if (hi <= 0.) cycle over_parts - hi1 = 1./hi; hi21 = hi1*hi1 - termnorm = const*weight - ! print*, "const: ", const - ! print*, "weight: ", weight - ! print*, "termnorm: ", termnorm - - !radkern = 2.*hi ! radius of the smoothing kernel - !print*, "radkern: ", radkern - !print*, "part pos: ", xi,yi,zi - term = termnorm*dat(i) ! weight for density calculation - ! I don't understand why this doesnt involve any actual smoothing? - !dfac = hi**3/(dxcell(1)*dxcell(2)*dxcell(3)*const) - ! - !--for each particle work out which pixels it contributes to - ! - !print*, "radkern: ", radkern - ipixmin = int((xi - radkernh - xmin(1))/dxcell(1)) - jpixmin = int((yi - radkernh - xmin(2))/dxcell(2)) - kpixmin = int((zi - radkernh - xmin(3))/dxcell(3)) - - ipixmax = int((xi + radkernh - xmin(1))/dxcell(1)) + 1 - jpixmax = int((yi + radkernh - xmin(2))/dxcell(2)) + 1 - kpixmax = nint((zi + radkernh - xmin(3))/dxcell(3)) + 1 - - !if (ipixmax == 33) stop - - - !if (ipixmin == 4 .and. jpixmin == 30 .and. kpixmin == 33) print*, "particle (min): ", i - !if (ipixmax == 4 .and. jpixmax == 30 .and. kpixmax == 33) print*, "particle (max): ", i -#ifndef PERIODIC - if (ipixmin < 1) ipixmin = 1 ! make sure they only contribute - if (jpixmin < 1) jpixmin = 1 ! to pixels in the image - if (kpixmin < 1) kpixmin = 1 - if (ipixmax > npixx) ipixmax = npixx - if (jpixmax > npixy) jpixmax = npixy - if (kpixmax > npixz) kpixmax = npixz - !print*, "ipixmin: ", ipixmin - !print*, "ipixmax: ", ipixmax - !print*, "jpixmin: ", jpixmin - !print*, "jpixmax: ", jpixmax - !print*, "kpixmin: ", kpixmin - !print*, "kpixmax: ", kpixmax -#endif - !print*,' part ',i,' lims = ',ipixmin,ipixmax,jpixmin,jpixmax,kpixmin,kpixmax - ! - !--loop over pixels, adding the contribution from this particle - ! (note that we handle the periodic boundary conditions - ! entirely on the root grid) - ! - do kpix = kpixmin,kpixmax - kpixi = kpix -#ifdef PERIODIC - if (kpixi < 1) then - kpixi = kpixi + npixz - zi = zorigi !+ dxmax(3) - elseif (kpixi > npixz) then - kpixi = kpixi - npixz - zi = zorigi !- dxmax(3) - else - zi = zorigi - endif -#endif - if (vertexcen) then - zpix = xmin(3) + (kpixi-1)*dxcell(3) - else - zpix = xmin(3) + (kpixi-0.5)*dxcell(3) - endif - dz = zpix - zi - dz2 = dz*dz*hi21 - - do jpix = jpixmin,jpixmax - jpixi = jpix -#ifdef PERIODIC - if (jpixi < 1) then - jpixi = jpixi + npixy - yi = yorigi !+ dxmax(2) - elseif (jpixi > npixy) then - jpixi = jpixi - npixy - yi = yorigi !- dxmax(2) - else - yi = yorigi - endif -#endif - if (vertexcen) then - ypix = xmin(2) + (jpixi-1)*dxcell(2) - else - ypix = xmin(2) + (jpixi-0.5)*dxcell(2) - endif - dy = ypix - yi - dyz2 = dy*dy*hi21 + dz2 - - do ipix = ipixmin,ipixmax - ipixi = ipix -#ifdef PERIODIC - if (ipixi < 1) then - ipixi = ipixi + npixx - xi = xorigi !+ dxmax(1) - elseif (ipixi > npixx) then - if (ipixi == 33) then - print*,"xi old: ", xorigi - print*, "xi new: ", xorigi-dxmax(1) - print*, "ipixi new: ", ipixi - npixx - endif - ipixi = ipixi - npixx - xi = xorigi !- dxmax(1) - else - xi = xorigi - endif -#endif - icell = ((kpixi-1)*nsub + (jpixi-1))*nsub + ipixi - ! - !--particle interpolates directly onto the root grid - ! - !print*,'onto root grid ',ipixi,jpixi,kpixi - if (vertexcen) then - xpix = xmin(1) + (ipixi-1)*dxcell(1) - else - xpix = xmin(1) + (ipixi-0.5)*dxcell(1) - endif - !print*, "xpix: ", xpix - !xpix = xmin(1) + (ipixi-1)*dxcell(1) ! Since we are vertex centered from Et - dx = xpix - xi - q2 = dx*dx*hi21 + dyz2 ! dx2 pre-calculated; dy2 pre-multiplied by hi21 - ! - !--SPH kernel - standard cubic spline - ! - if (q2 < radkern2) then - ! if (q2 < 1.0) then - ! qq = sqrt(q2) - ! wab = 1.-1.5*q2 + 0.75*q2*qq - ! else - ! qq = sqrt(q2) - ! wab = 0.25*(2.-qq)**3 - ! endif - ! Call the kernel routine - qq = sqrt(q2) - wab = wkern(q2,qq) - ! - !--calculate data value at this pixel using the summation interpolant - ! - ! Change this to the access the pixel coords x,y,z - !$omp critical - datsmooth(ipixi,jpixi,kpixi) = datsmooth(ipixi,jpixi,kpixi) + term*wab - - !if (ipixi==1 .and. jpixi==1 .and. kpixi==1) print*, "x position of 1,1,1", xi,yi,zi - if (normalise) then - datnorm(ipixi,jpixi,kpixi) = datnorm(ipixi,jpixi,kpixi) + termnorm*wab - endif - !$omp end critical - endif - enddo - enddo - enddo - enddo over_parts - !$omp enddo - !$omp end parallel - -!$ do i=0,nnodes -!$ call omp_destroy_lock(ilock(i)) -!$ enddo -!$ if (allocated(ilock)) deallocate(ilock) - - ! - !--normalise dat array - ! - if (normalise) then - where (datnorm > tiny(datnorm)) - datsmooth = datsmooth/datnorm - end where - endif - if (allocated(datnorm)) deallocate(datnorm) - ! - !--get ending CPU time - ! - call cpu_time(t_end) - print*,'completed in ',t_end-t_start,'s' - - return - -end subroutine interpolate3D - -end module interpolations3D From 6fde5a96acd7c491738671b19d0efd97ec032cf2 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 11:59:37 +1100 Subject: [PATCH 200/814] (#484) further reduced ntasks to 2 for MPI workflow --- .github/workflows/mpi.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/mpi.yml b/.github/workflows/mpi.yml index acd28d60c..46099c9f2 100644 --- a/.github/workflows/mpi.yml +++ b/.github/workflows/mpi.yml @@ -19,7 +19,7 @@ jobs: - yes ntasks: - 1 - - 4 + - 2 input: # [SETUP, phantom_tests] - ['test', ''] - ['testkd', ''] From 3711dc7021f9172a228774e125852b4e93ee8cc1 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 12:11:23 +1100 Subject: [PATCH 201/814] updated mailmap --- .mailmap | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/.mailmap b/.mailmap index 567c60b95..b870153b5 100644 --- a/.mailmap +++ b/.mailmap @@ -21,12 +21,13 @@ Rebecca Nealon Nealon Alex Alex Pettitt Alex Pettitt -Terrence Tricco - - - - - + + + + + + +Terrence Tricco James Wurster James Wurster James Wurster jameswurster James Wurster jameswurster @@ -46,12 +47,12 @@ Stéven Toupin stoupin Guillaume Laibe glaibe Guillaume Laibe glaibe Alice Cerioli ALICE CERIOLI +Alice Cerioli Thomas Reichardt Thomas Reichardt Thomas Reichardt Thomas Reichardt Mr Thomas Reichardt Roberto Iaconi Roberto Iaconi Roberto Iaconi Roberto Iaconi -Alice Cerioli Daniel Mentiplay Daniel Mentiplay Daniel Mentiplay @@ -85,8 +86,13 @@ Fangyi (Fitz) Hu Fitz-Hu <54089891+Fitz-Hu@users.n Fangyi (Fitz) Hu root Fangyi (Fitz) Hu root Fangyi (Fitz) Hu fitzHu <54089891+Fitz-Hu@users.noreply.github.com> +Fangyi (Fitz) Hu Fitz Hu +Fangyi (Fitz) Hu fhu Megha Sharma Megha Sharma <40732335+msha0023@users.noreply.github.com> Megha Sharma megha sharma +Megha Sharma Megha Sharma +Megha Sharma Megha Sharma +Megha Sharma Megha Sharma Mike Lau Mike Lau <55525335+themikelau@users.noreply.github.com> Elisabeth Borchert emborchert <69176538+emborchert@users.noreply.github.com> Ward Homan ward @@ -103,3 +109,9 @@ Sahl Rowther Sahl Rowther sahl95 Caitlyn Hardiman caitlynhardiman <72479852+caitlynhardiman@users.noreply.github.com> Amena Faruqi <42060670+amenafaruqi@users.noreply.github.com> +Amena Faruqi Amena Faruqi +Alison Young Alison Young +Simone Ceppi Simone Ceppi +Mats Esseldeurs mats esseldeurs +Mats Esseldeurs MatsEsseldeurs +Nicolás Cuello Nicolas Cuello From 7f901e18124c20e8860d6ba4a3b2c6ce3c83323d Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 12:13:33 +1100 Subject: [PATCH 202/814] [header-bot] updated file headers --- src/utils/analysis_radiotde.f90 | 2 +- src/utils/moddump_radiotde.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index e18da12f1..b994822d8 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -10,7 +10,7 @@ module analysis ! ! :References: None ! -! :Owner: fhu +! :Owner: Fitz) Hu ! ! :Runtime parameters: ! - drad_cap : *capture thickness (in cm) (-ve for all particles at outer radius)* diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 774536628..b64612288 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -10,7 +10,7 @@ module moddump ! ! :References: None ! -! :Owner: fhu +! :Owner: Fitz) Hu ! ! :Runtime parameters: ! - ieos : *equation of state used* From fee837a0c65b10899b036f69cb28dfd688784940 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 12:13:46 +1100 Subject: [PATCH 203/814] [author-bot] updated AUTHORS file --- AUTHORS | 48 ++++++++++++++++++------------------------------ 1 file changed, 18 insertions(+), 30 deletions(-) diff --git a/AUTHORS b/AUTHORS index a647036c4..1dc027d7b 100644 --- a/AUTHORS +++ b/AUTHORS @@ -11,23 +11,19 @@ Conrad Chan James Wurster David Liptai Lionel Siess +Fangyi (Fitz) Hu Daniel Mentiplay +Megha Sharma Arnaud Vericel Mark Hutchison -Fitz Hu -Megha Sharma +Mats Esseldeurs Rebecca Nealon Elisabeth Borchert Ward Homan Christophe Pinte -Fangyi (Fitz) Hu -Megha Sharma -Terrence Tricco -Mats Esseldeurs +Terrence Tricco +Simone Ceppi Stephane Michoulier -Simone Ceppi -MatsEsseldeurs -fhu Spencer Magnall Caitlyn Hardiman Enrico Ragusa @@ -36,43 +32,35 @@ Cristiano Longarini Giovanni Dipierro Roberto Iaconi Hauke Worpel +Amena Faruqi Alison Young -Simone Ceppi Stephen Neilson <36410751+s-neilson@users.noreply.github.com> -Amena Faruqi Martina Toscani Benedetta Veronesi -Simon Glover Sahl Rowther Thomas Reichardt +Simon Glover Jean-François Gonzalez Christopher Russell +Phantom benchmark bot +Jolien Malfait Alessia Franchini Alex Pettitt -Jolien Malfait -Phantom benchmark bot Nicole Rodrigues Kieran Hirsh -Amena Faruqi -David Trevascus +Nicolás Cuello Farzana Meru -Nicolas Cuello -Megha Sharma +David Trevascus Chris Nixon -Megha Sharma -s-neilson <36410751+s-neilson@users.noreply.github.com> -Orsola De Marco -Terrence Tricco +Giulia Ballabio Miguel Gonzalez-Bolivar -Benoit Commercon -Zachary Pellow Maxime Lombart +Benoit Commercon +Orsola De Marco Joe Fisher -Giulia Ballabio -Jorge Cuadra -Stéven Toupin -Nicolás Cuello -mats esseldeurs -Alison Young +s-neilson <36410751+s-neilson@users.noreply.github.com> +Zachary Pellow Cox, Samuel Steven Rieder +Stéven Toupin +Jorge Cuadra From d1b950dd3fd637078ba0f051aeadf87e414036f5 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 14:52:02 +1100 Subject: [PATCH 204/814] merge conflict fixed --- src/main/checksetup.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index 7529c36bd..77e711410 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.F90 @@ -547,11 +547,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) dx = xyzmh_ptmass(1:3,j) - xyzmh_ptmass(1:3,i) r = sqrt(dot_product(dx,dx)) if (r <= tiny(r)) then -<<<<<<< HEAD - print*,'ERROR! sink ',j,' on top of sink ',i,' at ',xyzmh_ptmass(1:3,i) -======= print*,'ERROR: sink ',j,' on top of sink ',i,' at ',xyzmh_ptmass(1:3,i) ->>>>>>> master nerror = nerror + 1 elseif (r <= max(xyzmh_ptmass(ihacc,i),xyzmh_ptmass(ihacc,j))) then print*,'WARNING: sinks ',i,' and ',j,' within each others accretion radii: sep =',& From ecce1db5b9f5587f4b6c32bc486dbc9911b2cd4d Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 14:55:57 +1100 Subject: [PATCH 205/814] (geopot) merge conflict fixed --- src/setup/setup_binary.f90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index cfe852451..8f0999e8d 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -48,7 +48,7 @@ module setup subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& polyk,gamma,hfact,time,fileprefix) use part, only:gr,nptmass,xyzmh_ptmass,vxyz_ptmass,& - ihacc,ihsoft,eos_vars,rad,nsinkproperties + ihacc,ihsoft,eos_vars,rad,nsinkproperties,iJ2,iReff,ispinx,ispinz use setbinary, only:set_binary,get_a_from_period use units, only:is_time_unit,in_code_units,utime use physcon, only:solarm,au,pi,solarr,days @@ -61,6 +61,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& use mpidomain, only:i_belong use centreofmass, only:reset_centreofmass use setunits, only:mass_unit,dist_unit + use physcon, only:deg_to_rad integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -187,8 +188,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& if (iexternalforce==iext_geopot .or. iexternalforce==iext_star) then ! delete first sink particle and copy its properties to the central potential nptmass = nptmass - 1 - mass1 = m1 - accradius1 = hacc1 + mass1 = xyzmh_ptmass(4,nptmass+1) + accradius1 = xyzmh_ptmass(ihacc,nptmass+1) xyzmh_ptmass(:,nptmass) = xyzmh_ptmass(:,nptmass+1) vxyz_ptmass(:,nptmass) = vxyz_ptmass(:,nptmass+1) else From 5e4c654120ef97abbf064d5943e37c541e3814b9 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 15:22:35 +1100 Subject: [PATCH 206/814] (geopot) fix test suite failures --- src/tests/test_corotate.f90 | 4 ++-- src/tests/test_ptmass.f90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/tests/test_corotate.f90 b/src/tests/test_corotate.f90 index 9cdaedb2c..501442514 100644 --- a/src/tests/test_corotate.f90 +++ b/src/tests/test_corotate.f90 @@ -98,7 +98,7 @@ subroutine test_sinkbinary(ntests,npass) use io, only:id,master use testutils, only:checkval,update_test_scores use extern_corotate, only:get_centrifugal_force,get_coriolis_force,omega_corotate - use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass use setbinary, only:set_binary use externalforces, only:iext_corotate use ptmass, only:get_accel_sink_sink @@ -127,7 +127,7 @@ subroutine test_sinkbinary(ntests,npass) ! ti = 0. call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,& - iext_corotate,ti,merge_ij,merge_n) + iext_corotate,ti,merge_ij,merge_n,dsdt_ptmass) call checkval(3,fxyz_ptmass(1:3,1),0.,epsilon(0.),nfailed(4),'sink-sink force1 = 0') call checkval(3,fxyz_ptmass(1:3,2),0.,epsilon(0.),nfailed(5),'sink-sink force2 = 0') diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index f0b3b877d..e8f9a97e4 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -326,11 +326,11 @@ subroutine test_binary(ntests,npass) call checkvalbuf_end('grav. wave strain (+)',ncheckgw(2),nfailgw(2),errgw(2),tolgw) call update_test_scores(ntests,nfailgw(1:2),npass) endif - call checkval(angtot,angmomin,3.1e-14,nfailed(3),'angular momentum') + call checkval(angtot,angmomin,3.1e-13,nfailed(3),'angular momentum') call checkval(totmom,totmomin,epsilon(0.),nfailed(2),'linear momentum') tolen = 3.e-8 if (itest==4) tolen = 1.6e-2 ! etot is small compared to ekin - if (itest==5) tolen = 5.7e-1 + if (itest==5) tolen = 9.e-1 end select ! !--check energy conservation From 5f4fb1f008f527d5361f5e2168ebbeb301b0ba96 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 16:04:46 +1100 Subject: [PATCH 207/814] (geopot) fix test/build failures --- src/setup/setup_disc.f90 | 2 ++ src/tests/test_ptmass.f90 | 13 ++++++++++--- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 92d6f5f7c..766f2a74e 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -1843,6 +1843,7 @@ end subroutine set_planets ! !-------------------------------------------------------------------------- subroutine set_sink_oblateness(isink,J2,planet_size,spin_period_hrs,kfac,obliquity) + use physcon, only:jupiterr integer, intent(in) :: isink real, intent(in) :: J2,planet_size,spin_period_hrs,kfac,obliquity real :: spin_am,planet_radius,planet_spin_period @@ -3266,6 +3267,7 @@ end subroutine read_oblateness_options subroutine print_oblateness_info(isink,spin_period_hrs) use vectorutils, only:unitvec,mag use units, only:unit_angmom + use physcon, only:earthr,jupiterr,au integer, intent(in) :: isink real, intent(in) :: spin_period_hrs real :: u(3) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index e8f9a97e4..274bf8106 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -114,6 +114,7 @@ subroutine test_binary(ntests,npass) use testutils, only:checkvalf,checkvalbuf,checkvalbuf_end use checksetup, only:check_setup use deriv, only:get_derivs_global + use timing, only:getused,printused integer, intent(inout) :: ntests,npass integer :: i,ierr,itest,nfailed(3),nsteps,nerr,nwarn,norbits integer :: merge_ij(2),merge_n,nparttot,nfailgw(2),ncheckgw(2) @@ -122,6 +123,7 @@ subroutine test_binary(ntests,npass) real :: angmomin,etotin,totmomin,dum,dum2,omega,errmax,dtsinksink,fac,errgw(2) real :: angle,rin,rout real :: fxyz_sinksink(4,2) ! we only use 2 sink particles in the tests here + real(kind=4) :: t1 character(len=20) :: dumpfile real, parameter :: tolgw = 1.2e-2 ! @@ -178,7 +180,8 @@ subroutine test_binary(ntests,npass) hacc1 = 0.35 hacc2 = 0.35 C_force = 0.25 - omega = sqrt((m1+m2)/a**3) + omega = sqrt(m1*m2/(m1+m2)/a**3) + if (itest==5) omega = sqrt((m1+m2)/a**3) t = 0. call set_units(mass=1.d0,dist=1.d0,G=1.d0) call set_binary(m1,m2,a,ecc,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,verbose=.false.) @@ -239,8 +242,10 @@ subroutine test_binary(ntests,npass) ! !--take the sink-sink timestep specified by the get_forces routine ! - dt = min(C_force*dtsinksink,4.e-3*sqrt(2.*pi/omega)) !2.0/(nsteps) - dtmax = dt ! required prior to derivs call, as used to set ibin + dt = C_force*dtsinksink + if (m2 <= 0.) dt = min(C_force*dtsinksink,4.e-3*sqrt(2.*pi/omega)) + + dtmax = dt ! required prior to derivs call, as used to set ibin ! !--compute SPH forces ! @@ -283,6 +288,7 @@ subroutine test_binary(ntests,npass) nfailgw = 0; ncheckgw = 0 dumpfile='test_00000' f_acc = 1. + call getused(t1) call init_step(npart,t,dtmax) do i=1,nsteps t = t + dt @@ -304,6 +310,7 @@ subroutine test_binary(ntests,npass) endif enddo call compute_energies(t) + call printused(t1) nfailed(:) = 0 select case(itest) case(3) From db3c067b540451941fbf58f77eb607c4fe422da6 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 17:25:01 +1100 Subject: [PATCH 208/814] (geopot) test failures + floating exceptions fixed --- src/setup/set_binary.f90 | 6 +++--- src/tests/test_ptmass.f90 | 3 +++ 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/setup/set_binary.f90 b/src/setup/set_binary.f90 index ca302618b..caf44f11c 100644 --- a/src/setup/set_binary.f90 +++ b/src/setup/set_binary.f90 @@ -273,7 +273,7 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & v1 = -dv*m2/mtot v2 = dv*m1/mtot - omega0 = v1(2)/x1(1) + omega0 = v2(2)/x2(1) ! print info about positions and velocities if (do_verbose) then @@ -282,8 +282,8 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & 'energy (KE+PE) :',-mtot/sqrt(dot_product(dx,dx)) + 0.5*dot_product(dv,dv),& 'angular momentum :',angmbin, & 'mean ang. speed :',omega0, & - 'Omega_0 (prim) :',v1(2)/x1(1), & - 'Omega_0 (second) :',v1(2)/x1(1), & + 'Omega_0 (prim) :',v2(2)/x2(1), & + 'Omega_0 (second) :',v2(2)/x2(1), & 'R_accretion (1) :',accretion_radius1, & 'R_accretion (2) :',accretion_radius2, & 'Roche lobe (1) :',Rochelobe1, & diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 274bf8106..c79cbfa79 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -115,6 +115,7 @@ subroutine test_binary(ntests,npass) use checksetup, only:check_setup use deriv, only:get_derivs_global use timing, only:getused,printused + use options, only:ipdv_heating,ishock_heating integer, intent(inout) :: ntests,npass integer :: i,ierr,itest,nfailed(3),nsteps,nerr,nwarn,norbits integer :: merge_ij(2),merge_n,nparttot,nfailgw(2),ncheckgw(2) @@ -134,6 +135,8 @@ subroutine test_binary(ntests,npass) tree_accuracy = 0. h_soft_sinksink = 0. calc_gravitwaves = .true. + ipdv_heating = 0 + ishock_heating = 0 binary_tests: do itest = 1,nbinary_tests select case(itest) From 426a728b4351489b760cfbc7495c41c4cda94f1e Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 17:44:10 +1100 Subject: [PATCH 209/814] (step; #55) remove GR ifdef from step, always compile extern_gr.F90 --- build/Makefile | 2 +- src/main/externalforces.f90 | 3 ++- src/main/step_leapfrog.F90 | 38 +++++++++++++++---------------------- 3 files changed, 18 insertions(+), 25 deletions(-) diff --git a/build/Makefile b/build/Makefile index 69d20f883..39061a658 100644 --- a/build/Makefile +++ b/build/Makefile @@ -482,7 +482,7 @@ SRCPOTS= extern_corotate.f90 \ externalforces.f90 endif ifeq (X$(SRCPOT), X) -SRCPOT=${SRCPOTS} +SRCPOT=extern_gr.F90 ${SRCPOTS} endif # # metrics for GR diff --git a/src/main/externalforces.f90 b/src/main/externalforces.f90 index 5a91b1f54..afdf3e033 100644 --- a/src/main/externalforces.f90 +++ b/src/main/externalforces.f90 @@ -558,12 +558,13 @@ end subroutine update_externalforce ! add checks to see if particle is bound etc. here) !+ !----------------------------------------------------------------------- -subroutine accrete_particles(iexternalforce,xi,yi,zi,hi,mi,ti,accreted) +subroutine accrete_particles(iexternalforce,xi,yi,zi,hi,mi,ti,accreted,i) use extern_binary, only:binary_accreted,accradius1 integer, intent(in) :: iexternalforce real, intent(in) :: xi,yi,zi,mi,ti real, intent(inout) :: hi logical, intent(out) :: accreted + integer, intent(in), optional :: i ! for compatibility with GR routine real :: r2 accreted = .false. diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 9f06f3d6a..45d9493fa 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -115,14 +115,11 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use timestep_ind, only:get_dt,nbinmax,decrease_dtmax,dt_too_small use timestep_sts, only:sts_get_dtau_next,use_sts,ibin_sts,sts_it_n use part, only:ibin,ibin_old,twas,iactive,ibin_wake -#ifdef GR use part, only:metricderivs use metric_tools, only:imet_minkowski,imetric use cons2prim, only:cons2primall use extern_gr, only:get_grforce_all -#else use cooling, only:cooling_in_step -#endif use timing, only:increment_timer,get_timings,itimer_extf use growth, only:check_dustprop use damping, only:idamp @@ -230,23 +227,22 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! accretion onto sinks/potentials also happens during substepping !---------------------------------------------------------------------- call get_timings(t1,tcpu1) -#ifdef GR - if ((iexternalforce > 0 .and. imetric /= imet_minkowski) .or. idamp > 0) then - call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) - call get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtextforce) - call step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,t) - else - call step_extern_sph_gr(dtsph,npart,xyzh,vxyzu,dens,pxyzu,metrics) - endif - -#else - if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then - call step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) + if (gr) then + if ((iexternalforce > 0 .and. imetric /= imet_minkowski) .or. idamp > 0) then + call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) + call get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtextforce) + call step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,t) + else + call step_extern_sph_gr(dtsph,npart,xyzh,vxyzu,dens,pxyzu,metrics) + endif else - call step_extern_sph(dtsph,npart,xyzh,vxyzu) + if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then + call step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & + nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) + else + call step_extern_sph(dtsph,npart,xyzh,vxyzu) + endif endif -#endif call get_timings(t2,tcpu2) call increment_timer(itimer_extf,t2-t1,tcpu2-tcpu1) @@ -679,13 +675,10 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call fatal('step','VELOCITY ITERATIONS NOT CONVERGED!!') endif -#ifdef GR - call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) -#endif + if (gr) call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) end subroutine step -#ifdef GR subroutine step_extern_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) use part, only:isdead_or_accreted,igas,massoftype,rhoh,eos_vars,igasP,& ien_type,eos_vars,igamma,itemp @@ -1028,7 +1021,6 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me end subroutine step_extern_gr -#endif !---------------------------------------------------------------- !+ ! This is the equivalent of the routine below when no external From 9c4b5dbd9736a42be6b89c2b582a12b34d49b0de Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 18:07:31 +1100 Subject: [PATCH 210/814] (geopot) mpi test failure fixed --- src/main/part.F90 | 4 +++- src/main/step_leapfrog.F90 | 4 +++- src/tests/test_ptmass.f90 | 16 ++++++++++------ 3 files changed, 16 insertions(+), 8 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index d4dbfb692..cbcbf5c32 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -189,7 +189,7 @@ module part real, allocatable :: xyzmh_ptmass(:,:) real, allocatable :: vxyz_ptmass(:,:) real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:) - real, allocatable :: dsdt_ptmass(:,:) + real, allocatable :: dsdt_ptmass(:,:),dsdt_ptmass_sinksink(:,:) integer :: nptmass = 0 ! zero by default real :: epot_sinksink character(len=*), parameter :: xyzmh_ptmass_label(nsinkproperties) = & @@ -411,6 +411,7 @@ subroutine allocate_part call allocate_array('fxyz_ptmass', fxyz_ptmass, 4, maxptmass) call allocate_array('fxyz_ptmass_sinksink', fxyz_ptmass_sinksink, 4, maxptmass) call allocate_array('dsdt_ptmass', dsdt_ptmass, 3, maxptmass) + call allocate_array('dsdt_ptmass_sinksink', dsdt_ptmass_sinksink, 3, maxptmass) call allocate_array('poten', poten, maxgrav) call allocate_array('nden_nimhd', nden_nimhd, n_nden_phantom, maxmhdni) call allocate_array('eta_nimhd', eta_nimhd, 4, maxmhdni) @@ -493,6 +494,7 @@ subroutine deallocate_part if (allocated(fxyz_ptmass)) deallocate(fxyz_ptmass) if (allocated(fxyz_ptmass_sinksink)) deallocate(fxyz_ptmass_sinksink) if (allocated(dsdt_ptmass)) deallocate(dsdt_ptmass) + if (allocated(dsdt_ptmass_sinksink)) deallocate(dsdt_ptmass_sinksink) if (allocated(poten)) deallocate(poten) if (allocated(nden_nimhd)) deallocate(nden_nimhd) if (allocated(eta_nimhd)) deallocate(eta_nimhd) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 45d9493fa..2f643f436 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -1074,7 +1074,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, use options, only:iexternalforce,icooling use part, only:maxphase,abundance,nabundances,h2chemistry,eos_vars,epot_sinksink,& isdead_or_accreted,iamboundary,igas,iphase,iamtype,massoftype,rhoh,divcurlv, & - fxyz_ptmass_sinksink,dust_temp,tau,nucleation,idK2,idmu,idkappa,idgamma + fxyz_ptmass_sinksink,dsdt_ptmass_sinksink,dust_temp,tau,nucleation,idK2,idmu,idkappa,idgamma use chem, only:update_abundances,get_dphot use cooling_ism, only:dphot0,energ_cooling_ism,dphotflag,abundsi,abundo,abunde,abundc,nabn use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete,summary_accrete_fail @@ -1176,9 +1176,11 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) endif fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf else fxyz_ptmass(:,:) = 0. + dsdt_ptmass(:,:) = 0. endif call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) call bcast_mpi(vxyz_ptmass(:,1:nptmass)) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index c79cbfa79..2cadbdbfa 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -123,7 +123,7 @@ subroutine test_binary(ntests,npass) real :: m1,m2,a,ecc,hacc1,hacc2,dt,dtext,t,dtnew,tolen,hp_exact,hx_exact real :: angmomin,etotin,totmomin,dum,dum2,omega,errmax,dtsinksink,fac,errgw(2) real :: angle,rin,rout - real :: fxyz_sinksink(4,2) ! we only use 2 sink particles in the tests here + real :: fxyz_sinksink(4,2),dsdt_sinksink(3,2) ! we only use 2 sink particles in the tests here real(kind=4) :: t1 character(len=20) :: dumpfile real, parameter :: tolgw = 1.2e-2 @@ -227,9 +227,10 @@ subroutine test_binary(ntests,npass) ! if (id==master) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_sinksink,epot_sinksink,& - dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) + dtsinksink,0,0.,merge_ij,merge_n,dsdt_sinksink) endif - fxyz_ptmass(:,:) = 0. + fxyz_ptmass(:,1:nptmass) = 0. + dsdt_ptmass(:,1:nptmass) = 0. call bcast_mpi(epot_sinksink) call bcast_mpi(dtsinksink) @@ -238,7 +239,10 @@ subroutine test_binary(ntests,npass) 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),dum,massoftype(igas),fxyz_ptmass,dsdt_ptmass,dum,dum2) enddo - if (id==master) fxyz_ptmass(:,1:nptmass) = fxyz_ptmass(:,1:nptmass) + fxyz_sinksink(:,1:nptmass) + if (id==master) then + fxyz_ptmass(:,1:nptmass) = fxyz_ptmass(:,1:nptmass) + fxyz_sinksink(:,1:nptmass) + dsdt_ptmass(:,1:nptmass) = dsdt_ptmass(:,1:nptmass) + dsdt_sinksink(:,1:nptmass) + endif call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) @@ -291,7 +295,7 @@ subroutine test_binary(ntests,npass) nfailgw = 0; ncheckgw = 0 dumpfile='test_00000' f_acc = 1. - call getused(t1) + if (id==master) call getused(t1) call init_step(npart,t,dtmax) do i=1,nsteps t = t + dt @@ -313,7 +317,7 @@ subroutine test_binary(ntests,npass) endif enddo call compute_energies(t) - call printused(t1) + if (id==master) call printused(t1) nfailed(:) = 0 select case(itest) case(3) From 2ebdc7a4d55b351f6a51af576685b00d53e88beb Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 18:07:52 +1100 Subject: [PATCH 211/814] (krome) quieten Makefile printout if Krome=no --- build/Makefile | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/build/Makefile b/build/Makefile index 39061a658..839ac79c8 100644 --- a/build/Makefile +++ b/build/Makefile @@ -571,16 +571,14 @@ ifeq ($(UNAME), Darwin) endif +ifeq ($(KROME), krome) @echo "" @echo "=============== CHEMISTRY ===============" @echo "" -ifeq ($(KROME), krome) @echo "krome coupling status = enabled" -else - @echo "krome coupling status = disabled" -endif @echo "" @echo "=========================================" +endif @sh ../scripts/phantom_version_gen.sh "$(IDFLAGS)" @echo "" @echo "The Phantom is here (in $(BINDIR)/phantom)" From d9d4a80f1ded20d64980f360d3cd0ebb49ab9511 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 18:11:17 +1100 Subject: [PATCH 212/814] (test_ptmass) use correct omega --- src/tests/test_ptmass.f90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 2cadbdbfa..927befc4a 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -183,8 +183,7 @@ subroutine test_binary(ntests,npass) hacc1 = 0.35 hacc2 = 0.35 C_force = 0.25 - omega = sqrt(m1*m2/(m1+m2)/a**3) - if (itest==5) omega = sqrt((m1+m2)/a**3) + omega = sqrt((m1+m2)/a**3) t = 0. call set_units(mass=1.d0,dist=1.d0,G=1.d0) call set_binary(m1,m2,a,ecc,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,verbose=.false.) From 746d870e0c19047197ade211c6908de60c67f4b7 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 18:11:33 +1100 Subject: [PATCH 213/814] (mpi) quieten a few warnings onto master thread only --- src/main/checksetup.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index 77e711410..15acdeb3c 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.F90 @@ -109,7 +109,7 @@ subroutine check_setup(nerror,nwarn,restart) nwarn = nwarn + 1 endif if (gamma <= 0.) then - print*,'WARNING! gamma not set (should be set > 0 even if not used)' + if (id==master) print*,'WARNING! gamma not set (should be set > 0 even if not used)' nwarn = nwarn + 1 endif endif @@ -117,10 +117,10 @@ subroutine check_setup(nerror,nwarn,restart) print*,'ERROR: npart = ',npart,', should be >= 0' nerror = nerror + 1 elseif (npart==0 .and. nptmass==0) then - print*,'WARNING! setup: npart = 0 (and no sink particles either)' + if (id==master) print*,'WARNING! setup: npart = 0 (and no sink particles either)' nwarn = nwarn + 1 elseif (npart==0) then - print*,'WARNING! setup contains no SPH particles (but has ',nptmass,' point masses)' + if (id==master) print*,'WARNING! setup contains no SPH particles (but has ',nptmass,' point masses)' nwarn = nwarn + 1 endif From 31c6a54e7f5408d124b727bc84e13a9a626fde50 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 21:25:03 +1100 Subject: [PATCH 214/814] (geopot) fix build failure --- build/Makefile | 8 +++++--- src/utils/analysis_common_envelope.f90 | 14 ++++++++------ 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/build/Makefile b/build/Makefile index 839ac79c8..c6e464592 100644 --- a/build/Makefile +++ b/build/Makefile @@ -468,7 +468,8 @@ OBJDIR=obj # external forces # ifeq (X$(SRCPOTS), X) -SRCPOTS= extern_corotate.f90 \ +SRCPOTS= extern_gr.F90 \ + extern_corotate.f90 \ extern_binary.f90 \ extern_spiral.f90 \ extern_lensethirring.f90 \ @@ -482,14 +483,15 @@ SRCPOTS= extern_corotate.f90 \ externalforces.f90 endif ifeq (X$(SRCPOT), X) -SRCPOT=extern_gr.F90 ${SRCPOTS} +SRCPOT=${SRCPOTS} endif # # metrics for GR # ifeq ($(GR),yes) - SRCPOT=extern_gr.F90 $(SRCPOTS:externalforces.f90=externalforces_gr.f90) + SRCPOT=$(SRCPOTS:externalforces.f90=externalforces_gr.f90) endif + ifdef METRIC SRCMETRIC= metric_${METRIC}.f90 else diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 6cd1c6c27..8aa0d5398 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -2938,6 +2938,7 @@ subroutine sink_properties(time,npart,particlemass,xyzh,vxyzu) real :: fxi, fyi, fzi, phii real, dimension(4,maxptmass) :: fssxyz_ptmass real, dimension(4,maxptmass) :: fxyz_ptmass + real, dimension(3,maxptmass) :: dsdt_ptmass real, dimension(3) :: com_xyz,com_vxyz integer :: i,ncols,merge_n,merge_ij(nptmass) @@ -2976,11 +2977,11 @@ subroutine sink_properties(time,npart,particlemass,xyzh,vxyzu) ' CoM vz' /) fxyz_ptmass = 0. - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,0,0.,merge_ij,merge_n) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) fssxyz_ptmass = fxyz_ptmass do i=1,npart call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,& - fxi,fyi,fzi,phii,particlemass,fxyz_ptmass,fonrmax) + fxi,fyi,fzi,phii,particlemass,fxyz_ptmass,dsdt_ptmass,fonrmax) enddo ! Determine position and velocity of the CoM @@ -3172,6 +3173,7 @@ subroutine gravitational_drag(time,npart,particlemass,xyzh,vxyzu) real, dimension(:), allocatable, save :: ang_mom_old,time_old real, dimension(:,:), allocatable :: drag_force real, dimension(4,maxptmass) :: fxyz_ptmass,fxyz_ptmass_sinksink + real, dimension(3,maxptmass) :: dsdt_ptmass real, dimension(3) :: avg_vel,avg_vel_par,avg_vel_perp,& com_xyz,com_vxyz,unit_vel,unit_vel_perp,& pos_wrt_CM,vel_wrt_CM,ang_mom,com_vec,& @@ -3311,7 +3313,7 @@ subroutine gravitational_drag(time,npart,particlemass,xyzh,vxyzu) ! Sum acceleration (fxyz_ptmass) on companion due to gravity of gas particles force_cut_vec = 0. fxyz_ptmass = 0. - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,0,0.,merge_ij,merge_n) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) sizeRcut = 5 if (i == 1) allocate(Rcut(sizeRcut)) @@ -3323,12 +3325,12 @@ subroutine gravitational_drag(time,npart,particlemass,xyzh,vxyzu) if (.not. isdead_or_accreted(xyzh(4,j))) then ! Get total gravitational force from gas call get_accel_sink_gas(nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),xyzmh_ptmass,& - fxi,fyi,fzi,phii,particlemass,fxyz_ptmass,fonrmax) + fxi,fyi,fzi,phii,particlemass,fxyz_ptmass,dsdt_ptmass,fonrmax) ! Get force from gas within distance cutoff do k = 1,sizeRcut if ( separation(xyzh(1:3,j), xyzmh_ptmass(1:4,i)) < Rcut(k) ) then call get_accel_sink_gas(nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),xyzmh_ptmass,& - fxi,fyi,fzi,phii,particlemass,force_cut_vec(1:4,:,k),fonrmax) + fxi,fyi,fzi,phii,particlemass,force_cut_vec(1:4,:,k),dsdt_ptmass,fonrmax) endif enddo endif @@ -3372,7 +3374,7 @@ subroutine gravitational_drag(time,npart,particlemass,xyzh,vxyzu) ! Calculate core + gas mass based on projected gravitational force Fgrav = fxyz_ptmass(1:3,i) * xyzmh_ptmass(4,i) - drag_perp_proj * (-unit_vel) ! Ftot,gas + Fsinksink = Fdrag + Fgrav - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass_sinksink,phitot,dtsinksink,0,0.,merge_ij,merge_n) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass_sinksink,phitot,dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) Fgrav = Fgrav + fxyz_ptmass_sinksink(1:3,i) * xyzmh_ptmass(4,i) Fgrav_mag = distance(Fgrav) mass_coregas = Fgrav_mag * sinksinksep**2 / xyzmh_ptmass(4,i) From 5456364137e389e05b4455e065b5b39412e4998b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 23:10:45 +1100 Subject: [PATCH 215/814] (geopot) build failures fixed --- src/main/externalforces.f90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/main/externalforces.f90 b/src/main/externalforces.f90 index afdf3e033..5a6471972 100644 --- a/src/main/externalforces.f90 +++ b/src/main/externalforces.f90 @@ -40,6 +40,7 @@ module externalforces real, private :: eps2_soft = 0.d0 real, public :: Rdisc = 5. + real, public :: accradius1_hard = 0. logical, public :: extract_iextern_from_hdr = .false. public :: mass1 @@ -635,7 +636,9 @@ subroutine write_options_externalforces(iunit,iexternalforce) select case(iexternalforce) case(iext_star,iext_prdrag,iext_lensethirring,iext_einsteinprec,iext_gnewton,iext_geopot) call write_inopt(mass1,'mass1','mass of central object in code units',iunit) + if (accradius1_hard < tiny(0.)) accradius1_hard = accradius1 call write_inopt(accradius1,'accradius1','soft accretion radius of central object',iunit) + call write_inopt(accradius1_hard,'accradius1_hard','hard accretion radius of central object',iunit) end select select case(iexternalforce) @@ -770,6 +773,10 @@ subroutine read_options_externalforces(name,valstring,imatch,igotall,ierr,iexter read(valstring,*,iostat=ierr) accradius1 if (iexternalforce <= 0) call warn(tag,'no external forces: ignoring accradius1 value') if (accradius1 < 0.) call fatal(tag,'negative accretion radius') + case('accradius1_hard') + read(valstring,*,iostat=ierr) accradius1_hard + if (iexternalforce <= 0) call warn(tag,'no external forces: ignoring accradius1_hard value') + if (accradius1_hard > accradius1) call fatal(tag,'hard accretion boundary must be within soft accretion boundary') case('eps_soft') read(valstring,*,iostat=ierr) eps_soft if (iexternalforce <= 0) call warn(tag,'no external forces: ignoring accradius1 value') From f0bd64e36ce97e19fb19a8ae8cbf204b8adc2bfa Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 28 Nov 2023 15:21:09 +0100 Subject: [PATCH 216/814] (readwrite_mesa) increase output precision of write_mesa to match MESA profiles --- src/setup/readwrite_mesa.f90 | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index bb8312f36..3bc0c780b 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.f90 @@ -198,39 +198,43 @@ subroutine write_mesa(outputpath,m,pres,temp,r,rho,ene,Xfrac,Yfrac,csound,mu) real, intent(in) :: m(:),rho(:),pres(:),r(:),ene(:),temp(:) real, intent(in), optional :: Xfrac(:),Yfrac(:),csound(:),mu(:) character(len=120), intent(in) :: outputpath - character(len=200) :: headers - integer :: i,noptionalcols,j,iu + character(len=200) :: headers(100) + integer :: i,ncols,noptionalcols,j,iu real, allocatable :: optionalcols(:,:) - character(len=*), parameter :: fmtstring = "(5(es13.6,2x),es13.6)" + character(len=*), parameter :: fmtstring = "(5(es24.16e3,2x),es24.16e3)" - headers = '[ Mass ] [ Pressure ] [Temperature] [ Radius ] [ Density ] [ E_int ]' + ncols = 6 + headers(1:ncols) = (/' Mass',' Pressure','Temperature',' Radius',' Density',' Eint'/) ! Add optional columns - allocate(optionalcols(size(r),10)) noptionalcols = 0 + allocate(optionalcols(size(r),10)) if (present(Xfrac)) then noptionalcols = noptionalcols + 1 - headers = trim(headers) // ' [ Xfrac ]' + headers(noptionalcols+ncols) = ' Xfrac' optionalcols(:,noptionalcols) = Xfrac endif if (present(Yfrac)) then noptionalcols = noptionalcols + 1 - headers = trim(headers) // ' [ Yfrac ]' + headers(noptionalcols+ncols) = ' Yfrac' optionalcols(:,noptionalcols) = Yfrac endif if (present(mu)) then noptionalcols = noptionalcols + 1 - headers = trim(headers) // ' [ mu ]' + headers(noptionalcols+ncols) = ' mu' optionalcols(:,noptionalcols) = mu endif if (present(csound)) then noptionalcols = noptionalcols + 1 - headers = trim(headers) // ' [Sound speed]' + headers(noptionalcols+ncols) = 'Sound speed' optionalcols(:,noptionalcols) = csound endif open(newunit=iu, file = outputpath, status = 'replace') - write(iu,'(a)') headers + do i = 1,noptionalcols+ncols-1 + write(iu,'(a24,2x)',advance="no") trim(headers(i)) + enddo + write(iu,'(a24)') trim(headers(noptionalcols+ncols)) do i=1,size(r) if (noptionalcols <= 0) then @@ -239,9 +243,9 @@ subroutine write_mesa(outputpath,m,pres,temp,r,rho,ene,Xfrac,Yfrac,csound,mu) write(iu,fmtstring,advance="no") m(i),pres(i),temp(i),r(i),rho(i),ene(i) do j=1,noptionalcols if (j==noptionalcols) then - write(iu,'(2x,es13.6)') optionalcols(i,j) + write(iu,'(2x,es24.16e3)') optionalcols(i,j) else - write(iu,'(2x,es13.6)',advance="no") optionalcols(i,j) + write(iu,'(2x,es24.16e3)',advance="no") optionalcols(i,j) endif enddo endif From 0c907f94c6dbf6c3a50c6dd56d0265311caa0b7f Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 28 Nov 2023 15:27:14 +0100 Subject: [PATCH 217/814] (ptmass_heating) add option to use smoothing kernel to distribute heating --- src/main/ptmass_heating.f90 | 81 +++++++++++++++++++++++++++++++++---- 1 file changed, 74 insertions(+), 7 deletions(-) diff --git a/src/main/ptmass_heating.f90 b/src/main/ptmass_heating.f90 index 370c6103c..66137558e 100644 --- a/src/main/ptmass_heating.f90 +++ b/src/main/ptmass_heating.f90 @@ -6,7 +6,7 @@ !--------------------------------------------------------------------------! module ptmass_heating ! -! Heating of particles around softening radius of sink particle +! Heating of particles around sink particles ! ! :References: None ! @@ -18,14 +18,16 @@ module ptmass_heating ! implicit none - public :: energ_sinkheat - real, public :: Lnuc + public :: energ_sinkheat,heating_kernel + real, public :: Lnuc + integer, public :: isink_heating + private contains !----------------------------------------------------------------------- !+ -! Heat from point mass +! heating from point mass !+ !----------------------------------------------------------------------- subroutine energ_sinkheat(nptmass,xyzmh_ptmass,xi,yi,zi,dudtheati) @@ -35,17 +37,82 @@ subroutine energ_sinkheat(nptmass,xyzmh_ptmass,xi,yi,zi,dudtheati) real, intent(in) :: xi,yi,zi,xyzmh_ptmass(:,:) real, intent(out) :: dudtheati integer :: i - real :: dri2 + real :: q2,dri2 dudtheati = 0. do i = 1,nptmass dri2 = (xi-xyzmh_ptmass(1,i))**2 + (yi-xyzmh_ptmass(2,i))**2 + (zi-xyzmh_ptmass(3,i))**2 - if (dri2 < radkern2*xyzmh_ptmass(ihsoft,i)**2) then - dudtheati = xyzmh_ptmass(iLum,i) / xyzmh_ptmass(imassenc,i) + q2 = dri2/xyzmh_ptmass(ihsoft,i)**2 + if (q2 < radkern2) then + dudtheati = xyzmh_ptmass(iLum,i) / xyzmh_ptmass(imassenc,i) * heating_kernel(q2,isink_heating) endif enddo end subroutine energ_sinkheat +!----------------------------------------------------------------------- +!+ +! heating weight function (note: arbitrary normalisation) +!+ +!----------------------------------------------------------------------- +real function heating_kernel(q2,kernel_type) + use kernel, only:wkern,cnormk + real, intent(in) :: q2 + integer, intent(in) :: kernel_type + + select case(kernel_type) + case(1) + heating_kernel = cnormk*wkern(q2,sqrt(q2)) + case default + heating_kernel = 1. + end select + +end function heating_kernel + + +!----------------------------------------------------------------------- +!+ +! write options to input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_ptmass_heating(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + call write_inopt(isink_heating,'isink_heating','sink heating distirbution (0=uniform,1=kernel)',iunit) + +end subroutine write_options_ptmass_heating + + +!----------------------------------------------------------------------- +!+ +! read options from input file +!+ +!----------------------------------------------------------------------- +subroutine read_options_ptmass_heating(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 + integer :: ni + character(len=30), parameter :: label = 'read_options_ptmass_heating' + + imatch = .true. + igotall = .false. + select case(trim(name)) + case('isink_heating') + read(valstring,*,iostat=ierr) isink_heating + ngot = ngot + 1 + if (isink_heating < 0 .or. isink_heating > 1) call fatal(label,'invalid setting for isink_heating ([0,1])') + case default + imatch = .false. + end select + ni = 1 + igotall = (ngot >= ni) + +end subroutine read_options_ptmass_heating + + end module ptmass_heating From 21ee5a3f5003aa5b1a50ac6d0517c316d23d1b6d Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 28 Nov 2023 15:30:02 +0100 Subject: [PATCH 218/814] (ptmass) omp parallelise calculation of enclosed mass and add weight function according to heating kernel --- src/main/ptmass.F90 | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index d4fabe75d..9afa848f9 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1717,26 +1717,38 @@ end subroutine calculate_mdot !----------------------------------------------------------------------- !+ -! calculate mass enclosed in sink softening radius +! calculate (weighted) sum of particle mass enclosed in sink softening radius !+ !----------------------------------------------------------------------- subroutine ptmass_calc_enclosed_mass(nptmass,npart,xyzh) - use part, only:imassenc,ihsoft,massoftype,igas,xyzmh_ptmass - use kernel, only:radkern2 + use part, only:sink_has_heating,imassenc,ihsoft,massoftype,igas,xyzmh_ptmass,isdead_or_accreted + use ptmass_heating, only:isink_heating,heating_kernel + use kernel, only:radkern2 integer, intent(in) :: nptmass,npart real, intent(in) :: xyzh(:,:) - integer :: i,j,ncount - real :: drj2 + integer :: i,j + real :: wi,q2,x0,y0,z0,hsoft21 do i = 1,nptmass - ncount = 0 + if (.not. sink_has_heating(xyzmh_ptmass(:,i))) cycle + wi = 0. + x0 = xyzmh_ptmass(1,i) + y0 = xyzmh_ptmass(2,i) + z0 = xyzmh_ptmass(3,i) + hsoft21 = 1./xyzmh_ptmass(ihsoft,i)**2 + + !$omp parallel do default (none) & + !$omp reduction(+:wi) & + !$omp shared(npart,xyzh,x0,y0,z0,i,hsoft21,isink_heating) & + !$omp private(j,q2) do j = 1,npart - drj2 = (xyzh(1,j)-xyzmh_ptmass(1,i))**2 + (xyzh(2,j)-xyzmh_ptmass(2,i))**2 + (xyzh(3,j)-xyzmh_ptmass(3,i))**2 - if (drj2 < radkern2*xyzmh_ptmass(ihsoft,i)**2) then - ncount = ncount + 1 + if (.not. isdead_or_accreted(xyzh(4,j))) then + q2 = ((xyzh(1,j)-x0)**2 + (xyzh(2,j)-y0)**2 + (xyzh(3,j)-z0)**2)*hsoft21 + if (q2 < radkern2) wi = wi + heating_kernel(q2,isink_heating) ! wj = 1 for uniform heating endif enddo - xyzmh_ptmass(imassenc,i) = ncount * massoftype(igas) + !$omp end parallel do + xyzmh_ptmass(imassenc,i) = wi * massoftype(igas) enddo end subroutine ptmass_calc_enclosed_mass From 162bdb2d393989d83bbbb33208eeb02685379ecb Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 28 Nov 2023 15:31:31 +0100 Subject: [PATCH 219/814] add query function to check if single ptmass has heating --- src/main/part.F90 | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/main/part.F90 b/src/main/part.F90 index 9a95e47f5..d54483019 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -745,6 +745,19 @@ logical function sinks_have_heating(nptmass,xyzmh_ptmass) end function sinks_have_heating +!------------------------------------------------------------------------ +!+ +! Query function to see if any sink particles have heating +!+ +!------------------------------------------------------------------------ +logical function sink_has_heating(xyzmh_ptmassi) + real, intent(in) :: xyzmh_ptmassi(:) + + sink_has_heating = xyzmh_ptmassi(iTeff) <= 0. .and. & + xyzmh_ptmassi(ilum) > 0. + +end function sink_has_heating + !---------------------------------------------------------------- !+ ! query function returning whether or not a particle is dead From bf242dc89e85a86fb6e912ef7d87dfe3be8eb5b9 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 28 Nov 2023 15:33:45 +0100 Subject: [PATCH 220/814] (get_idealplusrad_rhofrompresT) minor tweak to expression --- src/main/eos_idealplusrad.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/eos_idealplusrad.f90 b/src/main/eos_idealplusrad.f90 index 357d49acf..d98654bf3 100644 --- a/src/main/eos_idealplusrad.f90 +++ b/src/main/eos_idealplusrad.f90 @@ -141,7 +141,7 @@ subroutine get_idealplusrad_rhofrompresT(presi,tempi,mu,densi) real, intent(in) :: presi,tempi,mu real, intent(out) :: densi - densi = (presi - 1./3.*radconst*tempi**4) * mu / (Rg*tempi) + densi = (presi - radconst*tempi**4 /3.) * mu / (Rg*tempi) end subroutine get_idealplusrad_rhofrompresT From a57ae7844a7e8daafe3087b17d7b35d7f00e1f01 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 29 Nov 2023 13:33:47 +0100 Subject: [PATCH 221/814] (fixed_lum_core) shoot for profile for arbitrary heating kernel --- src/setup/set_fixedlumcore.f90 | 189 ++++++++++++++++++++------------- 1 file changed, 115 insertions(+), 74 deletions(-) diff --git a/src/setup/set_fixedlumcore.f90 b/src/setup/set_fixedlumcore.f90 index 7b53aa8ce..915e8de6f 100644 --- a/src/setup/set_fixedlumcore.f90 +++ b/src/setup/set_fixedlumcore.f90 @@ -24,7 +24,7 @@ module setfixedlumcore public :: set_fixedlum_softened_core private - integer, parameter :: ierr_rho=1,ierr_pres=2,ierr_mass=3 + integer, parameter :: ierr_rho=1,ierr_pres=2,ierr_mass=3,ierr_lum=4 contains @@ -81,11 +81,11 @@ subroutine set_fixedlum_softened_core(eos_type,rcore,Lstar,mcore,rho,r,pres,m,Xc X_local=Xcore,Z_local=1.-Xcore-Ycore) enddo - iverbose = 0 + iverbose = 1 call shoot_for_mcore(eos_type,r_alloc,mc,m(icore),Lstar,rho_alloc,pres_alloc,T_alloc,Xcore,Ycore,iverbose) mcore = mc / solarm - write(*,'(1x,a,f8.5,a)') 'Obtained core mass of ',mcore,' Msun' - write(*,'(1x,a,f8.5,a)') 'Softened mass is ',m(icore)/solarm-mcore,' Msun' + write(*,'(1x,a,es24.16e3,a)') 'Obtained core mass of ',mcore,' Msun' + write(*,'(1x,a,es24.16e3,a)') 'Softened mass is ',m(icore)/solarm-mcore,' Msun' rho(1:icore) = rho_alloc(1:icore) pres(1:icore) = pres_alloc(1:icore) call calc_mass_from_rho(r(1:icore),rho(1:icore),m(1:icore)) @@ -107,8 +107,9 @@ subroutine shoot_for_mcore(eos_type,r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,i real, intent(in) :: Lstar,mh,Xcore,Ycore real, intent(inout) :: mcore real, allocatable, dimension(:), intent(inout) :: rho,pres,temp - integer :: Nmax,it,ierr - real :: mass,mold,msoft,fac,mu,mcore_old + integer :: Nmax,it_m,it_l,ierr + real :: mass,mold,msoft,fac_m,fac_l,mu,mcore_old,& + eps0,epsold,l,lold,tol_eps,tol_m ! INSTRUCTIONS @@ -125,46 +126,90 @@ subroutine shoot_for_mcore(eos_type,r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,i mu = get_mean_molecular_weight(Xcore,1.-Xcore-Ycore) ! Start shooting method - fac = 0.0005 + fac_m = 0.005 mass = msoft - it = 0 - do + tol_eps = 1.e-10 + tol_m = 1.e-10 + + !---------------------------LOOP-OVER-MCORE------------------------------------- + ! Vary mcore so that m(0) = 0 + it_m = 0 + loop_over_mcore: do + l = Lstar + eps0 = Lstar/msoft ! initial guess for eps0 / erg/g mold = mass mcore_old = mcore - ierr = 0 - call one_shot(eos_type,r,mcore,msoft,Lstar,mu,rho,pres,temp,mass,iverbose,ierr) ! returned mass is m(r=0) - it = it + 1 + !---------------------------LOOP-OVER-HEATING-FACTOR------------------------------------- + ! Vary heating factor (eps0) so that central luminosity is zero + it_l = 0 + fac_l = 0.01 + loop_over_eps0: do + epsold = eps0 + lold = l + ierr = 0 + call one_shot(eos_type,r,mcore,msoft,Lstar,eps0,mu,rho,pres,temp,mass,l,iverbose,ierr) ! returned mass is m(r=0) + it_l = it_l + 1 + + if (iverbose > 1) write(*,'(2(1x,i5),8(2x,a,e15.8),2x,a,i1)') & + it_m,it_l,'eps0=',eps0,'m(0)=',mass/solarm,& + 'l(0)=',l,'eps0_old=',epsold,'mcore_old = ',& + mcore_old/solarm,'mcore=',mcore/solarm,'fac_l=',fac_l,& + 'fac_m=',fac_m,'ierr=',ierr + + if (l < 0.) then + eps0 = eps0 * (1. - fac_l) + elseif (l/Lstar < tol_eps) then ! l(r=0) sufficiently close to zero + ! write(*,'(/,1x,a,i5,a,e12.5)') 'Tolerance on luminosity reached on iteration no.',it_l,', fac_l =',fac_l + exit loop_over_eps0 + else + eps0 = eps0 * (1. + fac_l) + endif - if (iverbose > 0) write(*,'(1x,i5,4(2x,a,e15.8),2x,a,i1)') it,'m(r=0) = ',mass/solarm,'mcore_old = ',& - mcore_old/solarm,'mcore = ',mcore/solarm,'fac = ',fac,'ierr = ',ierr + if (abs(epsold-eps0) < tiny(0.)) then + fac_l = fac_l * 1.05 + elseif (lold * l < 0.) then + fac_l = fac_l * 0.95 + endif + enddo loop_over_eps0 + !----------------------------------------------------------------------------------------- + it_m = it_m + 1 + if (iverbose == 1) write(*,'(2(1x,i5),6(2x,a,e15.8),2x,a,i1)') & + it_m,it_l,'eps0=',eps0,'m(0)=',mass/solarm,'mcore_old = ',& + mcore_old/solarm,'mcore=',mcore/solarm,'fac_l=',fac_l,& + 'fac_m=',fac_m,'ierr=',ierr if (mass < 0.) then - mcore = mcore * (1. - fac) - elseif (mass/msoft < 1d-10 .and. ierr <= ierr_pres) then ! m(r=0) sufficiently close to zero - write(*,'(/,1x,a,i5,a,e12.5)') 'Tolerance on central mass reached on iteration no.',it,', fac =',fac + mcore = mcore * (1. - fac_m) + elseif (mass/msoft < tol_m .and. ierr <= ierr_pres) then ! m(r=0) sufficiently close to zero + write(*,'(/,1x,a,i5,2(1x,a,es24.16e3))') 'Converged on iteration no.',it_m,', fac_m =',fac_m,'eps0 = ',eps0 if (ierr == ierr_rho) write(*,'(a)') 'WARNING: Profile contains density inversion' - exit + exit loop_over_mcore else - mcore = mcore * (1. + fac) + mcore = mcore * (1. + fac_m) endif msoft = mh - mcore - if (abs(mold-mass) < tiny(0.)) then - fac = fac * 1.02 - elseif (mold * mass < 0.) then - fac = fac * 0.99 + if (mold * mass < 0.) then + fac_m = fac_m * 0.95 + else + fac_m = fac_m * 1.05 endif + ! if (abs(mold-mass) < tiny(0.)) then + ! fac_m = fac_m * 1.02 + ! elseif (mold * mass < 0.) then + ! fac_m = fac_m * 0.99 + ! endif if (abs(mold-mass) < tiny(0.) .and. ierr <= ierr_rho) then write(*,'(/,1x,a,e12.5)') 'WARNING: Converged on mcore without reaching tolerance on zero & ¢ral mass. m(r=0)/msoft = ',mass/msoft if (ierr == ierr_rho) write(*,'(1x,a)') 'WARNING: Profile contains density inversion' - write(*,'(/,1x,a,i4,a,e12.5)') 'Reached iteration ',it,', fac=',fac - exit + write(*,'(/,1x,a,i4,a,e12.5)') 'Reached iteration ',it_m,', fac_m=',fac_m + exit loop_over_mcore endif - - enddo + enddo loop_over_mcore + !----------------------------------------------------------------------------------------- end subroutine shoot_for_mcore @@ -174,24 +219,24 @@ end subroutine shoot_for_mcore ! One shot: Solve structure for given guess for msoft/mcore !+ !----------------------------------------------------------------------- -subroutine one_shot(eos_type,r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ierr) +subroutine one_shot(eos_type,r,mcore,msoft,Lstar,eps0,mu,rho,pres,T,mass,l,iverbose,ierr) use physcon, only:gg,pi,radconst,c,solarm use eos, only:calc_rho_from_PT,iopacity_type use radiation_utils, only:get_opacity use setfixedentropycore, only:gcore use units, only:unit_density,unit_opacity integer, intent(in) :: eos_type,iverbose - real, intent(in) :: mcore,msoft,Lstar,mu + real, intent(in) :: mcore,msoft,Lstar,eps0,mu real, allocatable, dimension(:), intent(in) :: r real, allocatable, dimension(:), intent(inout) :: rho,pres,T - real, intent(out) :: mass + real, intent(out) :: mass,l integer, intent(out) :: ierr integer :: i,Nmax real :: kappai,kappa_code,rcore,mu_local,rho_code real, allocatable, dimension(:) :: dr,dvol,lum Nmax = size(rho)-1 - allocate(dr(1:Nmax+1),dvol(1:Nmax+1),lum(1:Nmax)) + allocate(dr(1:Nmax+1),dvol(1:Nmax+1),lum(1:Nmax+1)) ! Pre-fill arrays do i = 1,Nmax+1 @@ -201,41 +246,53 @@ subroutine one_shot(eos_type,r,mcore,msoft,Lstar,mu,rho,pres,T,mass,iverbose,ier rcore = r(Nmax) mass = msoft - lum(Nmax) = Lstar + lum(Nmax:Nmax+1) = Lstar mu_local = mu ierr = 0 do i = Nmax, 1, -1 - pres(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & - * rho(i) * gg * (mass/r(i)**2 + mcore * gcore(r(i),rcore)) & - + dr(i)**2 * pres(i+1) & - + ( dr(i+1)**2 - dr(i)**2) * pres(i) ) / dr(i+1)**2 + pres(i-1) = pres(i) + dr(i) * rho(i) * gg * (mass/r(i)**2 + mcore * gcore(r(i),rcore)) + ! pres(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & + ! * rho(i) * gg * (mass/r(i)**2 + mcore * gcore(r(i),rcore)) & + ! + dr(i)**2 * pres(i+1) & + ! + ( dr(i+1)**2 - dr(i)**2) * pres(i) ) / dr(i+1)**2 rho_code = rho(i) / unit_density call get_opacity(iopacity_type,rho_code,T(i),kappa_code) kappai = kappa_code * unit_opacity - T(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & - * 3./(16.*pi*radconst*c) * rho(i)*kappai*lum(i) / (r(i)**2*T(i)**3) & - + dr(i)**2 * T(i+1) & - + ( dr(i+1)**2 - dr(i)**2) * T(i) ) / dr(i+1)**2 + T(i-1) = T(i) + dr(i) * 3./(16.*pi*radconst*c) * rho(i)*kappai*lum(i) / (r(i)**2*T(i)**3) + ! T(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & + ! * 3./(16.*pi*radconst*c) * rho(i)*kappai*lum(i) / (r(i)**2*T(i)**3) & + ! + dr(i)**2 * T(i+1) & + ! + ( dr(i+1)**2 - dr(i)**2) * T(i) ) / dr(i+1)**2 call calc_rho_from_PT(eos_type,pres(i-1),T(i-1),rho(i-1),ierr,mu_local) mass = mass - rho(i)*dvol(i) - lum(i-1) = luminosity(mass/msoft,Lstar) + lum(i-1) = lum(i) - dr(i)*4.*pi*r(i)**2*rho(i)*eps0*eps_heating(r(i),rcore) + ! lum(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & + ! * (-4.*pi)*r(i)**2*rho(i)*eps0*eps_heating(r(i),rcore) & + ! + dr(i)**2 * lum(i+1) & + ! + ( dr(i+1)**2 - dr(i)**2) * lum(i) ) / dr(i+1)**2 + l = lum(i-1) - if (iverbose > 2) print*,Nmax-i+1,rho(i-1),mass,pres(i-1),T(i-1),kappai + if (iverbose > 3) print*,Nmax-i+1,rho(i-1),mass,pres(i-1),T(i-1),kappai,lum(i-1) if (mass < 0.) then ! m(r) < 0 encountered, exit and decrease mcore - if (iverbose > 1) print*,'WARNING: Negative mass reached at i = ',i, 'm = ',mass/solarm + if (iverbose > 2) print*,'WARNING: Negative mass reached at i = ',i, 'm = ',mass/solarm ierr = ierr_mass return endif + if (l < 0.) then ! l(r) < 0 encountered, exit and increase heating pre-factor eps0 + if (iverbose > 2) print*,'WARNING: Negative luminosity reached at i = ',i, 'm = ',mass/solarm + ierr = ierr_lum + return + endif if (rho(i-1) 1) then + if (iverbose > 2) then print*,'WARNING: Density inversion at i = ',i, 'm = ',mass/solarm write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4,2x,e12.7)') i,rho(i),rho(i-1),mass,kappai endif ierr = ierr_rho endif if (pres(i-1) 1) then + if (iverbose > 2) then print*,'WARNING: Pressure inversion at i = ',i, 'm = ',mass/solarm write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4,2x,e12.7)') i,pres(i-1),rho(i),mass,kappai endif @@ -248,37 +305,21 @@ end subroutine one_shot !----------------------------------------------------------------------- !+ -! Normalised luminosity function. q can be m/msoft or r/rcore -! Note: For point mass heating, q = r/(radkern*hsoft), not r/hsoft, so -! that luminosity reaches target value at r = radkern*hsoft +! Wrapper function to return heating rate per unit mass (epsilon). +! Warning: normalisation is arbitrary (see heating_kernel) !+ !----------------------------------------------------------------------- -function luminosity(q,Lstar,hsoft) -! use kernel, only:radkern,wkern,cnormk - real, intent(in) :: q,Lstar - real, intent(in), optional :: hsoft - real :: luminosity - integer :: ilum - - ilum = 0 - - if (q > 1) then - luminosity = 1. - else - select case(ilum) - case(1) ! smooth step - luminosity = 3.*q**2 - 2.*q**3 - ! case(2) ! kernel softening - ! r_on_hsoft = q*radkern - ! luminosity = cnormk*wkern(r_on_hsoft*r_on_hsoft,r_on_hsoft)/hsoft**3 - case default ! linear (constant heating rate) - luminosity = q - end select - endif - - luminosity = luminosity * Lstar - -end function luminosity +function eps_heating(r,rcore) + use kernel, only:radkern2 + use ptmass_heating, only:heating_kernel,isink_heating + real, intent(in) :: r,rcore + real :: eps_heating,q2 + + isink_heating = 1 + q2 = radkern2 * r**2 / rcore**2 + eps_heating = heating_kernel(q2,isink_heating) + +end function eps_heating end module setfixedlumcore From 2042002d0ae880546057c572671b57b3ed1a928f Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 29 Nov 2023 13:35:16 +0100 Subject: [PATCH 222/814] (star) remove unneeded eos initialisation before core softening --- src/setup/set_softened_core.f90 | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index 9fea7e0b4..e75544b7b 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -109,14 +109,6 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore, Y(:) = Y(size(Y)) endif - if (eos_type==10) then - X_in = Xcore - Z_in = Zcore - call init_eos(eos_type,ierr) ! need to initialise EoS again with newfound composition - endif - - if (ierr /= 0) call fatal('set_softened_core','could not initialise equation of state') - ! call core-softening subroutines select case(isoftcore) ! choose type of core-softening case(1) From da865fe17f18393dcbc25ebfbbc9839fc9bd0126 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Sun, 3 Dec 2023 14:54:51 +0100 Subject: [PATCH 223/814] MAIN : implement ieos = 5 (to account of change in mu & gamma due to H2 formation) + fix asymptotic behavior of HI cooling + improve calc_muGamma --- src/main/checksetup.F90 | 4 +- src/main/config.F90 | 9 +++-- src/main/cons2prim.f90 | 12 ++++-- src/main/cooling.f90 | 6 +-- src/main/cooling_functions.f90 | 59 +++++++++++++++------------ src/main/dust_formation.f90 | 60 ++++++++++++++-------------- src/main/energies.F90 | 2 +- src/main/eos.f90 | 22 +++++++--- src/main/initial.F90 | 13 ++++-- src/main/partinject.F90 | 11 +++-- src/main/ptmass.F90 | 4 +- src/main/readwrite_dumps_fortran.F90 | 6 ++- src/main/readwrite_infile.F90 | 11 ++--- src/main/step_leapfrog.F90 | 26 +++++++----- src/main/wind.F90 | 13 ++++-- 15 files changed, 156 insertions(+), 102 deletions(-) diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index 376b58968..d8ede5356 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.F90 @@ -104,7 +104,7 @@ subroutine check_setup(nerror,nwarn,restart) nerror = nerror + 1 endif else - if (polyk < tiny(0.) .and. ieos /= 2) then + if (polyk < tiny(0.) .and. ieos /= 2 .and. ieos /= 5) then print*,'WARNING! polyk = ',polyk,' in setup, speed of sound will be zero in equation of state' nwarn = nwarn + 1 endif @@ -238,7 +238,7 @@ subroutine check_setup(nerror,nwarn,restart) nerror = nerror + 1 endif else - if (abs(gamma-1.) > tiny(gamma) .and. (ieos /= 2 .and. ieos /=9)) then + if (abs(gamma-1.) > tiny(gamma) .and. (ieos /= 2 .and. ieos /= 5 .and. ieos /=9)) then print*,'*** ERROR: using isothermal EOS, but gamma = ',gamma gamma = 1. print*,'*** Resetting gamma to 1, gamma = ',gamma diff --git a/src/main/config.F90 b/src/main/config.F90 index c915bc505..d58e7523d 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -274,10 +274,11 @@ module dim !-------------------- ! Dust formation !-------------------- - logical :: do_nucleation = .false. - integer :: itau_alloc = 0 - integer :: itauL_alloc = 0 - integer :: inucleation = 0 + logical :: do_nucleation = .false. + logical :: update_muGamma = .false. + integer :: itau_alloc = 0 + integer :: itauL_alloc = 0 + integer :: inucleation = 0 !number of elements considered in the nucleation chemical network integer, parameter :: nElements = 10 #ifdef DUST_NUCLEATION diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 49c85d640..cc224ea21 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -176,11 +176,11 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& 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 - use part, only:nucleation,gamma_chem + use part, only:nucleation,gamma_chem,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 + do_radiation,nalpha,mhd_nonideal,do_nucleation,use_krome,update_muGamma use nicil, only:nicil_update_nimhd,nicil_translate_error,n_warn use io, only:fatal,real4,warning use cullendehnen, only:get_alphaloc,xi_limiter @@ -217,7 +217,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& !$omp shared(ieos,gamma_chem,nucleation,nden_nimhd,eta_nimhd) & !$omp shared(alpha,alphamax,iphase,maxphase,maxp,massoftype) & !$omp shared(use_dustfrac,dustfrac,dustevol,this_is_a_test,ndustsmall,alphaind,dvdx) & -!$omp shared(iopacity_type,use_var_comp,do_nucleation,implicit_radiation) & +!$omp shared(iopacity_type,use_var_comp,do_nucleation,update_muGamma,implicit_radiation) & !$omp private(i,spsound,rhoi,p_on_rhogas,rhogas,gasfrac,uui) & !$omp private(Bxi,Byi,Bzi,psii,xi_limiteri,Bi,temperaturei,ierr,pmassi) & !$omp private(xi,yi,zi,hi) & @@ -265,6 +265,10 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& mui = nucleation(idmu,i) gammai = nucleation(idgamma,i) endif + if (update_muGamma) then + mui = eos_vars(imu,i) + gammai = eos_vars(igamma,i) + endif if (use_krome) gammai = gamma_chem(i) if (maxvxyzu >= 4) then uui = vxyzu(4,i) @@ -279,7 +283,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& eos_vars(igasP,i) = p_on_rhogas*rhogas eos_vars(ics,i) = spsound eos_vars(itemp,i) = temperaturei - if (use_var_comp .or. eos_outputs_mu(ieos) .or. do_nucleation) eos_vars(imu,i) = mui + if (use_var_comp .or. eos_outputs_mu(ieos) .or. do_nucleation .or. update_muGamma) eos_vars(imu,i) = mui if (do_radiation) then if (temperaturei > tiny(0.)) then diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index b2e42b862..4fd8ba46b 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -76,7 +76,7 @@ subroutine init_cooling(id,master,iprint,ierr) ierr = 0 select case(icooling) case(8) - if (id==master) write(iprint,*) 'initialising ISM cooling function...' + if (id==master) write(iprint,*) 'initialising ISM cooling functions...' call init_chem() call init_cooling_ism() case(6) @@ -122,7 +122,7 @@ subroutine energ_cooling(xi,yi,zi,ui,dudt,rho,dt,Tdust_in,mu_in,gamma_in,K2_in,k use physcon, only:Rg use units, only:unit_ergg use cooling_gammie, only:cooling_Gammie_explicit - use cooling_gammie_PL, only:cooling_Gammie_PL_explicit + use cooling_gammie_PL, only:cooling_Gammie_PL_explicit use cooling_solver, only:energ_cooling_solver use cooling_koyamainutsuka, only:cooling_KoyamaInutsuka_explicit,& cooling_KoyamaInutsuka_implicit @@ -172,7 +172,7 @@ subroutine write_options_cooling(iunit) use infile_utils, only:write_inopt use cooling_ism, only:write_options_cooling_ism use cooling_gammie, only:write_options_cooling_gammie - use cooling_gammie_PL, only:write_options_cooling_gammie_PL + use cooling_gammie_PL, only:write_options_cooling_gammie_PL use cooling_molecular, only:write_options_molecularcooling use cooling_solver, only:write_options_cooling_solver integer, intent(in) :: iunit diff --git a/src/main/cooling_functions.f90 b/src/main/cooling_functions.f90 index a5f1b724f..94a1d9988 100644 --- a/src/main/cooling_functions.f90 +++ b/src/main/cooling_functions.f90 @@ -40,6 +40,7 @@ module cooling_functions testing_cooling_functions private + real, parameter :: xH = 0.7, xHe = 0.28 !assumed H and He mass fractions contains !----------------------------------------------------------------------- @@ -149,12 +150,15 @@ subroutine cooling_neutral_hydrogen(T, rho_cgs, Q, dlnQ_dlnT) real, intent(out) :: Q,dlnQ_dlnT real, parameter :: f = 1.0d0 - real :: eps_e + real :: ne,nH if (T > 3000.) then - eps_e = calc_eps_e(T) - Q = -f*7.3d-19*eps_e*exp(-118400./T)*rho_cgs/(1.4*mass_proton_cgs)**2 - dlnQ_dlnT = -118400./T+log(calc_eps_e(1.001*T)/eps_e)/log(1.001) + nH = rho_cgs/(1.4*mass_proton_cgs) + ne = calc_eps_e(T)*nH + !the term 1/(1+sqrt(T)) comes from Cen (1992, ApjS, 78, 341) + Q = -f*7.3d-19*ne*nH*exp(-118400./T)/rho_cgs/(1.+sqrt(T/1.d5)) + dlnQ_dlnT = -118400./T+log(nH*calc_eps_e(1.001*T)/ne)/log(1.001) & + - 0.5*sqrt(T/1.d5)/(1.+sqrt(T/1.d5)) else Q = 0. dlnQ_dlnT = 0. @@ -164,7 +168,7 @@ end subroutine cooling_neutral_hydrogen !----------------------------------------------------------------------- !+ -! compute electron equilibrium abundance (Palla et al 1983) +! compute electron equilibrium abundance per nH atom (Palla et al 1983) !+ !----------------------------------------------------------------------- real function calc_eps_e(T) @@ -235,35 +239,40 @@ real function n_e(T_gas, rho_gas, mu, nH, nHe) real, intent(in) :: T_gas, rho_gas, mu, nH, nHe + real, parameter :: H2_diss = 7.178d-12 ! 4.48 eV in erg real, parameter :: H_ion = 2.179d-11 ! 13.60 eV in erg real, parameter :: He_ion = 3.940d-11 ! 24.59 eV in erg real, parameter :: He2_ion = 8.720d-11 ! 54.42 eV in erg - real :: n_gas, X, KH, xx, Y, KHe, KHe2, z1, z2, cst + real :: KH, KH2, xx, yy, KHe, KHe2, z1, z2, cst - n_gas = rho_gas/(mu*mass_proton_cgs) - X = nH /n_gas - Y = nHe/n_gas - cst = mass_proton_cgs/rho_gas * sqrt(mass_electron_cgs*kboltz*T_gas/(2.*pi*planckhbar**2))**3 + cst = mass_proton_cgs/rho_gas*sqrt(mass_electron_cgs*kboltz*T_gas/(2.*pi*planckhbar**2))**3 if (T_gas > 1.d5) then xx = 1. else - KH = cst/X * exp(-H_ion /(kboltz*T_gas)) + KH = cst/xH * exp(-H_ion /(kboltz*T_gas)) ! solution to quadratic SAHA equations (Eq. 16 in D'Angelo et al 2013) xx = 0.5 * (-KH + sqrt(KH**2+4.*KH)) endif + if (T_gas > 1.d4) then + yy = 1. + else + KH2 = 0.5*sqrt(0.5*mass_proton_cgs/mass_electron_cgs)**3*cst/xH * exp(-H2_diss/(kboltz*T_gas)) + ! solution to quadratic SAHA equations (Eq. 15 in D'Angelo et al 2013) + yy = 0.5 * (-KH + sqrt(KH2**2+4.*KH2)) + endif if (T_gas > 3.d5) then z1 = 1. z2 = 1. else KHe = 4.*cst * exp(-He_ion/(kboltz*T_gas)) KHe2 = cst * exp(-He2_ion/(kboltz*T_gas)) - ! solution to quadratic SAHA equations (Eq. 17 in D'Angelo et al 2013) - z1 = (2./Y ) * (-KHe-X + sqrt((KHe+X)**2+KHe*Y)) + z1 = (2./XHe ) * (-KHe-xH + sqrt((KHe+xH)**2+KHe*xHe)) ! solution to quadratic SAHA equations (Eq. 18 in D'Angelo et al 2013) - z2 = (2./Y ) * (-KHe2-X + sqrt((KHe+X+Y/4.)**2+KHe2*Y)) + z2 = (2./xHe ) * (-KHe2-xH + sqrt((KHe+xH+xHe/4.)**2+KHe2*xHe)) endif - n_e = xx * nH + z1*(1.+z2) * nHe + n_e = xx * nH + z1*(1.+z2) * nHe + !mu = 4./(2.*xH*(1.+xx+2.*xx*yy)+xHe*(1+z1+z1*z2)) end function n_e @@ -507,7 +516,6 @@ end function cool_coulomb real function heat_CosmicRays(nH, nH2) real, intent(in) :: nH, nH2 - real, parameter :: Rcr = 5.0d-17 !cosmic ray ionisation rate [s^-1] heat_CosmicRays = Rcr*(5.5d-12*nH+2.5d-11*nH2) @@ -524,7 +532,6 @@ real function cool_HI(T_gas, rho_gas, mu, nH, nHe) use physcon, only: mass_proton_cgs real, intent(in) :: T_gas, rho_gas, mu, nH, nHe - real :: n_gas ! all hydrogen atomic, so nH = n_gas @@ -532,6 +539,7 @@ real function cool_HI(T_gas, rho_gas, mu, nH, nHe) ! (1+sqrt(T_gas/1.d5))**(-1) correction factor added by Cen 1992 if (T_gas > 3000.) then n_gas = rho_gas/(mu*mass_proton_cgs) + !nH = XH*n_gas cool_HI = 7.3d-19*n_e(T_gas, rho_gas, mu, nH, nHe)*n_gas/(1.+sqrt(T_gas/1.d5))*exp(-118400./T_gas) else cool_HI = 0.0 @@ -549,13 +557,13 @@ real function cool_H_ionisation(T_gas, rho_gas, mu, nH, nHe) use physcon, only: mass_proton_cgs real, intent(in) :: T_gas, rho_gas, mu, nH, nHe - real :: n_gas ! all hydrogen atomic, so nH = n_gas ! (1+sqrt(T_gas/1.d5))**(-1) correction factor added by Cen 1992 if (T_gas > 4000.) then - n_gas = rho_gas/(mu*mass_proton_cgs) + n_gas = rho_gas/(mu*mass_proton_cgs) + !nH = XH*n_gas cool_H_ionisation = 1.27d-21*n_e(T_gas, rho_gas, mu, nH, nHe)*n_gas*sqrt(T_gas)/(1.+sqrt(T_gas/1.d5))*exp(-157809./T_gas) else cool_H_ionisation = 0.0 @@ -569,15 +577,17 @@ end function cool_H_ionisation !+ !----------------------------------------------------------------------- real function cool_He_ionisation(T_gas, rho_gas, mu, nH, nHe) - use physcon, only:mass_proton_cgs - real, intent(in) :: T_gas, rho_gas, mu, nH, nHe - real :: n_gas + use physcon, only:mass_proton_cgs + + real, intent(in) :: T_gas, rho_gas, mu, nH, nHe + real :: n_gas ! all hydrogen atomic, so nH = n_gas ! (1+sqrt(T_gas/1.d5))**(-1) correction factor added by Cen 1992 if (T_gas > 4000.) then - n_gas = rho_gas/(mu*mass_proton_cgs) + n_gas = rho_gas/(mu*mass_proton_cgs) + !nH = XH*n_gas cool_He_ionisation = 9.38d-22*n_e(T_gas, rho_gas, mu, nH, nHe)*nHe*sqrt(T_gas)*(1+sqrt(T_gas/1.d5))**(-1)*exp(-285335./T_gas) else cool_He_ionisation = 0.0 @@ -594,7 +604,6 @@ end function cool_He_ionisation real function cool_H2_rovib(T_gas, nH, nH2) real, intent(in) :: T_gas, nH, nH2 - real :: kH_01, kH2_01 real :: Lvh, Lvl, Lrh, Lrl real :: x, Qn @@ -717,7 +726,7 @@ real function cool_CO_rovib(T_gas, rho_gas, mu, nH, nH2, nCO) !McKee et al. 1982 eq. 5.2 QvibH2 = 1.83d-26*nH2*nfCO*T_gas*exp(-3080./T_gas)*exp(-68./(T_gas**(1./3.))) !Smith & Rosen - QvibH = 1.28d-24*nH *nfCO*sqrt(T)*exp(-3080./T_gas)*exp(-(2000./T_gas)**3.43) !Smith & Rosen + QvibH = 1.28d-24*nH *nfCO*sqrt(T_gas)*exp(-3080./T_gas)*exp(-(2000./T_gas)**3.43) !Smith & Rosen cool_CO_rovib = Qrot+QvibH+QvibH2 diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index 082ff5ca5..36ffb9cb0 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.f90 @@ -56,9 +56,9 @@ module dust_formation ! Indices for elements and molecules: integer, parameter :: nMolecules = 25 integer, parameter :: iH = 1, iHe=2, iC=3, iOx=4, iN=5, iNe=6, iSi=7, iS=8, iFe=9, iTi=10 - integer, parameter :: iH2=1, iOH=2, iH2O=3, iCO=4, iCO2=5, iCH4=6, iC2H=7, iC2H2=8, iN2=9, iNH3=10, iCN=11, & - iHCN=12, iSi2=13, iSi3=14, iSiO=15, iSi2C=16, iSiH4=17, iS2=18, iHS=19, iH2S=20, iSiS=21, & - iSiH=22, iTiO=23, iTiO2=24, iC2 = 25, iTiS=26 + integer, parameter :: iH2=1, iOH=2, iH2O=3, iCO=4, iCO2=5, iCH4=6, iC2H=7, iC2H2=8, iN2=9, & + iNH3=10, iCN=11, iHCN=12, iSi2=13, iSi3=14, iSiO=15, iSi2C=16, iSiH4=17, iS2=18, & + iHS=19, iH2S=20, iSiS=21, iSiH=22, iTiO=23, iTiO2=24,iC2 = 25, iTiS=26 real, parameter :: coefs(5,nMolecules) = reshape([& 4.25321d+05, -1.07123d+05, 2.69980d+01, 5.48280d-04, -3.81498d-08, & !H2- 4.15670d+05, -1.05260d+05, 2.54985d+01, 4.78020d-04, -2.82416d-08, & !OH- @@ -122,7 +122,8 @@ subroutine set_abundances eps(iTi) = 8.6d-8 eps(iC) = eps(iOx) * wind_CO_ratio mass_per_H = atomic_mass_unit*dot_product(Aw,eps) - + !XH = atomic_mass_unit*eps(iH)/mass_per_H ! H mass fraction + !XHe = atomic_mass_unit*eps(iHe)/mass_per_H ! He mass fraction end subroutine set_abundances !----------------------------------------------------------------------- @@ -376,26 +377,25 @@ subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) real, intent(in) :: rho_cgs real, intent(inout) :: T, mu, gamma real, intent(out) :: pH, pH_tot - real :: KH2, pH2 + real :: KH2, pH2, x real :: T_old, mu_old, gamma_old, tol logical :: converged integer :: i,isolve integer, parameter :: itermax = 100 character(len=30), parameter :: label = 'calc_muGamma' - if (T > 1.d5) then + pH_tot = rho_cgs*T*kboltz/(patm*mass_per_H) + T_old = T + if (T > 1.d4) then mu = (1.+4.*eps(iHe))/(1.+eps(iHe)) gamma = 5./3. - pH_tot = rho_cgs*T*kboltz/(patm*mass_per_H) pH = pH_tot elseif (T > 450.) then ! iterate to get consistently pH, T, mu and gamma tol = 1.d-3 converged = .false. isolve = 0 - pH_tot = rho_cgs*T*kboltz/(patm*mass_per_H) ! to avoid compiler warning - pH = pH_tot ! arbitrary value, overwritten below, to avoid compiler warning - !T = atomic_mass_unit*mu*(gamma-1)*u/kboltz + pH = pH_tot ! initial value, overwritten below, to avoid compiler warning i = 0 do while (.not. converged .and. i < itermax) i = i+1 @@ -403,31 +403,31 @@ subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) KH2 = calc_Kd(coefs(:,iH2), T) pH = solve_q(2.*KH2, 1., -pH_tot) pH2 = KH2*pH**2 - mu_old = mu - mu = (1.+4.*eps(iHe))*pH_tot/(pH+pH2+eps(iHe)*pH_tot) - gamma_old = gamma - gamma = (5.*pH+5.*eps(iHe)*pH_tot+7.*pH2)/(3.*pH+3.*eps(iHe)*pH_tot+5.*pH2) - T_old = T - T = T_old*mu*(gamma-1.)/(mu_old*(gamma_old-1.)) - !T = T_old !uncomment this line to cancel iterations + mu = (1.+4.*eps(iHe))/(.5+eps(iHe)+0.5*pH/pH_tot) + x = 2.*(1.+4.*eps(iHe))/mu + gamma = (3.*x+4.-3.*eps(iHe))/(x+4.+eps(iHe)) converged = (abs(T-T_old)/T_old) < tol - !print *,i,T_old,T,gamma_old,gamma,mu_old,mu,abs(T-T_old)/T_old - if (i>=itermax .and. .not.converged) then - if (isolve==0) then - isolve = isolve+1 - i = 0 - tol = 1.d-2 - print *,'[dust_formation] cannot converge on T(mu,gamma). Trying with lower tolerance' - else - print *,'Told=',T_old,',T=',T,',gamma_old=',gamma_old,',gamma=',gamma,',mu_old=',& - mu_old,',mu=',mu,',dT/T=',abs(T-T_old)/T_old - call fatal(label,'cannot converge on T(mu,gamma)') - endif + if (i == 1) then + mu_old = mu + gamma_old = gamma + else + T = 2.*T_old*mu/mu_old/(gamma_old-1.)*(x-eps(iHe))/(x+4.-eps(iHe)) + if (i>=itermax .and. .not.converged) then + if (isolve==0) then + isolve = isolve+1 + i = 0 + tol = 1.d-2 + print *,'[dust_formation] cannot converge on T(mu,gamma). Trying with lower tolerance' + else + print *,'Told=',T_old,',T=',T,',gamma_old=',gamma_old,',gamma=',gamma,',mu_old=',& + mu_old,',mu=',mu,',dT/T=',abs(T-T_old)/T_old,', rho=',rho_cgs + call fatal(label,'cannot converge on T(mu,gamma)') + endif + endif endif enddo else ! Simplified low-temperature chemistry: all hydrogen in H2 molecules - pH_tot = rho_cgs*T*kboltz/(patm*mass_per_H) pH2 = pH_tot/2. pH = 0. mu = (1.+4.*eps(iHe))/(0.5+eps(iHe)) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index aa83c46f0..d6711341a 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -362,7 +362,7 @@ subroutine compute_energies(t) if (vxyzu(iu,i) < tiny(vxyzu(iu,i))) np_e_eq_0 = np_e_eq_0 + 1 if (spsoundi < tiny(spsoundi) .and. vxyzu(iu,i) > 0. ) np_cs_eq_0 = np_cs_eq_0 + 1 else - if (ieos==2 .and. gamma > 1.001) then + if ((ieos==2 .or. ieos == 5) .and. gamma > 1.001) then !--thermal energy using polytropic equation of state etherm = etherm + pmassi*ponrhoi/(gamma-1.)*gasfrac elseif (ieos==9) then diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 30ca4f2e6..659935110 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -12,6 +12,7 @@ module eos ! 2 = adiabatic/polytropic eos ! 3 = eos for a locally isothermal disc as in Lodato & Pringle (2007) ! 4 = GR isothermal +! 5 = polytropic EOS with vary mu and gamma depending on H2 formation ! 6 = eos for a locally isothermal disc as in Lodato & Pringle (2007), ! centered on a sink particle ! 7 = z-dependent locally isothermal eos @@ -159,7 +160,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam spsoundi = sqrt(ponrhoi) tempi = temperature_coef*mui*ponrhoi - case(2) + case(2,5) ! !--Adiabatic equation of state (code default) ! @@ -754,7 +755,7 @@ end subroutine calc_rec_ene ! pressure and density. Inputs and outputs are in cgs units. ! ! Note on composition: -! For ieos=2 and 12, mu_local is an input, X & Z are not used +! For ieos=2, 5 and 12, mu_local is an input, X & Z are not used ! For ieos=10, mu_local is not used ! For ieos=20, mu_local is not used but available as an output !+ @@ -780,7 +781,7 @@ subroutine calc_temp_and_ene(eos_type,rho,pres,ene,temp,ierr,guesseint,mu_local, if (present(X_local)) X = X_local if (present(Z_local)) Z = Z_local select case(eos_type) - case(2) ! Ideal gas + case(2,5) ! Ideal gas temp = pres / (rho * kb_on_mh) * mu ene = pres / ( (gamma-1.) * rho) case(12) ! Ideal gas + radiation @@ -936,7 +937,7 @@ subroutine get_p_from_rho_s(ieos,S,rho,mu,P,temp) niter = 0 select case (ieos) - case (2) + case (2,5) temp = (cgsrho * exp(mu*cgss*mass_proton_cgs))**(2./3.) cgsP = cgsrho*kb_on_mh*temp / mu case (12) @@ -1041,7 +1042,7 @@ subroutine setpolyk(eos_type,iprint,utherm,xyzhi,npart) write(iprint,*) 'WARNING! different utherms but run is isothermal' endif - case(2) + case(2,5) ! !--adiabatic/polytropic eos ! this routine is ONLY called if utherm is NOT stored, so polyk matters @@ -1195,6 +1196,12 @@ subroutine eosinfo(eos_type,iprint) endif case(3) write(iprint,"(/,a,f10.6,a,f10.6)") ' Locally isothermal eq of state (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc + case(5) + if (maxvxyzu >= 4) then + write(iprint,"(/,a,f10.6,a,f10.6)") ' Adiabatic equation of state: P = (gamma-1)*rho*u, where gamma & mu depend on the formation of H2' + else + stop '[stop eos] eos = 5 cannot assume isothermal conditions' + endif case(6) write(iprint,"(/,a,i2,a,f10.6,a,f10.6)") ' Locally (on sink ',isink, & ') isothermal eos (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc @@ -1358,6 +1365,7 @@ end subroutine write_options_eos !+ !----------------------------------------------------------------------- subroutine read_options_eos(name,valstring,imatch,igotall,ierr) + use dim, only:store_dust_temperature,update_muGamma use io, only:fatal use eos_helmholtz, only:eos_helmholtz_set_relaxflag use eos_barotropic, only:read_options_eos_barotropic @@ -1381,6 +1389,10 @@ subroutine read_options_eos(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) ieos ngot = ngot + 1 if (ieos <= 0 .or. ieos > maxeos) call fatal(label,'equation of state choice out of range') + if (ieos == 5) then + store_dust_temperature = .true. + update_muGamma = .true. + endif case('mu') read(valstring,*,iostat=ierr) gmw ! not compulsory to read in diff --git a/src/main/initial.F90 b/src/main/initial.F90 index a63657cb8..08a7594ce 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -112,7 +112,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 + use_dustgrowth,ind_timesteps,idumpfile,update_muGamma use deriv, only:derivs use evwrite, only:init_evfile,write_evfile,write_evlog use energies, only:compute_energies @@ -125,7 +125,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use readwrite_dumps, only:read_dump,write_fulldump use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,Bevol,dBevol,tau, tau_lucy, & npartoftype,maxtypes,ndusttypes,alphaind,ntot,ndim,update_npartoftypetot,& - maxphase,iphase,isetphase,iamtype, & + maxphase,iphase,isetphase,iamtype,igamma,imu, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,igas,idust,massoftype,& epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& nden_nimhd,dustevol,rhoh,gradh, & @@ -142,7 +142,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use metric_tools, only:init_metric,imet_minkowski,imetric #endif use units, only:utime,umass,unit_Bfield - use eos, only:gmw + use eos, only:gmw,gamma use nicil, only:nicil_initialise use nicil_sup, only:use_consistent_gmw use ptmass, only:init_ptmass,get_accel_sink_gas,get_accel_sink_sink, & @@ -176,7 +176,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use mf_write, only:binpos_write,binpos_init use io, only:ibinpos,igpos #endif - use dust_formation, only:init_nucleation + use dust_formation, only:init_nucleation,set_abundances #ifdef INJECT_PARTICLES use inject, only:init_inject,inject_particles use partinject, only:update_injected_particles @@ -538,6 +538,11 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) !initialize Lucy optical depth array tau_lucy if (itauL_alloc == 1) tau_lucy = 2./3. endif + if (update_muGamma) then + eos_vars(igamma,:) = gamma + eos_vars(imu,:) = gmw + call set_abundances !to get mass_per_H + endif ! !--inject particles at t=0, and get timestep constraint on this ! diff --git a/src/main/partinject.F90 b/src/main/partinject.F90 index 8e3b7e0d8..4f6f8b494 100644 --- a/src/main/partinject.F90 +++ b/src/main/partinject.F90 @@ -41,12 +41,13 @@ 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 + use part, only:maxp,iamtype,iphase,maxvxyzu,iboundary,nucleation,eos_vars use part, only:maxalpha,alphaind,maxgradh,gradh,fxyzu,fext,set_particle_type use part, only:mhd,Bevol,dBevol,Bxyz,divBsymm!,dust_temp - use part, only:divcurlv,divcurlB,ndivcurlv,ndivcurlB,ntot,ibin + use part, only:divcurlv,divcurlB,ndivcurlv,ndivcurlB,ntot,ibin,imu,igamma use io, only:fatal - use dim, only:ind_timesteps + use eos, only:gamma,gmw + use dim, only:ind_timesteps,update_muGamma use timestep_ind, only:nbinmax integer, intent(in) :: itype real, intent(in) :: position(3), velocity(3), h, u @@ -107,6 +108,10 @@ subroutine add_or_update_particle(itype,position,velocity,h,u,particle_number,np if (ind_timesteps) ibin(particle_number) = nbinmax if (present(jKmuS)) nucleation(:,particle_number) = JKmuS(:) + if (update_muGamma) then + eos_vars(imu,particle_number) = gmw + eos_vars(igamma,particle_number) = gamma + endif end subroutine add_or_update_particle diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index d4fabe75d..071f750b8 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -849,7 +849,7 @@ end subroutine update_ptmass subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,time) use part, only:ihacc,ihsoft,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & - ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP + ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP,igamma use dim, only:maxp,maxneigh,maxvxyzu,maxptmass,ind_timesteps use kdtree, only:getneigh use kernel, only:kernel_softening,radkern @@ -1107,6 +1107,8 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote else if (ieos==2 .and. gamma > 1.001) then etherm = etherm + pmassj*(eos_vars(igasP,j)/rhoj)/(gamma - 1.) + elseif (ieos==5 .and. gamma > 1.001) then + etherm = etherm + pmassj*(eos_vars(igasP,j)/rhoj)/(eos_vars(igamma,j) - 1.) elseif (ieos==8) then etherm = etherm + pmassj*(eos_vars(igasP,j)/rhoj)/(gamma_barotropic(rhoj) - 1.) elseif (ieos==9) then diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 2d00153ff..8a1ca1686 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -204,7 +204,7 @@ end subroutine get_dump_size 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 + ind_timesteps,mhd_nonideal,use_krome,h2chemistry,update_muGamma 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 use part, only:xyzh,xyzh_label,vxyzu,vxyzu_label,Bevol,Bevol_label,Bxyz,Bxyz_label,npart,maxtypes, & @@ -421,6 +421,10 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) call write_array(1,mu_chem,'mu',npart,k,ipass,idump,nums,ierrs(23)) call write_array(1,T_gas_cool,'temp',npart,k,ipass,idump,nums,ierrs(24)) endif + if (update_muGamma) then + call write_array(1,eos_vars(imu,:),eos_vars_label(imu),npart,k,ipass,idump,nums,ierrs(12)) + call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,ierrs(12)) + endif if (do_nucleation) then call write_array(1,nucleation,nucleation_label,n_nucleation,npart,k,ipass,idump,nums,ierrs(25)) endif diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index c5378e43a..48abc999d 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -214,7 +214,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) ! thermodynamics ! call write_options_eos(iwritein) - if (maxvxyzu >= 4 .and. (ieos==2 .or. ieos==10 .or. ieos==15 .or. ieos==12 .or. ieos==16) ) then + if (maxvxyzu >= 4 .and. (ieos==2 .or. ieos==5 .or. ieos==10 .or. ieos==15 .or. ieos==12 .or. ieos==16) ) then call write_inopt(ipdv_heating,'ipdv_heating','heating from PdV work (0=off, 1=on)',iwritein) call write_inopt(ishock_heating,'ishock_heating','shock heating (0=off, 1=on)',iwritein) if (mhd) then @@ -306,7 +306,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 + itau_alloc,store_dust_temperature,gr,do_nucleation 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 @@ -675,15 +675,15 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (beta < 0.) call fatal(label,'beta < 0') if (beta > 4.) call warn(label,'very high beta viscosity set') #ifndef MCFOST - if (maxvxyzu >= 4 .and. (ieos /= 2 .and. ieos /= 4 .and. ieos /= 10 .and. ieos /=11 .and. & - ieos /=12 .and. ieos /= 15 .and. ieos /= 16 .and. ieos /= 20)) & + 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 /= 20)) & 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') if (shearparam < 0.) call fatal(label,'stupid value for shear parameter (< 0)') if (irealvisc==2 .and. shearparam > 1) call error(label,'alpha > 1 for shakura-sunyaev viscosity') if (iverbose > 99 .or. iverbose < -9) call fatal(label,'invalid verboseness setting (two digits only)') - if (icooling > 0 .and. ieos /= 2) call fatal(label,'cooling requires adiabatic eos (ieos=2)') + if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5)) call fatal(label,'cooling requires adiabatic eos (ieos=2)') if (icooling > 0 .and. (ipdv_heating <= 0 .or. ishock_heating <= 0)) & call fatal(label,'cooling requires shock and work contributions') if (((isink_radiation == 1 .or. isink_radiation == 3 ) .and. idust_opacity == 0 ) & @@ -693,6 +693,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) call fatal(label,'dust opacity not used! change isink_radiation or idust_opacity') if (iget_tdust > 2 .and. iray_resolution < 0 ) & call fatal(label,'To get dust temperature with Attenuation or Lucy, set iray_resolution >= 0') + if (do_nucleation .and. ieos == 5) call error(label,'with nucleation you must use ieos = 2') endif return diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index c2c828a36..274dd8724 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -823,7 +823,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me ! ! predictor step for external forces, also recompute external forces ! - !$omp parallel do default(none) schedule(runtime) & + !$omp parallel do default(none) & !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype) & !$omp shared(maxphase,maxp,eos_vars) & !$omp shared(dt,hdt,xtol,ptol) & @@ -957,7 +957,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me !$omp reduction(min:dtextforce_min) & !$omp reduction(+:accretedmass,naccreted,nlive) & !$omp shared(idamp,damp_fac) - !$omp do schedule(runtime) + !$omp do accreteloop: do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then if (ntypes > 1 .and. maxphase==maxp) then @@ -1070,7 +1070,8 @@ end subroutine step_extern_sph !---------------------------------------------------------------- subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time,nptmass, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nbinmax,ibin_wake) - use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome,itau_alloc,do_nucleation,h2chemistry + use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome,itau_alloc,& + do_nucleation,update_muGamma,h2chemistry use io, only:iverbose,id,master,iprint,warning,fatal use externalforces, only:externalforce,accrete_particles,update_externalforce, & update_vdependent_extforce_leapfrog,is_velocity_dependent @@ -1080,9 +1081,9 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, idvxmsi,idvymsi,idvzmsi,idfxmsi,idfymsi,idfzmsi, & ndptmass,update_ptmass use options, only:iexternalforce,icooling - use part, only:maxphase,abundance,nabundances,eos_vars,epot_sinksink,& + use part, only:maxphase,abundance,nabundances,eos_vars,epot_sinksink,eos_vars,& isdead_or_accreted,iamboundary,igas,iphase,iamtype,massoftype,rhoh,divcurlv, & - fxyz_ptmass_sinksink,dust_temp,tau,nucleation,idK2,idmu,idkappa,idgamma + fxyz_ptmass_sinksink,dust_temp,tau,nucleation,idK2,idmu,idkappa,idgamma,imu,igamma use chem, only:update_abundances,get_dphot use cooling_ism, only:dphot0,energ_cooling_ism,dphotflag,abundsi,abundo,abunde,abundc,nabn use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete,summary_accrete_fail @@ -1092,7 +1093,8 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, use damping, only:calc_damp,apply_damp,idamp use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation use cooling, only:energ_cooling,cooling_in_step - use dust_formation, only:evolve_dust + use dust_formation, only:evolve_dust,calc_muGamma + use units, only:unit_density #ifdef KROME use part, only: gamma_chem,mu_chem,dudt_chem,T_gas_cool use krome_interface, only: update_krome @@ -1109,7 +1111,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, integer(kind=1) :: ibin_wakei real :: timei,hdt,fextx,fexty,fextz,fextxi,fextyi,fextzi,phii,pmassi real :: dtphi2,dtphi2i,vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi - real :: dudtcool,fextv(3),poti,ui,rhoi + real :: dudtcool,fextv(3),poti,ui,rhoi,mui,gammai,ph,ph_tot real :: dt,dtextforcenew,dtsinkgas,fonrmax,fonrmaxi real :: dtf,accretedmass,t_end_step,dtextforce_min real, allocatable :: dptmass(:,:) ! dptmass(ndptmass,nptmass) @@ -1205,12 +1207,12 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, !$omp shared(xyzmh_ptmass,vxyz_ptmass,idamp,damp_fac) & !$omp shared(nptmass,nsubsteps,C_force,divcurlv,dphotflag,dphot0) & !$omp shared(abundc,abundo,abundsi,abunde) & - !$omp shared(nucleation,do_nucleation,h2chemistry) & + !$omp shared(nucleation,do_nucleation,update_muGamma,h2chemistry,unit_density) & #ifdef KROME !$omp shared(gamma_chem,mu_chem,dudt_chem) & #endif - !$omp private(dphot,abundi,gmwvar) & - !$omp private(ui,rhoi) & + !$omp private(dphot,abundi,gmwvar,ph,ph_tot) & + !$omp private(ui,rhoi, mui, gammai) & !$omp private(i,dudtcool,fxi,fyi,fzi,phii) & !$omp private(fextx,fexty,fextz,fextxi,fextyi,fextzi,poti,fextv,accreted) & !$omp private(fonrmaxi,dtphi2i,dtf) & @@ -1319,6 +1321,8 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, #else !evolve dust chemistry and compute dust cooling if (do_nucleation) call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) + + if (update_muGamma) call calc_muGamma(rhoi*unit_density, dust_temp(i), eos_vars(imu,i), eos_vars(igamma,i),ph,ph_tot) ! ! COOLING ! @@ -1334,6 +1338,8 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, if (do_nucleation) then call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,& dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) + elseif (update_muGamma) then + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,dust_temp(i),mui,gammai) else call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,dust_temp(i)) endif diff --git a/src/main/wind.F90 b/src/main/wind.F90 index c2ac72734..a55378788 100644 --- a/src/main/wind.F90 +++ b/src/main/wind.F90 @@ -91,6 +91,7 @@ subroutine setup_wind(Mstar_cg, Mdot_code, u_to_T, r0, T0, v0, rsonic, tsonic, s elseif (iget_tdust == 4) then call get_initial_tau_lucy(r0, T0, v0, tau_lucy_init) else + call set_abundances call get_initial_wind_speed(r0, T0, v0, rsonic, tsonic, stype) endif @@ -201,15 +202,16 @@ subroutine wind_step(state) use ptmass_radiation, only:alpha_rad,iget_tdust,tdust_exp,isink_radiation use physcon, only:pi,Rg use dust_formation, only:evolve_chem,calc_kappa_dust,calc_kappa_bowen,& - calc_Eddington_factor,idust_opacity + calc_Eddington_factor,idust_opacity,calc_muGamma use part, only:idK3,idmu,idgamma,idsat,idkappa use cooling_solver, only:calc_cooling_rate use options, only:icooling use units, only:unit_ergg,unit_density use dim, only:itau_alloc + use eos, only:ieos type(wind_state), intent(inout) :: state - real :: rvT(3), dt_next, v_old, dlnQ_dlnT, Q_code + real :: rvT(3), dt_next, v_old, dlnQ_dlnT, Q_code, pH, pH_tot real :: alpha_old, kappa_old, rho_old, Q_old, tau_lucy_bounded, mu_old, dt_old rvT(1) = state%r @@ -241,6 +243,7 @@ subroutine wind_step(state) state%JKmuS(idalpha) = state%alpha_Edd+alpha_rad elseif (idust_opacity == 1) then state%kappa = calc_kappa_bowen(state%Tdust) + if (ieos == 5) call calc_muGamma(state%rho, state%Tg,state%mu, state%gamma, pH, pH_tot) endif if (itau_alloc == 1) then @@ -342,15 +345,16 @@ subroutine wind_step(state) use ptmass_radiation, only:alpha_rad,iget_tdust,tdust_exp, isink_radiation use physcon, only:pi,Rg use dust_formation, only:evolve_chem,calc_kappa_dust,calc_kappa_bowen,& - calc_Eddington_factor,idust_opacity + calc_Eddington_factor,idust_opacity, calc_mugamma use part, only:idK3,idmu,idgamma,idsat,idkappa use cooling_solver, only:calc_cooling_rate use options, only:icooling use units, only:unit_ergg,unit_density use dim, only:itau_alloc + use eos, only:ieos type(wind_state), intent(inout) :: state - real :: rvT(3), dt_next, v_old, dlnQ_dlnT, Q_code + real :: rvT(3), dt_next, v_old, dlnQ_dlnT, Q_code, pH,pH_tot real :: alpha_old, kappa_old, rho_old, Q_old, tau_lucy_bounded kappa_old = state%kappa @@ -363,6 +367,7 @@ subroutine wind_step(state) state%kappa = calc_kappa_dust(state%JKmuS(idK3), state%Tdust, state%rho) elseif (idust_opacity == 1) then state%kappa = calc_kappa_bowen(state%Tdust) + if (ieos == 5 ) call calc_muGamma(state%rho, state%Tg,state%mu, state%gamma, pH, pH_tot) endif if (itau_alloc == 1) then From b28d3c3600bdabfba32188313eee0039d8d9b81a Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Mon, 4 Dec 2023 12:17:41 +0100 Subject: [PATCH 224/814] line truncation eos --- src/main/eos.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 659935110..88bf026c6 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -1198,7 +1198,8 @@ subroutine eosinfo(eos_type,iprint) write(iprint,"(/,a,f10.6,a,f10.6)") ' Locally isothermal eq of state (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc case(5) if (maxvxyzu >= 4) then - write(iprint,"(/,a,f10.6,a,f10.6)") ' Adiabatic equation of state: P = (gamma-1)*rho*u, where gamma & mu depend on the formation of H2' + write(iprint,"(/,a,f10.6,a,f10.6)") ' Adiabatic equation of state: P = (gamma-1)*rho*u, where ',& + ' gamma & mu depend on the formation of H2' else stop '[stop eos] eos = 5 cannot assume isothermal conditions' endif From 3beb7770679213d26f9e032327bf4000121f4249 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 4 Dec 2023 21:29:10 +0100 Subject: [PATCH 225/814] (step) when update_nuGamma, call energy_cooling used bad arguments + minor other bug fixes --- src/main/cooling_functions.f90 | 2 +- src/main/eos.f90 | 2 +- src/main/step_leapfrog.F90 | 3 ++- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/main/cooling_functions.f90 b/src/main/cooling_functions.f90 index 94a1d9988..5f5c14fee 100644 --- a/src/main/cooling_functions.f90 +++ b/src/main/cooling_functions.f90 @@ -144,7 +144,7 @@ end subroutine cooling_radiative_relaxation !----------------------------------------------------------------------- subroutine cooling_neutral_hydrogen(T, rho_cgs, Q, dlnQ_dlnT) - use physcon, only: mass_proton_cgs, pi + use physcon, only: mass_proton_cgs real, intent(in) :: T, rho_cgs real, intent(out) :: Q,dlnQ_dlnT diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 659935110..45de772c7 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -1198,7 +1198,7 @@ subroutine eosinfo(eos_type,iprint) write(iprint,"(/,a,f10.6,a,f10.6)") ' Locally isothermal eq of state (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc case(5) if (maxvxyzu >= 4) then - write(iprint,"(/,a,f10.6,a,f10.6)") ' Adiabatic equation of state: P = (gamma-1)*rho*u, where gamma & mu depend on the formation of H2' + write(iprint,"(' Adiabatic equation of state: P = (gamma-1)*rho*u, where gamma & mu depend on the formation of H2')") else stop '[stop eos] eos = 5 cannot assume isothermal conditions' endif diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 274dd8724..39eb9dc5e 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -1339,7 +1339,8 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,& dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) elseif (update_muGamma) then - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,dust_temp(i),mui,gammai) + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,& + dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i)) else call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,dust_temp(i)) endif From a075ec96c34b7c2e2f53df2e6767ace14aaae4dc Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Wed, 6 Dec 2023 08:06:13 +0100 Subject: [PATCH 226/814] implementation of generalized EOS -- work in progress --- src/main/cooling.f90 | 55 +++++---- src/main/cooling_ism.f90 | 22 ++++ src/main/eos.f90 | 108 ++++++++++++----- src/main/eos_gasradrec.f90 | 12 +- src/main/eos_helmholtz.f90 | 189 ++++++++++------------------- src/main/eos_idealplusrad.f90 | 14 +-- src/main/eos_mesa.f90 | 6 +- src/main/eos_mesa_microphysics.f90 | 5 +- src/main/part.F90 | 9 +- src/main/radiation_utils.f90 | 3 +- src/main/step_leapfrog.F90 | 18 +-- 11 files changed, 235 insertions(+), 206 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 4fd8ba46b..85ff83270 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -63,9 +63,8 @@ subroutine init_cooling(id,master,iprint,ierr) use physcon, only:mass_proton_cgs,kboltz use io, only:error use eos, only:gamma,gmw - use cooling_ism, only:init_cooling_ism - use chem, only:init_chem - use cooling_molecular, only:init_cooling_molec + use part, only:iHI + use cooling_ism, only:init_cooling_ism,abund_default use cooling_koyamainutsuka, only:init_cooling_KI02 use cooling_solver, only:init_cooling_solver @@ -75,18 +74,15 @@ subroutine init_cooling(id,master,iprint,ierr) cooling_in_step = .true. ierr = 0 select case(icooling) - case(8) + case(4) if (id==master) write(iprint,*) 'initialising ISM cooling functions...' - call init_chem() + abund_default(iHI) = 1. call init_cooling_ism() case(6) call init_cooling_KI02(ierr) case(5) call init_cooling_KI02(ierr) cooling_in_step = .false. - case(4) - ! Initialise molecular cooling - call init_cooling_molec case(3) ! Gammie cooling_in_step = .false. @@ -116,49 +112,58 @@ end subroutine init_cooling ! this routine returns the effective cooling rate du/dt ! !----------------------------------------------------------------------- -subroutine energ_cooling(xi,yi,zi,ui,dudt,rho,dt,Tdust_in,mu_in,gamma_in,K2_in,kappa_in) +subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2_in,kappa_in,abund_in) use io, only:fatal - use eos, only:gmw,gamma - use physcon, only:Rg - use units, only:unit_ergg + use dim, only:nabundances + use eos, only:gmw,gamma,ieos,get_temperature_from_u + use cooling_ism, only:nabn,energ_cooling_ism,abund_default,abundc,abunde,abundo,abundsi use cooling_gammie, only:cooling_Gammie_explicit use cooling_gammie_PL, only:cooling_Gammie_PL_explicit use cooling_solver, only:energ_cooling_solver use cooling_koyamainutsuka, only:cooling_KoyamaInutsuka_explicit,& cooling_KoyamaInutsuka_implicit - real, intent(in) :: xi,yi,zi,ui,rho,dt ! in code units + 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(out) :: dudt ! in code units - real :: mu,polyIndex,T_on_u,Tgas,Tdust,K2,kappa + real :: mui,gammai,Tgas,Tdust,K2,kappa + real :: abundi(nabn) - dudt = 0. - mu = gmw - polyIndex = gamma - T_on_u = (gamma-1.)*mu*unit_ergg/Rg - Tgas = T_on_u*ui - Tdust = Tgas + dudt = 0. + mui = gmw + gammai = gamma kappa = 0. K2 = 0. - if (present(gamma_in)) polyIndex = gamma_in - if (present(mu_in)) mu = mu_in - if (present(Tdust_in)) Tdust = Tdust_in + if (present(gamma_in)) gammai = gamma_in + if (present(mu_in)) mui = mu_in if (present(K2_in)) K2 = K2_in if (present(kappa_in)) kappa = kappa_in + if (present(abund_in)) then + abundi = abund_in + elseif (icooling==4) then + call get_extra_abundances(abund_default,nabundances,abundi,nabn,mui,& + abundc,abunde,abundo,abundsi) + endif + Tgas = get_temperature_from_u(ieos,xi,yi,zi,rho,ui,gammai,mui) + Tdust = Tgas + if (present(Tdust_in)) Tdust = Tdust_in + select case (icooling) case (6) call cooling_KoyamaInutsuka_implicit(ui,rho,dt,dudt) case (5) call cooling_KoyamaInutsuka_explicit(rho,Tgas,dudt) case (4) - !call cooling_molecular + call energ_cooling_ism(ui,rho,divv,mui,abundi,dudt) case (3) call cooling_Gammie_explicit(xi,yi,zi,ui,dudt) case (7) call cooling_Gammie_PL_explicit(xi,yi,zi,ui,dudt) case default - call energ_cooling_solver(ui,dudt,rho,dt,mu,polyIndex,Tdust,K2,kappa) + call energ_cooling_solver(ui,dudt,rho,dt,mui,gammai,Tdust,K2,kappa) end select end subroutine energ_cooling diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index cad122d85..32f25f50a 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.f90 @@ -33,6 +33,7 @@ module cooling_ism ! splineutils, units ! use physcon, only:kboltz + use dim, only:nabundances implicit none ! ! only publicly visible entries are the @@ -80,6 +81,8 @@ module cooling_ism ! These variables must be initialised during problem setup ! (in Phantom these appear in the input file when cooling is set, ! here we give them sensible default values) + real, public :: abund_default(nabundances) = 0. + ! ! Total abundances of C, O, Si: Sembach et al. (2000) real, public :: abundc = 1.4d-4 @@ -168,12 +171,20 @@ end subroutine energ_cooling_ism !----------------------------------------------------------------------- subroutine write_options_cooling_ism(iunit) use infile_utils, only:write_inopt + use dim, only:nabundances,h2chemistry + use part, only:abundance_meaning,abundance_label integer, intent(in) :: iunit + integer :: i call write_inopt(dlq,'dlq','distance for column density in cooling function',iunit) call write_inopt(dphot0,'dphot','photodissociation distance used for CO/H2',iunit) call write_inopt(dphotflag,'dphotflag','photodissociation distance static or radially adaptive (0/1)',iunit) call write_inopt(dchem,'dchem','distance for chemistry of HI',iunit) + if (.not.h2chemistry) then + do i=1,nabundances + call write_inopt(abund_default(i),abundance_label(i),abundance_meaning(i),iunit) + enddo + endif call write_inopt(abundc,'abundc','Carbon abundance',iunit) call write_inopt(abundo,'abundo','Oxygen abundance',iunit) call write_inopt(abundsi,'abundsi','Silicon abundance',iunit) @@ -196,9 +207,12 @@ end subroutine write_options_cooling_ism !+ !----------------------------------------------------------------------- subroutine read_options_cooling_ism(name,valstring,imatch,igotall,ierr) + use part, only:abundance_label + use dim, only:h2chemistry character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr + integer :: i imatch = .true. igotall = .true. ! none of the cooling options are compulsory @@ -235,6 +249,14 @@ subroutine read_options_cooling_ism(name,valstring,imatch,igotall,ierr) imatch = .false. end select + if (.not.h2chemistry .and. .not. imatch) then + do i=1,nabundances + if (trim(name)==trim(abundance_label(i))) then + read(valstring,*,iostat=ierr) abund_default(i) + endif + enddo + endif + end subroutine read_options_cooling_ism !======================================================================= diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 45de772c7..82e59f2aa 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -57,7 +57,7 @@ module eos public :: equationofstate,setpolyk,eosinfo,get_mean_molecular_weight public :: get_TempPresCs,get_spsound,get_temperature,get_pressure,get_cv public :: eos_is_non_ideal,eos_outputs_mu,eos_outputs_gasP - public :: get_local_u_internal + public :: get_local_u_internal,get_temperature_from_u public :: calc_rec_ene,calc_temp_and_ene,entropy,get_rho_from_p_s,get_u_from_rhoT public :: get_entropy,get_p_from_rho_s public :: init_eos,finish_eos,write_options_eos,read_options_eos @@ -107,7 +107,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam use part, only:xyzmh_ptmass, nptmass use units, only:unit_density,unit_pressure,unit_ergg,unit_velocity use physcon, only:kb_on_mh,radconst - use eos_mesa, only:get_eos_pressure_temp_gamma1_mesa + use eos_mesa, only:get_eos_pressure_temp_gamma1_mesa,get_eos_1overmu_mesa use eos_helmholtz, only:eos_helmholtz_pres_sound use eos_shen, only:eos_shen_NL3 use eos_idealplusrad @@ -119,9 +119,9 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam real, intent(in) :: rhoi,xi,yi,zi real, intent(out) :: ponrhoi,spsoundi real, intent(inout) :: tempi - real, intent(inout), optional :: eni - real, intent(inout), optional :: mu_local - real, intent(in) , optional :: gamma_local,Xlocal,Zlocal + real, intent(in), optional :: eni + real, intent(inout), optional :: mu_local,gamma_local + real, intent(in) , optional :: Xlocal,Zlocal integer :: ierr, i real :: r1,r2 real :: mass_r, mass ! defined for generalised Farris prescription @@ -294,6 +294,8 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam ponrhoi = presi / rhoi spsoundi = sqrt(gam1*ponrhoi) tempi = temperaturei + if (present(gamma_local)) gamma_local = gam1 ! gamma is an output + if (present(mu_local)) mu_local = 1./get_eos_1overmu_mesa(cgsrhoi,cgseni) if (ierr /= 0) call warning('eos_mesa','extrapolating off tables') case(11) @@ -327,9 +329,10 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam temperaturei = tempi ! Required as initial guess cgsrhoi = rhoi * unit_density cgseni = eni * unit_ergg - call get_idealplusrad_temp(cgsrhoi,cgseni,mui,gammai,temperaturei,ierr) + call get_idealplusrad_temp(cgsrhoi,cgseni,mui,temperaturei,ierr) call get_idealplusrad_pres(cgsrhoi,temperaturei,mui,cgspresi) - call get_idealplusrad_spsoundi(cgsrhoi,cgspresi,cgseni,spsoundi) + call get_idealplusrad_spsoundi(cgsrhoi,cgspresi,cgseni,spsoundi,gammai) + if (present(gamma_local)) gamma_local = gammai ! gamma is an output spsoundi = spsoundi / unit_velocity presi = cgspresi / unit_pressure ponrhoi = presi / rhoi @@ -413,11 +416,12 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam else temperaturei = min(0.67 * cgseni * mui / kb_on_mh, (cgseni*cgsrhoi/radconst)**0.25) endif - call equationofstate_gasradrec(cgsrhoi,cgseni*cgsrhoi,temperaturei,imui,X_i,1.-X_i-Z_i,cgspresi,cgsspsoundi) + call equationofstate_gasradrec(cgsrhoi,cgseni*cgsrhoi,temperaturei,imui,X_i,1.-X_i-Z_i,cgspresi,cgsspsoundi,gammai) ponrhoi = real(cgspresi / (unit_pressure * rhoi)) spsoundi = real(cgsspsoundi / unit_velocity) tempi = temperaturei if (present(mu_local)) mu_local = 1./imui + if (present(gamma_local)) gamma_local = gammai case default spsoundi = 0. ! avoids compiler warnings @@ -560,10 +564,11 @@ end subroutine finish_eos subroutine get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi,spsoundi,gammai,mui,Xi,Zi) use dim, only:maxvxyzu integer, intent(in) :: eos_type - real, intent(in) :: xyzi(:),rhoi - real, intent(inout) :: vxyzui(:),tempi + real, intent(in) :: vxyzui(:),xyzi(:),rhoi + real, intent(inout) :: tempi real, intent(out), optional :: presi,spsoundi - real, intent(in), optional :: gammai,mui,Xi,Zi + real, intent(inout), optional :: gammai,mui + real, intent(in), optional :: Xi,Zi real :: csi,ponrhoi,mu,X,Z logical :: use_gamma @@ -592,7 +597,9 @@ subroutine get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi,spsoundi,gammai, if (present(presi)) presi = ponrhoi*rhoi if (present(spsoundi)) spsoundi = csi - + if (present(mui)) mui = mu + if (present(gammai)) gammai = gamma + end subroutine get_TempPresCs !----------------------------------------------------------------------- @@ -603,8 +610,9 @@ end subroutine get_TempPresCs real function get_spsound(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) integer, intent(in) :: eos_type real, intent(in) :: xyzi(:),rhoi - real, intent(inout) :: vxyzui(:) - real, intent(in), optional :: gammai,mui,Xi,Zi + real, intent(in) :: vxyzui(:) + real, intent(in), optional :: Xi,Zi + real, intent(inout), optional :: gammai,mui real :: spsoundi,tempi,gam,mu,X,Z !set defaults for variables not passed in @@ -613,15 +621,18 @@ real function get_spsound(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) Z = Z_in tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess gam = -1. ! to indicate gamma is not being passed in - if (present(mui)) mu = mui if (present(Xi)) X = Xi if (present(Zi)) Z = Zi if (present(gammai)) gam = gammai - + if (present(mui)) mu = mui + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,spsoundi=spsoundi,gammai=gam,mui=mu,Xi=X,Zi=Z) get_spsound = spsoundi + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + end function get_spsound !----------------------------------------------------------------------- @@ -632,8 +643,9 @@ end function get_spsound real function get_temperature(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) integer, intent(in) :: eos_type real, intent(in) :: xyzi(:),rhoi - real, intent(inout) :: vxyzui(:) - real, intent(in), optional :: gammai,mui,Xi,Zi + real, intent(in) :: vxyzui(:) + real, intent(in), optional :: Xi,Zi + real, intent(inout),optional :: gammai,mui real :: tempi,gam,mu,X,Z !set defaults for variables not passed in @@ -642,17 +654,57 @@ real function get_temperature(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) Z = Z_in tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess gam = -1. ! to indicate gamma is not being passed in - if (present(mui)) mu = mui if (present(Xi)) X = Xi if (present(Zi)) Z = Zi if (present(gammai)) gam = gammai + if (present(mui)) mu = mui call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,gammai=gam,mui=mu,Xi=X,Zi=Z) get_temperature = tempi + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + end function get_temperature + +!----------------------------------------------------------------------- +!+ +! Wrapper function to calculate temperature +!+ +!----------------------------------------------------------------------- +real function get_temperature_from_u(eos_type,xpi,ypi,zpi,rhoi,ui,gammai,mui,Xi,Zi) + integer, intent(in) :: eos_type + real, intent(in) :: xpi,ypi,zpi,rhoi + real, intent(in) :: ui + real, intent(in), optional :: Xi,Zi + real, intent(inout),optional :: gammai,mui + real :: tempi,gam,mu,X,Z + real :: vxyzui(4),xyzi(3) + + !set defaults for variables not passed in + mu = gmw + X = X_in + Z = Z_in + tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess + gam = -1. ! to indicate gamma is not being passed in + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + if (present(gammai)) gam = gammai + if (present(mui)) mu = mui + + vxyzui = (/0.,0.,0.,ui/) + xyzi = (/xpi,ypi,zpi/) + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,gammai=gam,mui=mu,Xi=X,Zi=Z) + + get_temperature_from_u = tempi + + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + + +end function get_temperature_from_u !----------------------------------------------------------------------- !+ ! Wrapper function to calculate pressure @@ -660,9 +712,9 @@ end function get_temperature !----------------------------------------------------------------------- real function get_pressure(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) integer, intent(in) :: eos_type - real, intent(in) :: xyzi(:),rhoi - real, intent(inout) :: vxyzui(:) - real, intent(in), optional :: gammai,mui,Xi,Zi + real, intent(in) :: xyzi(:),rhoi,vxyzui(:) + real, intent(in), optional :: Xi,Zi + real, intent(inout),optional :: gammai,mui real :: presi,tempi,gam,mu,X,Z !set defaults for variables not passed in @@ -675,11 +727,15 @@ real function get_pressure(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) if (present(Xi)) X = Xi if (present(Zi)) Z = Zi if (present(gammai)) gam = gammai + if (present(mui)) mu = mui call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi=presi,gammai=gam,mui=mu,Xi=X,Zi=Z) get_pressure = presi + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + end function get_pressure !----------------------------------------------------------------------- @@ -1367,7 +1423,6 @@ end subroutine write_options_eos subroutine read_options_eos(name,valstring,imatch,igotall,ierr) use dim, only:store_dust_temperature,update_muGamma use io, only:fatal - use eos_helmholtz, only:eos_helmholtz_set_relaxflag use eos_barotropic, only:read_options_eos_barotropic use eos_piecewise, only:read_options_eos_piecewise use eos_gasradrec, only:read_options_eos_gasradrec @@ -1376,7 +1431,6 @@ subroutine read_options_eos(name,valstring,imatch,igotall,ierr) integer, intent(out) :: ierr integer, save :: ngot = 0 character(len=30), parameter :: label = 'read_options_eos' - integer :: tmp logical :: igotall_barotropic,igotall_piecewise,igotall_gasradrec imatch = .true. @@ -1405,12 +1459,6 @@ subroutine read_options_eos(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) Z_in if (Z_in <= 0. .or. Z_in > 1.) call fatal(label,'Z must be between 0 and 1') ngot = ngot + 1 - case('relaxflag') - ! ideally would like this to be self-contained within eos_helmholtz, - ! but it's a bit of a pain and this is easy - read(valstring,*,iostat=ierr) tmp - call eos_helmholtz_set_relaxflag(tmp) - ngot = ngot + 1 case default imatch = .false. end select diff --git a/src/main/eos_gasradrec.f90 b/src/main/eos_gasradrec.f90 index 09e743e0f..9c05fcb60 100644 --- a/src/main/eos_gasradrec.f90 +++ b/src/main/eos_gasradrec.f90 @@ -30,20 +30,22 @@ module eos_gasradrec ! EoS from HORMONE (Hirai et al., 2020). Note eint is internal energy per unit volume !+ !----------------------------------------------------------------------- -subroutine equationofstate_gasradrec(d,eint,T,imu,X,Y,p,cf) +subroutine equationofstate_gasradrec(d,eint,T,imu,X,Y,p,cf,gamma_eff) use ionization_mod, only:get_erec_imurec use physcon, only:radconst,Rg use io, only:fatal real, intent(in) :: d,eint real, intent(inout) :: T,imu ! imu is 1/mu, an output real, intent(in) :: X,Y - real, intent(out) :: p,cf - real :: corr,erec,derecdT,dimurecdT,Tdot,logd,dt,gamma_eff,Tguess + real, intent(out) :: p,cf,gamma_eff + real :: corr,erec,derecdT,dimurecdT,Tdot,logd,dt,Tguess real, parameter :: W4err=1.e-2,eoserr=1.e-13 + integer, parameter :: nmax = 500 integer n corr=huge(0.); Tdot=0.; logd=log10(d); dt=0.9; Tguess=T - do n = 1,500 + + do n = 1,nmax call get_erec_imurec(logd,T,X,Y,erec,imu,derecdT,dimurecdT) if (d*erec>=eint) then ! avoid negative thermal energy T = 0.9*T; Tdot=0.;cycle @@ -63,7 +65,7 @@ subroutine equationofstate_gasradrec(d,eint,T,imu,X,Y,p,cf) if (abs(corr)50) dt=0.5 enddo - if (n > 500) then + if (n > nmax) then print*,'d=',d,'eint=',eint/d,'Tguess=',Tguess,'mu=',1./imu,'T=',T,'erec=',erec call fatal('eos_gasradrec','Failed to converge on temperature in equationofstate_gasradrec') endif diff --git a/src/main/eos_helmholtz.f90 b/src/main/eos_helmholtz.f90 index de34545bf..c2e476d2d 100644 --- a/src/main/eos_helmholtz.f90 +++ b/src/main/eos_helmholtz.f90 @@ -25,7 +25,6 @@ module eos_helmholtz ! subroutines to read/initialise tables, and get pressure/sound speed public :: eos_helmholtz_init public :: eos_helmholtz_write_inopt - public :: eos_helmholtz_set_relaxflag public :: eos_helmholtz_pres_sound ! performs iterations, called by eos.F90 public :: eos_helmholtz_compute_pres_sound ! the actual eos calculation public :: eos_helmholtz_cv_dpresdt @@ -35,7 +34,6 @@ module eos_helmholtz public :: eos_helmholtz_get_maxtemp public :: eos_helmholtz_eosinfo - integer, public :: relaxflag = 1 private @@ -125,11 +123,6 @@ subroutine eos_helmholtz_init(ierr) ierr = 0 - ! check that the relaxflag is sensible, set to relax if not - if (relaxflag /= 0 .and. relaxflag /= 1) then - call eos_helmholtz_set_relaxflag(1) - endif - ! allocate memory allocate(f(imax,jmax),fd(imax,jmax),ft(imax,jmax), & fdd(imax,jmax),ftt(imax,jmax),fdt(imax,jmax), & @@ -332,37 +325,15 @@ end subroutine eos_helmholtz_calc_AbarZbar !---------------------------------------------------------------- !+ -! write options to the input file (currently only relaxflag) +! write options to the input file (currently nothing) !+ !---------------------------------------------------------------- subroutine eos_helmholtz_write_inopt(iunit) - use infile_utils, only:write_inopt integer, intent(in) :: iunit - call write_inopt(relaxflag, 'relaxflag', '0=evolve, 1=relaxation on (keep T const)', iunit) - end subroutine eos_helmholtz_write_inopt -!---------------------------------------------------------------- -!+ -! set the relaxflag based on input file read -! -! called by eos_read_inopt in eos.F90 -!+ -!---------------------------------------------------------------- -subroutine eos_helmholtz_set_relaxflag(tmp) - use io, only:fatal - integer, intent(in) :: tmp - character(len=30), parameter :: label = 'read_options_eos_helmholtz' - - relaxflag = tmp - - if (relaxflag /= 0 .and. relaxflag /= 1) call fatal(label, 'relax flag incorrect, try using 0 (evolve) or 1 (relaxation)') - -end subroutine eos_helmholtz_set_relaxflag - - ! return min density from table limits in code units real function eos_helmholtz_get_minrho() use units, only:unit_density @@ -425,7 +396,7 @@ subroutine eos_helmholtz_pres_sound(tempi,rhoi,ponrhoi,spsoundi,eni) real, intent(in) :: rhoi real, intent(out) :: ponrhoi real, intent(out) :: spsoundi - real, intent(inout) :: eni + real, intent(in) :: eni integer, parameter :: maxiter = 10 real, parameter :: tol = 1.0e-4 ! temperature convergence logical :: done @@ -437,94 +408,72 @@ subroutine eos_helmholtz_pres_sound(tempi,rhoi,ponrhoi,spsoundi,eni) call eos_helmholtz_compute_pres_sound(tempi, cgsrhoi, cgspresi, cgsspsoundi, cgseni_eos, cgsdendti) - ! relaxation: - ! constant temperature, set internal energy of particles to result from eos - if (relaxflag == 1) then - eni = cgseni_eos / unit_ergg - - ! dynamical evolution: - ! ue is evolved in time, iterate eos to solve for temperature when eos ue converges with particle ue - elseif (relaxflag == 0) then - - cgseni = eni * unit_ergg - - ! Newton-Raphson iterations - tprev = tempi - tnew = tempi - (cgseni_eos - cgseni) / cgsdendti - - ! disallow large temperature changes - if (tnew > 2.0 * tempi) then - tnew = 2.0 * tempi - endif - if (tnew < 0.5 * tempi) then - tnew = 0.5 * tempi - endif - - ! temperature and density limits are given in section 2.3 of Timmes & Swesty (2000) - if (tnew > tempmax) then - tnew = tempmax - endif - if (tnew < tempmin) then - tnew = tempmin - endif - - itercount = 0 - done = .false. - iterations: do while (.not. done) - - itercount = itercount + 1 - - ! store temperature of previous iteration - tprev = tnew - - ! get new pressure, sound speed, energy for this temperature and density - call eos_helmholtz_compute_pres_sound(tnew, cgsrhoi, cgspresi, cgsspsoundi, cgseni_eos, cgsdendti) - - ! iterate to new temperature - tnew = tnew - (cgseni_eos - cgseni) / cgsdendti - - ! disallow large temperature changes - if (tnew > 2.0 * tprev) then - tnew = 2.0 * tprev - endif - if (tnew < 0.5 * tprev) then - tnew = 0.5 * tprev - endif - - ! exit if tolerance criterion satisfied - if (abs(tnew - tprev) < tempi * tol) then - done = .true. - endif - - ! exit if gas is too cold or too hot - ! temperature and density limits are given in section 2.3 of Timmes & Swesty (2000) - if (tnew > tempmax) then - tnew = tempmax - done = .true. - endif - if (tnew < tempmin) then - tnew = tempmin - done = .true. - endif - - ! exit if reached max number of iterations (convergence failed) - if (itercount >= maxiter) then - call warning('eos','Helmholtz eos fail to converge') - done = .true. - endif - - enddo iterations - - ! store new temperature - tempi = tnew - - ! TODO: currently we just use the final temperature from the eos and assume we have converged - ! - ! Loren-Aguilar, Isern, Garcia-Berro (2010) time integrate the temperature as well as internal energy, - ! and if temperature is not converged here, then they use the eos internal energy overwriting - ! the value stored on the particles. - ! This does not conserve energy, but is one approach to deal with non-convergence of the temperature. +! dynamical evolution: +! ue is evolved in time, iterate eos to solve for temperature when eos ue converges with particle ue +cgseni = eni * unit_ergg +! Newton-Raphson iterations +tprev = tempi +tnew = tempi - (cgseni_eos - cgseni) / cgsdendti +! disallow large temperature changes +if (tnew > 2.0 * tempi) then + tnew = 2.0 * tempi +endif +if (tnew < 0.5 * tempi) then + tnew = 0.5 * tempi +endif +! temperature and density limits are given in section 2.3 of Timmes & Swesty (2000) +if (tnew > tempmax) then + tnew = tempmax +endif +if (tnew < tempmin) then + tnew = tempmin +endif +itercount = 0 +done = .false. +iterations: do while (.not. done) + itercount = itercount + 1 + ! store temperature of previous iteration + tprev = tnew + ! get new pressure, sound speed, energy for this temperature and density + call eos_helmholtz_compute_pres_sound(tnew, cgsrhoi, cgspresi, cgsspsoundi, cgseni_eos, cgsdendti) + ! iterate to new temperature + tnew = tnew - (cgseni_eos - cgseni) / cgsdendti + ! disallow large temperature changes + if (tnew > 2.0 * tprev) then + tnew = 2.0 * tprev + endif + if (tnew < 0.5 * tprev) then + tnew = 0.5 * tprev + endif + ! exit if tolerance criterion satisfied + if (abs(tnew - tprev) < tempi * tol) then + done = .true. + endif + ! exit if gas is too cold or too hot + ! temperature and density limits are given in section 2.3 of Timmes & Swesty (2000) + if (tnew > tempmax) then + tnew = tempmax + done = .true. + endif + if (tnew < tempmin) then + tnew = tempmin + done = .true. + endif + ! exit if reached max number of iterations (convergence failed) + if (itercount >= maxiter) then + call warning('eos','Helmholtz eos fail to converge') + done = .true. + endif +enddo iterations +! store new temperature +tempi = tnew +! TODO: currently we just use the final temperature from the eos and assume we have converged +! +! Loren-Aguilar, Isern, Garcia-Berro (2010) time integrate the temperature as well as internal energy, +! and if temperature is not converged here, then they use the eos internal energy overwriting +! the value stored on the particles. +! This does not conserve energy, but is one approach to deal with non-convergence of the temperature. ! if ((itercount > maxiter) .or. (abs(tnew - tempi) < tempi * tol)) then ! eni = cgseni_eos / unit_ergg ! not converged, modify energy @@ -533,10 +482,6 @@ subroutine eos_helmholtz_pres_sound(tempi,rhoi,ponrhoi,spsoundi,eni) ! endif - else - print *, 'error in relaxflag in Helmholtz equation of state' - endif - ! convert cgs values to code units and return these values ponrhoi = cgspresi / (unit_pressure * rhoi) spsoundi = cgsspsoundi / unit_velocity diff --git a/src/main/eos_idealplusrad.f90 b/src/main/eos_idealplusrad.f90 index 5fbe0b0ff..466fa476e 100644 --- a/src/main/eos_idealplusrad.f90 +++ b/src/main/eos_idealplusrad.f90 @@ -35,15 +35,15 @@ module eos_idealplusrad ! per unit mass (eni) and density (rhoi) !+ !---------------------------------------------------------------- -subroutine get_idealplusrad_temp(rhoi,eni,mu,gamma,tempi,ierr) - real, intent(in) :: rhoi,eni,mu,gamma +subroutine get_idealplusrad_temp(rhoi,eni,mu,tempi,ierr) + real, intent(in) :: rhoi,eni,mu real, intent(inout) :: tempi integer, intent(out):: ierr real :: gasfac,imu,numerator,denominator,correction integer :: iter integer, parameter :: iter_max = 1000 - gasfac = 1./(gamma-1.) + gasfac = 3./2. !this is NOT gamma = cp/cv, it refers to the gas being monoatomic imu = 1./mu if (tempi <= 0. .or. isnan(tempi)) tempi = eni*mu/(gasfac*Rg) ! Take gas temperature as initial guess @@ -72,13 +72,13 @@ subroutine get_idealplusrad_pres(rhoi,tempi,mu,presi) end subroutine get_idealplusrad_pres -subroutine get_idealplusrad_spsoundi(rhoi,presi,eni,spsoundi) +subroutine get_idealplusrad_spsoundi(rhoi,presi,eni,spsoundi,gammai) real, intent(in) :: rhoi,presi,eni real, intent(out) :: spsoundi - real :: gamma + real, intent(out) :: gammai - gamma = 1. + presi/(eni*rhoi) - spsoundi = sqrt(gamma*presi/rhoi) + gammai = 1. + presi/(eni*rhoi) + spsoundi = sqrt(gammai*presi/rhoi) end subroutine get_idealplusrad_spsoundi diff --git a/src/main/eos_mesa.f90 b/src/main/eos_mesa.f90 index 54fc7c700..f192233fc 100644 --- a/src/main/eos_mesa.f90 +++ b/src/main/eos_mesa.f90 @@ -112,10 +112,10 @@ end subroutine get_eos_kappa_mesa ! density, temperature and composition !+ !---------------------------------------------------------------- -real function get_eos_1overmu_mesa(den,u,Rg) result(rmu) - real, intent(in) :: den,u,Rg +real function get_eos_1overmu_mesa(den,u) result(rmu) + real, intent(in) :: den,u - rmu = get_1overmu_mesa(den,u,Rg) + rmu = get_1overmu_mesa(den,u) end function get_eos_1overmu_mesa diff --git a/src/main/eos_mesa_microphysics.f90 b/src/main/eos_mesa_microphysics.f90 index 958e4158a..e9bf5535c 100644 --- a/src/main/eos_mesa_microphysics.f90 +++ b/src/main/eos_mesa_microphysics.f90 @@ -259,8 +259,9 @@ subroutine get_kappa_mesa(rho,temp,kap,kapt,kapr) end subroutine get_kappa_mesa -real function get_1overmu_mesa(rho,u,Rg) result(rmu) - real, intent(in) :: rho,u,Rg +real function get_1overmu_mesa(rho,u) result(rmu) + real, parameter :: Rg = 8.31446261815324d7 !Gas constant erg/K/g + real, intent(in) :: rho,u real :: temp,pgas integer :: ierr diff --git a/src/main/part.F90 b/src/main/part.F90 index 0b6fc9fd6..f3464810b 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -117,9 +117,16 @@ module part #ifdef KROME character(len=16) :: abundance_label(krome_nmols) #else - character(len=*), parameter :: abundance_label(5) = & + character(len=*), parameter :: abundance_label(nabundances) = & (/'h2ratio','abHIq ','abhpq ','abeq ','abco '/) #endif +character(len=*), parameter :: abundance_meaning(nabundances) = & + (/'ratio of molecular to atomic Hydrogen ',& + 'nHI/nH: fraction of neutral atomic Hydrogen',& + 'nHII/nH: fraction of ionised Hydrogen (HII) ',& + 'ne/nH: fraction of electrons ',& + 'nCO/nH: fraction of Carbon Monoxide '/) + ! !--make a public krome_nmols variable to avoid ifdefs elsewhere ! diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index 153928690..644a9c3e3 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -453,7 +453,6 @@ end subroutine get_opacity real function get_1overmu(rho,u,cv_type) result(rmu) use eos, only:gmw use mesa_microphysics, only:get_1overmu_mesa - use physcon, only:Rg use units, only:unit_density,unit_ergg real, intent(in) :: rho,u integer, intent(in) :: cv_type @@ -463,7 +462,7 @@ real function get_1overmu(rho,u,cv_type) result(rmu) case(1) ! mu from MESA EoS tables rho_cgs = rho*unit_density u_cgs = u*unit_ergg - rmu = get_1overmu_mesa(rho_cgs,u_cgs,real(Rg)) + rmu = get_1overmu_mesa(rho_cgs,u_cgs) case default rmu = 1./gmw end select diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index fa5d9ae35..2ef416dbf 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -683,7 +683,7 @@ subroutine step_extern_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) use part, only:isdead_or_accreted,igas,massoftype,rhoh,eos_vars,igasP,& ien_type,eos_vars,igamma,itemp use cons2primsolver, only:conservative2primitive - use eos, only:ieos,get_pressure + use eos, only:ieos use io, only:warning use metric_tools, only:pack_metric use timestep, only:xtol @@ -1306,20 +1306,19 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, ! dphot = get_dphot(dphotflag,dphot0,xyzh(1,i),xyzh(2,i),xyzh(3,i)) call update_abundances(vxyzu(4,i),rhoi,abundance(:,i),& - nabundances,dphot,dt,abundi,nabn,gmwvar,abundc,abunde,abundo,abundsi) + nabundances,dphot,dt,abundi,nabn,eos_var(imu,i),abundc,abunde,abundo,abundsi) endif #ifdef KROME ! evolve chemical composition and determine new internal energy ! Krome also computes cooling function but only associated with chemical processes ui = vxyzu(4,i) - call update_krome(dt,xyzh(:,i),ui,rhoi,abundance(:,i),gamma_chem(i),mu_chem(i),T_gas_cool(i)) + call update_krome(dt,xyzh(:,i),ui,rhoi,abundance(:,i),eos_vars(igamma,i),eos_vars(imu,i),T_gas_cool(i)) dudt_chem(i) = (ui-vxyzu(4,i))/dt dudtcool = dudt_chem(i) #else !evolve dust chemistry and compute dust cooling if (do_nucleation) call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) - if (update_muGamma) call calc_muGamma(rhoi*unit_density, dust_temp(i), eos_vars(imu,i), eos_vars(igamma,i),ph,ph_tot) ! ! COOLING ! @@ -1329,21 +1328,22 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, ! Call cooling routine, requiring total density, some distance measure and ! abundances in the 'abund' format ! - call energ_cooling_ism(vxyzu(4,i),rhoi,divcurlv(1,i),gmwvar,abundi,dudtcool) + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i),abundi) elseif (store_dust_temperature) then ! cooling with stored dust temperature if (do_nucleation) then - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,& + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) elseif (update_muGamma) then - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,& + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i)) else - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,dust_temp(i)) + 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 else ! cooling without stored dust temperature - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt) + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool) endif endif #endif From d8698c54a8d442be47d499040df918cf7f61aaab Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Thu, 7 Dec 2023 04:50:52 +0100 Subject: [PATCH 227/814] main: make h2chemistry a runtime option + fix cooling in force --- src/main/cooling.f90 | 21 ++++++++++---------- src/main/cooling_ism.f90 | 6 +++++- src/main/dust_formation.f90 | 6 +++--- src/main/force.F90 | 30 ++++++++++++++++++++--------- src/main/h2chem.f90 | 2 +- src/main/inject_wind.f90 | 2 +- src/main/part.F90 | 2 +- src/main/partinject.F90 | 6 ++++-- src/main/readwrite_dumps_common.F90 | 2 +- src/main/step_leapfrog.F90 | 8 ++++---- src/setup/setup_wind.f90 | 2 +- 11 files changed, 53 insertions(+), 34 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 85ff83270..3dab03201 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -74,10 +74,11 @@ subroutine init_cooling(id,master,iprint,ierr) cooling_in_step = .true. ierr = 0 select case(icooling) - case(4) + case(4,8) if (id==master) write(iprint,*) 'initialising ISM cooling functions...' abund_default(iHI) = 1. call init_cooling_ism() + if (icooling==8) cooling_in_step = .false. case(6) call init_cooling_KI02(ierr) case(5) @@ -116,6 +117,7 @@ subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2 use io, only:fatal use dim, only:nabundances use eos, only:gmw,gamma,ieos,get_temperature_from_u + use chem, only:get_extra_abundances use cooling_ism, only:nabn,energ_cooling_ism,abund_default,abundc,abunde,abundo,abundsi use cooling_gammie, only:cooling_Gammie_explicit use cooling_gammie_PL, only:cooling_Gammie_PL_explicit @@ -142,7 +144,7 @@ subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2 if (present(kappa_in)) kappa = kappa_in if (present(abund_in)) then abundi = abund_in - elseif (icooling==4) then + elseif (icooling==4 .or. icooling==8) then call get_extra_abundances(abund_default,nabundances,abundi,nabn,mui,& abundc,abunde,abundo,abundsi) endif @@ -150,13 +152,13 @@ subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2 Tgas = get_temperature_from_u(ieos,xi,yi,zi,rho,ui,gammai,mui) Tdust = Tgas if (present(Tdust_in)) Tdust = Tdust_in - + select case (icooling) case (6) call cooling_KoyamaInutsuka_implicit(ui,rho,dt,dudt) case (5) call cooling_KoyamaInutsuka_explicit(rho,Tgas,dudt) - case (4) + case (4,8) call energ_cooling_ism(ui,rho,divv,mui,abundi,dudt) case (3) call cooling_Gammie_explicit(xi,yi,zi,ui,dudt) @@ -185,11 +187,11 @@ subroutine write_options_cooling(iunit) write(iunit,"(/,a)") '# options controlling cooling' call write_inopt(C_cool,'C_cool','factor controlling cooling timestep',iunit) call write_inopt(icooling,'icooling','cooling function (0=off, 1=library (step), 2=library (force),'// & - '3=Gammie, 5,6=KI02, 7=powerlaw, 8=ISM)',iunit) + '3=Gammie, 4=ISM, 5,6=KI02, 7=powerlaw)',iunit) select case(icooling) - case(0,4,5,6) + case(0,5,6) ! do nothing - case(8) + case(4,8) call write_options_cooling_ism(iunit) case(3) call write_options_cooling_gammie(iunit) @@ -241,11 +243,10 @@ subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) case default imatch = .false. select case(icooling) - case(0,4,5,6) + case(0,5,6) ! do nothing - case(8) + case(4,8) call read_options_cooling_ism(name,valstring,imatch,igotallism,ierr) - h2chemistry = .true. case(3) call read_options_cooling_gammie(name,valstring,imatch,igotallgammie,ierr) case(7) diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index 32f25f50a..657ac9377 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.f90 @@ -81,7 +81,7 @@ module cooling_ism ! These variables must be initialised during problem setup ! (in Phantom these appear in the input file when cooling is set, ! here we give them sensible default values) - real, public :: abund_default(nabundances) = 0. + real, public :: abund_default(nabundances) = (/0.,1.,0.,0.,0./) ! ! Total abundances of C, O, Si: Sembach et al. (2000) @@ -176,6 +176,7 @@ subroutine write_options_cooling_ism(iunit) integer, intent(in) :: iunit integer :: i + call write_inopt(h2chemistry,'h2chemistry','Calculate H2 chemistry',iunit) call write_inopt(dlq,'dlq','distance for column density in cooling function',iunit) call write_inopt(dphot0,'dphot','photodissociation distance used for CO/H2',iunit) call write_inopt(dphotflag,'dphotflag','photodissociation distance static or radially adaptive (0/1)',iunit) @@ -217,6 +218,8 @@ subroutine read_options_cooling_ism(name,valstring,imatch,igotall,ierr) imatch = .true. igotall = .true. ! none of the cooling options are compulsory select case(trim(name)) + case('h2chemistry') + read(valstring,*,iostat=ierr) h2chemistry case('dlq') read(valstring,*,iostat=ierr) dlq case('dphot') @@ -253,6 +256,7 @@ subroutine read_options_cooling_ism(name,valstring,imatch,igotall,ierr) do i=1,nabundances if (trim(name)==trim(abundance_label(i))) then read(valstring,*,iostat=ierr) abund_default(i) + imatch = .true. endif enddo endif diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index 36ffb9cb0..884296127 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.f90 @@ -423,7 +423,7 @@ subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) mu_old,',mu=',mu,',dT/T=',abs(T-T_old)/T_old,', rho=',rho_cgs call fatal(label,'cannot converge on T(mu,gamma)') endif - endif + endif endif enddo else @@ -718,9 +718,9 @@ subroutine write_options_dust_formation(iunit) write(iunit,"(/,a)") '# options controlling dust' if (nucleation) then - call write_inopt(idust_opacity,'idust_opacity','compute dust opacity (0=off,1 (bowen), 2 (nucleation))',iunit) + call write_inopt(idust_opacity,'idust_opacity','compute dust opacity (0=off, 1=bowen, 2=nucleation)',iunit) else - call write_inopt(idust_opacity,'idust_opacity','compute dust opacity (0=off,1 (bowen))',iunit) + call write_inopt(idust_opacity,'idust_opacity','compute dust opacity (0=off, 1=bowen)',iunit) endif if (idust_opacity == 1) then call write_inopt(kappa_gas,'kappa_gas','constant gas opacity (cm²/g)',iunit) diff --git a/src/main/force.F90 b/src/main/force.F90 index 2c831c5a5..2435b04c2 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -2488,13 +2488,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 + store_dust_temperature,do_nucleation,update_muGamma,h2chemistry use eos, only:gamma,ieos,iopacity_type use options, only:alpha,ipdv_heating,ishock_heating,psidecayfac,overcleanfac,hdivbbmax_max, & use_dustfrac,damp,icooling,implicit_radiation - use part, only:rhoanddhdrho,iboundary,igas,maxphase,maxvxyzu,nptmass,xyzmh_ptmass, & - massoftype,get_partinfo,tstop,strain_from_dvdx,ithick,iradP,sinks_have_heating,luminosity, & - nucleation,idK2,idmu,idkappa,idgamma,dust_temp,pxyzu,ndustsmall + 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,idmu,idkappa,idgamma,dust_temp,pxyzu,ndustsmall,imu,& + igamma,abundance,nabundances use cooling, only:energ_cooling,cooling_in_step use ptmass_heating, only:energ_sinkheat use dust, only:drag_implicit @@ -2867,16 +2868,27 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv !--add conductivity and resistive heating fxyz4 = fxyz4 + fac*fsum(idendtdissi) if (icooling > 0 .and. dt > 0. .and. .not. cooling_in_step) then - if (store_dust_temperature) then + if (h2chemistry) then + ! + ! Call cooling routine, requiring total density, some distance measure and + ! abundances in the 'abund' format + ! + call energ_cooling(xi,yi,zi,vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i)) + elseif (store_dust_temperature) then + ! cooling with stored dust temperature if (do_nucleation) then - call energ_cooling(xi,yi,zi,vxyzu(4,i),dudtcool,rhoi,dt,dust_temp(i),& - nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) + call energ_cooling(xi,yi,zi,vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) + elseif (update_muGamma) then + call energ_cooling(xi,yi,zi,vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),eos_vars(imu,i),eos_vars(igamma,i)) else - call energ_cooling(xi,yi,zi,vxyzu(4,i),dudtcool,rhoi,dt,dust_temp(i)) + call energ_cooling(xi,yi,zi,vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,dust_temp(i)) endif else ! cooling without stored dust temperature - call energ_cooling(xi,yi,zi,vxyzu(4,i),dudtcool,rhoi,dt) + call energ_cooling(xi,yi,zi,vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool) endif fxyz4 = fxyz4 + fac*dudtcool endif diff --git a/src/main/h2chem.f90 b/src/main/h2chem.f90 index 2578707cf..fda80dd84 100644 --- a/src/main/h2chem.f90 +++ b/src/main/h2chem.f90 @@ -25,7 +25,7 @@ module chem ! implicit none - public :: init_chem,update_abundances,get_dphot + public :: init_chem,update_abundances,get_dphot,get_extra_abundances ! !--some variables needed for CO chemistry, Nelson+Langer97 ! diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index a6078361e..24b168693 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.f90 @@ -40,7 +40,7 @@ module inject !--runtime settings for this module ! ! Read from input file - integer:: sonic_type = -1 + integer:: sonic_type = 0 integer:: iboundary_spheres = 5 integer:: iwind_resolution = 5 integer:: nfill_domain = 0 diff --git a/src/main/part.F90 b/src/main/part.F90 index f3464810b..cb04ba850 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -118,7 +118,7 @@ module part character(len=16) :: abundance_label(krome_nmols) #else character(len=*), parameter :: abundance_label(nabundances) = & - (/'h2ratio','abHIq ','abhpq ','abeq ','abco '/) + (/'h2ratio',' abHIq',' abhpq',' abeq',' abco'/) #endif character(len=*), parameter :: abundance_meaning(nabundances) = & (/'ratio of molecular to atomic Hydrogen ',& diff --git a/src/main/partinject.F90 b/src/main/partinject.F90 index 4f6f8b494..1d51f263a 100644 --- a/src/main/partinject.F90 +++ b/src/main/partinject.F90 @@ -41,14 +41,15 @@ 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 + 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!,dust_temp use part, only:divcurlv,divcurlB,ndivcurlv,ndivcurlB,ntot,ibin,imu,igamma use io, only:fatal use eos, only:gamma,gmw - use dim, only:ind_timesteps,update_muGamma + use dim, only:ind_timesteps,update_muGamma,h2chemistry use timestep_ind, only:nbinmax + use cooling_ism, only:abund_default integer, intent(in) :: itype real, intent(in) :: position(3), velocity(3), h, u real, intent(in), optional :: JKmuS(:) @@ -112,6 +113,7 @@ subroutine add_or_update_particle(itype,position,velocity,h,u,particle_number,np eos_vars(imu,particle_number) = gmw eos_vars(igamma,particle_number) = gamma endif + if (h2chemistry) abundance(:,particle_number) = abund_default end subroutine add_or_update_particle diff --git a/src/main/readwrite_dumps_common.F90 b/src/main/readwrite_dumps_common.F90 index 6bb8e6d8b..90a498fc7 100644 --- a/src/main/readwrite_dumps_common.F90 +++ b/src/main/readwrite_dumps_common.F90 @@ -221,7 +221,7 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING: u not in file but setting u = (K*rho**(gamma-1))/(gamma-1)' endif endif - if (h2chemistry .and. .not.all(got_abund)) then + if (h2chemistry .and. .not.all(got_abund).and. npartread > 0) then if (id==master) write(*,*) 'error in rdump: using H2 chemistry, but abundances not found in dump file' ierr = 9 return diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 2ef416dbf..99a21172a 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -1305,8 +1305,8 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, ! Get updated abundances of all species, updates 'chemarrays', ! dphot = get_dphot(dphotflag,dphot0,xyzh(1,i),xyzh(2,i),xyzh(3,i)) - call update_abundances(vxyzu(4,i),rhoi,abundance(:,i),& - nabundances,dphot,dt,abundi,nabn,eos_var(imu,i),abundc,abunde,abundo,abundsi) + call update_abundances(vxyzu(4,i),rhoi,abundance(:,i),nabundances,& + dphot,dt,abundi,nabn,eos_vars(imu,i),abundc,abunde,abundo,abundsi) endif #ifdef KROME ! evolve chemical composition and determine new internal energy @@ -1329,7 +1329,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, ! abundances in the 'abund' format ! call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i),abundi) + dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i),abund_in=abundi) elseif (store_dust_temperature) then ! cooling with stored dust temperature if (do_nucleation) then @@ -1339,7 +1339,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i)) 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)) + 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 else ! cooling without stored dust temperature diff --git a/src/setup/setup_wind.f90 b/src/setup/setup_wind.f90 index 86cdbef63..a8b1cf57c 100644 --- a/src/setup/setup_wind.f90 +++ b/src/setup/setup_wind.f90 @@ -293,7 +293,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! avoid failures in the setup by ensuring that tmax and dtmax are large enough ! tmax = max(tmax,100.) - dtmax = max(tmax/10.,dtmax) + !dtmax = max(tmax/10.,dtmax) end subroutine setpart From ce7fdf910485367a24dac93b412add43c5ef2dd9 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Wed, 13 Dec 2023 14:07:58 +0100 Subject: [PATCH 228/814] fix unit for cooling rate --- src/main/cooling_solver.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/cooling_solver.f90 b/src/main/cooling_solver.f90 index c578d474a..bab619637 100644 --- a/src/main/cooling_solver.f90 +++ b/src/main/cooling_solver.f90 @@ -290,7 +290,7 @@ end subroutine exact_cooling !+ !----------------------------------------------------------------------- subroutine calc_cooling_rate(Q, dlnQ_dlnT, rho, T, Teq, mu, gamma, K2, kappa) - use units, only:unit_ergg,unit_density + use units, only:unit_ergg,unit_density,utime use physcon, only:mass_proton_cgs use cooling_functions, only:cooling_neutral_hydrogen,& cooling_Bowen_relaxation,cooling_dust_collision,& @@ -344,7 +344,7 @@ subroutine calc_cooling_rate(Q, dlnQ_dlnT, rho, T, Teq, mu, gamma, K2, kappa) endif !limit exponent to prevent overflow dlnQ_dlnT = sign(min(50.,abs(dlnQ_dlnT)),dlnQ_dlnT) - Q = Q_cgs/unit_ergg + Q = Q_cgs/(unit_ergg/utime) !call testfunc() !call exit From 3941e3bd6dbc72333c65c801430da4a226735db1 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 15 Dec 2023 00:40:26 +0100 Subject: [PATCH 229/814] bug fixes --- src/main/cooling.f90 | 1 - src/main/force.F90 | 2 +- src/tests/test_eos.f90 | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 3dab03201..132e76917 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -211,7 +211,6 @@ end subroutine write_options_cooling !----------------------------------------------------------------------- subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) use io, only:fatal - use dim, only:h2chemistry use cooling_gammie, only:read_options_cooling_gammie use cooling_gammie_PL, only:read_options_cooling_gammie_PL use cooling_ism, only:read_options_cooling_ism diff --git a/src/main/force.F90 b/src/main/force.F90 index 2435b04c2..1c48ec50d 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -2495,7 +2495,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv 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,idmu,idkappa,idgamma,dust_temp,pxyzu,ndustsmall,imu,& - igamma,abundance,nabundances + igamma use cooling, only:energ_cooling,cooling_in_step use ptmass_heating, only:energ_sinkheat use dust, only:drag_implicit diff --git a/src/tests/test_eos.f90 b/src/tests/test_eos.f90 index 9152e1b2a..316c78cbc 100644 --- a/src/tests/test_eos.f90 +++ b/src/tests/test_eos.f90 @@ -333,7 +333,7 @@ end subroutine test_barotropic subroutine test_helmholtz(ntests, npass) use eos, only:maxeos,equationofstate,eosinfo,init_eos use eos_helmholtz, only:eos_helmholtz_get_minrho, eos_helmholtz_get_maxrho, & - eos_helmholtz_get_mintemp, eos_helmholtz_get_maxtemp, eos_helmholtz_set_relaxflag + eos_helmholtz_get_mintemp, eos_helmholtz_get_maxtemp use io, only:id,master,stdout use testutils, only:checkval,checkvalbuf,checkvalbuf_start,checkvalbuf_end use units, only:unit_density From 90cc9142e59aca368e74febd3069bc9a32755caa Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 15 Dec 2023 05:07:50 +0100 Subject: [PATCH 230/814] [header-bot] updated file headers --- src/main/cooling.f90 | 4 ++-- src/main/cooling_ism.f90 | 3 ++- src/main/dust_formation.f90 | 2 +- src/main/eos_helmholtz.f90 | 5 ++--- src/main/extern_geopot.f90 | 9 +++++---- src/main/externalforces.f90 | 3 ++- src/main/partinject.F90 | 4 ++-- src/main/ptmass.F90 | 5 +++-- src/main/step_leapfrog.F90 | 2 +- src/setup/setup_shock.F90 | 4 ++-- src/tests/test_externf.f90 | 4 ++-- src/tests/test_ptmass.f90 | 2 +- 12 files changed, 25 insertions(+), 22 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 132e76917..088a91a90 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -19,12 +19,12 @@ module cooling ! :References: ! Gail & Sedlmayr textbook Physics and chemistry of Circumstellar dust shells ! -! :Owner: Daniel Price +! :Owner: Lionel Siess ! ! :Runtime parameters: ! - C_cool : *factor controlling cooling timestep* ! - Tfloor : *temperature floor (K); on if > 0* -! - icooling : *cooling function (0=off, 1=cooling library (step), 2=cooling library (force),* +! - icooling : *cooling function (0=off, 1=library (step), 2=library (force),* ! ! :Dependencies: chem, cooling_gammie, cooling_gammie_PL, cooling_ism, ! cooling_koyamainutsuka, cooling_molecular, cooling_solver, dim, eos, diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index 657ac9377..614b69dd5 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.f90 @@ -26,10 +26,11 @@ module cooling_ism ! - dphot : *photodissociation distance used for CO/H2* ! - dphotflag : *photodissociation distance static or radially adaptive (0/1)* ! - dust_to_gas_ratio : *dust to gas ratio* +! - h2chemistry : *Calculate H2 chemistry* ! - iflag_atom : *Which atomic cooling (1:Gal ISM, 2:Z=0 gas)* ! - iphoto : *Photoelectric heating treatment (0=optically thin, 1=w/extinction)* ! -! :Dependencies: fs_data, infile_utils, io, mol_data, part, physcon, +! :Dependencies: dim, fs_data, infile_utils, io, mol_data, part, physcon, ! splineutils, units ! use physcon, only:kboltz diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index 884296127..2ffd9c61a 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.f90 @@ -16,7 +16,7 @@ module dust_formation ! - bowen_Tcond : *dust condensation temperature (K)* ! - bowen_delta : *condensation temperature range (K)* ! - bowen_kmax : *maximum dust opacity (cm²/g)* -! - idust_opacity : *compute dust opacity (0=off,1 (bowen))* +! - idust_opacity : *compute dust opacity (0=off, 1=bowen)* ! - kappa_gas : *constant gas opacity (cm²/g)* ! - wind_CO_ratio : *wind initial C/O ratio (> 1)* ! diff --git a/src/main/eos_helmholtz.f90 b/src/main/eos_helmholtz.f90 index c2e476d2d..328146248 100644 --- a/src/main/eos_helmholtz.f90 +++ b/src/main/eos_helmholtz.f90 @@ -15,10 +15,9 @@ module eos_helmholtz ! ! :Owner: Terrence Tricco ! -! :Runtime parameters: -! - relaxflag : *0=evolve, 1=relaxation on (keep T const)* +! :Runtime parameters: None ! -! :Dependencies: datafiles, infile_utils, io, physcon, units +! :Dependencies: datafiles, io, physcon, units ! implicit none diff --git a/src/main/extern_geopot.f90 b/src/main/extern_geopot.f90 index 4f5994c38..728dbffe2 100644 --- a/src/main/extern_geopot.f90 +++ b/src/main/extern_geopot.f90 @@ -1,8 +1,8 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! -! http://phantomsph.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_geopot ! @@ -19,9 +19,10 @@ module extern_geopot ! :Owner: Daniel Price ! ! :Runtime parameters: -! - J2 : *J2 parameter* +! - J2 : *J2 value in code units* +! - tilt_angle : *tilt angle (obliquity) in degrees* ! -! :Dependencies: infile_utils, io, kernel, physcon +! :Dependencies: infile_utils, io, physcon ! implicit none ! diff --git a/src/main/externalforces.f90 b/src/main/externalforces.f90 index 5a6471972..d564295b1 100644 --- a/src/main/externalforces.f90 +++ b/src/main/externalforces.f90 @@ -14,11 +14,12 @@ module externalforces ! ! :Runtime parameters: ! - accradius1 : *soft accretion radius of central object* +! - accradius1_hard : *hard accretion radius of central object* ! - eps_soft : *softening length (Plummer) for central potential in code units* ! - mass1 : *mass of central object in code units* ! ! :Dependencies: dump_utils, extern_Bfield, extern_binary, extern_corotate, -! extern_densprofile, extern_gnewton, extern_gwinspiral, +! extern_densprofile, extern_geopot, extern_gnewton, extern_gwinspiral, ! extern_lensethirring, extern_prdrag, extern_spiral, extern_staticsine, ! infile_utils, io, lumin_nsdisc, part, units ! diff --git a/src/main/partinject.F90 b/src/main/partinject.F90 index 1d51f263a..259a6dcac 100644 --- a/src/main/partinject.F90 +++ b/src/main/partinject.F90 @@ -17,8 +17,8 @@ module partinject ! ! :Runtime parameters: None ! -! :Dependencies: cons2prim, dim, extern_gr, io, metric_tools, options, -! part, timestep_ind +! :Dependencies: cons2prim, cooling_ism, dim, eos, extern_gr, io, +! metric_tools, options, part, timestep_ind ! implicit none diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index bf227d39b..a9aa4cb94 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -34,8 +34,9 @@ module ptmass ! - rho_crit_cgs : *density above which sink particles are created (g/cm^3)* ! ! :Dependencies: boundary, dim, eos, eos_barotropic, eos_piecewise, -! externalforces, fastmath, infile_utils, io, io_summary, kdtree, kernel, -! linklist, mpidomain, mpiutils, options, part, units +! extern_geopot, externalforces, fastmath, infile_utils, io, io_summary, +! kdtree, kernel, linklist, mpidomain, mpiutils, options, part, units, +! vectorutils ! use part, only:nsinkproperties,gravity,is_accretable,& ihsoft,ihacc,ispinx,ispiny,ispinz,imacc,iJ2,iReff diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 99a21172a..44cbb76a1 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -26,7 +26,7 @@ module step_lf_global ! cooling_ism, damping, deriv, dim, dust_formation, eos, extern_gr, ! externalforces, growth, io, io_summary, krome_interface, metric_tools, ! mpiutils, options, part, ptmass, ptmass_radiation, timestep, -! timestep_ind, timestep_sts, timing +! timestep_ind, timestep_sts, timing, units ! use dim, only:maxp,maxvxyzu,do_radiation,ind_timesteps use part, only:vpred,Bpred,dustpred,ppred diff --git a/src/setup/setup_shock.F90 b/src/setup/setup_shock.F90 index c39e04ed5..3ce703e75 100644 --- a/src/setup/setup_shock.F90 +++ b/src/setup/setup_shock.F90 @@ -37,8 +37,8 @@ module setup ! ! :Dependencies: boundary, cooling, dim, dust, eos, eos_idealplusrad, ! infile_utils, io, kernel, mpiutils, nicil, options, part, physcon, -! prompting, radiation_utils, set_dust, setshock, setup_params, timestep, -! unifdis, units +! prompting, radiation_utils, set_dust, setshock, setunits, setup_params, +! timestep, unifdis, units ! use dim, only:maxvxyzu,use_dust,do_radiation,mhd_nonideal use options, only:use_dustfrac diff --git a/src/tests/test_externf.f90 b/src/tests/test_externf.f90 index 00761efd9..fe58e1532 100644 --- a/src/tests/test_externf.f90 +++ b/src/tests/test_externf.f90 @@ -14,8 +14,8 @@ module testexternf ! ! :Runtime parameters: None ! -! :Dependencies: extern_corotate, externalforces, io, kernel, mpidomain, -! part, physcon, testutils, unifdis, units +! :Dependencies: extern_corotate, extern_geopot, externalforces, io, +! kernel, mpidomain, part, physcon, testutils, unifdis, units ! implicit none public :: test_externf diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 927befc4a..c5bd0fab6 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -17,7 +17,7 @@ module testptmass ! :Dependencies: boundary, checksetup, deriv, dim, energies, eos, ! gravwaveutils, io, kdtree, kernel, mpiutils, options, part, physcon, ! ptmass, random, setbinary, setdisc, spherical, step_lf_global, -! stretchmap, testutils, timestep, units +! stretchmap, testutils, timestep, timing, units ! use testutils, only:checkval,update_test_scores implicit none From 0635fd8d87cef19a46b75c1b7b8f447e6e091eee Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 15 Dec 2023 05:07:55 +0100 Subject: [PATCH 231/814] [space-bot] whitespace at end of lines removed --- src/main/eos.f90 | 4 ++-- src/utils/analysis_common_envelope.f90 | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 82e59f2aa..aeed05bcc 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -599,7 +599,7 @@ subroutine get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi,spsoundi,gammai, if (present(spsoundi)) spsoundi = csi if (present(mui)) mui = mu if (present(gammai)) gammai = gamma - + end subroutine get_TempPresCs !----------------------------------------------------------------------- @@ -625,7 +625,7 @@ real function get_spsound(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) if (present(Zi)) Z = Zi if (present(gammai)) gam = gammai if (present(mui)) mu = mui - + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,spsoundi=spsoundi,gammai=gam,mui=mu,Xi=X,Zi=Z) get_spsound = spsoundi diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index b97e723f7..552242c68 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -3875,7 +3875,7 @@ subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phii,epo epoti = 2.*poten + particlemass * phii ! For individual particles, need to multiply 2 to poten to get \sum_j G*mi*mj/r ekini = particlemass * 0.5 * dot_product(vxyzu(1:3),vxyzu(1:3)) einti = particlemass * vxyzu(4) - etoti = epoti + ekini + einti + etoti = epoti + ekini + einti end subroutine calc_gas_energies @@ -4579,16 +4579,16 @@ subroutine calc_escape_velocities(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phi real(4), intent(in) :: poten real, dimension(4), intent(in) :: xyzh,vxyzu real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass - real :: phii,epoti + real :: phii,epoti real :: fxi,fyi,fzi real, intent(out) :: v_esc - + phii = 0.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 v_esc = sqrt(2*abs(epoti/particlemass)) - + end subroutine calc_escape_velocities end module analysis From 1f025189e72b76cecb3192e102eaf18f772acca7 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 15 Dec 2023 05:07:55 +0100 Subject: [PATCH 232/814] [author-bot] updated AUTHORS file --- AUTHORS | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/AUTHORS b/AUTHORS index 7982b79fa..6fe8b175e 100644 --- a/AUTHORS +++ b/AUTHORS @@ -25,6 +25,7 @@ Simone Ceppi Mats Esseldeurs Mats Esseldeurs Stephane Michoulier +Spencer Magnall Caitlyn Hardiman Enrico Ragusa Sergei Biriukov @@ -52,11 +53,12 @@ David Trevascus Farzana Meru Nicolás Cuello Chris Nixon +Miguel Gonzalez-Bolivar Benoit Commercon Giulia Ballabio Joe Fisher Maxime Lombart -Miguel Gonzalez-Bolivar +Mike Lau Orsola De Marco Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> From 3c58b73b8a24c4f5e96cd115f24855467f95c1d5 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 15 Dec 2023 05:08:08 +0100 Subject: [PATCH 233/814] [indent-bot] standardised indentation --- src/main/cooling.f90 | 2 +- src/main/cooling_functions.f90 | 8 +- src/main/cooling_ism.f90 | 12 +-- src/main/eos_helmholtz.f90 | 106 ++++++++++++------------- src/main/part.F90 | 2 +- src/setup/setup_disc.f90 | 8 +- src/utils/analysis_common_envelope.f90 | 34 ++++---- 7 files changed, 86 insertions(+), 86 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 088a91a90..075b44555 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -190,7 +190,7 @@ subroutine write_options_cooling(iunit) '3=Gammie, 4=ISM, 5,6=KI02, 7=powerlaw)',iunit) select case(icooling) case(0,5,6) - ! do nothing + ! do nothing case(4,8) call write_options_cooling_ism(iunit) case(3) diff --git a/src/main/cooling_functions.f90 b/src/main/cooling_functions.f90 index 5f5c14fee..0bd205c24 100644 --- a/src/main/cooling_functions.f90 +++ b/src/main/cooling_functions.f90 @@ -40,7 +40,7 @@ module cooling_functions testing_cooling_functions private - real, parameter :: xH = 0.7, xHe = 0.28 !assumed H and He mass fractions + real, parameter :: xH = 0.7, xHe = 0.28 !assumed H and He mass fractions contains !----------------------------------------------------------------------- @@ -578,10 +578,10 @@ end function cool_H_ionisation !----------------------------------------------------------------------- real function cool_He_ionisation(T_gas, rho_gas, mu, nH, nHe) - use physcon, only:mass_proton_cgs + use physcon, only:mass_proton_cgs - real, intent(in) :: T_gas, rho_gas, mu, nH, nHe - real :: n_gas + real, intent(in) :: T_gas, rho_gas, mu, nH, nHe + real :: n_gas ! all hydrogen atomic, so nH = n_gas ! (1+sqrt(T_gas/1.d5))**(-1) correction factor added by Cen 1992 diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index 614b69dd5..98ec1d000 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.f90 @@ -254,12 +254,12 @@ subroutine read_options_cooling_ism(name,valstring,imatch,igotall,ierr) end select if (.not.h2chemistry .and. .not. imatch) then - do i=1,nabundances - if (trim(name)==trim(abundance_label(i))) then - read(valstring,*,iostat=ierr) abund_default(i) - imatch = .true. - endif - enddo + do i=1,nabundances + if (trim(name)==trim(abundance_label(i))) then + read(valstring,*,iostat=ierr) abund_default(i) + imatch = .true. + endif + enddo endif end subroutine read_options_cooling_ism diff --git a/src/main/eos_helmholtz.f90 b/src/main/eos_helmholtz.f90 index 328146248..988e29bda 100644 --- a/src/main/eos_helmholtz.f90 +++ b/src/main/eos_helmholtz.f90 @@ -410,63 +410,63 @@ subroutine eos_helmholtz_pres_sound(tempi,rhoi,ponrhoi,spsoundi,eni) ! dynamical evolution: ! ue is evolved in time, iterate eos to solve for temperature when eos ue converges with particle ue -cgseni = eni * unit_ergg + cgseni = eni * unit_ergg ! Newton-Raphson iterations -tprev = tempi -tnew = tempi - (cgseni_eos - cgseni) / cgsdendti + tprev = tempi + tnew = tempi - (cgseni_eos - cgseni) / cgsdendti ! disallow large temperature changes -if (tnew > 2.0 * tempi) then - tnew = 2.0 * tempi -endif -if (tnew < 0.5 * tempi) then - tnew = 0.5 * tempi -endif + if (tnew > 2.0 * tempi) then + tnew = 2.0 * tempi + endif + if (tnew < 0.5 * tempi) then + tnew = 0.5 * tempi + endif ! temperature and density limits are given in section 2.3 of Timmes & Swesty (2000) -if (tnew > tempmax) then - tnew = tempmax -endif -if (tnew < tempmin) then - tnew = tempmin -endif -itercount = 0 -done = .false. -iterations: do while (.not. done) - itercount = itercount + 1 - ! store temperature of previous iteration - tprev = tnew - ! get new pressure, sound speed, energy for this temperature and density - call eos_helmholtz_compute_pres_sound(tnew, cgsrhoi, cgspresi, cgsspsoundi, cgseni_eos, cgsdendti) - ! iterate to new temperature - tnew = tnew - (cgseni_eos - cgseni) / cgsdendti - ! disallow large temperature changes - if (tnew > 2.0 * tprev) then - tnew = 2.0 * tprev - endif - if (tnew < 0.5 * tprev) then - tnew = 0.5 * tprev - endif - ! exit if tolerance criterion satisfied - if (abs(tnew - tprev) < tempi * tol) then - done = .true. - endif - ! exit if gas is too cold or too hot - ! temperature and density limits are given in section 2.3 of Timmes & Swesty (2000) - if (tnew > tempmax) then - tnew = tempmax - done = .true. - endif - if (tnew < tempmin) then - tnew = tempmin - done = .true. - endif - ! exit if reached max number of iterations (convergence failed) - if (itercount >= maxiter) then - call warning('eos','Helmholtz eos fail to converge') - done = .true. - endif -enddo iterations + if (tnew > tempmax) then + tnew = tempmax + endif + if (tnew < tempmin) then + tnew = tempmin + endif + itercount = 0 + done = .false. + iterations: do while (.not. done) + itercount = itercount + 1 + ! store temperature of previous iteration + tprev = tnew + ! get new pressure, sound speed, energy for this temperature and density + call eos_helmholtz_compute_pres_sound(tnew, cgsrhoi, cgspresi, cgsspsoundi, cgseni_eos, cgsdendti) + ! iterate to new temperature + tnew = tnew - (cgseni_eos - cgseni) / cgsdendti + ! disallow large temperature changes + if (tnew > 2.0 * tprev) then + tnew = 2.0 * tprev + endif + if (tnew < 0.5 * tprev) then + tnew = 0.5 * tprev + endif + ! exit if tolerance criterion satisfied + if (abs(tnew - tprev) < tempi * tol) then + done = .true. + endif + ! exit if gas is too cold or too hot + ! temperature and density limits are given in section 2.3 of Timmes & Swesty (2000) + if (tnew > tempmax) then + tnew = tempmax + done = .true. + endif + if (tnew < tempmin) then + tnew = tempmin + done = .true. + endif + ! exit if reached max number of iterations (convergence failed) + if (itercount >= maxiter) then + call warning('eos','Helmholtz eos fail to converge') + done = .true. + endif + enddo iterations ! store new temperature -tempi = tnew + tempi = tnew ! TODO: currently we just use the final temperature from the eos and assume we have converged ! ! Loren-Aguilar, Isern, Garcia-Berro (2010) time integrate the temperature as well as internal energy, diff --git a/src/main/part.F90 b/src/main/part.F90 index cb04ba850..7eeee6ad2 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -120,7 +120,7 @@ module part character(len=*), parameter :: abundance_label(nabundances) = & (/'h2ratio',' abHIq',' abhpq',' abeq',' abco'/) #endif -character(len=*), parameter :: abundance_meaning(nabundances) = & + character(len=*), parameter :: abundance_meaning(nabundances) = & (/'ratio of molecular to atomic Hydrogen ',& 'nHI/nH: fraction of neutral atomic Hydrogen',& 'nHII/nH: fraction of ionised Hydrogen (HII) ',& diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 766f2a74e..23d79cd1a 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -3251,10 +3251,10 @@ subroutine read_oblateness_options(db,nerr,label,J2i,sizei,spin_periodi,kfaci,ob call read_inopt(J2i,'J2'//trim(label),db,min=-1.0,max=1.0) ! optional, no error if not read if (abs(J2i) > 0.) then - call read_inopt(sizei,'size'//trim(label),db,errcount=nerr) - call read_inopt(spin_periodi,'spin_period'//trim(label),db,errcount=nerr) - call read_inopt(kfaci,'kfac'//trim(label),db,min=0.,max=1.,errcount=nerr) - call read_inopt(obliquityi,'obliquity'//trim(label),db,min=0.,max=180.,errcount=nerr) + call read_inopt(sizei,'size'//trim(label),db,errcount=nerr) + call read_inopt(spin_periodi,'spin_period'//trim(label),db,errcount=nerr) + call read_inopt(kfaci,'kfac'//trim(label),db,min=0.,max=1.,errcount=nerr) + call read_inopt(obliquityi,'obliquity'//trim(label),db,min=0.,max=180.,errcount=nerr) endif end subroutine read_oblateness_options diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 552242c68..a000ddab0 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -1585,8 +1585,8 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) 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 + call calc_escape_velocities(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,v_esci) + quant(k,i) = v_esci case default print*,"Error: Requested quantity is invalid." stop @@ -4573,21 +4573,21 @@ end subroutine set_eos_options !+ !---------------------------------------------------------------- subroutine calc_escape_velocities(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phii,epoti,v_esc) - use ptmass, only:get_accel_sink_gas - use part, only:nptmass - real, intent(in) :: particlemass - real(4), intent(in) :: poten - real, dimension(4), intent(in) :: xyzh,vxyzu - real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass - real :: phii,epoti - real :: fxi,fyi,fzi - real, intent(out) :: v_esc - - phii = 0.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 - v_esc = sqrt(2*abs(epoti/particlemass)) + use ptmass, only:get_accel_sink_gas + use part, only:nptmass + real, intent(in) :: particlemass + real(4), intent(in) :: poten + real, dimension(4), intent(in) :: xyzh,vxyzu + real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass + real :: phii,epoti + real :: fxi,fyi,fzi + real, intent(out) :: v_esc + + phii = 0.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 + v_esc = sqrt(2*abs(epoti/particlemass)) end subroutine calc_escape_velocities From febbdfc2cce7e75805ad1eb7379d05dcedc135e3 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 15 Dec 2023 07:00:05 +0100 Subject: [PATCH 234/814] fixes test_eos + clean Krome variables #489 #487 --- src/main/config.F90 | 5 ++--- src/main/cons2prim.f90 | 6 +++--- src/main/energies.F90 | 23 ++++++++++------------- src/main/eos.f90 | 2 +- src/main/eos_idealplusrad.f90 | 6 +++--- src/main/force.F90 | 21 +++++++-------------- src/main/ionization.f90 | 6 +++--- src/main/krome.f90 | 26 +++++++++++++------------- src/main/part.F90 | 17 ++++------------- src/main/readwrite_dumps_fortran.F90 | 10 +++------- src/main/readwrite_dumps_hdf5.F90 | 12 +++--------- src/main/step_leapfrog.F90 | 11 ++--------- src/main/utils_dumpfiles_hdf5.f90 | 12 ------------ src/setup/setup_shock.F90 | 4 ++-- src/tests/test_eos.f90 | 7 +++---- src/utils/analysis_common_envelope.f90 | 26 +++++++++++++------------- 16 files changed, 72 insertions(+), 122 deletions(-) diff --git a/src/main/config.F90 b/src/main/config.F90 index c8ec18b0d..57c8b62ce 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -362,9 +362,8 @@ subroutine update_max_sizes(n,ntot) maxp = n -#ifdef KROME - maxp_krome = maxp -#endif + if (use_krome) maxp_krome = maxp + if (h2chemistry) maxp_h2 = maxp #ifdef SINK_RADIATION diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index cc224ea21..8845e893f 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -176,7 +176,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& 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 - use part, only:nucleation,gamma_chem,igamma + 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,& @@ -214,7 +214,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& !$omp parallel do default (none) & !$omp shared(xyzh,vxyzu,npart,rad,eos_vars,radprop,Bevol,Bxyz) & -!$omp shared(ieos,gamma_chem,nucleation,nden_nimhd,eta_nimhd) & +!$omp shared(ieos,nucleation,nden_nimhd,eta_nimhd) & !$omp shared(alpha,alphamax,iphase,maxphase,maxp,massoftype) & !$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) & @@ -269,7 +269,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& mui = eos_vars(imu,i) gammai = eos_vars(igamma,i) endif - if (use_krome) gammai = gamma_chem(i) + 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) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index d6711341a..b5f6788c9 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -64,13 +64,13 @@ subroutine compute_energies(t) use dim, only:maxp,maxvxyzu,maxalpha,maxtypes,mhd_nonideal,maxp_hard,& lightcurve,use_dust,maxdusttypes,do_radiation,gr,use_krome use part, only:rhoh,xyzh,vxyzu,massoftype,npart,maxphase,iphase,& - alphaind,Bevol,divcurlB,iamtype,& + alphaind,Bevol,divcurlB,iamtype,igamma,& igas,idust,iboundary,istar,idarkmatter,ibulge,& nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,isdeadh,& isdead_or_accreted,epot_sinksink,imacc,ispinx,ispiny,& ispinz,mhd,gravity,poten,dustfrac,eos_vars,itemp,igasP,ics,& nden_nimhd,eta_nimhd,iion,ndustsmall,graindens,grainsize,& - iamdust,ndusttypes,rad,iradxi,gamma_chem + iamdust,ndusttypes,rad,iradxi use part, only:pxyzu,fxyzu,fext use gravwaveutils, only:calculate_strain,calc_gravitwaves use centreofmass, only:get_centreofmass_accel @@ -100,7 +100,7 @@ subroutine compute_energies(t) real :: xmomacc,ymomacc,zmomacc,angaccx,angaccy,angaccz,xcom,ycom,zcom,dm real :: epoti,pmassi,dnptot,dnpgas,tsi real :: xmomall,ymomall,zmomall,angxall,angyall,angzall,rho1i,vsigi - real :: ponrhoi,spsoundi,spsound2i,va2cs2,rho1cs2,dumx,dumy,dumz + real :: ponrhoi,spsoundi,spsound2i,va2cs2,rho1cs2,dumx,dumy,dumz,gammai real :: divBi,hdivBonBi,alphai,valfven2i,betai real :: n_total,n_total1,n_ion,shearparam_art,shearparam_phys,ratio_phys_to_av real :: gasfrac,rhogasi,dustfracisum,dustfraci(maxdusttypes),dust_to_gas(maxdusttypes) @@ -169,14 +169,14 @@ subroutine compute_energies(t) !$omp shared(Bevol,divcurlB,iphase,poten,dustfrac,use_dustfrac) & !$omp shared(use_ohm,use_hall,use_ambi,nden_nimhd,eta_nimhd,eta_constant) & !$omp shared(ev_data,np_rho,erot_com,calc_erot,gas_only,track_mass) & -!$omp shared(calc_gravitwaves,gamma_chem) & +!$omp shared(calc_gravitwaves) & !$omp shared(iev_erad,iev_rho,iev_dt,iev_entrop,iev_rhop,iev_alpha) & !$omp shared(iev_B,iev_divB,iev_hdivB,iev_beta,iev_temp,iev_etao,iev_etah) & !$omp shared(iev_etaa,iev_vel,iev_vhall,iev_vion,iev_n) & !$omp shared(iev_dtg,iev_ts,iev_macc,iev_totlum,iev_erot,iev_viscrat) & !$omp shared(eos_vars,grainsize,graindens,ndustsmall,metrics) & !$omp private(i,j,xi,yi,zi,hi,rhoi,vxi,vyi,vzi,Bxi,Byi,Bzi,Bi,B2i,epoti,vsigi,v2i,vi1) & -!$omp private(ponrhoi,spsoundi,spsound2i,va2cs2,rho1cs2,ethermi,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & +!$omp private(ponrhoi,spsoundi,gammai,spsound2i,va2cs2,rho1cs2,ethermi,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & !$omp private(rho1i,shearparam_art,shearparam_phys,ratio_phys_to_av,betai) & !$omp private(gasfrac,rhogasi,dustfracisum,dustfraci,dust_to_gas,n_total,n_total1,n_ion) & !$omp private(etaohm,etahall,etaambi,vhalli,vhall,vioni,vion,data_out) & @@ -353,6 +353,7 @@ subroutine compute_energies(t) ! thermal energy ponrhoi = eos_vars(igasP,i)/rhoi spsoundi = eos_vars(ics,i) + gammai = eos_vars(igamma,i) if (maxvxyzu >= 4) then ethermi = pmassi*vxyzu(4,i)*gasfrac if (gr) ethermi = (alpha_gr/lorentzi)*ethermi @@ -362,9 +363,9 @@ subroutine compute_energies(t) if (vxyzu(iu,i) < tiny(vxyzu(iu,i))) np_e_eq_0 = np_e_eq_0 + 1 if (spsoundi < tiny(spsoundi) .and. vxyzu(iu,i) > 0. ) np_cs_eq_0 = np_cs_eq_0 + 1 else - if ((ieos==2 .or. ieos == 5) .and. gamma > 1.001) then + if ((ieos==2 .or. ieos == 5) .and. gammai > 1.001) then !--thermal energy using polytropic equation of state - etherm = etherm + pmassi*ponrhoi/(gamma-1.)*gasfrac + etherm = etherm + pmassi*ponrhoi/(gammai-1.)*gasfrac elseif (ieos==9) then !--thermal energy using piecewise polytropic equation of state etherm = etherm + pmassi*ponrhoi/(gamma_pwp(rhoi)-1.)*gasfrac @@ -374,11 +375,7 @@ subroutine compute_energies(t) vsigi = spsoundi ! entropy - if (use_krome) then - call ev_data_update(ev_data_thread,iev_entrop,pmassi*ponrhoi*rhoi**(1.-gamma_chem(i))) - else - call ev_data_update(ev_data_thread,iev_entrop,pmassi*ponrhoi*rhoi**(1.-gamma)) - endif + call ev_data_update(ev_data_thread,iev_entrop,pmassi*ponrhoi*rhoi**(1.-gammai)) ! gas temperature if (eos_is_non_ideal(ieos) .or. eos_outputs_gasP(ieos)) then @@ -598,7 +595,7 @@ subroutine compute_energies(t) if (.not.gr) ekin = 0.5*ekin emag = 0.5*emag ekin = reduceall_mpi('+',ekin) - if (maxvxyzu >= 4 .or. gamma >= 1.0001) etherm = reduceall_mpi('+',etherm) + if (maxvxyzu >= 4 .or. gammai >= 1.0001) etherm = reduceall_mpi('+',etherm) emag = reduceall_mpi('+',emag) epot = reduceall_mpi('+',epot) erad = reduceall_mpi('+',erad) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index aeed05bcc..304c50dc2 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -842,7 +842,7 @@ subroutine calc_temp_and_ene(eos_type,rho,pres,ene,temp,ierr,guesseint,mu_local, ene = pres / ( (gamma-1.) * rho) case(12) ! Ideal gas + radiation call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) - call get_idealplusrad_enfromtemp(rho,temp,mu,gamma,ene) + call get_idealplusrad_enfromtemp(rho,temp,mu,ene) case(10) ! MESA EoS call get_eos_eT_from_rhop_mesa(rho,pres,ene,temp,guesseint) case(20) ! Ideal gas + radiation + recombination (from HORMONE, Hirai et al., 2020) diff --git a/src/main/eos_idealplusrad.f90 b/src/main/eos_idealplusrad.f90 index 466fa476e..8ab9d69c4 100644 --- a/src/main/eos_idealplusrad.f90 +++ b/src/main/eos_idealplusrad.f90 @@ -122,11 +122,11 @@ end subroutine get_idealgasplusrad_tempfrompres ! and temperature !+ !---------------------------------------------------------------- -subroutine get_idealplusrad_enfromtemp(densi,tempi,mu,gamma,eni) - real, intent(in) :: densi,tempi,mu,gamma +subroutine get_idealplusrad_enfromtemp(densi,tempi,mu,eni) + real, intent(in) :: densi,tempi,mu real, intent(out) :: eni - eni = Rg*tempi/((gamma-1.)*mu) + radconst*tempi**4/densi + eni = 3./2.*Rg*tempi/mu + radconst*tempi**4/densi end subroutine get_idealplusrad_enfromtemp diff --git a/src/main/force.F90 b/src/main/force.F90 index 1c48ec50d..1d2d193cf 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -2494,7 +2494,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv 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,idmu,idkappa,idgamma,dust_temp,pxyzu,ndustsmall,imu,& + luminosity,nucleation,idK2,idkappa,dust_temp,pxyzu,ndustsmall,imu,& igamma use cooling, only:energ_cooling,cooling_in_step use ptmass_heating, only:energ_sinkheat @@ -2513,9 +2513,6 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv use timestep_sts, only:use_sts use units, only:unit_ergg,unit_density,get_c_code use eos_shen, only:eos_shen_get_dTdu -#ifdef KROME - use part, only:gamma_chem -#endif use metric_tools, only:unpack_metric use utils_gr, only:get_u0 use io, only:error @@ -2560,7 +2557,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv real, intent(inout) :: dtrad real :: c_code,dtradi,radlambdai,radkappai real :: xpartveci(maxxpartveciforce),fsum(maxfsum) - real :: rhoi,rho1i,rhogasi,hi,hi1,pmassi,tempi + real :: rhoi,rho1i,rhogasi,hi,hi1,pmassi,tempi,gammai real :: Bxyzi(3),curlBi(3),dvdxi(9),straini(6) real :: xi,yi,zi,B2i,f2i,divBsymmi,betai,frac_divB,divBi,vcleani real :: pri,spsoundi,drhodti,divvi,shearvisc,fac,pdv_work @@ -2645,6 +2642,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv tstopi = 0. dustfraci = 0. dustfracisum = 0. + gammai = eos_vars(igamma,i) vxi = xpartveci(ivxi) vyi = xpartveci(ivyi) @@ -2806,18 +2804,13 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv fxyz4 = fxyz4 + real(u0i/tempi*(fsum(idudtdissi) + fsum(idendtdissi))/kboltz) elseif (ien_type == ien_entropy) then ! here eni is the entropy if (gr .and. ishock_heating > 0) then - fxyz4 = fxyz4 + (gamma - 1.)*densi**(1.-gamma)*u0i*fsum(idudtdissi) + fxyz4 = fxyz4 + (gammai - 1.)*densi**(1.-gammai)*u0i*fsum(idudtdissi) elseif (ishock_heating > 0) then -#ifdef KROME - fxyz4 = fxyz4 + (gamma_chem(i) - 1.)*rhoi**(1.-gamma_chem(i))*fsum(idudtdissi) -#else - !LS if do_nucleation one should use the local gamma : nucleation(idgamma,i) - fxyz4 = fxyz4 + (gamma - 1.)*rhoi**(1.-gamma)*fsum(idudtdissi) -#endif + fxyz4 = fxyz4 + (gammai - 1.)*rhoi**(1.-gammai)*fsum(idudtdissi) endif ! add conductivity for GR if (gr) then - fxyz4 = fxyz4 + (gamma - 1.)*densi**(1.-gamma)*u0i*fsum(idendtdissi) + fxyz4 = fxyz4 + (gammai - 1.)*densi**(1.-gammai)*u0i*fsum(idendtdissi) endif #ifdef GR #ifdef ISENTROPIC @@ -2879,7 +2872,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv ! cooling with stored dust temperature if (do_nucleation) then call energ_cooling(xi,yi,zi,vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) + dust_temp(i),eos_vars(imu,i),eos_vars(igamma,i),nucleation(idK2,i),nucleation(idkappa,i)) elseif (update_muGamma) then call energ_cooling(xi,yi,zi,vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& dust_temp(i),eos_vars(imu,i),eos_vars(igamma,i)) diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index ebc536639..b603fc501 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -338,13 +338,13 @@ end subroutine get_erec_components ! gas particle. Inputs and outputs in code units !+ !---------------------------------------------------------------- -subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,gamma,ethi) +subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,ethi) use part, only:rhoh use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp use physcon, only:radconst,Rg use units, only:unit_density,unit_pressure,unit_ergg,unit_pressure integer, intent(in) :: ieos - real, intent(in) :: particlemass,presi,tempi,xyzh(4),vxyzu(4),gamma + real, intent(in) :: particlemass,presi,tempi,xyzh(4),vxyzu(4) real, intent(out) :: ethi real :: hi,densi_cgs,mui @@ -353,7 +353,7 @@ subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,gamma,et hi = xyzh(4) densi_cgs = rhoh(hi,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,gamma,ethi) + 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) diff --git a/src/main/krome.f90 b/src/main/krome.f90 index ce638b4f2..20e7bcd45 100644 --- a/src/main/krome.f90 +++ b/src/main/krome.f90 @@ -44,7 +44,7 @@ subroutine initialise_krome() krome_set_user_crflux,krome_get_names,krome_get_mu_x,krome_get_gamma_x,& krome_idx_S,krome_idx_Fe,krome_idx_Si,krome_idx_Mg,krome_idx_Na,& krome_idx_P,krome_idx_F - use part, only:abundance,abundance_label,mu_chem,gamma_chem,T_gas_cool + use part, only:abundance,abundance_label,eos_vars,igamma,imu,T_gas_cool use dim, only:maxvxyzu real :: wind_temperature @@ -98,8 +98,8 @@ subroutine initialise_krome() abundance(krome_idx_H,:) = H_init !set initial wind temperature to star's effective temperature - mu_chem(:) = krome_get_mu_x(abundance(:,1)) - gamma_chem(:) = krome_get_gamma_x(abundance(:,1),wind_temperature) + eos_vars(imu,:) = krome_get_mu_x(abundance(:,1)) + eos_vars(igamma,:) = krome_get_gamma_x(abundance(:,1),wind_temperature) T_gas_cool(:) = wind_temperature if (maxvxyzu < 4) then print *, "CHEMISTRY PROBLEM: ISOTHERMAL SETUP USED, INTERNAL ENERGY NOT STORED" @@ -107,35 +107,35 @@ subroutine initialise_krome() end subroutine initialise_krome -subroutine update_krome(dt,xyzh,u,rho,xchem,gamma_chem,mu_chem,T_gas_cool) +subroutine update_krome(dt,xyzh,u,rho,xchem,gamma_in,mu_in,T_gas_cool) - use krome_main, only: krome + use krome_main, only:krome use krome_user, only:krome_consistent_x,krome_get_mu_x,krome_get_gamma_x use units, only:unit_density,utime use eos, only:ieos,get_temperature,get_local_u_internal!,temperature_coef real, intent(in) :: dt,xyzh(4),rho - real, intent(inout) :: u,gamma_chem,mu_chem,xchem(:) + real, intent(inout) :: u,gamma_in,mu_in,xchem(:) real, intent(out) :: T_gas_cool real :: T_local, dt_cgs, rho_cgs - dt_cgs = dt*utime + dt_cgs = dt*utime rho_cgs = rho*unit_density - T_local = get_temperature(ieos,xyzh(1:3),rho,(/0.,0.,0.,u/),gammai=gamma_chem,mui=mu_chem) - T_local=max(T_local,20.0d0) + T_local = get_temperature(ieos,xyzh(1:3),rho,(/0.,0.,0.,u/),gammai=gamma_in,mui=mu_in) + T_local = max(T_local,20.0d0) ! normalise abudances and balance charge conservation with e- call krome_consistent_x(xchem) ! evolve the chemistry and update the abundances call krome(xchem,rho_cgs,T_local,dt_cgs) ! update the particle's mean molecular weight - mu_chem = krome_get_mu_x(xchem) + mu_in = krome_get_mu_x(xchem) ! update the particle's adiabatic index - gamma_chem = krome_get_gamma_x(xchem,T_local) + gamma_in = krome_get_gamma_x(xchem,T_local) ! update the particle's temperature T_gas_cool = T_local ! get the new internal energy - u = get_local_u_internal(gamma_chem,mu_chem,T_local) - !u = T_local/(mu_chem*temperature_coef)/(gamma_chem-1.) + u = get_local_u_internal(gamma_in,mu_in,T_local) + !u = T_local/(mu_in*temperature_coef)/(gamma_in-1.) end subroutine update_krome diff --git a/src/main/part.F90 b/src/main/part.F90 index 7eeee6ad2..70acccbef 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -106,7 +106,7 @@ module part 'dvydx','dvydy','dvydz', & 'dvzdx','dvzdy','dvzdz'/) ! -!--H2 and KROME chemistry +!--H2 chemistry ! integer, parameter :: ih2ratio = 1 ! ratio of H2 to H integer, parameter :: iHI = 2 ! HI abundance @@ -114,6 +114,9 @@ module part integer, parameter :: ielectron = 4 ! electron abundance integer, parameter :: iCO = 5 ! CO abundance real, allocatable :: abundance(:,:) +! +!--KROME chemistry +! #ifdef KROME character(len=16) :: abundance_label(krome_nmols) #else @@ -247,10 +250,7 @@ module part ! !--KROME variables ! - real, allocatable :: gamma_chem(:) - real, allocatable :: mu_chem(:) real, allocatable :: T_gas_cool(:) - real, allocatable :: dudt_chem(:) ! !--radiation hydro, evolved quantities (which have time derivatives) ! @@ -460,10 +460,7 @@ subroutine allocate_part else call allocate_array('abundance', abundance, nabundances, maxp_h2) endif - call allocate_array('gamma_chem', gamma_chem, maxp_krome) - call allocate_array('mu_chem', mu_chem, maxp_krome) call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) - call allocate_array('dudt_chem', dudt_chem, maxp_krome) end subroutine allocate_part @@ -525,10 +522,7 @@ subroutine deallocate_part if (allocated(nucleation)) deallocate(nucleation) if (allocated(tau)) deallocate(tau) if (allocated(tau_lucy)) deallocate(tau_lucy) - if (allocated(gamma_chem)) deallocate(gamma_chem) - if (allocated(mu_chem)) deallocate(mu_chem) if (allocated(T_gas_cool)) deallocate(T_gas_cool) - if (allocated(dudt_chem)) deallocate(dudt_chem) if (allocated(dust_temp)) deallocate(dust_temp) if (allocated(rad)) deallocate(rad,radpred,drad,radprop) if (allocated(iphase)) deallocate(iphase) @@ -1262,10 +1256,7 @@ subroutine copy_particle_all(src,dst,new_part) if (itauL_alloc == 1) tau_lucy(dst) = tau_lucy(src) if (use_krome) then - gamma_chem(dst) = gamma_chem(src) - mu_chem(dst) = mu_chem(src) T_gas_cool(dst) = T_gas_cool(src) - dudt_chem(dst) = dudt_chem(src) endif ibelong(dst) = ibelong(src) if (maxsts==maxp) then diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 1d78204c3..b4ef36210 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -224,7 +224,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) free_header,write_header,write_array,write_block_header use mpiutils, only:reduce_mpi,reduceall_mpi use timestep, only:dtmax,idtmax_n,idtmax_frac - use part, only:ibin,krome_nmols,gamma_chem,mu_chem,T_gas_cool + use part, only:ibin,krome_nmols,T_gas_cool #ifdef PRDRAG use lumin_nsdisc, only:beta #endif @@ -437,11 +437,9 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) if (use_krome) then call write_array(1,abundance,abundance_label,krome_nmols,npart,k,ipass,idump,nums,ierrs(21)) - call write_array(1,gamma_chem,'gamma',npart,k,ipass,idump,nums,ierrs(22)) - call write_array(1,mu_chem,'mu',npart,k,ipass,idump,nums,ierrs(23)) call write_array(1,T_gas_cool,'temp',npart,k,ipass,idump,nums,ierrs(24)) endif - if (update_muGamma) then + if (update_muGamma .or. use_krome) then call write_array(1,eos_vars(imu,:),eos_vars_label(imu),npart,k,ipass,idump,nums,ierrs(12)) call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,ierrs(12)) endif @@ -1138,7 +1136,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto VrelVf,VrelVf_label,dustgasprop,dustgasprop_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,gamma_chem,mu_chem,T_gas_cool + ithick,ilambda,iorig,dt_in,krome_nmols,T_gas_cool use sphNGutils, only:mass_sphng,got_mass,set_gas_particle_mass integer, intent(in) :: i1,i2,noffset,narraylengths,nums(:,:),npartread,npartoftype(:),idisk1,iprint real, intent(in) :: massoftype(:) @@ -1230,8 +1228,6 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto endif if (use_krome) then call read_array(abundance,abundance_label,got_krome_mols,ik,i1,i2,noffset,idisk1,tag,match,ierr) - call read_array(gamma_chem,'gamma',got_krome_gamma,ik,i1,i2,noffset,idisk1,tag,match,ierr) - call read_array(mu_chem,'mu',got_krome_mu,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 (do_nucleation) then diff --git a/src/main/readwrite_dumps_hdf5.F90 b/src/main/readwrite_dumps_hdf5.F90 index cc8e496c4..b520a2d3f 100644 --- a/src/main/readwrite_dumps_hdf5.F90 +++ b/src/main/readwrite_dumps_hdf5.F90 @@ -107,14 +107,13 @@ subroutine write_dump_hdf5(t,dumpfile,fulldump,ntotal,dtind) luminosity,eta_nimhd,massoftype,hfact,Bextx,Bexty, & Bextz,ndustlarge,idust,idustbound,grainsize, & graindens,h2chemistry,lightcurve,ndivcurlB, & - ndivcurlv,pxyzu,dens,gamma_chem,mu_chem,T_gas_cool, & + ndivcurlv,pxyzu,dens,T_gas_cool, & dust_temp,rad,radprop,itemp,igasP,eos_vars,iorig, & npartoftypetot,update_npartoftypetot use part, only:nucleation #ifdef IND_TIMESTEPS use part, only:ibin #endif - use part, only:gamma_chem use mpiutils, only:reduce_mpi,reduceall_mpi use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use setup_params, only:rhozero @@ -365,8 +364,6 @@ subroutine write_dump_hdf5(t,dumpfile,fulldump,ntotal,dtind) beta_pr, & ! pxyzu, & ! dens, & ! - gamma_chem, & ! - mu_chem, & ! T_gas_cool, & ! nucleation, & ! dust_temp, & ! @@ -483,9 +480,8 @@ subroutine read_any_dump_hdf5( ndustsmall,grainsize,graindens,Bextx,Bexty,Bextz, & alphaind,poten,Bxyz,Bevol,dustfrac,deltav,dustprop, & dustgasprop,VrelVf,eos_vars,abundance, & - periodic,ndusttypes,pxyzu,gamma_chem,mu_chem, & - T_gas_cool,dust_temp,nucleation,rad,radprop,igasP, & - itemp,iorig + periodic,ndusttypes,pxyzu,T_gas_cool,dust_temp, & + nucleation,rad,radprop,igasP,itemp,iorig #ifdef IND_TIMESTEPS use part, only:dt_in #endif @@ -677,8 +673,6 @@ subroutine read_any_dump_hdf5( dustgasprop, & abundance, & pxyzu, & - gamma_chem, & - mu_chem, & T_gas_cool, & nucleation, & dust_temp, & diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 44cbb76a1..5f7748070 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -108,9 +108,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) iosumflrp,iosumflrps,iosumflrc use cooling, only:ufloor use boundary_dyn, only:dynamic_bdy,update_xyzminmax -#ifdef KROME - use part, only:gamma_chem -#endif use timestep, only:dtmax,dtmax_ifactor,dtdiff use timestep_ind, only:get_dt,nbinmax,decrease_dtmax,dt_too_small use timestep_sts, only:sts_get_dtau_next,use_sts,ibin_sts,sts_it_n @@ -1089,7 +1086,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, use dust_formation, only:evolve_dust,calc_muGamma use units, only:unit_density #ifdef KROME - use part, only: gamma_chem,mu_chem,dudt_chem,T_gas_cool + use part, only: T_gas_cool use krome_interface, only: update_krome #endif integer, intent(in) :: npart,ntypes,nptmass @@ -1205,9 +1202,6 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, !$omp shared(nptmass,nsubsteps,C_force,divcurlv,dphotflag,dphot0) & !$omp shared(abundc,abundo,abundsi,abunde) & !$omp shared(nucleation,do_nucleation,update_muGamma,h2chemistry,unit_density) & -#ifdef KROME - !$omp shared(gamma_chem,mu_chem,dudt_chem) & -#endif !$omp private(dphot,abundi,gmwvar,ph,ph_tot) & !$omp private(ui,rhoi, mui, gammai) & !$omp private(i,dudtcool,fxi,fyi,fzi,phii) & @@ -1313,8 +1307,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, ! Krome also computes cooling function but only associated with chemical processes ui = vxyzu(4,i) call update_krome(dt,xyzh(:,i),ui,rhoi,abundance(:,i),eos_vars(igamma,i),eos_vars(imu,i),T_gas_cool(i)) - dudt_chem(i) = (ui-vxyzu(4,i))/dt - dudtcool = dudt_chem(i) + dudtcool = (ui-vxyzu(4,i))/dt #else !evolve dust chemistry and compute dust cooling if (do_nucleation) call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) diff --git a/src/main/utils_dumpfiles_hdf5.f90 b/src/main/utils_dumpfiles_hdf5.f90 index 32ab218c2..1bed55413 100644 --- a/src/main/utils_dumpfiles_hdf5.f90 +++ b/src/main/utils_dumpfiles_hdf5.f90 @@ -338,8 +338,6 @@ subroutine write_hdf5_arrays( & beta_pr, & pxyzu, & dens, & - gamma_chem, & - mu_chem, & T_gas_cool, & nucleation, & dust_temp, & @@ -370,8 +368,6 @@ subroutine write_hdf5_arrays( & deltav(:,:,:), & pxyzu(:,:), & dens(:), & - gamma_chem(:), & - mu_chem(:), & T_gas_cool(:), & nucleation(:,:), & dust_temp(:), & @@ -486,8 +482,6 @@ subroutine write_hdf5_arrays( & ! Chemistry (Krome) if (array_options%krome) then call write_to_hdf5(abundance(:,1:npart), 'abundance', group_id, error) - call write_to_hdf5(gamma_chem(1:npart), 'gamma_chem', group_id, error) - call write_to_hdf5(mu_chem(1:npart), 'mu_chem', group_id, error) call write_to_hdf5(T_gas_cool(1:npart), 'T_gas_cool', group_id, error) endif @@ -794,8 +788,6 @@ subroutine read_hdf5_arrays( & dustgasprop, & abundance, & pxyzu, & - gamma_chem, & - mu_chem, & T_gas_cool, & nucleation, & dust_temp, & @@ -824,8 +816,6 @@ subroutine read_hdf5_arrays( & VrelVf(:), & abundance(:,:), & pxyzu(:,:), & - gamma_chem(:), & - mu_chem(:), & T_gas_cool(:), & nucleation(:,:), & dust_temp(:), & @@ -959,8 +949,6 @@ subroutine read_hdf5_arrays( & if (array_options%krome) then call read_from_hdf5(abundance, 'abundance', group_id, got, error) if (got) got_arrays%got_krome_mols = .true. - call read_from_hdf5(gamma_chem, 'gamma_chem', group_id, got_arrays%got_krome_gamma, error) - call read_from_hdf5(mu_chem, 'mu_chem', group_id, got_arrays%got_krome_mu, error) call read_from_hdf5(T_gas_cool, 'T_gas_cool', group_id, got_arrays%got_krome_gamma, error) endif diff --git a/src/setup/setup_shock.F90 b/src/setup/setup_shock.F90 index 3ce703e75..8ada6be7d 100644 --- a/src/setup/setup_shock.F90 +++ b/src/setup/setup_shock.F90 @@ -258,12 +258,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, Pcgs = leftstate(ipr) * unit_pressure denscgs = leftstate(idens) * unit_density call get_idealgasplusrad_tempfrompres(Pcgs,denscgs,gmw,temp) - call get_idealplusrad_enfromtemp(denscgs,temp,gmw,5./3.,ucgs) + call get_idealplusrad_enfromtemp(denscgs,temp,gmw,ucgs) uuleft = ucgs/unit_ergg Pcgs = rightstate(ipr) * unit_pressure denscgs = rightstate(idens) * unit_density call get_idealgasplusrad_tempfrompres(Pcgs,denscgs,gmw,temp) - call get_idealplusrad_enfromtemp(denscgs,temp,gmw,5./3.,ucgs) + call get_idealplusrad_enfromtemp(denscgs,temp,gmw,ucgs) uuright = ucgs/unit_ergg else gam1 = gamma - 1. diff --git a/src/tests/test_eos.f90 b/src/tests/test_eos.f90 index 316c78cbc..546e33c53 100644 --- a/src/tests/test_eos.f90 +++ b/src/tests/test_eos.f90 @@ -126,7 +126,6 @@ subroutine test_idealplusrad(ntests, npass) ieos = 12 mu = 0.6 - gamma = 5./3. call get_rhoT_grid(npts,rhogrid,Tgrid) dum = 0. @@ -136,7 +135,7 @@ subroutine test_idealplusrad(ntests, npass) do i=1,npts do j=1,npts ! Get u, P from rho, T - call get_idealplusrad_enfromtemp(rhogrid(i),Tgrid(j),mu,gamma,eni) + call get_idealplusrad_enfromtemp(rhogrid(i),Tgrid(j),mu,eni) call get_idealplusrad_pres(rhogrid(i),Tgrid(j),mu,presi) ! Recalculate T, P, from rho, u @@ -181,7 +180,6 @@ subroutine test_hormone(ntests, npass) ieos = 20 X = 0.69843 Z = 0.01426 - gamma = 5./3. call get_rhoT_grid(npts,rhogrid,Tgrid) @@ -197,12 +195,13 @@ subroutine test_hormone(ntests, npass) call equationofstate(ieos,ponrhoi,csound,rhocodei,0.,0.,0.,tempi,eni_code,mu_local=mu,Xlocal=X,Zlocal=Z,gamma_local=gamma) do i=1,npts do j=1,npts + gamma = 5./3. ! Get mu from rho, T call get_imurec(log10(rhogrid(i)),Tgrid(j),X,1.-X-Z,imurec) mu = 1./imurec ! Get u, P from rho, T, mu - call get_idealplusrad_enfromtemp(rhogrid(i),Tgrid(j),mu,gamma,gasrad_eni) + call get_idealplusrad_enfromtemp(rhogrid(i),Tgrid(j),mu,gasrad_eni) eni = gasrad_eni + get_erec(log10(rhogrid(i)),Tgrid(j),X,1.-X-Z) call get_idealplusrad_pres(rhogrid(i),Tgrid(j),mu,presi) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index a000ddab0..62cba553d 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -702,7 +702,7 @@ subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) tempi = eos_vars(itemp,i) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call cross_product3D(xyzh(1:3,i), particlemass * vxyzu(1:3,i), rcrossmv) ! Angular momentum w.r.t. CoM - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) 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 @@ -1522,7 +1522,7 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum1) if (quantities_to_calculate(k)==1) then - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + 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 @@ -1578,7 +1578,7 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) 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),gamma,ethi) + 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 @@ -1732,7 +1732,7 @@ subroutine track_particle(time,particlemass,xyzh,vxyzu) ! MESA ENTROPY ! Si = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi call ionisation_fraction(rhopart*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) @@ -1932,7 +1932,7 @@ subroutine recombination_tau(time,npart,particlemass,xyzh,vxyzu) kappa_part(i) = kappa ! In cgs units call ionisation_fraction(rho_part(i)*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) ! Calculate total energy - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rho_part(i),eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rho_part(i),eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi if ((xh0 > recomb_th) .and. (.not. prev_recombined(i)) .and. (etoti < 0.)) then ! Recombination event and particle is still bound j=j+1 @@ -2013,7 +2013,7 @@ subroutine energy_hist(time,npart,particlemass,xyzh,vxyzu) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) if (ieos==10 .or. ieos==20) then - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) else ethi = einti endif @@ -2155,7 +2155,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) select case (iquantity) case(1) ! Energy call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) quant(i,1) = ekini + epoti + ethi case(2) ! Entropy if ((ieos==10) .and. (ientropy==2)) then @@ -2302,7 +2302,7 @@ subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) vr(i) = dot_product(xyzh(1:3,i),vxyzu(1:3,i)) / sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) if (ekini+epoti > 0.) then @@ -2611,7 +2611,7 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) etoti = ekini + epoti + ethi ! Ekin + Epot + Eth > 0 @@ -2719,7 +2719,7 @@ subroutine unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) etoti = ekini + epoti + ethi if ((etoti > 0.) .and. (.not. prev_unbound(i))) then @@ -2789,7 +2789,7 @@ subroutine unbound_temp(time,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),eos_vars(itemp,i),vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi if ((etoti > 0.) .and. (.not. prev_unbound(i))) then @@ -2859,7 +2859,7 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi call get_eos_pressure_temp_mesa(rhopart*unit_density,vxyzu(4,i)*unit_ergg,pressure,temperature) ! This should depend on ieos @@ -3062,7 +3062,7 @@ subroutine env_binding_ene(npart,particlemass,xyzh,vxyzu) rhoi = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhoi,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhoi,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhoi,eos_vars(itemp,i),ethi) eth_tot = eth_tot + ethi eint_tot = eint_tot + particlemass * vxyzu(4,i) From f85386d317b83b8d3e76fc289613e4cf1e7569a5 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 15 Dec 2023 12:49:30 +0100 Subject: [PATCH 235/814] remove unused variable --- src/main/force.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/force.F90 b/src/main/force.F90 index 1d2d193cf..f9b8dfec2 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -2489,7 +2489,7 @@ 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 - use eos, only:gamma,ieos,iopacity_type + use eos, only:ieos,iopacity_type use options, only:alpha,ipdv_heating,ishock_heating,psidecayfac,overcleanfac,hdivbbmax_max, & use_dustfrac,damp,icooling,implicit_radiation use part, only:rhoanddhdrho,iboundary,igas,maxphase,maxvxyzu,nptmass,xyzmh_ptmass,eos_vars, & From ccf8fd33429adece8d59171ceba67f1ea3f35275 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 15 Dec 2023 13:17:32 +0100 Subject: [PATCH 236/814] (dust_formation) missing update of eos_vars(mu,gamma) --- src/main/dust_formation.f90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index 2ffd9c61a..1046737f6 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.f90 @@ -134,6 +134,7 @@ end subroutine set_abundances subroutine evolve_dust(dtsph, xyzh, u, JKmuS, Tdust, rho) use units, only:utime,unit_density use eos, only:ieos,get_temperature + use part, only:eos_vars,igamma,imu real, intent(in) :: dtsph,Tdust,rho,u,xyzh(4) real, intent(inout) :: JKmuS(:) @@ -146,7 +147,9 @@ subroutine evolve_dust(dtsph, xyzh, u, JKmuS, Tdust, rho) vxyzui(4) = u T = get_temperature(ieos,xyzh,rho,vxyzui,gammai=JKmuS(idgamma),mui=JKmuS(idmu)) call evolve_chem(dt_cgs, T, rho_cgs, JKmuS) - JKmuS(idkappa) = calc_kappa_dust(JKmuS(idK3), Tdust, rho_cgs) + JKmuS(idkappa) = calc_kappa_dust(JKmuS(idK3), Tdust, rho_cgs) + eos_vars(imu,i) = JKmuS(idmu,i) + eos_vars(igamma,i) = JKmuS(idgamma,i) end subroutine evolve_dust From 35a2355a922289311d62b3ed3a3d7333429b6625 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 15 Dec 2023 13:22:17 +0100 Subject: [PATCH 237/814] fix bugs --- src/main/dust_formation.f90 | 3 --- src/main/step_leapfrog.F90 | 7 +++++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index 1046737f6..8343c00c3 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.f90 @@ -134,7 +134,6 @@ end subroutine set_abundances subroutine evolve_dust(dtsph, xyzh, u, JKmuS, Tdust, rho) use units, only:utime,unit_density use eos, only:ieos,get_temperature - use part, only:eos_vars,igamma,imu real, intent(in) :: dtsph,Tdust,rho,u,xyzh(4) real, intent(inout) :: JKmuS(:) @@ -148,8 +147,6 @@ subroutine evolve_dust(dtsph, xyzh, u, JKmuS, Tdust, rho) T = get_temperature(ieos,xyzh,rho,vxyzui,gammai=JKmuS(idgamma),mui=JKmuS(idmu)) call evolve_chem(dt_cgs, T, rho_cgs, JKmuS) JKmuS(idkappa) = calc_kappa_dust(JKmuS(idK3), Tdust, rho_cgs) - eos_vars(imu,i) = JKmuS(idmu,i) - eos_vars(igamma,i) = JKmuS(idgamma,i) end subroutine evolve_dust diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 5f7748070..5c1fcdbfb 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -1310,8 +1310,11 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, dudtcool = (ui-vxyzu(4,i))/dt #else !evolve dust chemistry and compute dust cooling - if (do_nucleation) call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) - + if (do_nucleation) then + call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) + eos_vars(imu,i) = nucleation(idmu,i) + eos_vars(igamma,i) = nucleation(idgamma,i) + endif ! ! COOLING ! From bec09105e87f40109a53700175ed4ce9ab5069f3 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 15 Dec 2023 14:12:23 +0100 Subject: [PATCH 238/814] not the right fix - please Daniel have a look (mpi stuff) --- src/main/energies.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index b5f6788c9..73d130e65 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -595,7 +595,8 @@ subroutine compute_energies(t) if (.not.gr) ekin = 0.5*ekin emag = 0.5*emag ekin = reduceall_mpi('+',ekin) - if (maxvxyzu >= 4 .or. gammai >= 1.0001) etherm = reduceall_mpi('+',etherm) + !LS I don't know what to do here ? gamma should be replaced by gammai ? + if (maxvxyzu >= 4 .or. gamma >= 1.0001) etherm = reduceall_mpi('+',etherm) emag = reduceall_mpi('+',emag) epot = reduceall_mpi('+',epot) erad = reduceall_mpi('+',erad) From be734160cfb5b7bb2c25f5c279e9c1dde9af2659 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Tue, 19 Dec 2023 09:42:05 +0100 Subject: [PATCH 239/814] minor change --- src/main/cooling_functions.f90 | 34 +++++++++++++++++----------------- src/main/krome.f90 | 2 +- src/main/step_leapfrog.F90 | 3 +-- 3 files changed, 19 insertions(+), 20 deletions(-) diff --git a/src/main/cooling_functions.f90 b/src/main/cooling_functions.f90 index 0bd205c24..5e1f64e2f 100644 --- a/src/main/cooling_functions.f90 +++ b/src/main/cooling_functions.f90 @@ -80,14 +80,14 @@ end subroutine piecewise_law ! Bowen 1988 cooling prescription !+ !----------------------------------------------------------------------- -subroutine cooling_Bowen_relaxation(T, Tdust, rho, mu, gamma, Q, dlnQ_dlnT) +subroutine cooling_Bowen_relaxation(T, Tdust, rho_cgs, mu, gamma, Q_cgs, dlnQ_dlnT) use physcon, only:Rg - real, intent(in) :: T, Tdust, rho, mu, gamma - real, intent(out) :: Q, dlnQ_dlnT + real, intent(in) :: T, Tdust, rho_cgs, mu, gamma + real, intent(out) :: Q_cgs, dlnQ_dlnT - Q = Rg/((gamma-1.)*mu)*rho*(Tdust-T)/bowen_Cprime + Q_cgs = Rg/((gamma-1.)*mu)*rho_cgs*(Tdust-T)/bowen_Cprime dlnQ_dlnT = -T/(Tdust-T+1.d-10) end subroutine cooling_Bowen_relaxation @@ -97,22 +97,22 @@ end subroutine cooling_Bowen_relaxation ! collisionnal cooling !+ !----------------------------------------------------------------------- -subroutine cooling_dust_collision(T, Tdust, rho, K2, mu, Q, dlnQ_dlnT) +subroutine cooling_dust_collision(T, Tdust, rho, K2, mu, Q_cgs, dlnQ_dlnT) use physcon, only: kboltz, mass_proton_cgs, pi real, intent(in) :: T, Tdust, rho, K2, mu - real, intent(out) :: Q, dlnQ_dlnT + real, intent(out) :: Q_cgs, dlnQ_dlnT real, parameter :: f = 0.15, a0 = 1.28e-8 real :: A A = 2. * f * kboltz * a0**2/(mass_proton_cgs**2*mu) & * (1.05/1.54) * sqrt(2.*pi*kboltz/mass_proton_cgs) * 2.*K2 * rho - Q = A * sqrt(T) * (Tdust-T) - if (Q > 1.d6) then + Q_cgs = A * sqrt(T) * (Tdust-T) + if (Q_cgs > 1.d6) then print *, f, kboltz, a0, mass_proton_cgs, mu - print *, mu, K2, rho, T, Tdust, A, Q + print *, mu, K2, rho, T, Tdust, A, Q_cgs stop 'cooling' else dlnQ_dlnT = 0.5+T/(Tdust-T+1.d-10) @@ -125,14 +125,14 @@ end subroutine cooling_dust_collision ! Woitke (2006 A&A) cooling term !+ !----------------------------------------------------------------------- -subroutine cooling_radiative_relaxation(T, Tdust, kappa, Q, dlnQ_dlnT) +subroutine cooling_radiative_relaxation(T, Tdust, kappa, Q_cgs, dlnQ_dlnT) use physcon, only: steboltz real, intent(in) :: T, Tdust, kappa - real, intent(out) :: Q, dlnQ_dlnT + real, intent(out) :: Q_cgs, dlnQ_dlnT - Q = 4.*steboltz*(Tdust**4-T**4)*kappa + Q_cgs = 4.*steboltz*(Tdust**4-T**4)*kappa dlnQ_dlnT = -4.*T**4/(Tdust**4-T**4+1.d-10) end subroutine cooling_radiative_relaxation @@ -142,12 +142,12 @@ end subroutine cooling_radiative_relaxation ! Cooling due to electron excitation of neutral H (Spitzer 1978) !+ !----------------------------------------------------------------------- -subroutine cooling_neutral_hydrogen(T, rho_cgs, Q, dlnQ_dlnT) +subroutine cooling_neutral_hydrogen(T, rho_cgs, Q_cgs, dlnQ_dlnT) use physcon, only: mass_proton_cgs real, intent(in) :: T, rho_cgs - real, intent(out) :: Q,dlnQ_dlnT + real, intent(out) :: Q_cgs,dlnQ_dlnT real, parameter :: f = 1.0d0 real :: ne,nH @@ -156,11 +156,11 @@ subroutine cooling_neutral_hydrogen(T, rho_cgs, Q, dlnQ_dlnT) nH = rho_cgs/(1.4*mass_proton_cgs) ne = calc_eps_e(T)*nH !the term 1/(1+sqrt(T)) comes from Cen (1992, ApjS, 78, 341) - Q = -f*7.3d-19*ne*nH*exp(-118400./T)/rho_cgs/(1.+sqrt(T/1.d5)) + Q_cgs = -f*7.3d-19*ne*nH*exp(-118400./T)/rho_cgs/(1.+sqrt(T/1.d5)) dlnQ_dlnT = -118400./T+log(nH*calc_eps_e(1.001*T)/ne)/log(1.001) & - 0.5*sqrt(T/1.d5)/(1.+sqrt(T/1.d5)) else - Q = 0. + Q_cgs = 0. dlnQ_dlnT = 0. endif @@ -341,7 +341,7 @@ end function n_dust !======================================================================= !\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ ! -! Cooling functions +! Cooling functions **** ALL IN cgs **** ! !\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ !======================================================================= diff --git a/src/main/krome.f90 b/src/main/krome.f90 index 20e7bcd45..24f7768b6 100644 --- a/src/main/krome.f90 +++ b/src/main/krome.f90 @@ -135,7 +135,7 @@ subroutine update_krome(dt,xyzh,u,rho,xchem,gamma_in,mu_in,T_gas_cool) T_gas_cool = T_local ! get the new internal energy u = get_local_u_internal(gamma_in,mu_in,T_local) - !u = T_local/(mu_in*temperature_coef)/(gamma_in-1.) +! u = T_local/(mu_in*temperature_coef)/(gamma_in-1.) end subroutine update_krome diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 5c1fcdbfb..6f039ff5c 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -106,7 +106,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,ibin_wake use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc - use cooling, only:ufloor use boundary_dyn, only:dynamic_bdy,update_xyzminmax use timestep, only:dtmax,dtmax_ifactor,dtdiff use timestep_ind, only:get_dt,nbinmax,decrease_dtmax,dt_too_small @@ -116,7 +115,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use metric_tools, only:imet_minkowski,imetric use cons2prim, only:cons2primall use extern_gr, only:get_grforce_all - use cooling, only:cooling_in_step + use cooling, only:ufloor,cooling_in_step use timing, only:increment_timer,get_timings,itimer_extf use growth, only:check_dustprop use damping, only:idamp From 42dbf9d0def6a69ea82763cd7bdcaeedf0a47aad Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Tue, 19 Dec 2023 10:38:59 +0100 Subject: [PATCH 240/814] bug fixes --- src/setup/setup_galdisc.f90 | 4 ++-- src/setup/setup_wind.f90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/setup/setup_galdisc.f90 b/src/setup/setup_galdisc.f90 index b03fc2541..36267b2c3 100644 --- a/src/setup/setup_galdisc.f90 +++ b/src/setup/setup_galdisc.f90 @@ -48,13 +48,13 @@ module setup ! !-------------------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) - use dim, only:maxp,maxvxyzu,use_dust + use dim, only:maxp,maxvxyzu,use_dust,h2chemistry use setup_params, only:rhozero use physcon, only:Rg,pi,solarm,pc,kpc use units, only:umass,udist,utime,set_units use mpiutils, only:bcast_mpi use random, only:ran2 - use part, only:h2chemistry,abundance,iHI,dustfrac,istar,igas,ibulge,& + use part, only:abundance,iHI,dustfrac,istar,igas,ibulge,& idarkmatter,iunknown,set_particle_type,ndusttypes use options, only:iexternalforce,icooling,nfulldump,use_dustfrac use externalforces, only:externalforce,initialise_externalforces diff --git a/src/setup/setup_wind.f90 b/src/setup/setup_wind.f90 index a8b1cf57c..90efaedfa 100644 --- a/src/setup/setup_wind.f90 +++ b/src/setup/setup_wind.f90 @@ -138,7 +138,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use io, only: master use eos, only: gmw,ieos,isink,qfacdisc use spherical, only: set_sphere - use timestep, only: tmax,dtmax + use timestep, only: tmax!,dtmax integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) From aac2cab15e445c2e25a4aa6979b2be5cfcf13c26 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Tue, 19 Dec 2023 11:33:30 +0100 Subject: [PATCH 241/814] more bug fixes --- src/utils/analysis_common_envelope.f90 | 2 +- src/utils/analysis_raytracer.f90 | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 62cba553d..d5080a7b4 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -3771,7 +3771,7 @@ subroutine analyse_disk(num,npart,particlemass,xyzh,vxyzu) ! Calculate thermal 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),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) call get_gas_omega(xyzmh_ptmass(1:3,2),vxyz_ptmass(1:3,2),xyzh(1:3,i),vxyzu(1:3,i),vphi,omegai) call cross_product3D(xyzh(1:3,i)-xyzmh_ptmass(1:3,2), vxyzu(1:3,i)-vxyz_ptmass(1:3,2), Ji) diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index 328a65284..3ca1cd8a6 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.f90 @@ -697,4 +697,3 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) end subroutine do_analysis end module analysis -raytracer_all From f54bf01e9e9bfc9f579f6665995879ebbfeabf3d Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Tue, 19 Dec 2023 14:04:18 +0100 Subject: [PATCH 242/814] wind_setup : missing initializations --- src/main/inject_wind.f90 | 1 - src/setup/setup_wind.f90 | 3 ++- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index 24b168693..0d40723cc 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.f90 @@ -664,7 +664,6 @@ subroutine write_options_inject(iunit) use infile_utils, only: write_inopt integer, intent(in) :: iunit - !if (sonic_type < 0) call set_default_options_inject call write_inopt(sonic_type,'sonic_type','find transonic solution (1=yes,0=no)',iunit) call write_inopt(wind_velocity_km_s,'wind_velocity','injection wind velocity (km/s, if sonic_type = 0)',iunit) !call write_inopt(pulsation_period_days,'pulsation_period','stellar pulsation period (days)',iunit) diff --git a/src/setup/setup_wind.f90 b/src/setup/setup_wind.f90 index 90efaedfa..dddc95231 100644 --- a/src/setup/setup_wind.f90 +++ b/src/setup/setup_wind.f90 @@ -132,7 +132,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use part, only: xyzmh_ptmass, vxyz_ptmass, nptmass, igas, iTeff, iLum, iReff use physcon, only: au, solarm, mass_proton_cgs, kboltz, solarl use units, only: umass,set_units,unit_velocity,utime,unit_energ,udist - use inject, only: init_inject + use inject, only: init_inject,set_default_options_inject use setbinary, only: set_binary use sethierarchical, only: set_multiple use io, only: master @@ -154,6 +154,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_units(dist=au,mass=solarm,G=1.) call set_default_parameters_wind() + call set_default_options_inject() !--general parameters ! From 9e1a0f5437d977bef87865068db6fb403e748e65 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Tue, 19 Dec 2023 14:58:06 +0100 Subject: [PATCH 243/814] (wind_setup) fix initialization - variables were systematically overwritten --- src/setup/setup_wind.f90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/setup/setup_wind.f90 b/src/setup/setup_wind.f90 index dddc95231..a95b35292 100644 --- a/src/setup/setup_wind.f90 +++ b/src/setup/setup_wind.f90 @@ -154,7 +154,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_units(dist=au,mass=solarm,G=1.) call set_default_parameters_wind() - call set_default_options_inject() + filename = trim(fileprefix)//'.in' + inquire(file=filename,exist=iexist) + if (.not. iexist) call set_default_options_inject !--general parameters ! From c15a2e20461a7ba2cb3ff7fb79af915ab1227804 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 20 Dec 2023 11:20:03 +1100 Subject: [PATCH 244/814] (cooling shock) bug fixes/updates to cooling shock problem --- src/main/cooling.f90 | 5 +++-- src/main/cooling_functions.f90 | 12 ++++++------ src/main/cooling_solver.f90 | 8 ++++---- src/main/eos.f90 | 4 ++-- src/setup/setup_shock.F90 | 33 +++++++++++++++++++-------------- src/tests/test_cooling.f90 | 13 +++++++++++++ 6 files changed, 47 insertions(+), 28 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 462394f0d..da419917a 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -33,7 +33,7 @@ module cooling use options, only:icooling use timestep, only:C_cool - use cooling_solver, only:T0_value ! expose to other routines + use cooling_solver, only:T0_value,lambda_shock_cgs ! expose to other routines implicit none character(len=*), parameter :: label = 'cooling' @@ -46,7 +46,7 @@ module cooling !--Minimum temperature (failsafe to prevent u < 0); optional for ALL cooling options real, public :: Tfloor = 0. ! [K]; set in .in file. On if Tfloor > 0. real, public :: ufloor = 0. ! [code units]; set in init_cooling - public :: T0_value ! expose to public + public :: T0_value,lambda_shock_cgs ! expose to public private @@ -147,6 +147,7 @@ subroutine energ_cooling(xi,yi,zi,ui,dudt,rho,dt,Tdust_in,mu_in,gamma_in,K2_in,k if (present(Tdust_in)) Tdust = Tdust_in if (present(K2_in)) K2 = K2_in if (present(kappa_in)) kappa = kappa_in + if (polyIndex < 1.) call fatal('energ_cooling','polyIndex < 1') select case (icooling) case (6) diff --git a/src/main/cooling_functions.f90 b/src/main/cooling_functions.f90 index 04ff47305..9f7b7b321 100644 --- a/src/main/cooling_functions.f90 +++ b/src/main/cooling_functions.f90 @@ -47,9 +47,9 @@ module cooling_functions ! Piecewise cooling law for simple shock problem (Creasey et al. 2011) !+ !----------------------------------------------------------------------- -subroutine piecewise_law(T, T0, ndens, Q, dlnQ) +subroutine piecewise_law(T, T0, rho_cgs, ndens, Q, dlnQ) - real, intent(in) :: T, T0, ndens + real, intent(in) :: T, T0, rho_cgs, ndens real, intent(out) :: Q, dlnQ real :: T1,Tmid !,dlnT,fac @@ -60,12 +60,12 @@ subroutine piecewise_law(T, T0, ndens, Q, dlnQ) dlnQ = 0. elseif (T >= T0 .and. T <= Tmid) then !dlnT = (T-T0)/(T0/100.) - Q = -lambda_shock_cgs*ndens**2*(T-T0)/T0 + Q = -lambda_shock_cgs*ndens**2/rho_cgs*(T-T0)/T0 !fac = 2./(1.d0 + exp(dlnT)) - dlnQ = 1./(T-T0+1.d-10) + dlnQ = 1./(T-T0+epsilon(0.)) elseif (T >= Tmid .and. T <= T1) then - Q = -lambda_shock_cgs*ndens**2*(T1-T)/T0 - dlnQ = -1./(T1-T+1.d-10) + Q = -lambda_shock_cgs*ndens**2/rho_cgs*(T1-T)/T0 + dlnQ = -1./(T1-T+epsilon(0.)) else Q = 0. dlnQ = 0. diff --git a/src/main/cooling_solver.f90 b/src/main/cooling_solver.f90 index c578d474a..11879c844 100644 --- a/src/main/cooling_solver.f90 +++ b/src/main/cooling_solver.f90 @@ -42,7 +42,7 @@ module cooling_solver public :: init_cooling_solver,read_options_cooling_solver,write_options_cooling_solver public :: energ_cooling_solver,calc_cooling_rate, calc_Q public :: testfunc,print_cooling_rates - public :: T0_value ! expose to cooling module + public :: T0_value,lambda_shock_cgs ! expose to cooling module logical, public :: Townsend_test = .false. !for analysis_cooling private @@ -290,7 +290,7 @@ end subroutine exact_cooling !+ !----------------------------------------------------------------------- subroutine calc_cooling_rate(Q, dlnQ_dlnT, rho, T, Teq, mu, gamma, K2, kappa) - use units, only:unit_ergg,unit_density + use units, only:unit_ergg,unit_density,utime use physcon, only:mass_proton_cgs use cooling_functions, only:cooling_neutral_hydrogen,& cooling_Bowen_relaxation,cooling_dust_collision,& @@ -330,7 +330,7 @@ subroutine calc_cooling_rate(Q, dlnQ_dlnT, rho, T, Teq, mu, gamma, K2, kappa) mu, Q_col_dust, dlnQ_col_dust) if (relax_Stefan == 1) call cooling_radiative_relaxation(T, Teq, kappa, Q_relax_Stefan,& dlnQ_relax_Stefan) - if (shock_problem == 1) call piecewise_law(T, T0_value, ndens, Q_H0, dlnQ_H0) + if (shock_problem == 1) call piecewise_law(T, T0_value, rho_cgs, ndens, Q_H0, dlnQ_H0) if (excitation_HI == 99) call testing_cooling_functions(int(K2), T, Q_H0, dlnQ_H0) !if (do_molecular_cooling) call calc_cool_molecular(T, r, rho_cgs, Q_molec, dlnQ_molec) @@ -344,7 +344,7 @@ subroutine calc_cooling_rate(Q, dlnQ_dlnT, rho, T, Teq, mu, gamma, K2, kappa) endif !limit exponent to prevent overflow dlnQ_dlnT = sign(min(50.,abs(dlnQ_dlnT)),dlnQ_dlnT) - Q = Q_cgs/unit_ergg + Q = Q_cgs/(unit_ergg/utime) !call testfunc() !call exit diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 30ca4f2e6..90b2dc0cc 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -434,7 +434,7 @@ end subroutine equationofstate !----------------------------------------------------------------------- subroutine init_eos(eos_type,ierr) use units, only:unit_velocity - use physcon, only:mass_proton_cgs,kboltz + use physcon, only:Rg use io, only:error,warning use eos_mesa, only:init_eos_mesa use eos_helmholtz, only:eos_helmholtz_init @@ -453,7 +453,7 @@ subroutine init_eos(eos_type,ierr) ! included in the function call rather than here ! c_s^2 = gamma*P/rho = gamma*kT/(gmw*m_p) -> T = P/rho * (gmw*m_p)/k ! - temperature_coef = mass_proton_cgs/kboltz * unit_velocity**2 + temperature_coef = unit_velocity**2 / Rg select case(eos_type) case(6) diff --git a/src/setup/setup_shock.F90 b/src/setup/setup_shock.F90 index c39e04ed5..67c13ac33 100644 --- a/src/setup/setup_shock.F90 +++ b/src/setup/setup_shock.F90 @@ -40,8 +40,8 @@ module setup ! prompting, radiation_utils, set_dust, setshock, setup_params, timestep, ! unifdis, units ! - use dim, only:maxvxyzu,use_dust,do_radiation,mhd_nonideal - use options, only:use_dustfrac + use dim, only:maxvxyzu,use_dust,do_radiation,mhd_nonideal,gr + use options, only:use_dustfrac,icooling use timestep, only:dtmax,tmax use dust, only:K_code use eos, only:ieos,gmw @@ -87,22 +87,22 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use boundary, only:ymin,zmin,ymax,zmax,set_boundary use mpiutils, only:bcast_mpi use dim, only:ndim,mhd - use options, only:use_dustfrac,icooling,ieos + use options, only:use_dustfrac,ieos use part, only:labeltype,set_particle_type,igas,iboundary,hrho,Bxyz,mhd,& periodic,dustfrac,gr,ndustsmall,ndustlarge,ndusttypes,ikappa use part, only:rad,radprop,iradxi,ikappa use kernel, only:radkern,hfact_default use prompting, only:prompt use set_dust, only:set_dustfrac - use units, only:set_units,unit_opacity,unit_pressure,unit_density,unit_ergg + use units, only:set_units,unit_opacity,unit_pressure,unit_density,unit_ergg,udist,unit_velocity use dust, only:idrag use unifdis, only:is_closepacked,is_valid_lattice - use physcon, only:au,solarm + use physcon, only:au,solarm,kboltz,mass_proton_cgs use setshock, only:set_shock,adjust_shock_boundaries,fsmooth use radiation_utils, only:radiation_and_gas_temperature_equal use eos_idealplusrad,only:get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp use eos, only:temperature_coef,init_eos - use cooling, only:T0_value + use cooling, only:T0_value,lambda_shock_cgs use nicil, only:eta_constant,eta_const_type,icnstsemi integer, intent(in) :: id integer, intent(out) :: npartoftype(:) @@ -116,6 +116,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real :: delta,gam1,xshock,fac,dtg real :: uuleft,uuright,xbdyleft,xbdyright,dxright real :: rholeft,rhoright,denscgs,Pcgs,ucgs,temp + real :: cooling_length,cs0 integer :: i,ierr,nbpts,iverbose character(len=120) :: shkfile, filename logical :: iexist,jexist,use_closepacked @@ -334,8 +335,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! if (iexist .and. icooling > 0) then call init_eos(ieos,ierr) + cooling_length = 1.0 T0_value = temperature_coef*gmw*rightstate(ipr)/rightstate(idens) - print*,' Setting T0 in cooling function to ',T0_value + cs0 = sqrt(gamma*rightstate(ipr)/rightstate(idens))*unit_velocity ! in cgs units + lambda_shock_cgs = kboltz*T0_value*cs0*mass_proton_cgs/((cooling_length*udist)*rightstate(idens)*unit_density) + print*,' Setting T0 in cooling function to ',T0_value,'mu = ',gmw,' u0 = ',rightstate(ipr)/((gamma-1)*rightstate(idens)),& + ' lambda_shock_cgs = ',lambda_shock_cgs + print*,' cooling length = ',(kboltz*T0_value*cs0/(lambda_shock_cgs*rightstate(idens)*unit_density/mass_proton_cgs))/udist + print*,' max time in code units is ',14.2*cooling_length/(cs0/unit_velocity) + print*,' ndens0 = ',rightstate(idens)*unit_density/mass_proton_cgs endif end subroutine setpart @@ -438,7 +446,7 @@ subroutine choose_shock (gamma,polyk,dtg,iexist) zright = 0.0 const = sqrt(4.*pi) - if (do_radiation) call set_units_interactive(gr) + if (do_radiation .or. icooling > 0 .or. mhd_nonideal) call set_units_interactive(gr) ! !--list of shocks @@ -682,9 +690,8 @@ end function get_conserved_density !------------------------------------------ subroutine write_setupfile(filename,iprint,numstates,gamma,polyk,dtg) use infile_utils, only:write_inopt - use dim, only:tagline,do_radiation + use dim, only:tagline use setunits, only:write_options_units - use part, only:gr integer, intent(in) :: iprint,numstates real, intent(in) :: gamma,polyk,dtg character(len=*), intent(in) :: filename @@ -696,7 +703,7 @@ subroutine write_setupfile(filename,iprint,numstates,gamma,polyk,dtg) write(lu,"(a)") '# '//trim(tagline) write(lu,"(a)") '# input file for Phantom shock tube setup' - if (do_radiation) call write_options_units(lu,gr) + if (do_radiation .or. icooling > 0 .or. mhd_nonideal) call write_options_units(lu,gr) write(lu,"(/,a)") '# shock tube' do i=1,numstates @@ -763,8 +770,6 @@ end subroutine write_setupfile subroutine read_setupfile(filename,iprint,numstates,gamma,polyk,dtg,ierr) use infile_utils, only:open_db_from_file,inopts,close_db,read_inopt use setunits, only:read_options_and_set_units - use part, only:gr - use dim, only:do_radiation character(len=*), intent(in) :: filename integer, parameter :: lu = 21 integer, intent(in) :: iprint,numstates @@ -780,7 +785,7 @@ subroutine read_setupfile(filename,iprint,numstates,gamma,polyk,dtg,ierr) nerr = 0 ! units - if (do_radiation) call read_options_and_set_units(db,nerr,gr) + if (do_radiation .or. icooling > 0 .or. mhd_nonideal) call read_options_and_set_units(db,nerr,gr) do i=1,numstates call read_inopt(leftstate(i), trim(var_label(i))//'left',db,errcount=nerr) diff --git a/src/tests/test_cooling.f90 b/src/tests/test_cooling.f90 index 75733587f..78ac815dd 100644 --- a/src/tests/test_cooling.f90 +++ b/src/tests/test_cooling.f90 @@ -54,10 +54,14 @@ end subroutine test_cooling subroutine test_cooling_rate(ntests,npass) use cooling_ism, only:nrates,dphot0,init_cooling_ism,energ_cooling_ism,dphotflag,& abundsi,abundo,abunde,abundc,nabn + !use cooling, only:energ_cooling + use cooling_solver, only:excitation_HI,icool_method use chem, only:update_abundances,init_chem,get_dphot use part, only:nabundances,iHI use physcon, only:Rg,mass_proton_cgs use units, only:unit_ergg,unit_density,udist,utime + use options, only:icooling + use eos, only:gamma,gmw real :: abundance(nabundances) !real :: ratesq(nrates) integer, intent(inout) :: ntests,npass @@ -83,11 +87,17 @@ subroutine test_cooling_rate(ntests,npass) rhoi = 2.3e-24/unit_density h2ratio = 0. gmwvar=1.4/1.1 + gmw = gmwvar + gamma = 5./3. ndens = rhoi*unit_density/(gmwvar*mass_proton_cgs) print*,' rho = ',rhoi, ' ndens = ',ndens call init_chem() call init_cooling_ism() + icooling = 1 ! use cooling solver + excitation_HI = 1 ! H1 cooling + icool_method = 1 ! explicit + open(newunit=iunit,file='cooltable.txt',status='replace') write(iunit,"(a)") '# T \Lambda_E(T) erg s^{-1} cm^3 \Lambda erg s^{-1} cm^{-3}' dlogt = (logtmax - logtmin)/real(nt) @@ -100,6 +110,9 @@ subroutine test_cooling_rate(ntests,npass) dphot = get_dphot(dphotflag,dphot0,xi,yi,zi) call update_abundances(ui,rhoi,abundance,nabundances,dphot,dt,abundi,nabn,gmwvar,abundc,abunde,abundo,abundsi) call energ_cooling_ism(ui,rhoi,divv_cgs,gmwvar,abundi,dudti) + !print*,'t = ',t,' u = ',ui + !call energ_cooling(xi,yi,zi,ui,dudti,rhoi,0.) + !call cool_func(tempiso,ndens,dlq,divv_cgs,abund,crate,ratesq) ndens = (rhoi*unit_density/mass_proton_cgs)*5.d0/7.d0 crate = dudti*udist**2/utime**3*(rhoi*unit_density) From 98a4cd07989ba7a199327467a8102595f4783fbc Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 20 Dec 2023 11:29:11 +1100 Subject: [PATCH 245/814] (build) fix ifort issue with newer compiler version --- build/Makefile_defaults_ifort | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/build/Makefile_defaults_ifort b/build/Makefile_defaults_ifort index 62dfc5299..1fb1d19c3 100644 --- a/build/Makefile_defaults_ifort +++ b/build/Makefile_defaults_ifort @@ -15,8 +15,8 @@ KNOWN_SYSTEM=yes # for ifort version 18+ -openmp flag is obsolete IFORT_VERSION_MAJOR=${shell ifort -v 2>&1 | head -1 | cut -d' ' -f 3 | cut -d'.' -f 1} -ifeq ($(shell [ $(IFORT_VERSION_MAJOR) -gt 17 ] && echo true),true) - OMPFLAGS= -qopenmp +ifeq ($(shell [ $(IFORT_VERSION_MAJOR) -lt 17 ] && echo true),true) + OMPFLAGS= -openmp else - OMPFLAGS = -openmp + OMPFLAGS = -qopenmp endif From 65ea96fd27adc508e6f03db7e29c6b911d7c98b7 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 20 Dec 2023 13:03:27 +1100 Subject: [PATCH 246/814] (eos_stratified) test failure fixed due to use of Rg instead of kboltz/mh in temperature_coef --- src/main/eos.f90 | 2 +- src/tests/test_eos_stratified.f90 | 91 ++++++++++++++++++------------- 2 files changed, 55 insertions(+), 38 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 5e1df4084..fe006f8d5 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -252,7 +252,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam ! .. WARNING:: should not be used for misaligned discs ! call get_eos_stratified(istrat,xi,yi,zi,polyk,polyk2,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,ponrhoi,spsoundi) - tempi = temperature_coef*mui*ponrhoi + tempi = temperature_coef*mui*ponrhoi case(8) ! diff --git a/src/tests/test_eos_stratified.f90 b/src/tests/test_eos_stratified.f90 index 065ffef27..827540dc1 100644 --- a/src/tests/test_eos_stratified.f90 +++ b/src/tests/test_eos_stratified.f90 @@ -26,23 +26,16 @@ module testeos_stratified ! Parameters are found using the fits from Law et al. 2021 ! Disc order: HD 1632996, IM Lup, GM Aur, AS 209, MWC 480 ! - real, parameter :: qfacdiscs(n) = (/0.09,0.01,0.005,0.09,0.115/) - real, parameter :: qfacdisc2s(n) = (/0.305,-0.015,0.275,0.295,0.35/) real, parameter :: alpha_zs(n) = (/3.01,4.91,2.57,3.31,2.78/) real, parameter :: beta_zs(n) = (/0.42,2.07,0.54,0.02,-0.05/) real, parameter :: z0s(n) = (/1.30089579367134,2.1733078802249720E-004,1.0812929024334721, & 4.5600541967795483,8.8124778825591701/) - real, parameter :: polyks(n) = (/2./3.*3.222911812370378E-004,2./3.*1.6068568523984949E-004, & - 2./3.*1.2276291046706421E-004, 2./3.*3.3571998045524743E-004, & - 2./3.*4.5645812781352422E-004/) - real, parameter :: polyk2s(n) = (/4.0858881228052306E-003,1.2253168963394993E-004, & - 2.3614956983147709E-003,2.1885055156599335E-003, & - 6.7732173498498277E-003/) real, parameter :: temp_mid0s(n) = (/24,25,20,25,27/) real, parameter :: temp_atm0s(n) = (/63,36,48,37,69/) real, parameter :: z0_originals(n) = (/9,3,13,5,7/) real, parameter :: q_mids(n) = (/-0.18,-0.02,-0.01,-0.18,-0.23/) real, parameter :: q_atms(n) = (/-0.61,0.03,-0.55,-0.59,-0.7/) + real, parameter :: r_ref = 100. private @@ -72,7 +65,7 @@ end subroutine test_eos_stratified !---------------------------------------------------------------------------- subroutine test_stratified_midplane(ntests, npass) use eos, only:maxeos,equationofstate,eosinfo,init_eos,qfacdisc, & - qfacdisc2,z0,alpha_z,beta_z,polyk,polyk2,istrat + qfacdisc2,z0,alpha_z,beta_z,polyk,polyk2,istrat,gmw use units, only:unit_density use io, only:id,master,stdout integer, intent(inout) :: ntests,npass @@ -82,7 +75,6 @@ subroutine test_stratified_midplane(ntests, npass) temp_atm0,z0_original,q_atm,q_mid,spsoundi_ref real :: errmax - if (id==master) write(*,"(/,a)") '--> testing stratified disc equation of state' ieos = 7 @@ -108,7 +100,7 @@ subroutine test_stratified_midplane(ntests, npass) call eosinfo(ieos,stdout) do i=1,5 - call get_disc_params(i,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk,polyk2, & + call get_disc_params(i,gmw,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk,polyk2, & temp_mid0,temp_atm0,z0_original,q_mid,q_atm) rhoi = 1e-13/unit_density @@ -141,7 +133,7 @@ end subroutine test_stratified_midplane !---------------------------------------------------------------------------- subroutine test_stratified_temps(ntests, npass) use eos, only:maxeos,equationofstate,eosinfo,init_eos,qfacdisc, & - qfacdisc2,z0,alpha_z,beta_z,polyk,polyk2,istrat + qfacdisc2,z0,alpha_z,beta_z,polyk,polyk2,istrat,gmw use units, only:unit_density,set_units use physcon, only:au,solarm integer, intent(inout) :: ntests,npass @@ -173,8 +165,9 @@ subroutine test_stratified_temps(ntests, npass) errmax = 0. do i=1,n - call get_disc_params(i,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk,polyk2, & + call get_disc_params(i,gmw,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk,polyk2, & temp_mid0,temp_atm0,z0_original,q_mid,q_atm) + do j=1,nmax,nstep xi=j do k=1,nmax,nstep @@ -184,9 +177,9 @@ subroutine test_stratified_temps(ntests, npass) rhoi = 1e-13/unit_density call equationofstate(ieos,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi) ri = sqrt(xi**2 + yi**2) - zq = z0_original*(ri/100)**beta_z - temp_mid = temp_mid0*(ri/100)**q_mid - temp_atm = temp_atm0*(ri/100)**q_atm + zq = z0_original*(ri/r_ref)**beta_z + temp_mid = temp_mid0*(ri/r_ref)**q_mid + temp_atm = temp_atm0*(ri/r_ref)**q_atm temp_ref = (temp_mid**4 + 0.5*(1+tanh((abs(zi) - alpha_z*zq)/zq))*temp_atm**4)**(0.25) call checkvalbuf(tempi,temp_ref,1e-14,'ieos=7 temp matches temp from Law et al. 2021 equation',& nfailed(1),ncheck(1),errmax) @@ -206,7 +199,7 @@ end subroutine test_stratified_temps !---------------------------------------------------------------------------- subroutine test_stratified_temps_dartois(ntests, npass) use eos, only:maxeos,equationofstate,eosinfo,init_eos,qfacdisc, & - qfacdisc2,z0,beta_z,polyk,polyk2,istrat + qfacdisc2,z0,beta_z,polyk,polyk2,istrat,gmw use io, only:master,stdout use testutils, only:checkval,update_test_scores,checkvalbuf,checkvalbuf_end use units, only:unit_density,set_units @@ -214,8 +207,8 @@ subroutine test_stratified_temps_dartois(ntests, npass) integer, intent(inout) :: ntests,npass integer :: nfailed(2),ncheck(2) integer :: ierr,ieos,j,k,l - real :: rhoi,tempi,xi,yi,zi,ponrhoi,spsoundi,temp_ref,temp_mid0, & - temp_atm0,z0_original,q_atm,q_mid,ri,temp_atm,temp_mid,zq + real :: rhoi,tempi,xi,yi,zi,ponrhoi,spsoundi,temp_ref,temp_mid0 + real :: temp_atm0,z0_original,q_atm,q_mid,ri,temp_atm,temp_mid,zq real :: errmax integer, parameter :: nstep=20,nmax=1000 real, parameter :: pi = 4.*atan(1.0) @@ -235,18 +228,19 @@ subroutine test_stratified_temps_dartois(ntests, npass) call init_eos(ieos, ierr) - qfacdisc = 0.17 - qfacdisc2 = 0.48 + q_mid = -0.34 + q_atm = -0.96 + qfacdisc = -0.5*q_mid + qfacdisc2 = -0.5*q_atm beta_z = 0.07 z0 = 43.466157604499408 - polyk = 2./3. * 7.7436597566195883E-004 - !polyk = 5.162439837746392E-004 - polyk2 = 2.7824007780848647E-002 temp_mid0 = 27.6 temp_atm0 = 85.6 z0_original = 60 - q_mid = -0.34 - q_atm = -0.96 + + ! translate temperature into sound speed squared at r=1 + polyk = get_polyk_from_T(temp_mid0,gmw,r_ref,q_mid) + polyk2 = get_polyk_from_T(temp_atm0,gmw,r_ref,q_atm) rhoi = 1e-13/unit_density @@ -259,9 +253,9 @@ subroutine test_stratified_temps_dartois(ntests, npass) istrat = 1 call equationofstate(ieos,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi) ri = sqrt(xi**2 + yi**2) - zq = z0_original*(ri/100)**beta_z - temp_mid = temp_mid0*(ri/100)**q_mid - temp_atm = temp_atm0*(ri/100)**q_atm + zq = z0_original*(ri/r_ref)**beta_z + temp_mid = temp_mid0*(ri/r_ref)**q_mid + temp_atm = temp_atm0*(ri/r_ref)**q_atm if (zi < zq) then temp_ref = temp_atm + (temp_mid - temp_atm)*(cos((pi/2)*(zi/zq)))**2 else @@ -287,7 +281,7 @@ end subroutine test_stratified_temps_dartois !---------------------------------------------------------------------------- subroutine map_stratified_temps(ntests, npass) use eos, only:maxeos,equationofstate,eosinfo,init_eos,qfacdisc, & - qfacdisc2,z0,alpha_z,beta_z,polyk,polyk2 + qfacdisc2,z0,alpha_z,beta_z,polyk,polyk2,gmw use units, only:unit_density use io, only:id,master,stdout integer, intent(inout) :: ntests,npass @@ -309,8 +303,9 @@ subroutine map_stratified_temps(ntests, npass) open(5, file='MWC480_temps.txt', status = 'replace') do i=1,n - call get_disc_params(i,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk,polyk2, & + call get_disc_params(i,gmw,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk,polyk2, & temp_mid0,temp_atm0,z0_original,q_mid,q_atm) + rhoi = 1e-13/unit_density do j=0,210 zi=j @@ -334,29 +329,51 @@ subroutine map_stratified_temps(ntests, npass) end subroutine map_stratified_temps +!---------------------------------------------------------------------------- +!+ +! function to translate temperature into sound speed at r=1 +!+ +!---------------------------------------------------------------------------- +real function get_polyk_from_T(temp,gmw,rref,qfac) result(polyk) + use physcon, only:Rg + use units, only:unit_velocity + real, intent(in) :: temp,gmw,rref,qfac + real :: cs2 + + ! translate temperature into sound speed at r_ref + cs2 = temp*Rg/gmw/unit_velocity**2 + + ! polyk is sound speed squared at r=1 + polyk = cs2 * (1./rref)**qfac + +end function get_polyk_from_T + !---------------------------------------------------------------------------- !+ ! extract parameters for a particular disc from the list of presets !+ !---------------------------------------------------------------------------- -subroutine get_disc_params(ndisc,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk, & - polyk2,temp_mid0,temp_atm0,z0_original,q_mid,q_atm) +subroutine get_disc_params(ndisc,gmw,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk,polyk2,& + temp_mid0,temp_atm0,z0_original,q_mid,q_atm) integer, intent(in) :: ndisc + real, intent(in) :: gmw real, intent(out) :: qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk,polyk2, & temp_mid0,temp_atm0,z0_original,q_mid,q_atm - qfacdisc = qfacdiscs(ndisc) - qfacdisc2 = qfacdisc2s(ndisc) alpha_z = alpha_zs(ndisc) beta_z = beta_zs(ndisc) z0 = z0s(ndisc) - polyk = polyks(ndisc) - polyk2 = polyk2s(ndisc) temp_mid0 = temp_mid0s(ndisc) temp_atm0 = temp_atm0s(ndisc) z0_original = z0_originals(ndisc) q_mid = q_mids(ndisc) q_atm = q_atms(ndisc) + qfacdisc = -0.5*q_mid + qfacdisc2 = -0.5*q_atm + + ! translate temperature into sound speed squared at r=1 + polyk = get_polyk_from_T(temp_mid0,gmw,r_ref,q_mid) + polyk2 = get_polyk_from_T(temp_atm0,gmw,r_ref,q_atm) end subroutine get_disc_params From da822c2b541b8796b46a95c23c34f288846121a3 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 20 Dec 2023 14:04:48 +1100 Subject: [PATCH 247/814] (nimhd) adjust values of non-ideal mhd coefficients in test suite due to use of Rg instead of kb/mh in computing temperature --- src/tests/test_nonidealmhd.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/tests/test_nonidealmhd.F90 b/src/tests/test_nonidealmhd.F90 index a69b01169..451bacdd6 100644 --- a/src/tests/test_nonidealmhd.F90 +++ b/src/tests/test_nonidealmhd.F90 @@ -62,7 +62,7 @@ subroutine test_nonidealmhd(ntests,npass,string) testshock = .false. testeta = .false. testall = .false. - select case(string) + select case(trim(string)) case('nimhddamp','wavedamp') testdamp = .true. case('nimhdshock') @@ -572,14 +572,14 @@ subroutine test_etaval(ntests,npass) call set_units(mass=solarm,dist=1.0d16,G=1.d0) rho0(1) = 7.420d-18 /unit_density ! [g/cm^3] Bz0(1) = 8.130d-5 /unit_Bfield ! [G] - eta_act(1,1) = 9.5267772328d10 ! [cm^2/s] expected eta_ohm - eta_act(2,1) = -1.1642052571d17 ! [cm^2/s] expected eta_hall - eta_act(3,1) = 3.2301843483d18 ! [cm^2/s] expected eta_ambi + eta_act(1,1) = 9.5262674506e10 ! [cm^2/s] expected eta_ohm + eta_act(2,1) = -1.17385344587d17 ! [cm^2/s] expected eta_hall + eta_act(3,1) = 3.24221785540d18 ! [cm^2/s] expected eta_ambi rho0(2) = 4.6d-3 /unit_density ! [g/cm^3] Bz0(2) = 1.92d2 /unit_Bfield ! [G] - eta_act(1,2) = 1.9073987505d9 ! [cm^2/s] expected eta_ohm - eta_act(2,2) = 2.3797926640d5 ! [cm^2/s] expected eta_hall - eta_act(3,2) = 1.1443044356d-2 ! [cm^2/s] expected eta_ambi + eta_act(1,2) = 2.051448843995e9 ! [cm^2/s] expected eta_ohm + eta_act(2,2) = 1.369211024952e6 ! [cm^2/s] expected eta_hall + eta_act(3,2) = 1.2374308216e-2 ! [cm^2/s] expected eta_ambi ! ! initialise values for grid ! From b9042714925cdc67f8c7770f17170d65a0489974 Mon Sep 17 00:00:00 2001 From: fhu Date: Thu, 11 Jan 2024 10:58:24 +1100 Subject: [PATCH 248/814] (inject_sim) save particles injected for restarting --- src/main/inject_sim.f90 | 66 ++++++++++++++++++++++++++++++++++++----- 1 file changed, 59 insertions(+), 7 deletions(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index bf33f0e89..4a21fbd91 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -26,8 +26,8 @@ module inject character(len=*), parameter, public :: inject_type = 'sim' public :: init_inject,inject_particles,write_options_inject,read_options_inject, & - set_default_options_inject - private + set_default_options_inject,update_injected_par + private :: read_injected_par ! !--runtime settings for this module ! @@ -41,6 +41,7 @@ module inject logical, allocatable :: injected(:) character(len=*), parameter :: label = 'inject_tdeoutflow' + character(len=*), parameter :: injected_filename = 'injected_par' contains @@ -85,6 +86,7 @@ subroutine init_inject(ierr) allocate(xyzh_pre(4,npart_sim),xyzh_next(4,npart_sim),vxyzu_next(4,npart_sim),pxyzu_next(4,npart_sim),injected(npart_sim)) xyzh_pre = 0. injected = .false. + call read_injected_par() !e_inject = -1./r_inject end subroutine init_inject @@ -122,14 +124,14 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& call find_next_dump(next_dump,next_time,ierr) start_dump = next_dump - write(*,'(i5,1x,a27,1x,a)') npart-npart_old, 'particles are injected from', trim(pre_dump) + write(*,'(i10,1x,a27,1x,a)') npart-npart_old, 'particles are injected from', trim(pre_dump) if (pre_dump == final_dump) then write(*,'(a)') ' Reach the final dumpfile. Stop injecting ...' next_time = huge(0.) endif - tfac = 1.d-10 ! set a tiny timestep so the code has time to adjust for timestep + tfac = 1.d-40 ! set a tiny timestep so the code has time to adjust for timestep endif ! update time to next inject @@ -249,7 +251,55 @@ subroutine inject_required_part_tde(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_n enddo end subroutine inject_required_part_tde - + + subroutine read_injected_par() + use io, only:fatal,warning + integer, parameter :: iunit=242 + logical :: iexist + integer :: nread,i + + inquire(file=trim(injected_filename),exist=iexist) + + if (iexist) then + open(iunit,file=trim(injected_filename),status='old') + read(iunit,*) nread + + ! check if npart in file is the same as npart_sim + if (nread /= npart_sim) call fatal('inject_sim','npart in '//trim(injected_filename)// & + ' does not match npart_sim') + + do i=1,nread + read(iunit,*) injected(i) + enddo + close(iunit) + else + call warning('inject_sim',trim(injected_filename)//' not found, assume no particles are injected') + injected = .false. + endif + + end subroutine + + subroutine update_injected_par() + use io, only:error + integer, parameter :: iunit=284 + logical :: iexist + integer :: i + + if (allocated(injected)) then + inquire(file=trim(injected_filename),exist=iexist) + if (iexist) then + open(iunit,file=trim(injected_filename),status='replace') + else + open(iunit,file=trim(injected_filename),status='new') + endif + + write(iunit,*) npart_sim + do i=1,npart_sim + write(iunit,*) injected(i) + enddo + close(iunit) + endif + end subroutine !----------------------------------------------------------------------- !+ @@ -271,9 +321,11 @@ subroutine write_options_inject(iunit) endif write(iunit,"(/,a)") '# options controlling particle injection' - call write_inopt(trim(start_dump),'start_dump','dumpfile to start for injection',iunit) + call write_inopt("'"//trim(start_dump)//"'",'start_dump','dumpfile to start for injection & + (with relative path if in other direc)',iunit) call write_inopt(r_inject_cgs,'r_inject','radius to inject tde outflow (in cm)',iunit) - call write_inopt(trim(final_dump),'final_dump','stop injection after this dump',iunit) + call write_inopt("'"//trim(final_dump)//"'",'final_dump','stop injection after this dump & + (with relative path if in other direc)',iunit) end subroutine write_options_inject From 83d29e9ed0c2c980c60174ecd0e54a916e3a3cdd Mon Sep 17 00:00:00 2001 From: fhu Date: Thu, 11 Jan 2024 11:27:35 +1100 Subject: [PATCH 249/814] (readwrite_infile) update injected particles stored when writing full dumps --- src/main/readwrite_infile.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 79f98765a..02e9f0f03 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -106,7 +106,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) use dust, only:write_options_dust use growth, only:write_options_growth #ifdef INJECT_PARTICLES - use inject, only:write_options_inject + use inject, only:write_options_inject,inject_type,update_injected_par #endif use dust_formation, only:write_options_dust_formation use nicil_sup, only:write_options_nicil @@ -265,6 +265,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) write(iwritein,"(/,a)") '# options for injecting/removing particles' #ifdef INJECT_PARTICLES call write_options_inject(iwritein) + if (inject_type=='sim') call update_injected_par() #endif call write_inopt(rkill,'rkill','deactivate particles outside this radius (<0 is off)',iwritein) From e3495cfa6a906867f7530deae1942da7718bc670 Mon Sep 17 00:00:00 2001 From: fhu Date: Thu, 11 Jan 2024 11:28:54 +1100 Subject: [PATCH 250/814] (analysis_radiotde) calculated shock mass from energy and velocity --- src/utils/analysis_radiotde.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index ca682ec80..939f5b371 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -391,9 +391,9 @@ subroutine shock_analysis(npart,pmass,rad_all,vr_all,ent) write(*,'(a14,1x,es8.1,1x,a5,1x,es8.1,1x,a2)') ' Shock is from', rad_min*udist/au, 'au to', rad_max*udist/au, 'au' - shock_m = pmass*n - shock_m_cnm = pmass*n_cnm - shock_m_tde = pmass*n_tde + shock_m = shock_e*2./shock_v**2 !pmass*n + shock_m_cnm = shock_e_cnm*2./shock_v_cnm**2 !pmass*n_cnm + shock_m_tde = shock_e_tde*2./shock_v_tde**2 !pmass*n_tde !shock_rho = shock_m*4./3.*pi*(rad_max**3-rad_min**3) end subroutine shock_analysis @@ -465,7 +465,7 @@ subroutine read_tdeparams(filename,ierr) call read_inopt(phi_min,'phi_min',db,min=-90.,max=90.,errcount=nerr) call read_inopt(phi_max,'phi_max',db,min=-90.,max=90.,errcount=nerr) case ('shock') - call read_inopt(npart_tde_reserve,'npart_tde',db,min=0,errcount=nerr) + call read_inopt(npart_tde_reserve,'npart_tde',db,errcount=nerr) case default end select From 2905f95a5b40a46f50b916a41f28115f37d91cba Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:09:32 +1100 Subject: [PATCH 251/814] (inject_BHL) placeholder function --- src/main/inject_BHL.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/inject_BHL.f90 b/src/main/inject_BHL.f90 index 0f55107bc..55513b912 100644 --- a/src/main/inject_BHL.f90 +++ b/src/main/inject_BHL.f90 @@ -30,7 +30,7 @@ module inject character(len=*), parameter, public :: inject_type = 'BHL' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par ! !--runtime settings for this module ! @@ -261,6 +261,11 @@ subroutine inject_or_update_particles(ifirst, n, position, velocity, h, u, bound end subroutine inject_or_update_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file From 3625dbb43a181426c3226e270c4f56ce2d7c6dd1 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:10:03 +1100 Subject: [PATCH 252/814] (inject_asteroidwind) placeholder function --- src/main/inject_asteroidwind.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/inject_asteroidwind.f90 b/src/main/inject_asteroidwind.f90 index 758784144..078bc57b3 100644 --- a/src/main/inject_asteroidwind.f90 +++ b/src/main/inject_asteroidwind.f90 @@ -29,7 +29,7 @@ module inject real, public :: mdot = 5.e8 ! mass injection rate in grams/second public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par private @@ -149,6 +149,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Returns dndt(t) depending on which function is chosen From 1a4828cd9d5310752e36ab39eaef70b60792321a Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:10:43 +1100 Subject: [PATCH 253/814] (inject_bondi) placeholder function --- src/main/inject_bondi.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/inject_bondi.f90 b/src/main/inject_bondi.f90 index 2272daf80..4b767d03f 100644 --- a/src/main/inject_bondi.f90 +++ b/src/main/inject_bondi.f90 @@ -31,7 +31,8 @@ module inject inject_particles, & write_options_inject, & read_options_inject, & - set_default_options_inject + set_default_options_inject, & + update_injected_par !-- Runtime variables read from input file real, public :: rin = 18.1 @@ -215,6 +216,10 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npar end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine !----------------------------------------------------------------------- !+ From 5082b5979aeaebb0da197613744a6a611bb545dc Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:11:10 +1100 Subject: [PATCH 254/814] (inject_firehose) placeholder function --- src/main/inject_firehose.f90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/main/inject_firehose.f90 b/src/main/inject_firehose.f90 index c1246d526..de33f11e3 100644 --- a/src/main/inject_firehose.f90 +++ b/src/main/inject_firehose.f90 @@ -26,7 +26,7 @@ module inject character(len=*), parameter, public :: inject_type = 'firehose' public :: inject_particles, write_options_inject, read_options_inject - public :: init_inject, set_default_options_inject + public :: init_inject, set_default_options_inject, update_injected_par real, private :: Mdot = 0. real, private :: Mdotcode = 0. @@ -210,6 +210,10 @@ end function Mdotfunc end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine !----------------------------------------------------------------------- !+ From 0b3b879c1534bc6bcfef3445aaf6d2204f492f21 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:11:46 +1100 Subject: [PATCH 255/814] (inject_galcen_wind) placeholder function --- src/main/inject_galcen_winds.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/inject_galcen_winds.f90 b/src/main/inject_galcen_winds.f90 index ea366c5cf..d02060eec 100644 --- a/src/main/inject_galcen_winds.f90 +++ b/src/main/inject_galcen_winds.f90 @@ -26,7 +26,7 @@ module inject character(len=*), parameter, public :: inject_type = 'galcen_winds' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par real :: outer_boundary = 20. character(len=120) :: datafile = 'winddata.txt' @@ -223,6 +223,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file. From fbe8014b0e78f4ac28902a89e869a67eba3d2ca9 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:12:18 +1100 Subject: [PATCH 256/814] (inject__keplerianshear) placeholder function --- src/main/inject_keplerianshear.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/inject_keplerianshear.f90 b/src/main/inject_keplerianshear.f90 index 43c728e2c..54ccc7fbc 100644 --- a/src/main/inject_keplerianshear.f90 +++ b/src/main/inject_keplerianshear.f90 @@ -50,7 +50,7 @@ module inject character(len=*), parameter, public :: inject_type = 'keplerianshear' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par public :: set_injection_parameters type injectparams @@ -186,6 +186,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file From 11496d7202c519bdebfa7831bf740b5cf157db02 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:12:48 +1100 Subject: [PATCH 257/814] (inject_rochelobe) placeholder function --- src/main/inject_rochelobe.f90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/main/inject_rochelobe.f90 b/src/main/inject_rochelobe.f90 index 55079d0bc..53aa7c5c3 100644 --- a/src/main/inject_rochelobe.f90 +++ b/src/main/inject_rochelobe.f90 @@ -25,7 +25,7 @@ module inject character(len=*), parameter, public :: inject_type = 'rochelobe' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par real, private :: Mdot = 1.0e-9 real, private :: Mdotcode = 0. @@ -278,6 +278,10 @@ subroutine phi_derivs(phinns,phizzs,xyzL1,xx1,xx2,theta_s,m1,m2,mu,r12,Porb) end subroutine phi_derivs +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine !----------------------------------------------------------------------- !+ From 4c193a9c312afcb3c41aa8f0c560dffa49f08e3e Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:13:11 +1100 Subject: [PATCH 258/814] (inject_sne) placeholder function --- src/main/inject_sne.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/inject_sne.f90 b/src/main/inject_sne.f90 index e0f95d8fb..01377cf14 100644 --- a/src/main/inject_sne.f90 +++ b/src/main/inject_sne.f90 @@ -20,7 +20,7 @@ module inject character(len=*), parameter, public :: inject_type = 'supernovae' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par integer, parameter :: maxsn = 30 real, parameter :: xyz_sn(3,maxsn) = & @@ -135,6 +135,11 @@ subroutine inject_particles(time,dtlast_u,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file From 1423e65f557170dd41529503874c158fb6527a05 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:13:35 +1100 Subject: [PATCH 259/814] (inject_steadydisc) placeholder function --- src/main/inject_steadydisc.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/inject_steadydisc.f90 b/src/main/inject_steadydisc.f90 index 254e3b57a..9b1d10465 100644 --- a/src/main/inject_steadydisc.f90 +++ b/src/main/inject_steadydisc.f90 @@ -26,7 +26,7 @@ module inject character(len=*), parameter, public :: inject_type = 'steadydisc' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par real, private :: R_ref,sig_ref real, private :: p_index,q_index,HoverR,M_star @@ -203,6 +203,11 @@ subroutine inject_particles_in_annulus(r1,r2,ninject,injected,list) end subroutine inject_particles_in_annulus +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file From 5c02b274a1185695c0aecde0678a0640986d645e Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:14:00 +1100 Subject: [PATCH 260/814] (inject_unifwind) placeholder function --- src/main/inject_unifwind.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/inject_unifwind.f90 b/src/main/inject_unifwind.f90 index 275fb3b75..6bc4d6df2 100644 --- a/src/main/inject_unifwind.f90 +++ b/src/main/inject_unifwind.f90 @@ -23,7 +23,7 @@ module inject character(len=*), parameter, public :: inject_type = 'unifwind' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par real, public :: wind_density = 7.2d-16 real, public :: wind_velocity = 29. @@ -125,6 +125,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file From 2dba8fa3b4f6ed6f903c7860e253834e7f7d95a4 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:14:27 +1100 Subject: [PATCH 261/814] (inject_wind) placeholder function --- src/main/inject_wind.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index 0d40723cc..591c850ab 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.f90 @@ -34,7 +34,7 @@ module inject character(len=*), parameter, public :: inject_type = 'wind' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - wind_injection_radius,set_default_options_inject + wind_injection_radius,set_default_options_inject,update_injected_par private ! !--runtime settings for this module @@ -482,6 +482,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Oscillating inner boundary From 2526a062de457db9c4d4389e44994ae14e49d626 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 14:14:47 +1100 Subject: [PATCH 262/814] (inject_windtunnel) placeholder function --- src/main/inject_windtunnel.f90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 5888f288e..ededc88cb 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -32,7 +32,7 @@ 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,update_injected_par ! !--runtime settings for this module ! @@ -255,6 +255,10 @@ subroutine inject_or_update_particles(ifirst, n, position, velocity, h, u, bound end subroutine inject_or_update_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine !----------------------------------------------------------------------- !+ From 9f3009fa2c0e91792a5418421edecbd06e44a040 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 12 Jan 2024 15:45:53 +1100 Subject: [PATCH 263/814] (inject_sim) fix warning --- src/main/inject_sim.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index 4a21fbd91..a98d261f3 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -321,11 +321,11 @@ subroutine write_options_inject(iunit) endif write(iunit,"(/,a)") '# options controlling particle injection' - call write_inopt("'"//trim(start_dump)//"'",'start_dump','dumpfile to start for injection & - (with relative path if in other direc)',iunit) + call write_inopt("'"//trim(start_dump)//"'",'start_dump', & + 'dumpfile to start for injection (with relative path if in other direc)',iunit) call write_inopt(r_inject_cgs,'r_inject','radius to inject tde outflow (in cm)',iunit) - call write_inopt("'"//trim(final_dump)//"'",'final_dump','stop injection after this dump & - (with relative path if in other direc)',iunit) + call write_inopt("'"//trim(final_dump)//"'",'final_dump', & + 'stop injection after this dump (with relative path if in other direc)',iunit) end subroutine write_options_inject From 5921eee4cc69f618ab048f810f33e0df9ec0d899 Mon Sep 17 00:00:00 2001 From: fhu Date: Mon, 15 Jan 2024 13:18:37 +1100 Subject: [PATCH 264/814] (inject_sim) try to solve Floating-point exception --- src/main/inject_sim.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index a98d261f3..1fa74d744 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -314,7 +314,7 @@ subroutine write_options_inject(iunit) real, parameter :: r_inject_default = 5.e14 ! write something meaningful in infile - if (r_inject_cgs < tiny(0.)) then + if (r_inject_cgs .le. 0.) then start_dump = start_dump_default r_inject_cgs = r_inject_default final_dump = final_dump_default From d6af633ca06ad14d50bfaa4b9acbd3229eb5c528 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 18 Jan 2024 14:18:09 +0100 Subject: [PATCH 265/814] (CE-analysis) add comments to potential energy calculation in calculate_energies --- src/utils/analysis_common_envelope.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 6cd1c6c27..aba02cdbe 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -793,7 +793,7 @@ subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) real :: rhopart,ponrhoi,spsoundi,tempi,r_ij,radvel real, dimension(3) :: rcrossmv character(len=17), allocatable :: columns(:) - integer :: i, j, ncols + integer :: i,j,ncols logical :: inearsink integer, parameter :: ie_tot = 1 integer, parameter :: ie_pot = ie_tot + 1 @@ -826,9 +826,9 @@ subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) ' pot energy',& ' kin energy',& 'therm energy',& - ' sink pot',& + ' sink pot',& ! does not include sink-gas potential energy ' sink kin',& - ' sink orb',& + ' sink orb',& ! sink kin + sink pot ' comp orb',& ' env pot',& ' env energy',& @@ -914,7 +914,7 @@ subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) do j=i+1,nptmass if (xyzmh_ptmass(4,j) > 0.) then r_ij = separation(xyzmh_ptmass(1:3,i),xyzmh_ptmass(1:3,j)) - encomp(ipot_sink) = encomp(ipot_sink) - xyzmh_ptmass(4,i) * xyzmh_ptmass(4,j) / r_ij + encomp(ipot_sink) = encomp(ipot_sink) - xyzmh_ptmass(4,i) * xyzmh_ptmass(4,j) / r_ij ! Newtonian expression is fine as long as rij > hsofti + hsoftj if (i==1 .and. j==2) encomp(iorb_comp) = encomp(iorb_comp) - xyzmh_ptmass(4,i) * xyzmh_ptmass(4,j) / r_ij endif enddo From aa546cda0c6f32ec8e318a5c49368312cfd398f5 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 18 Jan 2024 14:18:46 +0100 Subject: [PATCH 266/814] (CE-analysis) add sound speed to energy_profile --- src/utils/analysis_common_envelope.f90 | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index aba02cdbe..629645cb2 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -2064,11 +2064,12 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) if (dump_number==0) then iquantity = 1 use_mass_coord = .false. - print "(4(/,a))",'1. Energy',& + print "(5(/,a))",'1. Energy',& '2. Entropy',& '3. Bernoulli energy',& - '4. Ion fractions' - call prompt("Select quantity to calculate",iquantity,1,4) + '4. Ion fractions',& + '5. Sound speed' + call prompt("Select quantity to calculate",iquantity,1,5) call prompt("Bin in mass coordinates instead of radius?",use_mass_coord) endif @@ -2087,7 +2088,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) call compute_energies(time) ! Allocate arrays for single variable outputs - if ( (iquantity==1) .or. (iquantity==2) .or. (iquantity==3) ) then + if (iquantity==1 .or. iquantity==2 .or. iquantity==3 .or. iquantity==5) then nvars = 1 else nvars = 5 @@ -2127,6 +2128,9 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) ' # HeI', & ' # HeII', & ' # HeIII' /) + case(5) ! Sound speed + filename = ' grid_cs.ev' + headerline = '# cs profile ' end select allocate(iorder(npart)) @@ -2174,6 +2178,8 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) quant(i,3) = xhe0 quant(i,4) = xhe1 quant(i,5) = xhe2 + case(5) ! Sound speed + quant(i,1) = spsoundi end select enddo From b23ef5acabf9862868af52777abfb1de0f58a881 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 29 Jan 2024 17:17:05 +1100 Subject: [PATCH 267/814] (checksetup) force code units to au, solar masses and G=1 if self-gravity is used with no units set --- docs/running-first-calculation.rst | 6 +++--- src/main/checksetup.F90 | 14 +++++++++++--- 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/docs/running-first-calculation.rst b/docs/running-first-calculation.rst index 3a0b1bb3d..ec715719e 100644 --- a/docs/running-first-calculation.rst +++ b/docs/running-first-calculation.rst @@ -110,8 +110,8 @@ The basic physics that is controllable at runtime (any physics that affects memo # options controlling hydrodynamics, artificial dissipation ieos = 2 ! eqn of state (1=isoth; 2=adiab; 3/4=locally iso (sphere/cyl); 5=two phase) - alpha = 1.0000 ! MINIMUM art. viscosity parameter (max = 1.0) - alphau = 1.0000 ! art. conductivity parameter + alpha = 0.0000 ! MINIMUM shock viscosity parameter (max = 1.0) + alphau = 1.0000 ! shock conductivity parameter beta = 2.0000 ! beta viscosity avdecayconst = 0.1000 ! decay time constant for viscosity switches damp = 0.0000 ! artificial damping of velocities (if on, v=0 initially) @@ -168,6 +168,6 @@ The .ev files can be visualised using any standard plotting tool. For example yo splash -e blast*.ev -where column labels should be read automatically from the header of the .ev file +where column labels should be read automatically from the header of the .ev file. For more detailed analysis of :doc:`Phantom dump files `, write yourself an analysis module for the :doc:`phantomanalysis ` utility. Analysis modules exist for many common tasks, including interpolating to a 3D grid (both fixed and AMR), computing PDFs, structure functions and power spectra, getting disc surface density profiles, and converting to other formats. diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index 0200e4b53..79ce79cf1 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.F90 @@ -50,18 +50,19 @@ subroutine check_setup(nerror,nwarn,restart) use io, only:id,master use externalforces, only:accrete_particles,update_externalforce,accradius1,iext_star,iext_corotate use timestep, only:time - use units, only:G_is_unity,get_G_code + use units, only:G_is_unity,get_G_code,set_units use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax use boundary_dyn, only:dynamic_bdy,adjust_particles_dynamic_boundary use nicil, only:n_nden use metric_tools, only:imetric,imet_minkowski + use physcon, only:au,solarm integer, intent(out) :: nerror,nwarn logical, intent(in), optional :: restart integer :: i,nbad,itype,iu,ndead integer :: ncount(maxtypes) real :: xcom(ndim),vcom(ndim) real :: hi,hmin,hmax - logical :: accreted,dorestart + logical :: accreted,dorestart,fix_units character(len=3) :: string ! !--check that setup is sensible @@ -336,7 +337,14 @@ subroutine check_setup(nerror,nwarn,restart) elseif (nptmass > 0) then if (id==master) print*,'ERROR: sink particles used but G /= 1 in code units, got G=',get_G_code() endif - nerror = nerror + 1 + fix_units = .true. + if (fix_units) then + print*,' WARNING: forcing code units to au, Msun and G=1' + call set_units(dist=au,mass=solarm,G=1.d0) + nwarn = nwarn + 1 + else + nerror = nerror + 1 + endif endif endif if (.not. gr .and. (gravity .or. mhd) .and. ien_type == ien_etotal) then From 5e9abd4781dd9a2e715665dbabbb6e45db7738cf Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 29 Jan 2024 17:17:33 +1100 Subject: [PATCH 268/814] release notes for v2024 --- docs/releasenotes.rst | 44 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/docs/releasenotes.rst b/docs/releasenotes.rst index af41725c2..7134857c6 100644 --- a/docs/releasenotes.rst +++ b/docs/releasenotes.rst @@ -1,6 +1,50 @@ Release notes ============= +v2024.0.0 - 29th Jan 2024 +------------------------- + +Physics +~~~~~~~ +- ability to use numerical relativity backend with phantom (Magnall et al. 2023; #480) +- further improvements to implicit radiation scheme (thanks to Mike Lau and Ryosuke Hirai; #406,#438,#441,#452,#455,#458,#474) +- further improvements to wind injection and cooling modules (thanks to Lionel Siess, Mats Esseldeurs, Silke Maes and Jolien Malfait; #392,) +- J2 potential due to oblateness implemented for sink particles (#289) +- external potential implemented for geopotential model, to test J2 potential (#289) +- implemented Loren/Bate implicit scheme for 2-fluid drag (thanks to Stephane Michoulier, #428,#436) +- dynamic boundary conditions, allowing box with expanding boundaries (thanks to James Wurster; #416) +- bug fix in generalised Farris equation of state (thanks to Nicolas Cuello; #433) + +Setup +~~~~~ +- major reorganisation of star setup into separate module, can now setup and relax one or more stars in several different setups, allowing one-shot-setup-and-relax for common envelopes, binary stars and tidal disruption events (#405,#407,#413) +- new hierarchical system setup: can now setup an arbitrary number of point masses or stars in hierarchical systems (thanks to Simone Ceppi; #401,#426) +- relaxation process for stars is restartable, works automatically (#414, #417) +- can setup unbound parabolic and hyperbolic orbits using the standard 6-parameter orbital elements (#443,#448; #302) +- use m1 and m2 in the binary disc setup instead of primary mass and mass ratio (#431) +- new "wind tunnel" setup and injection module (thanks to Mike Lau; #470) +- new "solar system" setup for placing solar system planets and minor bodies by downloading their published orbital elements (#430) +- bugs fixed with asteroid wind setup (#463) +- bug fix with units in GR tidal disruption event setup (#432) +- bug fix with initial velocities in disc setup with self-gravity and dust, properly compute enclosed mass for both gas and dust (thanks to Cristiano Longarini; #427) +- bug fix with turbulent stirring setup (thanks to Terry Tricco; #449) + +Analysis/moddump utilities +~~~~~~~~~~~~~~~~~~~~~~~~~~ +- cleanup and further enhancements to common envelope analysis routines (thanks to Miguel Gonzalez-Bolivar; #467,#462) +- moddump_sink displays correct value of sink luminosity (#439) +- analysis routine for radio emission from tidal disruption events (thanks to Fitz Hu; #472) +- new analysis routine to compute time of dust formation (`Bermudez-Bustamante et al. 2023 <>`__) + +Other +~~~~~ +- github actions workflow now checks that running phantom on the .in file for one timestep succeeds following setup procedure +- github actions workflow checks compilation of phantom+mcfost +- phantom is now enforced to compile without any compiler warnings with gfortran on the master branch +- further work to reduce ugly ifdefs in phantom codebase (#55) +- various bugs with uninitialised variables fixed; all setups now checked with DEBUG=yes + + v2023.0.0 - 10th Mar 2023 ------------------------- From 2258b3d43b3bd10e6e3614807106e00931c4aaed Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 29 Jan 2024 20:32:30 +1100 Subject: [PATCH 269/814] [header-bot] updated file headers --- src/main/bondiexact.f90 | 2 +- src/main/bondiexact_gr.f90 | 2 +- src/main/boundary.f90 | 2 +- src/main/boundary_dynamic.f90 | 2 +- src/main/centreofmass.f90 | 2 +- src/main/checkconserved.f90 | 2 +- src/main/checkoptions.F90 | 2 +- src/main/checksetup.F90 | 2 +- src/main/config.F90 | 2 +- src/main/cons2prim.f90 | 2 +- src/main/cons2primsolver.f90 | 2 +- src/main/cooling.f90 | 2 +- src/main/cooling_functions.f90 | 2 +- src/main/cooling_gammie.f90 | 2 +- src/main/cooling_gammie_PL.f90 | 2 +- src/main/cooling_ism.f90 | 2 +- src/main/cooling_koyamainutsuka.f90 | 2 +- src/main/cooling_molecular.f90 | 2 +- src/main/cooling_solver.f90 | 2 +- src/main/cullendehnen.f90 | 2 +- src/main/damping.f90 | 2 +- src/main/datafiles.f90 | 2 +- src/main/dens.F90 | 2 +- src/main/deriv.F90 | 2 +- src/main/dtype_kdtree.F90 | 2 +- src/main/dust.f90 | 2 +- src/main/dust_formation.f90 | 2 +- src/main/energies.F90 | 2 +- src/main/eos.f90 | 2 +- src/main/eos_barotropic.f90 | 2 +- src/main/eos_gasradrec.f90 | 2 +- src/main/eos_helmholtz.f90 | 2 +- src/main/eos_idealplusrad.f90 | 2 +- src/main/eos_mesa.f90 | 2 +- src/main/eos_mesa_microphysics.f90 | 2 +- src/main/eos_piecewise.f90 | 2 +- src/main/eos_shen.f90 | 2 +- src/main/eos_stratified.f90 | 2 +- src/main/evolve.F90 | 2 +- src/main/evwrite.f90 | 2 +- src/main/extern_Bfield.f90 | 2 +- src/main/extern_binary.f90 | 2 +- src/main/extern_binary_gw.f90 | 2 +- src/main/extern_corotate.f90 | 2 +- src/main/extern_densprofile.f90 | 2 +- src/main/extern_geopot.f90 | 2 +- src/main/extern_gnewton.f90 | 2 +- src/main/extern_gr.F90 | 2 +- src/main/extern_gwinspiral.f90 | 2 +- src/main/extern_lensethirring.f90 | 2 +- src/main/extern_prdrag.f90 | 2 +- src/main/extern_spiral.f90 | 2 +- src/main/extern_staticsine.f90 | 2 +- src/main/externalforces.f90 | 2 +- src/main/externalforces_gr.f90 | 2 +- src/main/fastmath.f90 | 2 +- src/main/force.F90 | 2 +- src/main/forcing.F90 | 2 +- src/main/fs_data.f90 | 2 +- src/main/geometry.f90 | 2 +- src/main/gitinfo.f90 | 2 +- src/main/growth.F90 | 2 +- src/main/growth_smol.f90 | 2 +- src/main/h2chem.f90 | 2 +- src/main/initial.F90 | 2 +- src/main/inject_BHL.f90 | 2 +- src/main/inject_asteroidwind.f90 | 2 +- src/main/inject_bondi.f90 | 2 +- src/main/inject_firehose.f90 | 2 +- src/main/inject_galcen_winds.f90 | 2 +- src/main/inject_keplerianshear.f90 | 2 +- src/main/inject_rochelobe.f90 | 2 +- src/main/inject_sne.f90 | 2 +- src/main/inject_steadydisc.f90 | 2 +- src/main/inject_unifwind.f90 | 2 +- src/main/inject_wind.f90 | 2 +- src/main/inject_windtunnel.f90 | 2 +- src/main/interp_metric.F90 | 2 +- src/main/inverse4x4.f90 | 2 +- src/main/io.F90 | 2 +- src/main/ionization.f90 | 2 +- src/main/kdtree.F90 | 2 +- src/main/kernel_WendlandC2.f90 | 2 +- src/main/kernel_WendlandC4.f90 | 2 +- src/main/kernel_WendlandC6.f90 | 2 +- src/main/kernel_cubic.f90 | 2 +- src/main/kernel_quartic.f90 | 2 +- src/main/kernel_quintic.f90 | 2 +- src/main/krome.f90 | 2 +- src/main/linklist_kdtree.F90 | 2 +- src/main/lumin_nsdisc.F90 | 2 +- src/main/memory.F90 | 2 +- src/main/metric_et.f90 | 2 +- src/main/metric_flrw.f90 | 2 +- src/main/metric_kerr-schild.f90 | 2 +- src/main/metric_kerr.f90 | 2 +- src/main/metric_minkowski.f90 | 2 +- src/main/metric_schwarzschild.f90 | 2 +- src/main/metric_tools.F90 | 2 +- src/main/mf_write.f90 | 2 +- src/main/mol_data.f90 | 2 +- src/main/mpi_balance.F90 | 2 +- src/main/mpi_dens.F90 | 2 +- src/main/mpi_derivs.F90 | 2 +- src/main/mpi_domain.F90 | 2 +- src/main/mpi_force.F90 | 2 +- src/main/mpi_memory.f90 | 2 +- src/main/mpi_tree.F90 | 2 +- src/main/mpi_utils.F90 | 2 +- src/main/nicil_supplement.f90 | 2 +- src/main/options.f90 | 2 +- src/main/part.F90 | 2 +- src/main/partinject.F90 | 2 +- src/main/phantom.f90 | 2 +- src/main/physcon.f90 | 2 +- src/main/ptmass.F90 | 2 +- src/main/ptmass_heating.f90 | 2 +- src/main/ptmass_radiation.f90 | 2 +- src/main/quitdump.f90 | 2 +- src/main/radiation_implicit.f90 | 2 +- src/main/radiation_utils.f90 | 2 +- src/main/random.f90 | 2 +- src/main/readwrite_dumps.F90 | 2 +- src/main/readwrite_dumps_common.F90 | 2 +- src/main/readwrite_dumps_fortran.F90 | 2 +- src/main/readwrite_dumps_hdf5.F90 | 2 +- src/main/readwrite_infile.F90 | 2 +- src/main/sort_particles.f90 | 2 +- src/main/step_leapfrog.F90 | 2 +- src/main/step_supertimestep.F90 | 2 +- src/main/timestep.f90 | 2 +- src/main/tmunu2grid.f90 | 2 +- src/main/units.f90 | 2 +- src/main/utils_allocate.f90 | 2 +- src/main/utils_binary.f90 | 2 +- src/main/utils_cpuinfo.f90 | 2 +- src/main/utils_datafiles.f90 | 2 +- src/main/utils_deriv.f90 | 2 +- src/main/utils_dumpfiles.f90 | 2 +- src/main/utils_dumpfiles_hdf5.f90 | 2 +- src/main/utils_filenames.f90 | 2 +- src/main/utils_gr.F90 | 2 +- src/main/utils_hdf5.f90 | 2 +- src/main/utils_healpix.f90 | 2 +- src/main/utils_implicit.f90 | 2 +- src/main/utils_indtimesteps.F90 | 2 +- src/main/utils_infiles.f90 | 2 +- src/main/utils_inject.f90 | 2 +- src/main/utils_mathfunc.f90 | 2 +- src/main/utils_omp.F90 | 2 +- src/main/utils_raytracer.f90 | 2 +- src/main/utils_shuffleparticles.F90 | 2 +- src/main/utils_sort.f90 | 2 +- src/main/utils_sphNG.f90 | 2 +- src/main/utils_spline.f90 | 2 +- src/main/utils_summary.F90 | 2 +- src/main/utils_supertimestep.F90 | 2 +- src/main/utils_system.f90 | 2 +- src/main/utils_tables.f90 | 2 +- src/main/utils_timing.f90 | 2 +- src/main/utils_vectors.f90 | 2 +- src/main/viscosity.f90 | 2 +- src/main/wind.F90 | 2 +- src/main/wind_equations.f90 | 2 +- src/main/writeheader.F90 | 2 +- src/setup/density_profiles.f90 | 2 +- src/setup/libsetup.f90 | 2 +- src/setup/phantomsetup.F90 | 2 +- src/setup/readwrite_kepler.f90 | 2 +- src/setup/readwrite_mesa.f90 | 2 +- src/setup/relax_star.f90 | 2 +- src/setup/set_Bfield.f90 | 2 +- src/setup/set_binary.f90 | 2 +- src/setup/set_cubic_core.f90 | 2 +- src/setup/set_disc.F90 | 2 +- src/setup/set_dust.f90 | 2 +- src/setup/set_dust_options.f90 | 2 +- src/setup/set_fixedentropycore.f90 | 2 +- src/setup/set_flyby.f90 | 2 +- src/setup/set_hierarchical.f90 | 2 +- src/setup/set_hierarchical_utils.f90 | 2 +- src/setup/set_planets.f90 | 2 +- src/setup/set_shock.f90 | 2 +- src/setup/set_slab.f90 | 2 +- src/setup/set_softened_core.f90 | 2 +- src/setup/set_sphere.f90 | 2 +- src/setup/set_star.f90 | 2 +- src/setup/set_star_utils.f90 | 2 +- src/setup/set_unifdis.f90 | 2 +- src/setup/set_units.f90 | 2 +- src/setup/set_vfield.f90 | 2 +- src/setup/setup_BHL.f90 | 2 +- src/setup/setup_alfvenwave.f90 | 2 +- src/setup/setup_asteroidwind.f90 | 2 +- src/setup/setup_binary.f90 | 2 +- src/setup/setup_blob.f90 | 2 +- src/setup/setup_bondi.f90 | 2 +- src/setup/setup_bondiinject.f90 | 2 +- src/setup/setup_chinchen.f90 | 2 +- src/setup/setup_cluster.f90 | 2 +- src/setup/setup_collidingclouds.f90 | 2 +- src/setup/setup_common.f90 | 2 +- src/setup/setup_disc.f90 | 2 +- src/setup/setup_dustsettle.f90 | 2 +- src/setup/setup_dustybox.f90 | 2 +- src/setup/setup_dustysedov.f90 | 2 +- src/setup/setup_empty.f90 | 2 +- src/setup/setup_firehose.f90 | 2 +- src/setup/setup_flrw.f90 | 2 +- src/setup/setup_flrwpspec.f90 | 2 +- src/setup/setup_galaxies.f90 | 2 +- src/setup/setup_galcen_stars.f90 | 2 +- src/setup/setup_galdisc.f90 | 2 +- src/setup/setup_grdisc.F90 | 2 +- src/setup/setup_grtde.f90 | 2 +- src/setup/setup_gwdisc.f90 | 2 +- src/setup/setup_hierarchical.f90 | 2 +- src/setup/setup_jadvect.f90 | 2 +- src/setup/setup_kh.f90 | 2 +- src/setup/setup_mhdblast.f90 | 2 +- src/setup/setup_mhdrotor.f90 | 2 +- src/setup/setup_mhdsine.f90 | 2 +- src/setup/setup_mhdvortex.f90 | 2 +- src/setup/setup_mhdwave.f90 | 2 +- src/setup/setup_nsdisc.f90 | 2 +- src/setup/setup_orstang.f90 | 2 +- src/setup/setup_params.f90 | 2 +- src/setup/setup_planetdisc.f90 | 2 +- src/setup/setup_prtest.f90 | 2 +- src/setup/setup_quebec.f90 | 2 +- src/setup/setup_radiativebox.f90 | 2 +- src/setup/setup_sedov.f90 | 2 +- src/setup/setup_shock.F90 | 2 +- src/setup/setup_solarsystem.f90 | 2 +- src/setup/setup_sphereinbox.f90 | 2 +- src/setup/setup_srblast.f90 | 2 +- src/setup/setup_srpolytrope.f90 | 2 +- src/setup/setup_star.f90 | 2 +- src/setup/setup_taylorgreen.f90 | 2 +- src/setup/setup_testparticles.F90 | 2 +- src/setup/setup_tokamak.f90 | 2 +- src/setup/setup_torus.f90 | 2 +- src/setup/setup_turb.f90 | 2 +- src/setup/setup_unifdis.f90 | 2 +- src/setup/setup_wave.f90 | 2 +- src/setup/setup_wavedamp.f90 | 2 +- src/setup/setup_wddisc.f90 | 2 +- src/setup/setup_wind.f90 | 2 +- src/setup/setup_windtunnel.f90 | 2 +- src/setup/stretchmap.f90 | 2 +- src/setup/velfield_fromcubes.f90 | 2 +- src/tests/directsum.f90 | 2 +- src/tests/phantomtest.f90 | 2 +- src/tests/test_cooling.f90 | 5 +++-- src/tests/test_corotate.f90 | 2 +- src/tests/test_damping.f90 | 2 +- src/tests/test_derivs.F90 | 2 +- src/tests/test_dust.F90 | 2 +- src/tests/test_eos.f90 | 4 ++-- src/tests/test_eos_stratified.f90 | 2 +- src/tests/test_externf.f90 | 2 +- src/tests/test_externf_gr.f90 | 2 +- src/tests/test_fastmath.f90 | 2 +- src/tests/test_geometry.f90 | 2 +- src/tests/test_gnewton.f90 | 2 +- src/tests/test_gr.f90 | 2 +- src/tests/test_gravity.f90 | 2 +- src/tests/test_growth.f90 | 2 +- src/tests/test_hierarchical.f90 | 2 +- src/tests/test_indtstep.F90 | 2 +- src/tests/test_kdtree.F90 | 2 +- src/tests/test_kernel.f90 | 2 +- src/tests/test_link.F90 | 2 +- src/tests/test_luminosity.F90 | 2 +- src/tests/test_mpi.f90 | 2 +- src/tests/test_nonidealmhd.F90 | 2 +- src/tests/test_part.f90 | 2 +- src/tests/test_poly.f90 | 2 +- src/tests/test_ptmass.f90 | 2 +- src/tests/test_radiation.f90 | 2 +- src/tests/test_rwdump.F90 | 2 +- src/tests/test_sedov.F90 | 2 +- src/tests/test_setdisc.f90 | 2 +- src/tests/test_smol.F90 | 2 +- src/tests/test_step.F90 | 2 +- src/tests/test_wind.f90 | 2 +- src/tests/testsuite.F90 | 2 +- src/tests/utils_testsuite.f90 | 2 +- src/utils/acc2ang.f90 | 2 +- src/utils/adaptivemesh.f90 | 2 +- src/utils/analysis_1particle.f90 | 2 +- src/utils/analysis_BRhoOrientation.F90 | 2 +- src/utils/analysis_CoM.f90 | 2 +- src/utils/analysis_GalMerger.f90 | 2 +- src/utils/analysis_MWpdf.f90 | 2 +- src/utils/analysis_NSmerger.f90 | 2 +- src/utils/analysis_alpha.f90 | 2 +- src/utils/analysis_angmom.f90 | 2 +- src/utils/analysis_angmomvec.f90 | 2 +- src/utils/analysis_average_orb_en.f90 | 2 +- src/utils/analysis_binarydisc.f90 | 2 +- src/utils/analysis_bzrms.f90 | 2 +- src/utils/analysis_clumpfind.F90 | 2 +- src/utils/analysis_clumpfindWB23.F90 | 2 +- src/utils/analysis_collidingcloudevolution.f90 | 2 +- src/utils/analysis_collidingcloudhistograms.f90 | 2 +- src/utils/analysis_common_envelope.f90 | 2 +- src/utils/analysis_cooling.f90 | 2 +- src/utils/analysis_disc.f90 | 2 +- src/utils/analysis_disc_MFlow.f90 | 2 +- src/utils/analysis_disc_eccentric.f90 | 2 +- src/utils/analysis_disc_mag.f90 | 2 +- src/utils/analysis_disc_planet.f90 | 2 +- src/utils/analysis_disc_stresses.f90 | 2 +- src/utils/analysis_dtheader.f90 | 2 +- src/utils/analysis_dustformation.f90 | 2 +- src/utils/analysis_dustmass.f90 | 2 +- src/utils/analysis_dustydisc.f90 | 2 +- src/utils/analysis_dustywind.f90 | 2 +- src/utils/analysis_etotgr.f90 | 2 +- src/utils/analysis_getneighbours.f90 | 2 +- src/utils/analysis_gws.f90 | 2 +- src/utils/analysis_jet.f90 | 2 +- src/utils/analysis_kdtree.F90 | 2 +- src/utils/analysis_kepler.f90 | 2 +- src/utils/analysis_macctrace.f90 | 2 +- src/utils/analysis_mapping_mass.f90 | 2 +- src/utils/analysis_mcfost.f90 | 2 +- src/utils/analysis_mcfostcmdline.f90 | 2 +- src/utils/analysis_pairing.f90 | 2 +- src/utils/analysis_particle.f90 | 2 +- src/utils/analysis_pdfs.f90 | 2 +- src/utils/analysis_phantom_dump.f90 | 2 +- src/utils/analysis_polytropes.f90 | 2 +- src/utils/analysis_prdrag.f90 | 2 +- src/utils/analysis_protostar_environ.F90 | 2 +- src/utils/analysis_ptmass.f90 | 2 +- src/utils/analysis_radiotde.f90 | 2 +- src/utils/analysis_raytracer.f90 | 2 +- src/utils/analysis_sinkmass.f90 | 2 +- src/utils/analysis_sphere.f90 | 2 +- src/utils/analysis_structurefn.f90 | 2 +- src/utils/analysis_tde.f90 | 2 +- src/utils/analysis_torus.f90 | 2 +- src/utils/analysis_trackbox.f90 | 2 +- src/utils/analysis_tracks.f90 | 2 +- src/utils/analysis_velocitydispersion_vs_scale.f90 | 2 +- src/utils/analysis_velocityshear.f90 | 2 +- src/utils/analysis_write_kdtree.F90 | 2 +- src/utils/combinedustdumps.f90 | 2 +- src/utils/cubicsolve.f90 | 2 +- src/utils/diffdumps.f90 | 2 +- src/utils/dustywaves.f90 | 2 +- src/utils/einsteintk_utils.f90 | 2 +- src/utils/einsteintk_wrapper.f90 | 2 +- src/utils/ev2kdot.f90 | 2 +- src/utils/ev2mdot.f90 | 2 +- src/utils/evol_dustywaves.f90 | 2 +- src/utils/get_struct_slope.f90 | 2 +- src/utils/getmathflags.f90 | 2 +- src/utils/grid2pdf.f90 | 2 +- src/utils/hdf5utils.f90 | 2 +- src/utils/icosahedron.f90 | 2 +- src/utils/interpolate3D.F90 | 2 +- src/utils/interpolate3D_amr.F90 | 2 +- src/utils/io_grid.f90 | 2 +- src/utils/io_structurefn.f90 | 2 +- src/utils/leastsquares.f90 | 2 +- src/utils/libphantom-splash.f90 | 2 +- src/utils/lombperiod.f90 | 2 +- src/utils/mflow.f90 | 2 +- src/utils/moddump_CoM.f90 | 2 +- src/utils/moddump_addflyby.f90 | 2 +- src/utils/moddump_addplanets.f90 | 2 +- src/utils/moddump_binary.f90 | 2 +- src/utils/moddump_binarystar.f90 | 2 +- src/utils/moddump_changemass.f90 | 2 +- src/utils/moddump_default.f90 | 2 +- src/utils/moddump_disc.f90 | 2 +- src/utils/moddump_dustadd.f90 | 2 +- src/utils/moddump_extenddisc.f90 | 2 +- src/utils/moddump_growthtomultigrain.f90 | 2 +- src/utils/moddump_mergepart.f90 | 2 +- src/utils/moddump_messupSPH.f90 | 2 +- src/utils/moddump_perturbgas.f90 | 2 +- src/utils/moddump_polytrope.f90 | 2 +- src/utils/moddump_rad_to_LTE.f90 | 2 +- src/utils/moddump_radiotde.f90 | 2 +- src/utils/moddump_recalcuT.f90 | 2 +- src/utils/moddump_removeparticles_cylinder.f90 | 2 +- src/utils/moddump_removeparticles_radius.f90 | 2 +- src/utils/moddump_rotate.f90 | 2 +- src/utils/moddump_sink.f90 | 2 +- src/utils/moddump_sinkbinary.f90 | 2 +- src/utils/moddump_sphNG2phantom.f90 | 2 +- src/utils/moddump_sphNG2phantom_addBfield.f90 | 2 +- src/utils/moddump_sphNG2phantom_disc.f90 | 2 +- src/utils/moddump_splitpart.f90 | 2 +- src/utils/moddump_taylorgreen.f90 | 2 +- src/utils/moddump_tidal.f90 | 2 +- src/utils/moddump_torus.f90 | 2 +- src/utils/multirun.f90 | 2 +- src/utils/multirun_mach.f90 | 2 +- src/utils/pdfs.f90 | 2 +- src/utils/phantom2divb.f90 | 2 +- src/utils/phantom2divv.f90 | 2 +- src/utils/phantom2gadget.f90 | 2 +- src/utils/phantom2hdf5.f90 | 2 +- src/utils/phantom2sphNG.f90 | 2 +- src/utils/phantom_moddump.f90 | 2 +- src/utils/phantomanalysis.f90 | 2 +- src/utils/phantomevcompare.f90 | 2 +- src/utils/phantomextractsinks.f90 | 2 +- src/utils/plot_kernel.f90 | 2 +- src/utils/powerspectrums.f90 | 2 +- src/utils/prompting.f90 | 2 +- src/utils/quartic.f90 | 2 +- src/utils/rhomach.f90 | 2 +- src/utils/showarrays.f90 | 2 +- src/utils/showheader.f90 | 2 +- src/utils/solvelinearsystem.f90 | 2 +- src/utils/splitpart.f90 | 2 +- src/utils/struct2struct.f90 | 2 +- src/utils/struct_part.f90 | 2 +- src/utils/test_binary.f90 | 2 +- src/utils/testbinary.f90 | 2 +- src/utils/utils_disc.f90 | 2 +- src/utils/utils_ephemeris.f90 | 2 +- src/utils/utils_evfiles.f90 | 2 +- src/utils/utils_getneighbours.F90 | 2 +- src/utils/utils_gravwave.f90 | 2 +- src/utils/utils_linalg.f90 | 2 +- src/utils/utils_mpc.f90 | 2 +- src/utils/utils_orbits.f90 | 2 +- src/utils/utils_raytracer_all.f90 | 2 +- src/utils/utils_splitmerge.f90 | 2 +- src/utils/velfield.f90 | 2 +- 437 files changed, 440 insertions(+), 439 deletions(-) diff --git a/src/main/bondiexact.f90 b/src/main/bondiexact.f90 index 992ff21a7..e39ddd970 100644 --- a/src/main/bondiexact.f90 +++ b/src/main/bondiexact.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/bondiexact_gr.f90 b/src/main/bondiexact_gr.f90 index ddc693e3c..869fc061a 100644 --- a/src/main/bondiexact_gr.f90 +++ b/src/main/bondiexact_gr.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/boundary.f90 b/src/main/boundary.f90 index 4ecb9fcaa..08bb0fd34 100644 --- a/src/main/boundary.f90 +++ b/src/main/boundary.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/boundary_dynamic.f90 b/src/main/boundary_dynamic.f90 index 22e0303d8..88642a872 100644 --- a/src/main/boundary_dynamic.f90 +++ b/src/main/boundary_dynamic.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/centreofmass.f90 b/src/main/centreofmass.f90 index a638095de..88fb0fb70 100644 --- a/src/main/centreofmass.f90 +++ b/src/main/centreofmass.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/checkconserved.f90 b/src/main/checkconserved.f90 index c42381bbe..e47e96955 100644 --- a/src/main/checkconserved.f90 +++ b/src/main/checkconserved.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/checkoptions.F90 b/src/main/checkoptions.F90 index ff7de8cc9..d230f40bf 100644 --- a/src/main/checkoptions.F90 +++ b/src/main/checkoptions.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index 79ce79cf1..a14201b96 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/config.F90 b/src/main/config.F90 index 57c8b62ce..92faa467c 100644 --- a/src/main/config.F90 +++ b/src/main/config.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 8845e893f..9c1130f8e 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cons2primsolver.f90 b/src/main/cons2primsolver.f90 index ee101a69b..10e81529d 100644 --- a/src/main/cons2primsolver.f90 +++ b/src/main/cons2primsolver.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index e5d35d25e..90514dd7f 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cooling_functions.f90 b/src/main/cooling_functions.f90 index ec63f4ed8..229afeaef 100644 --- a/src/main/cooling_functions.f90 +++ b/src/main/cooling_functions.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cooling_gammie.f90 b/src/main/cooling_gammie.f90 index 505806b2e..3fffe3565 100644 --- a/src/main/cooling_gammie.f90 +++ b/src/main/cooling_gammie.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cooling_gammie_PL.f90 b/src/main/cooling_gammie_PL.f90 index 0262a0787..15ae40733 100644 --- a/src/main/cooling_gammie_PL.f90 +++ b/src/main/cooling_gammie_PL.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index 98ec1d000..60d574c75 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cooling_koyamainutsuka.f90 b/src/main/cooling_koyamainutsuka.f90 index 71fb2196e..eee002b73 100644 --- a/src/main/cooling_koyamainutsuka.f90 +++ b/src/main/cooling_koyamainutsuka.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cooling_molecular.f90 b/src/main/cooling_molecular.f90 index 798408f18..48055b2c9 100644 --- a/src/main/cooling_molecular.f90 +++ b/src/main/cooling_molecular.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cooling_solver.f90 b/src/main/cooling_solver.f90 index 11879c844..8775b5c7f 100644 --- a/src/main/cooling_solver.f90 +++ b/src/main/cooling_solver.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/cullendehnen.f90 b/src/main/cullendehnen.f90 index 37dbbeac7..5ebd2e7c9 100644 --- a/src/main/cullendehnen.f90 +++ b/src/main/cullendehnen.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/damping.f90 b/src/main/damping.f90 index 055a367a0..d7c83f925 100644 --- a/src/main/damping.f90 +++ b/src/main/damping.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/datafiles.f90 b/src/main/datafiles.f90 index 3fedf3827..b5f68a30d 100644 --- a/src/main/datafiles.f90 +++ b/src/main/datafiles.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/dens.F90 b/src/main/dens.F90 index 6ef38a06f..4c2ddf816 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index 3eb0e9f92..f86a8ba63 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/dtype_kdtree.F90 b/src/main/dtype_kdtree.F90 index 88b1303d6..6cf50144f 100644 --- a/src/main/dtype_kdtree.F90 +++ b/src/main/dtype_kdtree.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/dust.f90 b/src/main/dust.f90 index 4c61da088..fda11c216 100644 --- a/src/main/dust.f90 +++ b/src/main/dust.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index 8343c00c3..e594658ca 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 73d130e65..27684ce97 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/eos.f90 b/src/main/eos.f90 index fe006f8d5..d7f4b4d2e 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/eos_barotropic.f90 b/src/main/eos_barotropic.f90 index d42385e38..93f32e64c 100644 --- a/src/main/eos_barotropic.f90 +++ b/src/main/eos_barotropic.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/eos_gasradrec.f90 b/src/main/eos_gasradrec.f90 index 9c05fcb60..d8e949aba 100644 --- a/src/main/eos_gasradrec.f90 +++ b/src/main/eos_gasradrec.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/eos_helmholtz.f90 b/src/main/eos_helmholtz.f90 index 988e29bda..882967eba 100644 --- a/src/main/eos_helmholtz.f90 +++ b/src/main/eos_helmholtz.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/eos_idealplusrad.f90 b/src/main/eos_idealplusrad.f90 index 8ab9d69c4..995408085 100644 --- a/src/main/eos_idealplusrad.f90 +++ b/src/main/eos_idealplusrad.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/eos_mesa.f90 b/src/main/eos_mesa.f90 index f192233fc..216f04deb 100644 --- a/src/main/eos_mesa.f90 +++ b/src/main/eos_mesa.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/eos_mesa_microphysics.f90 b/src/main/eos_mesa_microphysics.f90 index e9bf5535c..aa9268c13 100644 --- a/src/main/eos_mesa_microphysics.f90 +++ b/src/main/eos_mesa_microphysics.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/eos_piecewise.f90 b/src/main/eos_piecewise.f90 index 78c087b04..8462e4bcf 100644 --- a/src/main/eos_piecewise.f90 +++ b/src/main/eos_piecewise.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/eos_shen.f90 b/src/main/eos_shen.f90 index a62ddb51d..7c2548677 100644 --- a/src/main/eos_shen.f90 +++ b/src/main/eos_shen.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/eos_stratified.f90 b/src/main/eos_stratified.f90 index 5c106e750..37f9bcd14 100644 --- a/src/main/eos_stratified.f90 +++ b/src/main/eos_stratified.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index bf6e6b5e7..9e4b9138d 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/evwrite.f90 b/src/main/evwrite.f90 index 61ff46cb1..8c8e5b76f 100644 --- a/src/main/evwrite.f90 +++ b/src/main/evwrite.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_Bfield.f90 b/src/main/extern_Bfield.f90 index 8ced5e325..1b4319e70 100644 --- a/src/main/extern_Bfield.f90 +++ b/src/main/extern_Bfield.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_binary.f90 b/src/main/extern_binary.f90 index e26cbf168..d22725666 100644 --- a/src/main/extern_binary.f90 +++ b/src/main/extern_binary.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_binary_gw.f90 b/src/main/extern_binary_gw.f90 index 93b6e1c07..db906d239 100644 --- a/src/main/extern_binary_gw.f90 +++ b/src/main/extern_binary_gw.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_corotate.f90 b/src/main/extern_corotate.f90 index a96802926..72eedd4e5 100644 --- a/src/main/extern_corotate.f90 +++ b/src/main/extern_corotate.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_densprofile.f90 b/src/main/extern_densprofile.f90 index 9dd4cde27..407e50fae 100644 --- a/src/main/extern_densprofile.f90 +++ b/src/main/extern_densprofile.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_geopot.f90 b/src/main/extern_geopot.f90 index 728dbffe2..f56ecb54a 100644 --- a/src/main/extern_geopot.f90 +++ b/src/main/extern_geopot.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_gnewton.f90 b/src/main/extern_gnewton.f90 index af89ff741..75a8563e9 100644 --- a/src/main/extern_gnewton.f90 +++ b/src/main/extern_gnewton.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 17d050f42..8696ffd10 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_gwinspiral.f90 b/src/main/extern_gwinspiral.f90 index 6ef4a6012..460cb5c3b 100644 --- a/src/main/extern_gwinspiral.f90 +++ b/src/main/extern_gwinspiral.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_lensethirring.f90 b/src/main/extern_lensethirring.f90 index c05bf54d0..cfc6b9b03 100644 --- a/src/main/extern_lensethirring.f90 +++ b/src/main/extern_lensethirring.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_prdrag.f90 b/src/main/extern_prdrag.f90 index cccb8d924..78456bd68 100644 --- a/src/main/extern_prdrag.f90 +++ b/src/main/extern_prdrag.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_spiral.f90 b/src/main/extern_spiral.f90 index cba734676..ddeb68966 100644 --- a/src/main/extern_spiral.f90 +++ b/src/main/extern_spiral.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/extern_staticsine.f90 b/src/main/extern_staticsine.f90 index e469b8fbb..8d71b1c14 100644 --- a/src/main/extern_staticsine.f90 +++ b/src/main/extern_staticsine.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/externalforces.f90 b/src/main/externalforces.f90 index d564295b1..51f3ecd3c 100644 --- a/src/main/externalforces.f90 +++ b/src/main/externalforces.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/externalforces_gr.f90 b/src/main/externalforces_gr.f90 index 1334ff2af..562660310 100644 --- a/src/main/externalforces_gr.f90 +++ b/src/main/externalforces_gr.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/fastmath.f90 b/src/main/fastmath.f90 index fec93b016..59bb2a052 100644 --- a/src/main/fastmath.f90 +++ b/src/main/fastmath.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/force.F90 b/src/main/force.F90 index f9b8dfec2..7a9cb72f2 100644 --- a/src/main/force.F90 +++ b/src/main/force.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/forcing.F90 b/src/main/forcing.F90 index 7b3a10e24..878e88f86 100644 --- a/src/main/forcing.F90 +++ b/src/main/forcing.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/fs_data.f90 b/src/main/fs_data.f90 index 12206a3c7..2e5c0718f 100644 --- a/src/main/fs_data.f90 +++ b/src/main/fs_data.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/geometry.f90 b/src/main/geometry.f90 index b78d805a8..e0fcf88d2 100644 --- a/src/main/geometry.f90 +++ b/src/main/geometry.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/gitinfo.f90 b/src/main/gitinfo.f90 index 19a62cf92..8ea06264e 100644 --- a/src/main/gitinfo.f90 +++ b/src/main/gitinfo.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/growth.F90 b/src/main/growth.F90 index bc12547e3..a8ad0f4a0 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/growth_smol.f90 b/src/main/growth_smol.f90 index c89207c4b..0a818364f 100644 --- a/src/main/growth_smol.f90 +++ b/src/main/growth_smol.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/h2chem.f90 b/src/main/h2chem.f90 index fda80dd84..a79faa951 100644 --- a/src/main/h2chem.f90 +++ b/src/main/h2chem.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/initial.F90 b/src/main/initial.F90 index ff53e88a5..6b61b32fb 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_BHL.f90 b/src/main/inject_BHL.f90 index 0f55107bc..37fd6f95b 100644 --- a/src/main/inject_BHL.f90 +++ b/src/main/inject_BHL.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_asteroidwind.f90 b/src/main/inject_asteroidwind.f90 index 758784144..155308b7e 100644 --- a/src/main/inject_asteroidwind.f90 +++ b/src/main/inject_asteroidwind.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_bondi.f90 b/src/main/inject_bondi.f90 index 2272daf80..3b6e5a32f 100644 --- a/src/main/inject_bondi.f90 +++ b/src/main/inject_bondi.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_firehose.f90 b/src/main/inject_firehose.f90 index c1246d526..e869e4161 100644 --- a/src/main/inject_firehose.f90 +++ b/src/main/inject_firehose.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_galcen_winds.f90 b/src/main/inject_galcen_winds.f90 index ea366c5cf..39215c90b 100644 --- a/src/main/inject_galcen_winds.f90 +++ b/src/main/inject_galcen_winds.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_keplerianshear.f90 b/src/main/inject_keplerianshear.f90 index 43c728e2c..9c4f7847b 100644 --- a/src/main/inject_keplerianshear.f90 +++ b/src/main/inject_keplerianshear.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_rochelobe.f90 b/src/main/inject_rochelobe.f90 index 55079d0bc..b71114463 100644 --- a/src/main/inject_rochelobe.f90 +++ b/src/main/inject_rochelobe.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_sne.f90 b/src/main/inject_sne.f90 index e0f95d8fb..9ebc81382 100644 --- a/src/main/inject_sne.f90 +++ b/src/main/inject_sne.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_steadydisc.f90 b/src/main/inject_steadydisc.f90 index 254e3b57a..9dc7aca64 100644 --- a/src/main/inject_steadydisc.f90 +++ b/src/main/inject_steadydisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_unifwind.f90 b/src/main/inject_unifwind.f90 index 275fb3b75..bb8da8607 100644 --- a/src/main/inject_unifwind.f90 +++ b/src/main/inject_unifwind.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index 0d40723cc..4387c9c20 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 5888f288e..dd3b4f1a1 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/interp_metric.F90 b/src/main/interp_metric.F90 index 0d1cb7080..362eb129f 100644 --- a/src/main/interp_metric.F90 +++ b/src/main/interp_metric.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/inverse4x4.f90 b/src/main/inverse4x4.f90 index 2450eaf08..2107fae70 100644 --- a/src/main/inverse4x4.f90 +++ b/src/main/inverse4x4.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/io.F90 b/src/main/io.F90 index 1c48207ac..97e2bb204 100644 --- a/src/main/io.F90 +++ b/src/main/io.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index b603fc501..032bc9ad6 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/kdtree.F90 b/src/main/kdtree.F90 index 0452a5772..9b70a7f1f 100644 --- a/src/main/kdtree.F90 +++ b/src/main/kdtree.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/kernel_WendlandC2.f90 b/src/main/kernel_WendlandC2.f90 index 546ea1be4..882b2d4a4 100644 --- a/src/main/kernel_WendlandC2.f90 +++ b/src/main/kernel_WendlandC2.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/kernel_WendlandC4.f90 b/src/main/kernel_WendlandC4.f90 index 596233360..ea1202d65 100644 --- a/src/main/kernel_WendlandC4.f90 +++ b/src/main/kernel_WendlandC4.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/kernel_WendlandC6.f90 b/src/main/kernel_WendlandC6.f90 index 20f819c1b..b7b690789 100644 --- a/src/main/kernel_WendlandC6.f90 +++ b/src/main/kernel_WendlandC6.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/kernel_cubic.f90 b/src/main/kernel_cubic.f90 index 075292bfc..bf16cead5 100644 --- a/src/main/kernel_cubic.f90 +++ b/src/main/kernel_cubic.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/kernel_quartic.f90 b/src/main/kernel_quartic.f90 index 4e32bb18b..a698e32b6 100644 --- a/src/main/kernel_quartic.f90 +++ b/src/main/kernel_quartic.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/kernel_quintic.f90 b/src/main/kernel_quintic.f90 index 15358b5ed..64482f474 100644 --- a/src/main/kernel_quintic.f90 +++ b/src/main/kernel_quintic.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/krome.f90 b/src/main/krome.f90 index 24f7768b6..8f5b14ed7 100644 --- a/src/main/krome.f90 +++ b/src/main/krome.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/linklist_kdtree.F90 b/src/main/linklist_kdtree.F90 index b644c7d75..4913f0925 100644 --- a/src/main/linklist_kdtree.F90 +++ b/src/main/linklist_kdtree.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/lumin_nsdisc.F90 b/src/main/lumin_nsdisc.F90 index 139ed68a5..90db88923 100644 --- a/src/main/lumin_nsdisc.F90 +++ b/src/main/lumin_nsdisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/memory.F90 b/src/main/memory.F90 index 500b414a7..5275c132a 100644 --- a/src/main/memory.F90 +++ b/src/main/memory.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index d13454ce1..ce133ea83 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/metric_flrw.f90 b/src/main/metric_flrw.f90 index 3685131b8..67127f46e 100644 --- a/src/main/metric_flrw.f90 +++ b/src/main/metric_flrw.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/metric_kerr-schild.f90 b/src/main/metric_kerr-schild.f90 index 6557462be..59ada6922 100644 --- a/src/main/metric_kerr-schild.f90 +++ b/src/main/metric_kerr-schild.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/metric_kerr.f90 b/src/main/metric_kerr.f90 index 329efe265..b270e4111 100644 --- a/src/main/metric_kerr.f90 +++ b/src/main/metric_kerr.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/metric_minkowski.f90 b/src/main/metric_minkowski.f90 index 94295f28e..3562abad8 100644 --- a/src/main/metric_minkowski.f90 +++ b/src/main/metric_minkowski.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/metric_schwarzschild.f90 b/src/main/metric_schwarzschild.f90 index 73d3451e8..6add9d242 100644 --- a/src/main/metric_schwarzschild.f90 +++ b/src/main/metric_schwarzschild.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/metric_tools.F90 b/src/main/metric_tools.F90 index c4acb5c4d..8fd54fdf0 100644 --- a/src/main/metric_tools.F90 +++ b/src/main/metric_tools.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/mf_write.f90 b/src/main/mf_write.f90 index 66249b76a..486ec1bf7 100644 --- a/src/main/mf_write.f90 +++ b/src/main/mf_write.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/mol_data.f90 b/src/main/mol_data.f90 index a71d18ebc..fe91bae89 100644 --- a/src/main/mol_data.f90 +++ b/src/main/mol_data.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/mpi_balance.F90 b/src/main/mpi_balance.F90 index 91e604027..1679dda42 100644 --- a/src/main/mpi_balance.F90 +++ b/src/main/mpi_balance.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/mpi_dens.F90 b/src/main/mpi_dens.F90 index 5a512ea63..d578658e3 100644 --- a/src/main/mpi_dens.F90 +++ b/src/main/mpi_dens.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/mpi_derivs.F90 b/src/main/mpi_derivs.F90 index 0eadd0034..a9b2b2641 100644 --- a/src/main/mpi_derivs.F90 +++ b/src/main/mpi_derivs.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/mpi_domain.F90 b/src/main/mpi_domain.F90 index 7a89c32cd..b58c49fed 100644 --- a/src/main/mpi_domain.F90 +++ b/src/main/mpi_domain.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/mpi_force.F90 b/src/main/mpi_force.F90 index 96ccacad9..3dab68ded 100644 --- a/src/main/mpi_force.F90 +++ b/src/main/mpi_force.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/mpi_memory.f90 b/src/main/mpi_memory.f90 index ad8ad64d6..5d635f2d4 100644 --- a/src/main/mpi_memory.f90 +++ b/src/main/mpi_memory.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/mpi_tree.F90 b/src/main/mpi_tree.F90 index 8183b03b5..fe49e3c22 100644 --- a/src/main/mpi_tree.F90 +++ b/src/main/mpi_tree.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/mpi_utils.F90 b/src/main/mpi_utils.F90 index bc2cc34ad..e725bc020 100644 --- a/src/main/mpi_utils.F90 +++ b/src/main/mpi_utils.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/nicil_supplement.f90 b/src/main/nicil_supplement.f90 index 45717c48b..c0d5fbfd3 100644 --- a/src/main/nicil_supplement.f90 +++ b/src/main/nicil_supplement.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/options.f90 b/src/main/options.f90 index 6ac0f8927..85887742a 100644 --- a/src/main/options.f90 +++ b/src/main/options.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/part.F90 b/src/main/part.F90 index 70acccbef..5a8ad35fc 100644 --- a/src/main/part.F90 +++ b/src/main/part.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/partinject.F90 b/src/main/partinject.F90 index 259a6dcac..0469a73fc 100644 --- a/src/main/partinject.F90 +++ b/src/main/partinject.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/phantom.f90 b/src/main/phantom.f90 index 8d26dafd8..798802b99 100644 --- a/src/main/phantom.f90 +++ b/src/main/phantom.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/physcon.f90 b/src/main/physcon.f90 index eeaa75506..2577d5fd6 100644 --- a/src/main/physcon.f90 +++ b/src/main/physcon.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index a9aa4cb94..b3df0de88 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/ptmass_heating.f90 b/src/main/ptmass_heating.f90 index 370c6103c..b89fe7983 100644 --- a/src/main/ptmass_heating.f90 +++ b/src/main/ptmass_heating.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/ptmass_radiation.f90 b/src/main/ptmass_radiation.f90 index f2cb966d2..18954ec84 100644 --- a/src/main/ptmass_radiation.f90 +++ b/src/main/ptmass_radiation.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/quitdump.f90 b/src/main/quitdump.f90 index f06e2bb2f..5f0159905 100644 --- a/src/main/quitdump.f90 +++ b/src/main/quitdump.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 719111842..5937e0efb 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index 644a9c3e3..0147e01c7 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/random.f90 b/src/main/random.f90 index 58d875b78..e77444401 100644 --- a/src/main/random.f90 +++ b/src/main/random.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/readwrite_dumps.F90 b/src/main/readwrite_dumps.F90 index f2d82edc1..ff82e7935 100644 --- a/src/main/readwrite_dumps.F90 +++ b/src/main/readwrite_dumps.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/readwrite_dumps_common.F90 b/src/main/readwrite_dumps_common.F90 index 90a498fc7..998e45e61 100644 --- a/src/main/readwrite_dumps_common.F90 +++ b/src/main/readwrite_dumps_common.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index b4ef36210..b583ac2be 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/readwrite_dumps_hdf5.F90 b/src/main/readwrite_dumps_hdf5.F90 index b520a2d3f..3e929d7b4 100644 --- a/src/main/readwrite_dumps_hdf5.F90 +++ b/src/main/readwrite_dumps_hdf5.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 48abc999d..016dc9174 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/sort_particles.f90 b/src/main/sort_particles.f90 index 6239caf4c..89cba893a 100644 --- a/src/main/sort_particles.f90 +++ b/src/main/sort_particles.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 6f039ff5c..c57029349 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/step_supertimestep.F90 b/src/main/step_supertimestep.F90 index 9dd9d932c..413f0615b 100644 --- a/src/main/step_supertimestep.F90 +++ b/src/main/step_supertimestep.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/timestep.f90 b/src/main/timestep.f90 index 2a6a857fc..99bd0e172 100644 --- a/src/main/timestep.f90 +++ b/src/main/timestep.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index bc5269940..5d41bbe10 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/units.f90 b/src/main/units.f90 index 71dfd54b0..d4b9caf19 100644 --- a/src/main/units.f90 +++ b/src/main/units.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_allocate.f90 b/src/main/utils_allocate.f90 index bdc5f9407..d3c704cc1 100644 --- a/src/main/utils_allocate.f90 +++ b/src/main/utils_allocate.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_binary.f90 b/src/main/utils_binary.f90 index ed96493c8..5f9ca8851 100644 --- a/src/main/utils_binary.f90 +++ b/src/main/utils_binary.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_cpuinfo.f90 b/src/main/utils_cpuinfo.f90 index 317a6c18b..5e50794c9 100644 --- a/src/main/utils_cpuinfo.f90 +++ b/src/main/utils_cpuinfo.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_datafiles.f90 b/src/main/utils_datafiles.f90 index ad8965012..f3212a0dd 100644 --- a/src/main/utils_datafiles.f90 +++ b/src/main/utils_datafiles.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_deriv.f90 b/src/main/utils_deriv.f90 index 46dc44ae8..29fcb1ecc 100644 --- a/src/main/utils_deriv.f90 +++ b/src/main/utils_deriv.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_dumpfiles.f90 b/src/main/utils_dumpfiles.f90 index 7e443fdbe..7691ea5c7 100644 --- a/src/main/utils_dumpfiles.f90 +++ b/src/main/utils_dumpfiles.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_dumpfiles_hdf5.f90 b/src/main/utils_dumpfiles_hdf5.f90 index 1bed55413..cffcc3b32 100644 --- a/src/main/utils_dumpfiles_hdf5.f90 +++ b/src/main/utils_dumpfiles_hdf5.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_filenames.f90 b/src/main/utils_filenames.f90 index bdc05883c..e13d3b7f1 100644 --- a/src/main/utils_filenames.f90 +++ b/src/main/utils_filenames.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index 550b340ec..479476ca6 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_hdf5.f90 b/src/main/utils_hdf5.f90 index 824c303fe..2afa77842 100644 --- a/src/main/utils_hdf5.f90 +++ b/src/main/utils_hdf5.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_healpix.f90 b/src/main/utils_healpix.f90 index 328bb3a0e..407761514 100644 --- a/src/main/utils_healpix.f90 +++ b/src/main/utils_healpix.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_implicit.f90 b/src/main/utils_implicit.f90 index 2f16f68ed..63fc4e843 100644 --- a/src/main/utils_implicit.f90 +++ b/src/main/utils_implicit.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_indtimesteps.F90 b/src/main/utils_indtimesteps.F90 index 00a3415f8..14ad9f826 100644 --- a/src/main/utils_indtimesteps.F90 +++ b/src/main/utils_indtimesteps.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_infiles.f90 b/src/main/utils_infiles.f90 index 2d47ad151..c40332b25 100644 --- a/src/main/utils_infiles.f90 +++ b/src/main/utils_infiles.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_inject.f90 b/src/main/utils_inject.f90 index e28f69f75..ca43b16ff 100644 --- a/src/main/utils_inject.f90 +++ b/src/main/utils_inject.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_mathfunc.f90 b/src/main/utils_mathfunc.f90 index f07f519f5..6fd3933a7 100644 --- a/src/main/utils_mathfunc.f90 +++ b/src/main/utils_mathfunc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_omp.F90 b/src/main/utils_omp.F90 index 32ee09250..07b462298 100644 --- a/src/main/utils_omp.F90 +++ b/src/main/utils_omp.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_raytracer.f90 b/src/main/utils_raytracer.f90 index 2f3eec04b..fe327480b 100644 --- a/src/main/utils_raytracer.f90 +++ b/src/main/utils_raytracer.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_shuffleparticles.F90 b/src/main/utils_shuffleparticles.F90 index 7a8665a1a..4d519b273 100644 --- a/src/main/utils_shuffleparticles.F90 +++ b/src/main/utils_shuffleparticles.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index eae395000..97031f2d2 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_sphNG.f90 b/src/main/utils_sphNG.f90 index 065101387..c0fe72c0a 100644 --- a/src/main/utils_sphNG.f90 +++ b/src/main/utils_sphNG.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_spline.f90 b/src/main/utils_spline.f90 index bb40adb31..2d97899f7 100644 --- a/src/main/utils_spline.f90 +++ b/src/main/utils_spline.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_summary.F90 b/src/main/utils_summary.F90 index 14b618a63..e3c780c39 100644 --- a/src/main/utils_summary.F90 +++ b/src/main/utils_summary.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_supertimestep.F90 b/src/main/utils_supertimestep.F90 index 45cf8082e..4f59faa67 100644 --- a/src/main/utils_supertimestep.F90 +++ b/src/main/utils_supertimestep.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_system.f90 b/src/main/utils_system.f90 index 7f43d764e..35c718e1b 100644 --- a/src/main/utils_system.f90 +++ b/src/main/utils_system.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_tables.f90 b/src/main/utils_tables.f90 index 292abac6f..47320b69c 100644 --- a/src/main/utils_tables.f90 +++ b/src/main/utils_tables.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_timing.f90 b/src/main/utils_timing.f90 index fc1a6f32c..f6fb6f23d 100644 --- a/src/main/utils_timing.f90 +++ b/src/main/utils_timing.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/utils_vectors.f90 b/src/main/utils_vectors.f90 index 2d3639f88..e529d5f36 100644 --- a/src/main/utils_vectors.f90 +++ b/src/main/utils_vectors.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/viscosity.f90 b/src/main/viscosity.f90 index 604dbe593..114165a0e 100644 --- a/src/main/viscosity.f90 +++ b/src/main/viscosity.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/wind.F90 b/src/main/wind.F90 index a55378788..259e21e5c 100644 --- a/src/main/wind.F90 +++ b/src/main/wind.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/wind_equations.f90 b/src/main/wind_equations.f90 index f6fec0ec5..ac0a78922 100644 --- a/src/main/wind_equations.f90 +++ b/src/main/wind_equations.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/ ! !--------------------------------------------------------------------------! diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index 0e17564b7..256b0dbbe 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/density_profiles.f90 b/src/setup/density_profiles.f90 index d71a5a5e6..c86853c5e 100644 --- a/src/setup/density_profiles.f90 +++ b/src/setup/density_profiles.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/libsetup.f90 b/src/setup/libsetup.f90 index 990b40f9d..fc36e5e26 100644 --- a/src/setup/libsetup.f90 +++ b/src/setup/libsetup.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/phantomsetup.F90 b/src/setup/phantomsetup.F90 index 3c44b2de5..e24b9669a 100644 --- a/src/setup/phantomsetup.F90 +++ b/src/setup/phantomsetup.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/readwrite_kepler.f90 b/src/setup/readwrite_kepler.f90 index 2ab20d606..21d138b8b 100644 --- a/src/setup/readwrite_kepler.f90 +++ b/src/setup/readwrite_kepler.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index bb8312f36..38444e812 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index 10ebeba56..a4bb589ec 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_Bfield.f90 b/src/setup/set_Bfield.f90 index 2a1a2dfe5..05d4ea027 100644 --- a/src/setup/set_Bfield.f90 +++ b/src/setup/set_Bfield.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_binary.f90 b/src/setup/set_binary.f90 index caf44f11c..e1208a837 100644 --- a/src/setup/set_binary.f90 +++ b/src/setup/set_binary.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_cubic_core.f90 b/src/setup/set_cubic_core.f90 index ce3fa9427..0daa194be 100644 --- a/src/setup/set_cubic_core.f90 +++ b/src/setup/set_cubic_core.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_disc.F90 b/src/setup/set_disc.F90 index 07600f456..505713346 100644 --- a/src/setup/set_disc.F90 +++ b/src/setup/set_disc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_dust.f90 b/src/setup/set_dust.f90 index 632877194..346b1ae8b 100644 --- a/src/setup/set_dust.f90 +++ b/src/setup/set_dust.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_dust_options.f90 b/src/setup/set_dust_options.f90 index fee9fd98a..e3d548a6b 100644 --- a/src/setup/set_dust_options.f90 +++ b/src/setup/set_dust_options.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_fixedentropycore.f90 b/src/setup/set_fixedentropycore.f90 index 6bf31ec59..24fa1f018 100644 --- a/src/setup/set_fixedentropycore.f90 +++ b/src/setup/set_fixedentropycore.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_flyby.f90 b/src/setup/set_flyby.f90 index b7668f9e6..d0250f8fa 100644 --- a/src/setup/set_flyby.f90 +++ b/src/setup/set_flyby.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_hierarchical.f90 b/src/setup/set_hierarchical.f90 index 5eeca00d0..22dad2a68 100644 --- a/src/setup/set_hierarchical.f90 +++ b/src/setup/set_hierarchical.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_hierarchical_utils.f90 b/src/setup/set_hierarchical_utils.f90 index 8a1b4205c..50aa1866e 100644 --- a/src/setup/set_hierarchical_utils.f90 +++ b/src/setup/set_hierarchical_utils.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_planets.f90 b/src/setup/set_planets.f90 index 5a0ee55ed..8abcb545c 100644 --- a/src/setup/set_planets.f90 +++ b/src/setup/set_planets.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_shock.f90 b/src/setup/set_shock.f90 index 65fd65484..e0623f797 100644 --- a/src/setup/set_shock.f90 +++ b/src/setup/set_shock.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_slab.f90 b/src/setup/set_slab.f90 index d8851f693..61c00f7ce 100644 --- a/src/setup/set_slab.f90 +++ b/src/setup/set_slab.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index dd3648941..920e8922d 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_sphere.f90 b/src/setup/set_sphere.f90 index 7aec455b2..e3358f9fd 100644 --- a/src/setup/set_sphere.f90 +++ b/src/setup/set_sphere.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 24071d154..a92ddda35 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index acc0de210..e83a89249 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_unifdis.f90 b/src/setup/set_unifdis.f90 index e85096dc6..b4dece1de 100644 --- a/src/setup/set_unifdis.f90 +++ b/src/setup/set_unifdis.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_units.f90 b/src/setup/set_units.f90 index 6754f4884..5c6de9e7e 100644 --- a/src/setup/set_units.f90 +++ b/src/setup/set_units.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/set_vfield.f90 b/src/setup/set_vfield.f90 index 3b5bdf238..68d2d03e3 100644 --- a/src/setup/set_vfield.f90 +++ b/src/setup/set_vfield.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_BHL.f90 b/src/setup/setup_BHL.f90 index 08a7497c2..560081f1b 100644 --- a/src/setup/setup_BHL.f90 +++ b/src/setup/setup_BHL.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_alfvenwave.f90 b/src/setup/setup_alfvenwave.f90 index 6564fad26..8bc9e10f9 100644 --- a/src/setup/setup_alfvenwave.f90 +++ b/src/setup/setup_alfvenwave.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index 44f098ea0..939193dac 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 8f0999e8d..28a0efac9 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_blob.f90 b/src/setup/setup_blob.f90 index ec8ec343d..d569cfb5b 100644 --- a/src/setup/setup_blob.f90 +++ b/src/setup/setup_blob.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_bondi.f90 b/src/setup/setup_bondi.f90 index 0edc1ce43..f543019fd 100644 --- a/src/setup/setup_bondi.f90 +++ b/src/setup/setup_bondi.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_bondiinject.f90 b/src/setup/setup_bondiinject.f90 index 057a0839e..d26c1a388 100644 --- a/src/setup/setup_bondiinject.f90 +++ b/src/setup/setup_bondiinject.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_chinchen.f90 b/src/setup/setup_chinchen.f90 index ef0ecfa73..708700567 100644 --- a/src/setup/setup_chinchen.f90 +++ b/src/setup/setup_chinchen.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 2a63e6ad5..cd3e60944 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_collidingclouds.f90 b/src/setup/setup_collidingclouds.f90 index 5ebfdaa10..ff9553b42 100644 --- a/src/setup/setup_collidingclouds.f90 +++ b/src/setup/setup_collidingclouds.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_common.f90 b/src/setup/setup_common.f90 index 706b18ef9..9a51767e0 100644 --- a/src/setup/setup_common.f90 +++ b/src/setup/setup_common.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 23d79cd1a..b1df4b584 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_dustsettle.f90 b/src/setup/setup_dustsettle.f90 index 83c64886b..5a58e68c5 100644 --- a/src/setup/setup_dustsettle.f90 +++ b/src/setup/setup_dustsettle.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_dustybox.f90 b/src/setup/setup_dustybox.f90 index fd8b7f0fe..00d9bae08 100644 --- a/src/setup/setup_dustybox.f90 +++ b/src/setup/setup_dustybox.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_dustysedov.f90 b/src/setup/setup_dustysedov.f90 index bf6fe0c8d..918becd15 100644 --- a/src/setup/setup_dustysedov.f90 +++ b/src/setup/setup_dustysedov.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_empty.f90 b/src/setup/setup_empty.f90 index 16ab99ccf..22c3a0893 100644 --- a/src/setup/setup_empty.f90 +++ b/src/setup/setup_empty.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_firehose.f90 b/src/setup/setup_firehose.f90 index 03ee60f0f..c6256bcf0 100644 --- a/src/setup/setup_firehose.f90 +++ b/src/setup/setup_firehose.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_flrw.f90 b/src/setup/setup_flrw.f90 index 875c44de2..5dab4626a 100644 --- a/src/setup/setup_flrw.f90 +++ b/src/setup/setup_flrw.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_flrwpspec.f90 b/src/setup/setup_flrwpspec.f90 index 2392255ac..69aa34256 100644 --- a/src/setup/setup_flrwpspec.f90 +++ b/src/setup/setup_flrwpspec.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_galaxies.f90 b/src/setup/setup_galaxies.f90 index ecac91afb..ea8d68924 100644 --- a/src/setup/setup_galaxies.f90 +++ b/src/setup/setup_galaxies.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_galcen_stars.f90 b/src/setup/setup_galcen_stars.f90 index 0c3778c94..b7d08a395 100644 --- a/src/setup/setup_galcen_stars.f90 +++ b/src/setup/setup_galcen_stars.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_galdisc.f90 b/src/setup/setup_galdisc.f90 index 36267b2c3..e6dbcd55b 100644 --- a/src/setup/setup_galdisc.f90 +++ b/src/setup/setup_galdisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index 640f8cf9b..e6fa50dc4 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index bcaf0e30c..a6d04d9ef 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_gwdisc.f90 b/src/setup/setup_gwdisc.f90 index 701e3c456..6f74be36a 100644 --- a/src/setup/setup_gwdisc.f90 +++ b/src/setup/setup_gwdisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_hierarchical.f90 b/src/setup/setup_hierarchical.f90 index eda66d600..cad18867d 100644 --- a/src/setup/setup_hierarchical.f90 +++ b/src/setup/setup_hierarchical.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_jadvect.f90 b/src/setup/setup_jadvect.f90 index 2f9e1c06a..15b8fc00e 100644 --- a/src/setup/setup_jadvect.f90 +++ b/src/setup/setup_jadvect.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_kh.f90 b/src/setup/setup_kh.f90 index c83f7c0fa..5e847d5f8 100644 --- a/src/setup/setup_kh.f90 +++ b/src/setup/setup_kh.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_mhdblast.f90 b/src/setup/setup_mhdblast.f90 index 19ade125d..12189204f 100644 --- a/src/setup/setup_mhdblast.f90 +++ b/src/setup/setup_mhdblast.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_mhdrotor.f90 b/src/setup/setup_mhdrotor.f90 index 9a9c2a234..25f1d5402 100644 --- a/src/setup/setup_mhdrotor.f90 +++ b/src/setup/setup_mhdrotor.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_mhdsine.f90 b/src/setup/setup_mhdsine.f90 index 371c5852d..0c1fa5b0a 100644 --- a/src/setup/setup_mhdsine.f90 +++ b/src/setup/setup_mhdsine.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_mhdvortex.f90 b/src/setup/setup_mhdvortex.f90 index b7138b364..8ea65ad98 100644 --- a/src/setup/setup_mhdvortex.f90 +++ b/src/setup/setup_mhdvortex.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_mhdwave.f90 b/src/setup/setup_mhdwave.f90 index fe25a364a..db858458b 100644 --- a/src/setup/setup_mhdwave.f90 +++ b/src/setup/setup_mhdwave.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_nsdisc.f90 b/src/setup/setup_nsdisc.f90 index da14cf4c6..bb9577f02 100644 --- a/src/setup/setup_nsdisc.f90 +++ b/src/setup/setup_nsdisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_orstang.f90 b/src/setup/setup_orstang.f90 index 137c9854d..04645cf0b 100644 --- a/src/setup/setup_orstang.f90 +++ b/src/setup/setup_orstang.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_params.f90 b/src/setup/setup_params.f90 index f8c3301a5..9be2eadb7 100644 --- a/src/setup/setup_params.f90 +++ b/src/setup/setup_params.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_planetdisc.f90 b/src/setup/setup_planetdisc.f90 index 250b6288c..8e8ecb444 100644 --- a/src/setup/setup_planetdisc.f90 +++ b/src/setup/setup_planetdisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_prtest.f90 b/src/setup/setup_prtest.f90 index 08fd76dfc..4ad6b335a 100644 --- a/src/setup/setup_prtest.f90 +++ b/src/setup/setup_prtest.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_quebec.f90 b/src/setup/setup_quebec.f90 index 795f3813c..0ce9bde95 100644 --- a/src/setup/setup_quebec.f90 +++ b/src/setup/setup_quebec.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_radiativebox.f90 b/src/setup/setup_radiativebox.f90 index 23fa719e8..b30ea361b 100644 --- a/src/setup/setup_radiativebox.f90 +++ b/src/setup/setup_radiativebox.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_sedov.f90 b/src/setup/setup_sedov.f90 index 5c2626949..49884983f 100644 --- a/src/setup/setup_sedov.f90 +++ b/src/setup/setup_sedov.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_shock.F90 b/src/setup/setup_shock.F90 index 3aa5a86b0..478846475 100644 --- a/src/setup/setup_shock.F90 +++ b/src/setup/setup_shock.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_solarsystem.f90 b/src/setup/setup_solarsystem.f90 index 5ccca23ff..5b06d37af 100644 --- a/src/setup/setup_solarsystem.f90 +++ b/src/setup/setup_solarsystem.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_sphereinbox.f90 b/src/setup/setup_sphereinbox.f90 index 2b079ecba..98a4a9156 100644 --- a/src/setup/setup_sphereinbox.f90 +++ b/src/setup/setup_sphereinbox.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_srblast.f90 b/src/setup/setup_srblast.f90 index 8e45ece8d..79e38118b 100644 --- a/src/setup/setup_srblast.f90 +++ b/src/setup/setup_srblast.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_srpolytrope.f90 b/src/setup/setup_srpolytrope.f90 index 4fb8ac843..f387060b3 100644 --- a/src/setup/setup_srpolytrope.f90 +++ b/src/setup/setup_srpolytrope.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 8107fceca..b7fb1d1d8 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_taylorgreen.f90 b/src/setup/setup_taylorgreen.f90 index 27a207eae..32f7ae24d 100644 --- a/src/setup/setup_taylorgreen.f90 +++ b/src/setup/setup_taylorgreen.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_testparticles.F90 b/src/setup/setup_testparticles.F90 index 29fe851c0..edbd8ab47 100644 --- a/src/setup/setup_testparticles.F90 +++ b/src/setup/setup_testparticles.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_tokamak.f90 b/src/setup/setup_tokamak.f90 index 25a2c3af7..6fe6d3ebb 100644 --- a/src/setup/setup_tokamak.f90 +++ b/src/setup/setup_tokamak.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_torus.f90 b/src/setup/setup_torus.f90 index 0a7570b0b..ed8b9470f 100644 --- a/src/setup/setup_torus.f90 +++ b/src/setup/setup_torus.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_turb.f90 b/src/setup/setup_turb.f90 index 5b0b4881e..6910265f4 100644 --- a/src/setup/setup_turb.f90 +++ b/src/setup/setup_turb.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_unifdis.f90 b/src/setup/setup_unifdis.f90 index ae8e7b409..45b2c1abe 100644 --- a/src/setup/setup_unifdis.f90 +++ b/src/setup/setup_unifdis.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_wave.f90 b/src/setup/setup_wave.f90 index e60ff7b5c..3a0816ee0 100644 --- a/src/setup/setup_wave.f90 +++ b/src/setup/setup_wave.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_wavedamp.f90 b/src/setup/setup_wavedamp.f90 index d1ad6ee52..8b6901518 100644 --- a/src/setup/setup_wavedamp.f90 +++ b/src/setup/setup_wavedamp.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_wddisc.f90 b/src/setup/setup_wddisc.f90 index 82d5a0cac..39d9101a1 100644 --- a/src/setup/setup_wddisc.f90 +++ b/src/setup/setup_wddisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_wind.f90 b/src/setup/setup_wind.f90 index a95b35292..012d95aea 100644 --- a/src/setup/setup_wind.f90 +++ b/src/setup/setup_wind.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index 91e0ce7c6..f4df9bffb 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/stretchmap.f90 b/src/setup/stretchmap.f90 index 733c14497..999823e0b 100644 --- a/src/setup/stretchmap.f90 +++ b/src/setup/stretchmap.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/ ! !--------------------------------------------------------------------------! diff --git a/src/setup/velfield_fromcubes.f90 b/src/setup/velfield_fromcubes.f90 index 8388cbb7a..9145c4c04 100644 --- a/src/setup/velfield_fromcubes.f90 +++ b/src/setup/velfield_fromcubes.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/directsum.f90 b/src/tests/directsum.f90 index fe53e38fa..c99024b0c 100644 --- a/src/tests/directsum.f90 +++ b/src/tests/directsum.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/phantomtest.f90 b/src/tests/phantomtest.f90 index b1090e72c..dd310aa6f 100644 --- a/src/tests/phantomtest.f90 +++ b/src/tests/phantomtest.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_cooling.f90 b/src/tests/test_cooling.f90 index 78ac815dd..41db26289 100644 --- a/src/tests/test_cooling.f90 +++ b/src/tests/test_cooling.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 testcooling ! ! :Runtime parameters: None ! -! :Dependencies: chem, cooling_ism, io, part, physcon, testutils, units +! :Dependencies: chem, cooling_ism, cooling_solver, eos, io, options, part, +! physcon, testutils, units ! use testutils, only:checkval,update_test_scores use io, only:id,master diff --git a/src/tests/test_corotate.f90 b/src/tests/test_corotate.f90 index 501442514..95d1d1b00 100644 --- a/src/tests/test_corotate.f90 +++ b/src/tests/test_corotate.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_damping.f90 b/src/tests/test_damping.f90 index 358a0860c..ca00a1b95 100644 --- a/src/tests/test_damping.f90 +++ b/src/tests/test_damping.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_derivs.F90 b/src/tests/test_derivs.F90 index 22d97edb0..4423158f5 100644 --- a/src/tests/test_derivs.F90 +++ b/src/tests/test_derivs.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_dust.F90 b/src/tests/test_dust.F90 index 6b5da7c77..f27bb670a 100644 --- a/src/tests/test_dust.F90 +++ b/src/tests/test_dust.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_eos.f90 b/src/tests/test_eos.f90 index 546e33c53..23a1372a7 100644 --- a/src/tests/test_eos.f90 +++ b/src/tests/test_eos.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/ ! !--------------------------------------------------------------------------! @@ -10,7 +10,7 @@ module testeos ! ! :References: None ! -! :Owner: Terrence Tricco +! :Owner: Daniel Price ! ! :Runtime parameters: None ! diff --git a/src/tests/test_eos_stratified.f90 b/src/tests/test_eos_stratified.f90 index 827540dc1..f8aaf1936 100644 --- a/src/tests/test_eos_stratified.f90 +++ b/src/tests/test_eos_stratified.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_externf.f90 b/src/tests/test_externf.f90 index fe58e1532..f6bb79410 100644 --- a/src/tests/test_externf.f90 +++ b/src/tests/test_externf.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_externf_gr.f90 b/src/tests/test_externf_gr.f90 index 57f621b26..ca7529063 100644 --- a/src/tests/test_externf_gr.f90 +++ b/src/tests/test_externf_gr.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_fastmath.f90 b/src/tests/test_fastmath.f90 index b04bbd1b3..358b25133 100644 --- a/src/tests/test_fastmath.f90 +++ b/src/tests/test_fastmath.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_geometry.f90 b/src/tests/test_geometry.f90 index 2abfd79bc..b32735f05 100644 --- a/src/tests/test_geometry.f90 +++ b/src/tests/test_geometry.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_gnewton.f90 b/src/tests/test_gnewton.f90 index 3757597b4..3dff7afa3 100644 --- a/src/tests/test_gnewton.f90 +++ b/src/tests/test_gnewton.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_gr.f90 b/src/tests/test_gr.f90 index 77e2de2d7..e32beae2d 100644 --- a/src/tests/test_gr.f90 +++ b/src/tests/test_gr.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_gravity.f90 b/src/tests/test_gravity.f90 index 37c46588a..db00c260a 100644 --- a/src/tests/test_gravity.f90 +++ b/src/tests/test_gravity.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_growth.f90 b/src/tests/test_growth.f90 index c30aa7442..68dd5391a 100644 --- a/src/tests/test_growth.f90 +++ b/src/tests/test_growth.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_hierarchical.f90 b/src/tests/test_hierarchical.f90 index a84b3d66b..9d5f6899a 100644 --- a/src/tests/test_hierarchical.f90 +++ b/src/tests/test_hierarchical.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_indtstep.F90 b/src/tests/test_indtstep.F90 index d136ec9f6..30d101661 100644 --- a/src/tests/test_indtstep.F90 +++ b/src/tests/test_indtstep.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_kdtree.F90 b/src/tests/test_kdtree.F90 index 4308c9867..4d5cfa0ab 100644 --- a/src/tests/test_kdtree.F90 +++ b/src/tests/test_kdtree.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_kernel.f90 b/src/tests/test_kernel.f90 index b89c628af..6169a18f7 100644 --- a/src/tests/test_kernel.f90 +++ b/src/tests/test_kernel.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_link.F90 b/src/tests/test_link.F90 index dc3b5566f..95c8a961a 100644 --- a/src/tests/test_link.F90 +++ b/src/tests/test_link.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_luminosity.F90 b/src/tests/test_luminosity.F90 index 04e14d591..dab7dc68f 100644 --- a/src/tests/test_luminosity.F90 +++ b/src/tests/test_luminosity.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_mpi.f90 b/src/tests/test_mpi.f90 index 307bd6851..e318998d9 100644 --- a/src/tests/test_mpi.f90 +++ b/src/tests/test_mpi.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_nonidealmhd.F90 b/src/tests/test_nonidealmhd.F90 index 451bacdd6..e03bab93d 100644 --- a/src/tests/test_nonidealmhd.F90 +++ b/src/tests/test_nonidealmhd.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_part.f90 b/src/tests/test_part.f90 index e0ccb61ed..aa4086b6f 100644 --- a/src/tests/test_part.f90 +++ b/src/tests/test_part.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_poly.f90 b/src/tests/test_poly.f90 index 427d2b5ad..a5bb1b56c 100644 --- a/src/tests/test_poly.f90 +++ b/src/tests/test_poly.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index c5bd0fab6..da894c7f1 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_radiation.f90 b/src/tests/test_radiation.f90 index 45bd857b5..3a72b7e62 100644 --- a/src/tests/test_radiation.f90 +++ b/src/tests/test_radiation.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_rwdump.F90 b/src/tests/test_rwdump.F90 index ba8d425b8..febdb7eb0 100644 --- a/src/tests/test_rwdump.F90 +++ b/src/tests/test_rwdump.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_sedov.F90 b/src/tests/test_sedov.F90 index a70797345..d12efb34a 100644 --- a/src/tests/test_sedov.F90 +++ b/src/tests/test_sedov.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_setdisc.f90 b/src/tests/test_setdisc.f90 index 39c910361..2f7bf026f 100644 --- a/src/tests/test_setdisc.f90 +++ b/src/tests/test_setdisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_smol.F90 b/src/tests/test_smol.F90 index 1f483dd93..7b26c1b65 100644 --- a/src/tests/test_smol.F90 +++ b/src/tests/test_smol.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_step.F90 b/src/tests/test_step.F90 index 2fd468fa7..9bd8f7ad8 100644 --- a/src/tests/test_step.F90 +++ b/src/tests/test_step.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index 164b79c77..26f469604 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index 87841d2a7..01e189eeb 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.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/ ! !--------------------------------------------------------------------------! diff --git a/src/tests/utils_testsuite.f90 b/src/tests/utils_testsuite.f90 index 189cb855f..50f081baa 100644 --- a/src/tests/utils_testsuite.f90 +++ b/src/tests/utils_testsuite.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/acc2ang.f90 b/src/utils/acc2ang.f90 index dc0b2048e..56058bbb5 100644 --- a/src/utils/acc2ang.f90 +++ b/src/utils/acc2ang.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/adaptivemesh.f90 b/src/utils/adaptivemesh.f90 index c2b347fb8..2072329a5 100644 --- a/src/utils/adaptivemesh.f90 +++ b/src/utils/adaptivemesh.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_1particle.f90 b/src/utils/analysis_1particle.f90 index 6c9a48513..eb96fac59 100644 --- a/src/utils/analysis_1particle.f90 +++ b/src/utils/analysis_1particle.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_BRhoOrientation.F90 b/src/utils/analysis_BRhoOrientation.F90 index 9abb5ca50..73170e3e6 100644 --- a/src/utils/analysis_BRhoOrientation.F90 +++ b/src/utils/analysis_BRhoOrientation.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_CoM.f90 b/src/utils/analysis_CoM.f90 index 890797894..199caa247 100644 --- a/src/utils/analysis_CoM.f90 +++ b/src/utils/analysis_CoM.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_GalMerger.f90 b/src/utils/analysis_GalMerger.f90 index 5239c1f23..4dc4d3352 100644 --- a/src/utils/analysis_GalMerger.f90 +++ b/src/utils/analysis_GalMerger.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_MWpdf.f90 b/src/utils/analysis_MWpdf.f90 index eab4a122c..84f49013c 100644 --- a/src/utils/analysis_MWpdf.f90 +++ b/src/utils/analysis_MWpdf.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_NSmerger.f90 b/src/utils/analysis_NSmerger.f90 index 957f35983..053402dff 100644 --- a/src/utils/analysis_NSmerger.f90 +++ b/src/utils/analysis_NSmerger.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_alpha.f90 b/src/utils/analysis_alpha.f90 index e2036f989..d96f6fe49 100644 --- a/src/utils/analysis_alpha.f90 +++ b/src/utils/analysis_alpha.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_angmom.f90 b/src/utils/analysis_angmom.f90 index bdeecc687..f27a87c2c 100644 --- a/src/utils/analysis_angmom.f90 +++ b/src/utils/analysis_angmom.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_angmomvec.f90 b/src/utils/analysis_angmomvec.f90 index 2a0d76b7f..31c6d6c3d 100644 --- a/src/utils/analysis_angmomvec.f90 +++ b/src/utils/analysis_angmomvec.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_average_orb_en.f90 b/src/utils/analysis_average_orb_en.f90 index 56a9ca69f..f9c99a3af 100644 --- a/src/utils/analysis_average_orb_en.f90 +++ b/src/utils/analysis_average_orb_en.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_binarydisc.f90 b/src/utils/analysis_binarydisc.f90 index c4a66dc94..0894b7133 100644 --- a/src/utils/analysis_binarydisc.f90 +++ b/src/utils/analysis_binarydisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_bzrms.f90 b/src/utils/analysis_bzrms.f90 index 81f38be88..e5b6443e2 100644 --- a/src/utils/analysis_bzrms.f90 +++ b/src/utils/analysis_bzrms.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_clumpfind.F90 b/src/utils/analysis_clumpfind.F90 index f75bea93b..697a4e1c1 100644 --- a/src/utils/analysis_clumpfind.F90 +++ b/src/utils/analysis_clumpfind.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_clumpfindWB23.F90 b/src/utils/analysis_clumpfindWB23.F90 index f6a5cd3d6..da430b9ff 100644 --- a/src/utils/analysis_clumpfindWB23.F90 +++ b/src/utils/analysis_clumpfindWB23.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_collidingcloudevolution.f90 b/src/utils/analysis_collidingcloudevolution.f90 index 49db64b2e..52cfdec52 100644 --- a/src/utils/analysis_collidingcloudevolution.f90 +++ b/src/utils/analysis_collidingcloudevolution.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_collidingcloudhistograms.f90 b/src/utils/analysis_collidingcloudhistograms.f90 index 4bf17b21d..c17daaddb 100644 --- a/src/utils/analysis_collidingcloudhistograms.f90 +++ b/src/utils/analysis_collidingcloudhistograms.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index d5080a7b4..86ee7cb4f 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_cooling.f90 b/src/utils/analysis_cooling.f90 index f2c83cd2f..ed70fc07e 100644 --- a/src/utils/analysis_cooling.f90 +++ b/src/utils/analysis_cooling.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_disc.f90 b/src/utils/analysis_disc.f90 index e284dc8cf..1f3e9f07f 100644 --- a/src/utils/analysis_disc.f90 +++ b/src/utils/analysis_disc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_disc_MFlow.f90 b/src/utils/analysis_disc_MFlow.f90 index 341a1b4d1..9cb995cae 100644 --- a/src/utils/analysis_disc_MFlow.f90 +++ b/src/utils/analysis_disc_MFlow.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_disc_eccentric.f90 b/src/utils/analysis_disc_eccentric.f90 index 6c242ed30..caf029f94 100644 --- a/src/utils/analysis_disc_eccentric.f90 +++ b/src/utils/analysis_disc_eccentric.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_disc_mag.f90 b/src/utils/analysis_disc_mag.f90 index 79e87352e..10f91136d 100644 --- a/src/utils/analysis_disc_mag.f90 +++ b/src/utils/analysis_disc_mag.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_disc_planet.f90 b/src/utils/analysis_disc_planet.f90 index b582ac50b..aad84a586 100644 --- a/src/utils/analysis_disc_planet.f90 +++ b/src/utils/analysis_disc_planet.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index e0acf7e43..f6ffe0648 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_dtheader.f90 b/src/utils/analysis_dtheader.f90 index 3d2fe285a..d36b73452 100644 --- a/src/utils/analysis_dtheader.f90 +++ b/src/utils/analysis_dtheader.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_dustformation.f90 b/src/utils/analysis_dustformation.f90 index 353a39b1b..9eaa95ee3 100644 --- a/src/utils/analysis_dustformation.f90 +++ b/src/utils/analysis_dustformation.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_dustmass.f90 b/src/utils/analysis_dustmass.f90 index eedb3cbf9..a072aedbe 100644 --- a/src/utils/analysis_dustmass.f90 +++ b/src/utils/analysis_dustmass.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_dustydisc.f90 b/src/utils/analysis_dustydisc.f90 index e4fbf91b4..c7f2d879b 100644 --- a/src/utils/analysis_dustydisc.f90 +++ b/src/utils/analysis_dustydisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_dustywind.f90 b/src/utils/analysis_dustywind.f90 index 2b4b675e3..74f071edb 100644 --- a/src/utils/analysis_dustywind.f90 +++ b/src/utils/analysis_dustywind.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_etotgr.f90 b/src/utils/analysis_etotgr.f90 index f0c2f50a3..be1a500aa 100644 --- a/src/utils/analysis_etotgr.f90 +++ b/src/utils/analysis_etotgr.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_getneighbours.f90 b/src/utils/analysis_getneighbours.f90 index b8a617ef5..fb20606c7 100644 --- a/src/utils/analysis_getneighbours.f90 +++ b/src/utils/analysis_getneighbours.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_gws.f90 b/src/utils/analysis_gws.f90 index 0a4dc055d..9be0e4330 100644 --- a/src/utils/analysis_gws.f90 +++ b/src/utils/analysis_gws.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_jet.f90 b/src/utils/analysis_jet.f90 index 6dd31f949..86c86dca8 100644 --- a/src/utils/analysis_jet.f90 +++ b/src/utils/analysis_jet.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_kdtree.F90 b/src/utils/analysis_kdtree.F90 index cdf614797..ef83ee5e3 100644 --- a/src/utils/analysis_kdtree.F90 +++ b/src/utils/analysis_kdtree.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_kepler.f90 b/src/utils/analysis_kepler.f90 index 756a28bfa..e6e63d942 100644 --- a/src/utils/analysis_kepler.f90 +++ b/src/utils/analysis_kepler.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_macctrace.f90 b/src/utils/analysis_macctrace.f90 index 4c012b6e0..26b1e224c 100644 --- a/src/utils/analysis_macctrace.f90 +++ b/src/utils/analysis_macctrace.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_mapping_mass.f90 b/src/utils/analysis_mapping_mass.f90 index 0a440b13d..892b5fb4c 100644 --- a/src/utils/analysis_mapping_mass.f90 +++ b/src/utils/analysis_mapping_mass.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_mcfost.f90 b/src/utils/analysis_mcfost.f90 index 29b0e71f0..05259161b 100644 --- a/src/utils/analysis_mcfost.f90 +++ b/src/utils/analysis_mcfost.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_mcfostcmdline.f90 b/src/utils/analysis_mcfostcmdline.f90 index 495828ced..2e3b10dc9 100644 --- a/src/utils/analysis_mcfostcmdline.f90 +++ b/src/utils/analysis_mcfostcmdline.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_pairing.f90 b/src/utils/analysis_pairing.f90 index a2d8a01b0..fbef57fe5 100644 --- a/src/utils/analysis_pairing.f90 +++ b/src/utils/analysis_pairing.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_particle.f90 b/src/utils/analysis_particle.f90 index fa3a06feb..5691ff0a9 100644 --- a/src/utils/analysis_particle.f90 +++ b/src/utils/analysis_particle.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_pdfs.f90 b/src/utils/analysis_pdfs.f90 index 3bc97092e..96c64fc73 100644 --- a/src/utils/analysis_pdfs.f90 +++ b/src/utils/analysis_pdfs.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_phantom_dump.f90 b/src/utils/analysis_phantom_dump.f90 index ddc26a7a6..0ffc60048 100644 --- a/src/utils/analysis_phantom_dump.f90 +++ b/src/utils/analysis_phantom_dump.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_polytropes.f90 b/src/utils/analysis_polytropes.f90 index 9054cbb44..bd0c57df8 100644 --- a/src/utils/analysis_polytropes.f90 +++ b/src/utils/analysis_polytropes.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_prdrag.f90 b/src/utils/analysis_prdrag.f90 index 05e8d9fa0..14160df8a 100644 --- a/src/utils/analysis_prdrag.f90 +++ b/src/utils/analysis_prdrag.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_protostar_environ.F90 b/src/utils/analysis_protostar_environ.F90 index e23faa0dd..6ac1dcd41 100644 --- a/src/utils/analysis_protostar_environ.F90 +++ b/src/utils/analysis_protostar_environ.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_ptmass.f90 b/src/utils/analysis_ptmass.f90 index 431ba7445..85477e1d4 100644 --- a/src/utils/analysis_ptmass.f90 +++ b/src/utils/analysis_ptmass.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index b994822d8..bef969001 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index 3ca1cd8a6..2a8305c9e 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_sinkmass.f90 b/src/utils/analysis_sinkmass.f90 index 03e4a60cf..7993d3664 100644 --- a/src/utils/analysis_sinkmass.f90 +++ b/src/utils/analysis_sinkmass.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_sphere.f90 b/src/utils/analysis_sphere.f90 index 2ea8d5320..837a5257a 100644 --- a/src/utils/analysis_sphere.f90 +++ b/src/utils/analysis_sphere.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_structurefn.f90 b/src/utils/analysis_structurefn.f90 index 73a2d7ffe..0e91bedde 100644 --- a/src/utils/analysis_structurefn.f90 +++ b/src/utils/analysis_structurefn.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_tde.f90 b/src/utils/analysis_tde.f90 index 746661e92..e0aa5ae7e 100644 --- a/src/utils/analysis_tde.f90 +++ b/src/utils/analysis_tde.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_torus.f90 b/src/utils/analysis_torus.f90 index 82e33695e..f6a745703 100644 --- a/src/utils/analysis_torus.f90 +++ b/src/utils/analysis_torus.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_trackbox.f90 b/src/utils/analysis_trackbox.f90 index ab3d23ba8..efbe6e251 100644 --- a/src/utils/analysis_trackbox.f90 +++ b/src/utils/analysis_trackbox.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_tracks.f90 b/src/utils/analysis_tracks.f90 index 5efa306a7..3812cc3b4 100644 --- a/src/utils/analysis_tracks.f90 +++ b/src/utils/analysis_tracks.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_velocitydispersion_vs_scale.f90 b/src/utils/analysis_velocitydispersion_vs_scale.f90 index 7c7ff311c..7bd2daa9d 100644 --- a/src/utils/analysis_velocitydispersion_vs_scale.f90 +++ b/src/utils/analysis_velocitydispersion_vs_scale.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_velocityshear.f90 b/src/utils/analysis_velocityshear.f90 index 8fdd9059b..16637d2d6 100644 --- a/src/utils/analysis_velocityshear.f90 +++ b/src/utils/analysis_velocityshear.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/analysis_write_kdtree.F90 b/src/utils/analysis_write_kdtree.F90 index f0f161286..a185c915d 100644 --- a/src/utils/analysis_write_kdtree.F90 +++ b/src/utils/analysis_write_kdtree.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/combinedustdumps.f90 b/src/utils/combinedustdumps.f90 index d12b32677..7dbbdf2d5 100755 --- a/src/utils/combinedustdumps.f90 +++ b/src/utils/combinedustdumps.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/cubicsolve.f90 b/src/utils/cubicsolve.f90 index feb34185f..3d88f97f5 100644 --- a/src/utils/cubicsolve.f90 +++ b/src/utils/cubicsolve.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/diffdumps.f90 b/src/utils/diffdumps.f90 index 43f984310..9423c6960 100644 --- a/src/utils/diffdumps.f90 +++ b/src/utils/diffdumps.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/dustywaves.f90 b/src/utils/dustywaves.f90 index 77aa7b1c4..2d671513f 100644 --- a/src/utils/dustywaves.f90 +++ b/src/utils/dustywaves.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index 7d436fd0a..6ec6668ef 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index ede060fcf..8bd6b847b 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/ev2kdot.f90 b/src/utils/ev2kdot.f90 index 1b3231c77..dced7d521 100644 --- a/src/utils/ev2kdot.f90 +++ b/src/utils/ev2kdot.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/ev2mdot.f90 b/src/utils/ev2mdot.f90 index 7376ef84d..40374442b 100644 --- a/src/utils/ev2mdot.f90 +++ b/src/utils/ev2mdot.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/evol_dustywaves.f90 b/src/utils/evol_dustywaves.f90 index 324bb0199..e9584604c 100644 --- a/src/utils/evol_dustywaves.f90 +++ b/src/utils/evol_dustywaves.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/get_struct_slope.f90 b/src/utils/get_struct_slope.f90 index 8768ff985..789e39854 100644 --- a/src/utils/get_struct_slope.f90 +++ b/src/utils/get_struct_slope.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/getmathflags.f90 b/src/utils/getmathflags.f90 index 463208c2c..fbe9f872e 100644 --- a/src/utils/getmathflags.f90 +++ b/src/utils/getmathflags.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/grid2pdf.f90 b/src/utils/grid2pdf.f90 index 61da9786a..8ae7ad563 100644 --- a/src/utils/grid2pdf.f90 +++ b/src/utils/grid2pdf.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/hdf5utils.f90 b/src/utils/hdf5utils.f90 index e11c6a574..34031f068 100644 --- a/src/utils/hdf5utils.f90 +++ b/src/utils/hdf5utils.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/icosahedron.f90 b/src/utils/icosahedron.f90 index 08b27b32d..d0b00c594 100644 --- a/src/utils/icosahedron.f90 +++ b/src/utils/icosahedron.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.F90 index ba9eac4c7..1a6d0d75e 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/interpolate3D_amr.F90 b/src/utils/interpolate3D_amr.F90 index ec65a2395..49a9eb8b7 100644 --- a/src/utils/interpolate3D_amr.F90 +++ b/src/utils/interpolate3D_amr.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/io_grid.f90 b/src/utils/io_grid.f90 index 157e3d32c..a54cec7fe 100644 --- a/src/utils/io_grid.f90 +++ b/src/utils/io_grid.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/io_structurefn.f90 b/src/utils/io_structurefn.f90 index c4f58d898..ca736c360 100644 --- a/src/utils/io_structurefn.f90 +++ b/src/utils/io_structurefn.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/leastsquares.f90 b/src/utils/leastsquares.f90 index 4f7228b94..f71fd3473 100644 --- a/src/utils/leastsquares.f90 +++ b/src/utils/leastsquares.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/libphantom-splash.f90 b/src/utils/libphantom-splash.f90 index 3a470b943..2c0fc772a 100644 --- a/src/utils/libphantom-splash.f90 +++ b/src/utils/libphantom-splash.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/lombperiod.f90 b/src/utils/lombperiod.f90 index f51c4108a..d9b7a668e 100644 --- a/src/utils/lombperiod.f90 +++ b/src/utils/lombperiod.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/mflow.f90 b/src/utils/mflow.f90 index 830f82c9d..ea284e3fa 100644 --- a/src/utils/mflow.f90 +++ b/src/utils/mflow.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_CoM.f90 b/src/utils/moddump_CoM.f90 index 0b2840d85..72df6ef41 100644 --- a/src/utils/moddump_CoM.f90 +++ b/src/utils/moddump_CoM.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_addflyby.f90 b/src/utils/moddump_addflyby.f90 index f131ada10..59bb9ca36 100644 --- a/src/utils/moddump_addflyby.f90 +++ b/src/utils/moddump_addflyby.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_addplanets.f90 b/src/utils/moddump_addplanets.f90 index 17b34a18f..9f913bb0c 100644 --- a/src/utils/moddump_addplanets.f90 +++ b/src/utils/moddump_addplanets.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_binary.f90 b/src/utils/moddump_binary.f90 index f7b376871..c4c1077c3 100644 --- a/src/utils/moddump_binary.f90 +++ b/src/utils/moddump_binary.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_binarystar.f90 b/src/utils/moddump_binarystar.f90 index 4d7d9e49b..4e15def00 100644 --- a/src/utils/moddump_binarystar.f90 +++ b/src/utils/moddump_binarystar.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_changemass.f90 b/src/utils/moddump_changemass.f90 index 0c2fc022e..a407d17e7 100644 --- a/src/utils/moddump_changemass.f90 +++ b/src/utils/moddump_changemass.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_default.f90 b/src/utils/moddump_default.f90 index 44ea7de38..0ae0f2a97 100644 --- a/src/utils/moddump_default.f90 +++ b/src/utils/moddump_default.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_disc.f90 b/src/utils/moddump_disc.f90 index df393c926..13a7bd473 100644 --- a/src/utils/moddump_disc.f90 +++ b/src/utils/moddump_disc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_dustadd.f90 b/src/utils/moddump_dustadd.f90 index f145b5e68..4df9d4c2a 100644 --- a/src/utils/moddump_dustadd.f90 +++ b/src/utils/moddump_dustadd.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_extenddisc.f90 b/src/utils/moddump_extenddisc.f90 index 73759d3ef..1f16281da 100644 --- a/src/utils/moddump_extenddisc.f90 +++ b/src/utils/moddump_extenddisc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_growthtomultigrain.f90 b/src/utils/moddump_growthtomultigrain.f90 index 0eb70bbda..0c5e599df 100644 --- a/src/utils/moddump_growthtomultigrain.f90 +++ b/src/utils/moddump_growthtomultigrain.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_mergepart.f90 b/src/utils/moddump_mergepart.f90 index 0a3513e63..17d42b67b 100644 --- a/src/utils/moddump_mergepart.f90 +++ b/src/utils/moddump_mergepart.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_messupSPH.f90 b/src/utils/moddump_messupSPH.f90 index f89ebb1e2..1f0b8a257 100644 --- a/src/utils/moddump_messupSPH.f90 +++ b/src/utils/moddump_messupSPH.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_perturbgas.f90 b/src/utils/moddump_perturbgas.f90 index dd5ab7326..8e895aafa 100644 --- a/src/utils/moddump_perturbgas.f90 +++ b/src/utils/moddump_perturbgas.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_polytrope.f90 b/src/utils/moddump_polytrope.f90 index 7a7195788..ed9554b90 100644 --- a/src/utils/moddump_polytrope.f90 +++ b/src/utils/moddump_polytrope.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_rad_to_LTE.f90 b/src/utils/moddump_rad_to_LTE.f90 index 1c93efd4d..6eff8ac4c 100644 --- a/src/utils/moddump_rad_to_LTE.f90 +++ b/src/utils/moddump_rad_to_LTE.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index b64612288..ab4ab6bfe 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_recalcuT.f90 b/src/utils/moddump_recalcuT.f90 index fe673eb37..814c275cf 100644 --- a/src/utils/moddump_recalcuT.f90 +++ b/src/utils/moddump_recalcuT.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_removeparticles_cylinder.f90 b/src/utils/moddump_removeparticles_cylinder.f90 index 6f2de9da1..eed6b214f 100644 --- a/src/utils/moddump_removeparticles_cylinder.f90 +++ b/src/utils/moddump_removeparticles_cylinder.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_removeparticles_radius.f90 b/src/utils/moddump_removeparticles_radius.f90 index dd9ada106..d123b0068 100644 --- a/src/utils/moddump_removeparticles_radius.f90 +++ b/src/utils/moddump_removeparticles_radius.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_rotate.f90 b/src/utils/moddump_rotate.f90 index 25689954c..34a6a069f 100644 --- a/src/utils/moddump_rotate.f90 +++ b/src/utils/moddump_rotate.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_sink.f90 b/src/utils/moddump_sink.f90 index faceeda4d..444a45e22 100644 --- a/src/utils/moddump_sink.f90 +++ b/src/utils/moddump_sink.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_sinkbinary.f90 b/src/utils/moddump_sinkbinary.f90 index 52283052a..46a128db7 100644 --- a/src/utils/moddump_sinkbinary.f90 +++ b/src/utils/moddump_sinkbinary.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_sphNG2phantom.f90 b/src/utils/moddump_sphNG2phantom.f90 index c344d0840..ad1b1feb7 100644 --- a/src/utils/moddump_sphNG2phantom.f90 +++ b/src/utils/moddump_sphNG2phantom.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_sphNG2phantom_addBfield.f90 b/src/utils/moddump_sphNG2phantom_addBfield.f90 index bb34829d8..e33c1cb92 100644 --- a/src/utils/moddump_sphNG2phantom_addBfield.f90 +++ b/src/utils/moddump_sphNG2phantom_addBfield.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_sphNG2phantom_disc.f90 b/src/utils/moddump_sphNG2phantom_disc.f90 index edc12f35d..833b765cf 100644 --- a/src/utils/moddump_sphNG2phantom_disc.f90 +++ b/src/utils/moddump_sphNG2phantom_disc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_splitpart.f90 b/src/utils/moddump_splitpart.f90 index c55368973..9f932cffc 100644 --- a/src/utils/moddump_splitpart.f90 +++ b/src/utils/moddump_splitpart.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_taylorgreen.f90 b/src/utils/moddump_taylorgreen.f90 index fd1613dcd..f165d49b6 100644 --- a/src/utils/moddump_taylorgreen.f90 +++ b/src/utils/moddump_taylorgreen.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_tidal.f90 b/src/utils/moddump_tidal.f90 index 4eacbe666..a4a1b4b51 100644 --- a/src/utils/moddump_tidal.f90 +++ b/src/utils/moddump_tidal.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/moddump_torus.f90 b/src/utils/moddump_torus.f90 index 7cc782ebc..3de87ae9a 100644 --- a/src/utils/moddump_torus.f90 +++ b/src/utils/moddump_torus.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/multirun.f90 b/src/utils/multirun.f90 index 6085a8a50..5536cdcf5 100644 --- a/src/utils/multirun.f90 +++ b/src/utils/multirun.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/multirun_mach.f90 b/src/utils/multirun_mach.f90 index 5b189a9e0..df2cb5b97 100644 --- a/src/utils/multirun_mach.f90 +++ b/src/utils/multirun_mach.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/pdfs.f90 b/src/utils/pdfs.f90 index 0ae12f9e7..fd306041d 100644 --- a/src/utils/pdfs.f90 +++ b/src/utils/pdfs.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/phantom2divb.f90 b/src/utils/phantom2divb.f90 index 9386bb51d..cac56bccd 100644 --- a/src/utils/phantom2divb.f90 +++ b/src/utils/phantom2divb.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/phantom2divv.f90 b/src/utils/phantom2divv.f90 index ee90b8be5..0befaad7d 100644 --- a/src/utils/phantom2divv.f90 +++ b/src/utils/phantom2divv.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/phantom2gadget.f90 b/src/utils/phantom2gadget.f90 index c499197b8..1681ff9cc 100644 --- a/src/utils/phantom2gadget.f90 +++ b/src/utils/phantom2gadget.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/phantom2hdf5.f90 b/src/utils/phantom2hdf5.f90 index b332ce44c..d4d032e0c 100644 --- a/src/utils/phantom2hdf5.f90 +++ b/src/utils/phantom2hdf5.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/phantom2sphNG.f90 b/src/utils/phantom2sphNG.f90 index ac6079b09..b4532fbef 100644 --- a/src/utils/phantom2sphNG.f90 +++ b/src/utils/phantom2sphNG.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/phantom_moddump.f90 b/src/utils/phantom_moddump.f90 index fccf96931..a6ed9bb0d 100644 --- a/src/utils/phantom_moddump.f90 +++ b/src/utils/phantom_moddump.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/phantomanalysis.f90 b/src/utils/phantomanalysis.f90 index 1e444dbf1..a0b88c2d2 100644 --- a/src/utils/phantomanalysis.f90 +++ b/src/utils/phantomanalysis.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/phantomevcompare.f90 b/src/utils/phantomevcompare.f90 index 42a9c32b1..8a0d15062 100644 --- a/src/utils/phantomevcompare.f90 +++ b/src/utils/phantomevcompare.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/phantomextractsinks.f90 b/src/utils/phantomextractsinks.f90 index 04b83cce5..1e4577fde 100644 --- a/src/utils/phantomextractsinks.f90 +++ b/src/utils/phantomextractsinks.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/plot_kernel.f90 b/src/utils/plot_kernel.f90 index 4973d3d5b..35b176884 100644 --- a/src/utils/plot_kernel.f90 +++ b/src/utils/plot_kernel.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/powerspectrums.f90 b/src/utils/powerspectrums.f90 index 1e65bc262..0ffd56515 100644 --- a/src/utils/powerspectrums.f90 +++ b/src/utils/powerspectrums.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/prompting.f90 b/src/utils/prompting.f90 index 1462eb885..c87e5f77c 100644 --- a/src/utils/prompting.f90 +++ b/src/utils/prompting.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/quartic.f90 b/src/utils/quartic.f90 index 83afe6690..4ae9ee375 100644 --- a/src/utils/quartic.f90 +++ b/src/utils/quartic.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/rhomach.f90 b/src/utils/rhomach.f90 index 956d246b5..8164eb3a2 100644 --- a/src/utils/rhomach.f90 +++ b/src/utils/rhomach.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/showarrays.f90 b/src/utils/showarrays.f90 index 252c3c05d..64762b59c 100644 --- a/src/utils/showarrays.f90 +++ b/src/utils/showarrays.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/showheader.f90 b/src/utils/showheader.f90 index bb355bc9b..b70b1a884 100644 --- a/src/utils/showheader.f90 +++ b/src/utils/showheader.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/solvelinearsystem.f90 b/src/utils/solvelinearsystem.f90 index ed2c26f5b..fefb6c08e 100644 --- a/src/utils/solvelinearsystem.f90 +++ b/src/utils/solvelinearsystem.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/splitpart.f90 b/src/utils/splitpart.f90 index a63a5a928..c6847e607 100644 --- a/src/utils/splitpart.f90 +++ b/src/utils/splitpart.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/struct2struct.f90 b/src/utils/struct2struct.f90 index 2ba0b54c2..2d22707f3 100644 --- a/src/utils/struct2struct.f90 +++ b/src/utils/struct2struct.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/struct_part.f90 b/src/utils/struct_part.f90 index ef585f97f..99640148d 100644 --- a/src/utils/struct_part.f90 +++ b/src/utils/struct_part.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/test_binary.f90 b/src/utils/test_binary.f90 index 1f08f57e0..4dd432524 100644 --- a/src/utils/test_binary.f90 +++ b/src/utils/test_binary.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/testbinary.f90 b/src/utils/testbinary.f90 index d31988c25..f7da761f8 100644 --- a/src/utils/testbinary.f90 +++ b/src/utils/testbinary.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/utils_disc.f90 b/src/utils/utils_disc.f90 index 02f994a27..91b783c29 100644 --- a/src/utils/utils_disc.f90 +++ b/src/utils/utils_disc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/utils_ephemeris.f90 b/src/utils/utils_ephemeris.f90 index fb3a72322..c6d0a689c 100644 --- a/src/utils/utils_ephemeris.f90 +++ b/src/utils/utils_ephemeris.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/utils_evfiles.f90 b/src/utils/utils_evfiles.f90 index ece09037e..515da58e6 100644 --- a/src/utils/utils_evfiles.f90 +++ b/src/utils/utils_evfiles.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/utils_getneighbours.F90 b/src/utils/utils_getneighbours.F90 index 2c1dd26f2..0e889d282 100644 --- a/src/utils/utils_getneighbours.F90 +++ b/src/utils/utils_getneighbours.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/utils_gravwave.f90 b/src/utils/utils_gravwave.f90 index ed0c0ddcb..225f091b6 100644 --- a/src/utils/utils_gravwave.f90 +++ b/src/utils/utils_gravwave.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/utils_linalg.f90 b/src/utils/utils_linalg.f90 index e1b2e5bac..c4c6c22bd 100644 --- a/src/utils/utils_linalg.f90 +++ b/src/utils/utils_linalg.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/utils_mpc.f90 b/src/utils/utils_mpc.f90 index 7b6489ddc..3a90abd94 100644 --- a/src/utils/utils_mpc.f90 +++ b/src/utils/utils_mpc.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/utils_orbits.f90 b/src/utils/utils_orbits.f90 index 00ba9ea53..a92cd3da9 100644 --- a/src/utils/utils_orbits.f90 +++ b/src/utils/utils_orbits.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/utils_raytracer_all.f90 b/src/utils/utils_raytracer_all.f90 index 3fbbbdae8..a257b00c4 100644 --- a/src/utils/utils_raytracer_all.f90 +++ b/src/utils/utils_raytracer_all.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/utils_splitmerge.f90 b/src/utils/utils_splitmerge.f90 index 4f740734f..87ec4670c 100644 --- a/src/utils/utils_splitmerge.f90 +++ b/src/utils/utils_splitmerge.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/ ! !--------------------------------------------------------------------------! diff --git a/src/utils/velfield.f90 b/src/utils/velfield.f90 index 564c8badb..4792a65f7 100644 --- a/src/utils/velfield.f90 +++ b/src/utils/velfield.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/ ! !--------------------------------------------------------------------------! From 59fe9e00dae54cf45e935d159471470931e86173 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 29 Jan 2024 20:32:49 +1100 Subject: [PATCH 270/814] [author-bot] updated AUTHORS file --- AUTHORS | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/AUTHORS b/AUTHORS index 6fe8b175e..c7c448d44 100644 --- a/AUTHORS +++ b/AUTHORS @@ -32,8 +32,8 @@ Sergei Biriukov Cristiano Longarini Giovanni Dipierro Roberto Iaconi -Amena Faruqi Hauke Worpel +Amena Faruqi Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani @@ -43,26 +43,26 @@ Simon Glover Thomas Reichardt Jean-François Gonzalez Christopher Russell +Phantom benchmark bot Alessia Franchini -Alex Pettitt Jolien Malfait -Phantom benchmark bot -Kieran Hirsh +Alex Pettitt Nicole Rodrigues +Kieran Hirsh David Trevascus -Farzana Meru Nicolás Cuello +Farzana Meru Chris Nixon Miguel Gonzalez-Bolivar +Mike Lau Benoit Commercon +Orsola De Marco Giulia Ballabio -Joe Fisher Maxime Lombart -Mike Lau -Orsola De Marco +Joe Fisher Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> Cox, Samuel -Jorge Cuadra Steven Rieder Stéven Toupin +Jorge Cuadra From 2a52111a40144ac092db601842f984a66dda803c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 29 Jan 2024 20:33:40 +1100 Subject: [PATCH 271/814] [indent-bot] standardised indentation --- src/utils/struct_part.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/utils/struct_part.f90 b/src/utils/struct_part.f90 index 99640148d..781a3c2fd 100644 --- a/src/utils/struct_part.f90 +++ b/src/utils/struct_part.f90 @@ -149,10 +149,10 @@ subroutine get_structure_fn(sf,nbins,norder,distmin,distmax,xbins,ncount,npart,x !$omp reduction(+:sf) do ipt=1,npts !$ if (.false.) then - if (mod(ipt,100)==0) then - call cpu_time(tcpu2) - print*,' ipt = ',ipt,tcpu2-tcpu1 - endif + if (mod(ipt,100)==0) then + call cpu_time(tcpu2) + print*,' ipt = ',ipt,tcpu2-tcpu1 + endif !$ endif i = list(ipt) xpt(1) = xyz(1,i) From 5802f8337ea0c9d0340df43fb869f194bc7bcf96 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 29 Jan 2024 20:36:58 +1100 Subject: [PATCH 272/814] auto-update docs --- docs/eos-list.rst | 4 ++-- docs/setups-list.rst | 14 +++++++++++--- docs/sink-properties.rst | 2 ++ 3 files changed, 15 insertions(+), 5 deletions(-) diff --git a/docs/eos-list.rst b/docs/eos-list.rst index 1975d7a4b..bd0d4ba50 100644 --- a/docs/eos-list.rst +++ b/docs/eos-list.rst @@ -7,8 +7,8 @@ | | | | | where :math:`c_s^2 \equiv K` is a constant stored in the dump file header | | | | -+-----------+----------------------------------------------------------------------------------+ -| 2 | **Adiabatic equation of state (code default)** | +| | | +| | Adiabatic equation of state (code default) | | | | | | :math:`P = (\gamma - 1) \rho u` | | | | diff --git a/docs/setups-list.rst b/docs/setups-list.rst index 18f054c35..b98b1fc47 100644 --- a/docs/setups-list.rst +++ b/docs/setups-list.rst @@ -15,7 +15,7 @@ +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | asteroidwind | asteroid emitting a wind (Trevascus et al. 2021) | isothermal | `setup_asteroidwind.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| balsarakim | Balsara-Kim 2004 | MHD, H2 Chemistry, periodic | `setup_unifdis.f90 `__ | +| balsarakim | Balsara-Kim 2004 | MHD, periodic | `setup_unifdis.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | binary | binary stars | self-gravity | `setup_binary.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ @@ -61,11 +61,15 @@ +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | firehose | injection of a stream of gas as a firehose | | `setup_firehose.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ +| flrw | constant density FLRW cosmology with perturbations | GR, et, periodic | `setup_flrw.f90 `__ | ++------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ +| flrwpspec | FLRW universe using a CMB powerspectrum and the Zeldovich approximation | GR, et, periodic | `setup_flrwpspec.f90 `__ | ++------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | galaxies | galaxy merger using data from Wurster & Thacker (2013a,b) | self-gravity | `setup_galaxies.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | galcen | galactic centre | | `setup_galcen_stars.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| galdisc | galactic disc simulations | H2 Chemistry | `setup_galdisc.f90 `__ | +| galdisc | galactic disc simulations | | `setup_galdisc.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | galdiscmhd | galactic disc simulations with magnetic fields | MHD, isothermal | `setup_galdisc.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ @@ -89,7 +93,7 @@ +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | hierarchical | hierarchical system setup | | `setup_hierarchical.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| ismwind | wind setup with dust nucleation and ISM cooling | H2 Chemistry | `setup_wind.f90 `__ | +| ismwind | wind setup with dust nucleation and ISM cooling | | `setup_wind.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | isosgdisc | isothermal self-gravitating disc | self-gravity, disc viscosity, isothermal | `setup_disc.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ @@ -143,6 +147,8 @@ +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | radiativebox | test of radiation coupling terms | radiation, periodic | `setup_radiativebox.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ +| radiotde | radio tidal disruption event in general relativity | GR, minkowski, no | `setup_unifdis.f90 `__ | ++------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | radshock | shock tube in radiation hydrodynamics | radiation, periodic | `setup_shock.F90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | radstar | setup a star as in the star setup but with radiation | self-gravity, radiation | `setup_star.f90 `__ | @@ -211,4 +217,6 @@ +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | wind | wind setup with dust nucleation | | `setup_wind.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ +| windtunnel | Wind tunnel setup | self-gravity | `setup_windtunnel.f90 `__ | ++------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ diff --git a/docs/sink-properties.rst b/docs/sink-properties.rst index b97e2817a..a8cf9a190 100644 --- a/docs/sink-properties.rst +++ b/docs/sink-properties.rst @@ -29,3 +29,5 @@ +-----------+------------------------------------------+ | imassenc | mass enclosed in sink softening radius | +-----------+------------------------------------------+ +| iJ2 | 2nd gravity moment due to oblateness | ++-----------+------------------------------------------+ From ff666ce4b5e5b26415c007754cec49b8e9ed8fc4 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 29 Jan 2024 20:41:41 +1100 Subject: [PATCH 273/814] (v2024) bump version numbers --- Makefile | 3 +-- build/Makefile | 6 ++---- docs/conf.py | 6 +++--- 3 files changed, 6 insertions(+), 9 deletions(-) diff --git a/Makefile b/Makefile index 220310c59..c265534c9 100644 --- a/Makefile +++ b/Makefile @@ -4,9 +4,8 @@ # # See build/Makefile for the main Makefile # -# (c) 2007-2023 The Authors (see AUTHORS) +# (c) 2007-2024 The Authors (see AUTHORS) # -# $Id: Makefile,v 98b9fad01f38 2013/03/25 23:02:49 daniel $ #---------------------------------------------------------------- .PHONY: phantom diff --git a/build/Makefile b/build/Makefile index 0ad8b8353..e87f32ad6 100644 --- a/build/Makefile +++ b/build/Makefile @@ -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://users.monash.edu.au/~dprice/phantom ! #--------------------------------------------------------------------------! @@ -14,14 +14,12 @@ # the SETUP variable # # OWNER: Daniel Price -# -# $Id: 2788b71b1c08e560e77dce9849c5cb24a668f4b9 $ #+ #-------------------------------------------------------------------------- .KEEP_STATE: -PHANTOM_VERSION_MAJOR=2023 +PHANTOM_VERSION_MAJOR=2024 PHANTOM_VERSION_MINOR=0 PHANTOM_VERSION_MICRO=0 VERSION=$(PHANTOM_VERSION_MAJOR).$(PHANTOM_VERSION_MINOR).$(PHANTOM_VERSION_MICRO) diff --git a/docs/conf.py b/docs/conf.py index 0fc6cd05d..f714b296b 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -20,13 +20,13 @@ # -- Project information ----------------------------------------------------- project = 'Phantom' -copyright = '2023 The Authors' +copyright = '2024 The Authors' author = 'Daniel Price' # The short X.Y version -version = '2023.0' +version = '2024.0' # The full version, including alpha/beta/rc tags -release = '2023.0.0' +release = '2024.0.0' # -- General configuration --------------------------------------------------- From 378f807febbdd7c52c16a046d69272eca5cf7777 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 29 Jan 2024 20:48:00 +1100 Subject: [PATCH 274/814] updated links in release notes --- docs/releasenotes.rst | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/docs/releasenotes.rst b/docs/releasenotes.rst index 7134857c6..2ca7cd79e 100644 --- a/docs/releasenotes.rst +++ b/docs/releasenotes.rst @@ -6,19 +6,19 @@ v2024.0.0 - 29th Jan 2024 Physics ~~~~~~~ -- ability to use numerical relativity backend with phantom (Magnall et al. 2023; #480) +- ability to use numerical relativity backend with phantom (`Magnall et al. 2023 `__; #480) - further improvements to implicit radiation scheme (thanks to Mike Lau and Ryosuke Hirai; #406,#438,#441,#452,#455,#458,#474) - further improvements to wind injection and cooling modules (thanks to Lionel Siess, Mats Esseldeurs, Silke Maes and Jolien Malfait; #392,) - J2 potential due to oblateness implemented for sink particles (#289) - external potential implemented for geopotential model, to test J2 potential (#289) -- implemented Loren/Bate implicit scheme for 2-fluid drag (thanks to Stephane Michoulier, #428,#436) +- implemented Loren/Bate implicit scheme for drag with dust-as-particles (thanks to Stephane Michoulier, #428,#436) - dynamic boundary conditions, allowing box with expanding boundaries (thanks to James Wurster; #416) - bug fix in generalised Farris equation of state (thanks to Nicolas Cuello; #433) Setup ~~~~~ - major reorganisation of star setup into separate module, can now setup and relax one or more stars in several different setups, allowing one-shot-setup-and-relax for common envelopes, binary stars and tidal disruption events (#405,#407,#413) -- new hierarchical system setup: can now setup an arbitrary number of point masses or stars in hierarchical systems (thanks to Simone Ceppi; #401,#426) +- new hierarchical system setup: can now setup an arbitrary number of point masses or stars in hierarchical systems (thanks to Simone Ceppi; #401,#426; see `Ceppi et al. 2022 `__) - relaxation process for stars is restartable, works automatically (#414, #417) - can setup unbound parabolic and hyperbolic orbits using the standard 6-parameter orbital elements (#443,#448; #302) - use m1 and m2 in the binary disc setup instead of primary mass and mass ratio (#431) @@ -34,7 +34,7 @@ Analysis/moddump utilities - cleanup and further enhancements to common envelope analysis routines (thanks to Miguel Gonzalez-Bolivar; #467,#462) - moddump_sink displays correct value of sink luminosity (#439) - analysis routine for radio emission from tidal disruption events (thanks to Fitz Hu; #472) -- new analysis routine to compute time of dust formation (`Bermudez-Bustamante et al. 2023 <>`__) +- new analysis routine to compute time of dust formation (`Bermudez-Bustamante et al. 2023 `__) Other ~~~~~ From 6b8bdc5a2a4d3257608f9f875ca05745d7b48ef5 Mon Sep 17 00:00:00 2001 From: fhu Date: Tue, 30 Jan 2024 10:49:18 +1100 Subject: [PATCH 275/814] (inject_sim) initialise r_inject_cgs to avoid build error --- src/main/inject_sim.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index 1fa74d744..ceada6544 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -36,7 +36,7 @@ module inject character(len=120) :: start_dump,final_dump,pre_dump,next_dump integer :: npart_sim - real :: r_inject,r_inject_cgs,next_time!,e_inject + real :: r_inject,r_inject_cgs=-1,next_time!,e_inject real, allocatable :: xyzh_pre(:,:),xyzh_next(:,:),vxyzu_next(:,:),pxyzu_next(:,:) logical, allocatable :: injected(:) From cc68da28bf9ce86eacb2dae7b9817e0468e6b938 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 30 Jan 2024 10:58:20 +0100 Subject: [PATCH 276/814] remove changes that had to do with fixed luminosity core, which was a fruitless endeavour --- build/Makefile | 2 +- src/setup/set_fixedlumcore.f90 | 325 -------------------------------- src/setup/set_softened_core.f90 | 14 +- src/setup/set_star.f90 | 30 ++- src/setup/set_star_utils.f90 | 6 +- src/setup/setup_star.f90 | 4 +- 6 files changed, 19 insertions(+), 362 deletions(-) delete mode 100644 src/setup/set_fixedlumcore.f90 diff --git a/build/Makefile b/build/Makefile index ee0bc68d4..e87f32ad6 100644 --- a/build/Makefile +++ b/build/Makefile @@ -657,7 +657,7 @@ SRCSETUP= prompting.f90 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_cubic_core.f90 set_fixedentropycore.f90 set_fixedlumcore.f90 set_softened_core.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 \ set_vfield.f90 set_Bfield.f90 \ ${SETUPFILE} diff --git a/src/setup/set_fixedlumcore.f90 b/src/setup/set_fixedlumcore.f90 deleted file mode 100644 index 915e8de6f..000000000 --- a/src/setup/set_fixedlumcore.f90 +++ /dev/null @@ -1,325 +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.github.io/ ! -!--------------------------------------------------------------------------! -module setfixedlumcore -! -! This module softens the core of a MESA stellar profile with a specified -! temperature profile that is in equilibrium with a luminosity function (see -! options in the function "luminosity"). This assumes the softened region is -! radiative and so the temperature gradient provides the flux needed to -! transport this luminosity. -! -! :References: -! -! :Owner: Mike Lau -! -! :Runtime parameters: None -! -! :Dependencies: dim, eos, io, kernel, physcon, table_utils -! - implicit none - public :: set_fixedlum_softened_core - - private - integer, parameter :: ierr_rho=1,ierr_pres=2,ierr_mass=3,ierr_lum=4 - -contains - -!----------------------------------------------------------------------- -!+ -! Main subroutine that calculates the softened profile -! Lstar in erg/s -!+ -!----------------------------------------------------------------------- -subroutine set_fixedlum_softened_core(eos_type,rcore,Lstar,mcore,rho,r,pres,m,Xcore,Ycore,ierr) - use eos, only:calc_temp_and_ene,get_mean_molecular_weight,iopacity_type - use io, only:fatal - use physcon, only:solarm,solarr - use table_utils, only:interpolator - use setfixedentropycore, only:calc_mass_from_rho - integer, intent(in) :: eos_type - real, intent(in) :: rcore,Lstar,Xcore,Ycore - real, intent(inout) :: r(:),rho(:),m(:),pres(:),mcore - real, allocatable :: r_alloc(:),rho_alloc(:),pres_alloc(:),T_alloc(:) - integer, intent(out) :: ierr - real :: mc,msoft,rc,eni,mu - integer :: i,icore,iverbose - - ierr = 0 - if (Lstar<=tiny(0.)) then - print *,'Lstar=',Lstar - call fatal('setfixedlumcore','Lstar must be positive') - endif - if (iopacity_type/=1 .and. iopacity_type/=2) then - print *,'iopacity_type=',iopacity_type - call fatal('setfixedlumcore','only iopacity_type = 1,2 are supported') - endif - - rc = rcore*solarr ! convert to cm - mc = mcore*solarm ! convert to g - call interpolator(r,rc,icore) ! find index in r closest to rc - msoft = m(icore) - mc - if (msoft<0.) call fatal('setfixedlumcore','mcore cannot exceed m(r=h)') - - ! Make allocatable copies, see instructions of calc_rho_and_pres - allocate(r_alloc(0:icore+1)) - r_alloc(0) = 0. - r_alloc(1:icore+1) = r(1:icore+1) - allocate(rho_alloc(0:icore)) - rho_alloc(icore) = rho(icore) - allocate(pres_alloc(0:icore+1)) - pres_alloc(icore:icore+1) = pres(icore:icore+1) - - ! Allocate and fill in temperature array - allocate(T_alloc(0:icore+1)) - do i = icore,icore+1 - mu = get_mean_molecular_weight(Xcore,1.-Xcore-Ycore) - call calc_temp_and_ene(eos_type,rho(i),pres(i),eni,T_alloc(i),ierr,mu_local=mu, & - X_local=Xcore,Z_local=1.-Xcore-Ycore) - enddo - - iverbose = 1 - call shoot_for_mcore(eos_type,r_alloc,mc,m(icore),Lstar,rho_alloc,pres_alloc,T_alloc,Xcore,Ycore,iverbose) - mcore = mc / solarm - write(*,'(1x,a,es24.16e3,a)') 'Obtained core mass of ',mcore,' Msun' - write(*,'(1x,a,es24.16e3,a)') 'Softened mass is ',m(icore)/solarm-mcore,' Msun' - rho(1:icore) = rho_alloc(1:icore) - pres(1:icore) = pres_alloc(1:icore) - call calc_mass_from_rho(r(1:icore),rho(1:icore),m(1:icore)) - m(1:icore) = m(1:icore) + mc - -end subroutine set_fixedlum_softened_core - - -!----------------------------------------------------------------------- -!+ -! Returns softened core profile -!+ -!----------------------------------------------------------------------- -subroutine shoot_for_mcore(eos_type,r,mcore,mh,Lstar,rho,pres,temp,Xcore,Ycore,iverbose) - use eos, only:get_mean_molecular_weight - use physcon, only:solarm - integer, intent(in) :: eos_type,iverbose - real, allocatable, dimension(:), intent(in) :: r - real, intent(in) :: Lstar,mh,Xcore,Ycore - real, intent(inout) :: mcore - real, allocatable, dimension(:), intent(inout) :: rho,pres,temp - integer :: Nmax,it_m,it_l,ierr - real :: mass,mold,msoft,fac_m,fac_l,mu,mcore_old,& - eps0,epsold,l,lold,tol_eps,tol_m - -! INSTRUCTIONS - -! Input variables should be given in the following format: - -! r(0:Nmax+1): Array of radial grid to be softened, satisfying r(0)=0 and r(Nmax)=rcore -! mcore: Core particle mass, need to provide initial guess -! mh: Mass coordinate at rcore, m(r=rcore) -! rho(0:Nmax): Give rho(Nmax)=(rho at rcore) as input. Outputs density profile. -! p(0:Nmax+1): Give p(Nmax:Nmax+1)=(p at r(Nmax:Nmax+1)) as input. Outputs pressure profile. - - msoft = mh - mcore - Nmax = size(rho)-1 ! Index corresponding to r = h - mu = get_mean_molecular_weight(Xcore,1.-Xcore-Ycore) - - ! Start shooting method - fac_m = 0.005 - mass = msoft - tol_eps = 1.e-10 - tol_m = 1.e-10 - - !---------------------------LOOP-OVER-MCORE------------------------------------- - ! Vary mcore so that m(0) = 0 - it_m = 0 - loop_over_mcore: do - l = Lstar - eps0 = Lstar/msoft ! initial guess for eps0 / erg/g - mold = mass - mcore_old = mcore - !---------------------------LOOP-OVER-HEATING-FACTOR------------------------------------- - ! Vary heating factor (eps0) so that central luminosity is zero - it_l = 0 - fac_l = 0.01 - loop_over_eps0: do - epsold = eps0 - lold = l - ierr = 0 - call one_shot(eos_type,r,mcore,msoft,Lstar,eps0,mu,rho,pres,temp,mass,l,iverbose,ierr) ! returned mass is m(r=0) - it_l = it_l + 1 - - if (iverbose > 1) write(*,'(2(1x,i5),8(2x,a,e15.8),2x,a,i1)') & - it_m,it_l,'eps0=',eps0,'m(0)=',mass/solarm,& - 'l(0)=',l,'eps0_old=',epsold,'mcore_old = ',& - mcore_old/solarm,'mcore=',mcore/solarm,'fac_l=',fac_l,& - 'fac_m=',fac_m,'ierr=',ierr - - if (l < 0.) then - eps0 = eps0 * (1. - fac_l) - elseif (l/Lstar < tol_eps) then ! l(r=0) sufficiently close to zero - ! write(*,'(/,1x,a,i5,a,e12.5)') 'Tolerance on luminosity reached on iteration no.',it_l,', fac_l =',fac_l - exit loop_over_eps0 - else - eps0 = eps0 * (1. + fac_l) - endif - - if (abs(epsold-eps0) < tiny(0.)) then - fac_l = fac_l * 1.05 - elseif (lold * l < 0.) then - fac_l = fac_l * 0.95 - endif - enddo loop_over_eps0 - !----------------------------------------------------------------------------------------- - it_m = it_m + 1 - if (iverbose == 1) write(*,'(2(1x,i5),6(2x,a,e15.8),2x,a,i1)') & - it_m,it_l,'eps0=',eps0,'m(0)=',mass/solarm,'mcore_old = ',& - mcore_old/solarm,'mcore=',mcore/solarm,'fac_l=',fac_l,& - 'fac_m=',fac_m,'ierr=',ierr - - if (mass < 0.) then - mcore = mcore * (1. - fac_m) - elseif (mass/msoft < tol_m .and. ierr <= ierr_pres) then ! m(r=0) sufficiently close to zero - write(*,'(/,1x,a,i5,2(1x,a,es24.16e3))') 'Converged on iteration no.',it_m,', fac_m =',fac_m,'eps0 = ',eps0 - if (ierr == ierr_rho) write(*,'(a)') 'WARNING: Profile contains density inversion' - exit loop_over_mcore - else - mcore = mcore * (1. + fac_m) - endif - msoft = mh - mcore - - if (mold * mass < 0.) then - fac_m = fac_m * 0.95 - else - fac_m = fac_m * 1.05 - endif - ! if (abs(mold-mass) < tiny(0.)) then - ! fac_m = fac_m * 1.02 - ! elseif (mold * mass < 0.) then - ! fac_m = fac_m * 0.99 - ! endif - - if (abs(mold-mass) < tiny(0.) .and. ierr <= ierr_rho) then - write(*,'(/,1x,a,e12.5)') 'WARNING: Converged on mcore without reaching tolerance on zero & - ¢ral mass. m(r=0)/msoft = ',mass/msoft - if (ierr == ierr_rho) write(*,'(1x,a)') 'WARNING: Profile contains density inversion' - write(*,'(/,1x,a,i4,a,e12.5)') 'Reached iteration ',it_m,', fac_m=',fac_m - exit loop_over_mcore - endif - - enddo loop_over_mcore - !----------------------------------------------------------------------------------------- - -end subroutine shoot_for_mcore - - -!----------------------------------------------------------------------- -!+ -! One shot: Solve structure for given guess for msoft/mcore -!+ -!----------------------------------------------------------------------- -subroutine one_shot(eos_type,r,mcore,msoft,Lstar,eps0,mu,rho,pres,T,mass,l,iverbose,ierr) - use physcon, only:gg,pi,radconst,c,solarm - use eos, only:calc_rho_from_PT,iopacity_type - use radiation_utils, only:get_opacity - use setfixedentropycore, only:gcore - use units, only:unit_density,unit_opacity - integer, intent(in) :: eos_type,iverbose - real, intent(in) :: mcore,msoft,Lstar,eps0,mu - real, allocatable, dimension(:), intent(in) :: r - real, allocatable, dimension(:), intent(inout) :: rho,pres,T - real, intent(out) :: mass,l - integer, intent(out) :: ierr - integer :: i,Nmax - real :: kappai,kappa_code,rcore,mu_local,rho_code - real, allocatable, dimension(:) :: dr,dvol,lum - - Nmax = size(rho)-1 - allocate(dr(1:Nmax+1),dvol(1:Nmax+1),lum(1:Nmax+1)) - - ! Pre-fill arrays - do i = 1,Nmax+1 - dr(i) = r(i)-r(i-1) - dvol(i) = 4.*pi/3. * (r(i)**3 - r(i-1)**3) - enddo - - rcore = r(Nmax) - mass = msoft - lum(Nmax:Nmax+1) = Lstar - mu_local = mu - ierr = 0 - - do i = Nmax, 1, -1 - pres(i-1) = pres(i) + dr(i) * rho(i) * gg * (mass/r(i)**2 + mcore * gcore(r(i),rcore)) - ! pres(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & - ! * rho(i) * gg * (mass/r(i)**2 + mcore * gcore(r(i),rcore)) & - ! + dr(i)**2 * pres(i+1) & - ! + ( dr(i+1)**2 - dr(i)**2) * pres(i) ) / dr(i+1)**2 - rho_code = rho(i) / unit_density - call get_opacity(iopacity_type,rho_code,T(i),kappa_code) - kappai = kappa_code * unit_opacity - T(i-1) = T(i) + dr(i) * 3./(16.*pi*radconst*c) * rho(i)*kappai*lum(i) / (r(i)**2*T(i)**3) - ! T(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & - ! * 3./(16.*pi*radconst*c) * rho(i)*kappai*lum(i) / (r(i)**2*T(i)**3) & - ! + dr(i)**2 * T(i+1) & - ! + ( dr(i+1)**2 - dr(i)**2) * T(i) ) / dr(i+1)**2 - call calc_rho_from_PT(eos_type,pres(i-1),T(i-1),rho(i-1),ierr,mu_local) - mass = mass - rho(i)*dvol(i) - lum(i-1) = lum(i) - dr(i)*4.*pi*r(i)**2*rho(i)*eps0*eps_heating(r(i),rcore) - ! lum(i-1) = ( dr(i) * dr(i+1) * sum(dr(i:i+1)) & - ! * (-4.*pi)*r(i)**2*rho(i)*eps0*eps_heating(r(i),rcore) & - ! + dr(i)**2 * lum(i+1) & - ! + ( dr(i+1)**2 - dr(i)**2) * lum(i) ) / dr(i+1)**2 - l = lum(i-1) - - if (iverbose > 3) print*,Nmax-i+1,rho(i-1),mass,pres(i-1),T(i-1),kappai,lum(i-1) - if (mass < 0.) then ! m(r) < 0 encountered, exit and decrease mcore - if (iverbose > 2) print*,'WARNING: Negative mass reached at i = ',i, 'm = ',mass/solarm - ierr = ierr_mass - return - endif - if (l < 0.) then ! l(r) < 0 encountered, exit and increase heating pre-factor eps0 - if (iverbose > 2) print*,'WARNING: Negative luminosity reached at i = ',i, 'm = ',mass/solarm - ierr = ierr_lum - return - endif - if (rho(i-1) 2) then - print*,'WARNING: Density inversion at i = ',i, 'm = ',mass/solarm - write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4,2x,e12.7)') i,rho(i),rho(i-1),mass,kappai - endif - ierr = ierr_rho - endif - if (pres(i-1) 2) then - print*,'WARNING: Pressure inversion at i = ',i, 'm = ',mass/solarm - write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4,2x,e12.7)') i,pres(i-1),rho(i),mass,kappai - endif - ierr = ierr_pres - return - endif - enddo -end subroutine one_shot - - -!----------------------------------------------------------------------- -!+ -! Wrapper function to return heating rate per unit mass (epsilon). -! Warning: normalisation is arbitrary (see heating_kernel) -!+ -!----------------------------------------------------------------------- -function eps_heating(r,rcore) - use kernel, only:radkern2 - use ptmass_heating, only:heating_kernel,isink_heating - real, intent(in) :: r,rcore - real :: eps_heating,q2 - - isink_heating = 1 - q2 = radkern2 * r**2 / rcore**2 - eps_heating = heating_kernel(q2,isink_heating) - -end function eps_heating - - -end module setfixedlumcore diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index 83cda17d9..a90f0529d 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -30,7 +30,7 @@ module setsoftenedcore ! Main subroutine that sets a softened core profile !+ !----------------------------------------------------------------------- -subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore,mcore,Lstar,r,den,pres,m,X,Y,ierr) +subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore,mcore,r,den,pres,m,X,Y,ierr) use eos, only:X_in,Z_in,init_eos,gmw,get_mean_molecular_weight,iopacity_type use eos_mesa, only:init_eos_mesa use io, only:fatal @@ -38,16 +38,13 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore, use setcubiccore, only:set_cubic_core,find_mcore_given_rcore,& find_rcore_given_mcore,check_rcore_and_mcore use setfixedentropycore, only:set_fixedS_softened_core - use setfixedlumcore, only:set_fixedlum_softened_core use physcon, only:solarr,solarm - use units, only:unit_luminosity integer, intent(in) :: eos_type,isoftcore,isofteningopt - real, intent(in) :: Lstar logical, intent(in) :: regrid_core real, intent(inout) :: rcore,mcore real, intent(inout), allocatable :: r(:),den(:),m(:),pres(:),X(:),Y(:) integer :: core_index,ierr,npts,Ncore - real :: Xcore,Zcore,rc,Lstar_cgs + real :: Xcore,Zcore,rc logical :: isort_decreasing,iexclude_core_mass real, allocatable :: r1(:),den1(:),pres1(:),m1(:),X1(:),Y1(:) @@ -116,13 +113,6 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore, case(2) call set_fixedS_softened_core(eos_type,mcore,rcore,den,r,pres,m,Xcore,1.-Xcore-Zcore,ierr) if (ierr /= 0) call fatal('setup','could not set fixed entropy softened core') - case(3) - if (iopacity_type < 1) then - call fatal('set_softened_core','Cannot use zero opacity (iopacity_type<1) with a fixed-luminosity core') - endif - Lstar_cgs = Lstar * unit_luminosity - call set_fixedlum_softened_core(eos_type,rcore,Lstar_cgs,mcore,den,r,pres,m,Xcore,1.-Xcore-Zcore,ierr) - if (ierr /= 0) call fatal('setup','could not set fixed entropy softened core') end select ! Reverse arrays so that data is sorted from stellar surface to stellar centre. diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 4a7f8c6be..a92ddda35 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -162,7 +162,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& 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%lcore,star%outputfilename,composition,& + star%hsoft,star%outputfilename,composition,& comp_label,ncols_compo) ! ! set up particles to represent the desired stellar profile @@ -445,7 +445,7 @@ 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,iopacity_type) +subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk) 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 @@ -453,7 +453,7 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk, type(star_t), intent(out) :: star integer, intent(in) :: id,master logical, intent(out) :: use_var_comp - integer, intent(out) :: need_iso,iopacity_type + integer, intent(out) :: need_iso integer, intent(inout) :: ieos real, intent(inout) :: polyk integer :: i @@ -504,11 +504,10 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk, call prompt('Use variable composition?',use_var_comp) print*,'Soften the core density profile and add a sink particle core?' - print "(4(/,a))",'0: Do not soften profile', & + print "(3(/,a))",'0: Do not soften profile', & '1: Use cubic softened density profile', & - '2: Use constant entropy softened profile', & - '3: Use linear luminosity softened profile' - call prompt('Select option above : ',star%isoftcore,0,3) + '2: Use constant entropy softened profile' + call prompt('Select option above : ',star%isoftcore,0,2) select case(star%isoftcore) case(0) @@ -547,13 +546,12 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk, call prompt('Enter sink particle luminosity [Lsun]',lcore_lsun,0.) star%lcore = lcore_lsun*real(solarl/unit_luminosity) - case(2,3) + 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.) - if (star%isoftcore == 3) call prompt('Enter opacity method (0=inf,1=mesa,2=constant,-1=preserve): ',iopacity_type,1) 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) @@ -573,7 +571,6 @@ end subroutine set_star_interactive !+ !----------------------------------------------------------------------- subroutine write_options_star(star,iunit,label) - use eos, only:iopacity_type 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 @@ -605,7 +602,7 @@ subroutine write_options_star(star,iunit,label) select case(star%iprofile) case(imesa) call write_inopt(star%isoftcore,'isoftcore'//trim(c),& - '0=no core softening, 1=cubic, 2=const. entropy, 3=const. lum',iunit) + '0=no core softening, 1=cubic, 2=const. entropy',iunit) if (star%isoftcore > 0) then call write_inopt(star%input_profile,'input_profile'//trim(c),& @@ -623,7 +620,7 @@ subroutine write_options_star(star,iunit,label) call write_inopt(in_solarm(star%mcore),'mcore'//trim(c),& 'Mass of point mass stellar core [Msun]',iunit) endif - elseif (star%isoftcore == 2 .or. star%isoftcore == 3) then + 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),& @@ -631,9 +628,6 @@ subroutine write_options_star(star,iunit,label) endif call write_inopt(in_solarl(star%lcore),'lcore'//trim(c),& 'Luminosity of point mass stellar core [Lsun]',iunit) - if (star%isoftcore == 3) call write_inopt(iopacity_type,'iopacity_type',& - 'opacity method (1=mesa,2=constant,-1=preserve)',iunit) - else call write_inopt(star%isinkcore,'isinkcore'//trim(c),& 'Add a sink particle stellar core',iunit) @@ -670,7 +664,6 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) use setstar_utils, only:need_inputprofile,need_rstar,nprofile_opts use units, only:umass,udist,unit_luminosity use physcon, only:solarm,solarr,solarl - use eos, only:iopacity_type type(star_t), intent(out) :: star type(inopts), allocatable, intent(inout) :: db(:) integer, intent(out) :: need_iso @@ -707,7 +700,7 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) case(imesa) ! core softening options call read_inopt(star%isoftcore,'isoftcore'//trim(c),db,errcount=nerr,min=0) - if (star%isoftcore==2 .or. star%isoftcore==3) star%isofteningopt=3 + if (star%isoftcore==2) star%isofteningopt=3 if (star%isoftcore <= 0) then ! sink particle core without softening call read_inopt(star%isinkcore,'isinkcore'//trim(c),db,errcount=nerr) @@ -728,12 +721,11 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) star%rcore = rcore_rsun*real(solarr/udist) endif if ((star%isofteningopt==2) .or. (star%isofteningopt==3) & - .or. (star%isoftcore==2) .or. (star%isoftcore==3)) then + .or. (star%isoftcore==2)) then call read_inopt(mcore_msun,'mcore'//trim(c),db,errcount=nerr,min=0.) star%mcore = mcore_msun*real(solarm/umass) endif call read_inopt(lcore_lsun,'lcore'//trim(c),db,errcount=nerr,min=0.) - if (star%isoftcore==3) call read_inopt(iopacity_type,'iopacity_type'//trim(c),db,errcount=nerr,min=1) star%lcore = lcore_lsun*real(solarl/unit_luminosity) endif case(ievrard) diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 1d73ef98e..6f99b896f 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -64,7 +64,7 @@ module setstar_utils subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& r,den,pres,temp,en,mtab,X_in,Z_in,Xfrac,Yfrac,mu,& npts,rmin,Rstar,Mstar,rhocentre,& - isoftcore,isofteningopt,rcore,mcore,hsoft,Lstar,outputfilename,& + isoftcore,isofteningopt,rcore,mcore,hsoft,outputfilename,& composition,comp_label,columns_compo) use extern_densprofile, only:read_rhotab_wrapper use eos_piecewise, only:get_dPdrho_piecewise @@ -78,7 +78,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& integer, intent(in) :: iprofile,ieos character(len=*), intent(in) :: input_profile,outputfilename real, intent(in) :: ui_coef - real, intent(inout) :: gamma,polyk,hsoft,Lstar + real, intent(inout) :: gamma,polyk,hsoft real, intent(in) :: X_in,Z_in real, allocatable, intent(out) :: r(:),den(:),pres(:),temp(:),en(:),mtab(:) real, allocatable, intent(out) :: Xfrac(:),Yfrac(:),mu(:),composition(:,:) @@ -132,7 +132,7 @@ subroutine read_star_profile(iprofile,ieos,input_profile,gamma,polyk,ui_coef,& eos_type = ieos endif regrid_core = .false. ! hardwired to be false for now - call set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore,mcore,Lstar,r,den,pres,mtab,Xfrac,Yfrac,ierr) + call set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore,mcore,r,den,pres,mtab,Xfrac,Yfrac,ierr) hsoft = rcore/radkern call solve_uT_profiles(eos_type,r,den,pres,Xfrac,Yfrac,regrid_core,temp,en,mu) diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index cbf03b2b1..e6fa4a8eb 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -194,7 +194,7 @@ end subroutine setpart subroutine setup_interactive(polyk,gamma,iexist,id,master,ierr) use prompting, only:prompt use units, only:select_unit - use eos, only:X_in,Z_in,gmw,iopacity_type + 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 @@ -209,7 +209,7 @@ 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,iopacity_type) + 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) From 591bcec32f78e085f9eae3d9521d572b16b64abf Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 30 Jan 2024 13:28:49 +0100 Subject: [PATCH 277/814] (fileutils) read data file where col labels could be separated by any number of spaces --- src/main/utils_filenames.f90 | 6 +----- src/setup/set_softened_core.f90 | 2 +- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/src/main/utils_filenames.f90 b/src/main/utils_filenames.f90 index e13d3b7f1..2c2c22ee5 100644 --- a/src/main/utils_filenames.f90 +++ b/src/main/utils_filenames.f90 @@ -591,11 +591,7 @@ subroutine get_column_labels(line,nlabels,labels,method,ndesired,csv) ! istyle = 1 i1 = max(index(line,'[')+1,i1) ! strip leading square bracket - ! try with different number of spaces between brackets (if labels not found) - over_spaces1: do i=4,0,-1 - call split(line(i1:),']'//spaces(1:i)//'[',labels,nlabels) - if (nlabels > 1) exit over_spaces1 - enddo over_spaces1 + call split(nospaces(line(i1:)),'][',labels,nlabels) elseif (index(line,',') > 1 .or. is_csv) then ! ! format style 2: mylabel1,mylabel2,mylabel3 diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index a90f0529d..a022d8c37 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -31,7 +31,7 @@ module setsoftenedcore !+ !----------------------------------------------------------------------- subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore,mcore,r,den,pres,m,X,Y,ierr) - use eos, only:X_in,Z_in,init_eos,gmw,get_mean_molecular_weight,iopacity_type + use eos, only:X_in,Z_in,init_eos,gmw,get_mean_molecular_weight use eos_mesa, only:init_eos_mesa use io, only:fatal use table_utils, only:interpolator,yinterp,flip_array From c8a53085f3cb14a9e5285d8858dd8fc8fafbceab Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 30 Jan 2024 13:34:27 +0100 Subject: [PATCH 278/814] comment out unused ptmass_heating subroutines to pass build test --- src/main/ptmass_heating.f90 | 60 ++++++++++++++++++------------------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/src/main/ptmass_heating.f90 b/src/main/ptmass_heating.f90 index 2878f57ae..2095b88f3 100644 --- a/src/main/ptmass_heating.f90 +++ b/src/main/ptmass_heating.f90 @@ -73,46 +73,46 @@ end function heating_kernel !----------------------------------------------------------------------- !+ -! write options to input file +! write options to input file (not used at the moment) !+ !----------------------------------------------------------------------- -subroutine write_options_ptmass_heating(iunit) - use infile_utils, only:write_inopt - integer, intent(in) :: iunit +! subroutine write_options_ptmass_heating(iunit) +! use infile_utils, only:write_inopt +! integer, intent(in) :: iunit - call write_inopt(isink_heating,'isink_heating','sink heating distirbution (0=uniform,1=kernel)',iunit) +! call write_inopt(isink_heating,'isink_heating','sink heating distirbution (0=uniform,1=kernel)',iunit) -end subroutine write_options_ptmass_heating +! end subroutine write_options_ptmass_heating !----------------------------------------------------------------------- !+ -! read options from input file +! read options from input file (not used at the moment) !+ !----------------------------------------------------------------------- -subroutine read_options_ptmass_heating(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 - integer :: ni - character(len=30), parameter :: label = 'read_options_ptmass_heating' - - imatch = .true. - igotall = .false. - select case(trim(name)) - case('isink_heating') - read(valstring,*,iostat=ierr) isink_heating - ngot = ngot + 1 - if (isink_heating < 0 .or. isink_heating > 1) call fatal(label,'invalid setting for isink_heating ([0,1])') - case default - imatch = .false. - end select - ni = 1 - igotall = (ngot >= ni) - -end subroutine read_options_ptmass_heating +! subroutine read_options_ptmass_heating(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 +! integer :: ni +! character(len=30), parameter :: label = 'read_options_ptmass_heating' + +! imatch = .true. +! igotall = .false. +! select case(trim(name)) +! case('isink_heating') +! read(valstring,*,iostat=ierr) isink_heating +! ngot = ngot + 1 +! if (isink_heating < 0 .or. isink_heating > 1) call fatal(label,'invalid setting for isink_heating ([0,1])') +! case default +! imatch = .false. +! end select +! ni = 1 +! igotall = (ngot >= ni) + +! end subroutine read_options_ptmass_heating end module ptmass_heating From 7774d5f3b516f15d1df8e2bbc3d1d3cd0e7a349b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 10:17:20 +1100 Subject: [PATCH 279/814] (docs) bug fix in table of pre-cooked setups [skip ci] --- build/Makefile_setups | 28 ++++++++++++++-------------- docs/setups-list.rst | 2 +- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/build/Makefile_setups b/build/Makefile_setups index cb367b716..ae562595d 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -1038,23 +1038,24 @@ endif ifeq ($(SETUP), flrw) # constant density FLRW cosmology with perturbations - GR=yes - KNOWN_SETUP=yes - IND_TIMESTEPS=no - METRIC=et - SETUPFILE= setup_flrw.f90 - PERIODIC=yes + GR=yes + KNOWN_SETUP=yes + IND_TIMESTEPS=no + METRIC=et + SETUPFILE= setup_flrw.f90 + PERIODIC=yes endif ifeq ($(SETUP), flrwpspec) -# FLRW universe using a CMB powerspectrum and the Zeldovich approximation - GR=yes - KNOWN_SETUP=yes - IND_TIMESTEPS=no - METRIC=et - SETUPFILE= setup_flrwpspec.f90 - PERIODIC=yes +# FLRW universe using a CMB powerspectrum + GR=yes + KNOWN_SETUP=yes + IND_TIMESTEPS=no + METRIC=et + SETUPFILE= setup_flrwpspec.f90 + PERIODIC=yes endif + ifeq ($(SETUP), default) # default setup, uniform box KNOWN_SETUP=yes @@ -1069,7 +1070,6 @@ ifeq ($(SETUP), galaxies) ANALYSIS=analysis_GalMerger.f90 IND_TIMESTEPS=yes GRAVITY=yes - MAXP=2600000 KNOWN_SETUP=yes endif diff --git a/docs/setups-list.rst b/docs/setups-list.rst index b98b1fc47..5f45b60ce 100644 --- a/docs/setups-list.rst +++ b/docs/setups-list.rst @@ -63,7 +63,7 @@ +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | flrw | constant density FLRW cosmology with perturbations | GR, et, periodic | `setup_flrw.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| flrwpspec | FLRW universe using a CMB powerspectrum and the Zeldovich approximation | GR, et, periodic | `setup_flrwpspec.f90 `__ | +| flrwpspec | FLRW universe using a CMB powerspectrum | GR, et, periodic | `setup_flrwpspec.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ | galaxies | galaxy merger using data from Wurster & Thacker (2013a,b) | self-gravity | `setup_galaxies.f90 `__ | +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ From a3f0e719ce29313f81151dcedc73968e645c2fd7 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 10:44:39 +1100 Subject: [PATCH 280/814] Update analysis.rst [skip ci] --- docs/analysis.rst | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/docs/analysis.rst b/docs/analysis.rst index b7d4e492c..f8f712f10 100644 --- a/docs/analysis.rst +++ b/docs/analysis.rst @@ -109,7 +109,6 @@ specified in `build/Makefile_setups `. @@ -162,8 +167,11 @@ utility in splash. For example, to convert all files to ascii format splash to ascii blast_0* -To avoid precision loss, you will need to ensure that splash is compiled -in double precision (use make DOUBLEPRECISION=yes when compiling splash) +You can also convert to other code formats, e.g.: + +.. code-block:: bash + + splash to gadget blast_0* Analysis with pyanalysis ~~~~~~~~~~~~~~~~~~~~~~~~ From 14f78c879d57d96890f541ef67bd2620d4895cbd Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 31 Jan 2024 10:46:02 +1100 Subject: [PATCH 281/814] (inject_sim) handle error when no file is read --- src/main/inject_sim.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index ceada6544..f3063bcc7 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -64,6 +64,7 @@ subroutine init_inject(ierr) ! next_dump = getnextfilename(start_dump) call get_dump_time_npart(trim(next_dump),next_time,ierr,npart_out=npart_sim) + if (ierr /= 0) next_time = -1. ierr = 0 niter = 0 From 09471be95ffe2a301697e84954ad6dec3d0feed8 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 11:00:07 +1100 Subject: [PATCH 282/814] Update running-first-calculation.rst [skip ci] --- docs/running-first-calculation.rst | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/docs/running-first-calculation.rst b/docs/running-first-calculation.rst index ec715719e..a6771f4cc 100644 --- a/docs/running-first-calculation.rst +++ b/docs/running-first-calculation.rst @@ -26,34 +26,32 @@ because the neighbour caches in phantom are private to each thread, and hence stored on the per-thread stack – this means the storage can exceed the default openMP stack size setting, usually causing a seg-fault. -Running the testsuite +Choosing a compiler --------------------- -Type: +Fortran is a compiled language, for which many compilers exist. The free +compiler is called gfortran, but the Intel Fortran Compiler (ifort) is the main +commercial compiler and typically runs phantom ~20% faster than gfortran. -:: - - make test - -where you will need to specify a SYSTEM variable corresponding to one of -those listed in phantom/build/Makefile. You can do this by setting an -environment variable (e.g. in bash/sh): +You can choose the compiler and other machine-specific configurations by specifying +a SYSTEM variable corresponding to one of those listed in `phantom/build/Makefile_systems `__. +You can do this by setting an environment variable (e.g. in bash/sh): :: export SYSTEM=ifort -(the best way is to put the line above into your .profile/.bashrc so -that it is always set for the machine that you’re using), or by -including it on the command line: +The best way is to put the line above into your .profile/.bashrc so +that it is always set for the machine that you’re using. Alternatively you +can specify this by including it on the command line every time you compile the code: :: - make SYSTEM=ifort test + make SYSTEM=ifort -:doc:`Click here for more details about the test suite. ` +A list of current options for the SYSTEM variable is given below, please contribute +if you have configured phantom for your local cluster so that others can benefit: -There should be *no* failures in the test suite assuming the code you are using is from the master branch. Running an example calculation ------------------------------ From b52533bf605709c658a977cbd241e774dbd08fd3 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 11:30:17 +1100 Subject: [PATCH 283/814] (docs) updated list of possible SYSTEM= settings [skip ci] --- build/Makefile_systems | 95 ++++++--------------------- docs/running-first-calculation.rst | 1 + docs/scripts/print_systems.sh | 41 ++++++++++++ docs/scripts/update_docs_from_code.sh | 1 + docs/systems-list.rst | 52 +++++++++++++++ 5 files changed, 114 insertions(+), 76 deletions(-) create mode 100755 docs/scripts/print_systems.sh create mode 100644 docs/systems-list.rst diff --git a/build/Makefile_systems b/build/Makefile_systems index c5d648787..0e9e1091d 100644 --- a/build/Makefile_systems +++ b/build/Makefile_systems @@ -2,7 +2,8 @@ # Sensible compiler options for different compute systems #---------------------------------------------------------------- -ifeq ($(SYSTEM),cray) +ifeq ($(SYSTEM), cray) +# default settings for the Cray Fortran Compiler (ftn) FC=ftn FFLAGS=-Oaggress -Ovector3 -Oipa4 DBLFLAG= -s real64 @@ -15,7 +16,8 @@ ifeq ($(MAP),yes) endif endif -ifeq ($(SYSTEM),daint) +ifeq ($(SYSTEM), daint) +# piz-daint supercomputer facility https://www.cscs.ch/computers/piz-daint include Makefile_defaults_ifort FC=ftn FFLAGS+= -heap-arrays @@ -25,8 +27,8 @@ ifeq ($(MPI),daint) endif endif -ifeq ($(SYSTEM),xc40) -#massively copied from the Daint system +ifeq ($(SYSTEM), xc40) +# Cray XC40 machine, similar to the daint system include Makefile_defaults_ifort FC=ftn FFLAGS+= -heap-arrays -dynamic @@ -39,29 +41,6 @@ ifeq ($(MPI),xc40) endif endif -ifeq ($(SYSTEM), msg) - include Makefile_defaults_ifort - QSYS = sge - QSHELL = tcsh - ifeq ($(OPENMP),yes) - QPE = smp - NOMP = '$$NSLOTS' - ifndef NPAR - NPAR = '4-32' - endif - endif - ifeq ($(MPI),yes) - QPE = mpi - ifeq ($(OPENMP),yes) - QPE = mqu4 - NOMP = 4 - endif - endif - #QEXTRA='-l dpod=true -q mqu2' - #HDF5=yes -# HDF5ROOT=/opt/sw/hdf5-1.8.0/ -endif - ifeq ($(SYSTEM), m2) # MASSIVE facility: massive.org.au include Makefile_defaults_ifort @@ -75,24 +54,8 @@ ifeq ($(SYSTEM), m2) WALLTIME='500:00:00' endif -ifeq ($(SYSTEM), g2) -# gstar facility -# Note: gstar has nomp=12; sstar has nomp=16 - include Makefile_defaults_ifort - QSYS = pbs - ifeq ($(OPENMP),yes) - NOMP='16' - else - NOMP='1' - endif - QNAME='sstar' - QNODES='nodes='$(NMPI)':ppn='$(NOMP) - WALLTIME='168:00:00' - MPIEXEC='mpiexec -npernode 1' -endif - ifeq ($(SYSTEM), ozstar) -# ozstar facility +# ozstar facility using ifort https://supercomputing.swin.edu.au/ozstar/ include Makefile_defaults_ifort OMPFLAGS=-qopenmp NOMP=32 @@ -102,7 +65,7 @@ ifeq ($(SYSTEM), ozstar) endif ifeq ($(SYSTEM), nt) -# ozstar milan cluster +# ozstar milan cluster using aocc (Ngarru Tindebeek) include Makefile_defaults_aocc OMPFLAGS=-fopenmp NOMP='32' @@ -132,6 +95,7 @@ ifeq ($(SYSTEM), ipopeyearch) endif ifeq ($(SYSTEM), monarch) +# Monarch cluster at Monash University include Makefile_defaults_ifort OMPFLAGS=-qopenmp -qopt-report QSYS = slurm @@ -140,12 +104,6 @@ ifeq ($(SYSTEM), monarch) QPARTITION='comp' endif -ifeq ($(SYSTEM), monarchpsxe) - include Makefile_defaults_ifort - QSYS = slurm - QPROJECT='p01' -endif - ifeq ($(SYSTEM), nci) # gadi (NCI machine) include Makefile_defaults_ifort @@ -169,29 +127,10 @@ ifeq ($(SYSTEM), nci) endif ifeq ($(SYSTEM), gfortran) +# default settings for the gfortran compiler include Makefile_defaults_gfortran endif -ifeq ($(SYSTEM), gfortranOSX) # for use with mac gfortran (5.3.0, 7.3.0 tested) - include Makefile_defaults_gfortran -endif - -ifeq ($(SYSTEM), gfortran44) - include Makefile_defaults_gfortran - FC= gfortran -gdwarf-2 - FFLAGS= -O3 -Wall -frecord-marker=4 -finline-functions-called-once -finline-limit=1500 -funroll-loops -ftree-vectorize - DEBUGFLAG= -g -frange-check -ffpe-trap=invalid,denormal -finit-real=nan -finit-integer=nan -fbacktrace -endif - -ifeq ($(SYSTEM), gfortran47) - include Makefile_defaults_gfortran - FC= gfortran-mp-4.7 -gdwarf-2 - FFLAGS= -Wall -m64 -O3 -ffast-math -funroll-loops -ftree-loop-linear \ - -finline-functions-called-once \ - -fomit-frame-pointer -finline-limit=3000 --param min-vect-loop-bound=2 - DEBUGFLAG= -Wextra -g -frange-check -fcheck=all -ffpe-trap=denormal -finit-real=nan -finit-integer=nan -fbacktrace -endif - ifeq ($(SYSTEM), complexity) # complexity.leicester.dirac.ac.uk include Makefile_defaults_ifort @@ -205,7 +144,7 @@ ifeq ($(SYSTEM), complexity) endif ifeq ($(SYSTEM), isca) - # local cluster at the University of Exeter +# local cluster at the University of Exeter include Makefile_defaults_ifort FFLAGS= -O3 -axAVX \ -warn uninitialized -warn truncated_source\ @@ -217,7 +156,7 @@ ifeq ($(SYSTEM), isca) endif ifeq ($(SYSTEM), skylake) -# HPCs Skylake cluster at Cambridge +# HPCs Skylake cluster at Cambridge include Makefile_defaults_ifort FFLAGS= -O3 -shared-intel -warn uninitialized -warn unused -warn \ truncated_source -xCORE-AVX512 -ipo @@ -229,17 +168,19 @@ ifeq ($(SYSTEM), skylake) endif ifeq ($(SYSTEM), kennedy) -# HPCs cluster at University of St. Andrews +# HPC cluster at University of St. Andrews include Makefile_defaults_ifort OMPFLAGS = -qopenmp QSYS = slurm endif ifeq ($(SYSTEM), ifort) +# default settings for the Intel Fortran Compiler include Makefile_defaults_ifort endif ifeq ($(SYSTEM), ifortmac) +# default settings for the Intel Fortran Compiler on Mac OS include Makefile_defaults_ifort FFLAGS= -O3 -xhost -shared-intel -warn uninitialized \ -warn unused -warn truncated_source -Wl,-rpath,/opt/intel/lib @@ -247,13 +188,14 @@ ifeq ($(SYSTEM), ifortmac) endif ifeq ($(SYSTEM), ifortgcc) +# Intel Fortran Compiler but gcc for C include Makefile_defaults_ifort CC = gcc CCFLAGS = -O3 endif ifeq ($(SYSTEM), hydra) -# this configuration works for the hydra cluster http://www.mpcdf.mpg.de/services/computing/hydra +# this configuration works for the hydra cluster http://www.mpcdf.mpg.de/services/computing/hydra include Makefile_defaults_ifort FFLAGS= -O3 -xavx -ip -shared-intel -warn uninitialized \ -warn unused -warn truncated_source @@ -262,7 +204,7 @@ ifeq ($(SYSTEM), hydra) endif ifeq ($(SYSTEM), lyoccf) -# LIO CCF cluster +# LIO CCF cluster include Makefile_defaults_ifort FFLAGS= -O3 -ftz -xavx -cpp -sox -fno-alias -fno-fnalias \ -no-prec-div -no-prec-sqrt -align all -warn uninitialized \ @@ -271,5 +213,6 @@ ifeq ($(SYSTEM), lyoccf) endif ifeq ($(SYSTEM), aocc) +# default settings for the AMD optimized fortran compiler (aocc) include Makefile_defaults_aocc endif diff --git a/docs/running-first-calculation.rst b/docs/running-first-calculation.rst index a6771f4cc..25423d443 100644 --- a/docs/running-first-calculation.rst +++ b/docs/running-first-calculation.rst @@ -52,6 +52,7 @@ can specify this by including it on the command line every time you compile the A list of current options for the SYSTEM variable is given below, please contribute if you have configured phantom for your local cluster so that others can benefit: +.. include:: systems-list.rst Running an example calculation ------------------------------ diff --git a/docs/scripts/print_systems.sh b/docs/scripts/print_systems.sh new file mode 100755 index 000000000..4e7c4502f --- /dev/null +++ b/docs/scripts/print_systems.sh @@ -0,0 +1,41 @@ +#!/bin/bash +# +# script to print out information about all the SETUP= options +# from the phantom Makefile +# +phantomdir='../../' +url="https://github.com/danieljprice/phantom/blob/master/" +echo "" +echo ".. tabularcolumns:: |p{3cm}|p{15cm}|" +echo "" +echo ".. table:: List of possible SYSTEM configurations" +echo " :widths: auto" +echo "" +printf "+" +printf -- '-%.0s' {1..18} +printf "+" +printf -- '-%.0s' {1..123} +printf "+\n" +printf "| %-16s | %-121s | \n" "SYSTEM=" "description" +printf "+" +printf -- '=%.0s' {1..18} +printf "+" +printf -- '=%.0s' {1..123} +printf "+\n" +print_system() +{ + system=$1; + descript=`grep -A 1 "ifeq (\\$(SYSTEM), $system)" $phantomdir/build/Makefile_systems | grep '#' | cut -d'#' -f 2 | tail -1 | xargs` + #lineno=`grep -n "ifeq (\\$(SETUP), $setup)" $phantomdir/build/Makefile_setups | cut -d':' -f 1` + printf "| %-16s | %-121s | \n" "$system" "$descript" + printf "+" + printf -- '-%.0s' {1..18} + printf "+" + printf -- '-%.0s' {1..123} + printf "+\n" +} +listofsystems=`grep 'ifeq ($(SYSTEM)' $phantomdir/build/Makefile_systems | grep -v skip | cut -d, -f 2 | cut -d')' -f 1 | sort` +for system in $listofsystems; do + print_system $system +done +echo diff --git a/docs/scripts/update_docs_from_code.sh b/docs/scripts/update_docs_from_code.sh index a64c9885f..a960966f0 100755 --- a/docs/scripts/update_docs_from_code.sh +++ b/docs/scripts/update_docs_from_code.sh @@ -2,3 +2,4 @@ ./eos_options.pl > ../eos-list.rst ./print_setups.sh > ../setups-list.rst ./print_setups.sh best > ../setups-best.rst +./print_systems.sh > ../systems-list.rst diff --git a/docs/systems-list.rst b/docs/systems-list.rst new file mode 100644 index 000000000..16f01c036 --- /dev/null +++ b/docs/systems-list.rst @@ -0,0 +1,52 @@ + +.. tabularcolumns:: |p{3cm}|p{15cm}| + +.. table:: List of possible SYSTEM configurations + :widths: auto + ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| SYSTEM= | description | ++==================+===========================================================================================================================+ +| aocc | default settings for the AMD optimized fortran compiler (aocc) | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| complexity | complexity.leicester.dirac.ac.uk | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| cray | default settings for the Cray Fortran Compiler (ftn) | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| daint | piz-daint supercomputer facility https://www.cscs.ch/computers/piz-daint | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| gfortran | default settings for the gfortran compiler | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| hydra | this configuration works for the hydra cluster http://www.mpcdf.mpg.de/services/computing/hydra | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| ifort | default settings for the Intel Fortran Compiler | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| ifortgcc | Intel Fortran Compiler but gcc for C | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| ifortmac | default settings for the Intel Fortran Compiler on Mac OS | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| ipopeyearch | Flatiron CCA popeye cluster icelake node | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| isca | local cluster at the University of Exeter | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| kennedy | HPC cluster at University of St. Andrews | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| lyoccf | LIO CCF cluster | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| m2 | MASSIVE facility: massive.org.au | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| monarch | Monarch cluster at Monash University | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| nci | gadi (NCI machine) | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| nt | ozstar milan cluster using aocc (Ngarru Tindebeek) | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| ozstar | ozstar facility using ifort https://supercomputing.swin.edu.au/ozstar/ | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| rusty | Flatiron CCA rusty cluster rome node, AMD EPYC 7742 | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| skylake | HPCs Skylake cluster at Cambridge | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ +| xc40 | Cray XC40 machine, similar to the daint system | ++------------------+---------------------------------------------------------------------------------------------------------------------------+ + From fb2df8853f142fba31fd4b56254eadde04bc69fa Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 11:43:23 +1100 Subject: [PATCH 284/814] Update clusters.rst [skip ci] --- docs/clusters.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/clusters.rst b/docs/clusters.rst index 7b13dd407..e78924ca3 100644 --- a/docs/clusters.rst +++ b/docs/clusters.rst @@ -245,7 +245,7 @@ where the *jobid* is the id for the job listed in qstat Slurm vs pbs, and configuring the phantom Makefile for your cluster ------------------------------------------------------------------- -Slurm is the main alternative to PBS for managing job submission. The functionality is similar but the commands are different. You can configure the "make qscript" command in phantom to use either by making your own "SYSTEM" block in build/Makefile and specifying QSYS=slurm or QSYS=pbs. For example, add the following lines to phantom/build/Makefile:: +Slurm is the main alternative to PBS for managing job submission. The functionality is similar but the commands are different. You can configure the "make qscript" command in phantom to use either by making your own "SYSTEM" block in `phantom/build/Makefile_systems `__ and specifying QSYS=slurm or QSYS=pbs. For example, add the following lines to `phantom/build/Makefile_systems `__:: ifeq ($(SYSTEM), mycluster) include Makefile_defaults_ifort @@ -277,7 +277,7 @@ is output to a file called "tde01.log", which is automatically updated to "tde02 Type ctrl-c to quit the "tail -f". Obviously you can also look at the dump files as they arrive using splash:: - $ ssplash tde_0* + $ splash tde_0* A common problem is to have forgotten to type "ssh -Y", which will give you the following error:: From a7815c571c37c0accd90818069af18175e999d4c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 11:44:22 +1100 Subject: [PATCH 285/814] (docs) updated SYSTEMS list [skip ci] --- build/Makefile_systems | 2 +- docs/systems-list.rst | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/build/Makefile_systems b/build/Makefile_systems index 0e9e1091d..d38bd096e 100644 --- a/build/Makefile_systems +++ b/build/Makefile_systems @@ -195,7 +195,7 @@ ifeq ($(SYSTEM), ifortgcc) endif ifeq ($(SYSTEM), hydra) -# this configuration works for the hydra cluster http://www.mpcdf.mpg.de/services/computing/hydra +# hydra cluster in Garching http://www.mpcdf.mpg.de/services/computing/hydra include Makefile_defaults_ifort FFLAGS= -O3 -xavx -ip -shared-intel -warn uninitialized \ -warn unused -warn truncated_source diff --git a/docs/systems-list.rst b/docs/systems-list.rst index 16f01c036..20c4fe6f9 100644 --- a/docs/systems-list.rst +++ b/docs/systems-list.rst @@ -17,7 +17,7 @@ +------------------+---------------------------------------------------------------------------------------------------------------------------+ | gfortran | default settings for the gfortran compiler | +------------------+---------------------------------------------------------------------------------------------------------------------------+ -| hydra | this configuration works for the hydra cluster http://www.mpcdf.mpg.de/services/computing/hydra | +| hydra | hydra cluster in Garching http://www.mpcdf.mpg.de/services/computing/hydra | +------------------+---------------------------------------------------------------------------------------------------------------------------+ | ifort | default settings for the Intel Fortran Compiler | +------------------+---------------------------------------------------------------------------------------------------------------------------+ From 2e7f7b85c4830ab92c6aba902b533e0deaecdd89 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 12:07:14 +1100 Subject: [PATCH 286/814] Update data-curation.rst [skip ci] --- docs/data-curation.rst | 38 ++++++++++++++++++++++++++++++++------ 1 file changed, 32 insertions(+), 6 deletions(-) diff --git a/docs/data-curation.rst b/docs/data-curation.rst index d6c26998d..6940ed145 100644 --- a/docs/data-curation.rst +++ b/docs/data-curation.rst @@ -1,22 +1,48 @@ -Long-term archiving of your phantom calculations +Publishing the data from your phantom calculations ================================================================== -One of the biggest headaches we have with shared supercomputer projects -is that inevitably somebody fills whatever disk quota was allocated, -and the project halts for everyone. A true tragedy of the commons. To solve this, shift your data somewhere more permanent. +Recommended best practice for open science is that parameter files, initial conditions +and snapshots from calculations with phantom should be made publicly available on publication. + +FAIR Principles +---------------- +According to the `FAIR principles for scientific data management `__, your data should be: + +- Findable, e.g. with links to and from the paper publishing the simulations +- Accessible, available for free in a publicly accessible repository +- Interoperable, data is labelled and able to be reused or converted +- Reusable, include enough information to be able to reproduce your simulations Data curation ------------- For calculations with phantom that have been published in a paper, -best practice is to upload the **entire calculation including .in and +ideal practice is to upload the **entire calculation including .in and .setup files, .ev files and all dump files in a public repository**. See for example a dataset from Mentiplay et al. (2020) using figshare: ``_ Or this example from Wurster, Bate & Price (2018) in the University of Exeter repository: ``_ +However, size limitations may restrict preservation of all data, in which case we recommend saving: + +- .in files +- .setup files +- .ev files +- dump files used to create figures in your paper, with a link to splash or sarracen in the metadata for how to read/convert these files +- dump files containing initial conditions, if these are non-trivial +- metadata including link to your publication or arXiv preprint, link to the phantom code, code version information and labelling of data corresponding to simulations listed in your paper + +Zenodo community +---------------- +To facilitate better data sharing between phantom users, we have set up a Zenodo community: + + https://zenodo.org/communities/phantom + +Please join this community and let's learn from each other to create best-practice data curation. +Zenodo currently has a 50Gb limit on data size, which is sufficient for the recommended list of files to save above. + Archiving your data to Google Drive using rclone ------------------------------------------------ -You can use rclone to copy data from a remote cluster or supercomputing facility to Google Drive. For universities with institutional subscriptions, this provides almost unlimited storage. +You can use rclone to copy data from a remote cluster or supercomputing facility to Google Drive. This is not recommended as a long term storage solution but can facilitate short-term data sharing between users. Set this up by logging into your supercomputer and typing:: From 8ecac179866468d8ff5b726b19298de40494e7e4 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 12:10:50 +1100 Subject: [PATCH 287/814] (docs) moved data curation to user guide not quickstart [skip ci] --- docs/getting-started.rst | 3 ++- docs/user-guide.rst | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/docs/getting-started.rst b/docs/getting-started.rst index 2d8505cfa..496d56cc5 100644 --- a/docs/getting-started.rst +++ b/docs/getting-started.rst @@ -16,6 +16,8 @@ Quickstart 5. Please cite the `code paper `__ and other relevant papers in your publications. +6. :doc:`Publish your data ` on `Zenodo `__ or similar + Contents -------- @@ -33,4 +35,3 @@ Contents pawsey kennedy running-mac - data-curation diff --git a/docs/user-guide.rst b/docs/user-guide.rst index eea596b38..2b9cfe8d7 100644 --- a/docs/user-guide.rst +++ b/docs/user-guide.rst @@ -16,3 +16,4 @@ This section contains the basic user guide for Phantom. utils dumpfile hdf5 + data-curation From 363392a4da14b9a1bc58240c19406fe05ea61c2c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 12:58:15 +1100 Subject: [PATCH 288/814] (docs) major reorganisation into subdirectories [skip ci] --- docs/{ => developer-guide}/bots.rst | 0 docs/{ => developer-guide}/data-curation.rst | 0 docs/{ => developer-guide}/datafiles.rst | 0 docs/{ => developer-guide}/fork.rst | 0 docs/{ => developer-guide}/fortran.rst | 0 .../index.rst} | 0 docs/{ => developer-guide}/philosophy.rst | 0 docs/{ => developer-guide}/sort.rst | 0 docs/{ => developer-guide}/stable.rst | 0 docs/{ => developer-guide}/staging.rst | 0 docs/{ => developer-guide}/styleguide.rst | 0 docs/{ => developer-guide}/testing.rst | 0 docs/{ => developer-guide}/vscode.rst | 0 docs/{ => examples}/CE.rst | 0 docs/{ => examples}/binary.rst | 0 docs/{ => examples}/density.rst | 0 docs/{ => examples}/disc.rst | 0 docs/{ => examples}/dustgrowth.rst | 0 docs/{ => examples}/dustsettle.rst | 0 docs/{ => examples}/hierarchicalsystems.rst | 0 docs/{examples.rst => examples/index.rst} | 0 docs/{ => examples}/mdot.rst | 0 docs/{ => examples}/phantomNR.rst | 0 .../selfgravity_gravitationalinstability.rst | 0 docs/{ => examples}/softstar.rst | 0 docs/{ => examples}/star.rst | 0 docs/{ => examples}/wind.rst | 0 docs/{ => external-utilities}/fortree.rst | 0 docs/{ => external-utilities}/imorbel.rst | 0 .../index.rst} | 0 docs/{ => external-utilities}/mcfost.rst | 0 docs/{ => external-utilities}/phantom-config.rst | 0 docs/{ => external-utilities}/plonk.rst | 0 docs/{ => external-utilities}/sarracen.rst | 0 docs/{ => getting-started}/DiAL.rst | 0 docs/{ => getting-started}/clusters.rst | 0 docs/{ => getting-started}/flatiron.rst | 0 docs/{ => getting-started}/g2.rst | 0 docs/{ => getting-started}/gitinfo.rst | 0 .../index.rst} | 0 docs/{ => getting-started}/kennedy.rst | 0 docs/{ => getting-started}/monarch.rst | 0 docs/{ => getting-started}/nci.rst | 0 docs/{ => getting-started}/ozstar.rst | 0 docs/{ => getting-started}/pawsey.rst | 0 docs/{ => getting-started}/running-clusters.rst | 0 .../running-first-calculation.rst | 0 docs/{ => getting-started}/running-mac.rst | 0 docs/{ => getting-started}/systems-list.rst | 0 docs/index.rst | 12 ++++++------ docs/{ => physics}/eos-list.rst | 0 docs/{ => physics}/eos.rst | 0 docs/{physics-guide.rst => physics/index.rst} | 0 docs/{ => physics}/sink-properties.rst | 0 docs/{ => physics}/sinks.rst | 0 docs/scripts/update_docs_from_code.sh | 10 +++++----- docs/{ => user-guide}/analysis.rst | 0 docs/{ => user-guide}/config.rst | 0 docs/{ => user-guide}/dumpfile.rst | 0 docs/{ => user-guide}/hdf5.rst | 0 docs/{user-guide.rst => user-guide/index.rst} | 0 docs/{ => user-guide}/infile.rst | 0 docs/{ => user-guide}/moddump.rst | 0 docs/{ => user-guide}/mpi.rst | 0 docs/{ => user-guide}/qscript.rst | 0 docs/{ => user-guide}/setup.rst | 0 docs/{ => user-guide}/setups-best.rst | 0 docs/{ => user-guide}/setups-list.rst | 0 docs/{ => user-guide}/setups.rst | 0 docs/{ => user-guide}/sweeps.rst | 0 docs/{ => user-guide}/utils.rst | 0 71 files changed, 11 insertions(+), 11 deletions(-) rename docs/{ => developer-guide}/bots.rst (100%) rename docs/{ => developer-guide}/data-curation.rst (100%) rename docs/{ => developer-guide}/datafiles.rst (100%) rename docs/{ => developer-guide}/fork.rst (100%) rename docs/{ => developer-guide}/fortran.rst (100%) rename docs/{developer-guide.rst => developer-guide/index.rst} (100%) rename docs/{ => developer-guide}/philosophy.rst (100%) rename docs/{ => developer-guide}/sort.rst (100%) rename docs/{ => developer-guide}/stable.rst (100%) rename docs/{ => developer-guide}/staging.rst (100%) rename docs/{ => developer-guide}/styleguide.rst (100%) rename docs/{ => developer-guide}/testing.rst (100%) rename docs/{ => developer-guide}/vscode.rst (100%) rename docs/{ => examples}/CE.rst (100%) rename docs/{ => examples}/binary.rst (100%) rename docs/{ => examples}/density.rst (100%) rename docs/{ => examples}/disc.rst (100%) rename docs/{ => examples}/dustgrowth.rst (100%) rename docs/{ => examples}/dustsettle.rst (100%) rename docs/{ => examples}/hierarchicalsystems.rst (100%) rename docs/{examples.rst => examples/index.rst} (100%) rename docs/{ => examples}/mdot.rst (100%) rename docs/{ => examples}/phantomNR.rst (100%) rename docs/{ => examples}/selfgravity_gravitationalinstability.rst (100%) rename docs/{ => examples}/softstar.rst (100%) rename docs/{ => examples}/star.rst (100%) rename docs/{ => examples}/wind.rst (100%) rename docs/{ => external-utilities}/fortree.rst (100%) rename docs/{ => external-utilities}/imorbel.rst (100%) rename docs/{external-utilities.rst => external-utilities/index.rst} (100%) rename docs/{ => external-utilities}/mcfost.rst (100%) rename docs/{ => external-utilities}/phantom-config.rst (100%) rename docs/{ => external-utilities}/plonk.rst (100%) rename docs/{ => external-utilities}/sarracen.rst (100%) rename docs/{ => getting-started}/DiAL.rst (100%) rename docs/{ => getting-started}/clusters.rst (100%) rename docs/{ => getting-started}/flatiron.rst (100%) rename docs/{ => getting-started}/g2.rst (100%) rename docs/{ => getting-started}/gitinfo.rst (100%) rename docs/{getting-started.rst => getting-started/index.rst} (100%) rename docs/{ => getting-started}/kennedy.rst (100%) rename docs/{ => getting-started}/monarch.rst (100%) rename docs/{ => getting-started}/nci.rst (100%) rename docs/{ => getting-started}/ozstar.rst (100%) rename docs/{ => getting-started}/pawsey.rst (100%) rename docs/{ => getting-started}/running-clusters.rst (100%) rename docs/{ => getting-started}/running-first-calculation.rst (100%) rename docs/{ => getting-started}/running-mac.rst (100%) rename docs/{ => getting-started}/systems-list.rst (100%) rename docs/{ => physics}/eos-list.rst (100%) rename docs/{ => physics}/eos.rst (100%) rename docs/{physics-guide.rst => physics/index.rst} (100%) rename docs/{ => physics}/sink-properties.rst (100%) rename docs/{ => physics}/sinks.rst (100%) rename docs/{ => user-guide}/analysis.rst (100%) rename docs/{ => user-guide}/config.rst (100%) rename docs/{ => user-guide}/dumpfile.rst (100%) rename docs/{ => user-guide}/hdf5.rst (100%) rename docs/{user-guide.rst => user-guide/index.rst} (100%) rename docs/{ => user-guide}/infile.rst (100%) rename docs/{ => user-guide}/moddump.rst (100%) rename docs/{ => user-guide}/mpi.rst (100%) rename docs/{ => user-guide}/qscript.rst (100%) rename docs/{ => user-guide}/setup.rst (100%) rename docs/{ => user-guide}/setups-best.rst (100%) rename docs/{ => user-guide}/setups-list.rst (100%) rename docs/{ => user-guide}/setups.rst (100%) rename docs/{ => user-guide}/sweeps.rst (100%) rename docs/{ => user-guide}/utils.rst (100%) diff --git a/docs/bots.rst b/docs/developer-guide/bots.rst similarity index 100% rename from docs/bots.rst rename to docs/developer-guide/bots.rst diff --git a/docs/data-curation.rst b/docs/developer-guide/data-curation.rst similarity index 100% rename from docs/data-curation.rst rename to docs/developer-guide/data-curation.rst diff --git a/docs/datafiles.rst b/docs/developer-guide/datafiles.rst similarity index 100% rename from docs/datafiles.rst rename to docs/developer-guide/datafiles.rst diff --git a/docs/fork.rst b/docs/developer-guide/fork.rst similarity index 100% rename from docs/fork.rst rename to docs/developer-guide/fork.rst diff --git a/docs/fortran.rst b/docs/developer-guide/fortran.rst similarity index 100% rename from docs/fortran.rst rename to docs/developer-guide/fortran.rst diff --git a/docs/developer-guide.rst b/docs/developer-guide/index.rst similarity index 100% rename from docs/developer-guide.rst rename to docs/developer-guide/index.rst diff --git a/docs/philosophy.rst b/docs/developer-guide/philosophy.rst similarity index 100% rename from docs/philosophy.rst rename to docs/developer-guide/philosophy.rst diff --git a/docs/sort.rst b/docs/developer-guide/sort.rst similarity index 100% rename from docs/sort.rst rename to docs/developer-guide/sort.rst diff --git a/docs/stable.rst b/docs/developer-guide/stable.rst similarity index 100% rename from docs/stable.rst rename to docs/developer-guide/stable.rst diff --git a/docs/staging.rst b/docs/developer-guide/staging.rst similarity index 100% rename from docs/staging.rst rename to docs/developer-guide/staging.rst diff --git a/docs/styleguide.rst b/docs/developer-guide/styleguide.rst similarity index 100% rename from docs/styleguide.rst rename to docs/developer-guide/styleguide.rst diff --git a/docs/testing.rst b/docs/developer-guide/testing.rst similarity index 100% rename from docs/testing.rst rename to docs/developer-guide/testing.rst diff --git a/docs/vscode.rst b/docs/developer-guide/vscode.rst similarity index 100% rename from docs/vscode.rst rename to docs/developer-guide/vscode.rst diff --git a/docs/CE.rst b/docs/examples/CE.rst similarity index 100% rename from docs/CE.rst rename to docs/examples/CE.rst diff --git a/docs/binary.rst b/docs/examples/binary.rst similarity index 100% rename from docs/binary.rst rename to docs/examples/binary.rst diff --git a/docs/density.rst b/docs/examples/density.rst similarity index 100% rename from docs/density.rst rename to docs/examples/density.rst diff --git a/docs/disc.rst b/docs/examples/disc.rst similarity index 100% rename from docs/disc.rst rename to docs/examples/disc.rst diff --git a/docs/dustgrowth.rst b/docs/examples/dustgrowth.rst similarity index 100% rename from docs/dustgrowth.rst rename to docs/examples/dustgrowth.rst diff --git a/docs/dustsettle.rst b/docs/examples/dustsettle.rst similarity index 100% rename from docs/dustsettle.rst rename to docs/examples/dustsettle.rst diff --git a/docs/hierarchicalsystems.rst b/docs/examples/hierarchicalsystems.rst similarity index 100% rename from docs/hierarchicalsystems.rst rename to docs/examples/hierarchicalsystems.rst diff --git a/docs/examples.rst b/docs/examples/index.rst similarity index 100% rename from docs/examples.rst rename to docs/examples/index.rst diff --git a/docs/mdot.rst b/docs/examples/mdot.rst similarity index 100% rename from docs/mdot.rst rename to docs/examples/mdot.rst diff --git a/docs/phantomNR.rst b/docs/examples/phantomNR.rst similarity index 100% rename from docs/phantomNR.rst rename to docs/examples/phantomNR.rst diff --git a/docs/selfgravity_gravitationalinstability.rst b/docs/examples/selfgravity_gravitationalinstability.rst similarity index 100% rename from docs/selfgravity_gravitationalinstability.rst rename to docs/examples/selfgravity_gravitationalinstability.rst diff --git a/docs/softstar.rst b/docs/examples/softstar.rst similarity index 100% rename from docs/softstar.rst rename to docs/examples/softstar.rst diff --git a/docs/star.rst b/docs/examples/star.rst similarity index 100% rename from docs/star.rst rename to docs/examples/star.rst diff --git a/docs/wind.rst b/docs/examples/wind.rst similarity index 100% rename from docs/wind.rst rename to docs/examples/wind.rst diff --git a/docs/fortree.rst b/docs/external-utilities/fortree.rst similarity index 100% rename from docs/fortree.rst rename to docs/external-utilities/fortree.rst diff --git a/docs/imorbel.rst b/docs/external-utilities/imorbel.rst similarity index 100% rename from docs/imorbel.rst rename to docs/external-utilities/imorbel.rst diff --git a/docs/external-utilities.rst b/docs/external-utilities/index.rst similarity index 100% rename from docs/external-utilities.rst rename to docs/external-utilities/index.rst diff --git a/docs/mcfost.rst b/docs/external-utilities/mcfost.rst similarity index 100% rename from docs/mcfost.rst rename to docs/external-utilities/mcfost.rst diff --git a/docs/phantom-config.rst b/docs/external-utilities/phantom-config.rst similarity index 100% rename from docs/phantom-config.rst rename to docs/external-utilities/phantom-config.rst diff --git a/docs/plonk.rst b/docs/external-utilities/plonk.rst similarity index 100% rename from docs/plonk.rst rename to docs/external-utilities/plonk.rst diff --git a/docs/sarracen.rst b/docs/external-utilities/sarracen.rst similarity index 100% rename from docs/sarracen.rst rename to docs/external-utilities/sarracen.rst diff --git a/docs/DiAL.rst b/docs/getting-started/DiAL.rst similarity index 100% rename from docs/DiAL.rst rename to docs/getting-started/DiAL.rst diff --git a/docs/clusters.rst b/docs/getting-started/clusters.rst similarity index 100% rename from docs/clusters.rst rename to docs/getting-started/clusters.rst diff --git a/docs/flatiron.rst b/docs/getting-started/flatiron.rst similarity index 100% rename from docs/flatiron.rst rename to docs/getting-started/flatiron.rst diff --git a/docs/g2.rst b/docs/getting-started/g2.rst similarity index 100% rename from docs/g2.rst rename to docs/getting-started/g2.rst diff --git a/docs/gitinfo.rst b/docs/getting-started/gitinfo.rst similarity index 100% rename from docs/gitinfo.rst rename to docs/getting-started/gitinfo.rst diff --git a/docs/getting-started.rst b/docs/getting-started/index.rst similarity index 100% rename from docs/getting-started.rst rename to docs/getting-started/index.rst diff --git a/docs/kennedy.rst b/docs/getting-started/kennedy.rst similarity index 100% rename from docs/kennedy.rst rename to docs/getting-started/kennedy.rst diff --git a/docs/monarch.rst b/docs/getting-started/monarch.rst similarity index 100% rename from docs/monarch.rst rename to docs/getting-started/monarch.rst diff --git a/docs/nci.rst b/docs/getting-started/nci.rst similarity index 100% rename from docs/nci.rst rename to docs/getting-started/nci.rst diff --git a/docs/ozstar.rst b/docs/getting-started/ozstar.rst similarity index 100% rename from docs/ozstar.rst rename to docs/getting-started/ozstar.rst diff --git a/docs/pawsey.rst b/docs/getting-started/pawsey.rst similarity index 100% rename from docs/pawsey.rst rename to docs/getting-started/pawsey.rst diff --git a/docs/running-clusters.rst b/docs/getting-started/running-clusters.rst similarity index 100% rename from docs/running-clusters.rst rename to docs/getting-started/running-clusters.rst diff --git a/docs/running-first-calculation.rst b/docs/getting-started/running-first-calculation.rst similarity index 100% rename from docs/running-first-calculation.rst rename to docs/getting-started/running-first-calculation.rst diff --git a/docs/running-mac.rst b/docs/getting-started/running-mac.rst similarity index 100% rename from docs/running-mac.rst rename to docs/getting-started/running-mac.rst diff --git a/docs/systems-list.rst b/docs/getting-started/systems-list.rst similarity index 100% rename from docs/systems-list.rst rename to docs/getting-started/systems-list.rst diff --git a/docs/index.rst b/docs/index.rst index 8946b7d98..aabf50518 100644 --- a/docs/index.rst +++ b/docs/index.rst @@ -20,12 +20,12 @@ Contents .. toctree:: :maxdepth: 1 - getting-started - user-guide - examples - external-utilities - physics-guide - developer-guide + getting-started/index + user-guide/index + examples/index + external-utilities/index + physics/index + developer-guide/index faq releasenotes diff --git a/docs/eos-list.rst b/docs/physics/eos-list.rst similarity index 100% rename from docs/eos-list.rst rename to docs/physics/eos-list.rst diff --git a/docs/eos.rst b/docs/physics/eos.rst similarity index 100% rename from docs/eos.rst rename to docs/physics/eos.rst diff --git a/docs/physics-guide.rst b/docs/physics/index.rst similarity index 100% rename from docs/physics-guide.rst rename to docs/physics/index.rst diff --git a/docs/sink-properties.rst b/docs/physics/sink-properties.rst similarity index 100% rename from docs/sink-properties.rst rename to docs/physics/sink-properties.rst diff --git a/docs/sinks.rst b/docs/physics/sinks.rst similarity index 100% rename from docs/sinks.rst rename to docs/physics/sinks.rst diff --git a/docs/scripts/update_docs_from_code.sh b/docs/scripts/update_docs_from_code.sh index a960966f0..852e5a3cc 100755 --- a/docs/scripts/update_docs_from_code.sh +++ b/docs/scripts/update_docs_from_code.sh @@ -1,5 +1,5 @@ -./sink_particle_properties.pl > ../sink-properties.rst -./eos_options.pl > ../eos-list.rst -./print_setups.sh > ../setups-list.rst -./print_setups.sh best > ../setups-best.rst -./print_systems.sh > ../systems-list.rst +./sink_particle_properties.pl > ../physics/sink-properties.rst +./eos_options.pl > ../physics/eos-list.rst +./print_setups.sh > ../user-guide/setups-list.rst +./print_setups.sh best > ../user-guide/setups-best.rst +./print_systems.sh > ../getting-started/systems-list.rst diff --git a/docs/analysis.rst b/docs/user-guide/analysis.rst similarity index 100% rename from docs/analysis.rst rename to docs/user-guide/analysis.rst diff --git a/docs/config.rst b/docs/user-guide/config.rst similarity index 100% rename from docs/config.rst rename to docs/user-guide/config.rst diff --git a/docs/dumpfile.rst b/docs/user-guide/dumpfile.rst similarity index 100% rename from docs/dumpfile.rst rename to docs/user-guide/dumpfile.rst diff --git a/docs/hdf5.rst b/docs/user-guide/hdf5.rst similarity index 100% rename from docs/hdf5.rst rename to docs/user-guide/hdf5.rst diff --git a/docs/user-guide.rst b/docs/user-guide/index.rst similarity index 100% rename from docs/user-guide.rst rename to docs/user-guide/index.rst diff --git a/docs/infile.rst b/docs/user-guide/infile.rst similarity index 100% rename from docs/infile.rst rename to docs/user-guide/infile.rst diff --git a/docs/moddump.rst b/docs/user-guide/moddump.rst similarity index 100% rename from docs/moddump.rst rename to docs/user-guide/moddump.rst diff --git a/docs/mpi.rst b/docs/user-guide/mpi.rst similarity index 100% rename from docs/mpi.rst rename to docs/user-guide/mpi.rst diff --git a/docs/qscript.rst b/docs/user-guide/qscript.rst similarity index 100% rename from docs/qscript.rst rename to docs/user-guide/qscript.rst diff --git a/docs/setup.rst b/docs/user-guide/setup.rst similarity index 100% rename from docs/setup.rst rename to docs/user-guide/setup.rst diff --git a/docs/setups-best.rst b/docs/user-guide/setups-best.rst similarity index 100% rename from docs/setups-best.rst rename to docs/user-guide/setups-best.rst diff --git a/docs/setups-list.rst b/docs/user-guide/setups-list.rst similarity index 100% rename from docs/setups-list.rst rename to docs/user-guide/setups-list.rst diff --git a/docs/setups.rst b/docs/user-guide/setups.rst similarity index 100% rename from docs/setups.rst rename to docs/user-guide/setups.rst diff --git a/docs/sweeps.rst b/docs/user-guide/sweeps.rst similarity index 100% rename from docs/sweeps.rst rename to docs/user-guide/sweeps.rst diff --git a/docs/utils.rst b/docs/user-guide/utils.rst similarity index 100% rename from docs/utils.rst rename to docs/user-guide/utils.rst From 80b76e74b3a2f631a55467bd67aabd951ca0e245 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 13:01:48 +1100 Subject: [PATCH 289/814] (docs) fix missing images [skip ci] --- docs/external-utilities/plonk.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/external-utilities/plonk.rst b/docs/external-utilities/plonk.rst index 646e7395e..1b2db485d 100644 --- a/docs/external-utilities/plonk.rst +++ b/docs/external-utilities/plonk.rst @@ -10,12 +10,12 @@ hydrodynamics data. Plonk is open source. Examples -------- -.. figure:: _static/images/plonk_render.png +.. figure:: ../_static/images/plonk_render.png Density projection render of a snapshot in Cartesian coordinates, and polar coordinates. The data comes from a single Phantom dump. -.. figure:: _static/images/plonk_accretion.png +.. figure:: ../_static/images/plonk_accretion.png Mass accretion and accretion rate onto sink particles. The data comes from the Phantom sink `.ev` files. From cd95febb0ed63c0e7da5e0ddebb6e5297036cc7c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 13:03:09 +1100 Subject: [PATCH 290/814] (docs) fix missing images [skip ci] --- docs/developer-guide/vscode.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/developer-guide/vscode.rst b/docs/developer-guide/vscode.rst index 8863f567c..2e32d871a 100644 --- a/docs/developer-guide/vscode.rst +++ b/docs/developer-guide/vscode.rst @@ -3,13 +3,13 @@ Coding Phantom in VSCode or Cursor AI In VSCode or Cursor there are several helpful settings when editing Phantom source files. After installing a modern Fortran extension, to enforce the indentation conventions in Phantom you should use `findent `_ as in the indentation engine: -.. image:: images/vscode-findent.png +.. image:: ../images/vscode-findent.png :width: 800 :alt: findent option in VSCode and pass it the same options as used in `the bots script `_: -.. image:: images/vscode-findent-flags.png +.. image:: ../images/vscode-findent-flags.png :width: 800 :alt: findent flags in VSCode From 7c15728e5352b82268e417b98d9f66e504a77363 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 14:03:31 +1100 Subject: [PATCH 291/814] (docs) fix broken links [skip ci] --- docs/developer-guide/stable.rst | 2 +- docs/developer-guide/staging.rst | 2 +- docs/examples/disc.rst | 4 ++-- docs/getting-started/running-first-calculation.rst | 2 +- docs/{developer-guide => user-guide}/data-curation.rst | 0 5 files changed, 5 insertions(+), 5 deletions(-) rename docs/{developer-guide => user-guide}/data-curation.rst (100%) diff --git a/docs/developer-guide/stable.rst b/docs/developer-guide/stable.rst index f371ced62..c69ef2b8a 100644 --- a/docs/developer-guide/stable.rst +++ b/docs/developer-guide/stable.rst @@ -2,7 +2,7 @@ How to use download and use stable code releases ================================================ The master branch of phantom develops rapidly, but if you want to only -:doc:`stable versions of phantom `, the best way is to use +:doc:`stable versions of phantom <../releasenotes>`, the best way is to use the \`stable’ code branch from the git repository. **Nobody has permission** to push directly to the stable branch, it must be updated via pull request, so it **cannot** be inadvertently broken diff --git a/docs/developer-guide/staging.rst b/docs/developer-guide/staging.rst index 750537b35..685765882 100644 --- a/docs/developer-guide/staging.rst +++ b/docs/developer-guide/staging.rst @@ -5,7 +5,7 @@ Procedure is: - set the version number in phantom/build/Makefile - set the version number in phantom/docs/conf.py -- update the :doc:`release notes ` +- update the :doc:`release notes <../releasenotes>` - use git to tag the code version for the release :: diff --git a/docs/examples/disc.rst b/docs/examples/disc.rst index e64c67f58..f1d0e25cf 100644 --- a/docs/examples/disc.rst +++ b/docs/examples/disc.rst @@ -138,7 +138,7 @@ The above procedure prints a .discparams file (in the above example would be called disc.discparams) that contains some of the parameters used to initialise the disc setup. -For a circumbinary disc the equation of state is set to a vertically isothermal equation of state (ieos=3) where the radius is taken with respect to *the coordinate origin*. See :doc:`Equations of state available in Phantom ` +For a circumbinary disc the equation of state is set to a vertically isothermal equation of state (ieos=3) where the radius is taken with respect to *the coordinate origin*. See :doc:`Equations of state available in Phantom ` check the .in file and proceed to run phantom ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -181,7 +181,7 @@ which produces:: secondary mass : 1.00 mass ratio : 1.00 -For a circumprimary disc the equation of state is set to ieos=6, such that the radius is taken with respect to the first sink particle in the simulation. See :doc:`Equations of state available in Phantom ` +For a circumprimary disc the equation of state is set to ieos=6, such that the radius is taken with respect to the first sink particle in the simulation. See :doc:`Equations of state available in Phantom ` The Farris et al. (2014) :doc:`equation of state ` (ieos=14 for a binary or ieos=13 if there are more than two stars) is also useful for a flyby simulation if one does not want to have excessively cold material around the secondary diff --git a/docs/getting-started/running-first-calculation.rst b/docs/getting-started/running-first-calculation.rst index 25423d443..ac2462bc7 100644 --- a/docs/getting-started/running-first-calculation.rst +++ b/docs/getting-started/running-first-calculation.rst @@ -153,7 +153,7 @@ For the Sedov example shown above, there’s even an exact solution included in .. important:: If you have v2.x or earlier of splash, - type ssplash instead of splash to read :doc:`the phantom native binary format`. + type ssplash instead of splash to read :doc:`the phantom native binary format`. The .ev files, which are just ascii files containing global quantities as a function of time:: diff --git a/docs/developer-guide/data-curation.rst b/docs/user-guide/data-curation.rst similarity index 100% rename from docs/developer-guide/data-curation.rst rename to docs/user-guide/data-curation.rst From 441e9975837745dfa35a3cd6a81dbcfbb104d769 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jan 2024 15:46:34 +1100 Subject: [PATCH 292/814] (docs) compile sphinx docs without errors or warnings [skip ci] --- docs/conf.py | 2 +- .../{user-guide => developer-guide}/setup.rst | 38 +- docs/developer-guide/stable.rst | 35 -- docs/developer-guide/testing.rst | 10 +- docs/examples/CE.rst | 6 +- docs/examples/binary.rst | 6 +- docs/examples/disc.rst | 4 +- docs/examples/index.rst | 2 + docs/examples/mdot.rst | 2 +- .../selfgravity_gravitationalinstability.rst | 8 +- docs/examples/star.rst | 16 +- docs/examples/wind.rst | 57 +-- docs/getting-started/flatiron.rst | 4 +- docs/getting-started/gitinfo.rst | 5 +- docs/getting-started/index.rst | 4 +- docs/getting-started/nci.rst | 14 +- .../running-first-calculation.rst | 6 +- docs/getting-started/systems-list.rst | 90 ++-- docs/physics/eos-list.rst | 249 +++++----- docs/physics/eos.rst | 3 - docs/physics/sink-properties.rst | 66 +-- docs/scripts/eos_options.pl | 20 +- docs/scripts/print_setups.sh | 10 +- docs/scripts/print_systems.sh | 10 +- docs/scripts/sink_particle_properties.pl | 10 +- docs/user-guide/analysis.rst | 4 +- docs/user-guide/data-curation.rst | 2 +- docs/user-guide/dumpfile.rst | 10 +- docs/user-guide/index.rst | 1 + docs/user-guide/setups-best.rst | 34 +- docs/user-guide/setups-list.rst | 430 +++++++++--------- src/main/utils_mathfunc.f90 | 17 +- src/main/utils_timing.f90 | 2 + src/setup/density_profiles.f90 | 13 +- src/setup/set_Bfield.f90 | 8 +- src/setup/set_flyby.f90 | 19 +- src/setup/stretchmap.f90 | 11 +- src/tests/test_radiation.f90 | 8 +- 38 files changed, 586 insertions(+), 650 deletions(-) rename docs/{user-guide => developer-guide}/setup.rst (62%) delete mode 100644 docs/developer-guide/stable.rst diff --git a/docs/conf.py b/docs/conf.py index f714b296b..4b2549359 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -62,7 +62,7 @@ # # This is also used if you do content translation via gettext catalogs. # Usually you set "language" from the command line for these cases. -language = None +language = 'en' # List of patterns, relative to source directory, that match files and # directories to ignore when looking for source files. diff --git a/docs/user-guide/setup.rst b/docs/developer-guide/setup.rst similarity index 62% rename from docs/user-guide/setup.rst rename to docs/developer-guide/setup.rst index 0bf48ef3d..b6a97936b 100644 --- a/docs/user-guide/setup.rst +++ b/docs/developer-guide/setup.rst @@ -3,7 +3,7 @@ Initial conditions / writing your own setup routine Steps are: -1. check that a :doc:`setup routine for your problem ` does not already exist. +1. check that a :doc:`setup routine for your problem ` does not already exist. 2. copy one of the existing setups (e.g. setup_unifdis.f90) to a new file (e.g. setup_myproblem.f90). 3. edit this file. @@ -64,26 +64,26 @@ be present in the subroutine). Utility routines ~~~~~~~~~~~~~~~~ -There are several routines in the :doc:`libsetup ` library to assist with setting up the +There are several routines in the :doc:`libsetup ` library to assist with setting up the particle positions: -+---------------------------------------+-----------------------------------------------+ -| module/subroutine | purpose | -+=======================================+===============================================+ -| :doc:`set_unifdis ` | sets up a uniform particle distribution with | -| | particles set on various lattice options | -+---------------------------------------+-----------------------------------------------+ -| :doc:`set_sphere ` | sets up a uniform density sphere | -| | (interface to set_unifdis) | -+---------------------------------------+-----------------------------------------------+ -| :doc:`set_disc ` | sets up a single accretion disc with given | -| | surface density and temperature profiles | -+---------------------------------------+-----------------------------------------------+ -| :doc:`set_binary ` | sets up a binary consisting of two point mass | -| | particles with all 6 orbital elements | -+---------------------------------------+-----------------------------------------------+ -| :doc:`set_slab ` | sets up a thin slab for 2D tests done in 3D | -+---------------------------------------+-----------------------------------------------+ ++---------------------------------------------+-----------------------------------------------+ +| module/subroutine | purpose | ++=============================================+===============================================+ +| :doc:`set_unifdis ` | sets up a uniform particle distribution with | +| | particles set on various lattice options | ++---------------------------------------------+-----------------------------------------------+ +| :doc:`set_sphere ` | sets up a uniform density sphere | +| | (interface to set_unifdis) | ++---------------------------------------------+-----------------------------------------------+ +| :doc:`set_disc ` | sets up a single accretion disc with given | +| | surface density and temperature profiles | ++---------------------------------------------+-----------------------------------------------+ +| :doc:`set_binary ` | sets up a binary consisting of two point mass | +| | particles with all 6 orbital elements | ++---------------------------------------------+-----------------------------------------------+ +| :doc:`set_slab ` | sets up a thin slab for 2D tests done in 3D | ++---------------------------------------------+-----------------------------------------------+ Try to use these wherever possible. This makes the setup routines much simpler and means less cut-and-pasting between otherwise similar setups. diff --git a/docs/developer-guide/stable.rst b/docs/developer-guide/stable.rst deleted file mode 100644 index c69ef2b8a..000000000 --- a/docs/developer-guide/stable.rst +++ /dev/null @@ -1,35 +0,0 @@ -How to use download and use stable code releases -================================================ - -The master branch of phantom develops rapidly, but if you want to only -:doc:`stable versions of phantom <../releasenotes>`, the best way is to use -the \`stable’ code branch from the git repository. **Nobody has -permission** to push directly to the stable branch, it must be updated -via pull request, so it **cannot** be inadvertently broken - -Obtaining a stable copy of the code ------------------------------------ - -:: - - $ git clone https://github.com/danieljprice/phantom - $ cd phantom - $ git checkout stable - -Updating to the latest stable copy of the code ----------------------------------------------- - -Simply use \`git pull’ while on the stable branch: - -:: - - $ git checkout stable - $ git pull - -Switching back to the developer version ---------------------------------------- - -:: - - $ cd phantom - $ git checkout master diff --git a/docs/developer-guide/testing.rst b/docs/developer-guide/testing.rst index 9d9fc9f03..0a956ab7f 100644 --- a/docs/developer-guide/testing.rst +++ b/docs/developer-guide/testing.rst @@ -106,7 +106,7 @@ The buildbot ~~~~~~~~~~~~ The buildbot also runs in `an action `_ and checks that the code compiles in :doc:`all of -the possible SETUP configurations in the Makefile `. You can run this +the possible SETUP configurations in the Makefile `. You can run this offline as follows:: cd phantom/scripts @@ -134,8 +134,8 @@ I suggest to do this *only* as a last resort. The recommended steps are as follo Running the actions locally ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Install `Docker `_ -2. Install `act `_ +1. Install `Docker `__ +2. Install `act `__ 3. run the pull_request workflow :: @@ -145,9 +145,9 @@ Running the actions locally Checking the phantom build that is failing manually ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If you just want to check things manually but in the same environment -as used in the actions, try the following:: +as used in the actions, try the following: -1. Install [Docker](https://docs.docker.com/desktop/install/mac-install/) +1. Install `Docker `__ 2. Install Docker command line tools :: diff --git a/docs/examples/CE.rst b/docs/examples/CE.rst index 382a7b017..2c38b5f86 100644 --- a/docs/examples/CE.rst +++ b/docs/examples/CE.rst @@ -1,5 +1,5 @@ How to set up and run a common envelope binary simulation -========================================================= +========================================================== Polytropic star + sink companion -------------------------------- @@ -76,7 +76,9 @@ Use SETUP=star or SETUP=dustystar and if not specified, the default options. the core mass is the same as the one you have measured from MESA (0.46Mo in Jan_Star_Phantom_Profile.data). This produces a file called star.setup - this file has all the options so you can edit it. 2.4 vim star.setup, (write_rho_to_file = T) -Relaxation + + +Relaxation of the star :: diff --git a/docs/examples/binary.rst b/docs/examples/binary.rst index 853c3ebb7..a83a390ca 100644 --- a/docs/examples/binary.rst +++ b/docs/examples/binary.rst @@ -2,11 +2,11 @@ Binary stars and common envelope evolution ============================================ Setting up and relaxing binary stars (the easy way) ---------------------------------------------------- -The one-stop-shop to setup a binary star simulation is as follows:: +---------------------------------------------------- +The one-stop-shop to setup a binary star simulation is as follows: make a new directory and write a local Makefile -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ :: diff --git a/docs/examples/disc.rst b/docs/examples/disc.rst index f1d0e25cf..d4232fbde 100644 --- a/docs/examples/disc.rst +++ b/docs/examples/disc.rst @@ -181,9 +181,9 @@ which produces:: secondary mass : 1.00 mass ratio : 1.00 -For a circumprimary disc the equation of state is set to ieos=6, such that the radius is taken with respect to the first sink particle in the simulation. See :doc:`Equations of state available in Phantom ` +For a circumprimary disc the equation of state is set to ieos=6, such that the radius is taken with respect to the first sink particle in the simulation. See :doc:`Equations of state available in Phantom ` -The Farris et al. (2014) :doc:`equation of state ` (ieos=14 for a binary or ieos=13 if there are more than two stars) is also useful for a flyby simulation if one does not want to have excessively cold material around the secondary +The Farris et al. (2014) :doc:`equation of state ` (ieos=14 for a binary or ieos=13 if there are more than two stars) is also useful for a flyby simulation if one does not want to have excessively cold material around the secondary Protoplanetary disc with embedded planets diff --git a/docs/examples/index.rst b/docs/examples/index.rst index 00d619c81..63d576bc5 100644 --- a/docs/examples/index.rst +++ b/docs/examples/index.rst @@ -11,10 +11,12 @@ This section contains some examples of physical problems that you can solve with disc binary star + CE softstar dustsettle dustgrowth density hierarchicalsystems selfgravity_gravitationalinstability + phantomNR wind \ No newline at end of file diff --git a/docs/examples/mdot.rst b/docs/examples/mdot.rst index 4c687dc37..00f6e6feb 100644 --- a/docs/examples/mdot.rst +++ b/docs/examples/mdot.rst @@ -66,7 +66,7 @@ Write an analysis module More generally, to have full access to all of the sink particle information in the dump files, :doc:`write yourself a module for the -phantomanalysis utility `. Then you can just import the sink +phantomanalysis utility `. Then you can just import the sink particle arrays directly and perform whatever analysis you desire. You can access the mass accreted by a sink particle by first importing diff --git a/docs/examples/selfgravity_gravitationalinstability.rst b/docs/examples/selfgravity_gravitationalinstability.rst index 5960326f9..8146e009e 100644 --- a/docs/examples/selfgravity_gravitationalinstability.rst +++ b/docs/examples/selfgravity_gravitationalinstability.rst @@ -1,15 +1,15 @@ Simulation of self-gravitating and gravitationally unstable accretion discs -==================================================================== +============================================================================ In PHANTOM, it is possible to perform simulations of accretion discs taking into account the role of the disc self-gravity and, possibly, to trigger gravitational instability. Self-gravity in (vertically isothermal) accretion discs ------------------- +-------------------------------------------------------- Normally in the *disc* and *dustydisc* environments the disc self-gravity is not taken into account. Indeed, usually the disc to star mass ratio is so low that the disc contribution to the gravitational potential is negligible. The setups *isosgdisc* and *dustyisosgdisc* allow simulating vertically isothermal discs with self-gravity and disc viscosity ($α_{SS}$), and work as the *disc* and *dustydisc* ones. -Gravitational instability accretion discs ------------------- +Gravitationally unstable accretion discs +------------------------------------------ The environments *sgdisc* and *dustysgdisc* allow the user to simulate a gravitationally unstable accretion disc. Gravitational instability is triggered by cooling, using an adiabatic equation of state and without disc viscosity. Usually, a cooling law it is prescribed, and the simplest one has been proposed by Gammie (2001): the cooling timescale $t_{cool}$ is assumed to be proportional to the dynamical time of the disc $t_{dyn}$ so that $t_{cool} = β t_{dyn}$. In the *setup* file there are the disc parameters, and in the *input* file it is possible to prescribe the cooling law. In particular, the variables to pay attention to are: diff --git a/docs/examples/star.rst b/docs/examples/star.rst index 978bf81b4..ba81b1969 100644 --- a/docs/examples/star.rst +++ b/docs/examples/star.rst @@ -4,11 +4,11 @@ Setting up stars and tidal disruption events Setting up and relaxing a star ------------------------------ -First, follow the usual procedure for initiating a new simulation with -phantom. We’ll use the “star” setup, but you can also use the -“polytrope” or “neutronstar” configurations (the first two use self-gravity +First, follow the :doc:`usual procedure for initiating a new simulation with +phantom `. We’ll use the “:doc:`star `” setup, but you can also use the +“:doc:`polytrope `” or “:doc:`neutronstar `” configurations (the first two use self-gravity for the star, the last one uses an external potential). For tidal disruption -events in general relativity use“grtde”. That is: +events in general relativity use “:doc:`grtde `”. That is: make a new directory and write a local Makefile ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -121,7 +121,7 @@ check the output Putting the star on an orbit for a tidal disruption event --------------------------------------------------------- -If you used the “tde” or "grtde" setup then simply compile :doc:`moddump `:: +If you used the “tde” or "grtde" setup then simply compile :doc:`moddump `:: $ make moddump @@ -162,8 +162,8 @@ compile phantommoddump ~~~~~~~~~~~~~~~~~~~~~~ The module used to compile this utility is specified using MODFILE= in -phantom/build/Makefile. The default for the “polytrope” setup is -currently moddump_spheres.f90:: +`build/Makefile_setups `__. +The default for the “polytrope” setup is currently moddump_spheres.f90:: MODFILE=moddump_spheres.f90 @@ -201,4 +201,4 @@ now implement something decent in src/setup/set_Bfield.f90 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ you can either use the pre-cooked magnetic field setups in this routine, -or you can just make a new :doc:`moddump ` module that sets up the magnetic field in a custom way. +or you can just make a new :doc:`moddump ` module that sets up the magnetic field in a custom way. diff --git a/docs/examples/wind.rst b/docs/examples/wind.rst index d6a31b739..f69600296 100644 --- a/docs/examples/wind.rst +++ b/docs/examples/wind.rst @@ -30,8 +30,6 @@ For an isothermal wind, use SETUP=isowind At the end of these instructions, a wind.setup and wind.in file are created. Each file contains specific options that are described below. Note that you may need to run ``./phantomsetup wind`` a few times to get to the final setting. -:: - Content of the .setup file -------------------------- @@ -64,9 +62,6 @@ so you only need to provide 2 out of these 3 variables. - If you provide all the quantites, the radius will be recalculated -:: - - Content of the .in file ----------------------- @@ -87,67 +82,47 @@ Options controlling particle injection iboundary_spheres = 5 ! number of boundary spheres (integer) outer_boundary = 50. ! delete gas particles outside this radius (au) -Here’s a brief description of each of them (remember that technical details can be found in `Siess et al. (2023)` - -:: +Here’s a brief description of each of them (remember that technical details can be found in `Siess et al. (2023)`:: sonic_type = 0 ! find transonic solution (1=yes,0=no) decide whether you set the initial wind velocity (``sonic_type = 0``) or if you let the code find the trans-sonic solution. -In this latter case, you need a high wind temperature (coronal wind) so the pressure gradient can overcome the stellar gravity. - -:: +In this latter case, you need a high wind temperature (coronal wind) so the pressure gradient can overcome the stellar gravity:: wind_velocity = 15. ! injection wind velocity (km/s, if sonic_type = 0) -set the launching wind velocity (if sonic_type = 0) - -:: +set the launching wind velocity (if sonic_type = 0):: wind_inject_radius = 1.100 ! wind injection radius (au, if 0 take Rstar) -set the distance from the star's center where the wind is launched. If set to zero, the stellar surface is assumed - -:: +set the distance from the star's center where the wind is launched. If set to zero, the stellar surface is assumed:: wind_mass_rate = 1.000E-05 ! wind mass loss rate (Msun/yr) -set the mass loss rate - -:: +set the mass loss rate:: wind_temperature = 2500. ! wind temperature at the injection point (K) -set the wind temperature. For trans-sonic solution, this value needs to be high (> 10,000 K) - -:: +set the wind temperature. For trans-sonic solution, this value needs to be high (> 10,000 K):: iwind_resolution = 10 ! if<>0 set number of particles on the sphere, reset particle mass set the number of particles to be launched and given the mass loss rate determines the particle's mass. -If set to zero, the particle mass defined in the .setup file is used and the code finds the corresponding number of particles to be launched. - -:: +If set to zero, the particle mass defined in the .setup file is used and the code finds the corresponding number of particles to be launched:: nfill_domain = 0 ! number of spheres used to set the background density profile -set a background density profile. This option can limit the effect of boundary conditions. The larger nfill_domain, the bigger the domain - -:: +set a background density profile. This option can limit the effect of boundary conditions. The larger nfill_domain, the bigger the domain:: wind_shell_spacing = 1.000 ! desired ratio of sphere spacing to particle spacing set the resolution of the simulation. This parameters gives the ratio between the distance of 2 particles on an ejected sphere and the distance between 2 consecutive spheres. -Its value should be kept close to unity that - -:: +Its value should be kept close to unity that:: iboundary_spheres = 5 ! number of boundary spheres (integer) -set the number of shells that serve as inner boundary condition for the wind - -:: +set the number of shells that serve as inner boundary condition for the wind:: outer_boundary = 50. ! delete gas particles outside this radius (au) @@ -207,22 +182,16 @@ set how radiation pressure is accounted for. The star's effective gravity is giv g_\mathrm{eff} = \frac{Gm}{r^2} \times (1-\alpha_\mathrm{rad}-\Gamma) alpha is an ad-hoc parameter that allows the launching of the wind in case of a cool wind for example when dust is not accounted for. -Gamma is the Eddington factor that depends on the dust opacity. gamma is therefore <> 0 only when dust is activated (``idust_opacity > 0``) - -:: +Gamma is the Eddington factor that depends on the dust opacity. gamma is therefore <> 0 only when dust is activated (``idust_opacity > 0``):: alpha_rad = 1.000 ! fraction of the gravitational acceleration imparted to the gas -parameter entering in the above equation for the effective gravity - -:: +parameter entering in the above equation for the effective gravity:: iget_tdust = 1 ! dust temperature (0:Tdust=Tgas 1:T(r) 2:Flux dilution 3:Lucy 4:MCfost) defines how the dust temperature is calculated. By default one assumes Tdust = Tgas but other options are availabe as well. -Options 1-3 use analytical prescriptions, and option 4 uses full 3D RT using the MCfost code (under development!) - -:: +Options 1-3 use analytical prescriptions, and option 4 uses full 3D RT using the MCfost code (under development!):: iray_resolution = -1 ! set the number of rays to 12*4**iray_resolution (deactivated if <0) diff --git a/docs/getting-started/flatiron.rst b/docs/getting-started/flatiron.rst index 64a22c839..d10f73624 100644 --- a/docs/getting-started/flatiron.rst +++ b/docs/getting-started/flatiron.rst @@ -204,8 +204,8 @@ read the `splash userguide `__ for more more interesting examples ------------------------- To proceed to a more interesting calculation, just change the name of the :doc:`SETUP -parameter ` when you created the Makefile in the run directory, as per -the :doc:`examples `:: +parameter ` when you created the Makefile in the run directory, as per +the :doc:`examples `:: cd ~/ceph mkdir disc diff --git a/docs/getting-started/gitinfo.rst b/docs/getting-started/gitinfo.rst index 38edd26e4..de0ab83e4 100644 --- a/docs/getting-started/gitinfo.rst +++ b/docs/getting-started/gitinfo.rst @@ -6,7 +6,7 @@ Make sure you have the git version control system installed. Getting your first copy ----------------------- -Once you have a GitHub account, you must create your own :doc:`fork `. +Once you have a GitHub account, you must create your own :doc:`fork `. This is done using the “fork” button (the big button on top right of the repo page). You can then clone your fork to your computer:: @@ -96,4 +96,5 @@ that your changes be pulled into the master copy of Phantom. Please do this frequently. Many small pull requests are much better than one giant pull request! -Automated tests will be performed on all pull requests to ensure nothing gets broken. Once these pass and the code has been reviewed, the code can be merged. +Automated tests will be performed on all pull requests to ensure nothing gets broken. +Once these pass and the code has been reviewed, the code can be merged. diff --git a/docs/getting-started/index.rst b/docs/getting-started/index.rst index 496d56cc5..62f74dc3a 100644 --- a/docs/getting-started/index.rst +++ b/docs/getting-started/index.rst @@ -10,13 +10,13 @@ Quickstart 2. Make your :doc:`first calculation `. -3. Understand how the code works (:doc:`Fortree ` may help). +3. Understand how the code works (:doc:`Fortree ` may help). 4. Run your simulations :doc:`on a cluster ` and make cool science. 5. Please cite the `code paper `__ and other relevant papers in your publications. -6. :doc:`Publish your data ` on `Zenodo `__ or similar +6. :doc:`Publish your data ` on `Zenodo `__ or similar Contents -------- diff --git a/docs/getting-started/nci.rst b/docs/getting-started/nci.rst index b1e46cd55..890fcc4e6 100644 --- a/docs/getting-started/nci.rst +++ b/docs/getting-started/nci.rst @@ -1,5 +1,5 @@ Getting started on the NCI supercomputer (Australian National Supercomputing Facility) -====================================================================================== +======================================================================================= Apply for an account at http://nci.org.au @@ -14,7 +14,7 @@ Please read the :doc:`general instructions for how to log in/out and copy files ssh -Y USER@gadi.nci.org.au Configure your environment ------------------- +--------------------------- First edit your .bashrc file in your favourite text editor:: @@ -68,7 +68,7 @@ Finally, make a shortcut to the /g/data filesystem:: pwd -P Get phantom ------------ +------------ Clone a copy of phantom into your home directory:: @@ -154,7 +154,7 @@ Check the status using:: qstat -u $USER How to keep your job running for more than 48 hours ---------------------------------------------------- +---------------------------------------------------- Often you will want to keep your calculation going for longer than the 48-hour maximum queue limit. To achieve this you can just submit another job with the same script @@ -190,10 +190,10 @@ and submit your script using:: which will automagically submit 10 jobs to the queue, each depending on completion of the previous job. how to not annoy everybody else ------------------------------------ +--------------------------------- Do not fill the disk quota! Use a mix of small and full dumps where possible and set dtmax to a reasonable value to avoid generating large numbers of unnecessary large files. -For how to move the results of your calculations off gadi see :doc:`here ` +For how to move the results of your calculations off gadi see :doc:`here ` how to use splash to make movies without your job getting killed ----------------------------------------------------------------- @@ -220,7 +220,7 @@ If you still get prompts that need answers you can follow the procedure `here ` For more information on the actual machine `read the diff --git a/docs/getting-started/running-first-calculation.rst b/docs/getting-started/running-first-calculation.rst index ac2462bc7..fcbac958c 100644 --- a/docs/getting-started/running-first-calculation.rst +++ b/docs/getting-started/running-first-calculation.rst @@ -65,7 +65,7 @@ Then use the writemake script in the phantom/scripts directory to write a local ~/phantom/scripts/writemake.sh sedov > Makefile -where “sedov” is the :doc:`name of a SETUP variable in phantom/build/Makefile_setups ` +where “sedov” is the :doc:`name of a SETUP variable in phantom/build/Makefile_setups ` (this argument is optional, but convenient as it means phantom when compiled in this directory will always compile for this setup). Then you should have:: $ ls @@ -94,7 +94,7 @@ The dump file (blast_00000.tmp) is a binary file that can be read by `splash `__. The .tmp appended to the filename is because phantomsetup does not compute the density, so the smoothing lengths and densities in the file are at this stage just guesses. The input file (blast.in) contains all of the :doc:`runtime configuration -options `. It’s fairly self-explanatory, but probably the main things to note are the end time and the time between dumps:: +options `. It’s fairly self-explanatory, but probably the main things to note are the end time and the time between dumps:: tmax = 0.2000 ! end time dtmax = 0.0100 ! time between dumps @@ -169,4 +169,4 @@ The .ev files can be visualised using any standard plotting tool. For example yo where column labels should be read automatically from the header of the .ev file. -For more detailed analysis of :doc:`Phantom dump files `, write yourself an analysis module for the :doc:`phantomanalysis ` utility. Analysis modules exist for many common tasks, including interpolating to a 3D grid (both fixed and AMR), computing PDFs, structure functions and power spectra, getting disc surface density profiles, and converting to other formats. +For more detailed analysis of :doc:`Phantom dump files `, write yourself an analysis module for the :doc:`phantomanalysis ` utility. Analysis modules exist for many common tasks, including interpolating to a 3D grid (both fixed and AMR), computing PDFs, structure functions and power spectra, getting disc surface density profiles, and converting to other formats. diff --git a/docs/getting-started/systems-list.rst b/docs/getting-started/systems-list.rst index 20c4fe6f9..028353bca 100644 --- a/docs/getting-started/systems-list.rst +++ b/docs/getting-started/systems-list.rst @@ -4,49 +4,49 @@ .. table:: List of possible SYSTEM configurations :widths: auto -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| SYSTEM= | description | -+==================+===========================================================================================================================+ -| aocc | default settings for the AMD optimized fortran compiler (aocc) | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| complexity | complexity.leicester.dirac.ac.uk | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| cray | default settings for the Cray Fortran Compiler (ftn) | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| daint | piz-daint supercomputer facility https://www.cscs.ch/computers/piz-daint | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| gfortran | default settings for the gfortran compiler | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| hydra | hydra cluster in Garching http://www.mpcdf.mpg.de/services/computing/hydra | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| ifort | default settings for the Intel Fortran Compiler | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| ifortgcc | Intel Fortran Compiler but gcc for C | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| ifortmac | default settings for the Intel Fortran Compiler on Mac OS | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| ipopeyearch | Flatiron CCA popeye cluster icelake node | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| isca | local cluster at the University of Exeter | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| kennedy | HPC cluster at University of St. Andrews | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| lyoccf | LIO CCF cluster | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| m2 | MASSIVE facility: massive.org.au | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| monarch | Monarch cluster at Monash University | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| nci | gadi (NCI machine) | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| nt | ozstar milan cluster using aocc (Ngarru Tindebeek) | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| ozstar | ozstar facility using ifort https://supercomputing.swin.edu.au/ozstar/ | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| rusty | Flatiron CCA rusty cluster rome node, AMD EPYC 7742 | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| skylake | HPCs Skylake cluster at Cambridge | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ -| xc40 | Cray XC40 machine, similar to the daint system | -+------------------+---------------------------------------------------------------------------------------------------------------------------+ + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | SYSTEM= | description | + +==================+===========================================================================================================================+ + | aocc | default settings for the AMD optimized fortran compiler (aocc) | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | complexity | complexity.leicester.dirac.ac.uk | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | cray | default settings for the Cray Fortran Compiler (ftn) | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | daint | piz-daint supercomputer facility https://www.cscs.ch/computers/piz-daint | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | gfortran | default settings for the gfortran compiler | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | hydra | hydra cluster in Garching http://www.mpcdf.mpg.de/services/computing/hydra | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | ifort | default settings for the Intel Fortran Compiler | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | ifortgcc | Intel Fortran Compiler but gcc for C | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | ifortmac | default settings for the Intel Fortran Compiler on Mac OS | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | ipopeyearch | Flatiron CCA popeye cluster icelake node | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | isca | local cluster at the University of Exeter | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | kennedy | HPC cluster at University of St. Andrews | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | lyoccf | LIO CCF cluster | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | m2 | MASSIVE facility: massive.org.au | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | monarch | Monarch cluster at Monash University | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | nci | gadi (NCI machine) | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | nt | ozstar milan cluster using aocc (Ngarru Tindebeek) | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | ozstar | ozstar facility using ifort https://supercomputing.swin.edu.au/ozstar/ | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | rusty | Flatiron CCA rusty cluster rome node, AMD EPYC 7742 | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | skylake | HPCs Skylake cluster at Cambridge | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ + | xc40 | Cray XC40 machine, similar to the daint system | + +------------------+---------------------------------------------------------------------------------------------------------------------------+ diff --git a/docs/physics/eos-list.rst b/docs/physics/eos-list.rst index bd0d4ba50..be573c5a4 100644 --- a/docs/physics/eos-list.rst +++ b/docs/physics/eos-list.rst @@ -1,123 +1,126 @@ -+-----------+----------------------------------------------------------------------------------+ -| ieos | Description | -+===========+==================================================================================+ -| 1 | **Isothermal eos** | -| | | -| | :math:`P = c_s^2 \rho` | -| | | -| | where :math:`c_s^2 \equiv K` is a constant stored in the dump file header | -| | | -| | | -| | Adiabatic equation of state (code default) | -| | | -| | :math:`P = (\gamma - 1) \rho u` | -| | | -| | if the code is compiled with ISOTHERMAL=yes, ieos=2 gives a polytropic eos: | -| | | -| | :math:`P = K \rho^\gamma` | -| | | -| | where K is a global constant specified in the dump header | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 3 | **Locally isothermal disc as in Lodato & Pringle (2007) where** | -| | | -| | :math:`P = c_s^2 (r) \rho` | -| | | -| | sound speed (temperature) is prescribed as a function of radius using: | -| | | -| | :math:`c_s = c_{s,0} r^{-q}` where :math:`r = \sqrt{x^2 + y^2 + z^2}` | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 4 | **Isothermal equation of state for GR, enforcing cs = constant** | -| | | -| | .. WARNING:: this is experimental: use with caution | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 6 | **Locally isothermal disc centred on sink particle** | -| | | -| | As in ieos=3 but in this version radius is taken with respect to a designated | -| | sink particle (by default the first sink particle in the simulation) | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 7 | **Vertically stratified equation of state** | -| | | -| | sound speed is prescribed as a function of (cylindrical) radius R and | -| | height z above the x-y plane | -| | | -| | .. WARNING:: should not be used for misaligned discs | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 8 | **Barotropic equation of state** | -| | | -| | :math:`P = K \rho^\gamma` | -| | | -| | where the value of gamma (and K) are a prescribed function of density | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 9 | **Piecewise Polytropic equation of state** | -| | | -| | :math:`P = K \rho^\gamma` | -| | | -| | where the value of gamma (and K) are a prescribed function of density. | -| | Similar to ieos=8 but with different defaults and slightly different | -| | functional form | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 10 | **MESA equation of state** | -| | | -| | a tabulated equation of state including gas, radiation pressure | -| | and ionisation/dissociation. MESA is a stellar evolution code, so | -| | this equation of state is designed for matter inside stars | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 11 | **Isothermal equation of state with pressure and temperature equal to zero** | -| | | -| | :math:`P = 0` | -| | | -| | useful for simulating test particle dynamics using SPH particles | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 12 | **Ideal gas plus radiation pressure** | -| | | -| | :math:`P = (\gamma - 1) \rho u` | -| | | -| | but solved by first solving the quartic equation: | -| | | -| | :math:`u = \frac32 \frac{k_b T}{\mu m_H} + \frac{a T^4}{\rho}` | -| | | -| | for temperature (given u), then solving for pressure using | -| | | -| | :math:`P = \frac{k_b T}{\mu m_H} + \frac13 a T^4` | -| | | -| | hence in this equation of state gamma (and temperature) are an output | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 13 | **Locally isothermal eos for generic hierarchical system** | -| | | -| | Assuming all sink particles are stars. | -| | Generalisation of Farris et al. (2014; for binaries) to N stars. | -| | For two sink particles this is identical to ieos=14 | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 14 | **Locally isothermal eos from Farris et al. (2014) for binary system** | -| | | -| | uses the locations of the first two sink particles | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 15 | **Helmholtz equation of state (computed live, not tabulated)** | -| | | -| | .. WARNING:: not widely tested in phantom, better to use ieos=10 | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 16 | **Shen (2012) equation of state for neutron stars** | -| | | -| | this equation of state requires evolving temperature as the energy variable | -| | | -| | .. WARNING:: not tested: use with caution | -| | | -+-----------+----------------------------------------------------------------------------------+ -| 20 | **Gas + radiation + various forms of recombination** | -| | | -| | from HORMONE, Hirai+2020, as used in Lau+2022b | -| | | -+-----------+----------------------------------------------------------------------------------+ +.. table:: Equations of state implemented in phantom + :widths: auto + + +-----------+----------------------------------------------------------------------------------+ + | ieos | Description | + +===========+==================================================================================+ + | 1 | **Isothermal eos** | + | | | + | | :math:`P = c_s^2 \rho` | + | | | + | | where :math:`c_s^2 \equiv K` is a constant stored in the dump file header | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 2 | **Adiabatic equation of state (code default)** | + | | | + | | :math:`P = (\gamma - 1) \rho u` | + | | | + | | if the code is compiled with ISOTHERMAL=yes, ieos=2 gives a polytropic eos: | + | | | + | | :math:`P = K \rho^\gamma` | + | | | + | | where K is a global constant specified in the dump header | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 3 | **Locally isothermal disc as in Lodato & Pringle (2007) where** | + | | | + | | :math:`P = c_s^2 (r) \rho` | + | | | + | | sound speed (temperature) is prescribed as a function of radius using: | + | | | + | | :math:`c_s = c_{s,0} r^{-q}` where :math:`r = \sqrt{x^2 + y^2 + z^2}` | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 4 | **Isothermal equation of state for GR, enforcing cs = constant** | + | | | + | | .. WARNING:: this is experimental: use with caution | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 6 | **Locally isothermal disc centred on sink particle** | + | | | + | | As in ieos=3 but in this version radius is taken with respect to a designated | + | | sink particle (by default the first sink particle in the simulation) | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 7 | **Vertically stratified equation of state** | + | | | + | | sound speed is prescribed as a function of (cylindrical) radius R and | + | | height z above the x-y plane | + | | | + | | .. WARNING:: should not be used for misaligned discs | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 8 | **Barotropic equation of state** | + | | | + | | :math:`P = K \rho^\gamma` | + | | | + | | where the value of gamma (and K) are a prescribed function of density | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 9 | **Piecewise Polytropic equation of state** | + | | | + | | :math:`P = K \rho^\gamma` | + | | | + | | where the value of gamma (and K) are a prescribed function of density. | + | | Similar to ieos=8 but with different defaults and slightly different | + | | functional form | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 10 | **MESA equation of state** | + | | | + | | a tabulated equation of state including gas, radiation pressure | + | | and ionisation/dissociation. MESA is a stellar evolution code, so | + | | this equation of state is designed for matter inside stars | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 11 | **Isothermal equation of state with pressure and temperature equal to zero** | + | | | + | | :math:`P = 0` | + | | | + | | useful for simulating test particle dynamics using SPH particles | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 12 | **Ideal gas plus radiation pressure** | + | | | + | | :math:`P = (\gamma - 1) \rho u` | + | | | + | | but solved by first solving the quartic equation: | + | | | + | | :math:`u = \frac32 \frac{k_b T}{\mu m_H} + \frac{a T^4}{\rho}` | + | | | + | | for temperature (given u), then solving for pressure using | + | | | + | | :math:`P = \frac{k_b T}{\mu m_H} + \frac13 a T^4` | + | | | + | | hence in this equation of state gamma (and temperature) are an output | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 13 | **Locally isothermal eos for generic hierarchical system** | + | | | + | | Assuming all sink particles are stars. | + | | Generalisation of Farris et al. (2014; for binaries) to N stars. | + | | For two sink particles this is identical to ieos=14 | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 14 | **Locally isothermal eos from Farris et al. (2014) for binary system** | + | | | + | | uses the locations of the first two sink particles | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 15 | **Helmholtz equation of state (computed live, not tabulated)** | + | | | + | | .. WARNING:: not widely tested in phantom, better to use ieos=10 | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 16 | **Shen (2012) equation of state for neutron stars** | + | | | + | | this equation of state requires evolving temperature as the energy variable | + | | | + | | .. WARNING:: not tested: use with caution | + | | | + +-----------+----------------------------------------------------------------------------------+ + | 20 | **Gas + radiation + various forms of recombination** | + | | | + | | from HORMONE, Hirai+2020, as used in Lau+2022b | + | | | + +-----------+----------------------------------------------------------------------------------+ diff --git a/docs/physics/eos.rst b/docs/physics/eos.rst index a6baff0cd..68763ec44 100644 --- a/docs/physics/eos.rst +++ b/docs/physics/eos.rst @@ -5,7 +5,4 @@ The following is a list of equations of state currently implemented in phantom. For full details have a look in the `source code `__ -.. table:: - :class: tight-table - .. include:: eos-list.rst diff --git a/docs/physics/sink-properties.rst b/docs/physics/sink-properties.rst index a8cf9a190..367382693 100644 --- a/docs/physics/sink-properties.rst +++ b/docs/physics/sink-properties.rst @@ -1,33 +1,33 @@ -+-----------+------------------------------------------+ -| Index | Description | -+===========+==========================================+ -| ihacc | accretion radius | -+-----------+------------------------------------------+ -| ihsoft | softening radius | -+-----------+------------------------------------------+ -| imacc | accreted mass | -+-----------+------------------------------------------+ -| ispinx | spin angular momentum x | -+-----------+------------------------------------------+ -| ispiny | spin angular momentum y | -+-----------+------------------------------------------+ -| ispinz | spin angular momentum z | -+-----------+------------------------------------------+ -| i_tlast | time of last injection | -+-----------+------------------------------------------+ -| ilum | luminosity | -+-----------+------------------------------------------+ -| iTeff | effective temperature | -+-----------+------------------------------------------+ -| iReff | effective radius | -+-----------+------------------------------------------+ -| imloss | mass loss rate | -+-----------+------------------------------------------+ -| imdotav | accretion rate average | -+-----------+------------------------------------------+ -| i_mlast | accreted mass of last time | -+-----------+------------------------------------------+ -| imassenc | mass enclosed in sink softening radius | -+-----------+------------------------------------------+ -| iJ2 | 2nd gravity moment due to oblateness | -+-----------+------------------------------------------+ + +-----------+------------------------------------------+ + | Index | Description | + +===========+==========================================+ + | ihacc | accretion radius | + +-----------+------------------------------------------+ + | ihsoft | softening radius | + +-----------+------------------------------------------+ + | imacc | accreted mass | + +-----------+------------------------------------------+ + | ispinx | spin angular momentum x | + +-----------+------------------------------------------+ + | ispiny | spin angular momentum y | + +-----------+------------------------------------------+ + | ispinz | spin angular momentum z | + +-----------+------------------------------------------+ + | i_tlast | time of last injection | + +-----------+------------------------------------------+ + | ilum | luminosity | + +-----------+------------------------------------------+ + | iTeff | effective temperature | + +-----------+------------------------------------------+ + | iReff | effective radius | + +-----------+------------------------------------------+ + | imloss | mass loss rate | + +-----------+------------------------------------------+ + | imdotav | accretion rate average | + +-----------+------------------------------------------+ + | i_mlast | accreted mass of last time | + +-----------+------------------------------------------+ + | imassenc | mass enclosed in sink softening radius | + +-----------+------------------------------------------+ + | iJ2 | 2nd gravity moment due to oblateness | + +-----------+------------------------------------------+ diff --git a/docs/scripts/eos_options.pl b/docs/scripts/eos_options.pl index 4088a7a3b..44ac0b148 100755 --- a/docs/scripts/eos_options.pl +++ b/docs/scripts/eos_options.pl @@ -3,19 +3,21 @@ # @(#) Perl script to extract sink particle properties from src/main/part.F90 # my $start = 0; -open(FILE,'../../src/main/eos.F90'); +open(FILE,'../../src/main/eos.f90'); while () { my $line = $_; if ( m/select case\(eos_type\)/) { - print "+-----------+","-" x 82,"+\n"; - printf("| ieos | %-80s | \n","Description"); - print "+===========+","=" x 82,"+\n"; + print ".. table:: Equations of state implemented in phantom\n"; + print " :widths: auto\n\n"; + print " +-----------+","-" x 82,"+\n"; + printf(" | ieos | %-80s | \n","Description"); + print " +===========+","=" x 82,"+\n"; $start = 1; } elsif ($start == 1) { # last entry, close on matching ---- line - if (m/^\s*case\((\d+)\).*/) { + if (m/^\s*case\(([\d,\,]+)\).*/) { if ($printed_case_num) { - print "+-----------+","-" x 82,"+\n"; + print " +-----------+","-" x 82,"+\n"; } $case_num = $1; $printed_case_num = 0; @@ -24,13 +26,13 @@ next; } elsif (m/^\!--\s*(.*)/ or m/^\!\s*(.*)/) { if (!$printed_case_num) { - printf("| %-2d | %-80s |\n",$case_num,substr("**$1**", 0, 80)); + printf(" | %-2d | %-80s |\n",$case_num,substr("**$1**", 0, 80)); $printed_case_num = 1; } else { - printf("| | %-80s |\n",substr($1, 0, 80)); # additional comments + printf(" | | %-80s |\n",substr($1, 0, 80)); # additional comments } } elsif (m/end\s+select/) { - print "+-----------+","-" x 82,"+\n"; + print " +-----------+","-" x 82,"+\n"; exit(); } } diff --git a/docs/scripts/print_setups.sh b/docs/scripts/print_setups.sh index 1915fe3b4..4be6c3ff9 100755 --- a/docs/scripts/print_setups.sh +++ b/docs/scripts/print_setups.sh @@ -11,7 +11,7 @@ echo "" echo ".. table:: List of pre-cooked SETUP configurations" echo " :widths: auto" echo "" -printf "+" +printf " +" printf -- '-%.0s' {1..18} printf "+" printf -- '-%.0s' {1..63} @@ -20,8 +20,8 @@ printf -- '-%.0s' {1..52} printf "+" printf -- '-%.0s' {1..123} printf "+\n" -printf "| %-16s | %-61s | %-50s | %-121s | \n" "SETUP=" "description" "compile-time options" "initial conditions file" -printf "+" +printf " | %-16s | %-61s | %-50s | %-121s | \n" "SETUP=" "description" "compile-time options" "initial conditions file" +printf " +" printf -- '=%.0s' {1..18} printf "+" printf -- '=%.0s' {1..63} @@ -41,8 +41,8 @@ print_setup() for x in $setupfile; do lastfile=$x; done - printf "| %-16s | %-61s | %-50s | %-121s | \n" "$setup" "$descript" "$options" "\`$lastfile <$url/src/setup/$lastfile>\`__" - printf "+" + printf " | %-16s | %-61s | %-50s | %-121s | \n" "$setup" "$descript" "$options" "\`$lastfile <$url/src/setup/$lastfile>\`__" + printf " +" printf -- '-%.0s' {1..18} printf "+" printf -- '-%.0s' {1..63} diff --git a/docs/scripts/print_systems.sh b/docs/scripts/print_systems.sh index 4e7c4502f..59c0fa39e 100755 --- a/docs/scripts/print_systems.sh +++ b/docs/scripts/print_systems.sh @@ -11,13 +11,13 @@ echo "" echo ".. table:: List of possible SYSTEM configurations" echo " :widths: auto" echo "" -printf "+" +printf " +" printf -- '-%.0s' {1..18} printf "+" printf -- '-%.0s' {1..123} printf "+\n" -printf "| %-16s | %-121s | \n" "SYSTEM=" "description" -printf "+" +printf " | %-16s | %-121s | \n" "SYSTEM=" "description" +printf " +" printf -- '=%.0s' {1..18} printf "+" printf -- '=%.0s' {1..123} @@ -27,8 +27,8 @@ print_system() system=$1; descript=`grep -A 1 "ifeq (\\$(SYSTEM), $system)" $phantomdir/build/Makefile_systems | grep '#' | cut -d'#' -f 2 | tail -1 | xargs` #lineno=`grep -n "ifeq (\\$(SETUP), $setup)" $phantomdir/build/Makefile_setups | cut -d':' -f 1` - printf "| %-16s | %-121s | \n" "$system" "$descript" - printf "+" + printf " | %-16s | %-121s | \n" "$system" "$descript" + printf " +" printf -- '-%.0s' {1..18} printf "+" printf -- '-%.0s' {1..123} diff --git a/docs/scripts/sink_particle_properties.pl b/docs/scripts/sink_particle_properties.pl index 25cc9e80b..24c48e3c3 100755 --- a/docs/scripts/sink_particle_properties.pl +++ b/docs/scripts/sink_particle_properties.pl @@ -7,15 +7,15 @@ while () { my $line = $_; if ( m/(^\!--sink particles$)/) { - print "+-----------+------------------------------------------+\n"; - print "| Index | Description | \n"; - print "+===========+==========================================+\n"; + print " +-----------+------------------------------------------+\n"; + print " | Index | Description | \n"; + print " +===========+==========================================+\n"; $start = 1; } elsif ($start == 1) { # last entry, close on matching ---- line if (m/integer, parameter :: (.*) = (\d+)\s+\!\s+(.*)/) { - printf "| %-9s | %-40s | \n",$1,$3; - print "+-----------+------------------------------------------+\n"; + printf " | %-9s | %-40s | \n",$1,$3; + print " +-----------+------------------------------------------+\n"; #exit(); } elsif (m/^\!.*/) { # skip diff --git a/docs/user-guide/analysis.rst b/docs/user-guide/analysis.rst index f8f712f10..9e5729a26 100644 --- a/docs/user-guide/analysis.rst +++ b/docs/user-guide/analysis.rst @@ -85,13 +85,13 @@ yourself! (If you need convincing, just have a quick look at how long the read_data_sphNG.f90 file in splash is). The best way to read/analyse phantom dumps, aside from using splash to visualise them, is to use the built-in phantomanalysis utility (described below), or the -:doc:`sarracen ` python package. A full description of +:doc:`sarracen ` python package. A full description of the data format and how to read it can be found :doc:`here `. Sarracen ~~~~~~~~ -- See :doc:`How to analyse and visualise phantom data with sarracen ` +- See :doc:`How to analyse and visualise phantom data with sarracen ` Phantomanalysis ~~~~~~~~~~~~~~~ diff --git a/docs/user-guide/data-curation.rst b/docs/user-guide/data-curation.rst index 6940ed145..99aa163d7 100644 --- a/docs/user-guide/data-curation.rst +++ b/docs/user-guide/data-curation.rst @@ -98,5 +98,5 @@ To SYNC an entire directory tree onto your google drive, DELETING files ALSO ON Other helpful information -------------------------- -- :doc:`General instructions for running on a remote cluster ` +- :doc:`General instructions for running on a remote cluster ` - `rclone userguide `_ diff --git a/docs/user-guide/dumpfile.rst b/docs/user-guide/dumpfile.rst index 54dbe6886..44ac8a9bb 100644 --- a/docs/user-guide/dumpfile.rst +++ b/docs/user-guide/dumpfile.rst @@ -18,7 +18,7 @@ from the code. It reads the raw data files and gives you plots and visualisation sarracen ~~~~~~~~ -:doc:`Sarracen ` is a package with similar functionality to splash but done in Python:: +:doc:`Sarracen ` is a package with similar functionality to splash but done in Python:: import sarracen sdf = sarracen.read_phantom('file_00000') @@ -88,7 +88,7 @@ Compile `showarrays ` package: +:doc:`sarracen ` package: - https://github.com/ttricco/sarracen @@ -219,8 +219,8 @@ blocks. Each block contains a set of arrays of the same length with one of eight possible data types. The opening gambit -~~~~~~~~~~~~~~~~~~ -The file is a Fortran binary file. Each `write' statement in Fortran +~~~~~~~~~~~~~~~~~~~ +The file is a Fortran binary file. Each 'write' statement in Fortran writes a 4-byte tag at the beginning and end. In other languages you will need to read these tags and can use them to decide the length of the line. @@ -250,7 +250,7 @@ Typically in dumps written by phantom this contains code version and date inform FT:Phantom:2021.0.0:63a3980 (hydro+1dust): 11/11/2021 15:52:02.3 -The first letter of the file id indicates if the file is a `full dump' (F) or 'small dump' (S). +The first letter of the file id indicates if the file is a 'full dump' (F) or 'small dump' (S). The second letter (T) indicates the file is written in the 'tagged' format, where printed labels are written prior to each array being written to the file. diff --git a/docs/user-guide/index.rst b/docs/user-guide/index.rst index 2b9cfe8d7..d2ec5c32c 100644 --- a/docs/user-guide/index.rst +++ b/docs/user-guide/index.rst @@ -16,4 +16,5 @@ This section contains the basic user guide for Phantom. utils dumpfile hdf5 + mpi data-curation diff --git a/docs/user-guide/setups-best.rst b/docs/user-guide/setups-best.rst index b0c156665..8ccf1fbae 100644 --- a/docs/user-guide/setups-best.rst +++ b/docs/user-guide/setups-best.rst @@ -4,21 +4,21 @@ .. table:: List of pre-cooked SETUP configurations :widths: auto -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| SETUP= | description | compile-time options | initial conditions file | -+==================+===============================================================+====================================================+===========================================================================================================================+ -| disc | locally isothermal gas disc | disc viscosity, isothermal | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| star | import stellar model from 1D stellar evolution code | self-gravity | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| binary | binary stars | self-gravity | `setup_binary.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| wind | wind setup with dust nucleation | | `setup_wind.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| jet | Jet simulation from Price, Tricco & Bate (2012) | MHD, self-gravity, isothermal, periodic | `setup_sphereinbox.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| turb | driven supersonic turbulence (hydro, mhd, dusty) | isothermal | `setup_turb.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| cluster | star cluster formation | self-gravity, isothermal | `setup_cluster.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | SETUP= | description | compile-time options | initial conditions file | + +==================+===============================================================+====================================================+===========================================================================================================================+ + | disc | locally isothermal gas disc | disc viscosity, isothermal | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | star | import stellar model from 1D stellar evolution code | self-gravity | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | binary | binary stars | self-gravity | `setup_binary.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | wind | wind setup with dust nucleation | | `setup_wind.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | jet | Jet simulation from Price, Tricco & Bate (2012) | MHD, self-gravity, isothermal, periodic | `setup_sphereinbox.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | turb | driven supersonic turbulence (hydro, mhd, dusty) | isothermal | `setup_turb.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | cluster | star cluster formation | self-gravity, isothermal | `setup_cluster.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ diff --git a/docs/user-guide/setups-list.rst b/docs/user-guide/setups-list.rst index 5f45b60ce..99127166a 100644 --- a/docs/user-guide/setups-list.rst +++ b/docs/user-guide/setups-list.rst @@ -4,219 +4,219 @@ .. table:: List of pre-cooked SETUP configurations :widths: auto -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| SETUP= | description | compile-time options | initial conditions file | -+==================+===============================================================+====================================================+===========================================================================================================================+ -| BHL | Bondi-Hoyle-Lyttleton setup | | `setup_BHL.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| adiabaticdisc | adiabatic disc | disc viscosity | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| alfven | MHD circularly polarised Alfven wave problem | MHD, periodic | `setup_alfvenwave.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| asteroidwind | asteroid emitting a wind (Trevascus et al. 2021) | isothermal | `setup_asteroidwind.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| balsarakim | Balsara-Kim 2004 | MHD, periodic | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| binary | binary stars | self-gravity | `setup_binary.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| binarydiscMFlow | binarydiscMFlow setup | isothermal | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| blob | Blob evaporation problem | periodic | `setup_blob.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| bondi | Bondi accretion flow | isothermal | `setup_bondi.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| cluster | star cluster formation | self-gravity, isothermal | `setup_cluster.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| common | binary setup | | `setup_common.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| converging | Simulation from Wurster & Bonnell (2023) | no, self-gravity, no, periodic | `setup_collidingclouds.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| default | default setup, uniform box | dust, periodic | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| disc | locally isothermal gas disc | disc viscosity, isothermal | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| dustsettle | dust settling test from PL15 | dust, isothermal, periodic | `setup_dustsettle.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| dustybox | dust in a box | dust, isothermal, periodic | `setup_dustybox.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| dustydisc | locally isothermal dusty discs | dust, disc viscosity, isothermal | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| dustyisosgdisc | isothermal self-gravitating dustydisc | dust, self-gravity, disc viscosity, isothermal | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| dustysedov | Sedov blast wave test with dust | dust, periodic | `setup_dustysedov.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| dustysgdisc | self-gravitating dustydisc | dust, self-gravity | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| dustyshock | shock tube tests with dust | dust, periodic | `setup_shock.F90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| dustystar | import stellar model from 1D stellar evolution code w/dust | self-gravity | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| dustywave | dust in a box | dust, periodic | `setup_wave.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| empty | empty setup for external-driver simulation | | `setup_empty.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| evrard | Evrard collapse test problem | self-gravity | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| exoALMA | exoALMA comparison of planet-disc interaction | isothermal | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| firehose | injection of a stream of gas as a firehose | | `setup_firehose.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| flrw | constant density FLRW cosmology with perturbations | GR, et, periodic | `setup_flrw.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| flrwpspec | FLRW universe using a CMB powerspectrum | GR, et, periodic | `setup_flrwpspec.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| galaxies | galaxy merger using data from Wurster & Thacker (2013a,b) | self-gravity | `setup_galaxies.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| galcen | galactic centre | | `setup_galcen_stars.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| galdisc | galactic disc simulations | | `setup_galdisc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| galdiscmhd | galactic disc simulations with magnetic fields | MHD, isothermal | `setup_galdisc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| gr_testparticles | test particles in GR | GR, kerr | `setup_testparticles.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| grbondi | Bondi accretion flow in GR | GR, schwarzschild | `setup_bondi.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| grbondi-inject | Bondi accretion flow in GR with particle injection | GR, schwarzschild | `setup_bondiinject.F90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| grdisc | accretion disc around a Kerr black hole | GR, kerr | `setup_grdisc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| growingdisc | locally isothermal dusty discs with growth and fragmentation | dust, disc viscosity, isothermal | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| growthtomulti | transform dustgrowth dump into multi large grains dump | dust, disc viscosity, isothermal | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| grstar | star in GR using Minkowski metric | GR, minkowski, self-gravity | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| grtde | tidal disruption event in general relativity | GR, kerr, self-gravity | `setup_grtde.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| gwdisc | disc around inspiralling binary with gravitational wave decay | disc viscosity, isothermal | `setup_gwdisc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| hierarchical | hierarchical system setup | | `setup_hierarchical.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| ismwind | wind setup with dust nucleation and ISM cooling | | `setup_wind.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| isosgdisc | isothermal self-gravitating disc | self-gravity, disc viscosity, isothermal | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| isowind | isothermal spherical wind | isothermal | `setup_wind.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| jadvect | MHD current loop advection problem | MHD, periodic | `setup_jadvect.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| jet | Jet simulation from Price, Tricco & Bate (2012) | MHD, self-gravity, isothermal, periodic | `setup_sphereinbox.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| jetdusty | dust in star formation | no, dust, self-gravity, isothermal, periodic | `setup_sphereinbox.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| jetnimhd | Simulation from Wurster, Price & Bate (2016,2017) et seq | MHD, non-ideal, self-gravity, isothermal, periodic | `setup_sphereinbox.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| kh | Kelvin-Helmholtz problem | periodic | `setup_kh.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| lightcurvedisc | adiabatic disc with lightcurve | disc viscosity | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| mhdblast | MHD blast wave test | MHD, periodic | `setup_mhdblast.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| mhdrotor | MHD rotor problem | MHD, periodic | `setup_mhdrotor.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| mhdshock | Ryu & Brio-Wu shock tube tests | MHD, periodic | `setup_shock.F90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| mhdsine | MHD sine wave | MHD, periodic | `setup_mhdsine.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| mhdvortex | Balsara (2004) MHD vortex | MHD, periodic | `setup_mhdvortex.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| mhdwave | propagating isolated MHD wave | MHD, periodic | `setup_mhdwave.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| neutronstar | isolated neutron star | isothermal | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| nimhdshock | non-ideal mhd standing and C shock tests | MHD, non-ideal, isothermal, periodic | `setup_shock.F90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| nshwdisc | disc around a neutron star | disc viscosity, isothermal | `setup_nsdisc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| nsmerger | Model a neutron star merger; use option 6 | self-gravity, isothermal | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| orstang | Orszag-Tang vortex | MHD, periodic | `setup_orstang.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| planetatm | disc interaction with fixed planet orbit + atmosphere | isothermal | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| planetdisc | planet disc interaction with fixed planet orbit | isothermal | `setup_planetdisc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| polytrope | single or binary polytrope test | self-gravity, isothermal | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| prtest | simple test of Poynting-Robertson drag | isothermal | `setup_prtest.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| quebec | Terry Tricco | self-gravity | `setup_quebec.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| raddisc | adiabatic disc with radiation | radiation, disc viscosity | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| radiativebox | test of radiation coupling terms | radiation, periodic | `setup_radiativebox.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| radiotde | radio tidal disruption event in general relativity | GR, minkowski, no | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| radshock | shock tube in radiation hydrodynamics | radiation, periodic | `setup_shock.F90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| radstar | setup a star as in the star setup but with radiation | self-gravity, radiation | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| radwind | wind setup with dust nucleation | | `setup_wind.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| sedov | Sedov blast wave test | periodic | `setup_sedov.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| sgdisc | self-gravitating disc | self-gravity | `setup_disc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| shock | shock tube tests | periodic | `setup_shock.F90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| solarsystem | orbits of minor planets | dust, isothermal | `setup_solarsystem.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| sphereinbox | sphere-in-box setup | periodic | `setup_sphereinbox.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| srblast | special relativistic blast wave test (spherical) | GR, minkowski, periodic | `setup_srblast.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| srpolytrope | polytrope in special relativity | GR, minkowski, self-gravity | `setup_srpolytrope.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| srshock | special relativistic sod shock tube test | GR, minkowski, periodic | `setup_shock.F90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| star | import stellar model from 1D stellar evolution code | self-gravity | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| taylorgreen | Taylor-Green vortex problem | isothermal | `setup_taylorgreen.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| tde | tidal disruption simulations | self-gravity, isothermal | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| test | default setup for tests | MHD, dust, radiation, periodic | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| test2 | default setup for tests | disc viscosity | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| testcyl | default setup for tests | disc viscosity | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| testdust | dust unit tests | dust, periodic | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| testgr | unit tests of general relativistic code | GR, kerr | `setup_grdisc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| testgrav | self-gravity unit tests | self-gravity | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| testgrowth | dust growth unit tests | dust, periodic | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| testkd | default setup for tests | MHD, radiation, periodic | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| testlum | Lense-Thirring setup | | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| testnimhd | non-ideal MHD (+boundary parts+super-timesteps) unit tests | MHD, non-ideal, isothermal, periodic | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| testparticles | test particles | | `setup_testparticles.F90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| tokamak | tokamak torus setup | isothermal | `setup_tokamak.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| torus | MRI torus | | `setup_torus.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| turb | driven supersonic turbulence (hydro, mhd, dusty) | isothermal | `setup_turb.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| turbdrive | driven turbulence | isothermal | `setup_unifdis.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| wave | linear wave | periodic | `setup_wave.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| wavedamp | Wave damping test as per Choi et al (2009) | MHD, non-ideal, isothermal, periodic | `setup_wavedamp.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| wd | white dwarf from stellar model | self-gravity | `setup_star.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| wddisc | disc around a white dwarf | dust, isothermal | `setup_wddisc.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| wind | wind setup with dust nucleation | | `setup_wind.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ -| windtunnel | Wind tunnel setup | self-gravity | `setup_windtunnel.f90 `__ | -+------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | SETUP= | description | compile-time options | initial conditions file | + +==================+===============================================================+====================================================+===========================================================================================================================+ + | BHL | Bondi-Hoyle-Lyttleton setup | | `setup_BHL.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | adiabaticdisc | adiabatic disc | disc viscosity | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | alfven | MHD circularly polarised Alfven wave problem | MHD, periodic | `setup_alfvenwave.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | asteroidwind | asteroid emitting a wind (Trevascus et al. 2021) | isothermal | `setup_asteroidwind.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | balsarakim | Balsara-Kim 2004 | MHD, periodic | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | binary | binary stars | self-gravity | `setup_binary.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | binarydiscMFlow | binarydiscMFlow setup | isothermal | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | blob | Blob evaporation problem | periodic | `setup_blob.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | bondi | Bondi accretion flow | isothermal | `setup_bondi.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | cluster | star cluster formation | self-gravity, isothermal | `setup_cluster.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | common | binary setup | | `setup_common.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | converging | Simulation from Wurster & Bonnell (2023) | no, self-gravity, no, periodic | `setup_collidingclouds.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | default | default setup, uniform box | dust, periodic | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | disc | locally isothermal gas disc | disc viscosity, isothermal | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | dustsettle | dust settling test from PL15 | dust, isothermal, periodic | `setup_dustsettle.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | dustybox | dust in a box | dust, isothermal, periodic | `setup_dustybox.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | dustydisc | locally isothermal dusty discs | dust, disc viscosity, isothermal | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | dustyisosgdisc | isothermal self-gravitating dustydisc | dust, self-gravity, disc viscosity, isothermal | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | dustysedov | Sedov blast wave test with dust | dust, periodic | `setup_dustysedov.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | dustysgdisc | self-gravitating dustydisc | dust, self-gravity | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | dustyshock | shock tube tests with dust | dust, periodic | `setup_shock.F90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | dustystar | import stellar model from 1D stellar evolution code w/dust | self-gravity | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | dustywave | dust in a box | dust, periodic | `setup_wave.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | empty | empty setup for external-driver simulation | | `setup_empty.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | evrard | Evrard collapse test problem | self-gravity | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | exoALMA | exoALMA comparison of planet-disc interaction | isothermal | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | firehose | injection of a stream of gas as a firehose | | `setup_firehose.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | flrw | constant density FLRW cosmology with perturbations | GR, et, periodic | `setup_flrw.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | flrwpspec | FLRW universe using a CMB powerspectrum | GR, et, periodic | `setup_flrwpspec.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | galaxies | galaxy merger using data from Wurster & Thacker (2013a,b) | self-gravity | `setup_galaxies.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | galcen | galactic centre | | `setup_galcen_stars.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | galdisc | galactic disc simulations | | `setup_galdisc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | galdiscmhd | galactic disc simulations with magnetic fields | MHD, isothermal | `setup_galdisc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | gr_testparticles | test particles in GR | GR, kerr | `setup_testparticles.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | grbondi | Bondi accretion flow in GR | GR, schwarzschild | `setup_bondi.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | grbondi-inject | Bondi accretion flow in GR with particle injection | GR, schwarzschild | `setup_bondiinject.F90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | grdisc | accretion disc around a Kerr black hole | GR, kerr | `setup_grdisc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | growingdisc | locally isothermal dusty discs with growth and fragmentation | dust, disc viscosity, isothermal | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | growthtomulti | transform dustgrowth dump into multi large grains dump | dust, disc viscosity, isothermal | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | grstar | star in GR using Minkowski metric | GR, minkowski, self-gravity | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | grtde | tidal disruption event in general relativity | GR, kerr, self-gravity | `setup_grtde.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | gwdisc | disc around inspiralling binary with gravitational wave decay | disc viscosity, isothermal | `setup_gwdisc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | hierarchical | hierarchical system setup | | `setup_hierarchical.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | ismwind | wind setup with dust nucleation and ISM cooling | | `setup_wind.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | isosgdisc | isothermal self-gravitating disc | self-gravity, disc viscosity, isothermal | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | isowind | isothermal spherical wind | isothermal | `setup_wind.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | jadvect | MHD current loop advection problem | MHD, periodic | `setup_jadvect.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | jet | Jet simulation from Price, Tricco & Bate (2012) | MHD, self-gravity, isothermal, periodic | `setup_sphereinbox.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | jetdusty | dust in star formation | no, dust, self-gravity, isothermal, periodic | `setup_sphereinbox.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | jetnimhd | Simulation from Wurster, Price & Bate (2016,2017) et seq | MHD, non-ideal, self-gravity, isothermal, periodic | `setup_sphereinbox.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | kh | Kelvin-Helmholtz problem | periodic | `setup_kh.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | lightcurvedisc | adiabatic disc with lightcurve | disc viscosity | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | mhdblast | MHD blast wave test | MHD, periodic | `setup_mhdblast.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | mhdrotor | MHD rotor problem | MHD, periodic | `setup_mhdrotor.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | mhdshock | Ryu & Brio-Wu shock tube tests | MHD, periodic | `setup_shock.F90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | mhdsine | MHD sine wave | MHD, periodic | `setup_mhdsine.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | mhdvortex | Balsara (2004) MHD vortex | MHD, periodic | `setup_mhdvortex.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | mhdwave | propagating isolated MHD wave | MHD, periodic | `setup_mhdwave.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | neutronstar | isolated neutron star | isothermal | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | nimhdshock | non-ideal mhd standing and C shock tests | MHD, non-ideal, isothermal, periodic | `setup_shock.F90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | nshwdisc | disc around a neutron star | disc viscosity, isothermal | `setup_nsdisc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | nsmerger | Model a neutron star merger; use option 6 | self-gravity, isothermal | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | orstang | Orszag-Tang vortex | MHD, periodic | `setup_orstang.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | planetatm | disc interaction with fixed planet orbit + atmosphere | isothermal | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | planetdisc | planet disc interaction with fixed planet orbit | isothermal | `setup_planetdisc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | polytrope | single or binary polytrope test | self-gravity, isothermal | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | prtest | simple test of Poynting-Robertson drag | isothermal | `setup_prtest.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | quebec | Terry Tricco | self-gravity | `setup_quebec.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | raddisc | adiabatic disc with radiation | radiation, disc viscosity | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | radiativebox | test of radiation coupling terms | radiation, periodic | `setup_radiativebox.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | radiotde | radio tidal disruption event in general relativity | GR, minkowski, no | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | radshock | shock tube in radiation hydrodynamics | radiation, periodic | `setup_shock.F90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | radstar | setup a star as in the star setup but with radiation | self-gravity, radiation | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | radwind | wind setup with dust nucleation | | `setup_wind.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | sedov | Sedov blast wave test | periodic | `setup_sedov.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | sgdisc | self-gravitating disc | self-gravity | `setup_disc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | shock | shock tube tests | periodic | `setup_shock.F90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | solarsystem | orbits of minor planets | dust, isothermal | `setup_solarsystem.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | sphereinbox | sphere-in-box setup | periodic | `setup_sphereinbox.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | srblast | special relativistic blast wave test (spherical) | GR, minkowski, periodic | `setup_srblast.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | srpolytrope | polytrope in special relativity | GR, minkowski, self-gravity | `setup_srpolytrope.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | srshock | special relativistic sod shock tube test | GR, minkowski, periodic | `setup_shock.F90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | star | import stellar model from 1D stellar evolution code | self-gravity | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | taylorgreen | Taylor-Green vortex problem | isothermal | `setup_taylorgreen.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | tde | tidal disruption simulations | self-gravity, isothermal | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | test | default setup for tests | MHD, dust, radiation, periodic | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | test2 | default setup for tests | disc viscosity | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | testcyl | default setup for tests | disc viscosity | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | testdust | dust unit tests | dust, periodic | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | testgr | unit tests of general relativistic code | GR, kerr | `setup_grdisc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | testgrav | self-gravity unit tests | self-gravity | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | testgrowth | dust growth unit tests | dust, periodic | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | testkd | default setup for tests | MHD, radiation, periodic | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | testlum | Lense-Thirring setup | | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | testnimhd | non-ideal MHD (+boundary parts+super-timesteps) unit tests | MHD, non-ideal, isothermal, periodic | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | testparticles | test particles | | `setup_testparticles.F90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | tokamak | tokamak torus setup | isothermal | `setup_tokamak.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | torus | MRI torus | | `setup_torus.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | turb | driven supersonic turbulence (hydro, mhd, dusty) | isothermal | `setup_turb.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | turbdrive | driven turbulence | isothermal | `setup_unifdis.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | wave | linear wave | periodic | `setup_wave.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | wavedamp | Wave damping test as per Choi et al (2009) | MHD, non-ideal, isothermal, periodic | `setup_wavedamp.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | wd | white dwarf from stellar model | self-gravity | `setup_star.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | wddisc | disc around a white dwarf | dust, isothermal | `setup_wddisc.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | wind | wind setup with dust nucleation | | `setup_wind.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ + | windtunnel | Wind tunnel setup | self-gravity | `setup_windtunnel.f90 `__ | + +------------------+---------------------------------------------------------------+----------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------+ diff --git a/src/main/utils_mathfunc.f90 b/src/main/utils_mathfunc.f90 index 6fd3933a7..e133bdbb7 100644 --- a/src/main/utils_mathfunc.f90 +++ b/src/main/utils_mathfunc.f90 @@ -26,23 +26,18 @@ module mathfunc contains -!-------------------------------------------------------------------- -!Gegenbauer polynomials -!-------------------------------------------------------------------- subroutine gegenbauer_poly( n, alpha, x, cx ) ! -!Taken from the Polpak http://people.sc.fsu.edu/~jburkardt/ +! GEGENBAUER_POLY computes the Gegenbauer polynomials C(I,ALPHA,X). ! -!*****************************************************************************80 -! -!! GEGENBAUER_POLY computes the Gegenbauer polynomials C(I,ALPHA,X). +! Taken from the Polpak http://people.sc.fsu.edu/~jburkardt/ ! ! Discussion: ! ! The Gegenbauer polynomial can be evaluated in Mathematica with ! the command ! -! GegenbauerC[n,m,x] +! GegenbauerC[n,m,x] ! ! ALPHA must be greater than -0.5. ! @@ -140,13 +135,11 @@ subroutine gegenbauer_poly( n, alpha, x, cx ) end subroutine gegenbauer_poly !-------------------------------------------------------------------- -!Associated Legendre polynomials +! Associated Legendre polynomials !-------------------------------------------------------------------- subroutine legendre_associated( n, m, x, cx ) - -!*****************************************************************************80 ! -!! LEGENDRE_ASSOCIATED evaluates the associated Legendre functions. +! LEGENDRE_ASSOCIATED evaluates the associated Legendre functions. ! ! Differential equation: ! diff --git a/src/main/utils_timing.f90 b/src/main/utils_timing.f90 index f6fb6f23d..c9ec91558 100644 --- a/src/main/utils_timing.f90 +++ b/src/main/utils_timing.f90 @@ -75,9 +75,11 @@ module timing !+ !-------------------------------------- subroutine setup_timers + ! ! These timers must be initialised with the correct tree hierarchy, ! i.e. children must immediately follow their parents or siblings ! + ! timer from array label parent call init_timer(itimer_fromstart , 'all', 0 ) call init_timer(itimer_lastdump , 'last', 0 ) diff --git a/src/setup/density_profiles.f90 b/src/setup/density_profiles.f90 index c86853c5e..b06e9b2f1 100644 --- a/src/setup/density_profiles.f90 +++ b/src/setup/density_profiles.f90 @@ -7,12 +7,13 @@ module rho_profile ! ! This computes several radial density profiles useful for stars -! and gravitational collapse calculations, including -! 1) uniform -! 2) polytrope -! 3) piecewise polytrope -! 4) Evrard -! 5) Bonnor-Ebert sphere +! and gravitational collapse calculations, including: +! +! 1. uniform +! 2. polytrope +! 3. piecewise polytrope +! 4. Evrard +! 5. Bonnor-Ebert sphere ! ! :References: Evrard (1988), MNRAS 235, 911-934 ! diff --git a/src/setup/set_Bfield.f90 b/src/setup/set_Bfield.f90 index 05d4ea027..489904342 100644 --- a/src/setup/set_Bfield.f90 +++ b/src/setup/set_Bfield.f90 @@ -8,10 +8,10 @@ module setBfield ! ! Interactive setup of magnetic field on the particles ! -! Can be used to add magnetic field to hydro setups, and -! is used by utilities like moddump to add magnetic field -! to purely hydrodynamic dump files before continuing the -! calculation +! Can be used to add magnetic field to hydro setups, and +! is used by utilities like moddump to add magnetic field +! to purely hydrodynamic dump files before continuing the +! calculation ! ! :References: None ! diff --git a/src/setup/set_flyby.f90 b/src/setup/set_flyby.f90 index d0250f8fa..783ae37a9 100644 --- a/src/setup/set_flyby.f90 +++ b/src/setup/set_flyby.f90 @@ -7,20 +7,17 @@ module setflyby ! ! This module is contains utilities for setting up flyby. -! Our conventions for angles are the same as in Xiang-Gruess (2016). -! Eccentricity is set to unity, i.e. for a parabolic orbit. +! Our conventions for angles are the same as in Xiang-Gruess (2016). +! Eccentricity is set to unity, i.e. for a parabolic orbit: ! -! minimum_approach = distance of minimum approach (pericentre) -! initial_dist = the initial separation distance (in units of -! minimum_approach) -! posang_ascnode = angle counter-clockwise (East) from y-axis (North) -! inclination = angle of rotation of orbital plane around axis -! defined by the position angle (for -! posang_ascnode==0 this is a roll angle) +! - minimum_approach : *distance of minimum approach (pericentre)* +! - initial_dist : *the initial separation distance (in units of minimum_approach)* +! - posang_ascnode : *angle counter-clockwise (East) from y-axis (North)* +! - inclination : *angle of rotation of orbital plane around axis defined by the position angle (for posang_ascnode=0 this is a roll angle)* ! ! :References: -! Xiang-Gruess (2016), MNRAS 455, 3086-3100 -! Cuello et al. (2019), MNRAS 483, 4114-4139 +! - Xiang-Gruess (2016), MNRAS 455, 3086-3100 +! - Cuello et al. (2019), MNRAS 483, 4114-4139 ! ! :Owner: Daniel Mentiplay ! diff --git a/src/setup/stretchmap.f90 b/src/setup/stretchmap.f90 index 999823e0b..cea129eca 100644 --- a/src/setup/stretchmap.f90 +++ b/src/setup/stretchmap.f90 @@ -40,6 +40,7 @@ module stretchmap ierr_memory_allocation = 2, & ! error code ierr_table_size_differs = 3, & ! error code ierr_not_converged = -1 ! error code + abstract interface real function rho_func(x) real, intent(in) :: x @@ -78,11 +79,11 @@ subroutine set_density_profile(np,xyzh,min,max,rhofunc,massfunc,rhotab,xtab,star ! max_bn : max range in the coordinate to apply transformation ! start : only consider particles between start and np (optional) ! geom : geometry in which stretch mapping is to be performed (optional) -! 1 - cartesian -! 2 - cylindrical -! 3 - spherical -! 4 - toroidal -! (if not specified, assumed to be cartesian) +! 1 - cartesian +! 2 - cylindrical +! 3 - spherical +! 4 - toroidal +! (if not specified, assumed to be cartesian) ! coord : coordinate direction in which stretch mapping is to be performed (optional) ! (if not specified, assumed to be the first coordinate) ! rhofunc : function containing the desired density function rho(r) or rho(x) (optional) diff --git a/src/tests/test_radiation.f90 b/src/tests/test_radiation.f90 index 3a72b7e62..36c299cfd 100644 --- a/src/tests/test_radiation.f90 +++ b/src/tests/test_radiation.f90 @@ -9,9 +9,9 @@ module testradiation ! Unit tests for radiation hydro ! ! :References: -! Whitehouse & Bate (2004), 353, 1078 -! Whitehouse, Bate & Monaghan (2005), 364, 1367 -! Biriukov (2019), PhD thesis, Monash Univ. +! - Whitehouse & Bate (2004), 353, 1078 +! - Whitehouse, Bate & Monaghan (2005), 364, 1367 +! - Biriukov (2019), PhD thesis, Monash Univ. ! ! :Owner: Daniel Price ! @@ -450,7 +450,7 @@ subroutine setup_radiation_diffusion_problem_sinusoid(kappa_code,c_code,xi0,rho0 nptot = reduceall_mpi('+',npart) rho0 = 2.5e-24 - massoftype(igas) = rho0*dxbound*dybound*dzbound/nptot !*1e-25 + massoftype(igas) = rho0*dxbound*dybound*dzbound/nptot pmassi = massoftype(igas) if (maxphase==maxp) iphase(1:npart) = isetphase(igas,iactive=.true.) npartoftype(:) = 0 From c0a313b603f77b095ab23487c4b4aae71b1ccc9c Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 31 Jan 2024 09:56:51 +0100 Subject: [PATCH 293/814] (star) fix single precision warning --- src/setup/set_softened_core.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index a022d8c37..575eb8598 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -101,7 +101,7 @@ subroutine set_softened_core(eos_type,isoftcore,isofteningopt,regrid_core,rcore, X1 = X Y1 = Y Ncore = 5000 ! number of grid points in softened region (hardwired for now) - call calc_regrid_core(Ncore,rcore*solarr,core_index,r1,den1,pres1,m1,X1,Y1,r,den,pres,m,X,Y) + call calc_regrid_core(Ncore,rc,core_index,r1,den1,pres1,m1,X1,Y1,r,den,pres,m,X,Y) X(:) = X(size(X)) Y(:) = Y(size(Y)) endif From 1739157f492306611a15997e4ac90503c01ca4a1 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 1 Feb 2024 17:44:27 +1100 Subject: [PATCH 294/814] (docs) added physics guide to radiation [skip ci] --- docs/physics/index.rst | 1 + docs/physics/radiation.rst | 134 +++++++++++++++++++++++++++++++++++++ 2 files changed, 135 insertions(+) create mode 100644 docs/physics/radiation.rst diff --git a/docs/physics/index.rst b/docs/physics/index.rst index cebe30a20..99161f5f4 100644 --- a/docs/physics/index.rst +++ b/docs/physics/index.rst @@ -10,3 +10,4 @@ are described in the `code paper `. + +The difference between two simulations using the above methods is a measure of the importance of radiative cooling. +Importantly in neither of the above cases is the temperature of the gas actually computed, though one is free to do so. +One can simply interpret the sound speed or internal energy in terms of temperature after the fact +by choosing code units, but the simulations themselves do not care about the units and are scale-free. + +For accretion discs using a strictly isothermal equation of state is a bad idea +so we typically prescribe a fixed temperature profile (e.g. T is a prescribed function of radius) +rather than T=const. There are various options for this in phantom, see :doc:`Equations of state in phantom ` and :doc:`Accretion discs `. +As above, the temperature is *not actually computed*, but rather the *sound speed* is prescribed. + +Radiation pressure +------------------- +The next level of sophistication, assuming radiation is perfectly trapped (optically thick), is to include the effect +of radiation pressure using :doc:`the gas+radiation equation of state (ieos=12) `. +Here, we assume that the internal energy represents the total specific energy, ie. +the sum of the gas thermal energy and the radiation energy. +More specifically: + + :math:`u = \frac{3}{2} \frac{k_B T}{\mu m_H} + a T^4` + +This equation can be solved backwards for temperature, and the resulting temperature used to +compute the pressure: + + :math:`P = \frac{k_b T}{\mu m_H} + \frac13 a T^4` + +See :doc:`documentation for ieos=12 `. One important difference +compared to the adiabatic vs. isothermal equation of states is that real physical constants +are needed to compute P from u, and so the units of the simulation are no longer arbitrary. + +The main effect of radiation pressure is to reduce the effective adiabatic index of the gas. +One can see this because when the gas pressure term dominates, we have + + :math:`P = \frac32 \rho u` + +implying :math:`\gamma=5/3`, whereas when the radiation pressure term dominates, we have + + :math:`P = \frac13 \rho u` + +implying :math:`\gamma=4/3`. + +Ionization and recombination +------------------------------ +One level up from this is to also include ionization and recombination using the +:doc:`the gas+rad+rec equation of state (ieos=15) `, which utilises a similar +approach to the gas+radiation equation of state above but also solves a Saha equation +for Hydrogen and Helium ionization/recombination. One can also achieve similar physics +using the :doc:`tabulated MESA equation of state (ieos=10) ` but with less control over +which ionizations to switch on/off. One also should be careful that the simulation remains +within the density and temperature ranges of the table. + +Radiation transport with flux-limited diffusion +------------------------------------------------- +Next level, we can allow the radiation to diffuse. The implicit flux-limited diffusion +scheme implemented in phantom is from Whitehouse & Bate (2004) and Whitehouse, +Bate and Monaghan (2005). Flux limited diffusion is correct when the gas is optically +thick but makes an approximation to limit the radiation propagation to the speed of +light in optically thin regions, but still treats propagation of radiation as diffusion +in these regions, which does not capture things like shadowing. + +In the code this formulation differs by splitting the gas and radiation pressure +into separate contributions. The gas specific internal energy is stored in the vxyzu array, +while the radiation specific internal energy is stored in the rad array. + +Hence the total internal energy per unit mass in this case is:: + + ui = vxyzu(4,i) + rad(iradxi,i) + +Hence in this case **you need to set both the gas and radiation internal energies during +the setup of the simulation**, or when injecting particles. + +As a first step, you can reproduce the gas + radiation equation of state above +by assuming an infinite opacity, by setting the appropriate flag in the input file:: + + iopacity_type = 0 ! opacity method (0=inf,1=mesa,2=constant,-1=preserve) + +More generally, one can set the opacity as a function of density and temperature from +the MESA tables (iopacity_type=1) which then allows radiation to diffuse. +Ionization/recombination is included in these tables, but at the moment not +molecular hydrogen formation. + +For modelling stars other than those powered by contraction, including the +leakage of radiation in this way requires you to supply a heating source, otherwise +the star will just steadily cool. For red giants with a sink particle core a simple procedure +is to supply a constant luminosity input from the core (:doc:`sink heating `). This is experimental. +Another option would be to include a nuclear burning network (please somebody contribute this). + +Irradiation from stars with phantom + MCFOST +--------------------------------------------- +In regimes where the radiation diffusion time is relatively short, anything not inside stars +or where temperatures are set by external irradiation, a better approach is to use +the :doc:`coupled version of phantom and MCFOST `. + +In this procedure we call MCFOST at discrete intervals (set by the dtmax parameter in the .in file) +which emits and propagates photons until radiative equilibrium is reached. This is a +good approximation if the time to reach radiative equilibrium is shorter than the time interval +between calls to MCFOST, which is true for example in most protoplanetary discs. + +One can also include PdV work and shock heating contributions in the calculation of +radiative equilibrium, so this allows for shock heating from the gas as well as heating +from central stars. The (dust) temperature we receive back from MCFOST is then simply used +as the gas temperature, and is kept fixed on particles between calls to MCFOST. + +MCFOST by default assumes the only source of opacity is dust, and if dust is not used in +the simulation will assume that dust is 1% of the gas in order to compute opacities. If the +simulation includes dust species (with :doc:`DUST=yes `) or dust formation (with :doc:`NUCLEATION=yes `) then +opacities will be computed from the dust information in the simulation. See :doc:`Using Phantom with MCFOST ` + +Using MCFOST for gas radiative transfer, using the atomic line transfer capabilities outlined +by `Tessore et al. (2021) `__ is also possible but more experimental. + +See also +-------- + +- :doc:`Equations of state available in Phantom ` +- :doc:`MCFOST ` \ No newline at end of file From 91a2fefa39826f7aee1434192ef012a4f9dbd1cb Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 2 Feb 2024 09:35:27 +1100 Subject: [PATCH 295/814] Update radiation.rst [skip ci] --- docs/physics/radiation.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/physics/radiation.rst b/docs/physics/radiation.rst index 7f830dbe3..fdd6b94b4 100644 --- a/docs/physics/radiation.rst +++ b/docs/physics/radiation.rst @@ -49,7 +49,7 @@ are needed to compute P from u, and so the units of the simulation are no longer The main effect of radiation pressure is to reduce the effective adiabatic index of the gas. One can see this because when the gas pressure term dominates, we have - :math:`P = \frac32 \rho u` + :math:`P = \frac23 \rho u` implying :math:`\gamma=5/3`, whereas when the radiation pressure term dominates, we have @@ -131,4 +131,4 @@ See also -------- - :doc:`Equations of state available in Phantom ` -- :doc:`MCFOST ` \ No newline at end of file +- :doc:`MCFOST ` From fdd5317950db0eea41ba08bba4b6286fe4a13eb2 Mon Sep 17 00:00:00 2001 From: Christophe Pinte Date: Mon, 5 Feb 2024 16:36:19 +1000 Subject: [PATCH 296/814] (mcfost) Fixing Makefile --- build/Makefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/build/Makefile b/build/Makefile index e87f32ad6..8cb3c6349 100644 --- a/build/Makefile +++ b/build/Makefile @@ -133,6 +133,7 @@ ifeq ($(MCFOST), yes) else #--otherwise assume the source code is lying around somewhere MCFOST_LIBS = $(MCFOST_INSTALL)/lib/$(FC) + HDF5_DIR = $(MCFOST_LIBS) MCFOST_INCLUDE = $(MCFOST_INSTALL)/include ifeq ("X$(MCFOST_LIB)","X") MCFOST_LIB = $(MCFOST_DIR)/src @@ -148,7 +149,6 @@ ifeq ($(MCFOST), yes) LDFLAGS+= -I$(MCFOST_INCLUDE) -I$(MCFOST_INCLUDE)/voro++ -I$(MCFOST_INCLUDE)/hdf5 -I$(MCFOST_INCLUDE)/$(FC) \ -L$(MCFOST_LIB) -lmcfost -L$(MCFOST_LIBS) $(LIBCXX) -lcfitsio -lvoro++ -lsprng \ -L$(HDF5_DIR) -lhdf5_fortran -lhdf5 -lz #$(LXGBOOST) - #-L$(HDF5_DIR)/lib/Intel -lhdf5_fortran endif include Makefile_systems @@ -491,7 +491,7 @@ ifdef METRIC else SRCMETRIC= metric_minkowski.f90 endif -SRCGR=inverse4x4.f90 einsteintk_utils.f90 $(SRCMETRIC) metric_tools.f90 utils_gr.f90 interpolate3D.f90 tmunu2grid.f90 +SRCGR=inverse4x4.f90 einsteintk_utils.f90 $(SRCMETRIC) metric_tools.f90 utils_gr.f90 interpolate3D.f90 tmunu2grid.f90 # # chemistry and cooling # @@ -998,7 +998,7 @@ phantom2mcfost: checkmcfost ANALYSISBIN=$@ ANALYSISONLY=yes LDFLAGS="-L$(MCFOST_DIR)/src -lmcfost $(LIBCXX)" analysis_mcfost.o: analysis_mcfost.f90 - $(FC) -c $(FFLAGS) -I$(MCFOST_INCLUDE) $< -o $@ + $(FC) -c $(FFLAGS) -I$(MCFOST_INCLUDE) -I$(MCFOST_DIR)/src $< -o $@ analysis_mcfost.o: checkmcfost From 1e740d161771239cb775a0e2d3b4e6b805a4ab9f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taj=20Jankovi=C4=8D?= Date: Fri, 9 Feb 2024 11:38:10 +1100 Subject: [PATCH 297/814] Fixes #498 --- src/main/units.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/units.f90 b/src/main/units.f90 index d4b9caf19..62cae18aa 100644 --- a/src/main/units.f90 +++ b/src/main/units.f90 @@ -100,13 +100,13 @@ subroutine set_units(dist,mass,time,G,c) utime = sqrt(udist**3/(gg*umass)) if (present(time)) print "(a)",' WARNING: over-riding time unit with G=1 assumption' elseif (present(dist) .and. present(time)) then - umass = udist**2/(gg*utime**2) + umass = udist**3/(gg*utime**2) if (present(mass)) print "(a)",' WARNING: over-riding mass unit with G=1 assumption' elseif (present(mass) .and. present(time)) then udist = (utime**2*(gg*umass))**(1.d0/3.d0) if (present(dist)) print "(a)",' WARNING: over-riding length unit with G=1 assumption' elseif (present(time)) then - umass = udist**2/(gg*utime**2) ! udist is 1 + umass = udist**3/(gg*utime**2) ! udist is 1 else utime = sqrt(udist**3/(gg*umass)) ! udist and umass are 1 endif From 904ed8d8ffb6e5f2f7dab09964ca0653058c7a08 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 12 Feb 2024 17:47:22 +1100 Subject: [PATCH 298/814] (docs) update index on examples [skip ci] --- docs/examples/index.rst | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/docs/examples/index.rst b/docs/examples/index.rst index 63d576bc5..77a2d8640 100644 --- a/docs/examples/index.rst +++ b/docs/examples/index.rst @@ -11,7 +11,6 @@ This section contains some examples of physical problems that you can solve with disc binary star - CE softstar dustsettle dustgrowth @@ -19,4 +18,4 @@ This section contains some examples of physical problems that you can solve with hierarchicalsystems selfgravity_gravitationalinstability phantomNR - wind \ No newline at end of file + wind From 6c1f9d008e27b41413b03179fb52c95cb3a0b0e7 Mon Sep 17 00:00:00 2001 From: Jeremy Smallwood Date: Thu, 15 Feb 2024 15:04:37 +0800 Subject: [PATCH 299/814] fix bug in set star with undefined need_iso --- src/setup/set_star.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index a92ddda35..fe24be09d 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -413,6 +413,7 @@ subroutine set_defaults_given_profile(iprofile,filename,need_iso,ieos,mstar,poly integer, intent(inout) :: ieos real, intent(inout) :: mstar,polyk + need_iso = 0 select case(iprofile) case(ifromfile) ! Read the density profile from file (e.g. for neutron star) From e33e15fcf27fca25435c3e1607517989ed8d623d Mon Sep 17 00:00:00 2001 From: fhu Date: Wed, 31 Jan 2024 13:36:53 +1100 Subject: [PATCH 300/814] update .gitignore to ignore file produced by aocc compiler --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index 992380c36..4b9ae030f 100644 --- a/.gitignore +++ b/.gitignore @@ -23,3 +23,7 @@ build/phantom-version.h *.tar .DS_Store _build +*.cmdx +*.cmod +*.ilm +*.stb From 0474b12f9429747df5cde67d8ee6c5b4e3d53b3c Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 16 Feb 2024 10:43:40 +1100 Subject: [PATCH 301/814] (deriv) uncomment prim2cons which cause error in setting up star in gr --- src/main/deriv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index f86a8ba63..d9e6334e5 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -113,7 +113,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& if (gr) then ! Recalculate the metric after moving particles to their new tasks call init_metric(npart,xyzh,metrics) - !call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) + call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) endif if (nptmass > 0 .and. periodic) call ptmass_boundary_crossing(nptmass,xyzmh_ptmass) From 57a5e20bd69df93ab2ff6c11957cf1502f164818 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 16 Feb 2024 10:45:03 +1100 Subject: [PATCH 302/814] (docs) documentation for injecting particles from another simulations --- docs/inject_sim.rst | 73 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 73 insertions(+) create mode 100644 docs/inject_sim.rst diff --git a/docs/inject_sim.rst b/docs/inject_sim.rst new file mode 100644 index 000000000..392cc783e --- /dev/null +++ b/docs/inject_sim.rst @@ -0,0 +1,73 @@ + +Injecting particles from existing simulations to new simulations +========================================================= + +Initial setup +------------- + +To ensure the particle mass and units are consistent in both existing & new simulations, + it is recommended to use 'phantommoddump' with existing simulations to setup new simulations + +:: + + make SRCINJECT=inject_sim.f90; make moddump SRCINJECT=inject_sim.f90 + ./phantommoddump YOUR_EXISTING_SIMULATION YOUR_NEW_SIMULATION TIME + +'phantommodump' might produce a parameter file depending on the setup, + in that case one would need to run +:: + + ./phantommoddump YOUR_EXISTING_SIMULATION YOUR_NEW_SIMULATION TIME' + +one more time after setting up the parameters + +At the end of these instructions, an initial dump of the new simulaton and a .in file are created. + +:: + +Content of the .in file +-------------------------- + +Options controlling particle injection +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +:: + + # options controlling particle injection + start_dump = 'dump_00000' ! dumpfile to start for injection + r_inject = 5.000E+14 ! radius to inject tde outflow (in cm) + final_dump = 'dump_02000' ! stop injection after this dump + +Here’s a brief description of each of them + +:: + + start_dump = 'dump_00000' ! dumpfile to start for injection + +set the dump start to inject. The code will check the start_dump time and start injection when the time is reached in new simulations +Once a dump is used by injection, the dump number will automatically increased by 1. The new dump is written to .in file once a full dump is saved + +If the dumps are in a different directory, + +:: + + start_dump = 'PATH/TO/YOUR/OTHER/DIR/dump_00000' ! dumpfile to start for injection + +can read dumps from other directory. The path needs to be the RELATIVE path to the working directory +!!!--------------------------------------!!! +NOTE: qotation marks are NECESSARY with path +!!!--------------------------------------!!! + +:: + + r_inject = 5.000E+14 ! radius to inject tde outflow (in cm) + +set the radius for inject. For TDE outflow specifically, once a particle pass this radius from inside to outside in the existing simulations, it is injected to the new simulations + +:: + + final_dump = 'dump_02000' ! stop injection after this dump + +set the dump to stop injection. The injection dump number keep increasing by 1 after each injection and will stop once reaching this set final_dump. +If there is a PATH in start_dump, it is NECESSARY in final_dump as well. + From 82fb151a5f55c92d376891d778c88f22b86604b4 Mon Sep 17 00:00:00 2001 From: Chunliang Mu Date: Fri, 16 Feb 2024 13:12:26 +1100 Subject: [PATCH 303/814] Added documentation for stellar relaxation --- docs/user-guide/index.rst | 1 + docs/user-guide/relaxation.rst | 29 +++++++++++++++++++++++++++++ 2 files changed, 30 insertions(+) create mode 100755 docs/user-guide/relaxation.rst diff --git a/docs/user-guide/index.rst b/docs/user-guide/index.rst index d2ec5c32c..4b1e7c182 100644 --- a/docs/user-guide/index.rst +++ b/docs/user-guide/index.rst @@ -8,6 +8,7 @@ This section contains the basic user guide for Phantom. config setups + relaxation infile qscript sweeps diff --git a/docs/user-guide/relaxation.rst b/docs/user-guide/relaxation.rst new file mode 100755 index 000000000..81e261e7d --- /dev/null +++ b/docs/user-guide/relaxation.rst @@ -0,0 +1,29 @@ + +Stellar relaxation +================== + + +When mapping 1D profile from MESA to a 3D code such as Phantom, a relaxation procedure is required to ensure that the particles are in hydrostatic equilibrium. + +In phantom this is achieved by a process called ``relax-o-matic`` +(`Lau et al., 2022 `_ - **please see its appendix C for full details of how it works**). + + +To run ``relax-o-matic`` after setting up a star, +just follow the instructions during setup (from ``phantomsetup``) and type ``yes`` when prompted "Relax star automatically during setup?"; + +Then, modify the ``.setup`` file and fill in the relaxation options, which are pretty self-explanatory:: + + relax_star = T ! relax star automatically during setup + tol_ekin = 1.000E-07 ! tolerance on ekin/epot to stop relaxation + tol_dens = 1.000 ! % error in density to stop relaxation + maxits = 1000 ! maximum number of relaxation iterations + write_rho_to_file = F ! write density profile to file + +Run the ``phantomsetup`` again to start the auto relaxation process. +You are now good to go! + +If interruptted during the relaxation, run ``phantomsetup`` again and it will pick up from where it left off automatically. + +If in doubt, you can always run the star in isolation for a few years to see if relaxation procedure worked. + From e991af4fde752e6c42b2881df0f1e3b348f623d4 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Fri, 16 Feb 2024 05:58:06 +0100 Subject: [PATCH 304/814] bugfix iorig --- src/main/evolve.F90 | 2 +- src/main/initial.F90 | 2 +- src/main/inject_BHL.f90 | 4 ++-- src/main/inject_asteroidwind.f90 | 4 ++-- src/main/inject_bondi.f90 | 5 +++-- src/main/inject_firehose.f90 | 4 ++-- src/main/inject_galcen_winds.f90 | 4 ++-- src/main/inject_keplerianshear.f90 | 4 ++-- src/main/inject_rochelobe.f90 | 4 ++-- src/main/inject_sne.f90 | 4 ++-- src/main/inject_steadydisc.f90 | 4 ++-- src/main/inject_unifwind.f90 | 4 ++-- src/main/inject_wind.f90 | 8 ++++---- src/main/inject_windtunnel.f90 | 4 ++-- src/setup/setup_asteroidwind.f90 | 3 ++- src/setup/setup_bondiinject.f90 | 5 +++-- src/tests/test_wind.f90 | 4 ++-- 17 files changed, 36 insertions(+), 33 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index bf6e6b5e7..f9f04b09b 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -220,7 +220,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! if (.not. present(flag)) then npart_old=npart - call inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,dtinject) + call inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) call update_injected_particles(npart_old,npart,istepfrac,nbinmax,time,dtmax,dt,dtinject) endif #endif diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 08a7594ce..a0ac6b36f 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -562,7 +562,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif npart_old = npart call inject_particles(time,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) call update_injected_particles(npart_old,npart,istepfrac,nbinmax,time,dtmax,dt,dtinject) #endif ! diff --git a/src/main/inject_BHL.f90 b/src/main/inject_BHL.f90 index 0f55107bc..9be8454c9 100644 --- a/src/main/inject_BHL.f90 +++ b/src/main/inject_BHL.f90 @@ -169,12 +169,12 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use physcon, only:gg,pi use units, only:utime real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject diff --git a/src/main/inject_asteroidwind.f90 b/src/main/inject_asteroidwind.f90 index 758784144..9e13bb5cc 100644 --- a/src/main/inject_asteroidwind.f90 +++ b/src/main/inject_asteroidwind.f90 @@ -56,7 +56,7 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use io, only:fatal use part, only:nptmass,massoftype,igas,hfact,ihsoft use partinject, only:add_or_update_particle @@ -68,7 +68,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& use binaryutils, only:get_orbit_bits real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject real, dimension(3) :: xyz,vxyz,r1,r2,v2,vhat,v1 diff --git a/src/main/inject_bondi.f90 b/src/main/inject_bondi.f90 index 2272daf80..72fbcf201 100644 --- a/src/main/inject_bondi.f90 +++ b/src/main/inject_bondi.f90 @@ -150,14 +150,15 @@ end subroutine init_inject ! Main routine handling wind injection. !+ !----------------------------------------------------------------------- -subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,dtinject) +subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + npart,npart_old,npartoftype,dtinject) use io, only:iprint,warning use eos, only:gamma use part, only:igas,iboundary use injectutils, only:inject_geodesic_sphere real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject real, parameter :: pi3 = pi/3. !-- irrational number close to one diff --git a/src/main/inject_firehose.f90 b/src/main/inject_firehose.f90 index c1246d526..5500f03f3 100644 --- a/src/main/inject_firehose.f90 +++ b/src/main/inject_firehose.f90 @@ -56,7 +56,7 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use part, only:igas,hfact,massoftype,nptmass use partinject,only:add_or_update_particle use physcon, only:pi,solarr,au,solarm,years @@ -64,7 +64,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & use eos, only:gamma real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject real :: Rp,Rtidal,Rstar,beta,dt_walls diff --git a/src/main/inject_galcen_winds.f90 b/src/main/inject_galcen_winds.f90 index ea366c5cf..8bdf95c63 100644 --- a/src/main/inject_galcen_winds.f90 +++ b/src/main/inject_galcen_winds.f90 @@ -63,7 +63,7 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use io, only:fatal,iverbose use part, only:massoftype,igas,ihacc,i_tlast use partinject,only:add_or_update_particle @@ -73,7 +73,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& use eos, only:gmw,gamma real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject real :: r2,Mcut,Mdot_fac,vel_fac,Minject,Mdot_code,tlast diff --git a/src/main/inject_keplerianshear.f90 b/src/main/inject_keplerianshear.f90 index 43c728e2c..f7cac751a 100644 --- a/src/main/inject_keplerianshear.f90 +++ b/src/main/inject_keplerianshear.f90 @@ -86,14 +86,14 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use part, only:igas,iboundary, massoftype use physcon, only:Rg,gg,pi use eos, only:gamma use io, only:master real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject diff --git a/src/main/inject_rochelobe.f90 b/src/main/inject_rochelobe.f90 index 55079d0bc..5dba4211d 100644 --- a/src/main/inject_rochelobe.f90 +++ b/src/main/inject_rochelobe.f90 @@ -54,7 +54,7 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use io, only:fatal use part, only:nptmass,massoftype,igas,hfact use partinject,only:add_or_update_particle @@ -65,7 +65,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& use eos, only:gmw real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject real :: m1,m2,q,radL1,h,u,theta_s,A,mu,theta_rand,r_rand,dNdt_code,Porb,r12,r2L1,r0L1,smag diff --git a/src/main/inject_sne.f90 b/src/main/inject_sne.f90 index e0f95d8fb..feb998386 100644 --- a/src/main/inject_sne.f90 +++ b/src/main/inject_sne.f90 @@ -79,14 +79,14 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast_u,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use io, only:id,master use eos, only:gamma use part, only:rhoh,massoftype,iphase,igas,iunknown use partinject, only: updated_particle real, intent(in) :: time, dtlast_u real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject integer :: i,i_sn,ipart diff --git a/src/main/inject_steadydisc.f90 b/src/main/inject_steadydisc.f90 index 254e3b57a..f030a4d81 100644 --- a/src/main/inject_steadydisc.f90 +++ b/src/main/inject_steadydisc.f90 @@ -70,12 +70,12 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use io, only:id,master,fatal use damping, only:r1in,r2in,r1out,r2out real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject integer :: ninner,nouter,injected diff --git a/src/main/inject_unifwind.f90 b/src/main/inject_unifwind.f90 index 275fb3b75..93803ec1f 100644 --- a/src/main/inject_unifwind.f90 +++ b/src/main/inject_unifwind.f90 @@ -52,7 +52,7 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use part, only:hfact,igas,iboundary,massoftype use partinject,only:add_or_update_particle use io, only:iprint @@ -62,7 +62,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index a6078361e..6a8313506 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.f90 @@ -319,7 +319,7 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use physcon, only:pi,au use io, only:fatal,iverbose use wind, only:interp_wind_profile !,wind_profile @@ -334,7 +334,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject integer :: outer_sphere, inner_sphere, inner_boundary_sphere, first_particle, i, ipart, & @@ -364,11 +364,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& ! ! delete particles that exit the outer boundary ! - i = npart inner_radius = wind_injection_radius + deltaR_osc*sin(omega_osc*time) if (outer_boundary_au > Rinject) call delete_particles_outside_sphere(x0,real(outer_boundary_au*au/udist),npart) call delete_dead_particles_inside_radius(x0,inner_radius,npart) - if (npart /= i .and. iverbose > 0) print *,'deleted ',i-npart,'particles, remaining',npart + if (npart_old /= npart .and. iverbose > 0) print *,'deleted ',npart_old-npart,'particles, remaining',npart + npart_old = npart if (time_period > orbital_period .and. nptmass == 2) then time_period = 0. diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 7c304db07..49cebe41d 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -159,12 +159,12 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use physcon, only:gg,pi use units, only:utime real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index aff62f942..90654ca3b 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -180,7 +180,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! we use the estimated injection rate and the final time to set the particle mass massoftype(igas) = tmax*mdot/(umass/utime)/npart_at_end hfact = hfact_default - !call inject_particles(time,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,dtinj) + !npart_old = npart + !call inject_particles(time,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinj) ! !-- check for silly parameter choices diff --git a/src/setup/setup_bondiinject.f90 b/src/setup/setup_bondiinject.f90 index 057a0839e..19f6e4f9c 100644 --- a/src/setup/setup_bondiinject.f90 +++ b/src/setup/setup_bondiinject.f90 @@ -54,7 +54,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma_eos,hf real, intent(inout) :: time character(len=*), intent(in) :: fileprefix logical :: iexist - integer :: ierr,nspheres + integer :: ierr,nspheres,npart_old real :: dtinject,tinfall,fac if (.not.gr) call fatal('setup','This setup only works with GR on') @@ -100,7 +100,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma_eos,hf nspheres = int(tinfall/dtsphere) !27!100!20! write(iprint,*) 'number of "real" spheres: ',nspheres fac = 1.+1.e-15 - call inject_particles(dtsphere*nspheres*fac,dtsphere*nspheres,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,dtinject) + npart_old = npart + call inject_particles(dtsphere*nspheres*fac,dtsphere*nspheres,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) endif end subroutine setpart diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index 164b79c77..69c9d9e90 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -122,7 +122,7 @@ subroutine test_wind(ntests,npass) nfailed(1),'no errors in setting particle mass') npart_old = npart call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) ! check 1D wind profile @@ -146,7 +146,7 @@ subroutine test_wind(ntests,npass) ! injection of new particles into simulation ! npart_old=npart - call inject_particles(t,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,dtinject) + call inject_particles(t,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) dtmaxold = dtmax nsteps = nsteps+1 From 71d4589ed55977ba228358abe473f5ea90ddd76c Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Fri, 16 Feb 2024 06:09:33 +0100 Subject: [PATCH 305/814] [header-bot] updated file headers --- src/main/ptmass.F90 | 4 ++-- src/setup/set_softened_core.f90 | 4 ++-- src/setup/set_star_utils.f90 | 7 ++++--- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 97acebd6f..e36d26066 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -35,8 +35,8 @@ module ptmass ! ! :Dependencies: boundary, dim, eos, eos_barotropic, eos_piecewise, ! extern_geopot, externalforces, fastmath, infile_utils, io, io_summary, -! kdtree, kernel, linklist, mpidomain, mpiutils, options, part, units, -! vectorutils +! kdtree, kernel, linklist, mpidomain, mpiutils, options, part, +! ptmass_heating, units, vectorutils ! use part, only:nsinkproperties,gravity,is_accretable,& ihsoft,ihacc,ispinx,ispiny,ispinz,imacc,iJ2,iReff diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index 575eb8598..9c1cd8bec 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -15,8 +15,8 @@ module setsoftenedcore ! ! :Runtime parameters: None ! -! :Dependencies: eos, io, physcon, setcubiccore, setfixedentropycore, -! table_utils +! :Dependencies: eos, eos_mesa, io, physcon, setcubiccore, +! setfixedentropycore, table_utils ! implicit none ! rcore: Radius / Rsun below which we replace the original profile with a diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 6f99b896f..e38097cc7 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -14,9 +14,10 @@ module setstar_utils ! ! :Runtime parameters: None ! -! :Dependencies: eos, eos_piecewise, extern_densprofile, io, part, physcon, -! radiation_utils, readwrite_kepler, readwrite_mesa, rho_profile, -! setsoftenedcore, sortutils, spherical, table_utils, unifdis, units +! :Dependencies: eos, eos_piecewise, extern_densprofile, io, kernel, part, +! physcon, radiation_utils, readwrite_kepler, readwrite_mesa, +! rho_profile, setsoftenedcore, sortutils, spherical, table_utils, +! unifdis, units ! use extern_densprofile, only:nrhotab use readwrite_kepler, only:write_kepler_comp From eefcc37537001b84e1ec32e7180be994ec327ac5 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Fri, 16 Feb 2024 06:09:35 +0100 Subject: [PATCH 306/814] [space-bot] whitespace at end of lines removed --- src/setup/set_fixedentropycore.f90 | 4 ++-- src/setup/set_softened_core.f90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/setup/set_fixedentropycore.f90 b/src/setup/set_fixedentropycore.f90 index 4f34fffef..abff4b6b8 100644 --- a/src/setup/set_fixedentropycore.f90 +++ b/src/setup/set_fixedentropycore.f90 @@ -8,7 +8,7 @@ module setfixedentropycore ! ! This module replaces the core of a MESA stellar profile with a flat- ! entropy profile that is in hydrostatic equilibrium with an added sink -! particle. +! particle. ! ! :References: ! @@ -197,7 +197,7 @@ subroutine one_shot(Sc,r,mcore,msoft,mu,rho,pres,mass,iverbose,ierr) return endif if (rho(i-1) 1) then + if (iverbose > 1) then print*,'WARNING: Density inversion at i = ',i, 'm = ',mass/solarm write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4)') i,rho(i),rho(i-1),mass endif diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index 9c1cd8bec..a7d546658 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -144,7 +144,7 @@ subroutine calc_regrid_core(Ncore,rcore_cm,icore,r1,den1,pres1,m1,X1,Y1,r2,den2, integer, intent(in) :: Ncore real, intent(in) :: rcore_cm integer, intent(inout) :: icore - real, intent(in), dimension(:) :: r1,den1,pres1,m1,X1,Y1 + real, intent(in), dimension(:) :: r1,den1,pres1,m1,X1,Y1 real, intent(out), dimension(:), allocatable :: r2,den2,pres2,m2,X2,Y2 integer :: npts,npts_old,i real :: dr From d41bfd4a7c03c4c909ff9e777f3e26631f76c181 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Fri, 16 Feb 2024 06:09:35 +0100 Subject: [PATCH 307/814] [author-bot] updated AUTHORS file --- AUTHORS | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/AUTHORS b/AUTHORS index c7c448d44..08231398f 100644 --- a/AUTHORS +++ b/AUTHORS @@ -32,8 +32,8 @@ Sergei Biriukov Cristiano Longarini Giovanni Dipierro Roberto Iaconi -Hauke Worpel Amena Faruqi +Hauke Worpel Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani @@ -43,26 +43,28 @@ Simon Glover Thomas Reichardt Jean-François Gonzalez Christopher Russell -Phantom benchmark bot Alessia Franchini -Jolien Malfait Alex Pettitt -Nicole Rodrigues +Jolien Malfait +Phantom benchmark bot Kieran Hirsh +Nicole Rodrigues David Trevascus -Nicolás Cuello Farzana Meru +Nicolás Cuello Chris Nixon Miguel Gonzalez-Bolivar -Mike Lau Benoit Commercon -Orsola De Marco Giulia Ballabio -Maxime Lombart Joe Fisher +Maxime Lombart +Mike Lau +Orsola De Marco Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> Cox, Samuel +Jeremy Smallwood +Jorge Cuadra Steven Rieder Stéven Toupin -Jorge Cuadra +Taj Jankovič From 17ea91dd389e9a79f804393b0e8ae2ed8fc4cba1 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Fri, 16 Feb 2024 06:09:41 +0100 Subject: [PATCH 308/814] [indent-bot] standardised indentation --- src/setup/set_fixedentropycore.f90 | 2 +- src/setup/set_star_utils.f90 | 2 +- src/utils/struct_part.f90 | 8 ++++---- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/setup/set_fixedentropycore.f90 b/src/setup/set_fixedentropycore.f90 index abff4b6b8..5466782fd 100644 --- a/src/setup/set_fixedentropycore.f90 +++ b/src/setup/set_fixedentropycore.f90 @@ -140,7 +140,7 @@ subroutine calc_rho_and_pres(r,mcore,mh,rho,pres,Xcore,Ycore,iverbose) if (abs(mold-mass) < tiny(0.) .and. ierr /= ierr_pres .and. ierr /= ierr_mass) then write(*,'(/,1x,a,e12.5)') 'WARNING: Converged on mcore without reaching tolerance on zero & - ¢ral mass. m(r=0)/msoft = ',mass/msoft + ¢ral mass. m(r=0)/msoft = ',mass/msoft write(*,'(/,1x,a,i4,a,e12.5)') 'Reached iteration ',it,', fac=',fac exit endif diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index e38097cc7..73a5d7017 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -483,6 +483,6 @@ subroutine solve_uT_profiles(eos_type,r,den,pres,Xfrac,Yfrac,regrid_core,temp,en en(i) = eni temp(i) = tempi enddo -end subroutine +end subroutine solve_uT_profiles end module setstar_utils diff --git a/src/utils/struct_part.f90 b/src/utils/struct_part.f90 index 781a3c2fd..99640148d 100644 --- a/src/utils/struct_part.f90 +++ b/src/utils/struct_part.f90 @@ -149,10 +149,10 @@ subroutine get_structure_fn(sf,nbins,norder,distmin,distmax,xbins,ncount,npart,x !$omp reduction(+:sf) do ipt=1,npts !$ if (.false.) then - if (mod(ipt,100)==0) then - call cpu_time(tcpu2) - print*,' ipt = ',ipt,tcpu2-tcpu1 - endif + if (mod(ipt,100)==0) then + call cpu_time(tcpu2) + print*,' ipt = ',ipt,tcpu2-tcpu1 + endif !$ endif i = list(ipt) xpt(1) = xyz(1,i) From 75eb98c2173267eab30d7f6c44ee19cc816a835c Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Mon, 19 Feb 2024 06:49:15 +0100 Subject: [PATCH 309/814] add iorig test --- src/main/partinject.F90 | 12 ++-- src/main/ptmass.F90 | 4 +- src/setup/set_fixedentropycore.f90 | 6 +- src/setup/set_softened_core.f90 | 6 +- src/setup/set_star_utils.f90 | 9 +-- src/setup/setup_bondiinject.f90 | 3 +- src/tests/test_iorig.f90 | 99 ++++++++++++++++++++++++++++++ src/tests/test_ptmass.f90 | 4 +- src/tests/testsuite.F90 | 25 ++++++-- src/tests/utils_testsuite.f90 | 67 +++++++++++++++++++- src/utils/struct_part.f90 | 8 +-- 11 files changed, 209 insertions(+), 34 deletions(-) create mode 100644 src/tests/test_iorig.f90 diff --git a/src/main/partinject.F90 b/src/main/partinject.F90 index 0469a73fc..dadfffb35 100644 --- a/src/main/partinject.F90 +++ b/src/main/partinject.F90 @@ -45,6 +45,7 @@ subroutine add_or_update_particle(itype,position,velocity,h,u,particle_number,np use part, only:maxalpha,alphaind,maxgradh,gradh,fxyzu,fext,set_particle_type use part, only:mhd,Bevol,dBevol,Bxyz,divBsymm!,dust_temp 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 @@ -69,6 +70,9 @@ subroutine add_or_update_particle(itype,position,velocity,h,u,particle_number,np call fatal('Add particle','npart > maxp') endif npartoftype(itype) = npartoftype(itype) + 1 + ! add particle ID + norig = norig + 1 + iorig(particle_number) = norig elseif (particle_number > npart + 1) then call fatal('Add particle', 'Incorrect particle number (> npart + 1).') elseif (particle_number <= npart) then @@ -160,7 +164,7 @@ end subroutine add_or_update_sink subroutine update_injected_particles(npartold,npart,istepfrac,nbinmax,time,dtmax,dt,dtinject) use dim, only:ind_timesteps use timestep_ind, only:get_newbin,change_nbinmax,get_dt - use part, only:twas,ibin,ibin_old,norig,iorig,iphase,igas,iunknown + use part, only:twas,ibin,ibin_old,iphase,igas,iunknown #ifdef GR use part, only:xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext use cons2prim, only:prim2consall @@ -213,12 +217,6 @@ subroutine update_injected_particles(npartold,npart,istepfrac,nbinmax,time,dtmax dt = min(dt,dtinject) endif - ! add particle ID - do i=npartold+1,npart - norig = norig + 1 - iorig(i) = norig - enddo - ! if a particle was updated rather than added, reset iphase & set timestep (if individual timestepping) if (updated_particle) then do i=1,npart diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 97acebd6f..e36d26066 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -35,8 +35,8 @@ module ptmass ! ! :Dependencies: boundary, dim, eos, eos_barotropic, eos_piecewise, ! extern_geopot, externalforces, fastmath, infile_utils, io, io_summary, -! kdtree, kernel, linklist, mpidomain, mpiutils, options, part, units, -! vectorutils +! kdtree, kernel, linklist, mpidomain, mpiutils, options, part, +! ptmass_heating, units, vectorutils ! use part, only:nsinkproperties,gravity,is_accretable,& ihsoft,ihacc,ispinx,ispiny,ispinz,imacc,iJ2,iReff diff --git a/src/setup/set_fixedentropycore.f90 b/src/setup/set_fixedentropycore.f90 index 4f34fffef..5466782fd 100644 --- a/src/setup/set_fixedentropycore.f90 +++ b/src/setup/set_fixedentropycore.f90 @@ -8,7 +8,7 @@ module setfixedentropycore ! ! This module replaces the core of a MESA stellar profile with a flat- ! entropy profile that is in hydrostatic equilibrium with an added sink -! particle. +! particle. ! ! :References: ! @@ -140,7 +140,7 @@ subroutine calc_rho_and_pres(r,mcore,mh,rho,pres,Xcore,Ycore,iverbose) if (abs(mold-mass) < tiny(0.) .and. ierr /= ierr_pres .and. ierr /= ierr_mass) then write(*,'(/,1x,a,e12.5)') 'WARNING: Converged on mcore without reaching tolerance on zero & - ¢ral mass. m(r=0)/msoft = ',mass/msoft + ¢ral mass. m(r=0)/msoft = ',mass/msoft write(*,'(/,1x,a,i4,a,e12.5)') 'Reached iteration ',it,', fac=',fac exit endif @@ -197,7 +197,7 @@ subroutine one_shot(Sc,r,mcore,msoft,mu,rho,pres,mass,iverbose,ierr) return endif if (rho(i-1) 1) then + if (iverbose > 1) then print*,'WARNING: Density inversion at i = ',i, 'm = ',mass/solarm write(*,'(i5,2x,e12.4,2x,e12.4,2x,e12.4)') i,rho(i),rho(i-1),mass endif diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index 575eb8598..a7d546658 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -15,8 +15,8 @@ module setsoftenedcore ! ! :Runtime parameters: None ! -! :Dependencies: eos, io, physcon, setcubiccore, setfixedentropycore, -! table_utils +! :Dependencies: eos, eos_mesa, io, physcon, setcubiccore, +! setfixedentropycore, table_utils ! implicit none ! rcore: Radius / Rsun below which we replace the original profile with a @@ -144,7 +144,7 @@ subroutine calc_regrid_core(Ncore,rcore_cm,icore,r1,den1,pres1,m1,X1,Y1,r2,den2, integer, intent(in) :: Ncore real, intent(in) :: rcore_cm integer, intent(inout) :: icore - real, intent(in), dimension(:) :: r1,den1,pres1,m1,X1,Y1 + real, intent(in), dimension(:) :: r1,den1,pres1,m1,X1,Y1 real, intent(out), dimension(:), allocatable :: r2,den2,pres2,m2,X2,Y2 integer :: npts,npts_old,i real :: dr diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 6f99b896f..73a5d7017 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -14,9 +14,10 @@ module setstar_utils ! ! :Runtime parameters: None ! -! :Dependencies: eos, eos_piecewise, extern_densprofile, io, part, physcon, -! radiation_utils, readwrite_kepler, readwrite_mesa, rho_profile, -! setsoftenedcore, sortutils, spherical, table_utils, unifdis, units +! :Dependencies: eos, eos_piecewise, extern_densprofile, io, kernel, part, +! physcon, radiation_utils, readwrite_kepler, readwrite_mesa, +! rho_profile, setsoftenedcore, sortutils, spherical, table_utils, +! unifdis, units ! use extern_densprofile, only:nrhotab use readwrite_kepler, only:write_kepler_comp @@ -482,6 +483,6 @@ subroutine solve_uT_profiles(eos_type,r,den,pres,Xfrac,Yfrac,regrid_core,temp,en en(i) = eni temp(i) = tempi enddo -end subroutine +end subroutine solve_uT_profiles end module setstar_utils diff --git a/src/setup/setup_bondiinject.f90 b/src/setup/setup_bondiinject.f90 index 33db8a8af..cd39849b1 100644 --- a/src/setup/setup_bondiinject.f90 +++ b/src/setup/setup_bondiinject.f90 @@ -101,7 +101,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma_eos,hf write(iprint,*) 'number of "real" spheres: ',nspheres fac = 1.+1.e-15 npart_old = npart - call inject_particles(dtsphere*nspheres*fac,dtsphere*nspheres,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) + call inject_particles(dtsphere*nspheres*fac,dtsphere*nspheres,xyzh,vxyzu,xyzmh_ptmass,& + vxyz_ptmass,npart,npart_old,npartoftype,dtinject) endif end subroutine setpart diff --git a/src/tests/test_iorig.f90 b/src/tests/test_iorig.f90 new file mode 100644 index 000000000..5dcfde5b1 --- /dev/null +++ b/src/tests/test_iorig.f90 @@ -0,0 +1,99 @@ +!--------------------------------------------------------------------------! +! 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 testiorig +! +! Unit tests particle id +! +! :References: +! +! :Owner: Mats Esseldeurs +! +! :Runtime parameters: None +! +! :Dependencies: io, part, partinject, random, testutils +! + implicit none + + public :: test_iorig + private + +contains +!------------------------------------------------- +!+ +! unit tests of particle id bookkeeping +!+ +!------------------------------------------------- +subroutine test_iorig(ntests,npass) + use part, only:iorig,npart,npartoftype,xyzh,vxyzu,kill_particle,shuffle_part + use io, only:id,master + use testutils, only:checkval,update_test_scores,checkvalbuf,checkvalbuf_end + use random, only:ran2 + use partinject, only:add_or_update_particle, update_injected_particles + integer, intent(inout) :: ntests,npass + integer :: i, j, iseed, ncheck, ierrmax + integer :: nfailed(1) + character(len=10) :: stringi, stringj + + if (id==master) write(*,"(/,a,/)") '--> TESTING PARTICLE ID' + + nfailed(1) = 0 + npart = 0 + iseed = -666 + + do i = 1,100 + call add_or_update_particle(1,(/ran2(iseed), ran2(iseed), ran2(iseed)/),(/ran2(iseed), ran2(iseed), ran2(iseed)/), & + ran2(iseed),ran2(iseed),i,npart,npartoftype,xyzh,vxyzu) + enddo + + call checkval(npart,100,0,nfailed(1),'Check npart at start') + call update_test_scores(ntests,nfailed,npass) + + ncheck=0 + nfailed(1)=0 + ierrmax=0 + do i = 1, 10 + call kill_particle(12, npartoftype) + call kill_particle(3, npartoftype) + call kill_particle(9, npartoftype) + call kill_particle(8, npartoftype) + + call shuffle_part(npart) + + write(stringi, "(I2)") i + call checkvalbuf(npart,100-4*i,0,'Check npart while deleting '//trim(stringi),nfailed(1),ncheck,ierrmax) + enddo + + call checkvalbuf_end('check npart while deleting', ncheck, nfailed(1), ierrmax, 0) + + do i = npart,npart+100 + call add_or_update_particle(1,(/ran2(iseed), ran2(iseed), ran2(iseed)/),(/ran2(iseed), ran2(iseed), ran2(iseed)/), & + ran2(iseed),ran2(iseed),i,npart,npartoftype,xyzh,vxyzu) + enddo + + call checkval(npart,160,0,nfailed(1),'Check npart at end') + call update_test_scores(ntests,nfailed,npass) + + ncheck=0 + nfailed(1)=0 + do i = 1, npart + do j = i+1, npart + write(stringi, "(I2)") i + write(stringj, "(I2)") j + call checkvalbuf(iorig(i)==iorig(j),.false.,& + 'Check iorig('//trim(stringi)//' != iorig('//trim(stringj)//')',nfailed(1),ncheck) + enddo + enddo + call checkvalbuf_end('Check iorig',ncheck,nfailed(1)) + + call update_test_scores(ntests,nfailed,npass) + + if (id==master) write(*,"(/,a)") '<-- PARTICLE ID TEST COMPLETE' + +end subroutine test_iorig + + +end module testiorig diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index da894c7f1..28cdce44b 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -276,7 +276,7 @@ subroutine test_binary(ntests,npass) ! !--check initial angular momentum on the two sinks is correct ! - call checkval(angtot,m1*m2*sqrt(a/(m1 + m2)),1.e6*epsilon(0.),nfailed(1),'angular momentum') + call checkval(angtot,m1*m2*sqrt(a/(m1 + m2)),1e6*epsilon(0.),nfailed(1),'angular momentum') call update_test_scores(ntests,nfailed,npass) endif ! @@ -339,7 +339,7 @@ subroutine test_binary(ntests,npass) call checkvalbuf_end('grav. wave strain (+)',ncheckgw(2),nfailgw(2),errgw(2),tolgw) call update_test_scores(ntests,nfailgw(1:2),npass) endif - call checkval(angtot,angmomin,3.1e-13,nfailed(3),'angular momentum') + call checkval(angtot,angmomin,3.2e-13,nfailed(3),'angular momentum') call checkval(totmom,totmomin,epsilon(0.),nfailed(2),'linear momentum') tolen = 3.e-8 if (itest==4) tolen = 1.6e-2 ! etot is small compared to ekin diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index 01e189eeb..180e2708b 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -18,10 +18,10 @@ module test ! :Dependencies: dim, io, io_summary, mpiutils, options, testcooling, ! testcorotate, testdamping, testderivs, testdust, testeos, testexternf, ! testgeometry, testgnewton, testgr, testgravity, testgrowth, -! testindtstep, testkdtree, testkernel, testlink, testmath, testmpi, -! testnimhd, testpart, testpoly, testptmass, testradiation, testrwdump, -! testsedov, testsetdisc, testsethier, testsmol, teststep, testwind, -! timing +! testindtstep, testiorig, testkdtree, testkernel, testlink, testmath, +! testmpi, testnimhd, testpart, testpoly, testptmass, testradiation, +! testrwdump, testsedov, testsetdisc, testsethier, testsmol, teststep, +! testwind, timing ! implicit none public :: testsuite @@ -64,6 +64,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) use testcooling, only:test_cooling use testgeometry, only:test_geometry use testwind, only:test_wind + use testiorig, only:test_iorig use testpoly, only:test_poly use testdamping, only:test_damping use testradiation,only:test_radiation @@ -79,7 +80,7 @@ subroutine testsuite(string,first,last,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 + logical :: dogr,doradiation,dopart,dopoly,dompi,dohier,dodamp,dowind,doiorig #ifdef FINVSQRT logical :: usefsqrt,usefinvsqrt #endif @@ -132,6 +133,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) dohier = .false. dodamp = .false. dowind = .false. + doiorig = .false. if (index(string,'deriv') /= 0) doderivs = .true. if (index(string,'grav') /= 0) dogravity = .true. @@ -153,10 +155,11 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) if (index(string,'hier') /= 0) dohier = .true. if (index(string,'damp') /= 0) dodamp = .true. if (index(string,'wind') /= 0) dowind = .true. + if (index(string,'iorig') /= 0) doiorig = .true. doany = any((/doderivs,dogravity,dodust,dogrowth,donimhd,dorwdump,& doptmass,docooling,dogeom,dogr,dosmol,doradiation,& - dopart,dopoly,dohier,dodamp,dowind/)) + dopart,dopoly,dohier,dodamp,dowind,doiorig/)) select case(trim(string)) case('kernel','kern') @@ -197,6 +200,8 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) donimhd = .true. case('wind') dowind = .true. + case('iorig') + doiorig = .true. case('mpi') dompi = .true. case default @@ -396,6 +401,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) call test_radiation(ntests,npass) call set_default_options_testsuite(iverbose) ! restore defaults endif +! !--test of wind module ! if (dowind.or.testall) then @@ -403,6 +409,13 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) call set_default_options_testsuite(iverbose) ! restore defaults endif ! +!--test of particle id +! + if (doiorig .or. testall) then + call test_iorig(ntests,npass) + call set_default_options_testsuite(iverbose) ! restore defaults + endif +! !--now do a "real" calculation, putting it all together (Sedov blast wave) ! if (dosedov.or.testall) then diff --git a/src/tests/utils_testsuite.f90 b/src/tests/utils_testsuite.f90 index 50f081baa..8f05a7d0c 100644 --- a/src/tests/utils_testsuite.f90 +++ b/src/tests/utils_testsuite.f90 @@ -42,7 +42,7 @@ module testutils end interface checkvalbuf interface checkvalbuf_end - module procedure checkvalbuf_end_int,checkvalbuf_end_real + module procedure checkvalbuf_end_int,checkvalbuf_end_real,checkvalbuf_end_logical end interface checkvalbuf_end interface printerr @@ -50,7 +50,7 @@ module testutils end interface printerr interface printresult - module procedure printresult_real,printresult_int + module procedure printresult_real,printresult_int,printresult_logical end interface printresult real, parameter :: smallval = 1.e-6 @@ -709,6 +709,26 @@ subroutine checkvalbuf_end_real(label,n,ndiff,errmax,tol) return end subroutine checkvalbuf_end_real +!---------------------------------------------------------------- +!+ +! end a buffered error check (logical) +!+ +!---------------------------------------------------------------- +subroutine checkvalbuf_end_logical(label,n,ndiff,ntot) + character(len=*), intent(in) :: label + integer, intent(in) :: n + integer, intent(inout) :: ndiff + integer, intent(in), optional :: ntot + + call print_testinfo(trim(label)) + if (present(ntot)) then + call printresult(n,ndiff,ntot) + else + call printresult(n,ndiff) + endif + +end subroutine checkvalbuf_end_logical + !---------------------------------------------------------------- !+ ! formatting for printing errors in test results @@ -923,4 +943,47 @@ subroutine printresult_int(nchecki,ndiff,ierrmax,itol,ntot) return end subroutine printresult_int +!---------------------------------------------------------------- +!+ +! formatting for printing test results +!+ +!---------------------------------------------------------------- +subroutine printresult_logical(nchecki,ndiff,ntot) + integer, intent(in) :: nchecki + integer, intent(inout) :: ndiff + integer, intent(in), optional :: ntot + integer(kind=8) :: ncheck + + ncheck = reduce_mpi('+',nchecki) + ndiff = int(reduce_mpi('+',ndiff)) + + if (id==master) then + if (ndiff==0) then + if (ncheck > 0) then + if (present(ntot)) then + if (ntot < 1e6 .and. ncheck < 1e6) then + write(*,"(2(a,i5),a)") 'OK [checked ',ncheck,' of ',ntot,' values]' + else + write(*,"(2(a,i10),a)") 'OK [checked ',ncheck,' of ',ntot,' values]' + endif + else + if (ncheck < 1e6) then + write(*,"(a,i5,a)") 'OK [checked ',ncheck,' values]' + else + write(*,"(a,i10,a)") 'OK [checked ',ncheck,' values]' + endif + endif + else + write(*,"(a)") 'OK' + endif + elseif (ndiff > 0) then + write(*,"(2(a,i10),a)") 'FAILED [on ',ndiff,' of ',ncheck,' values',']' + else ! this is used for single values + write(*,"(1x,a)") 'FAILED' + endif + endif + + return +end subroutine printresult_logical + end module testutils diff --git a/src/utils/struct_part.f90 b/src/utils/struct_part.f90 index 781a3c2fd..99640148d 100644 --- a/src/utils/struct_part.f90 +++ b/src/utils/struct_part.f90 @@ -149,10 +149,10 @@ subroutine get_structure_fn(sf,nbins,norder,distmin,distmax,xbins,ncount,npart,x !$omp reduction(+:sf) do ipt=1,npts !$ if (.false.) then - if (mod(ipt,100)==0) then - call cpu_time(tcpu2) - print*,' ipt = ',ipt,tcpu2-tcpu1 - endif + if (mod(ipt,100)==0) then + call cpu_time(tcpu2) + print*,' ipt = ',ipt,tcpu2-tcpu1 + endif !$ endif i = list(ipt) xpt(1) = xyz(1,i) From 18115534c984322141e3fc111f3116172ebc3fb8 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Mon, 19 Feb 2024 06:50:20 +0100 Subject: [PATCH 310/814] [author-bot] updated AUTHORS file --- AUTHORS | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/AUTHORS b/AUTHORS index c7c448d44..dc6272205 100644 --- a/AUTHORS +++ b/AUTHORS @@ -16,14 +16,13 @@ Daniel Mentiplay Megha Sharma Arnaud Vericel Mark Hutchison +Mats Esseldeurs Rebecca Nealon Elisabeth Borchert Ward Homan Christophe Pinte Terrence Tricco Simone Ceppi -Mats Esseldeurs -Mats Esseldeurs Stephane Michoulier Spencer Magnall Caitlyn Hardiman @@ -32,8 +31,8 @@ Sergei Biriukov Cristiano Longarini Giovanni Dipierro Roberto Iaconi -Hauke Worpel Amena Faruqi +Hauke Worpel Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani @@ -43,26 +42,28 @@ Simon Glover Thomas Reichardt Jean-François Gonzalez Christopher Russell -Phantom benchmark bot Alessia Franchini -Jolien Malfait Alex Pettitt -Nicole Rodrigues +Jolien Malfait +Phantom benchmark bot Kieran Hirsh +Nicole Rodrigues David Trevascus -Nicolás Cuello Farzana Meru +Nicolás Cuello Chris Nixon Miguel Gonzalez-Bolivar -Mike Lau Benoit Commercon -Orsola De Marco Giulia Ballabio -Maxime Lombart Joe Fisher +Maxime Lombart +Mike Lau +Orsola De Marco Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> Cox, Samuel +Jeremy Smallwood +Jorge Cuadra Steven Rieder Stéven Toupin -Jorge Cuadra +Taj Jankovič From 8fd14a01685020e0835228a873b9b3e8a2199fc7 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Mon, 19 Feb 2024 06:56:48 +0100 Subject: [PATCH 311/814] update makefile --- .mailmap | 4 ---- build/Makefile | 2 +- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/.mailmap b/.mailmap index 4643b98f1..8332207b8 100644 --- a/.mailmap +++ b/.mailmap @@ -80,8 +80,6 @@ Lionel Siess Lionel Siess Lionel Siess Lionel Siess -Mats Esseldeurs -Mats Esseldeurs David Liptai David Liptai David Liptai <31463304+dliptai@users.noreply.github.com> @@ -117,6 +115,4 @@ Amena Faruqi <42060670+amenafaruqi@users.noreply.gi Amena Faruqi Amena Faruqi Alison Young Alison Young Simone Ceppi Simone Ceppi -Mats Esseldeurs mats esseldeurs -Mats Esseldeurs MatsEsseldeurs Nicolás Cuello Nicolas Cuello diff --git a/build/Makefile b/build/Makefile index 8cb3c6349..ccbba721b 100644 --- a/build/Makefile +++ b/build/Makefile @@ -689,7 +689,7 @@ SRCTESTS=utils_testsuite.f90 ${TEST_FASTMATH} test_kernel.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_hierarchical.f90 test_damping.f90 test_wind.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 \ ${SRCTESTMPI} test_sedov.F90 test_poly.f90 test_radiation.F90 \ From 6513792a790ebefdad2b5963c56a94345f0c2545 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Mon, 19 Feb 2024 23:57:05 +0100 Subject: [PATCH 312/814] Increase tol to pass oblate star test --- src/tests/test_ptmass.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 28cdce44b..2096c3d5d 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -339,7 +339,7 @@ subroutine test_binary(ntests,npass) call checkvalbuf_end('grav. wave strain (+)',ncheckgw(2),nfailgw(2),errgw(2),tolgw) call update_test_scores(ntests,nfailgw(1:2),npass) endif - call checkval(angtot,angmomin,3.2e-13,nfailed(3),'angular momentum') + call checkval(angtot,angmomin,4.e-13,nfailed(3),'angular momentum') call checkval(totmom,totmomin,epsilon(0.),nfailed(2),'linear momentum') tolen = 3.e-8 if (itest==4) tolen = 1.6e-2 ! etot is small compared to ekin From c635ede23b77938e97063d96d651b5ecbaf1f103 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Tue, 20 Feb 2024 05:01:19 +0100 Subject: [PATCH 313/814] Make phantom compile with Krome --- build/MakeKrome | 11 ++++++----- build/Makefile | 3 ++- scripts/writemake.sh | 13 ++++++++----- src/main/krome.f90 | 8 ++++---- src/main/step_leapfrog.F90 | 3 +++ 5 files changed, 23 insertions(+), 15 deletions(-) diff --git a/build/MakeKrome b/build/MakeKrome index 382d96261..ab8b2d3ca 100644 --- a/build/MakeKrome +++ b/build/MakeKrome @@ -3,7 +3,7 @@ KROME_BUILD_DIR = ${KROMEPATH}/build -KFLAGS="$(FFLAGS)" +KFLAGS="$(FFLAGS) -ffree-line-length-none -fallow-argument-mismatch" FFLAGS+= -I$(KROME_BUILD_DIR) PASSED=0 @@ -21,23 +21,24 @@ endif ifeq ("$(wildcard ${KROMEPATH}/build/optionsKrome.opt)","") cp $(RUNDIR)/krome.setup ${KROMEPATH}/build/optionsKrome.opt cd ${KROMEPATH}; ./krome -options=build/optionsKrome.opt - cp -f ${KROMEPATH}/data/coolCO.dat ${KROMEPATH}/data/coolH2O.dat ${KROMEPATH}/data/coolOH.dat ${KROMEPATH}/data/coolHCN.dat ${KROMEPATH}/build/reactions_verbatim.dat ${RUNDIR} + cp -f ${KROMEPATH}/build/*.dat ${KROMEPATH}/build/*.gfe ${RUNDIR} make clean_krome override PASSED:=1 endif ifeq ("$(PASSED)$(wildcard ${KROMEPATH}/build/reactions_verbatim.dat)","0") cd ${KROMEPATH}; ./krome -options=build/optionsKrome.opt - cp ${KROMEPATH}/data/coolCO.dat ${KROMEPATH}/data/coolH2O.dat ${KROMEPATH}/data/coolOH.dat ${KROMEPATH}/data/coolHCN.dat ${KROMEPATH}/build/reactions_verbatim.dat ${RUNDIR} + @echo ${KROMEPATH}/build/*.dat + cp -f ${KROMEPATH}/build/*.dat ${KROMEPATH}/build/*.gfe ${RUNDIR} endif krome: $(KROME_OBJS) ifeq ("$(wildcard coolCO.dat)","") - cp -f ${KROMEPATH}/data/coolCO.dat ${KROMEPATH}/data/coolH2O.dat ${KROMEPATH}/data/coolOH.dat ${KROMEPATH}/data/coolHCN.dat ${KROMEPATH}/build/reactions_verbatim.dat ${RUNDIR} + cp -f ${KROMEPATH}/build/*.dat ${KROMEPATH}/build/*.gfe ${RUNDIR} endif $(KROME_OBJS): - $(MAKE) -C $(KROME_BUILD_DIR) fc=$(FC) switch=$(KFLAGS) + $(MAKE) -C $(KROME_BUILD_DIR) fc=$(FC) switch=$(filter-out -std=f2008, $(KFLAGS)) clean_krome: $(MAKE) -C $(KROME_BUILD_DIR) clean diff --git a/build/Makefile b/build/Makefile index ccbba721b..d5f59fc7c 100644 --- a/build/Makefile +++ b/build/Makefile @@ -291,7 +291,8 @@ ifeq ($(KROME), krome) ifeq ($(SYSTEM), ifort) LDFLAGS += -mkl else - LDFLAGS += -L/usr/lib/x86_64-linux-gnu -lmkl_core -lmkl_gnu_thread -lmkl_gf_lp64 -fopenmp + # LDFLAGS += -L/usr/lib/x86_64-linux-gnu -lmkl_core -lmkl_gnu_thread -lmkl_gf_lp64 -fopenmp + LDFLAGS += -llapack endif endif diff --git a/scripts/writemake.sh b/scripts/writemake.sh index 74de842f4..c7c487fb4 100755 --- a/scripts/writemake.sh +++ b/scripts/writemake.sh @@ -12,13 +12,16 @@ echo '#' echo 'PHANTOMDIR='${0/scripts\/writemake.sh/}; echo 'SPLASHDIR='$splashdir echo 'EDITOR=vi' +makeflags='RUNDIR=${PWD}'; if [ $# -ge 1 ]; then echo 'ifndef SETUP'; echo 'SETUP='$1; echo 'endif'; - makeflags='SETUP=${SETUP} RUNDIR=${PWD} KROME='$2; -else - makeflags='RUNDIR=${PWD}'; + makeflags=$makeflags' SETUP=${SETUP}'; +fi +if [ $# -ge 2 ]; then + echo 'KROMEPATH='${0/phantom\/scripts\/writemake.sh/krome}; + makeflags=$makeflags' KROME='$2' KROMEPATH=${KROMEPATH}'; fi echo '' echo 'again:' @@ -38,8 +41,8 @@ echo 'libphantom : phantomlib' echo 'mflow : mflow' echo echo 'clean:' -if [ $# -ge 1 ]; then - echo ' cd ${PHANTOMDIR}; make clean KROME=krome' +if [ $# -ge 2 ]; then + echo ' cd ${PHANTOMDIR}; make clean KROME='$2' KROMEPATH=${KROMEPATH}' else echo ' cd ${PHANTOMDIR}; make clean' fi diff --git a/src/main/krome.f90 b/src/main/krome.f90 index 8f5b14ed7..4ece40748 100644 --- a/src/main/krome.f90 +++ b/src/main/krome.f90 @@ -75,11 +75,11 @@ subroutine initialise_krome() S_init = 3.97e-4 ! mass fraction Fe_init = 1.17e-3 ! mass fraction Si_init = 6.54e-4 ! mass fraction - Mg_init = 5.16e-4 + Mg_init = 5.16e-4 ! mass fraction - Na_init = 3.38e-5 - P_init = 8.17e-6 - F_init = 4.06e-7 + Na_init = 3.38e-5 ! mass fraction + P_init = 8.17e-6 ! mass fraction + F_init = 4.06e-7 ! mass fraction H_init = 1.0 - He_init - C_init - N_init - O_init - S_init - Fe_init - & Si_init - Mg_init - Na_init - P_init - F_init diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index c57029349..70e4376dd 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -1208,6 +1208,9 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, !$omp private(fonrmaxi,dtphi2i,dtf) & !$omp private(vxhalfi,vyhalfi,vzhalfi) & !$omp firstprivate(pmassi,itype) & +#ifdef KROME + !$omp shared(T_gas_cool) & +#endif !$omp reduction(+:accretedmass) & !$omp reduction(min:dtextforcenew,dtsinkgas,dtphi2) & !$omp reduction(max:fonrmax) & From c8c446e0590df83c27207414062516030c0725e4 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Wed, 21 Feb 2024 14:43:13 +1100 Subject: [PATCH 314/814] Add github action for compiling phantom with krome --- .github/workflows/krome.yml | 50 + build/MakeKrome | 11 +- build/Makefile | 4 +- build/optionsKrome.opt | 12 - data/Krome/react_AGBwind_nucleation | 2017 +++++++++++++++++++++++++++ 5 files changed, 2076 insertions(+), 18 deletions(-) create mode 100644 .github/workflows/krome.yml delete mode 100644 build/optionsKrome.opt create mode 100644 data/Krome/react_AGBwind_nucleation diff --git a/.github/workflows/krome.yml b/.github/workflows/krome.yml new file mode 100644 index 000000000..db85f8c42 --- /dev/null +++ b/.github/workflows/krome.yml @@ -0,0 +1,50 @@ +name: krome + +# Trigger on pull request, but only for the master branch +on: + pull_request: + branches: [ master ] + paths-ignore: + - 'docs/**' + - 'README.md' + +env: + PREFIX: /usr/local/ + PHANTOM_DIR: ${{ github.workspace }} + KROMEPATH: ${{ github.workspace }}/krome + +# A workflow run is made up of one or more jobs that can run sequentially or in parallel +jobs: + test: + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, macos-latest] + toolchain: [{compiler: gcc}, {compiler: intel-classic}] + + steps: + - uses: awvwgk/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} + + - name: "Clone phantom" + uses: actions/checkout@v3 + + - name: "Clone krome" + run: git clone https://bitbucket.org/tgrassi/krome.git krome + + - name: "make krome.setup" + run: echo -e "-n=networks/react_AGBwind_nucleation\n-cooling=ATOMIC,CHEM,H2,CIE,Z,CI,CII,OI,OII,CO,OH,H2O,HCN\n-heating=CHEM,CR\n-H2opacity=RIPAMONTI\n-gamma=EXACT\n-noSinkCheck\n-noRecCheck\n-noTlimits\n-useX\n-conserveLin\n-useTabs\n-unsafe\n-iRHS" > krome.setup && cat krome.setup + + - name: "Compile phantom and link with krome" + run: make SYSTEM=${{ env.FC }} SETUP=wind KROME=krome KROMEPATH=${KROMEPATH} PREFIX=${PREFIX} RUNDIR=${{ github.workspace }} + + - name: "Compile phantomsetup and link with krome" + run: make SYSTEM=${{ env.FC }} SETUP=wind KROME=krome KROMEPATH=${KROMEPATH} PREFIX=${PREFIX} RUNDIR=${PREFIX} setup + + - name: "Compile phantomanalysis and link with krome" + run: make SYSTEM=${{ env.FC }} SETUP=wind KROME=krome KROMEPATH=${KROMEPATH} PREFIX=${PREFIX} RUNDIR=${PREFIX} analysis + + - name: "Compile phantommoddump and link with krome" + run: make SYSTEM=${{ env.FC }} SETUP=wind KROME=krome KROMEPATH=${KROMEPATH} PREFIX=${PREFIX} RUNDIR=${PREFIX} moddump diff --git a/build/MakeKrome b/build/MakeKrome index ab8b2d3ca..0171e2408 100644 --- a/build/MakeKrome +++ b/build/MakeKrome @@ -3,7 +3,12 @@ KROME_BUILD_DIR = ${KROMEPATH}/build -KFLAGS="$(FFLAGS) -ffree-line-length-none -fallow-argument-mismatch" +KFLAGS=$(filter-out -std=f2008, $(FFLAGS)) +ifeq ($(SYSTEM), ifort) + KFLAGS += -O3 -ipo -ip -unroll -xHost -g -fp-model precise +else + KFLAGS += -ffree-line-length-none -w -fallow-argument-mismatch +endif FFLAGS+= -I$(KROME_BUILD_DIR) PASSED=0 @@ -27,7 +32,6 @@ override PASSED:=1 endif ifeq ("$(PASSED)$(wildcard ${KROMEPATH}/build/reactions_verbatim.dat)","0") cd ${KROMEPATH}; ./krome -options=build/optionsKrome.opt - @echo ${KROMEPATH}/build/*.dat cp -f ${KROMEPATH}/build/*.dat ${KROMEPATH}/build/*.gfe ${RUNDIR} endif @@ -36,9 +40,8 @@ ifeq ("$(wildcard coolCO.dat)","") cp -f ${KROMEPATH}/build/*.dat ${KROMEPATH}/build/*.gfe ${RUNDIR} endif - $(KROME_OBJS): - $(MAKE) -C $(KROME_BUILD_DIR) fc=$(FC) switch=$(filter-out -std=f2008, $(KFLAGS)) + $(MAKE) -C $(KROME_BUILD_DIR) fc=$(FC) switch="$(KFLAGS)" clean_krome: $(MAKE) -C $(KROME_BUILD_DIR) clean diff --git a/build/Makefile b/build/Makefile index d5f59fc7c..219f2eb0b 100644 --- a/build/Makefile +++ b/build/Makefile @@ -289,7 +289,7 @@ endif ifeq ($(KROME), krome) FPPFLAGS += -DKROME ifeq ($(SYSTEM), ifort) - LDFLAGS += -mkl + LDFLAGS += -llapack else # LDFLAGS += -L/usr/lib/x86_64-linux-gnu -lmkl_core -lmkl_gnu_thread -lmkl_gf_lp64 -fopenmp LDFLAGS += -llapack @@ -555,7 +555,7 @@ OBJECTS = $(OBJECTS1:.F90=.o) ifeq ($(KROME), krome) .PHONY: all - all: checksystem krome_setup krome phantom + all: checksystem checkparams krome_setup krome phantom include MakeKrome else .PHONY: phantom diff --git a/build/optionsKrome.opt b/build/optionsKrome.opt deleted file mode 100644 index f553c9d5b..000000000 --- a/build/optionsKrome.opt +++ /dev/null @@ -1,12 +0,0 @@ --n=networks/react_AGB_full_noNucl -#-compact --cooling=ATOMIC,CHEM,H2,CIE,Z,CI,CII,OI,OII,CO,OH,H2O,HCN --heating=CHEM,CR --H2opacity=RIPAMONTI --gamma=EXACT --noSinkCheck --noRecCheck --noTlimits --useX --conserveLin --useTabs diff --git a/data/Krome/react_AGBwind_nucleation b/data/Krome/react_AGBwind_nucleation new file mode 100644 index 000000000..b2aca4fec --- /dev/null +++ b/data/Krome/react_AGBwind_nucleation @@ -0,0 +1,2017 @@ +######################### +# This a reduced network with nucleation reactions suitable for an AGB wind. +# It consists of several parts +# 1. Reduced AGB wind network +# 2. Nucleation reactions for SiO, TiO2, MgO, Al2O3 +# 3. Additional reactions with Ti, Mg, Al - oxides +# Note: this network is suitable to be used with tabulated rates (-useTabs) +# +# +# 1. +# reactions 1 - 219 are a subset from UMIST database limited to 3 atoms +# non-reduced file automatically generated with DOCMAKE on 2017-04-07 16:21:33 +#changeset: ab01f9b +#using the following options +# skipSpecies = +# outputFile = UMIST_to_Fe_3atmbis.dat +# Tmin = -1e99 +# cations = True +# skipTlimitsSingle = True +# maxAtoms = 3 +# useAtoms = E,H,He,Li,Be,B,C,N,O,F,Ne,Na,Mg,Al,Si,P,S,Fe,Co,Ni +# Tmax = 1e99 +# skipString = +# skipRateString = dustGrainAlbedo|user_Av +# skipAtoms = +# anions = True +# useSpecies = +# +# reactions 220 - 256 are added manually with reason and/or reference +# given at the reaction +# +# +# 2.+ 3. +# Nucleation reactions with cluster_growth_rate() based on +# non-steady state nucleation theory. +# Additional reactions manually added from literature sources +# with reference and extra info given at the reaction. +# Reversed reactions based on detailed balance with Gibbs free energy +# values in data/thermochemistry. This data should be used below 10 000K, +# above this threshold extra electronic energy contributions have to added to +# the data. +# Note: this part is not a reduced version and can still contain reaction_start +# that are unimportant in an AGB wind + +@common:user_crflux +@var:ntot=sum(n(1:nmols)) +@var:R=Rgas_kJ + +@format:idx,R,R,P,P,rate +1,H,He+,He,H+,1.20e-15*(T32)**(0.25) + +@format:idx,R,R,P,P,rate +2,C,NO,CO,N,9.00e-11*(T32)**(-0.16) + +@format:idx,R,R,P,P,rate +3,NH+,E,N,H,4.30e-08*(T32)**(-0.50) + +@format:idx,R,R,P,rate +4,He+,E,He,5.36e-12*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +5,O2,S,SO,O,1.76e-12*(T32)**(0.81)*exp(+30.8*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +6,H,HS+,S+,H2,1.10e-10 + +@format:idx,R,R,P,P,rate +7,H+,Si,Si+,H,9.90e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +8,H+,OH,OH+,H,2.10e-09*(T32)**(-0.50) + +@storeonce_start +@format:idx,R,R,P,P,rate +9,N,HS,NS,H,1.00e-10 + +@format:idx,R,R,P,P,rate +10,He+,Si,Si+,He,3.30e-09 + +@format:idx,R,R,P,P,rate +11,H,HeH+,He,H2+,9.10e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +12,H2,HS,H2S,H,6.52e-12*(T32)**(0.09)*exp(-8050.0*invT) + +@storeonce_start +@format:idx,R,R,P,rate +13,O,E,O-,1.50e-15 + +@format:idx,R,R,P,P,rate +14,S+,Fe,Fe+,S,1.80e-10 +@storeonce_stop + +@format:idx,R,R,P,rate +15,H,Si+,SiH+,1.17e-17*(T32)**(-0.14) + +@format:idx,R,R,P,P,rate +16,H,NS,HS,N,7.27e-11*(T32)**(0.50)*exp(-15700.0*invT) + +@format:idx,R,R,P,P,rate +17,N,CS,S,CN,3.80e-11*(T32)**(0.50)*exp(-1160.0*invT) + +@format:idx,R,R,P,P,rate +18,H,S2,HS,S,2.25e-10*(T32)**(0.50)*exp(-8355.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +19,Na,S+,S,Na+,2.60e-10 + +@format:idx,R,R,P,P,rate +20,OH,F,HF,O,1.60e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +21,H,SO,S,OH,5.90e-10*(T32)**(-0.31)*exp(-11100.0*invT) + +@format:idx,R,R,P,P,rate +22,H-,Na+,H,Na,7.51e-08*(T32)**(-0.50) + +@storeonce_start +@format:idx,R,R,P,P,rate +23,CH,S,CS,H,5.00e-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +24,H-,Fe+,H,Fe,7.51e-08*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +25,HeH+,E,He,H,1.00e-08*(T32)**(-0.60) + +@format:idx,R,R,P,P,rate +26,H2,O2,OH,OH,3.16e-10*exp(-21890.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +27,OH,S,SO,H,6.60e-11 +@storeonce_stop + +@format:idx,R,R,P,P,P,rate +28,H,O2,O,O,H,6.00e-09*exp(-52300.0*invT) + +@format:idx,R,R,P,rate +29,H+,E,H,3.50e-12*(T32)**(-0.75) + +@format:idx,R,R,P,P,rate +30,H,NO,OH,N,3.60e-10*exp(-24910.0*invT) + +@format:idx,R,R,P,P,rate +31,O,SO2,SO,O2,9.01e-12*exp(-9837.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +32,H2+,He,HeH+,H,1.30e-10 +@storeonce_stop + +@format:idx,R,R,P,P,P,rate +33,H,H2,H,H,H,4.67e-07*(T32)**(-1.00)*exp(-55000.0*invT) + +@format:idx,R,R,P,P,rate +34,C,CS,S,C2,1.44e-11*(T32)**(0.50)*exp(-20435.0*invT) + +@format:idx,R,R,P,P,rate +35,N,NO,N2,O,3.38e-11*(T32)**(-0.17)*exp(+2.8*invT) + +@format:idx,R,R,P,P,rate +36,H,CO,OH,C,1.10e-10*(T32)**(0.50)*exp(-77700.0*invT) + +@format:idx,R,R,P,P,rate +37,H2,F,HF,H,1.00e-10*exp(-400.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +38,H,CH2,CH,H2,2.20e-10 +@storeonce_stop + +@format:idx,R,R,P,rate +39,O,O,O2,4.90e-20*(T32)**(1.58) + +@format:idx,R,R,P,P,rate +40,H,NH,N,H2,1.73e-11*(T32)**(0.50)*exp(-2400.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +41,NH,O,OH,N,1.16e-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +42,H2,CH,CH2,H,5.46e-10*exp(-1943.0*invT) + +@format:idx,R,R,P,P,rate +43,H,HCN,CN,H2,6.20e-10*exp(-12500.0*invT) + +@format:idx,R,R,P,P,rate +44,OH,CO,CO2,H,2.81e-13*exp(-176.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +45,NH,O,NO,H,6.60e-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +46,C,CO,C2,O,2.94e-11*(T32)**(0.50)*exp(-58025.0*invT) + +@format:idx,R,R,P,P,rate +47,C,CN,C2,N,4.98e-10*exp(-18116.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +48,N,NH,N2,H,4.98e-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +49,Si,O2,SiO,O,1.72e-10*(T32)**(-0.53)*exp(-17.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +50,H,O-,OH,E,5.00e-10 + +@format:idx,R,R,P,P,rate +51,OH,SiO,SiO2,H,2.00e-12 + +@format:idx,R,R,P,P,rate +52,C,HCO+,CO,CH+,1.10e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +53,H,NH2,NH,H2,4.56e-12*(T32)**(1.02)*exp(-2161.0*invT) + +@format:idx,R,R,P,P,rate +54,H2,C,CH,H,6.64e-10*exp(-11700.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +55,H2,O+,OH+,H,1.70e-09 + +@format:idx,R,R,P,P,rate +56,H,OCN,OH,CN,1.00e-10 +@storeonce_stop + +@format:idx,R,R,P,rate +57,H,E,H-,3.37e-16*(T32)**(0.64)*exp(-9.2*invT) + +@storeonce_stop +@format:idx,R,R,P,P,rate +58,H2+,O,OH+,H,1.50e-09 + +@format:idx,R,R,P,P,rate +59,Mg,S+,S,Mg+,2.80e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +60,N,O2,NO,O,2.26e-12*(T32)**(0.86)*exp(-3134.0*invT) + +@format:idx,R,R,P,rate +61,H+,H,H2+,1.15e-18*(T32)**(1.49)*exp(-228.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +62,H,HS,S,H2,2.50e-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +63,O-,Mg+,O,Mg,7.51e-08*(T32)**(-0.50) + +@format:idx,R,R,P,rate +64,Mg+,E,Mg,2.78e-12*(T32)**(-0.68) + +@format:idx,R,R,P,P,rate +65,H-,H+,H,H,7.51e-08*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +66,H-,S+,H,S,7.51e-08*(T32)**(-0.50) + +@format:idx,R,R,P,P,P,rate +67,H,OH,O,H,H,6.00e-09*exp(-50900.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +68,O+,Fe,Fe+,O,2.90e-09 + +@format:idx,R,R,P,P,rate +69,H-,N,NH,E,1.00e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +70,H,NO,O,NH,9.29e-10*(T32)**(-0.10)*exp(-35220.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +71,Si,HCO+,SiH+,CO,1.60e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +72,O,CN,NO,C,5.37e-11*exp(-13800.0*invT) + +@format:idx,R,R,P,P,rate +73,H-,O+,H,O,7.51e-08*(T32)**(-0.50) + +@format:idx,R,R,P,rate +74,O+,E,O,3.24e-12*(T32)**(-0.66) + +@storeonce_start +@format:idx,R,R,P,rate +75,H2,C,CH2,1.00e-17 + +@format:idx,R,R,P,P,rate +76,H,S-,HS,E,1.00e-10 + +@format:idx,R,R,P,P,rate +77,OH,CS,CO,HS,3.00e-11 + +@format:idx,R,R,P,P,rate +78,Na,Fe+,Fe,Na+,1.00e-11 + +@format:idx,R,R,P,P,rate +79,SiO+,Fe,Fe+,SiO,1.00e-09 + +@format:idx,R,R,P,P,rate +80,C,SO,CS,O,3.50e-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +81,OH,Si+,SiO+,H,6.30e-10*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +82,O,CS,SO,C,4.68e-11*(T32)**(0.50)*exp(-28940.0*invT) + +@format:idx,R,R,P,rate +83,H,O,OH,9.90e-19*(T32)**(-0.38) + +@storeonce_start +@format:idx,R,R,P,P,rate +84,H+,P,P+,H,1.00e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +85,CN,S,NS,C,5.71e-11*(T32)**(0.50)*exp(-32010.0*invT) + +@format:idx,R,R,P,P,rate +86,O,HS,S,OH,1.74e-11*(T32)**(0.67)*exp(-956.0*invT) + +@format:idx,R,R,P,P,rate +87,OH+,E,O,H,3.75e-08*(T32)**(-0.50) + +@storeonce_start +@format:idx,R,R,P,rate +88,H,C,CH,1.00e-17 +@storeonce_stop + +@format:idx,R,R,P,P,rate +89,Si,CO,SiO,C,1.30e-09*exp(-34513.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +90,C,HS,CS,H,1.00e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +91,H2,S,HS,H,1.76e-13*(T32)**(2.88)*exp(-6126.0*invT) + +@format:idx,R,R,P,P,rate +92,H,CH,C,H2,1.31e-10*exp(-80.0*invT) + +@format:idx,R,R,P,P,rate +93,H,O2,OH,O,2.61e-10*exp(-8156.0*invT) + +@format:idx,R,R,P,P,rate +94,N,SO,NS,O,4.68e-11*(T32)**(0.50)*exp(-8254.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +95,H,HCO,CO,H2,1.50e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +96,OH,CN,HCN,O,1.00e-11*exp(-1000.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +97,O,SiO+,O2,Si+,2.00e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +98,CH,O,OH,C,2.52e-11*exp(-2381.0*invT) + +@format:idx,R,R,P,P,rate +99,CH,S,HS,C,1.73e-11*(T32)**(0.50)*exp(-4000.0*invT) + +@format:idx,R,R,P,P,rate +100,HF,Si+,SiF+,H,5.70e-09*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +101,C,NO,CN,O,6.00e-11*(T32)**(-0.16) + +@format:idx,R,R,P,P,rate +102,H2+,E,H,H,1.60e-08*(T32)**(-0.43) + +@format:idx,R,R,P,P,P,rate +103,H,H2O,OH,H,H,5.80e-09*exp(-52900.0*invT) + +@format:idx,R,R,P,P,rate +104,H2,NH,NH2,H,5.96e-11*exp(-7782.0*invT) + +@format:idx,R,R,P,P,rate +105,C,NH,N,CH,1.73e-11*(T32)**(0.50)*exp(-4000.0*invT) + +@format:idx,R,R,P,P,rate +106,C,N2,CN,N,8.69e-11*exp(-22600.0*invT) + +@format:idx,R,R,P,P,P,rate +107,H2,E,H,H,E,3.22e-09*(T32)**(0.35)*exp(-102000.0*invT) + +@format:idx,R,R,P,P,P,rate +108,H,CH,C,H,H,6.00e-09*exp(-40200.0*invT) + +@format:idx,R,R,P,P,rate +109,SiF+,E,Si,F,2.00e-07*(T32)**(-0.50) + +@storeonce_start +@format:idx,R,R,P,P,rate +110,H,SiH+,Si+,H2,1.90e-09 + +@format:idx,R,R,P,P,rate +111,C+,Mg,Mg+,C,1.10e-09 +@storeonce_stop + +@format:idx,R,R,P,rate +112,C,O,CO,4.69e-19*(T32)**(1.52)*exp(+50.5*invT) + +@format:idx,R,R,P,P,rate +113,CN,O2,OCN,O,2.02e-11*(T32)**(-0.19)*exp(+31.9*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +114,NH,S,NS,H,1.00e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +115,SiO+,E,Si,O,2.00e-07*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +116,O,HCN,CO,NH,7.30e-13*(T32)**(1.14)*exp(-3742.0*invT) + +@format:idx,R,R,P,P,rate +117,H2,N,NH,H,1.69e-09*exp(-18095.0*invT) + +@format:idx,R,R,P,P,rate +118,O,HCN,CN,OH,6.21e-10*exp(-12439.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +119,Si,S+,S,Si+,1.60e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +120,O,OH,O2,H,3.69e-11*(T32)**(-0.27)*exp(-12.9*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +121,C+,Si,Si+,C,2.10e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +122,O,SO,S,O2,6.60e-13*exp(-2760.0*invT) + +@format:idx,R,R,P,P,rate +123,Si,NO,SiO,N,9.00e-11*(T32)**(-0.96)*exp(-28.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +124,C+,Fe,Fe+,C,2.60e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +125,S,SO2,SO,SO,9.76e-12*exp(-4545.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +126,Mg,SiO+,SiO,Mg+,1.00e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +127,O,HCN,OCN,H,1.36e-12*(T32)**(1.38)*exp(-3693.0*invT) + +@format:idx,R,R,P,P,rate +128,N,CN,N2,C,1.00e-10*(T32)**(0.18) + +@storeonce_start +@format:idx,R,R,P,P,rate +129,H-,C,CH,E,1.00e-09 + +@format:idx,R,R,P,P,rate +130,Mg,Si+,Si,Mg+,2.90e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +131,CH,N,NH,C,3.03e-11*(T32)**(0.65)*exp(-1207.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +132,Na,Si+,Si,Na+,2.70e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +133,C-,H+,C,H,7.51e-08*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +134,Si,CO2,SiO,CO,2.72e-11*exp(-282.0*invT) + +@format:idx,R,R,P,P,rate +135,H,OCS,HS,CO,1.23e-11*exp(-1949.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +136,Si+,Fe,Fe+,Si,1.90e-09 + +@format:idx,R,R,P,rate +137,S,E,S-,5.00e-15 + +@format:idx,R,R,P,P,rate +138,HCO+,Fe,Fe+,HCO,1.90e-09 +@storeonce_stop + +@format:idx,R,R,P,rate +139,P+,E,P,3.41e-12*(T32)**(-0.65) + +@format:idx,R,R,P,P,rate +140,H+,SiO,SiO+,H,3.30e-09*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +141,O,HS,SO,H,1.74e-10*(T32)**(-0.20)*exp(-5.7*invT) + +@format:idx,R,R,P,rate +142,Fe+,E,Fe,2.55e-12*(T32)**(-0.69) + +@storeonce_start +@format:idx,R,R,P,P,rate +143,Si,P+,P,Si+,1.00e-09 + +@format:idx,R,R,P,P,rate +144,H+,Mg,Mg+,H,1.10e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +145,H-,Si+,H,Si,7.51e-08*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +146,H,H2O,OH,H2,1.59e-11*(T32)**(1.20)*exp(-9610.0*invT) + +@format:idx,R,R,P,P,rate +147,OH,OH,H2O,O,1.65e-12*(T32)**(1.14)*exp(-50.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +148,OH,SO,SO2,H,8.60e-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +149,H2,OH,H2O,H,2.05e-12*(T32)**(1.52)*exp(-1736.0*invT) + +@format:idx,R,R,P,P,rate +150,H,OCN,HCN,O,1.87e-11*(T32)**(0.90)*exp(-2924.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +151,N,C2,CN,C,5.00e-11 + +@format:idx,R,R,P,P,rate +152,C,CH,C2,H,6.59e-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +153,H,C2,CH,C,4.67e-10*(T32)**(0.50)*exp(-30450.0*invT) + +@format:idx,R,R,P,P,rate +154,H,OCN,NH,CO,1.26e-10*exp(-515.0*invT) + +@format:idx,R,R,P,P,rate +155,N,OH,O,NH,1.88e-11*(T32)**(0.10)*exp(-10700.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +156,N,SiO+,NO,Si+,2.10e-10 + +@format:idx,R,R,P,rate +157,C,E,C-,2.25e-15 +@storeonce_stop + +@format:idx,R,R,P,P,rate +158,NH,S,HS,N,1.73e-11*(T32)**(0.50)*exp(-4000.0*invT) + +@format:idx,R,R,P,P,rate +159,H2,O,OH,H,3.14e-13*(T32)**(2.70)*exp(-3150.0*invT) + +@format:idx,R,R,P,P,rate +160,O,CS,S,CO,2.48e-10*(T32)**(-0.65)*exp(-783.0*invT) + +@format:idx,R,R,P,P,rate +161,OH,H2S,HS,H2O,6.30e-12*exp(-80.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +162,C,NH,CN,H,1.20e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +163,H,H2S,HS,H2,3.71e-12*(T32)**(1.94)*exp(-455.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +164,Mg,HCO+,HCO,Mg+,2.90e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +165,CH,N,CN,H,1.66e-10*(T32)**(-0.09) + +@format:idx,R,R,P,rate +166,C,C,C2,4.36e-18*(T32)**(0.35)*exp(-161.3*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +167,H+,S,S+,H,1.30e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +168,O,C2,CO,C,2.00e-10*(T32)**(-0.12) + +@format:idx,R,R,P,P,rate +169,C,OH,O,CH,2.25e-11*(T32)**(0.50)*exp(-14800.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +170,H,C-,CH,E,5.00e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +171,C,HS,S,CH,1.20e-11*(T32)**(0.58)*exp(-5880.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +172,H+,Fe,Fe+,H,7.40e-09 +@storeonce_stop + +@format:idx,R,R,P,rate +173,C,N,CN,5.72e-19*(T32)**(0.37)*exp(-51.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +174,OH,CS,H,OCS,1.70e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +175,N,CO2,NO,CO,3.20e-13*exp(-1710.0*invT) + +@format:idx,R,R,P,P,rate +176,H,CO2,CO,OH,3.38e-10*exp(-13163.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +177,C2,S,CS,C,1.00e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +178,H2,S+,HS+,H,1.10e-10*exp(-9860.0*invT) + +@format:idx,R,R,P,P,rate +179,N,HS,S,NH,1.73e-11*(T32)**(0.50)*exp(-9060.0*invT) + +@format:idx,R,R,P,P,rate +180,O,N2,NO,N,2.51e-10*exp(-38602.0*invT) + +@format:idx,R,R,P,P,rate +181,CH,O,CO,H,6.02e-11*(T32)**(0.10)*exp(+4.5*invT) + +@format:idx,R,R,P,P,rate +182,H,O+,O,H+,5.66e-10*(T32)**(0.36)*exp(+8.6*invT) + +@format:idx,R,R,P,P,rate +183,N,OH,NO,H,6.05e-11*(T32)**(-0.23)*exp(-14.9*invT) + +@format:idx,R,R,P,P,rate +184,H+,O,O+,H,6.86e-10*(T32)**(0.26)*exp(-224.3*invT) + +@format:idx,R,R,P,P,rate +185,H,SO,HS,O,1.73e-11*(T32)**(0.50)*exp(-19930.0*invT) + +@format:idx,R,R,P,rate +186,O,Si,SiO,5.52e-18*(T32)**(0.31) + +@format:idx,R,R,P,rate +187,S+,E,S,5.49e-12*(T32)**(-0.59) + +@storeonce_start +@format:idx,R,R,P,P,rate +188,HS,HS,H2S,S,1.30e-11 + +@format:idx,R,R,P,P,rate +189,C,SO2,CO,SO,7.00e-11 +@storeonce_stop + +@format:idx,R,R,P,rate +190,Na+,E,Na,2.76e-12*(T32)**(-0.68) + +@storeonce_start +@format:idx,R,R,P,P,rate +191,S,HS,S2,H,4.50e-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +192,H-,H,H2,E,4.82e-09*(T32)**(0.02)*exp(-4.3*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +193,C,SO,S,CO,3.50e-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +194,H,CH+,C+,H2,9.06e-10*(T32)**(-0.37)*exp(-29.1*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +195,Na,Mg+,Mg,Na+,1.00e-11 + +@format:idx,R,R,P,P,rate +196,H,H2+,H2,H+,6.40e-10 +@storeonce_stop + +@format:idx,R,R,P,rate +197,Si+,E,Si,4.26e-12*(T32)**(-0.62) + +@format:idx,R,R,P,P,rate +198,C,NS,S,CN,1.50e-10*(T32)**(-0.16) + +@format:idx,R,R,P,P,rate +199,O-,H+,O,H,7.51e-08*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +200,CH,O,HCO+,E,1.09e-11*(T32)**(-2.19)*exp(-165.1*invT) + +@format:idx,R,R,P,P,rate +201,SiH+,E,Si,H,2.00e-07*(T32)**(-0.50) + +@storeonce_start +@format:idx,R,R,P,P,rate +202,C,SiO+,Si+,CO,1.00e-09 + +@format:idx,R,R,P,P,rate +203,H-,O,OH,E,1.00e-09 + +@format:idx,R,R,P,P,rate +204,C,OH,CO,H,1.00e-10 + +@format:idx,R,R,P,P,rate +205,OH,Si,SiO,H,1.00e-10 + +@format:idx,R,R,P,P,rate +206,H2+,C,CH+,H,2.40e-09 +@storeonce_stop + +@format:idx,R,R,P,rate +207,C,S,CS,4.36e-19*(T32)**(0.22) + +@format:idx,R,R,P,P,rate +208,H,OH,O,H2,6.99e-14*(T32)**(2.80)*exp(-1950.0*invT) + +@format:idx,R,R,P,P,rate +209,CH+,E,C,H,1.50e-07*(T32)**(-0.42) + +@format:idx,R,R,P,P,rate +210,O-,Fe+,O,Fe,7.51e-08*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +211,N,SO,S,NO,1.73e-11*(T32)**(0.50)*exp(-750.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +212,O,NS,S,NO,1.00e-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +213,O,H2O,OH,OH,1.85e-11*(T32)**(0.95)*exp(-8571.0*invT) + +@format:idx,R,R,P,P,rate +214,H-,Mg+,H,Mg,7.51e-08*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +215,H2,CN,HCN,H,4.04e-13*(T32)**(2.87)*exp(-820.0*invT) + +@format:idx,R,R,P,P,rate +216,C,O2,CO,O,5.56e-11*(T32)**(0.41)*exp(+26.9*invT) + +@format:idx,R,R,P,P,rate +217,H,NS,S,NH,7.27e-11*(T32)**(0.50)*exp(-20735.0*invT) + +@storeonce_start +@format:idx,R,R,P,P,rate +218,O,CN,CO,N,2.54e-11 + +@format:idx,R,R,P,P,rate +219,OH,CN,OCN,H,7.00e-11 +@storeonce_stop + +################################## +# Added from primordial3 +# commented ones are already in the UMIST database +@format:idx,R,R,R,P,P,P,P,Tmin,Tmax,rate +#Janev 1987 +220,H,E,,H+,E,E,,NONE,NONE,exp(-32.71396786d0+13.5365560d0*lnTe-5.73932875d0*(lnTe**2)+1.56315498d0*(lnTe**3)-0.28770560d0*(lnTe**4)+3.48255977d-2*(lnTe**5)-2.63197617d-3*(lnTe**6)+1.11954395d-4*(lnTe**7)-2.03914985d-6*(lnTe**8)) + +#Janev 1987 +221,HE,E,,HE+,E,E,,NONE,NONE,exp(-44.09864886d0+23.91596563d0*lnTe-10.7532302d0*(lnTe**2)+3.05803875d0*(lnTe**3)-0.56851189d0*(lnTe**4)+6.79539123d-2*(lnTe**5)-5.00905610d-3*(lnTe**6)+2.06723616d-4*(lnTe**7)-3.64916141d-6*(lnTe**8)) + +# fit by Savin et al. 2004, see also Glover et al. 2010 !NEW! +@var:asav = 2.1237150d4 +@var:bsav1=-3.3232183d-7 +@var:bsav2= 3.3735382d-7 +@var:bsav3=-1.4491368d-7 +@var:bsav4= 3.4172805d-8 +@var:bsav5=-4.7813728d-9 +@var:bsav6= 3.9731542d-10 +@var:bsav7=-1.8171411d-11 +@var:bsav8= 3.5311932d-13 +@var:sumsav=bsav1+bsav2*log(Tgas)+bsav3*(log(Tgas))**2+bsav4*(log(Tgas))**3+bsav5*(log(Tgas))**4+bsav6*(log(Tgas))**5+bsav7*(log(Tgas))**6+bsav8*(log(Tgas))**7 +222,H2,H+,,H2+,H,,,.GE.1.d2,.LE.3.d4,sumsav*exp(-asav*invT) + +# Capitelli et al. 2007 ! NEW REACTION! +223,H2,E,,H,H-,,,NONE,NONE,3.55d1*Tgas**(-2.28)*exp(-46707./Tgas) + +#Janev 1987 +224,H-,E,,H,E,E,,NONE,NONE,exp(-18.01849334273d0+2.360852208681d0*lnTe-0.2827443061704d0*lnTe**2+0.01623316639567d0*lnTe**3-0.03365012031362999d0*lnTe**4+0.01178329782711d0*lnTe**5-0.001656194699504d0*lnTe**6+0.0001068275202678d0*lnTe**7-2.631285809207d-6*lnTe**8) + +#Abel et al. 1997, based on Janev 1987 +225,H-,H,,H,H,E,,>1.16e3,NONE,exp(-20.37260896533324d0+1.139449335841631d0*lnTe-0.1421013521554148d0*lnTe**2+0.00846445538663d0*lnTe**3-0.0014327641212992d0*lnTe**4+0.0002012250284791d0*lnTe**5+0.0000866396324309d0*lnTe**6-0.00002585009680264d0*lnTe**7+2.4555011970392d-6*lnTe**8-8.06838246118d-8*lnTe**9) + +#Poulart 1978 +226,H-,H+,,H2+,E,,,NONE,NONE,1.d-8*Tgas**(-0.4d0) + +#Forrey 2013 !NEW! +227,H,H,H,H2,H,,,NONE,NONE,6.d-32*Tgas**(-0.25d0)+2.d-31*Tgas**(-0.5d0) + +#Glover&Abel 2008 +228,H2,H,H,H2,H2,,,NONE,NONE,(6.d-32*Tgas**(-0.25d0)+2.d-31*Tgas**(-0.5d0))/8.d0 + +#Glover&Abel 2008 +229,H,H,HE,H2,HE,,,NONE,NONE,6.9d-32*Tgas**(-0.4d0) + +#KIDA +#NA+ production +@storeonce_start +230,H+,NA,,NA+,H,,,1.d1,1d4,1.20e-09 +@storeonce_stop + +##################################### +#cosmic ray reaction from UMIST +#scaled with user_crflux = 1.36e-17 +@CR_start +@format:idx,R,P,P,rate +231,H2,H+,H-,0.000286764705882*user_crflux + +@format:idx,R,P,P,Tmin,Tmax,rate +232,C,C+,E,10,41000,1.69117647059*user_crflux + +@format:idx,R,P,P,Tmin,Tmax,rate +233,H,H+,E,10,41000,0.439705882353*user_crflux + +@format:idx,R,P,P,Tmin,Tmax,rate +234,N,N+,E,10,41000,1.98529411765*user_crflux + +@format:idx,R,P,P,rate +235,CO,CO+,E,2.86764705882*user_crflux + +@format:idx,R,P,P,P,rate +236,H2,H+,H,E,0.0210294117647*user_crflux + +@format:idx,R,P,P,rate +237,H2,H,H,0.0955882352941*user_crflux + +@format:idx,R,P,P,Tmin,Tmax,rate +238,He,He+,E,10,41000,0.477941176471*user_crflux + +@format:idx,R,P,P,Tmin,Tmax,rate +239,O,O+,E,10,41000,2.5*user_crflux + +@format:idx,R,P,P,rate +240,H2,H2+,E,0.882352941176*user_crflux + +##################################### +#extra cosmic ray reaction from KIDA +@format:idx,R,P,P,rate +241,N2,N,N,5.000e+00*user_crflux + +@format:idx,R,P,P,rate +242,CO,C,O,5.000e+00*user_crflux +@CR_stop + +##################################### +#added to get recCheck OK/no sinks +@format:idx,R,R,P,rate +243,C+,E,C,2.36e-12*(T32)**(-0.29)*exp(+17.6*invT) + +@format:idx,R,R,P,rate +244,N+,E,N,3.50e-12*(T32)**(-0.53)*exp(+3.2*invT) + +@format:idx,R,R,P,P,rate +245,CO+,E,O,C,2.00e-07*(T32)**(-0.48) + +@storeonce_start +@format:idx,R,R,P,P,P,rate +246,He+,SiO2,O2,Si+,He,2.00e-09 +@storeonce_stop + +@format:idx,R,R,P,P,rate +247,H+,NH,NH+,H,2.10e-09*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +248,HS+,E,S,H,2.00e-07*(T32)**(-0.50) + +@format:idx,R,R,P,P,rate +249,HCO+,E,CO,H,2.40e-07*(T32)**(-0.69) + +@format:idx,R,R,P,P,P,rate +250,He+,HF,F+,H,He,1.10e-08*(T32)**(-0.50) + +@storeonce_start +@format:idx,R,R,P,P,rate +251,H2,F+,H2+,F,6.24e-10 +@storeonce_stop + +@format:idx,R,R,P,rate +252,F+,E,F,auto + +################################## +#Add to get PN and PO like the full network +#From react_cloud (E.Herbst) aka KIDA +#get PN +@storeonce_start +@format:idx,R,R,P,P,rate +253,N,PN,P,N2,1.00e-18 +@storeonce_stop + +@format:idx,R,R,P,P,rate +254,N,PO,PN,O,3.00e-11*(T32)**(-0.60) + +#get PO +@storeonce_start +@format:idx,R,R,P,P,rate +255,P,O2,PO,O,1.00e-13 + +@format:idx,R,R,P,P,rate +256,N,PO,P,NO,2.55e-12 +@storeonce_stop + +# # SiO nucleation reactions +# # Cluster growth reactions +# # cluster_growth_rate(index_of_monomer, cluster_size, temperature, sticking_coefficient) +@format:idx,R,R,P,rate +257,SiO,SiO,Si2O2,cluster_growth_rate(idx_SiO, 1, Tgas) + +@format:idx,R,R,P,rate +258,Si2O2,SiO,Si3O3,cluster_growth_rate(idx_SiO, 2, Tgas) + +@format:idx,R,R,P,rate +259,Si3O3,SiO,Si4O4,cluster_growth_rate(idx_SiO, 3, Tgas) + +@format:idx,R,R,P,rate +260,Si4O4,SiO,Si5O5,cluster_growth_rate(idx_SiO, 4, Tgas) + +@format:idx,R,R,P,rate +261,Si5O5,SiO,Si6O6,cluster_growth_rate(idx_SiO, 5, Tgas) + +@format:idx,R,R,P,rate +262,Si6O6,SiO,Si7O7,cluster_growth_rate(idx_SiO, 6, Tgas) + +@format:idx,R,R,P,rate +263,Si7O7,SiO,Si8O8,cluster_growth_rate(idx_SiO, 7, Tgas) + +@format:idx,R,R,P,rate +264,Si8O8,SiO,Si9O9,cluster_growth_rate(idx_SiO, 8, Tgas) + + +# Cluster destruction reactions +# Based on detailed balance +@format:idx,R,P,P,rate +265,Si2O2,SiO,SiO,cluster_growth_rate(idx_SiO, 1, Tgas) * revKc_with_GFE(Tgas, [idx_Si2O2], [idx_SiO,idx_SiO]) + +@format:idx,R,P,P,rate +266,Si3O3,Si2O2,SiO,cluster_growth_rate(idx_SiO, 2, Tgas) * revKc_with_GFE(Tgas, [idx_Si3O3], [idx_Si2O2,idx_SiO]) + +@format:idx,R,P,P,rate +267,Si4O4,Si3O3,SiO,cluster_growth_rate(idx_SiO, 3, Tgas) * revKc_with_GFE(Tgas, [idx_Si4O4], [idx_Si3O3,idx_SiO]) + +@format:idx,R,P,P,rate +268,Si5O5,Si4O4,SiO,cluster_growth_rate(idx_SiO, 4, Tgas) * revKc_with_GFE(Tgas, [idx_Si5O5], [idx_Si4O4,idx_SiO]) + +@format:idx,R,P,P,rate +269,Si6O6,Si5O5,SiO,cluster_growth_rate(idx_SiO, 5, Tgas) * revKc_with_GFE(Tgas, [idx_Si6O6], [idx_Si5O5,idx_SiO]) + +@format:idx,R,P,P,rate +270,Si7O7,Si6O6,SiO,cluster_growth_rate(idx_SiO, 6, Tgas) * revKc_with_GFE(Tgas, [idx_Si7O7], [idx_Si6O6,idx_SiO]) + +@format:idx,R,P,P,rate +271,Si8O8,Si7O7,SiO,cluster_growth_rate(idx_SiO, 7, Tgas) * revKc_with_GFE(Tgas, [idx_Si8O8], [idx_Si7O7,idx_SiO]) + +@format:idx,R,P,P,rate +272,Si9O9,Si8O8,SiO,cluster_growth_rate(idx_SiO, 8, Tgas) * revKc_with_GFE(Tgas, [idx_Si9O9], [idx_Si8O8,idx_SiO]) + + +# Cluster growth reactions +# cluster_growth_rate(index_of_monomer, cluster_size, temperature, sticking_coefficient) +@format:idx,R,R,P,rate +273,TiO2,TiO2,Ti2O4,cluster_growth_rate(idx_TiO2, 1, Tgas) + +@format:idx,R,R,P,rate +274,Ti2O4,TiO2,Ti3O6,cluster_growth_rate(idx_TiO2, 2, Tgas) + +@format:idx,R,R,P,rate +275,Ti3O6,TiO2,Ti4O8,cluster_growth_rate(idx_TiO2, 3, Tgas) + +@format:idx,R,R,P,rate +276,Ti4O8,TiO2,Ti5O10,cluster_growth_rate(idx_TiO2, 4, Tgas) + +@format:idx,R,R,P,rate +277,Ti5O10,TiO2,Ti6O12,cluster_growth_rate(idx_TiO2, 5, Tgas) + +@format:idx,R,R,P,rate +278,Ti6O12,TiO2,Ti7O14,cluster_growth_rate(idx_TiO2, 6, Tgas) + +@format:idx,R,R,P,rate +279,Ti7O14,TiO2,Ti8O16,cluster_growth_rate(idx_TiO2, 7, Tgas) + +@format:idx,R,R,P,rate +280,Ti8O16,TiO2,Ti9O18,cluster_growth_rate(idx_TiO2, 8, Tgas) + +@format:idx,R,R,P,rate +281,Ti9O18,TiO2,Ti10O20,cluster_growth_rate(idx_TiO2, 9, Tgas) + +# Cluster destruction reactions +# Based on detailed balance +@format:idx,R,P,P,rate +282,Ti2O4,TiO2,TiO2,cluster_growth_rate(idx_TiO2, 1, Tgas) * revKc_with_GFE(Tgas, [idx_Ti2O4], [idx_TiO2,idx_TiO2]) + +@format:idx,R,P,P,rate +283,Ti3O6,Ti2O4,TiO2,cluster_growth_rate(idx_TiO2, 2, Tgas) * revKc_with_GFE(Tgas, [idx_Ti3O6], [idx_Ti2O4,idx_TiO2]) + +@format:idx,R,P,P,rate +284,Ti4O8,Ti3O6,TiO2,cluster_growth_rate(idx_TiO2, 3, Tgas) * revKc_with_GFE(Tgas, [idx_Ti4O8], [idx_Ti3O6,idx_TiO2]) + +@format:idx,R,P,P,rate +285,Ti5O10,Ti4O8,TiO2,cluster_growth_rate(idx_TiO2, 4, Tgas) * revKc_with_GFE(Tgas, [idx_Ti5O10], [idx_Ti4O8,idx_TiO2]) + +@format:idx,R,P,P,rate +286,Ti6O12,Ti5O10,TiO2,cluster_growth_rate(idx_TiO2, 5, Tgas) * revKc_with_GFE(Tgas, [idx_Ti6O12], [idx_Ti5O10,idx_TiO2]) + +@format:idx,R,P,P,rate +287,Ti7O14,Ti6O12,TiO2,cluster_growth_rate(idx_TiO2, 6, Tgas) * revKc_with_GFE(Tgas, [idx_Ti7O14], [idx_Ti6O12,idx_TiO2]) + +@format:idx,R,P,P,rate +288,Ti8O16,Ti7O14,TiO2,cluster_growth_rate(idx_TiO2, 7, Tgas) * revKc_with_GFE(Tgas, [idx_Ti8O16], [idx_Ti7O14,idx_TiO2]) + +@format:idx,R,P,P,rate +289,Ti9O18,Ti8O16,TiO2,cluster_growth_rate(idx_TiO2, 8, Tgas) * revKc_with_GFE(Tgas, [idx_Ti9O18], [idx_Ti8O16,idx_TiO2]) + +@format:idx,R,P,P,rate +290,Ti10O20,Ti9O18,TiO2,cluster_growth_rate(idx_TiO2, 9, Tgas) * revKc_with_GFE(Tgas, [idx_Ti10O20], [idx_Ti9O18,idx_TiO2]) + +# TIO reactions +# Campbell and McClean 1993 DOI: 10.1021/j100132a024 +# Note: +# Only the reactions of Ti with NO and CO2 were found to depend on the argon buffer gas pressure. +# Termolecular rate constants at 300 K were determined to be 5.8e-31 cm^6 s-1 +# and 3.5e-32 cm^6 s-1 for NO and CO2,respectively. +@format:idx,R,R,P,P,Tmin,Tmax,rate +291,Ti,O2,TiO,O,300,600,1.69d-10*exp(-11.6/(R * Tgas)) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +292,Ti,N2O,TiO,N2,300,600,1.74d-10*exp(-14.3/(R * Tgas)) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +293,Ti,NO,TiO,N,300,600,3.28d-11*exp(-3.62/(R * Tgas)) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +294,Ti,CO2,TiO,CO,300,600,7.d-11*exp(-14.9/(R * Tgas)) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +295,Ti,SO2,TiO,SO,300,600,1.7d-10*exp(-2.66/(R * Tgas)) + +@storeonce_start +@format:idx,R,R,P,P,Tmin,Tmax,rate +296,Ti,NO2,TiO,NO,300,500,9d-11 +@storeonce_stop + +#reverse +@format:idx,R,R,P,P,Tmin,Tmax,rate +297,TiO,O,Ti,O2,300,600,1.69d-10*exp(-11.6/(R * Tgas))*revKc_with_GFE(Tgas,[idx_TiO,idx_O],[idx_Ti,idx_O2]) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +298,TiO,N2,Ti,N2O,300,600,1.74d-10*exp(-14.3/(R * Tgas))*revKc_with_GFE(Tgas,[idx_TiO,idx_N2],[idx_Ti,idx_N2O]) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +299,TiO,N,Ti,NO,300,600,3.28d-11*exp(-3.62/(R * Tgas))*revKc_with_GFE(Tgas,[idx_TiO,idx_N],[idx_Ti,idx_NO]) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +300,TiO,CO,Ti,CO2,300,600,7.d-11*exp(-14.9/(R * Tgas))*revKc_with_GFE(Tgas,[idx_TiO,idx_CO],[idx_Ti,idx_CO2]) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +301,TiO,SO,Ti,SO2,300,600,1.7d-10*exp(-2.66/(R * Tgas))*revKc_with_GFE(Tgas,[idx_TiO,idx_SO],[idx_Ti,idx_SO2]) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +302,TiO,NO,Ti,NO2,300,500,9d-11*revKc_with_GFE(Tgas,[idx_TiO,idx_NO],[idx_Ti,idx_NO2]) + +# Higuchi+2008 DOI: 10.1016/j.cplett.2007.12.067 +@storeonce_start +@format:idx,R,R,P,P,Tmin,Tmax,rate +303,TiO,O2,TiO2,O,300,300,7.07d-12 +@storeonce_stop +# Note: products are unsure... + +#reverse +@format:idx,R,R,P,P,Tmin,Tmax,rate +304,TiO2,O,TiO,O2,300,300,7.07d-12*revKc_with_GFE(Tgas,[idx_TiO2,idx_O],[idx_TiO,idx_O2]) + +#Ritter and Weisshaar 1989 DOI: 10.1021/j100341a076 +@storeonce_start +@format:idx,R,R,P,P,Tmin,Tmax,rate +305,TiO,NO,TiO2,N,300,300,2.2d-12 +@storeonce_stop +# Note: products are unsure... + +#reverse +@format:idx,R,R,P,P,Tmin,Tmax,rate +306,TiO2,N,TiO,NO,300,300,2.2d-12*revKc_with_GFE(Tgas,[idx_TiO2,idx_N],[idx_TiO,idx_NO]) + +# Plane 2013 DOI: 10.1098/rsta.2012.0335 +@format:idx,R,R,P,P,rate +307,TiO,OH,TiO2,H,1.4e-11*(1000./Tgas)**0.39 + +@format:idx,R,R,P,P,rate +308,TiO2,H,TiO,OH,5.0e-10*exp(-15570/Tgas) + +# Cluster growth reactions +# cluster_growth_rate(index_of_monomer, cluster_size, temperature, sticking_coefficient) +@format:idx,R,R,P,rate +309,Al2O3,Al2O3,Al4O6,cluster_growth_rate(idx_Al2O3, 1, Tgas) + +@format:idx,R,R,P,rate +310,Al4O6,Al2O3,Al6O9,cluster_growth_rate(idx_Al2O3, 2, Tgas) + +@format:idx,R,R,P,rate +311,Al6O9,Al2O3,Al8O12,cluster_growth_rate(idx_Al2O3, 3, Tgas) + +@format:idx,R,R,P,rate +312,Al8O12,Al2O3,Al10O15,cluster_growth_rate(idx_Al2O3, 4, Tgas) + +@format:idx,R,R,P,rate +313,Al10O15,Al2O3,Al12O18,cluster_growth_rate(idx_Al2O3, 5, Tgas) + +@format:idx,R,R,P,rate +314,Al12O18,Al2O3,Al14O21,cluster_growth_rate(idx_Al2O3, 6, Tgas) + +# Cluster destruction reactions +# Based on detailed balance +@format:idx,R,P,P,rate +315,Al4O6,Al2O3,Al2O3,cluster_growth_rate(idx_Al2O3, 1, Tgas) * revKc_with_GFE(Tgas, [idx_Al4O6], [idx_Al2O3,idx_Al2O3]) + +@format:idx,R,P,P,rate +316,Al6O9,Al4O6,Al2O3,cluster_growth_rate(idx_Al2O3, 2, Tgas) * revKc_with_GFE(Tgas, [idx_Al6O9], [idx_Al4O6,idx_Al2O3]) + +@format:idx,R,P,P,rate +317,Al8O12,Al6O9,Al2O3,cluster_growth_rate(idx_Al2O3, 3, Tgas) * revKc_with_GFE(Tgas, [idx_Al8O12], [idx_Al6O9,idx_Al2O3]) + +@format:idx,R,P,P,rate +318,Al10O15,Al8O12,Al2O3,cluster_growth_rate(idx_Al2O3, 4, Tgas) * revKc_with_GFE(Tgas, [idx_Al10O15], [idx_Al8O12,idx_Al2O3]) + +@format:idx,R,P,P,rate +319,Al12O18,Al10O15,Al2O3,cluster_growth_rate(idx_Al2O3, 5, Tgas) * revKc_with_GFE(Tgas, [idx_Al12O18], [idx_Al10O15,idx_Al2O3]) + +@format:idx,R,P,P,rate +320,Al14O21,Al12O18,Al2O3,cluster_growth_rate(idx_Al2O3, 6, Tgas) * revKc_with_GFE(Tgas, [idx_Al14O21], [idx_Al12O18,idx_Al2O3]) + +# # Al reactions +# ########################## +# ########################## +# data/database/ALchemistry.dat +# Starik+2014, Combustion and Flame 161, 1659 +# and references therein +@format:idx,R,R,P,P,rate +321,Al,O2,AlO,O,3.836d-11*Tgas**(.17) + +@format:idx,R,R,P,P,rate +322,AlO,O2,AlO2,O,1.182d-11*Tgas**(.5)*exp(-1.315d4*invT) + +# manually added ntot term bacause this is a high density regime +# and a collision partner can aid in crossing this high barrier +@format:idx,R,P,P,rate +323,AlO2,AlO,O,1.661d-9*exp(-44564.6*invT) * ntot + +# manually added ntot term bacause this is a high density regime +# and a collision partner can aid in crossing this high barrier +@format:idx,R,P,P,rate +324,Al2O,AlO,Al,1.661d-9*exp(-67035.7*invT) * ntot + +# manually added ntot term bacause this is a high density regime +# and a collision partner can aid in crossing this high barrier +@format:idx,R,P,P,rate +325,Al2O2,AlO,AlO,1.661d-9*exp(-59335.7*invT) * ntot + +# manually added ntot term bacause this is a high density regime +# and a collision partner can aid in crossing this high barrier +@format:idx,R,P,P,rate +326,Al2O2,Al,AlO2,1.661d-9*exp(-74937.1*invT) * ntot + +# manually added ntot term bacause this is a high density regime +# and a collision partner can aid in crossing this high barrier +@format:idx,R,P,P,rate +327,Al2O2,Al2O,O,1.661d-9*exp(-52466.*invT) * ntot + +# manually added ntot term bacause this is a high density regime +# and a collision partner can aid in crossing this high barrier +@format:idx,R,P,P,rate +328,Al2O3,Al2O2,O,4.982d-9*exp(-49144.4*invT) * ntot + +# manually added ntot term bacause this is a high density regime +# and a collision partner can aid in crossing this high barrier +@format:idx,R,P,P,rate +329,Al2O3,AlO2,AlO,4.982d-9*exp(-63915.4*invT) * ntot + +@format:idx,R,R,P,P,rate +330,Al,H2O,AlOH,H,3.255d-10*Tgas**(-0.09)*exp(-3744.*invT) + 4.616d-18*Tgas**(2.06)*exp(-438.*invT) + +@format:idx,R,R,P,P,rate +331,AlOH,H,AlO,H2,4.417d-16*Tgas**(.82)*exp(-7844.*invT) + +@format:idx,R,R,P,P,rate +332,AlOH,O,AlO,OH,1.251d-11*Tgas**(.5)*exp(-4450.*invT) + +@format:idx,R,R,P,P,rate +333,AlO,AlH,AlOH,Al,4.218d-11*Tgas**(.17) + +@format:idx,R,R,P,P,rate +334,AlO2,H2O,AlO2H,OH,4.367d-22*Tgas**(3.26)*exp(-3430.*invT) + +@format:idx,R,R,P,P,rate +335,AlO2,H2,AlO2H,H,7.672d-14*Tgas**(1.39)*exp(-2940.*invT) + +@format:idx,R,R,P,P,rate +336,AlO2,OH,AlO2H,O,4.268d-11*Tgas**(.17) + +@format:idx,R,R,P,P,rate +337,AlO2H,O,AlOH,O2,3.554d-11*Tgas**(.17) + +# high density limit +@format:idx,R,R,P,rate +338,AlO2H,H,AlO2H2,1.227d-10*Tgas**(.17) + +# high density limit +@format:idx,R,R,P,rate +339,AlOH,OH,AlO2H2,4.118d-11*Tgas**(.16)*exp(23.*invT) + +# high density limit +@format:idx,R,R,P,rate +340,AlO2H2,OH,AlO3H3,4.218d-11*Tgas**(.15)*exp(48.*invT) + +# 3 body reactions +@format:idx,R,R,R,P,P,rate +341,Al,O,H2O,AlO,H2O,2.317d-31/Tgas + +@format:idx,R,R,R,P,P,rate +342,Al,O,O2,AlO,O2,9.101d-31/Tgas + +@format:idx,R,R,R,P,P,rate +343,Al,O,H2,AlO,H2,9.101d-31/Tgas + +@format:idx,R,R,R,P,P,rate +344,Al,H2O,H2O,AlO2H2,H2,3.198e-33*Tgas**(.5) + +@format:idx,R,R,R,P,P,P,rate +345,Al,H2O,H2O,AlOH,H,H2O,3.198e-33*Tgas**(.5)*exp(-1260.*invT) + +@noTabNext +@format:idx,R,R,P,rate +346,AlO,H,AlOH,5.489d-33*Tgas**(.5)*ntot + +@noTabNext +@format:idx,R,R,P,rate +347,Al,OH,AlOH,5.957d-33*Tgas**(.5)*ntot + +@noTabNext +@format:idx,R,R,P,rate +348,AlO,OH,AlO2H,7.226e-33*Tgas**(.5)*ntot + +@noTabNext +@format:idx,R,R,P,rate +349,AlO2,H,AlO2H,6.04d-33*Tgas**(.5)*ntot + +@noTabNext +@format:idx,R,R,P,rate +350,AlOH,O,AlO2H,8.107d-33*Tgas**(.5)*ntot + +@noTabNext +@format:idx,R,R,P,rate +351,Al,H,AlH,2.600d-33*Tgas**(.5)*ntot + + +# #reversed reactions +@format:idx,R,R,P,P,rate +352,AlO,O,Al,O2,3.836d-11*Tgas**(.17) * revKc_with_GFE(Tgas, [idx_AlO,idx_O], [idx_Al,idx_O2]) + +@format:idx,R,R,P,P,rate +353,AlO2,O,AlO,O2,1.182d-11*Tgas**(.5)*exp(-1.315d4*invT) * revKc_with_GFE(Tgas, [idx_AlO2,idx_O], [idx_AlO,idx_O2]) + +# manually added third body (ntot) term bacause this is a high density regime +# and this is not an association reaction +# also see non-reversed reaction +@format:idx,R,R,P,rate +354,AlO,O,AlO2,1.661d-9*exp(-44564.6*invT) * ntot * revKc_with_GFE(Tgas, [idx_AlO,idx_O], [idx_AlO2]) + +# manually added third body (ntot) term bacause this is a high density regime +# and this is not an association reaction +# also see non-reversed reaction +@format:idx,R,R,P,rate +355,AlO,Al,Al2O,1.661d-9*exp(-67035.7*invT) * ntot * revKc_with_GFE(Tgas, [idx_AlO,idx_Al], [idx_Al2O]) + +# manually added third body (ntot) term bacause this is a high density regime +# and this is not an association reaction +# also see non-reversed reaction +@format:idx,R,R,P,rate +356,AlO,AlO,Al2O2,1.661d-9*exp(-59335.7*invT) * ntot * revKc_with_GFE(Tgas, [idx_AlO,idx_AlO], [idx_Al2O2]) + +# manually added third body (ntot) term bacause this is a high density regime +# and this is not an association reaction +# also see non-reversed reaction +@format:idx,R,R,P,rate +357,Al,AlO2,Al2O2,1.661d-9*exp(-74937.1*invT) * ntot * revKc_with_GFE(Tgas, [idx_Al,idx_AlO2], [idx_Al2O2]) + +# manually added third body (ntot) term bacause this is a high density regime +# and this is not an association reaction +# also see non-reversed reaction +@format:idx,R,R,P,rate +358,Al2O,O,Al2O2,1.661d-9*exp(-52466.*invT) * ntot * revKc_with_GFE(Tgas, [idx_Al2O,idx_O], [idx_Al2O2]) + +# manually added third body (ntot) term bacause this is a high density regime +# and this is not an association reaction +# also see non-reversed reaction +@format:idx,R,R,P,rate +359,Al2O2,O,Al2O3,4.982d-9*exp(-49144.4*invT) * ntot * revKc_with_GFE(Tgas, [idx_Al2O2,idx_O], [idx_Al2O3]) + +# manually added third body (ntot) term bacause this is a high density regime +# and this is not an association reaction +# also see non-reversed reaction +@format:idx,R,R,P,rate +360,AlO2,AlO,Al2O3,4.982d-9*exp(-63915.4*invT) * ntot * revKc_with_GFE(Tgas, [idx_AlO2,idx_AlO], [idx_Al2O3]) + +@format:idx,R,R,P,P,rate +361,AlOH,H,Al,H2O,(3.255d-10*Tgas**(-.09)*exp(-3744.*invT) + 4.616d-18*Tgas**(2.06)*exp(-438.*invT)) * revKc_with_GFE(Tgas, [idx_AlOH,idx_H], [idx_Al,idx_H2O]) + +@format:idx,R,R,P,P,rate +362,AlO,H2,AlOH,H,4.417d-16*Tgas**(.82)*exp(-7844.*invT) * revKc_with_GFE(Tgas, [idx_AlO,idx_H2], [idx_AlOH,idx_H]) + +@format:idx,R,R,P,P,rate +363,AlO,OH,AlOH,O,1.251d-11*Tgas**(.5)*exp(-4450.*invT) * revKc_with_GFE(Tgas, [idx_AlO,idx_OH], [idx_AlOH,idx_O]) + +@format:idx,R,R,P,P,rate +364,AlOH,Al,AlO,AlH,4.218d-11*Tgas**(.17) * revKc_with_GFE(Tgas, [idx_AlOH,idx_Al], [idx_AlO,idx_AlH]) + +@format:idx,R,R,P,P,rate +365,AlO2H,OH,AlO2,H2O,4.367d-22*Tgas**(3.26)*exp(-3430.*invT) * revKc_with_GFE(Tgas, [idx_AlO2H,idx_OH], [idx_AlO2,idx_H2O]) + +@format:idx,R,R,P,P,rate +366,AlO2H,H,AlO2,H2,7.672d-14*Tgas**(1.39)*exp(-2940.*invT) * revKc_with_GFE(Tgas, [idx_AlO2H,idx_H], [idx_AlO2,idx_H2]) + +@format:idx,R,R,P,P,rate +367,AlO2H,O,AlO2,OH,4.268d-11*Tgas**(.17) * revKc_with_GFE(Tgas, [idx_AlO2H,idx_O], [idx_AlO2,idx_OH]) + +@format:idx,R,R,P,P,rate +368,AlOH,O2,AlO2H,O,3.554d-11*Tgas**(.17) * revKc_with_GFE(Tgas, [idx_AlOH,idx_O2], [idx_AlO2H,idx_O]) + +@format:idx,R,P,P,rate +369,AlO2H2,AlO2H,H,1.227d-10*Tgas**(.17) * revKc_with_GFE(Tgas, [idx_AlO2H2], [idx_AlO2H,idx_H]) + +@format:idx,R,P,P,rate +370,AlO2H2,AlOH,OH,4.118d-11*Tgas**(.16)*exp(23.*invT) * revKc_with_GFE(Tgas, [idx_AlO2H2], [idx_AlOH,idx_OH]) + +@format:idx,R,P,P,rate +371,AlO3H3,AlO2H2,OH,4.218d-11*Tgas**(.15)*exp(48.*invT) * revKc_with_GFE(Tgas, [idx_AlO3H3], [idx_AlO2H2,idx_OH]) + +# 3 body +@format:idx,R,R,P,P,P,rate +372,AlO,H2O,Al,O,H2O,2.317d-31/Tgas * revKc_with_GFE(Tgas, [idx_AlO], [idx_Al,idx_O]) + +@format:idx,R,R,P,P,P,rate +373,AlO,O2,Al,O,O2,9.101d-31/Tgas * revKc_with_GFE(Tgas, [idx_AlO], [idx_Al,idx_O]) + +@format:idx,R,R,P,P,P,rate +374,AlO,H2,Al,O,H2,9.101d-31/Tgas * revKc_with_GFE(Tgas, [idx_AlO], [idx_Al,idx_O]) + +@format:idx,R,R,P,P,P,rate +375,AlO2H2,H2,Al,H2O,H2O,3.198d-33*Tgas**(.5) * revKc_with_GFE(Tgas, [idx_AlO2H2,idx_H2], [idx_Al,idx_H2O,idx_H2O]) + +@format:idx,R,R,R,P,P,P,rate +376,AlOH,H,H2O,Al,H2O,H2O,3.198d-33*Tgas**(.5)*exp(-1260.*invT) * revKc_with_GFE(Tgas, [idx_AlOH,idx_H,idx_H2O], [idx_Al,idx_H2O,idx_H2O]) + +@noTabNext +@format:idx,R,P,P,rate +377,AlOH,AlO,H,5.489d-33*Tgas**(.5)*ntot * revKc_with_GFE(Tgas, [idx_AlOH], [idx_AlO,idx_H]) + +@noTabNext +@format:idx,R,P,P,rate +378,AlOH,Al,OH,5.957d-33*Tgas**(.5)*ntot * revKc_with_GFE(Tgas, [idx_AlOH], [idx_Al,idx_OH]) + +@noTabNext +@format:idx,R,P,P,rate +379,AlH,Al,H,2.600d-33*Tgas**(.5)*ntot * revKc_with_GFE(Tgas, [idx_AlH], [idx_Al,idx_H]) + +@noTabNext +@format:idx,R,P,P,rate +380,AlO2H,AlO,OH,7.226d-33*Tgas**(.5)*ntot * revKc_with_GFE(Tgas, [idx_AlO2H], [idx_AlO,idx_OH]) + +@noTabNext +@format:idx,R,P,P,rate +381,AlO2H,AlO2,H,6.04d-33*Tgas**(.5)*ntot * revKc_with_GFE(Tgas, [idx_AlO2H], [idx_AlO2,idx_H]) + +@noTabNext +@format:idx,R,P,P,rate +382,AlO2H,AlOH,O,8.107d-33*Tgas**(.5)*ntot * revKc_with_GFE(Tgas, [idx_AlO2H], [idx_AlOH,idx_O]) + +#not in data/database/ALchemistry.dat but still in Starik+2014 +@format:idx,R,R,P,P,rate +383,Al,HO2,AlO,OH,2.209d-11*Tgas**(0.17) + +@format:idx,R,R,P,P,rate +384,Al,HO2,AlH,O2,2.209d-11*Tgas**(0.17) + +# original rate format, but don't use @var because these will be global variables +# and not just for this rate +# @var: k0 = 1.607d-9 * exp(-19962.*invT) +# @var: kinf = 2.42d-9 * exp(-23376.*invT) +# @var: beta = (1. + log10(k0 * ntot / kinf)**2 )**(-1.) +# @var: Fc = -4.1 * exp(-Tgas/21.6) + 5.1 * exp(-Tgas/493.) + exp(-942.*invT) +# 385,AlH2,AlH,H,k0 * ntot / (1 + k0*ntot/kinf) * Fc**beta +@noTabNext +@format:idx,R,P,P,rate +385,AlH2,AlH,H, troe_falloff( ( 1.607d-9 * exp(-19962.*invT) ), ( 2.42d-9 * exp(-23376.*invT) ), ( -4.1 * exp(-Tgas/21.6) + 5.1 * exp(-Tgas/493.) + exp(-942.*invT) ), ntot) + +# original rate format, but don't use @var because these will be global variables +# and not just for this rate +# @var: k0 = 1.677d-9 * exp(-27089.*invT) +# @var: kinf = 2.46d-11 * exp(-30756.*invT) +# @var: beta = (1 + log10(k0 * ntot / kinf)**2 )**(-1.) +# @var: Fc = 0.94 * exp(-Tgas/885.) + 0.06 * exp(-Tgas/552.) + exp(-3807.*invT) +# 386,AlH3,AlH,H2,k0 * ntot / (1 + k0*ntot/kinf) * Fc**beta +@noTabNext +@format:idx,R,P,P,rate +386,AlH3,AlH,H2, troe_falloff( ( 1.677d-9 * exp(-27089.*invT) ), ( 2.46d-11 * exp(-30756.*invT) ), ( 0.94 * exp(-Tgas/885.) + 0.06 * exp(-Tgas/552.) + exp(-3807.*invT) ), ntot) + +@format:idx,R,R,P,P,rate +387,AlH,H,Al,H2,1.187d-10 * Tgas**(0.17) + +@storeonce_start +@format:idx,R,R,P,P,rate +388,AlH2,H,AlH,H2,3.321d-11 +@storeonce_stop + +@format:idx,R,R,P,P,rate +389,AlH3,H,AlH2,H2,7.888d-15 * Tgas**(1.5) + +@format:idx,R,R,P,P,rate +390,AlO,HO2,AlOH,O2,3.637d-10 * Tgas**(-0.08) * exp(35.*invT) + +@format:idx,R,R,P,P,rate +391,AlOH,HO2,AlO2H,OH,6.244d-11 * Tgas**(0.14) + +#reversed +@format:idx,R,R,P,P,rate +392,AlO,OH,Al,HO2,2.209d-11*Tgas**(0.17) * revKc_with_GFE(Tgas, [idx_AlO,idx_OH], [idx_Al,idx_HO2]) + +@format:idx,R,R,P,P,rate +393,AlH,O2,Al,HO2,2.209d-11*Tgas**(0.17) * revKc_with_GFE(Tgas, [idx_AlH,idx_O2], [idx_Al,idx_HO2]) + +# original rate format, but don't use @var because these will be global variables +# and not just for this rate +# @var: k0 = 1.607d-9 * exp(-19962.*invT) +# @var: kinf = 2.42d-9 * exp(-23376.*invT) +# @var: beta = (1. + log10(k0 * ntot / kinf)**2 )**(-1.) +# @var: Fc = -4.1 * exp(-Tgas/21.6) + 5.1 * exp(-Tgas/493.) + exp(-942.*invT) +@noTabNext +@format:idx,R,R,P,rate +394,AlH,H,AlH2, revKc_with_GFE(Tgas, [idx_AlH,idx_H], [idx_AlH2]) * troe_falloff( ( 1.607d-9 * exp(-19962.*invT) ), ( 2.42d-9 * exp(-23376.*invT) ), ( -4.1 * exp(-Tgas/21.6) + 5.1 * exp(-Tgas/493.) + exp(-942.*invT) ), ntot) + +# original rate format, but don't use @var because these will be global variables +# and not just for this rate +# @var: k0 = 1.677d-9 * exp(-27089.*invT) +# @var: kinf = 2.46d-11 * exp(-30756.*invT) +# @var: beta = (1 + log10(k0 * ntot / kinf)**2 )**(-1.) +# @var: Fc = 0.94 * exp(-Tgas/885.) + 0.06 * exp(-Tgas/552.) + exp(-3807.*invT) +@noTabNext +@format:idx,R,R,P,rate +395,AlH,H2,AlH3, revKc_with_GFE(Tgas, [idx_AlH,idx_H2], [idx_AlH3]) * troe_falloff( ( 1.677d-9 * exp(-27089.*invT) ), ( 2.46d-11 * exp(-30756.*invT) ), ( 0.94 * exp(-Tgas/885.) + 0.06 * exp(-Tgas/552.) + exp(-3807.*invT) ), ntot) + +@format:idx,R,R,P,P,rate +396,Al,H2,AlH,H,1.187d-10 * Tgas**(0.17) * revKc_with_GFE(Tgas, [idx_Al,idx_H2], [idx_AlH,idx_H]) + +@format:idx,R,R,P,P,rate +397,AlH,H2,AlH2,H,3.321d-11 * revKc_with_GFE(Tgas, [idx_AlH,idx_H2], [idx_AlH2,idx_H]) + +@format:idx,R,R,P,P,rate +398,AlH2,H2,AlH3,H,7.888d-15 * Tgas**(1.5) * revKc_with_GFE(Tgas, [idx_AlH2,idx_H2], [idx_AlH3,idx_H]) + +@format:idx,R,R,P,P,rate +399,AlOH,O2,AlO,HO2,3.637d-10 * Tgas**(-0.08) * exp(35.*invT) * revKc_with_GFE(Tgas, [idx_AlOH,idx_O2], [idx_AlO,idx_HO2]) + +@format:idx,R,R,P,P,rate +400,AlO2H,OH,AlOH,HO2,6.244d-11 * Tgas**(0.14) * revKc_with_GFE(Tgas, [idx_AlO2H,idx_OH], [idx_AlOH,idx_HO2]) + +# Sharipov & Starik 2016 +@format:idx,R,R,P,P,Tmin,Tmax,rate +401,Al,H2O2,AlOH,OH,300,4000,1.827d-11 * Tgas**(0.159) * exp(91.1*invT) + +@format:idx,R,R,P,Tmin,Tmax,rate +402,Al,H2O2,AlO2H2,300,4000,1.827d-11 * Tgas**(0.159) * exp(91.1*invT) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +403,AlO,H2O2,AlOH,HO2,300,4000,6.044d-11 * Tgas**(0.152) * exp(78.8*invT) + +# @format:idx,R,R,P,Tmin,Tmax,rate +# 404,AlO,H2O2,AlO3H2,300,4000,6.044d-11 * Tgas**(0.152) * exp(78.8*invT) +# REMOVED because not thermochemical data + +@format:idx,R,R,P,P,Tmin,Tmax,rate +404,AlOH,H2O2,AlO2H2,OH,300,4000,4.367d-11 * Tgas**(0.18) * exp(15.4*invT) + +@format:idx,R,R,P,Tmin,Tmax,rate +405,AlOH,H2O2,AlO3H3,300,4000,4.367d-11 * Tgas**(0.18) * exp(15.4*invT) + +#note that AlO2H is OAlOH and not AlOOH +@format:idx,R,R,P,P,Tmin,Tmax,rate +406,AlOH,H2O2,AlO2H,H2O,300,4000,4.367d-11 * Tgas**(0.18) * exp(15.4*invT) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +407,AlH,HO2,AlOH,OH,300,4000,4.948d-11 * Tgas**(0.167) * exp(0.3*invT) + +# Reversed +@format:idx,R,R,P,P,Tmin,Tmax,rate +408,AlOH,OH,Al,H2O2,300,4000,1.827d-11 * Tgas**(0.159) * exp(91.1*invT) * revKc_with_GFE(Tgas, [idx_AlOH,idx_OH], [idx_Al,idx_H2O2]) + +@format:idx,R,P,P,Tmin,Tmax,rate +409,AlO2H2,Al,H2O2,300,4000,1.827d-11 * Tgas**(0.159) * exp(91.1*invT) * revKc_with_GFE(Tgas, [idx_AlO2H2], [idx_Al,idx_H2O2]) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +410,AlOH,HO2,AlO,H2O2,300,4000,6.044d-11 * Tgas**(0.152) * exp(78.8*invT) * revKc_with_GFE(Tgas, [idx_AlOH,idx_HO2], [idx_AlO,idx_H2O2]) + +# @format:idx,R,P,P,Tmin,Tmax,rate +# 412,AlO3H2,AlO,H2O2,300,4000,6.044d-11 * Tgas**(0.152) * exp(78.8*invT) * revKc_with_GFE(Tgas, [idx_AlO3H2], [idx_AlO,idx_H2O2]) +# REMOVED because not thermochemical data + +@format:idx,R,R,P,P,Tmin,Tmax,rate +411,AlO2H2,OH,AlOH,H2O2,300,4000,4.367d-11 * Tgas**(0.18) * exp(15.4*invT) * revKc_with_GFE(Tgas, [idx_AlO2H2,idx_OH], [idx_AlOH,idx_H2O2]) + +@format:idx,R,P,P,Tmin,Tmax,rate +412,AlO3H3,AlOH,H2O2,300,4000,4.367d-11 * Tgas**(0.18) * exp(15.4*invT) * revKc_with_GFE(Tgas, [idx_AlO3H3], [idx_AlOH,idx_H2O2]) + +#note that AlO2H is OAlOH and not AlOOH +@format:idx,R,R,P,P,Tmin,Tmax,rate +413,AlO2H,H2O,AlOH,H2O2,300,4000,4.367d-11 * Tgas**(0.18) * exp(15.4*invT) * revKc_with_GFE(Tgas, [idx_AlO2H,idx_H2O], [idx_AlOH,idx_H2O2]) + +@format:idx,R,R,P,P,Tmin,Tmax,rate +414,AlOH,OH,AlH,HO2,300,4000,4.948d-11 * Tgas**(0.167) * exp(0.3*invT) * revKc_with_GFE(Tgas, [idx_AlOH,idx_OH], [idx_AlH,idx_HO2]) + +# Sharipov+ 2012 in Combustion Theory and Modelling +@format:idx,R,R,P,P,rate +415,Al,CO2,AlO,CO,1.214d-11 * Tgas**(0.5) * exp(-7470.*invT) + +@format:idx,R,R,P,P,rate +416,Al,HCO,AlH,CO,4.550d-11 * Tgas**(0.17) + +@format:idx,R,R,P,P,rate +417,AlO,CO2,AlO2,CO,1.187d-11 * Tgas**(0.5) * exp(-15600.*invT) + +# 3 body +# @noTabNext +# @format:idx,R,R,P,rate +# 422,Al,CO,AlCO,1.44d-33 * Tgas**(0.5) * ntot +# REMOVED because not thermochemical data + +# @noTabNext +# @format:idx,R,R,P,rate +# 423,Al,NO,AlNO,1.40d-33 *Tgas**(0.5) * ntot +# REMOVED because not thermochemical data + +@noTabNext +@format:idx,R,R,P,rate +418,Al,C,AlC,9.21d-33 * Tgas**(0.5) * ntot + +# reversed +@format:idx,R,R,P,P,rate +419,AlO,CO,Al,CO2,1.214d-11 * Tgas**(0.5) * exp(-7470.*invT) * revKc_with_GFE(Tgas, [idx_AlO,idx_CO], [idx_Al,idx_CO2]) + +@format:idx,R,R,P,P,rate +420,AlH,CO,Al,HCO,4.550d-11 * Tgas**(0.17) * revKc_with_GFE(Tgas, [idx_AlH,idx_CO], [idx_Al,idx_HCO]) + +@format:idx,R,R,P,P,rate +421,AlO2,CO,AlO,CO2,1.187d-11 * Tgas**(0.5) * exp(-15600.*invT) * revKc_with_GFE(Tgas, [idx_AlO2,idx_CO], [idx_AlO,idx_CO2]) + +# # 3 body +# @noTabNext +# @format:idx,R,P,P,rate +# 431,AlCO,Al,CO,1.44d-33 * Tgas**(0.5) * ntot * revKc_with_GFE(Tgas, [idx_AlCO], [idx_Al,idx_CO]) +# REMOVED because not thermochemical data +# +# @noTabNext +# @format:idx,R,P,P,rate +# 432,AlNO,Al,NO,1.40d-33 *Tgas**(0.5) * ntot * revKc_with_GFE(Tgas, [idx_AlNO], [idx_Al,idx_NO]) +# REMOVED because not thermochemical data + +@noTabNext +@format:idx,R,P,P,rate +422,AlC,Al,C,9.21d-33 * Tgas**(0.5) * ntot * revKc_with_GFE(Tgas, [idx_AlC], [idx_Al,idx_C]) + +# # Cluster growth reactions +# # cluster_growth_rate(index_of_monomer, cluster_size, temperature, sticking_coefficient) +@format:idx,R,R,P,rate +423,MgO,MgO,Mg2O2,cluster_growth_rate(idx_MgO, 1, Tgas) + +@format:idx,R,R,P,rate +424,Mg2O2,MgO,Mg3O3,cluster_growth_rate(idx_MgO, 2, Tgas) + +@format:idx,R,R,P,rate +425,Mg3O3,MgO,Mg4O4,cluster_growth_rate(idx_MgO, 3, Tgas) + +@format:idx,R,R,P,rate +426,Mg4O4,MgO,Mg5O5,cluster_growth_rate(idx_MgO, 4, Tgas) + +@format:idx,R,R,P,rate +427,Mg5O5,MgO,Mg6O6,cluster_growth_rate(idx_MgO, 5, Tgas) + +@format:idx,R,R,P,rate +428,Mg6O6,MgO,Mg7O7,cluster_growth_rate(idx_MgO, 6, Tgas) + +@format:idx,R,R,P,rate +429,Mg7O7,MgO,Mg8O8,cluster_growth_rate(idx_MgO, 7, Tgas) + +@format:idx,R,R,P,rate +430,Mg8O8,MgO,Mg9O9,cluster_growth_rate(idx_MgO, 8, Tgas) + +@format:idx,R,R,P,rate +431,Mg9O9,MgO,Mg10O10,cluster_growth_rate(idx_MgO, 9, Tgas) + +# Cluster destruction reactions +# Based on detailed balance +@format:idx,R,P,P,rate +432,Mg2O2,MgO,MgO,cluster_growth_rate(idx_MgO, 1, Tgas) * revKc_with_GFE(Tgas, [idx_Mg2O2], [idx_MgO,idx_MgO]) + +@format:idx,R,P,P,rate +433,Mg3O3,Mg2O2,MgO,cluster_growth_rate(idx_MgO, 2, Tgas) * revKc_with_GFE(Tgas, [idx_Mg3O3], [idx_Mg2O2,idx_MgO]) + +@format:idx,R,P,P,rate +434,Mg4O4,Mg3O3,MgO,cluster_growth_rate(idx_MgO, 3, Tgas) * revKc_with_GFE(Tgas, [idx_Mg4O4], [idx_Mg3O3,idx_MgO]) + +@format:idx,R,P,P,rate +435,Mg5O5,Mg4O4,MgO,cluster_growth_rate(idx_MgO, 4, Tgas) * revKc_with_GFE(Tgas, [idx_Mg5O5], [idx_Mg4O4,idx_MgO]) + +@format:idx,R,P,P,rate +436,Mg6O6,Mg5O5,MgO,cluster_growth_rate(idx_MgO, 5, Tgas) * revKc_with_GFE(Tgas, [idx_Mg6O6], [idx_Mg5O5,idx_MgO]) + +@format:idx,R,P,P,rate +437,Mg7O7,Mg6O6,MgO,cluster_growth_rate(idx_MgO, 6, Tgas) * revKc_with_GFE(Tgas, [idx_Mg7O7], [idx_Mg6O6,idx_MgO]) + +@format:idx,R,P,P,rate +438,Mg8O8,Mg7O7,MgO,cluster_growth_rate(idx_MgO, 7, Tgas) * revKc_with_GFE(Tgas, [idx_Mg8O8], [idx_Mg7O7,idx_MgO]) + +@format:idx,R,P,P,rate +439,Mg9O9,Mg8O8,MgO,cluster_growth_rate(idx_MgO, 8, Tgas) * revKc_with_GFE(Tgas, [idx_Mg9O9], [idx_Mg8O8,idx_MgO]) + +@format:idx,R,P,P,rate +440,Mg10O10,Mg9O9,MgO,cluster_growth_rate(idx_MgO, 9, Tgas) * revKc_with_GFE(Tgas, [idx_Mg10O10], [idx_Mg9O9,idx_MgO]) + +# # +# Mg reactions +########################## +########################## +# Next reactions follow the numbering from Plane, Feng, and Dawkins 2015 (PFD15) +# doi: 10.1021/cr500501m +# The rates are taken from the original papers and not Plane+2015 +# +# Plane & Hemler 1995 (PH95) (doi:10.1039/fd9950000411) +@format:idx,R,R,P,P,rate +441,Mg,O3,MgO,O2,2.3d-10 * exp(-139.*invT) + +#REVERSED +@format:idx,R,R,P,P,rate +442,MgO,O2,Mg,O3,2.3d-10 * exp(-139.*invT) * revKc_with_GFE(Tgas, [idx_MgO,idx_O2], [idx_Mg,idx_O3]) + +# Plane & Whalley 2012 (PW12) (doi:10.1021/jp211526h) +@format:idx,R,R,P,P,rate +443,MgO,O,Mg,O2,6.2d-10 * (Tgas/300.)**(1./6.) + +#REVERSED +@format:idx,R,R,P,P,rate +444,Mg,O2,MgO,O,6.2d-10 * (Tgas/300.)**(1./6.) * revKc_with_GFE(Tgas, [idx_MgO,idx_O2], [idx_MgO,idx_O]) + +# PH95 +@format:idx,R,R,P,P,rate +445,MgO,O3,MgO2,O2,2.2d-10 * exp(-548.*invT) + +# PW12 +@format:idx,R,R,P,P,rate +446,MgO2,O,MgO,O2,8.4d-11 * (Tgas/300.)**(1./6.) + +# Rollason & Plane 2001 (RP01) (doi:10.1039/b105673p) +# 3 Body +# original rate format, but don't use @var because these will be global variables +# and not just for this rate +# @var: logk0 = -32.75 + 7.894*log10(Tgas) - 2.127*(log10(Tgas))**2 +# @var: kinf = 3.52d-10 * exp(-334.*invT) +# @var: beta = (1 + (logk0 + log10(ntot / kinf) )**2 )**(-1.) +# @var: Fc = 0.28 +@noTabNext +@format:idx,R,R,P,rate +447,MgO,H2O,MgO2H2, troe_falloff(( 10**(-32.75 + 7.894*log10(Tgas) - 2.127*(log10(Tgas))**2) ), ( 3.52d-10 * exp(-334.*invT) ), (0.28d0), ntot) + +#REVERSED +@noTabNext +@format:idx,R,P,P,rate +448,MgO2H2,MgO,H2O, troe_falloff(( 10**(-32.75 + 7.894*log10(Tgas) - 2.127*(log10(Tgas))**2) ), ( 3.52d-10 * exp(-334.*invT) ), (0.28d0), ntot) * revKc_with_GFE(Tgas, [idx_MgO2H2], [idx_MgO,idx_H2O]) + + +# PW12 (says "fast") PFD15 (estimate?) +@storeonce_start +@format:idx,R,R,P,P,rate +449,MgO3,H2O,MgO2H2,O2,1d-12 +@storeonce_stop + +# Rollason & Plane 2001 (RP01) (doi:10.1039/b105673p) +# 3 Body +# original rate format, but don't use @var because these will be global variables +# and not just for this rate +# @var: logk0 = -28.05 + 1.423*log10(Tgas) - 0.683*(log10(Tgas))**2 +# @var: kinf = 1.16d-10 * exp(-219.*invT) +# @var: beta = (1 + (logk0 + log10(ntot / kinf) )**2 )**(-1.) +# @var: Fc = 0.34 +@noTabNext +@format:idx,R,R,P,rate +450,MgO,O2,MgO3, troe_falloff(( 10**(-28.05 + 1.423*log10(Tgas) - 0.683*(log10(Tgas))**2) ), ( 1.16d-10 * exp(-219.*invT) ), ( 0.34d0 ), ntot) + +# Rollason & Plane 2001 (RP01) (doi:10.1039/b105673p) +# 3 Body +# original rate format, but don't use @var because these will be global variables +# and not just for this rate +# @var: logk0 = -33.70 + 5.827*log10(Tgas) - 1.494*(log10(Tgas))**2 +# @var: kinf = 6.79d-10 * exp(-310.*invT) +# @var: beta = (1 + (logk0 + log10(ntot / kinf) )**2 )**(-1.) +# @var: Fc = 0.37 +@noTabNext +@format:idx,R,R,P,rate +451,MgO,CO2,MgCO3, troe_falloff(( 10**(-33.70 + 5.827*log10(Tgas) - 1.494*(log10(Tgas))**2) ), ( 6.79d-10 * exp(-310.*invT) ), ( 0.37d0 ), ntot) + +#REVERSED +@noTabNext +@format:idx,R,P,P,rate +452,MgCO3,MgO,CO2, troe_falloff(( 10**(-33.70 + 5.827*log10(Tgas) - 1.494*(log10(Tgas))**2) ), ( 6.79d-10 * exp(-310.*invT) ), ( 0.37d0 ), ntot) * revKc_with_GFE(Tgas, [idx_MgCO3], [idx_MgO,idx_CO2]) + + +# PW12 (rate in text) +# 3 Body +# original rate format, but don't use @var because these will be global variables +# and not just for this rate +# @var: k0 = 6.4d-27 * (Tgas/300.)**(-3.3) +# @var: kinf = 1.8d-10 * exp(-46.*invT) +# @var: beta = (1 + log10(k0 * ntot / kinf)**2 )**(-1.) +# @var: Fc = 0.30 +@noTabNext +@format:idx,R,R,P,rate +453,MgO2,O2,MgO4,troe_falloff( ( 6.4d-27 * (Tgas/300.)**(-3.3) ), ( 1.8d-10 * exp(-46.*invT) ), ( 0.30d0 ), ntot) + +# PW12 (says "fast"), PFD15 (estimate?) +@storeonce_start +@format:idx,R,R,P,P,rate +454,MgO4,O,MgO3,O2,8d-14 +@storeonce_stop + +# PW12 (unclear...) but also used in PFD15 and L+15 +@format:idx,R,R,P,P,rate +455,MgO2H2,H,MgOH,H2O,1d-11 * exp(-600*invT) + +#REVERSED +@format:idx,R,R,P,P,rate +456,MgOH,H2O,MgO2H2,H,1d-11 * exp(-600*invT) * revKc_with_GFE(Tgas, [idx_MgOH,idx_H2O], [idx_MgO2H2,idx_H]) + +# PW12 (No rate given), PFD15 (estimate?) +@storeonce_start +@format:idx,R,R,P,P,rate +457,MgOH,H,Mg,H2O,2d-10 +@storeonce_stop + +@format:idx,R,R,P,P,rate +458,Mg,H2O,MgOH,H,2d-10 * revKc_with_GFE(Tgas, [idx_Mg,idx_H2O], [idx_MgOH,idx_H]) + +@storeonce_start +# PW12 (No rate given), PFD15 (estimate?) +@format:idx,R,R,P,P,rate +459,MgO3,H,MgOH,O2,2d-12 + +# Langowski+ 2015(L+15) (doi:10.5194/acp-15-273-2015) +# @format:idx,R,R,P,rate +# 465,MgOH,MgOH,Mg2O2H2,9d-10 +# REMOVED because SINK +# +# Rutterford 1971, KIDA +@format:idx,R,R,P,P,rate +460,Mg,O2+,Mg+,O2,1.2d-9 + +# Rutterford 1971, KIDA +@format:idx,R,R,P,P,rate +461,Mg,NO+,Mg+,NO,8.2d-10 + +# Whalley+2011 (W+11) (doi:10.1039/c0cp02637a) +@format:idx,R,R,P,P,rate +462,Mg+,O3,MgO+,O2,1.17d-9 + +# WHalley & Plane 2010 (WP10) (doi:10.1039/c003726e) +@format:idx,R,R,P,P,rate +463,MgO+,O,Mg+,O2,5.9d-10 +@storeonce_stop + +# W+11 +# 3 body +@noTabNext +@format:idx,R,R,P,rate +464,Mg+,N2,MgN2+,2.7d-31 * (Tgas/300.)**(-1.88) * ntot + +# W+11 +# 3 body +@noTabNext +@format:idx,R,R,P,rate +465,Mg+,O2,MgO2+,4.1d-31 * (Tgas/300.)**(-1.65) * ntot + +# WP10 +@storeonce_start +@format:idx,R,R,P,P,rate +466,MgO2+,O,MgO+,O2,6.5d-10 + +# W+11 +@format:idx,R,R,P,P,P,rate +467,MgO+,O3,Mg+,O2,O2,8.5d-10 * 0.35 + +# W+11 +@format:idx,R,R,P,P,rate +468,MgO+,O3,MgO2+,O2,8.5d-10 * 0.65 +@storeonce_stop + +# Martinez-Nunez et al 2010 (MN+10) (doi:10.1021/jp102454j) +# 3 Body +# original rate format, but don't use @var because these will be global variables +# and not just for this rate +# @var: k0 = 2.9d-29 +# @var: kinf = 5.0d-11 * exp(829./(8.314)*invT) +# @var: beta = (1 + log10(k0 * ntot / kinf)**2 )**(-1.) +# @var: Fc = 0.52 +@noTabNext +@format:idx,R,R,P,rate +469,Mg+,H2O,MgH2O+,troe_falloff((2.9d-29 ), ( 5.0d-11 * exp(829./(8.314)*invT) ), ( 0.52d0 ), ntot) + +# W+11 +# 3 Body +@noTabNext +@format:idx,R,R,P,rate +470,Mg+,CO2,MgCO2+,7.3d-30 * (Tgas/300.)**(-1.59) * ntot + +#Verner 1996, auto in KROME +@format:idx,R,R,P,P,P,rate +471,Mg,E,Mg+,E,E,auto + +# next reactions are not in PFD15 +# W+11 +@format:idx,R,R,P,P,rate +472,Mg,NO2,MgO,NO,1.4d-11 * exp(-3.4*invT/R) + +#REVERSED +@format:idx,R,R,P,P,rate +473,MgO,NO,Mg,NO2,1.4d-11 * exp(-3.4*invT/R) * revKc_with_GFE(Tgas, [idx_MgO,idx_NO], [idx_Mg,idx_NO2]) + +# W+11 +# 3 body +@noTabNext +@format:idx,R,R,P,rate +474,Mg+,N2O,MgN2O+,5.8d-30 * (Tgas/300.)**(-1.94) * ntot + +# W+11 +@storeonce_start +@format:idx,R,R,P,P,rate +475,MgCO2+,H2O,MgH2O+,CO2,5.1d-11 + +# W+11 +@format:idx,R,R,P,P,rate +476,MgO2+,H2O,MgH2O+,O2,1.9d-11 + +# W+11 +@format:idx,R,R,P,P,rate +477,MgN2+,O2,MgO2+,N2,3.5d-12 +@storeonce_stop + +# W+11 +# 3 body +@noTabNext +@format:idx,R,R,P,rate +478,MgO2+,O2,MgO4+,9d-30 * (Tgas/300.)**(-3.80) * ntot + +# W+11 +# 3 body +@noTabNext +@format:idx,R,R,P,rate +479,MgCO2+,CO2,MgC2O4+,2.3d-29 * (Tgas/300.)**(-5.08) * ntot + +# W+11 +# 3 body +@noTabNext +@format:idx,R,R,P,rate +480,MgH2O+,H2O,MgH4O2+,3.0d-28 * (Tgas/300.)**(-3.96) * ntot + +# W+11 +# 3 body +@noTabNext +@format:idx,R,R,P,rate +481,MgO2+,N2,MgO2N2+,4.7d-30 * (Tgas/300.)**(-3.75) * ntot + +# W+11 +# 3 body +@noTabNext +@format:idx,R,R,P,rate +482,MgO2+,CO2,MgCO4+,6.6d-29 * (Tgas/300.)**(-4.18) * ntot + +# W+11 +# 3 body +@noTabNext +@format:idx,R,R,P,rate +483,MgH2O+,O2,MgH2O3+,1.2d-27 * (Tgas/300.)**(-4.13) * ntot + +# WP10 +@storeonce_start +@format:idx,R,R,P,P,rate +484,MgCO2+,O2,MgO2+,CO2,2.2d-11 +@storeonce_stop + +# Dissociative recombination reactions +# PFD15 +# Estimate base on review of dissociative electron recombination of +# Florescu-Mitchell & Mitchell 2006 (FMM06) (doi:10.1016/J.PHYSREP.2006.04.002) +# MgX+ + E -> Mg + X +@format:idx,R,R,P,P,rate +485,MgO+,E,Mg,O,3d-7 * (Tgas/200.)**(-0.5) + +@format:idx,R,R,P,P,rate +486,MgO2+,E,Mg,O2,3d-7 * (Tgas/200.)**(-0.5) + +@format:idx,R,R,P,P,rate +487,MgN2+,E,Mg,N2,3d-7 * (Tgas/200.)**(-0.5) + +@format:idx,R,R,P,P,rate +488,MgCO2+,E,Mg,CO2,3d-7 * (Tgas/200.)**(-0.5) + +@format:idx,R,R,P,P,rate +489,MgH2O+,E,Mg,H2O,3d-7 * (Tgas/200.)**(-0.5) + +@format:idx,R,R,P,P,rate +490,MgN2O+,E,Mg,N2O,3d-7 * (Tgas/200.)**(-0.5) + +# dissociation based on ion cluster notation in W+11 +# MgY+(dot)X + E -> MgY + X +@format:idx,R,R,P,P,rate +491,MgO4+,E,MgO2,O2,3d-7 * (Tgas/200.)**(-0.5) + +@format:idx,R,R,P,P,P,rate +492,MgC2O4+,E,Mg,CO2,CO2,3d-7 * (Tgas/200.)**(-0.5) + +@format:idx,R,R,P,P,P,rate +493,MgH4O2+,E,Mg,H2O,H2O,3d-7 * (Tgas/200.)**(-0.5) + +@format:idx,R,R,P,P,rate +494,MgO2N2+,E,MgO2,N2,3d-7 * (Tgas/200.)**(-0.5) + +@format:idx,R,R,P,P,rate +495,MgCO4+,E,MgO2,CO2,3d-7 * (Tgas/200.)**(-0.5) + +@format:idx,R,R,P,P,rate +496,MgH2O3+,E,MgO2,H2O,3d-7 * (Tgas/200.)**(-0.5) + +# Missing recombination +@format:idx,R,R,P,P,rate +497,NO+,E,O,N,4.30d-7*(T32)**(-0.37) + +@format:idx,R,R,P,P,rate +498,O2+,E,O,O,1.95d-7*(T32)**(-0.70) + +# Atkinson+2004 (doi:10.5194/acp-4-1461-2004) +@format:idx,R,R,P,P,rate +499,O3,O,O2,O2,8d-12 * exp(-2060.*invT) + +# Atkinson+2004 (doi:10.5194/acp-4-1461-2004) +@format:idx,R,R,R,P,P,rate +500,O,O2,O2,O3,O2,6.0d-34*(Tgas/300.)**(-2.6) + +# DeMore+1997 (https://jpldataeval.jpl.nasa.gov/pdf/Atmos97_Anotated.pdf) +@format:idx,R,R,P,P,rate +501,H,O3,OH,O2,1.4d-10*exp(470.*invT) + +# # Add to avoid source terms +# UMIST +@format:idx,R,R,P,P,rate +502,O+,N2,NO+,N,2.42d-12*(T32)**(-0.21)*exp(44.0*invT) + +# Add to avoid source terms +@storeonce_start +@format:idx,R,R,P,P,rate +503,H+,O2,O2+,H,2.00d-9 +@storeonce_stop From 1f6229fa7c510912a0150862cba4e1f925d1cc22 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Wed, 21 Feb 2024 07:42:51 +0100 Subject: [PATCH 315/814] Update krome.yml to exclude ifort macos --- .github/workflows/krome.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/krome.yml b/.github/workflows/krome.yml index db85f8c42..25204531a 100644 --- a/.github/workflows/krome.yml +++ b/.github/workflows/krome.yml @@ -22,6 +22,9 @@ jobs: matrix: os: [ubuntu-latest, macos-latest] toolchain: [{compiler: gcc}, {compiler: intel-classic}] + exclude: + - os: macos-latest + toolchain: {compiler: intel-classic} steps: - uses: awvwgk/setup-fortran@v1 From 2bdeb2f1dd9f9d435ca6299a8cb761ad39f12337 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 28 Feb 2024 12:09:55 +1100 Subject: [PATCH 316/814] Update ozstar.rst [skip ci] --- docs/getting-started/ozstar.rst | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/docs/getting-started/ozstar.rst b/docs/getting-started/ozstar.rst index 234fc4d24..7792728cd 100644 --- a/docs/getting-started/ozstar.rst +++ b/docs/getting-started/ozstar.rst @@ -25,12 +25,16 @@ show available software $ module avail -load intel compilers, git and splash +load intel compilers, git and splash. These might have different names +to the below, but should be similar + :: - $ module load ifort/2018.1.163-gcc-6.4.0 - $ module load git/2.18.0 + $ module load intel-compilers/2023.0.0 + $ module load ffmpeg/5.1.2 + $ module load gompi/2023a + $ module load hdf5/1.14.0 Get phantom ~~~~~~~~~~~ @@ -64,8 +68,10 @@ contains the modules I want loaded every time I log in. For example: :: $ cat .modules - module load ifort - module load git + module load intel-compilers/2023.0.0 + module load ffmpeg/5.1.2 + module load gompi/2023a + module load hdf5/1.14.0 Then, add the following lines to your ~/.bashrc From c8bfab2fe8a464319a3da89a4c6e6d8c4bcb5e5d Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 29 Feb 2024 12:17:40 +1100 Subject: [PATCH 317/814] Update ozstar.rst [skip ci] --- docs/getting-started/ozstar.rst | 71 +++++++++++---------------------- 1 file changed, 24 insertions(+), 47 deletions(-) diff --git a/docs/getting-started/ozstar.rst b/docs/getting-started/ozstar.rst index 7792728cd..fa564a3d4 100644 --- a/docs/getting-started/ozstar.rst +++ b/docs/getting-started/ozstar.rst @@ -1,7 +1,7 @@ How to run Phantom on OzStar ============================ -See also older instructions for :doc:`gstar `. +See also general instructions for :doc:`running phantom on a remote cluster `. Apply for an account -------------------- @@ -9,27 +9,25 @@ Apply for an account https://supercomputing.swin.edu.au/account-management/new_account_request If you are in Daniel Price’s research group, from your account -management page, request “join project” and select “oz015 - Price/Pinte -research group” +management page, request “join project”: + +https://supercomputing.swin.edu.au/account-management/project_join_request + +and select “oz015 - Price/Pinte research group” First time you log in --------------------- -:: +Replace USERNAME below with your username:: $ ssh -Y USERNAME@ozstar.swin.edu.au -show available software - -:: +show available software:: $ module avail load intel compilers, git and splash. These might have different names -to the below, but should be similar - - -:: +to the below, but should be similar:: $ module load intel-compilers/2023.0.0 $ module load ffmpeg/5.1.2 @@ -39,18 +37,14 @@ to the below, but should be similar Get phantom ~~~~~~~~~~~ -Clone a copy of phantom into your home directory - -:: +Clone a copy of phantom into your home directory:: $ git clone https://github.com/danieljprice/phantom.git Set your username and email address ----------------------------------- -Ensure that your name and email address are set, as follows: - -:: +Ensure that your name and email address are set, as follows:: cd phantom git config --global user.name "Joe Bloggs" @@ -63,9 +57,7 @@ edit your .bashrc file ---------------------- I put the “module load” commands in a file called ~/.modules which -contains the modules I want loaded every time I log in. For example: - -:: +contains the modules I want loaded every time I log in. For example:: $ cat .modules module load intel-compilers/2023.0.0 @@ -73,9 +65,7 @@ contains the modules I want loaded every time I log in. For example: module load gompi/2023a module load hdf5/1.14.0 -Then, add the following lines to your ~/.bashrc - -:: +Then, add the following lines to your ~/.bashrc:: source ~/.modules export SYSTEM=ozstar @@ -92,9 +82,7 @@ code and small files. Calculations should be run in the “project” area in /fred/PROJECT_NAME/$USER I usually make a soft link / shortcut called “runs” pointing to the -directory where I want to run my calculations: - -:: +directory where I want to run my calculations:: $ cd /fred/oz015 $ mkdir $USER @@ -105,9 +93,7 @@ directory where I want to run my calculations: /fred/oz015/USERNAME then make a subdirectory for the name of the calculation you want to run -(e.g. shock) - -:: +(e.g. shock):: $ mkdir shock $ cd shock @@ -117,15 +103,11 @@ then make a subdirectory for the name of the calculation you want to run $ ./phantomsetup myshock To run the code, you need to write a slurm script. You can get an -example by typing “make qscript”: - -:: +example by typing “make qscript”:: $ make qscript INFILE=myshock.in > run.q -should produce something like - -:: +should produce something like:: $ cat run.q #!/bin/bash @@ -155,16 +137,12 @@ should produce something like echo "writing output to $outfile" ./phantom myshock.in >& $outfile -You can then submit this to the queue using - -:: +You can then submit this to the queue using:: $ sbatch run.q Submitted batch job 245936 -and check status using - -:: +and check status using:: $ squeue -u dprice JOBID PARTITION NAME USER ST TIME NODES NODELIST(REASON) @@ -176,16 +154,12 @@ splash on OzStar There is a version of splash you can get by loading the relevant module (module load splash). If you want a more recent version there is a version that gets regularly updated in the shared project folder -(/fred/oz015/splash): - -:: +(/fred/oz015/splash):: /fred/oz015/splash/bin/splash You can add this directory in your path by putting the following lines -in your ~/.bashrc file: - -:: +in your ~/.bashrc file:: export PATH=/fred/oz015/splash/bin:${PATH} export LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:/fred/oz015/splash/giza/lib @@ -235,3 +209,6 @@ more info For more information on the actual machine `read the userguide `__ +See also general instructions for :doc:`running phantom on a remote cluster `. + + From 1ec9f7bff72b4a9300f95824656439e81f964b2a Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 1 Mar 2024 17:12:56 +1100 Subject: [PATCH 318/814] (docs) added docs on composition tracking [skip ci] --- docs/physics/composition.rst | 40 ++++++++++++++++++++++++++++++++++++ docs/physics/index.rst | 1 + 2 files changed, 41 insertions(+) create mode 100644 docs/physics/composition.rst diff --git a/docs/physics/composition.rst b/docs/physics/composition.rst new file mode 100644 index 000000000..e395dde06 --- /dev/null +++ b/docs/physics/composition.rst @@ -0,0 +1,40 @@ +Composition tracking in phantom +===================================== + +This file documents how to track chemical abundances and mixing in phantom. + +Composition tracking with fixed abundances +-------------------------------------------- +Tracking the chemical composition of the gas in phantom with fixed +abundances is straightforward, since phantom is a Lagrangian code and +the particle identifiers are preserved throughout the simulation. + +In the non-MPI code without particle injection, the particles are +always written to the dump files in the same order, so the particle +id is simply the particle index in the dump file. In the MPI code, +the particle id is stored in the 'iorig' array in the dump file. + +Hence composition tracking can done as a post-processing step. + +Writing a .comp file +~~~~~~~~~~~~~~~~~~~~~ +In practice, the composition of the gas can be tracked by writing a .comp file +either once for the entire simulation, or one per dump file. The .comp file +is a simple ascii file with one row per particle, where the columns are the abundances. +You should also give the first line a header with labels for each element:: + + # h1, he3, he4, c12, n14, o16, ne20, mg24, si28, s32, ar36, ca40, ti44, cr48, fe52, ni56 + 7.1119142075E-01 9.3180507858E-05 2.7341075111E-01 ... + 7.1119141814E-01 9.3180815248E-05 2.7341075311E-01 ... + 7.0179434509E-01 3.6580185766E-06 2.8264795926E-01 ... + ... + +If the phantom dump is called `foo_0000`, the .comp file should be called `foo_0000.comp` +or simply `foo.comp` if the composition is constant on each particle. + +This file is automatically read by splash and used to create extra columns in the visualisation. + +See also +-------- + +- :doc:`Setting up stars and tidal disruption events ` diff --git a/docs/physics/index.rst b/docs/physics/index.rst index 99161f5f4..48b833fad 100644 --- a/docs/physics/index.rst +++ b/docs/physics/index.rst @@ -10,4 +10,5 @@ are described in the `code paper Date: Wed, 13 Mar 2024 09:43:45 +1100 Subject: [PATCH 319/814] (shamrock) fix compatibility issues reading dump file with only one block, or with MHD arrays in block 1 instead of block 4 --- src/main/readwrite_dumps_fortran.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index b583ac2be..065057bca 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -752,7 +752,7 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie write (*,*) 'WARNING! readdump: MHD data not present in dumpfile' !ierr = 7 !return - elseif (narraylengths < 2 .or. narraylengths > 4) then + elseif (narraylengths < 1 .or. narraylengths > 4) then write (*,*) 'error 7 in readdump, narraylengths=',narraylengths ierr = 7 return @@ -1268,7 +1268,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto case(2) call read_array(xyzmh_ptmass,xyzmh_ptmass_label,got_sink_data,ik,1,nptmass,0,idisk1,tag,match,ierr) call read_array(vxyz_ptmass, vxyz_ptmass_label, got_sink_vels,ik,1,nptmass,0,idisk1,tag,match,ierr) - case(4) + 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) end select From 566e261d3e267f1c5d18f8da5da53b1464b42771 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 15 Mar 2024 16:16:04 +1100 Subject: [PATCH 320/814] (analysis_radiotde) calculate gas-only entropy --- src/utils/analysis_radiotde.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index ac228be09..00c09030b 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -6,11 +6,11 @@ !--------------------------------------------------------------------------! module analysis ! -! Computes the outflow profile in a TDE simulation +! Computes the properties of shock formed in radio TDE ! ! :References: None ! -! :Owner: Fitz) Hu +! :Owner: Fitz Hu ! ! :Runtime parameters: ! - drad_cap : *capture thickness (in cm) (-ve for all particles at outer radius)* From e0b624b041449c26e85ef285b8880e254b572b90 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 15 Mar 2024 16:17:29 +1100 Subject: [PATCH 321/814] (analysis_tdeoutflow) capture temporal tde outflow properties as a fixed radius --- src/utils/analysis_tdeoutflow.f90 | 293 ++++++++++++++++++++++++++++++ 1 file changed, 293 insertions(+) create mode 100644 src/utils/analysis_tdeoutflow.f90 diff --git a/src/utils/analysis_tdeoutflow.f90 b/src/utils/analysis_tdeoutflow.f90 new file mode 100644 index 000000000..e0a0265fc --- /dev/null +++ b/src/utils/analysis_tdeoutflow.f90 @@ -0,0 +1,293 @@ +!--------------------------------------------------------------------------! +! 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 analysis +! +! Computes the outflow profile in a TDE simulation +! +! :References: None +! +! :Owner: Fitz Hu +! +! :Runtime parameters: +! - drad_cap : *capture thickness (in cm) (-ve for all particles at outer radius)* +! - phi_max : *max phi (in deg)* +! - phi_min : *min phi (in deg)* +! - rad_cap : *capture inner radius (in cm)* +! - theta_max : *max theta (in deg)* +! - theta_min : *min theta (in deg)* +! - v_max : *max velocity (in c)* +! - v_min : *min velocity (in c)* +! +! :Dependencies: infile_utils, io, physcon, readwrite_dumps, units +! + implicit none + character(len=10), parameter, public :: analysistype = 'tdeoutflow' + public :: do_analysis + + private + + character(len=7) :: ana + real, dimension(:), allocatable :: rad_all,vr_all,v_all + real, dimension(:), allocatable :: theta,plot_theta,phi,vr,vtheta,vphi + logical, dimension(:), allocatable :: cap + real :: m_accum, m_cap + real :: vr_accum_mean, vr_accum_max, vr_cap_mean, vr_cap_max + real :: r_accum_maxv, r_cap_maxv + real :: v_accum_mean, v_cap_mean + real :: e_accum, e_cap + integer :: n_accum, n_cap + real :: shock_v, rad_min, rad_max, shock_e, shock_m!, shock_rho + real :: shock_v_tde, rad_min_tde, rad_max_tde, shock_e_tde, shock_m_tde!, shock_rho + real :: shock_v_cnm, rad_min_cnm, rad_max_cnm, shock_e_cnm, shock_m_cnm!, shock_rho + + !---- These can be changed in the params file + real :: rad_cap = 1.e16 ! radius where the outflow in captured (in cm) + real :: drad_cap = 4.7267e14 ! thickness of the shell to capture outflow (in cm) + real :: v_min = 0. + real :: v_max = 1. + real :: theta_min = -180. + real :: theta_max = 180. + real :: phi_min = -90. + real :: phi_max = 90. + + !--- shock detection global var + integer :: npart_cnm = -1, npart_tde, npart_tde_reserve=-1 + real, allocatable :: ent_bg(:) + logical, allocatable :: counted(:),accreted(:) + real :: told,r_in=1.e14 + logical :: first = .true. + +contains + +subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) + use readwrite_dumps, only: opened_full_dump + use units, only: udist,utime,unit_energ,umass!,unit_density + use physcon, only: solarm,days,c + use part, only: pxyzu + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: numfile,npart,iunit + real, intent(in) :: xyzh(:,:),vxyzu(:,:) + real, intent(in) :: pmass,time + character(len=120) :: output + character(len=30) :: filename,outfile + integer :: i,ierr,npart_new,npart_tde_old + logical :: iexist + real :: toMsun,todays,dt + real :: mout,vrout,vout,macc + + toMsun = umass/solarm + todays = utime/days + + if (.not.opened_full_dump) then + write(*,'("SKIPPING FILE -- (Not a full dump)")') + return + endif + +! Print the analysis being done + write(*,'(" Performing analysis type ",A)') analysistype + write(*,'(" Input file name is ",A)') dumpfile + + ! Read black hole mass from params file + filename = 'analysis_'//trim(analysistype)//'.params' + inquire(file=filename,exist=iexist) + if (iexist) call read_tdeparams(filename,ierr) + if (.not.iexist.or.ierr/=0) then + call write_tdeparams(filename) + print*,' Edit '//trim(filename)//' and rerun phantomanalysis' + stop + endif + + ! input to code unit + r_in = r_in / udist + + ! allocate memory + if (allocated(rad_all)) deallocate(rad_all(npart),vr_all(npart),v_all(npart)) + allocate(rad_all(npart),vr_all(npart),v_all(npart)) + call to_rad(npart,xyzh,vxyzu,rad_all,vr_all,v_all) + + write(*,'(a)') ' Analysing the outflow ...' + + print*, 'Counting outflow from', r_in + + if (first) then + allocate(counted(npart),accreted(npart)) + counted = .false. + accreted = .false. + mout = 0. + vrout = 0. + vout = 0. + macc = 0. + dt = 1. + else + call outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all,mout,vrout,vout,macc) + dt = time - told + endif + told = time + + outfile='outflow' + inquire(file=outfile,exist=iexist) + if (iexist .and. .not. first) then + open(iunit,file=outfile,status='old',access='append') + elseif (iexist) then + open(iunit,file=outfile,status='replace') + else + open(iunit,file=outfile,status='new') + endif + + if (first) then + write(iunit,"('#',5(1x,'[',i2.2,1x,a11,']',2x))") & + 1,'time [s]', & + 2,'mout [g/s]', & + 3,'vrout [cm/s]', & + 4,'vout [cm/s]', & + 5,'macc [g/s]' + endif + + write(iunit,'(5(es18.10,1X))') & + time*utime, & + mout/dt*umass/utime, & + vrout, & + vout, & + macc/dt*umass/utime + close(iunit) + first = .false. + +end subroutine do_analysis + +subroutine to_rad(npart,xyzh,vxyzu,rad,vr,v) + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:),vxyzu(:,:) + real, intent(out) :: rad(:),vr(:),v(:) + integer :: i + real :: xyz(1:3),vxyz(1:3) + + do i = 1,npart + xyz = xyzh(1:3,i) + vxyz = vxyzu(1:3,i) + rad(i) = sqrt(dot_product(xyz,xyz)) + vr(i) = dot_product(xyz,vxyz)/rad(i) + v(i) = sqrt(dot_product(vxyz,vxyz)) + enddo + +end subroutine to_rad +!-------------------------------------------------------------------------------------------------------------------- +! +!-- Actual subroutine where the analysis is done! +! +!-------------------------------------------------------------------------------------------------------------------- +subroutine outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all,mout,vrout,vout,macc) + use io, only: fatal + use part, only:isdead_or_accreted + integer, intent(in) :: npart + real, intent(in) :: pmass,xyzh(:,:),vxyzu(:,:),rad_all(:),vr_all(:),v_all(:) + real, intent(out) :: mout,vrout,vout,macc + integer :: i,nout,nacc + real :: ri,vi,x,y,z + real :: thetai,phii,vri + real :: vrsum,vsum + + nout = 0 + nacc = 0 + vrsum = 0. + vsum = 0. + + do i = 1,npart + ri = rad_all(i) + vi = v_all(i) + vri = vr_all(i) + if (isdead_or_accreted(xyzh(4,i))) then + nacc = nacc + 1 + accreted(i) = .true. + elseif (ri > r_in) then + if (.not. counted(i)) then + if (theta_min < -180. .or. theta_min > 180.) theta_min = -180. + if (theta_max < theta_min .or. theta_max > 180.) theta_max = 180. + if (phi_min < -90. .or. phi_min > 90.) phi_min = -90. + if (phi_max < phi_min .or. phi_max > 90.) phi_max = 90. + + x = xyzh(1,i) + y = xyzh(2,i) + z = xyzh(3,i) + thetai = atan2d(y,x) + phii = atan2d(z,sqrt(x**2+y**2)) + + if ((thetai >= theta_min .and. thetai <= theta_max) .and. (phii >= phi_min .and. phii <= phi_max)) then + nout = nout + 1 + vrsum = vrsum + vri + vsum = vsum + vi + endif + counted(i) = .true. + endif + else + counted(i) = .false. + endif + enddo + mout = nout * pmass + vrout = vrsum / nout + vout = vsum / nout + macc = nacc * pmass + +end subroutine outflow_analysis + +!---------------------------------------------------------------- +!+ +! Read/write tde information from/to params file +!+ +!---------------------------------------------------------------- +subroutine write_tdeparams(filename) + use infile_utils, only:write_inopt + character(len=*), intent(in) :: filename + integer, parameter :: iunit = 20 + + print "(a)",' writing analysis options file '//trim(filename) + open(unit=iunit,file=filename,status='replace',form='formatted') + write(iunit,"(a,/)") '# options when performing TDE outflow analysis' + + call write_inopt(r_in,'r_in','radius to count outflow (in cm)',iunit) + + call write_inopt(theta_min,'theta_min','min theta (in deg) (-ve = ignore)',iunit) + call write_inopt(theta_max,'theta_max','max theta (in deg) (-ve = ignore)',iunit) + + call write_inopt(phi_min,'phi_min','min phi (in deg) (-ve = ignore)',iunit) + call write_inopt(phi_max,'phi_max','max phi (in deg) (-ve = ignore)',iunit) + + close(iunit) + +end subroutine write_tdeparams + +subroutine read_tdeparams(filename,ierr) + use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db + use io, only:error + character(len=*), intent(in) :: filename + integer, intent(out) :: ierr + integer, parameter :: iunit = 21 + integer :: nerr + type(inopts), allocatable :: db(:) + + print "(a)",' reading analysis options from '//trim(filename) + nerr = 0 + ierr = 0 + call open_db_from_file(db,filename,iunit,ierr) + + call read_inopt(r_in,'r_in',db,min=0.,errcount=nerr) + + call read_inopt(theta_min,'theta_min',db,max=360.,errcount=nerr) + call read_inopt(theta_max,'theta_max',db,max=360.,errcount=nerr) + + call read_inopt(phi_min,'phi_min',db,max=180.,errcount=nerr) + call read_inopt(phi_max,'phi_max',db,max=180.,errcount=nerr) + + call close_db(db) + if (nerr > 0) then + print "(1x,i2,a)",nerr,' error(s) during read of params file: re-writing...' + ierr = nerr + endif + +end subroutine read_tdeparams + +end module analysis + From 7e65f60d5b9134aefc6ff2e33a8a601547edba75 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 15 Mar 2024 16:18:20 +1100 Subject: [PATCH 322/814] (moddump_radiotde) calculate gas-only entropy --- src/utils/moddump_radiotde.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 14a77b8dc..5bea8c7ec 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -233,7 +233,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) if (read_temp) temperature = get_temp_r(r,rad_prof,temp_prof) vxyzu(4,i) = uerg(rhof(r),temperature) vxyzu(1:3,i) = 0. ! stationary for now - pxyzu(4,i) = (kb_on_mh / mu * log(temperature**1.5/rhof(r)) + 4.*radconst*temperature**3 / (3.*rhof(r))) / kboltz/ unit_ergg + pxyzu(4,i) = (kb_on_mh / mu * log(temperature**1.5/(rhof(r)*unit_density))) / kboltz/ unit_ergg enddo !--Set timesteps From 85c230bbea3ff9e08aebfac147cb8a1a2d05dac9 Mon Sep 17 00:00:00 2001 From: fhu Date: Fri, 15 Mar 2024 16:19:01 +1100 Subject: [PATCH 323/814] Revert "(analysis_radiotde) calculate gas-only entropy" This reverts commit b516e6c0fd69e7875cbb00568c83ac7db92f8b93. --- src/utils/analysis_radiotde.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 00c09030b..ac228be09 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -6,11 +6,11 @@ !--------------------------------------------------------------------------! module analysis ! -! Computes the properties of shock formed in radio TDE +! Computes the outflow profile in a TDE simulation ! ! :References: None ! -! :Owner: Fitz Hu +! :Owner: Fitz) Hu ! ! :Runtime parameters: ! - drad_cap : *capture thickness (in cm) (-ve for all particles at outer radius)* From 93253ef359a41a0b5ecc5179b9dbd5c92d86fd31 Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Mon, 25 Mar 2024 09:40:36 +0100 Subject: [PATCH 324/814] modif porosity --- src/main/porosity.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 35db4f32b..e58aba902 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -519,9 +519,9 @@ subroutine get_filfac_col(i,rho,mfrac,graindens,dustgasprop,filfaccol) m5 = (9.*nu*rho/(2.*graindens*smono**2*Omega_k(i)))**1.5 / m2**(0.5*cratio) if (m4 < m5) then !- filling factor: Epstein regime - St>1 - filfaccol = 0.5*m1**(cratio+0.125) * m4**0.075 / mfrac**0.2 + filfaccol = m1**(cratio+0.125) * m4**0.075 / mfrac**0.2 else !- filling factor: Stokes regime - St>1 - filfaccol = 0.5*m2**cratio * (m5/mfrac)**0.2 + filfaccol = m2**cratio * (m5/mfrac)**0.2 endif endif From 8cb88424c657fb0d65d0e748c7c6fe2b8c0c5b6b Mon Sep 17 00:00:00 2001 From: Stephane Michoulier Date: Mon, 25 Mar 2024 11:40:14 +0100 Subject: [PATCH 325/814] bugs correction due to the merge --- src/main/force.F90 | 4 ---- src/main/readwrite_dumps_fortran.F90 | 1 + src/main/readwrite_infile.F90 | 1 + 3 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/main/force.F90 b/src/main/force.F90 index da22b288e..0d3e6ac1e 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -916,7 +916,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g use part, only:ndustsmall,grainsize,graindens,ndustsmall,grainsize,graindens,filfac use options, only:use_porosity use growth, only:get_size -#ifdef DUSTGROWTH use kernel, only:wkern,cnormk #ifdef IND_TIMESTEPS use part, only:ibin_old,iamboundary @@ -1877,7 +1876,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g else call get_ts(idrag,1,get_size(grainmassi,graindensi),graindensi,rhoj,rhoi,spsoundj,dv2,tsijtmp,iregime) endif -#ifdef DUSTGROWTH if (q2i < q2j) then winter = wkern(q2i,qi)*hi21*hi1*cnormk else @@ -2550,7 +2548,6 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv use metric_tools, only:unpack_metric use utils_gr, only:get_u0 use io, only:error -#ifdef DUSTGROWTH use growth, only:get_size use dust, only:idrag,get_ts use physcon, only:fourpi @@ -2621,7 +2618,6 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv logical :: allow_decrease,dtcheck character(len=16) :: dtchar #endif -#ifdef DUSTGROWTH real :: tstopint,gmassi,gdensi integer :: ireg integer :: ip,i diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 7ee5605fe..2d80c89b4 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -1142,6 +1142,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto nucleation,nucleation_label,n_nucleation,ikappa,tau,itau_alloc,tau_lucy,itauL_alloc,& ithick,ilambda,iorig,dt_in,krome_nmols,T_gas_cool 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 real, intent(in) :: massoftype(:) integer, intent(in) :: nptmass,nsinkproperties diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 0e43f3b7b..e672ad128 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -322,6 +322,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) use linklist, only:read_inopts_link use dust, only:read_options_dust use growth, only:read_options_growth + use options, only:use_porosity use porosity, only:read_options_porosity use metric, only:read_options_metric #ifdef INJECT_PARTICLES From c56eed82a58dab1ea3521dccefbc8b21c2ca5836 Mon Sep 17 00:00:00 2001 From: StephaneMichoulier Date: Mon, 25 Mar 2024 14:52:29 +0100 Subject: [PATCH 326/814] Update porosity.f90 Add references --- src/main/porosity.f90 | 56 +++++++------------------------------------ 1 file changed, 9 insertions(+), 47 deletions(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 4a5f795d1..6b266d666 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -1,4 +1,13 @@ module porosity +! +! Contains routine for porosity evolution (growth, bouncing, fragmentation, compaction, disruption) +! +! :References: +! Okuzumi et al. (1997), ApJ 752, 106 +! Garcia, Gonzalez (2020), MNRAS 493, 1788 +! Tatsuuma et Kataoka (2021), ApJ 913, 132 +! Michoulier & Gonzalez (2022), Icarus 517, 3064 +! use units, only:umass,udist,unit_energ,unit_pressure,unit_density use physcon, only:Ro,pi,fourpi,roottwo implicit none @@ -387,53 +396,6 @@ subroutine get_filfac_frag(mprev,dustprop,filfac,dustgasprop,rhod,VrelVf,dt,filf case (0) ! Fragmentation at constant filling factor filfacfrag = filfac -! case (1) -! ! model Fit1ncoll -! sdust = get_size(mprev,dustprop(2),filfac) -! vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) -! ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev -! -! compfactor = (3.*0.3*filfac**(-0.2))*exp(1.5*(0.3-VrelVf)) + 1. -! filfacfrag = filfac*compfactor**ncoll -! case (2) -! ! model Fit2ncoll -! sdust = get_size(mprev,dustprop(2),filfac) -! vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) -! ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev -! -! compfactor = 27.*filfac**(-0.2)*VrelVf**(1.5)/(2.*exp(4.*VrelVf)-1.) + 1. -! filfacfrag = filfac*compfactor**ncoll -! case (3) -! ! model Garcia -! sdust = get_size(mprev,dustprop(2),filfac) -! vol = fourpi/3. * sdust**3 -! vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) -! ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev -! -! ekin = mprev*vrel*vrel/4. -! -! if (filfac >= 0.01) then -! pdyn = Yd0*filfac**Ydpow -! else -! pdyn = Yd0*0.01**Ydpow -! endif -! -! deltavol = ekin/pdyn -! -! if (deltavol >= vol) deltavol = vol -! -! filfacfrag = filfac *(1./(1.-0.5*deltavol/vol))**ncoll -! case (4) -! !model Fit1 + garcia -! sdust = get_size(mprev,dustprop(2),filfac) -! vol = fourpi/3. * sdust**3 -! vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) -! ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev -! -! compfactor = (3.*0.3*filfac**(-0.2))*exp(1.5*(0.3-VrelVf)) + 1. -! deltavol = vol - dustprop(1)*vol/mprev/compfactor -! filfacfrag = filfac *(1./(1.-deltavol/vol))**ncoll -! case (1) ! model Garcia + Kataoka mod sdust = get_size(mprev,dustprop(2),filfac) From fb1d4bc5953bb957326195959ce923ea33c33bda Mon Sep 17 00:00:00 2001 From: StephaneMichoulier Date: Mon, 25 Mar 2024 14:53:01 +0100 Subject: [PATCH 327/814] Update porosity.f90 Add references --- src/main/porosity.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 6b266d666..83d1e514a 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -6,7 +6,7 @@ module porosity ! Okuzumi et al. (1997), ApJ 752, 106 ! Garcia, Gonzalez (2020), MNRAS 493, 1788 ! Tatsuuma et Kataoka (2021), ApJ 913, 132 -! Michoulier & Gonzalez (2022), Icarus 517, 3064 +! Michoulier & Gonzalez (2022), MNRAS 517, 3064 ! use units, only:umass,udist,unit_energ,unit_pressure,unit_density use physcon, only:Ro,pi,fourpi,roottwo From 99a7583336bac18b3070d521c7f959f40bbe0004 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Sat, 30 Mar 2024 19:39:02 +0100 Subject: [PATCH 328/814] (star) fix sink read_inopt logic and bug with lcore not being read --- src/setup/set_star.f90 | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index fe24be09d..fa316c63f 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -700,11 +700,16 @@ 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.) + 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==2) star%isofteningopt=3 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.) star%mcore = mcore_msun*real(solarm/umass) @@ -712,11 +717,13 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) star%hsoft = hsoft_rsun*real(solarr/udist) endif else - star%isinkcore = .true. - call read_inopt(star%input_profile,'input_profile'//trim(c),db,errcount=nerr) call read_inopt(star%outputfilename,'outputfilename'//trim(c),db,errcount=nerr) - if (star%isoftcore==1) call read_inopt(star%isofteningopt,'isofteningopt'//trim(c),& - db,errcount=nerr,min=0) + if (star%isoftcore==2) then + star%isofteningopt=3 + elseif (star%isoftcore==1) then + call read_inopt(star%isofteningopt,'isofteningopt'//trim(c),db,errcount=nerr,min=0) + endif + if ((star%isofteningopt==1) .or. (star%isofteningopt==3)) then call read_inopt(rcore_rsun,'rcore'//trim(c),db,errcount=nerr,min=0.) star%rcore = rcore_rsun*real(solarr/udist) @@ -726,8 +733,6 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) call read_inopt(mcore_msun,'mcore'//trim(c),db,errcount=nerr,min=0.) star%mcore = mcore_msun*real(solarm/umass) endif - call read_inopt(lcore_lsun,'lcore'//trim(c),db,errcount=nerr,min=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.) From 8444d6637cf41188e2d3955d313124566ff6dce7 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 2 Apr 2024 11:34:52 +0200 Subject: [PATCH 329/814] new moddump that converts non-radiative dump to radiative dump --- src/utils/moddump_LTE_to_rad.f90 | 68 ++++++++++++++++++++++++++++++++ src/utils/moddump_rad_to_LTE.f90 | 4 -- 2 files changed, 68 insertions(+), 4 deletions(-) create mode 100644 src/utils/moddump_LTE_to_rad.f90 diff --git a/src/utils/moddump_LTE_to_rad.f90 b/src/utils/moddump_LTE_to_rad.f90 new file mode 100644 index 000000000..2d03902d9 --- /dev/null +++ b/src/utils/moddump_LTE_to_rad.f90 @@ -0,0 +1,68 @@ +!--------------------------------------------------------------------------! +! 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 moddump +! +! Convert non-radiation dump (assuming LTE, ieos=12) to radiation dump +! +! :References: None +! +! :Owner: Mike Lau +! +! :Runtime parameters: None +! +! :Dependencies: dim, eos, io, part +! + implicit none + +contains + +subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) + use units, only:unit_density,unit_opacity,unit_ergg + use dim, only:do_radiation + use io, only:fatal + use eos, only:gmw,gamma,X_in,Z_in + use eos_idealplusrad, only:get_idealplusrad_temp + use eos_mesa, only:init_eos_mesa + use part, only:igas,rad,iradxi,ikappa,rhoh,radprop,ithick + use radiation_utils, only:radiation_and_gas_temperature_equal,ugas_from_Tgas + use mesa_microphysics,only:get_kappa_mesa + integer, intent(inout) :: npart + integer, intent(inout) :: npartoftype(:) + real, intent(inout) :: massoftype(:) + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + integer :: i,ierr + real :: pmass,mu,rhoi,kappa_cgs,kapt,kapr,rho_cgs,ugasi,tempi,gamma_fixed + + if (.not. do_radiation) call fatal("moddump_LTE_to_rad","Not compiled with radiation") + + mu = gmw + gamma_fixed = 5/3. ! gamma should be exactly 5/3, because that is what ieos=12 assumes + gamma = gamma_fixed + print*,'Assuming gmw = ',mu,' and gamma=',gamma,'X = ',X_in,'Z = ',Z_in ! X and Z are only used for calculating opacity + call init_eos_mesa(X_in,Z_in,ierr) + + pmass = massoftype(igas) + do i=1,npart + rhoi = rhoh(xyzh(4,i),pmass) + rho_cgs = rhoi*unit_density + call get_idealplusrad_temp(rho_cgs,vxyzu(4,i)*unit_ergg,mu,tempi,ierr) + + ! calculate u and xi + ugasi = ugas_from_Tgas(tempi,gamma,gmw) + vxyzu(4,i) = ugasi + rad(iradxi,i) = radiation_and_gas_temperature_equal(rhoi,ugasi,gamma,mu) + + ! calculate opacity + call get_kappa_mesa(rho_cgs,tempi,kappa_cgs,kapt,kapr) + radprop(ikappa,i) = kappa_cgs/unit_opacity + radprop(ithick,i) = 1. + enddo + +end subroutine modify_dump + +end module moddump + diff --git a/src/utils/moddump_rad_to_LTE.f90 b/src/utils/moddump_rad_to_LTE.f90 index 6eff8ac4c..7b14b0ee0 100644 --- a/src/utils/moddump_rad_to_LTE.f90 +++ b/src/utils/moddump_rad_to_LTE.f90 @@ -37,10 +37,6 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) vxyzu(4,i) = vxyzu(4,i) + rad(iradxi,i) enddo - ieos = 12 - gmw = 0.6 ! CHANGE MU HERE for writing into infile - print*,'mu has been changed to',gmw ! mu should not change from what was assumed with radiation - end subroutine modify_dump end module moddump From bf9ef221abf92da311f65529987da0bf8724c60b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Apr 2024 13:11:44 +1100 Subject: [PATCH 330/814] add the option to integrate ptmass with 4th order scheme --- build/Makefile | 4 + src/main/config.F90 | 7 + src/main/ptmass.F90 | 243 ++++++++++++++++++++++ src/main/step_leapfrog.F90 | 398 ++++++++++++++++++++++++++++++++++++- 4 files changed, 649 insertions(+), 3 deletions(-) diff --git a/build/Makefile b/build/Makefile index 219f2eb0b..7056a4d0c 100644 --- a/build/Makefile +++ b/build/Makefile @@ -274,6 +274,10 @@ ifeq ($(RADIATION), yes) FPPFLAGS += -DRADIATION endif +ifeq ($(FOURTHORDER), yes) + FPPFLAGS += -DNBODYREG +endif + ifeq ($(SINK_RADIATION), yes) FPPFLAGS += -DSINK_RADIATION endif diff --git a/src/main/config.F90 b/src/main/config.F90 index 92faa467c..55b990fec 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -122,6 +122,13 @@ module dim logical, parameter :: do_radiation = .false. #endif + ! Regularisation method and/or higher order integrator +#ifdef FOURTHORDER + logical, parameter :: use_fourthorder = .true. +#else + logical, parameter :: use_fourthorder = .false. +#endif + ! rhosum integer, parameter :: maxrhosum = 39 + & maxdustlarge - 1 + & diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e36d26066..5a82d13c1 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -46,6 +46,7 @@ module ptmass public :: init_ptmass, finish_ptmass public :: pt_write_sinkev, pt_close_sinkev public :: get_accel_sink_gas, get_accel_sink_sink + public :: get_gradf_sink_gas, get_gradf_sink_sink public :: merge_sinks public :: ptmass_predictor, ptmass_corrector public :: ptmass_not_obscured @@ -110,6 +111,27 @@ module ptmass private contains + +!---------------------------------------------------------------- +!+ +! Kernel for gradient force calculation, necessary for the FSI +!+ +!---------------------------------------------------------------- +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4,q6 + + if (q<1.) then + gsoft = q*(-15.*q2*q-24.*q2)/10. + else + q4 = q2*q2 + q6 = q4*q2 + gsoft = (25.*q6-120.*q4*q+150.*q4-10.)/(50.*q2) + endif + +end subroutine kernel_grad_soft + !---------------------------------------------------------------- !+ ! if (tofrom==.true.) Acceleration from/to gas particles due to sink particles; @@ -469,6 +491,227 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin enddo end subroutine get_accel_sink_sink + +!---------------------------------------------------------------- +!+ +! get gradient correction of the force for FSI integrator (sink-gas) +!+ +!---------------------------------------------------------------- +subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & + pmassi,fxyz_ptmass) + use kernel, only:kernel_softening,radkern + integer, intent(in) :: nptmass + real, intent(in) :: xi,yi,zi,hi,dt + real, intent(inout) :: fxi,fyi,fzi + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(in) :: pmassi + real, intent(inout) :: fxyz_ptmass(4,nptmass) + real :: gtmpxi,gtmpyi,gtmpzi + real :: dx,dy,dz,rr2,ddr,dr3,g11,g12,g21,g22,pmassj + real :: dfx,dfy,dfz,drdotdf + real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft,gpref + integer :: j + + gtmpxi = 0. ! use temporary summation variable + gtmpyi = 0. ! (better for round-off, plus we need this bit of + gtmpzi = 0. + + do j=1,nptmass + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + dfx = fxi - fxyz_ptmass(1,j) + dfy = fyi - fxyz_ptmass(2,j) + dfz = fzi - fxyz_ptmass(3,j) + pmassj = xyzmh_ptmass(4,j) + hsoft = xyzmh_ptmass(ihsoft,j) + if (hsoft > 0.0) hsoft = max(hsoft,hi) + if (pmassj < 0.0) cycle + + rr2 = dx*dx + dy*dy + dz*dz + epsilon(rr2) + drdotdf = dx*dfx + dy*dfy + dz*dfz + epsilon(drdotdf) + ddr = 1./sqrt(rr2) + if (rr2 < (radkern*hsoft)**2) then + ! + ! if the sink particle is given a softening length, soften the + ! force and potential if r < radkern*hsoft + ! + hsoft1 = 1.0/hsoft + hsoft21= hsoft1**2 + q2i = rr2*hsoft21 + qi = sqrt(q2i) + call kernel_softening(q2i,qi,psoft,fsoft) + + gpref = ((dt**2)/24.)*hsoft21 + + ! first grad term of gas due to point mass particle + g11 = pmassj*fsoft*ddr + + ! first grad term of sink from gas + g21 = pmassi*fsoft*ddr + + call kernel_grad_soft(q2i,qi,gsoft) + + dr3 = ddr*ddr*ddr + + ! Second grad term of gas due to point mass particle + g12 = pmassj*gsoft*dr3*drdotdf + + ! Second grad term of sink from gas + g22 = pmassi*gsoft*dr3*drdotdf + + gtmpxi = gtmpxi - gpref*(dfx*g11-dx*g12) + gtmpyi = gtmpyi - gpref*(dfy*g11-dy*g12) + gtmpzi = gtmpzi - gpref*(dfz*g11-dz*g12) + + + else + ! no softening on the sink-gas interaction + dr3 = ddr*ddr*ddr + + gpref = ((dt**2)/24.) + + ! first grad term of gas due to point mass particle + g11 = pmassj*dr3 + + ! first grad term of sink from gas + g21 = pmassi*dr3 + + ! first grad term of gas due to point mass particle + g12 = 3*pmassj*dr3*ddr*ddr*drdotdf + + ! first grad term of sink from gas + g22 = 3*pmassi*dr3*ddr*ddr*drdotdf + + + gtmpxi = gtmpxi - gpref*(dfx*g11-dx*g12) + gtmpyi = gtmpyi - gpref*(dfy*g11-dy*g12) + gtmpzi = gtmpzi - gpref*(dfz*g11-dz*g12) + endif + + ! backreaction of gas onto sink + fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + gpref*(dfx*g21 - dx*g22) + fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + gpref*(dfy*g21 - dy*g22) + fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + gpref*(dfz*g21 - dz*g22) + enddo + ! + ! add temporary sums to existing force on gas particle + ! + fxi = fxi + gtmpxi + fyi = fyi + gtmpyi + fzi = fzi + gtmpzi + +end subroutine get_gradf_sink_gas + +!---------------------------------------------------------------- +!+ +! get gradient correction of the force for FSI integrator (sink-gas) +!+ +!---------------------------------------------------------------- +subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) + use kernel, only:kernel_softening,radkern + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(inout) :: fxyz_ptmass(4,nptmass) + real, intent(in) :: dt + real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,gxi,gyi,gzi + real :: ddr,dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,dr3,g1,g2 + real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft + real :: gpref + integer :: i,j + + if (nptmass <= 1) return + if (h_soft_sinksink > 0.) then + hsoft1 = 1.0/h_soft_sinksink + hsoft21= hsoft1**2 + else + hsoft1 = 0. ! to avoid compiler warnings + hsoft21 = 0. + endif + ! + !--compute N^2 gradf on point mass particles due to each other + ! + !$omp parallel do default(none) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass) & + !$omp shared(h_soft_sinksink,hsoft21,dt) & + !$omp private(i,xi,yi,zi,pmassi,pmassj) & + !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & + !$omp private(fxi,fyi,fzi,gxi,gyi,gzi,gpref) & + !$omp private(q2i,qi,psoft,fsoft,gsoft) + do i=1,nptmass + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + pmassi = xyzmh_ptmass(4,i) + if (pmassi < 0.) cycle + fxi = fxyz_ptmass(1,i) + fyi = fxyz_ptmass(2,i) + fzi = fxyz_ptmass(3,i) + gxi = 0. + gyi = 0. + gzi = 0. + do j=1,nptmass + if (i==j) cycle + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + dfx = fxi - fxyz_ptmass(1,j) + dfy = fyi - fxyz_ptmass(2,j) + dfz = fzi - fxyz_ptmass(3,j) + pmassj = xyzmh_ptmass(4,j) + if (pmassj < 0.) cycle + + rr2 = dx*dx + dy*dy + dz*dz + epsilon(rr2) + drdotdf = dx*dfx + dy*dfy + dz*dfz +epsilon(drdotdf) + ddr = 1./sqrt(rr2) + + gpref = pmassj*((dt**2)/24.) + + if (rr2 < (radkern*h_soft_sinksink)**2) then + ! + ! if the sink particle is given a softening length, soften the + ! force and potential if r < radkern*h_soft_sinksink + ! + q2i = rr2*hsoft21 + qi = sqrt(q2i) + call kernel_softening(q2i,qi,psoft,fsoft) ! Note: psoft < 0 + + + ! gradf part 1 of sink1 from sink2 + g1 = fsoft*hsoft21*ddr + + call kernel_grad_soft(q2i,qi,gsoft) + + dr3 = ddr*ddr*ddr + + ! gradf part 2 of sink1 from sink2 + g2 = gsoft*hsoft21*dr3*drdotdf + gxi = gxi - gpref*(dfx*g1 - dx*g2) + gyi = gyi - gpref*(dfy*g1 - dy*g2) + gzi = gzi - gpref*(dfz*g1 - dz*g2) + + else + ! no softening on the sink-sink interaction + dr3 = ddr*ddr*ddr + + ! gradf part 1 of sink1 from sink2 + g1 = dr3 + ! gradf part 2 of sink1 from sink2 + g2 = 3*dr3*ddr*ddr*drdotdf + gxi = gxi - gpref*(dfx*g1 - dx*g2) + gyi = gyi - gpref*(dfy*g1 - dy*g2) + gzi = gzi - gpref*(dfz*g1 - dz*g2) + endif + enddo + ! + !--store sink-sink forces (only) + ! + fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + gxi + fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + gyi + fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + gzi + enddo +!$omp end parallel do +end subroutine get_gradf_sink_sink !---------------------------------------------------------------- !+ ! Update position of sink particles if they cross the periodic boundary diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 70e4376dd..2380b7718 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -90,7 +90,7 @@ 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_fourthorder 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, & @@ -233,8 +233,13 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif else if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then - call step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) + if (use_fourthorder) then + call step_extern_FSI(dtextforce,dtsph,t,npart,nptmass,xyzh,vxyzu,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + else + call step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & + nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) + endif else call step_extern_sph(dtsph,npart,xyzh,vxyzu) endif @@ -1048,6 +1053,393 @@ subroutine step_extern_sph(dt,npart,xyzh,vxyzu) end subroutine step_extern_sph +!---------------------------------------------------------------- +!+ +! This is the equivalent of the routine below with no cooling +! and external forces except ptmass. (4th order scheme) +!+ +!---------------------------------------------------------------- +subroutine step_extern_PEFRL(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + use part, only: isdead_or_accreted,igas,massoftype + use io, only:iverbose,id,master,iprint,warning,fatal + use io_summary, only:summary_variable,iosumextr,iosumextt + real, intent(in) :: dtsph,time + integer, intent(in) :: npart,nptmass + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + real,parameter :: ck(5) = (/0.1786178958448091,-0.06626458266981849,0.77529337365001878,-0.06626458266981849,0.1786178958448091/) + real,parameter :: dk(4) = (/0.7123418310626054,-0.2123418310626054,-0.2123418310626054,0.7123418310626054/) + real :: dt,t_end_step,dtextforce_min + real :: pmassi,timei + logical :: done,last_step + integer :: nsubsteps + integer :: i + + ! + ! determine whether or not to use substepping + ! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + + timei = time + pmassi = massoftype(igas) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + + substeps: do while (timei <= t_end_step .and. .not.done) + timei = timei + dt + if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + nsubsteps = nsubsteps + 1 + do i=1,4 + call drift_4th(ck(i),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + call kick_4th (dk(i),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + enddo + call drift_4th(ck(5),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + + if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"dt : ",dt + dtextforce_min = min(dtextforce_min,dtextforce) + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + enddo substeps + + if (nsubsteps > 1) then + if (iverbose>=1 .and. id==master) then + write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + + +end subroutine step_extern_PEFRL + +!---------------------------------------------------------------- +!+ +! This is the equivalent of the routine below with no cooling +! and external forces except ptmass. (4th order scheme) +!+ +!---------------------------------------------------------------- +subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + use part, only: isdead_or_accreted,igas,massoftype + use io, only:iverbose,id,master,iprint,warning,fatal + use io_summary, only:summary_variable,iosumextr,iosumextt + real, intent(in) :: dtsph,time + integer, intent(in) :: npart,nptmass + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) + real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) + real,parameter :: ck(2) = (/0.5,0.5/) + real :: dt,t_end_step,dtextforce_min + real :: pmassi,timei + logical :: done,last_step + integer :: nsubsteps + + ! + ! determine whether or not to use substepping + ! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + + timei = time + pmassi = massoftype(igas) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + + substeps: do while (timei <= t_end_step .and. .not.done) + timei = timei + dt + if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + nsubsteps = nsubsteps + 1 + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + call kick_4th (dk(1),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call drift_4th(ck(1),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Direct calculation of the force and force gradient + call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) + ! call get_force_extrapol_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + ! xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Extrapolation of the modified force using Omelyan technique + + call kick_4th (dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + !print*,xyzmh_ptmass(1,1:20) + call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + call kick_4th (dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt + + dtextforce_min = min(dtextforce_min,dtextforce) + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + enddo substeps + + if (nsubsteps > 1) then + if (iverbose>=1 .and. id==master) then + write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + + +end subroutine step_extern_FSI + + +!---------------------------------------------------------------- +!+ +! drift routine for the 4th order scheme +!+ +!---------------------------------------------------------------- + +subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + use part, only: isdead_or_accreted,ispinx,ispiny,ispinz + real, intent(in) :: dt,ck + integer, intent(in) :: npart,nptmass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) + integer :: i + + ! Drift gas particles + + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,vxyzu,dt,ck) & + !$omp private(i) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + xyzh(1,i) = xyzh(1,i) + ck*dt*vxyzu(1,i) + xyzh(2,i) = xyzh(2,i) + ck*dt*vxyzu(2,i) + xyzh(3,i) = xyzh(3,i) + ck*dt*vxyzu(3,i) + endif + enddo + !$omp end parallel do + + ! Drift sink particles + + !$omp parallel do default(none) & + !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ck,dt) & + !$omp private(i) + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ck*dt*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ck*dt*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ck*dt*vxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + ck*dt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + ck*dt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + ck*dt*dsdt_ptmass(3,i) + endif + enddo + !$omp end parallel do +end subroutine drift_4th + + +!---------------------------------------------------------------- +!+ +! kick routine for the 4th order scheme +!+ +!---------------------------------------------------------------- + +subroutine kick_4th(dk,dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + use part, only: isdead_or_accreted,ispinx,ispiny,ispinz + real, intent(in) :: dt,dk + integer, intent(in) :: npart,nptmass + real, intent(in) :: xyzh(:,:) + real, intent(inout) :: vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + integer :: i + + ! Kick gas particles + + !$omp parallel do default(none) & + !$omp shared(npart,fext,xyzh,vxyzu,dt,dk) & + !$omp private(i) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + vxyzu(1,i) = vxyzu(1,i) + dk*dt*fext(1,i) + vxyzu(2,i) = vxyzu(2,i) + dk*dt*fext(2,i) + vxyzu(3,i) = vxyzu(3,i) + dk*dt*fext(3,i) + endif + enddo + !$omp end parallel do + + ! Kick sink particles + + !$omp parallel do default(none) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,dsdt_ptmass,dk,dt) & + !$omp private(i) + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dk*dt*fxyz_ptmass(1,i) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dk*dt*fxyz_ptmass(2,i) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dk*dt*fxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dk*dt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dk*dt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dk*dt*dsdt_ptmass(3,i) + endif + enddo + !$omp end parallel do + +end subroutine kick_4th + +!---------------------------------------------------------------- +!+ +! force routine for the 4th order scheme +!+ +!---------------------------------------------------------------- + +subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + use options, only:iexternalforce + use dim, only:maxptmass + use io, only:iverbose,master,iprint,warning,fatal + use part, only:epot_sinksink,fxyz_ptmass_sinksink,dsdt_ptmass_sinksink + use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks + use timestep, only:bignumber,C_force + integer, intent(in):: nptmass,npart,nsubsteps + real, intent(inout) :: xyzh(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) + real, intent(inout) :: dtextforce + real, intent(in) :: timei,pmassi + integer :: merge_ij(nptmass) + integer :: merge_n + integer :: i + real :: dtf,dtextforcenew,dtsinkgas,dtphi2,fonrmax + real :: fextx,fexty,fextz + real :: fonrmaxi,phii,dtphi2i + + dtextforcenew = bignumber + dtsinkgas = bignumber + dtphi2 = bignumber + fonrmax = 0 + if (nptmass>0) then + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + endif + else + fxyz_ptmass(:,:) = 0. + dsdt_ptmass(:,:) = 0. + endif + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + dtextforcenew = min(dtextforcenew,C_force*dtf) + if (iverbose >= 3 ) write(iprint,*) "dt_sink_sink",dtextforcenew + !$omp parallel default(none) & + !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext) & + !$omp private(fextx,fexty,fextz) & + !$omp private(fonrmaxi,dtphi2i,phii,pmassi,dtf) & + !$omp reduction(min:dtextforcenew,dtsinkgas,dtphi2) & + !$omp reduction(max:fonrmax) & + !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) + !$omp do + do i=1,npart + fextx = 0. + fexty = 0. + fextz = 0. + call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,& + fextx,fexty,fextz,phii,pmassi,fxyz_ptmass,dsdt_ptmass,fonrmaxi,dtphi2i) + fonrmax = max(fonrmax,fonrmaxi) + dtphi2 = min(dtphi2,dtphi2i) + fext(1,i) = fextx + fext(2,i) = fexty + fext(3,i) = fextz + enddo + !$omp enddo + !$omp end parallel + + if (fonrmax > 0.) then + dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) + endif + if (iverbose >= 3 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas + dtextforcenew = min(dtextforcenew,dtsinkgas) + dtextforce = dtextforcenew + +end subroutine get_force_4th + + +!---------------------------------------------------------------- +!+ +! grad routine for the 4th order scheme (FSI) +!+ +!---------------------------------------------------------------- + + +subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) + use dim, only:maxptmass + use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink + integer, intent(in) :: nptmass,npart + real, intent(inout) :: xyzh(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) + real, intent(inout) :: dt + real, intent(in) :: pmassi + real :: fextx,fexty,fextz + integer :: i + + + if (nptmass>0) then + call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) + !print*,fxyz_ptmass(1,1:5) + else + fxyz_ptmass(:,:) = 0. + endif + + !$omp parallel default(none) & + !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,dt,pmassi) & + !$omp private(fextx,fexty,fextz) & + !$omp reduction(+:fxyz_ptmass) + !$omp do + do i=1,npart + fextx = 0. + fexty = 0. + fextz = 0. + call get_gradf_sink_gas(nptmass,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& + xyzmh_ptmass,fextx,fexty,fextz,pmassi,fxyz_ptmass) + fext(1,i) = fext(1,i)+ fextx + fext(2,i) = fext(2,i)+ fexty + fext(3,i) = fext(3,i)+ fextz + enddo + !$omp enddo + !$omp end parallel + +end subroutine get_gradf_4th + + !---------------------------------------------------------------- !+ ! Substepping of external and sink particle forces. From c782b8b4226ec7d2449c5668f1e43e635c763511 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Apr 2024 14:39:45 +1100 Subject: [PATCH 331/814] Add group indentification, first parts of TTL integration scheme and kepler utils.. --- build/Makefile | 4 + src/main/part.F90 | 22 +++ src/main/sdar_group.f90 | 315 ++++++++++++++++++++++++++++++++++++++ src/main/utils_kepler.f90 | 114 ++++++++++++++ src/main/utils_sdar.f90 | 17 ++ 5 files changed, 472 insertions(+) create mode 100644 src/main/sdar_group.f90 create mode 100644 src/main/utils_kepler.f90 create mode 100644 src/main/utils_sdar.f90 diff --git a/build/Makefile b/build/Makefile index 7056a4d0c..4d3da5a7a 100644 --- a/build/Makefile +++ b/build/Makefile @@ -275,6 +275,10 @@ ifeq ($(RADIATION), yes) endif ifeq ($(FOURTHORDER), yes) + FPPFLAGS += -DFOURTHORDER +endif + +ifeq ($(NBODYREG), yes) FPPFLAGS += -DNBODYREG endif diff --git a/src/main/part.F90 b/src/main/part.F90 index 27c6391f7..fe849c8d3 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -281,6 +281,23 @@ module part ! real(kind=4), allocatable :: luminosity(:) ! +!-- Regularisation algorithm allocation +! +#ifdef NBODYREG + integer, allocatable :: group_info(:,:) + integer(kind=1), allocatable :: nmatrix(:,:) + integer, parameter :: igarg = 1 ! idx of the particle member of a group + integer, parameter :: igid = 2 ! id of the group (may be unescessary) + integer, parameter :: igsize = 3 ! size of the group (may be unescessary) + integer, parameter :: igcum = 4 ! cumulative sum of the indices to find the starting and ending point of a group + ! needed for group identification and sorting + integer :: ngroup = 0 + integer :: n_ingroup = 0 + integer :: n_sing = 0 + ! Gradient of the time transformation function + real, allocatable :: gtgrad(:,:) +#endif +! !--derivatives (only needed if derivs is called) ! real, allocatable :: fxyzu(:,:) @@ -461,6 +478,9 @@ subroutine allocate_part call allocate_array('abundance', abundance, nabundances, maxp_h2) endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) + call allocate_array('group_info', group_info, 4, maxptmass) + call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) + call allocate_array("gtgrad", gtgrad, 3, maxptmass) end subroutine allocate_part @@ -533,6 +553,8 @@ subroutine deallocate_part if (allocated(ibelong)) deallocate(ibelong) if (allocated(istsactive)) deallocate(istsactive) if (allocated(ibin_sts)) deallocate(ibin_sts) + if (allocated(group_info)) deallocate(group_info) + if (allocated(nmatrix)) deallocate(nmatrix) end subroutine deallocate_part diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 new file mode 100644 index 000000000..3687c41c5 --- /dev/null +++ b/src/main/sdar_group.f90 @@ -0,0 +1,315 @@ +module sdar_group +! +! this module contains everything to identify +! and integrate regularized groups... +! +! :References: Makino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 +! +! :Owner: Daniel Price +! + implicit none + public :: group_identify + public :: evolve_groups + ! parameters for group identification + real, public :: r_neigh = 0.0 + real, public :: t_crit = 0.0 + real, public :: C_bin = 0.0 + real, public :: r_search = 0.0 + private +contains + +! +! +! Group identification routines +! +! +subroutine group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(in) :: group_info(:,:) + integer(kind=1), intent(inout) :: nmatrix(:,:) + integer, intent(in) :: nptmass + + ngroup = 0 + n_ingroup = 0 + n_sing = 0 + call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) + call form_group(group_info,nmatrix,nptmass) + +end subroutine group_identify + + +subroutine form_group(group_info,nmatrix,nptmass) + use part, only : igid,igarg,igsize,igcum + integer(kind=1), intent(in) :: nmatrix(:,:) + integer, intent(out):: group_info(:,:) + integer, intent(in) :: nptmass + integer :: i + logical :: visited(nptmass) + do i=1,nptmass + if(.not.visited(i)) then + n_ingroup = n_ingroup + 1 + call dfs(i,i,visited,group_info,nmatrix,nptmass,n_ingroup) + if (group_info(igsize,i)>1)then + ngroup = ngroup + 1 + group_info(igcum,ngroup+1) = group_info(igsize,i) + group_info(igcum,ngroup) + else + n_ingroup= n_ingroup - 1 + group_info(igsize,i) = 0 + group_info(igarg,nptmass-n_sing) = i + group_info(igid,nptmass-n_sing) = 0 + n_sing = n_sing + 1 + endif + endif + enddo +end subroutine form_group + +recursive subroutine dfs(inode,iroot,visited,group_info,nmatrix,npt,n_ingroup) + use part, only : igid,igarg,igsize,igcum + integer, intent(in) :: inode,npt,iroot + integer(kind=1), intent(in) :: nmatrix(:,:) + integer, intent(inout) :: group_info(:,:) + integer, intent(inout) :: n_ingroup + logical, intent(inout) :: visited(:) + integer :: j + !print*,nping,inode + group_info(igarg,n_ingroup) = inode + group_info(igid,n_ingroup) = iroot + group_info(igsize,iroot) = group_info(igsize,iroot)+1 + visited(inode) = .true. + do j=1,npt + if (nmatrix(inode,j)==1 .and. (visited(j).eqv..false.)) then + n_ingroup = n_ingroup + 1 + call dfs(j,iroot,visited,group_info,nmatrix,npt,n_ingroup) + endif + enddo +end subroutine dfs + + +subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) + use utils_kepler, only: bindE,extract_a,extract_e,extract_ea + integer(kind=1), intent(out):: nmatrix(:,:) + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(in) :: vxyz_ptmass(:,:) + integer, intent(in) :: nptmass + real :: xi,yi,zi,vxi,vyi,vzi,mi + real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu + real :: aij,eij,B,rperi + integer :: i,j + + nmatrix = 0. + + do i=1,nptmass + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + mi = xyzmh_ptmass(4,i) + vxi = vxyz_ptmass(1,i) + vyi = vxyz_ptmass(2,i) + vzi = vxyz_ptmass(3,i) + do j=1,nptmass + if(i==j) cycle + if(j>i) then + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) + if (rr_search) then + nmatrix(i,j) = 0 + cycle + endif + mu = mi + xyzmh_ptmass(4,j) + dvx = vxi - vxyz_ptmass(1,j) + dvy = vyi - vxyz_ptmass(2,j) + dvz = vzi - vxyz_ptmass(3,j) + v2 = dvx**2+dvy**2+dvz**2 + call bindE(v2,r,mu,B) + call extract_a(r,mu,v2,aij) + if (B<0) then + if (aij=1) then + eij = 0. + else + eij = sqrt(1-neg_e) + endif + +end subroutine extract_ea + +subroutine extract_kep_elmt(x,y,z,vx,vy,vz,mu,r,a,e,i,argp,longi,M) + real, intent(in) :: x,y,z,vx,vy,vz,mu,r + real, intent(out):: a,e,i,argp,longi,M + real :: hx,hy,hz,ex,ey,ez,v2,h,anoE,nu + real :: rdote,n,ndote + + v2 = vx**2+vy**2+vz**2 + + a = (r*mu)/(2*mu-r*v2) + + hx = y*vz-z*vy + hy = z*vx-x*vz + hz = x*vy-y*vx + + h = sqrt(hx*2+hy**2+hz**2) + i = acos(hz/h) + + ex = (vy*hz-vz*hy)/mu - x/r + ey = (vz*hx-vx*hz)/mu - y/r + ez = (vx*hy-hx*vy)/mu - z/r + + e = sqrt(ex**2+ey**2+ez**2) + + rdote = x*ex+y*ey+z*ez + + if (x*vx+y*vy+z*vz>=0) then + nu = acos(rdote/(e*r)) + else + nu = 2*pi - acos(rdote/(e*r)) + endif + anoE = tan(nu*0.5)/sqrt((1+e)/(1-e)) + anoE = 2*atan(anoE) + + M = E-e*sin(E) + + n = sqrt(hy**2+hx**2) + if (hx>=0) then + longi = acos(-hy/n) + else + longi = 2*pi - acos(-hy/n) + endif + + ndote = -hy*ex + hx*ey + if (ez>=0) then + argp = acos(ndote/(n*e)) + else + argp = 2*pi - acos(ndote/(n*e)) + endif + +end subroutine extract_kep_elmt + + + + +end module utils_kepler diff --git a/src/main/utils_sdar.f90 b/src/main/utils_sdar.f90 new file mode 100644 index 000000000..553489996 --- /dev/null +++ b/src/main/utils_sdar.f90 @@ -0,0 +1,17 @@ +module utils_sdar + implicit none + real, dimension(8),parameter :: ck=(/0.3922568052387800,0.5100434119184585,-0.4710533854097566,& + 0.0687531682525181,0.0687531682525181,-0.4710533854097566,& + 0.5100434119184585,0.3922568052387800/) + real, dimension(8),parameter :: cck_sorted=(/0.0976997828427615,0.3922568052387800,0.4312468317474820,& + 0.5000000000000000,0.5687531682525181,0.6077431947612200,& + 0.9023002171572385,1.0000000000000000/) + real, dimension(8),parameter :: dk=(/0.7845136104775600,0.2355732133593570,-1.1776799841788701,& + 1.3151863206839063,-1.1776799841788701,0.2355732133593570,& + 0.7845136104775600,0.0000000000000000/) + integer, dimension(8),parameter :: cck_sorted_id=(/6,1,3,4,5,7,2,8/) + + +contains + +end module utils_sdar From 0049d967cee378874bf03b24e46b8a27e8c541b0 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Apr 2024 14:43:05 +1100 Subject: [PATCH 332/814] Fix a wrong compiler flag name --- build/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build/Makefile b/build/Makefile index 7056a4d0c..de95a5bf7 100644 --- a/build/Makefile +++ b/build/Makefile @@ -275,7 +275,7 @@ ifeq ($(RADIATION), yes) endif ifeq ($(FOURTHORDER), yes) - FPPFLAGS += -DNBODYREG + FPPFLAGS += -DFOURTHORDER endif ifeq ($(SINK_RADIATION), yes) From c221ac496a966a45abc5de8030e6f00fec8e6be9 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Apr 2024 17:37:49 +1100 Subject: [PATCH 333/814] Remove ifdef + step_extern in a module --- build/Makefile | 4 - src/main/config.F90 | 8 - src/main/options.f90 | 6 + src/main/step_extern.f90 | 1278 ++++++++++++++++++++++++++++++++++++ src/main/step_leapfrog.F90 | 1237 +--------------------------------- 5 files changed, 1288 insertions(+), 1245 deletions(-) create mode 100644 src/main/step_extern.f90 diff --git a/build/Makefile b/build/Makefile index de95a5bf7..219f2eb0b 100644 --- a/build/Makefile +++ b/build/Makefile @@ -274,10 +274,6 @@ ifeq ($(RADIATION), yes) FPPFLAGS += -DRADIATION endif -ifeq ($(FOURTHORDER), yes) - FPPFLAGS += -DFOURTHORDER -endif - ifeq ($(SINK_RADIATION), yes) FPPFLAGS += -DSINK_RADIATION endif diff --git a/src/main/config.F90 b/src/main/config.F90 index 55b990fec..d85a33daf 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -121,14 +121,6 @@ module dim #else logical, parameter :: do_radiation = .false. #endif - - ! Regularisation method and/or higher order integrator -#ifdef FOURTHORDER - logical, parameter :: use_fourthorder = .true. -#else - logical, parameter :: use_fourthorder = .false. -#endif - ! rhosum integer, parameter :: maxrhosum = 39 + & maxdustlarge - 1 + & diff --git a/src/main/options.f90 b/src/main/options.f90 index 85887742a..0312c9371 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -58,6 +58,10 @@ module options logical, public :: exchange_radiation_energy, limit_radiation_flux, implicit_radiation logical, public :: implicit_radiation_store_drad +! Regularisation method and/or higher order integrator + logical, public :: use_fourthorder + + public :: set_default_options public :: ieos,idamp public :: iopacity_type @@ -170,6 +174,8 @@ subroutine set_default_options ! variable composition use_var_comp = .false. + use_fourthorder = .false. + end subroutine set_default_options end module options diff --git a/src/main/step_extern.f90 b/src/main/step_extern.f90 new file mode 100644 index 000000000..9cb3da671 --- /dev/null +++ b/src/main/step_extern.f90 @@ -0,0 +1,1278 @@ +!--------------------------------------------------------------------------! +! 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 step_extern +! +! Computes sub-steps in the RESPA algorithm +! +! Multiple option of sub stepping can be choosed depending on +! the physics and the precision needed +! +! Only Hydro : step_extern_sph +! Hydro + GR : step_extern_sph_gr step_extern_gr +! 2nd order with all fast physics implemented : step extern +! 4th order (Work in progress, only gravitionnal interaction +! sink-sink and sink-gas) : step_extern_FSI step_extern_PEFRL +! +! :References: +! Verlet (1967), Phys. Rev. 159, 98-103 +! Tuckerman, Berne & Martyna (1992), J. Chem. Phys. 97, 1990-2001 +! Rantala + (2020) (2023),Chin (2007a) +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: boundary_dyn, chem, cons2prim, cons2primsolver, cooling, +! cooling_ism, damping, deriv, dim, dust_formation, eos, extern_gr, +! externalforces, growth, io, io_summary, krome_interface, metric_tools, +! mpiutils, options, part, ptmass, ptmass_radiation, timestep, +! timestep_ind, timestep_sts, timing, units +! + implicit none + + public :: step_extern_lf + public :: step_extern_gr + public :: step_extern_sph + public :: step_extern_sph_gr + public :: step_extern_FSI + public :: step_extern_PEFRL + +contains + +subroutine step_extern_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) + use part, only:isdead_or_accreted,igas,massoftype,rhoh,eos_vars,igasP,& + ien_type,eos_vars,igamma,itemp + use cons2primsolver, only:conservative2primitive + use eos, only:ieos + use io, only:warning + use metric_tools, only:pack_metric + use timestep, only:xtol + real, intent(in) :: dt + integer, intent(in) :: npart + real, intent(inout) :: xyzh(:,:),dens(:),metrics(:,:,:,:) + real, intent(in) :: pxyzu(:,:) + real, intent(out) :: vxyzu(:,:) + integer, parameter :: nitermax = 50 + integer :: i,niter,ierr + real :: xpred(1:3),vold(1:3),diff + logical :: converged + real :: rhoi,pri,tempi,gammai + + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,vxyzu,dens,dt,xtol) & + !$omp shared(pxyzu,metrics,ieos,massoftype,ien_type,eos_vars) & + !$omp private(i,niter,diff,xpred,vold,converged,ierr) & + !$omp private(pri,rhoi,tempi,gammai) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + + !-- unpack and compute values for initial guess in cons2prim + pri = eos_vars(igasP,i) + tempi = eos_vars(itemp,i) + gammai = eos_vars(igamma,i) + rhoi = rhoh(xyzh(4,i),massoftype(igas)) + + call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),& + pri,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) + if (ierr > 0) call warning('cons2primsolver [in step_extern_sph_gr (a)]','enthalpy did not converge',i=i) + ! + ! main position update + ! + xpred = xyzh(1:3,i) + dt*vxyzu(1:3,i) + vold = vxyzu(1:3,i) + converged = .false. + niter = 0 + do while (.not. converged .and. niter<=nitermax) + niter = niter + 1 + call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),& + pri,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) + if (ierr > 0) call warning('cons2primsolver [in step_extern_sph_gr (b)]','enthalpy did not converge',i=i) + xyzh(1:3,i) = xpred + 0.5*dt*(vxyzu(1:3,i)-vold) + diff = maxval(abs(xyzh(1:3,i)-xpred)/xpred) + if (diff < xtol) converged = .true. + ! UPDATE METRIC HERE + call pack_metric(xyzh(1:3,i),metrics(:,:,:,i)) + enddo + if (niter > nitermax) call warning('step_extern_sph_gr','Reached max number of x iterations. x_err ',val=diff) + + ! repack values + eos_vars(igasP,i) = pri + eos_vars(itemp,i) = tempi + eos_vars(igamma,i) = gammai + endif + enddo + !$omp end parallel do + +end subroutine step_extern_sph_gr + +subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) + use dim, only:maxptmass,maxp,maxvxyzu + 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 + use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete + use timestep, only:bignumber,C_force,xtol,ptol + use eos, only:equationofstate,ieos + use cons2primsolver,only:conservative2primitive + use extern_gr, only:get_grforce + use metric_tools, only:pack_metric,pack_metricderivs + use damping, only:calc_damp,apply_damp,idamp + integer, intent(in) :: npart,ntypes + real, intent(in) :: dtsph,time + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:),pxyzu(:,:),dens(:),metrics(:,:,:,:),metricderivs(:,:,:,:) + integer :: i,itype,nsubsteps,naccreted,its,ierr,nlive + real :: timei,t_end_step,hdt,pmassi + real :: dt,dtf,dtextforcenew,dtextforce_min + real :: pri,spsoundi,pondensi,tempi,gammai + real, save :: pprev(3),xyz_prev(3),fstar(3),vxyz_star(3),xyz(3),pxyz(3),vxyz(3),fexti(3) + !$omp threadprivate(pprev,xyz_prev,fstar,vxyz_star,xyz,pxyz,vxyz,fexti) + real :: x_err,pmom_err,accretedmass,damp_fac + ! real, save :: dmdt = 0. + logical :: last_step,done,converged,accreted + integer, parameter :: itsmax = 50 + integer :: pitsmax,xitsmax + real :: perrmax,xerrmax + real :: rhoi,hi,eni,uui,densi + + pitsmax = 0 + xitsmax = 0 + perrmax = 0. + xerrmax = 0. + + ! + ! determine whether or not to use substepping + ! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + + timei = time + itype = igas + pmassi = massoftype(igas) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + substeps: do while (timei <= t_end_step .and. .not.done) + hdt = 0.5*dt + timei = timei + dt + nsubsteps = nsubsteps + 1 + dtextforcenew = bignumber + + call calc_damp(time, damp_fac) + + if (.not.last_step .and. iverbose > 1 .and. id==master) then + write(iprint,"(a,f14.6)") '> external forces only : t=',timei + endif + !--------------------------- + ! predictor during substeps + !--------------------------- + ! + ! predictor step for external forces, also recompute external forces + ! + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype) & + !$omp shared(maxphase,maxp,eos_vars) & + !$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) & + !$omp private(converged,pmom_err,x_err,pri,ierr,gammai) & + !$omp firstprivate(pmassi,itype) & + !$omp reduction(max:xitsmax,pitsmax,perrmax,xerrmax) & + !$omp reduction(min:dtextforcenew) + predictor: do i=1,npart + xyz(1) = xyzh(1,i) + xyz(2) = xyzh(2,i) + xyz(3) = xyzh(3,i) + hi = xyzh(4,i) + if (.not.isdead_or_accreted(hi)) then + if (ntypes > 1 .and. maxphase==maxp) then + itype = iamtype(iphase(i)) + pmassi = massoftype(itype) + endif + + its = 0 + converged = .false. + ! + ! make local copies of array quantities + ! + pxyz(1:3) = pxyzu(1:3,i) + eni = pxyzu(4,i) + vxyz(1:3) = vxyzu(1:3,i) + uui = vxyzu(4,i) + fexti = fext(:,i) + + pxyz = pxyz + hdt*fexti + + !-- unpack thermo variables for the first guess in cons2prim + densi = dens(i) + pri = eos_vars(igasP,i) + gammai = eos_vars(igamma,i) + tempi = eos_vars(itemp,i) + rhoi = rhoh(hi,massoftype(igas)) + + ! Note: grforce needs derivatives of the metric, + ! which do not change between pmom iterations + pmom_iterations: do while (its <= itsmax .and. .not. converged) + its = its + 1 + pprev = pxyz + call conservative2primitive(xyz,metrics(:,:,:,i),vxyz,densi,uui,pri,& + tempi,gammai,rhoi,pxyz,eni,ierr,ien_type) + if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (a)]','enthalpy did not converge',i=i) + call get_grforce(xyzh(:,i),metrics(:,:,:,i),metricderivs(:,:,:,i),vxyz,densi,uui,pri,fstar) + pxyz = pprev + hdt*(fstar - fexti) + pmom_err = maxval(abs(pxyz - pprev)) + if (pmom_err < ptol) converged = .true. + fexti = fstar + enddo pmom_iterations + if (its > itsmax ) call warning('step_extern_gr',& + 'max # of pmom iterations',var='pmom_err',val=pmom_err) + pitsmax = max(its,pitsmax) + perrmax = max(pmom_err,perrmax) + + call conservative2primitive(xyz,metrics(:,:,:,i),vxyz,densi,uui,pri,tempi,& + gammai,rhoi,pxyz,eni,ierr,ien_type) + if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (b)]','enthalpy did not converge',i=i) + xyz = xyz + dt*vxyz + call pack_metric(xyz,metrics(:,:,:,i)) + + its = 0 + converged = .false. + vxyz_star = vxyz + ! Note: since particle positions change between iterations + ! the metric and its derivatives need to be updated. + ! cons2prim does not require derivatives of the metric, + ! so those can updated once the iterations are complete + ! in order to reduce the number of computations. + xyz_iterations: do while (its <= itsmax .and. .not. converged) + its = its+1 + xyz_prev = xyz + call conservative2primitive(xyz,metrics(:,:,:,i),vxyz_star,densi,uui,& + pri,tempi,gammai,rhoi,pxyz,eni,ierr,ien_type) + if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (c)]','enthalpy did not converge',i=i) + xyz = xyz_prev + hdt*(vxyz_star - vxyz) + x_err = maxval(abs(xyz-xyz_prev)) + if (x_err < xtol) converged = .true. + vxyz = vxyz_star + ! UPDATE METRIC HERE + call pack_metric(xyz,metrics(:,:,:,i)) + enddo xyz_iterations + call pack_metricderivs(xyz,metricderivs(:,:,:,i)) + if (its > itsmax ) call warning('step_extern_gr','Reached max number of x iterations. x_err ',val=x_err) + xitsmax = max(its,xitsmax) + xerrmax = max(x_err,xerrmax) + + ! re-pack arrays back where they belong + xyzh(1:3,i) = xyz(1:3) + pxyzu(1:3,i) = pxyz(1:3) + vxyzu(1:3,i) = vxyz(1:3) + vxyzu(4,i) = uui + fext(:,i) = fexti + dens(i) = densi + eos_vars(igasP,i) = pri + eos_vars(itemp,i) = tempi + eos_vars(igamma,i) = gammai + + ! Skip remainder of update if boundary particle; note that fext==0 for these particles + if (iamboundary(itype)) cycle predictor + endif + enddo predictor + !$omp end parallel do + + if (iverbose >= 2 .and. id==master) then + write(iprint,*) '------ Iterations summary: -------------------------------' + write(iprint,"(a,i2,a,f14.6)") 'Most pmom iterations = ',pitsmax,' | max error = ',perrmax + write(iprint,"(a,i2,a,f14.6)") 'Most xyz iterations = ',xitsmax,' | max error = ',xerrmax + write(iprint,*) + endif + + ! + ! corrector step on gas particles (also accrete particles at end of step) + ! + accretedmass = 0. + naccreted = 0 + nlive = 0 + 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 private(i,accreted) & + !$omp shared(ieos,dens,pxyzu,iexternalforce,C_force) & + !$omp private(pri,pondensi,spsoundi,tempi,dtf) & + !$omp firstprivate(itype,pmassi) & + !$omp reduction(min:dtextforce_min) & + !$omp reduction(+:accretedmass,naccreted,nlive) & + !$omp shared(idamp,damp_fac) + !$omp do + accreteloop: do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + if (ntypes > 1 .and. maxphase==maxp) then + itype = iamtype(iphase(i)) + pmassi = massoftype(itype) + ! if (itype==iboundary) cycle accreteloop + 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) + dtextforce_min = min(dtextforce_min,C_force*dtf) + + if (idamp > 0) then + call apply_damp(fext(1,i), fext(2,i), fext(3,i), vxyzu(1:3,i), xyzh(1:3,i), damp_fac) + endif + + ! + ! correct v to the full step using only the external force + ! + pxyzu(1:3,i) = pxyzu(1:3,i) + hdt*fext(1:3,i) + ! Do we need call cons2prim here ?? + + if (iexternalforce > 0) then + call accrete_particles(iexternalforce,xyzh(1,i),xyzh(2,i), & + xyzh(3,i),xyzh(4,i),pmassi,timei,accreted,i) + if (accreted) then + accretedmass = accretedmass + pmassi + naccreted = naccreted + 1 + endif + endif + nlive = nlive + 1 + endif + enddo accreteloop + !$omp enddo + !$omp end parallel + + if (npart > 2 .and. nlive < 2) then + call fatal('step','all particles accreted',var='nlive',ival=nlive) + endif + + if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a)") & + 'Step: at time ',timei,', ',naccreted,' particles were accreted. Mass accreted = ',accretedmass + + dtextforcenew = min(dtextforce_min,dtextforcenew) + dtextforce = dtextforcenew + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + + enddo substeps + + if (nsubsteps > 1) then + if (iverbose>=1 .and. id==master) then + write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + +end subroutine step_extern_gr + + !---------------------------------------------------------------- + !+ + ! This is the equivalent of the routine below when no external + ! forces, sink particles or cooling are used + !+ + !---------------------------------------------------------------- +subroutine step_extern_sph(dt,npart,xyzh,vxyzu) + use part, only:isdead_or_accreted + real, intent(in) :: dt + integer, intent(in) :: npart + real, intent(inout) :: xyzh(:,:) + real, intent(in) :: vxyzu(:,:) + integer :: i + + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,vxyzu,dt) & + !$omp private(i) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + ! + ! main position update + ! + xyzh(1,i) = xyzh(1,i) + dt*vxyzu(1,i) + xyzh(2,i) = xyzh(2,i) + dt*vxyzu(2,i) + xyzh(3,i) = xyzh(3,i) + dt*vxyzu(3,i) + endif + enddo + !$omp end parallel do + +end subroutine step_extern_sph + + !---------------------------------------------------------------- + !+ + ! This is the equivalent of the routine below with no cooling + ! and external forces except ptmass. (4th order scheme) + !+ + !---------------------------------------------------------------- +subroutine step_extern_PEFRL(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + use part, only: isdead_or_accreted,igas,massoftype + use io, only:iverbose,id,master,iprint,warning,fatal + use io_summary, only:summary_variable,iosumextr,iosumextt + real, intent(in) :: dtsph,time + integer, intent(in) :: npart,nptmass + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + real,parameter :: ck(5) = (/0.1786178958448091,-0.06626458266981849,0.77529337365001878,-0.06626458266981849,0.1786178958448091/) + real,parameter :: dk(4) = (/0.7123418310626054,-0.2123418310626054,-0.2123418310626054,0.7123418310626054/) + real :: dt,t_end_step,dtextforce_min + real :: pmassi,timei + logical :: done,last_step + integer :: nsubsteps + integer :: i + + ! + ! determine whether or not to use substepping + ! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + + timei = time + pmassi = massoftype(igas) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + + substeps: do while (timei <= t_end_step .and. .not.done) + timei = timei + dt + if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + nsubsteps = nsubsteps + 1 + do i=1,4 + call drift_4th(ck(i),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + call kick_4th (dk(i),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + enddo + call drift_4th(ck(5),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + + if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"dt : ",dt + dtextforce_min = min(dtextforce_min,dtextforce) + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + enddo substeps + + if (nsubsteps > 1) then + if (iverbose>=1 .and. id==master) then + write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + + +end subroutine step_extern_PEFRL + + !---------------------------------------------------------------- + !+ + ! This is the equivalent of the routine below with no cooling + ! and external forces except ptmass. (4th order scheme) + !+ + !---------------------------------------------------------------- +subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + use part, only: isdead_or_accreted,igas,massoftype + use io, only:iverbose,id,master,iprint,warning,fatal + use io_summary, only:summary_variable,iosumextr,iosumextt + real, intent(in) :: dtsph,time + integer, intent(in) :: npart,nptmass + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) + real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) + real,parameter :: ck(2) = (/0.5,0.5/) + real :: dt,t_end_step,dtextforce_min + real :: pmassi,timei + logical :: done,last_step + integer :: nsubsteps + + ! + ! determine whether or not to use substepping + ! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + + timei = time + pmassi = massoftype(igas) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + + substeps: do while (timei <= t_end_step .and. .not.done) + timei = timei + dt + if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + nsubsteps = nsubsteps + 1 + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + call kick_4th (dk(1),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call drift_4th(ck(1),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Direct calculation of the force and force gradient + call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) + ! call get_force_extrapol_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + ! xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Extrapolation of the modified force using Omelyan technique + + call kick_4th (dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + !print*,xyzmh_ptmass(1,1:20) + call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + call kick_4th (dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt + + dtextforce_min = min(dtextforce_min,dtextforce) + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + enddo substeps + + if (nsubsteps > 1) then + if (iverbose>=1 .and. id==master) then + write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + + +end subroutine step_extern_FSI + + + !---------------------------------------------------------------- + !+ + ! drift routine for the 4th order scheme + !+ + !---------------------------------------------------------------- + +subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + use part, only: isdead_or_accreted,ispinx,ispiny,ispinz + real, intent(in) :: dt,ck + integer, intent(in) :: npart,nptmass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) + integer :: i + + ! Drift gas particles + + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,vxyzu,dt,ck) & + !$omp private(i) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + xyzh(1,i) = xyzh(1,i) + ck*dt*vxyzu(1,i) + xyzh(2,i) = xyzh(2,i) + ck*dt*vxyzu(2,i) + xyzh(3,i) = xyzh(3,i) + ck*dt*vxyzu(3,i) + endif + enddo + !$omp end parallel do + + ! Drift sink particles + + !$omp parallel do default(none) & + !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ck,dt) & + !$omp private(i) + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ck*dt*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ck*dt*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ck*dt*vxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + ck*dt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + ck*dt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + ck*dt*dsdt_ptmass(3,i) + endif + enddo + !$omp end parallel do +end subroutine drift_4th + + + !---------------------------------------------------------------- + !+ + ! kick routine for the 4th order scheme + !+ + !---------------------------------------------------------------- + +subroutine kick_4th(dk,dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + use part, only: isdead_or_accreted,ispinx,ispiny,ispinz + real, intent(in) :: dt,dk + integer, intent(in) :: npart,nptmass + real, intent(in) :: xyzh(:,:) + real, intent(inout) :: vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + integer :: i + + ! Kick gas particles + + !$omp parallel do default(none) & + !$omp shared(npart,fext,xyzh,vxyzu,dt,dk) & + !$omp private(i) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + vxyzu(1,i) = vxyzu(1,i) + dk*dt*fext(1,i) + vxyzu(2,i) = vxyzu(2,i) + dk*dt*fext(2,i) + vxyzu(3,i) = vxyzu(3,i) + dk*dt*fext(3,i) + endif + enddo + !$omp end parallel do + + ! Kick sink particles + + !$omp parallel do default(none) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,dsdt_ptmass,dk,dt) & + !$omp private(i) + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dk*dt*fxyz_ptmass(1,i) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dk*dt*fxyz_ptmass(2,i) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dk*dt*fxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dk*dt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dk*dt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dk*dt*dsdt_ptmass(3,i) + endif + enddo + !$omp end parallel do + +end subroutine kick_4th + + !---------------------------------------------------------------- + !+ + ! force routine for the 4th order scheme + !+ + !---------------------------------------------------------------- + +subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + use options, only:iexternalforce + use dim, only:maxptmass + use io, only:iverbose,master,iprint,warning,fatal + use part, only:epot_sinksink,fxyz_ptmass_sinksink,dsdt_ptmass_sinksink + use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks + use timestep, only:bignumber,C_force + integer, intent(in):: nptmass,npart,nsubsteps + real, intent(inout) :: xyzh(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) + real, intent(inout) :: dtextforce + real, intent(in) :: timei,pmassi + integer :: merge_ij(nptmass) + integer :: merge_n + integer :: i + real :: dtf,dtextforcenew,dtsinkgas,dtphi2,fonrmax + real :: fextx,fexty,fextz + real :: fonrmaxi,phii,dtphi2i + + dtextforcenew = bignumber + dtsinkgas = bignumber + dtphi2 = bignumber + fonrmax = 0 + if (nptmass>0) then + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + endif + else + fxyz_ptmass(:,:) = 0. + dsdt_ptmass(:,:) = 0. + endif + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + dtextforcenew = min(dtextforcenew,C_force*dtf) + if (iverbose >= 3 ) write(iprint,*) "dt_sink_sink",dtextforcenew + !$omp parallel default(none) & + !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext) & + !$omp private(fextx,fexty,fextz) & + !$omp private(fonrmaxi,dtphi2i,phii,pmassi,dtf) & + !$omp reduction(min:dtextforcenew,dtsinkgas,dtphi2) & + !$omp reduction(max:fonrmax) & + !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) + !$omp do + do i=1,npart + fextx = 0. + fexty = 0. + fextz = 0. + call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,& + fextx,fexty,fextz,phii,pmassi,fxyz_ptmass,dsdt_ptmass,fonrmaxi,dtphi2i) + fonrmax = max(fonrmax,fonrmaxi) + dtphi2 = min(dtphi2,dtphi2i) + fext(1,i) = fextx + fext(2,i) = fexty + fext(3,i) = fextz + enddo + !$omp enddo + !$omp end parallel + + if (fonrmax > 0.) then + dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) + endif + if (iverbose >= 3 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas + dtextforcenew = min(dtextforcenew,dtsinkgas) + dtextforce = dtextforcenew + +end subroutine get_force_4th + + + !---------------------------------------------------------------- + !+ + ! grad routine for the 4th order scheme (FSI) + !+ + !---------------------------------------------------------------- + + +subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) + use dim, only:maxptmass + use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink + integer, intent(in) :: nptmass,npart + real, intent(inout) :: xyzh(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) + real, intent(inout) :: dt + real, intent(in) :: pmassi + real :: fextx,fexty,fextz + integer :: i + + + if (nptmass>0) then + call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) + !print*,fxyz_ptmass(1,1:5) + else + fxyz_ptmass(:,:) = 0. + endif + + !$omp parallel default(none) & + !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,dt,pmassi) & + !$omp private(fextx,fexty,fextz) & + !$omp reduction(+:fxyz_ptmass) + !$omp do + do i=1,npart + fextx = 0. + fexty = 0. + fextz = 0. + call get_gradf_sink_gas(nptmass,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& + xyzmh_ptmass,fextx,fexty,fextz,pmassi,fxyz_ptmass) + fext(1,i) = fext(1,i)+ fextx + fext(2,i) = fext(2,i)+ fexty + fext(3,i) = fext(3,i)+ fextz + enddo + !$omp enddo + !$omp end parallel + +end subroutine get_gradf_4th + + + !---------------------------------------------------------------- + !+ + ! Substepping of external and sink particle forces. + ! Also updates position of all particles even if no external + ! forces applied. This is the internal loop of the RESPA + ! algorithm over the "fast" forces. + !+ + !---------------------------------------------------------------- +subroutine step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time,nptmass, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) + use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome,itau_alloc,& + do_nucleation,update_muGamma,h2chemistry + use io, only:iverbose,id,master,iprint,warning,fatal + use externalforces, only:externalforce,accrete_particles,update_externalforce, & + update_vdependent_extforce_leapfrog,is_velocity_dependent + use ptmass, only:ptmass_predictor,ptmass_corrector,ptmass_accrete, & + get_accel_sink_gas,get_accel_sink_sink,merge_sinks,f_acc,pt_write_sinkev, & + idxmsi,idymsi,idzmsi,idmsi,idspinxsi,idspinysi,idspinzsi, & + idvxmsi,idvymsi,idvzmsi,idfxmsi,idfymsi,idfzmsi, & + ndptmass,update_ptmass + use options, only:iexternalforce,icooling + use part, only:maxphase,abundance,nabundances,eos_vars,epot_sinksink,eos_vars,& + isdead_or_accreted,iamboundary,igas,iphase,iamtype,massoftype,rhoh,divcurlv, & + fxyz_ptmass_sinksink,dsdt_ptmass_sinksink,dust_temp,tau,& + nucleation,idK2,idmu,idkappa,idgamma,imu,igamma + use chem, only:update_abundances,get_dphot + use cooling_ism, only:dphot0,energ_cooling_ism,dphotflag,abundsi,abundo,abunde,abundc,nabn + use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete,summary_accrete_fail + use timestep, only:bignumber,C_force + use timestep_sts, only:sts_it_n + use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi + use damping, only:calc_damp,apply_damp,idamp + use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation + use cooling, only:energ_cooling,cooling_in_step + use dust_formation, only:evolve_dust,calc_muGamma + use units, only:unit_density +#ifdef KROME + use part, only: T_gas_cool + use krome_interface, only: update_krome +#endif + integer, intent(in) :: npart,ntypes,nptmass + real, intent(in) :: dtsph,time + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:),fxyzu(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + integer(kind=1), intent(in) :: nbinmax + integer(kind=1), intent(inout) :: ibin_wake(:) + integer :: i,itype,nsubsteps,naccreted,nfail,nfaili,merge_n,nlive + integer :: merge_ij(nptmass) + integer(kind=1) :: ibin_wakei + real :: timei,hdt,fextx,fexty,fextz,fextxi,fextyi,fextzi,phii,pmassi + real :: dtphi2,dtphi2i,vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi + real :: dudtcool,fextv(3),poti,ui,rhoi,mui,gammai,ph,ph_tot + real :: dt,dtextforcenew,dtsinkgas,fonrmax,fonrmaxi + real :: dtf,accretedmass,t_end_step,dtextforce_min + real, allocatable :: dptmass(:,:) ! dptmass(ndptmass,nptmass) + real :: damp_fac,dphot + real, save :: dmdt = 0. + real :: abundi(nabn),gmwvar + logical :: accreted,extf_is_velocity_dependent + logical :: last_step,done + + + ! + ! determine whether or not to use substepping + ! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + + timei = time + extf_is_velocity_dependent = is_velocity_dependent(iexternalforce) + accretedmass = 0. + itype = igas + pmassi = massoftype(igas) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + ! allocate memory for dptmass array (avoids ifort bug) + allocate(dptmass(ndptmass,nptmass)) + + substeps: do while (timei <= t_end_step .and. .not.done) + hdt = 0.5*dt + timei = timei + dt + if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + nsubsteps = nsubsteps + 1 + dtextforcenew = bignumber + dtsinkgas = bignumber + dtphi2 = bignumber + + call calc_damp(time, damp_fac) + + if (.not.last_step .and. iverbose > 1 .and. id==master) then + write(iprint,"(a,f14.6)") '> external/ptmass forces only : t=',timei + endif + ! + ! update time-dependent external forces + ! + call update_externalforce(iexternalforce,timei,dmdt) + + !--------------------------- + ! predictor during substeps + !--------------------------- + ! + ! point mass predictor step + ! + if (nptmass > 0) then + if (id==master) then + call ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + ! + ! get sink-sink forces (and a new sink-sink timestep. Note: fxyz_ptmass is zeroed in this subroutine) + ! pass sink-sink forces to variable fxyz_ptmass_sinksink for later writing. + ! + if (iexternalforce==14) call update_externalforce(iexternalforce,timei,dmdt) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + endif + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + else + fxyz_ptmass(:,:) = 0. + dsdt_ptmass(:,:) = 0. + endif + call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + call bcast_mpi(epot_sinksink) + call bcast_mpi(dtf) + dtextforcenew = min(dtextforcenew,C_force*dtf) + endif + + ! + ! predictor step for sink-gas and external forces, also recompute sink-gas and external forces + ! + fonrmax = 0. + !$omp parallel default(none) & + !$omp shared(maxp,maxphase) & + !$omp shared(npart,xyzh,vxyzu,fext,abundance,iphase,ntypes,massoftype) & + !$omp shared(eos_vars,dust_temp,store_dust_temperature) & + !$omp shared(dt,hdt,timei,iexternalforce,extf_is_velocity_dependent,cooling_in_step,icooling) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,idamp,damp_fac) & + !$omp shared(nptmass,nsubsteps,C_force,divcurlv,dphotflag,dphot0) & + !$omp shared(abundc,abundo,abundsi,abunde) & + !$omp shared(nucleation,do_nucleation,update_muGamma,h2chemistry,unit_density) & + !$omp private(dphot,abundi,gmwvar,ph,ph_tot) & + !$omp private(ui,rhoi, mui, gammai) & + !$omp private(i,dudtcool,fxi,fyi,fzi,phii) & + !$omp private(fextx,fexty,fextz,fextxi,fextyi,fextzi,poti,fextv,accreted) & + !$omp private(fonrmaxi,dtphi2i,dtf) & + !$omp private(vxhalfi,vyhalfi,vzhalfi) & + !$omp firstprivate(pmassi,itype) & +#ifdef KROME + !$omp shared(T_gas_cool) & +#endif + !$omp reduction(+:accretedmass) & + !$omp reduction(min:dtextforcenew,dtsinkgas,dtphi2) & + !$omp reduction(max:fonrmax) & + !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) + !$omp do + predictor: do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + if (ntypes > 1 .and. maxphase==maxp) then + itype = iamtype(iphase(i)) + pmassi = massoftype(itype) + endif + ! + ! predict v to the half step + ! + vxyzu(1:3,i) = vxyzu(1:3,i) + hdt*fext(1:3,i) + ! + ! main position update + ! + xyzh(1,i) = xyzh(1,i) + dt*vxyzu(1,i) + xyzh(2,i) = xyzh(2,i) + dt*vxyzu(2,i) + xyzh(3,i) = xyzh(3,i) + dt*vxyzu(3,i) + ! + ! Skip remainder of update if boundary particle; note that fext==0 for these particles + if (iamboundary(itype)) cycle predictor + ! + ! compute and add sink-gas force + ! + fextx = 0. + fexty = 0. + fextz = 0. + if (nptmass > 0) then + call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),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 + ! + ! compute and add external forces + ! + if (iexternalforce > 0) then + call externalforce(iexternalforce,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i), & + timei,fextxi,fextyi,fextzi,poti,dtf,i) + dtextforcenew = min(dtextforcenew,C_force*dtf) + + fextx = fextx + fextxi + fexty = fexty + fextyi + fextz = fextz + fextzi + ! + ! Velocity-dependent external forces require special handling + ! in leapfrog (corrector is implicit) + ! + if (extf_is_velocity_dependent) then + vxhalfi = vxyzu(1,i) + vyhalfi = vxyzu(2,i) + vzhalfi = vxyzu(3,i) + fxi = fextx + fyi = fexty + fzi = fextz + call update_vdependent_extforce_leapfrog(iexternalforce,& + vxhalfi,vyhalfi,vzhalfi, & + fxi,fyi,fzi,fextv,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i)) + fextx = fextx + fextv(1) + fexty = fexty + fextv(2) + fextz = fextz + fextv(3) + endif + endif + if (idamp > 0) then + call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), xyzh(1:3,i), damp_fac) + endif + fext(1,i) = fextx + fext(2,i) = fexty + fext(3,i) = fextz + + if (maxvxyzu >= 4 .and. itype==igas) then + ! NOTE: The chemistry and cooling here is implicitly calculated. That is, + ! dt is *passed in* to the chemistry & cooling routines so that the + ! output will be at the correct time of time + dt. Since this is + ! implicit, there is no cooling timestep. Explicit cooling is + ! calculated in force and requires a cooling timestep. + + dudtcool = 0. + rhoi = rhoh(xyzh(4,i),pmassi) + ! + ! CHEMISTRY + ! + if (h2chemistry) then + ! + ! Get updated abundances of all species, updates 'chemarrays', + ! + dphot = get_dphot(dphotflag,dphot0,xyzh(1,i),xyzh(2,i),xyzh(3,i)) + call update_abundances(vxyzu(4,i),rhoi,abundance(:,i),nabundances,& + dphot,dt,abundi,nabn,eos_vars(imu,i),abundc,abunde,abundo,abundsi) + endif +#ifdef KROME + ! evolve chemical composition and determine new internal energy + ! Krome also computes cooling function but only associated with chemical processes + ui = vxyzu(4,i) + call update_krome(dt,xyzh(:,i),ui,rhoi,abundance(:,i),eos_vars(igamma,i),eos_vars(imu,i),T_gas_cool(i)) + dudtcool = (ui-vxyzu(4,i))/dt +#else + !evolve dust chemistry and compute dust cooling + if (do_nucleation) then + call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) + eos_vars(imu,i) = nucleation(idmu,i) + eos_vars(igamma,i) = nucleation(idgamma,i) + endif + ! + ! COOLING + ! + if (icooling > 0 .and. cooling_in_step) then + if (h2chemistry) then + ! + ! Call cooling routine, requiring total density, some distance measure and + ! abundances in the 'abund' format + ! + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i),abund_in=abundi) + elseif (store_dust_temperature) then + ! cooling with stored dust temperature + if (do_nucleation) then + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) + elseif (update_muGamma) then + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i)) + 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 + 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) + endif + endif +#endif + ! update internal energy + if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool + endif + endif + enddo predictor + !$omp enddo + !$omp end parallel + + if (nptmass > 0 .and. isink_radiation > 0) then + if (itau_alloc == 1) then + call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) + else + call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext) + endif + endif + + ! + ! reduction of sink-gas forces from each MPI thread + ! + if (nptmass > 0) then + call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) + call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + endif + !--------------------------- + ! corrector during substeps + !--------------------------- + ! + ! corrector step on sinks (changes velocities only, does not change position) + ! + if (nptmass > 0) then + if (id==master) then + call ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,iexternalforce) + endif + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + endif + + ! + ! corrector step on gas particles (also accrete particles at end of step) + ! + accretedmass = 0. + nfail = 0 + naccreted = 0 + nlive = 0 + ibin_wakei = 0 + dptmass(:,:) = 0. + + !$omp parallel default(none) & + !$omp shared(maxp,maxphase) & + !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype,hdt,timei,nptmass,sts_it_n) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & + !$omp shared(iexternalforce) & + !$omp shared(nbinmax,ibin_wake) & + !$omp reduction(+:dptmass) & + !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & + !$omp firstprivate(itype,pmassi,ibin_wakei) & + !$omp reduction(+:accretedmass,nfail,naccreted,nlive) + !$omp do + accreteloop: do i=1,npart + 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 + endif + ! + ! correct v to the full step using only the external force + ! + vxyzu(1:3,i) = vxyzu(1:3,i) + hdt*fext(1:3,i) + + if (iexternalforce > 0) then + call accrete_particles(iexternalforce,xyzh(1,i),xyzh(2,i), & + xyzh(3,i),xyzh(4,i),pmassi,timei,accreted) + if (accreted) accretedmass = accretedmass + pmassi + endif + ! + ! accretion onto sink particles + ! need position, velocities and accelerations of both gas and sinks to be synchronised, + ! otherwise will not conserve momentum + ! Note: requiring sts_it_n since this is supertimestep with the most active particles + ! + if (nptmass > 0 .and. sts_it_n) then + fxi = fext(1,i) + fyi = fext(2,i) + fzi = fext(3,i) + if (ind_timesteps) ibin_wakei = ibin_wake(i) + + call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& + vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxi,fyi,fzi,& + itype,pmassi,xyzmh_ptmass,vxyz_ptmass,& + accreted,dptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) + if (accreted) then + naccreted = naccreted + 1 + cycle accreteloop + else + if (ind_timesteps) ibin_wake(i) = ibin_wakei + endif + if (nfaili > 1) nfail = nfail + 1 + endif + nlive = nlive + 1 + endif + enddo accreteloop + !$omp enddo + !$omp end parallel + + if (npart > 2 .and. nlive < 2) then + call fatal('step','all particles accreted',var='nlive',ival=nlive) + endif + + ! + ! reduction of sink particle changes across MPI + ! + if (nptmass > 0) then + call reduce_in_place_mpi('+',dptmass(:,1:nptmass)) + + naccreted = int(reduceall_mpi('+',naccreted)) + nfail = int(reduceall_mpi('+',nfail)) + + if (id==master) call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) + + call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + call bcast_mpi(fxyz_ptmass(:,1:nptmass)) + endif + + if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a,i4,a)") & + 'Step: at time ',timei,', ',naccreted,' particles were accreted amongst ',nptmass,' sink(s).' + + if (nptmass > 0) then + call summary_accrete_fail(nfail) + call summary_accrete(nptmass) + ! only write to .ev during substeps if no gas particles present + if (npart==0) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & + fxyz_ptmass,fxyz_ptmass_sinksink) + endif + ! + ! check if timestep criterion was violated during substeps + ! + if (nptmass > 0) then + if (fonrmax > 0.) then + dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) + endif + if (iverbose >= 2) write(iprint,*) nsubsteps,'dt(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas + dtextforcenew = min(dtextforcenew,dtsinkgas) + endif + + dtextforcenew = reduceall_mpi('min',dtextforcenew) + + dtextforce_min = min(dtextforce_min,dtextforcenew) + dtextforce = dtextforcenew + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + enddo substeps + + deallocate(dptmass) + + if (nsubsteps > 1) then + if (iverbose>=1 .and. id==master) then + write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + +end subroutine step_extern_lf + + +end module step_extern diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 2380b7718..18d197625 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -90,9 +90,9 @@ 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_fourthorder + use_dustgrowth,use_krome,gr,do_radiation use io, only:iprint,fatal,iverbose,id,master,warning - use options, only:iexternalforce,use_dustfrac,implicit_radiation + use options, only:iexternalforce,use_dustfrac,implicit_radiation,use_fourthorder 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,& @@ -121,6 +121,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate + use step_extern, only:step_extern_FSI,step_extern_PEFRL,step_extern_lf, & + step_extern_gr,step_extern_sph_gr,step_extern_sph integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -680,1237 +682,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) end subroutine step -subroutine step_extern_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) - use part, only:isdead_or_accreted,igas,massoftype,rhoh,eos_vars,igasP,& - ien_type,eos_vars,igamma,itemp - use cons2primsolver, only:conservative2primitive - use eos, only:ieos - use io, only:warning - use metric_tools, only:pack_metric - use timestep, only:xtol - real, intent(in) :: dt - integer, intent(in) :: npart - real, intent(inout) :: xyzh(:,:),dens(:),metrics(:,:,:,:) - real, intent(in) :: pxyzu(:,:) - real, intent(out) :: vxyzu(:,:) - integer, parameter :: nitermax = 50 - integer :: i,niter,ierr - real :: xpred(1:3),vold(1:3),diff - logical :: converged - real :: rhoi,pri,tempi,gammai - - !$omp parallel do default(none) & - !$omp shared(npart,xyzh,vxyzu,dens,dt,xtol) & - !$omp shared(pxyzu,metrics,ieos,massoftype,ien_type,eos_vars) & - !$omp private(i,niter,diff,xpred,vold,converged,ierr) & - !$omp private(pri,rhoi,tempi,gammai) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - - !-- unpack and compute values for initial guess in cons2prim - pri = eos_vars(igasP,i) - tempi = eos_vars(itemp,i) - gammai = eos_vars(igamma,i) - rhoi = rhoh(xyzh(4,i),massoftype(igas)) - - call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),& - pri,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_sph_gr (a)]','enthalpy did not converge',i=i) - ! - ! main position update - ! - xpred = xyzh(1:3,i) + dt*vxyzu(1:3,i) - vold = vxyzu(1:3,i) - converged = .false. - niter = 0 - do while (.not. converged .and. niter<=nitermax) - niter = niter + 1 - call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),& - pri,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_sph_gr (b)]','enthalpy did not converge',i=i) - xyzh(1:3,i) = xpred + 0.5*dt*(vxyzu(1:3,i)-vold) - diff = maxval(abs(xyzh(1:3,i)-xpred)/xpred) - if (diff < xtol) converged = .true. - ! UPDATE METRIC HERE - call pack_metric(xyzh(1:3,i),metrics(:,:,:,i)) - enddo - if (niter > nitermax) call warning('step_extern_sph_gr','Reached max number of x iterations. x_err ',val=diff) - - ! repack values - eos_vars(igasP,i) = pri - eos_vars(itemp,i) = tempi - eos_vars(igamma,i) = gammai - endif - enddo - !$omp end parallel do - -end subroutine step_extern_sph_gr - -subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) - use dim, only:maxptmass,maxp,maxvxyzu - 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 - use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete - use timestep, only:bignumber,C_force,xtol,ptol - use eos, only:equationofstate,ieos - use cons2primsolver,only:conservative2primitive - use extern_gr, only:get_grforce - use metric_tools, only:pack_metric,pack_metricderivs - use damping, only:calc_damp,apply_damp,idamp - integer, intent(in) :: npart,ntypes - real, intent(in) :: dtsph,time - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:),pxyzu(:,:),dens(:),metrics(:,:,:,:),metricderivs(:,:,:,:) - integer :: i,itype,nsubsteps,naccreted,its,ierr,nlive - real :: timei,t_end_step,hdt,pmassi - real :: dt,dtf,dtextforcenew,dtextforce_min - real :: pri,spsoundi,pondensi,tempi,gammai - real, save :: pprev(3),xyz_prev(3),fstar(3),vxyz_star(3),xyz(3),pxyz(3),vxyz(3),fexti(3) -!$omp threadprivate(pprev,xyz_prev,fstar,vxyz_star,xyz,pxyz,vxyz,fexti) - real :: x_err,pmom_err,accretedmass,damp_fac - ! real, save :: dmdt = 0. - logical :: last_step,done,converged,accreted - integer, parameter :: itsmax = 50 - integer :: pitsmax,xitsmax - real :: perrmax,xerrmax - real :: rhoi,hi,eni,uui,densi - - pitsmax = 0 - xitsmax = 0 - perrmax = 0. - xerrmax = 0. - -! -! determine whether or not to use substepping -! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - - timei = time - itype = igas - pmassi = massoftype(igas) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - substeps: do while (timei <= t_end_step .and. .not.done) - hdt = 0.5*dt - timei = timei + dt - nsubsteps = nsubsteps + 1 - dtextforcenew = bignumber - - call calc_damp(time, damp_fac) - - if (.not.last_step .and. iverbose > 1 .and. id==master) then - write(iprint,"(a,f14.6)") '> external forces only : t=',timei - endif - !--------------------------- - ! predictor during substeps - !--------------------------- - ! - ! predictor step for external forces, also recompute external forces - ! - !$omp parallel do default(none) & - !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype) & - !$omp shared(maxphase,maxp,eos_vars) & - !$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) & - !$omp private(converged,pmom_err,x_err,pri,ierr,gammai) & - !$omp firstprivate(pmassi,itype) & - !$omp reduction(max:xitsmax,pitsmax,perrmax,xerrmax) & - !$omp reduction(min:dtextforcenew) - predictor: do i=1,npart - xyz(1) = xyzh(1,i) - xyz(2) = xyzh(2,i) - xyz(3) = xyzh(3,i) - hi = xyzh(4,i) - if (.not.isdead_or_accreted(hi)) then - if (ntypes > 1 .and. maxphase==maxp) then - itype = iamtype(iphase(i)) - pmassi = massoftype(itype) - endif - - its = 0 - converged = .false. - ! - ! make local copies of array quantities - ! - pxyz(1:3) = pxyzu(1:3,i) - eni = pxyzu(4,i) - vxyz(1:3) = vxyzu(1:3,i) - uui = vxyzu(4,i) - fexti = fext(:,i) - - pxyz = pxyz + hdt*fexti - - !-- unpack thermo variables for the first guess in cons2prim - densi = dens(i) - pri = eos_vars(igasP,i) - gammai = eos_vars(igamma,i) - tempi = eos_vars(itemp,i) - rhoi = rhoh(hi,massoftype(igas)) - - ! Note: grforce needs derivatives of the metric, - ! which do not change between pmom iterations - pmom_iterations: do while (its <= itsmax .and. .not. converged) - its = its + 1 - pprev = pxyz - call conservative2primitive(xyz,metrics(:,:,:,i),vxyz,densi,uui,pri,& - tempi,gammai,rhoi,pxyz,eni,ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (a)]','enthalpy did not converge',i=i) - call get_grforce(xyzh(:,i),metrics(:,:,:,i),metricderivs(:,:,:,i),vxyz,densi,uui,pri,fstar) - pxyz = pprev + hdt*(fstar - fexti) - pmom_err = maxval(abs(pxyz - pprev)) - if (pmom_err < ptol) converged = .true. - fexti = fstar - enddo pmom_iterations - if (its > itsmax ) call warning('step_extern_gr',& - 'max # of pmom iterations',var='pmom_err',val=pmom_err) - pitsmax = max(its,pitsmax) - perrmax = max(pmom_err,perrmax) - - call conservative2primitive(xyz,metrics(:,:,:,i),vxyz,densi,uui,pri,tempi,& - gammai,rhoi,pxyz,eni,ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (b)]','enthalpy did not converge',i=i) - xyz = xyz + dt*vxyz - call pack_metric(xyz,metrics(:,:,:,i)) - - its = 0 - converged = .false. - vxyz_star = vxyz - ! Note: since particle positions change between iterations - ! the metric and its derivatives need to be updated. - ! cons2prim does not require derivatives of the metric, - ! so those can updated once the iterations are complete - ! in order to reduce the number of computations. - xyz_iterations: do while (its <= itsmax .and. .not. converged) - its = its+1 - xyz_prev = xyz - call conservative2primitive(xyz,metrics(:,:,:,i),vxyz_star,densi,uui,& - pri,tempi,gammai,rhoi,pxyz,eni,ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (c)]','enthalpy did not converge',i=i) - xyz = xyz_prev + hdt*(vxyz_star - vxyz) - x_err = maxval(abs(xyz-xyz_prev)) - if (x_err < xtol) converged = .true. - vxyz = vxyz_star - ! UPDATE METRIC HERE - call pack_metric(xyz,metrics(:,:,:,i)) - enddo xyz_iterations - call pack_metricderivs(xyz,metricderivs(:,:,:,i)) - if (its > itsmax ) call warning('step_extern_gr','Reached max number of x iterations. x_err ',val=x_err) - xitsmax = max(its,xitsmax) - xerrmax = max(x_err,xerrmax) - - ! re-pack arrays back where they belong - xyzh(1:3,i) = xyz(1:3) - pxyzu(1:3,i) = pxyz(1:3) - vxyzu(1:3,i) = vxyz(1:3) - vxyzu(4,i) = uui - fext(:,i) = fexti - dens(i) = densi - eos_vars(igasP,i) = pri - eos_vars(itemp,i) = tempi - eos_vars(igamma,i) = gammai - - ! Skip remainder of update if boundary particle; note that fext==0 for these particles - if (iamboundary(itype)) cycle predictor - endif - enddo predictor - !$omp end parallel do - - if (iverbose >= 2 .and. id==master) then - write(iprint,*) '------ Iterations summary: -------------------------------' - write(iprint,"(a,i2,a,f14.6)") 'Most pmom iterations = ',pitsmax,' | max error = ',perrmax - write(iprint,"(a,i2,a,f14.6)") 'Most xyz iterations = ',xitsmax,' | max error = ',xerrmax - write(iprint,*) - endif - - ! - ! corrector step on gas particles (also accrete particles at end of step) - ! - accretedmass = 0. - naccreted = 0 - nlive = 0 - 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 private(i,accreted) & - !$omp shared(ieos,dens,pxyzu,iexternalforce,C_force) & - !$omp private(pri,pondensi,spsoundi,tempi,dtf) & - !$omp firstprivate(itype,pmassi) & - !$omp reduction(min:dtextforce_min) & - !$omp reduction(+:accretedmass,naccreted,nlive) & - !$omp shared(idamp,damp_fac) - !$omp do - accreteloop: do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - if (ntypes > 1 .and. maxphase==maxp) then - itype = iamtype(iphase(i)) - pmassi = massoftype(itype) - ! if (itype==iboundary) cycle accreteloop - 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) - dtextforce_min = min(dtextforce_min,C_force*dtf) - - if (idamp > 0) then - call apply_damp(fext(1,i), fext(2,i), fext(3,i), vxyzu(1:3,i), xyzh(1:3,i), damp_fac) - endif - - ! - ! correct v to the full step using only the external force - ! - pxyzu(1:3,i) = pxyzu(1:3,i) + hdt*fext(1:3,i) - ! Do we need call cons2prim here ?? - - if (iexternalforce > 0) then - call accrete_particles(iexternalforce,xyzh(1,i),xyzh(2,i), & - xyzh(3,i),xyzh(4,i),pmassi,timei,accreted,i) - if (accreted) then - accretedmass = accretedmass + pmassi - naccreted = naccreted + 1 - endif - endif - nlive = nlive + 1 - endif - enddo accreteloop - !$omp enddo - !$omp end parallel - - if (npart > 2 .and. nlive < 2) then - call fatal('step','all particles accreted',var='nlive',ival=nlive) - endif - - if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a)") & - 'Step: at time ',timei,', ',naccreted,' particles were accreted. Mass accreted = ',accretedmass - - dtextforcenew = min(dtextforce_min,dtextforcenew) - dtextforce = dtextforcenew - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - - enddo substeps - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - -end subroutine step_extern_gr - -!---------------------------------------------------------------- -!+ -! This is the equivalent of the routine below when no external -! forces, sink particles or cooling are used -!+ -!---------------------------------------------------------------- -subroutine step_extern_sph(dt,npart,xyzh,vxyzu) - use part, only:isdead_or_accreted - real, intent(in) :: dt - integer, intent(in) :: npart - real, intent(inout) :: xyzh(:,:) - real, intent(in) :: vxyzu(:,:) - integer :: i - - !$omp parallel do default(none) & - !$omp shared(npart,xyzh,vxyzu,dt) & - !$omp private(i) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - ! - ! main position update - ! - xyzh(1,i) = xyzh(1,i) + dt*vxyzu(1,i) - xyzh(2,i) = xyzh(2,i) + dt*vxyzu(2,i) - xyzh(3,i) = xyzh(3,i) + dt*vxyzu(3,i) - endif - enddo - !$omp end parallel do - -end subroutine step_extern_sph - -!---------------------------------------------------------------- -!+ -! This is the equivalent of the routine below with no cooling -! and external forces except ptmass. (4th order scheme) -!+ -!---------------------------------------------------------------- -subroutine step_extern_PEFRL(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - use part, only: isdead_or_accreted,igas,massoftype - use io, only:iverbose,id,master,iprint,warning,fatal - use io_summary, only:summary_variable,iosumextr,iosumextt - real, intent(in) :: dtsph,time - integer, intent(in) :: npart,nptmass - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real,parameter :: ck(5) = (/0.1786178958448091,-0.06626458266981849,0.77529337365001878,-0.06626458266981849,0.1786178958448091/) - real,parameter :: dk(4) = (/0.7123418310626054,-0.2123418310626054,-0.2123418310626054,0.7123418310626054/) - real :: dt,t_end_step,dtextforce_min - real :: pmassi,timei - logical :: done,last_step - integer :: nsubsteps - integer :: i - - ! - ! determine whether or not to use substepping - ! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - - timei = time - pmassi = massoftype(igas) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - - substeps: do while (timei <= t_end_step .and. .not.done) - timei = timei + dt - if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) - nsubsteps = nsubsteps + 1 - do i=1,4 - call drift_4th(ck(i),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - call kick_4th (dk(i),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - enddo - call drift_4th(ck(5),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - - if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"dt : ",dt - dtextforce_min = min(dtextforce_min,dtextforce) - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - enddo substeps - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - - -end subroutine step_extern_PEFRL - -!---------------------------------------------------------------- -!+ -! This is the equivalent of the routine below with no cooling -! and external forces except ptmass. (4th order scheme) -!+ -!---------------------------------------------------------------- -subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - use part, only: isdead_or_accreted,igas,massoftype - use io, only:iverbose,id,master,iprint,warning,fatal - use io_summary, only:summary_variable,iosumextr,iosumextt - real, intent(in) :: dtsph,time - integer, intent(in) :: npart,nptmass - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) - real,parameter :: ck(2) = (/0.5,0.5/) - real :: dt,t_end_step,dtextforce_min - real :: pmassi,timei - logical :: done,last_step - integer :: nsubsteps - - ! - ! determine whether or not to use substepping - ! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - - timei = time - pmassi = massoftype(igas) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - - substeps: do while (timei <= t_end_step .and. .not.done) - timei = timei + dt - if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) - nsubsteps = nsubsteps + 1 - call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - call kick_4th (dk(1),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift_4th(ck(1),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Direct calculation of the force and force gradient - call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) - ! call get_force_extrapol_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - ! xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Extrapolation of the modified force using Omelyan technique - - call kick_4th (dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - !print*,xyzmh_ptmass(1,1:20) - call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - call kick_4th (dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt - - dtextforce_min = min(dtextforce_min,dtextforce) - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - enddo substeps - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - - -end subroutine step_extern_FSI - - -!---------------------------------------------------------------- -!+ -! drift routine for the 4th order scheme -!+ -!---------------------------------------------------------------- - -subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - use part, only: isdead_or_accreted,ispinx,ispiny,ispinz - real, intent(in) :: dt,ck - integer, intent(in) :: npart,nptmass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) - integer :: i - - ! Drift gas particles - - !$omp parallel do default(none) & - !$omp shared(npart,xyzh,vxyzu,dt,ck) & - !$omp private(i) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - xyzh(1,i) = xyzh(1,i) + ck*dt*vxyzu(1,i) - xyzh(2,i) = xyzh(2,i) + ck*dt*vxyzu(2,i) - xyzh(3,i) = xyzh(3,i) + ck*dt*vxyzu(3,i) - endif - enddo - !$omp end parallel do - - ! Drift sink particles - - !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ck,dt) & - !$omp private(i) - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ck*dt*vxyz_ptmass(1,i) - xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ck*dt*vxyz_ptmass(2,i) - xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ck*dt*vxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + ck*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + ck*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + ck*dt*dsdt_ptmass(3,i) - endif - enddo - !$omp end parallel do -end subroutine drift_4th - - -!---------------------------------------------------------------- -!+ -! kick routine for the 4th order scheme -!+ -!---------------------------------------------------------------- - -subroutine kick_4th(dk,dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - use part, only: isdead_or_accreted,ispinx,ispiny,ispinz - real, intent(in) :: dt,dk - integer, intent(in) :: npart,nptmass - real, intent(in) :: xyzh(:,:) - real, intent(inout) :: vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - integer :: i - - ! Kick gas particles - - !$omp parallel do default(none) & - !$omp shared(npart,fext,xyzh,vxyzu,dt,dk) & - !$omp private(i) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - vxyzu(1,i) = vxyzu(1,i) + dk*dt*fext(1,i) - vxyzu(2,i) = vxyzu(2,i) + dk*dt*fext(2,i) - vxyzu(3,i) = vxyzu(3,i) + dk*dt*fext(3,i) - endif - enddo - !$omp end parallel do - - ! Kick sink particles - - !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,dsdt_ptmass,dk,dt) & - !$omp private(i) - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dk*dt*fxyz_ptmass(1,i) - vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dk*dt*fxyz_ptmass(2,i) - vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dk*dt*fxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dk*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dk*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dk*dt*dsdt_ptmass(3,i) - endif - enddo - !$omp end parallel do - -end subroutine kick_4th - -!---------------------------------------------------------------- -!+ -! force routine for the 4th order scheme -!+ -!---------------------------------------------------------------- - -subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - use options, only:iexternalforce - use dim, only:maxptmass - use io, only:iverbose,master,iprint,warning,fatal - use part, only:epot_sinksink,fxyz_ptmass_sinksink,dsdt_ptmass_sinksink - use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks - use timestep, only:bignumber,C_force - integer, intent(in):: nptmass,npart,nsubsteps - real, intent(inout) :: xyzh(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real, intent(inout) :: dtextforce - real, intent(in) :: timei,pmassi - integer :: merge_ij(nptmass) - integer :: merge_n - integer :: i - real :: dtf,dtextforcenew,dtsinkgas,dtphi2,fonrmax - real :: fextx,fexty,fextz - real :: fonrmaxi,phii,dtphi2i - - dtextforcenew = bignumber - dtsinkgas = bignumber - dtphi2 = bignumber - fonrmax = 0 - if (nptmass>0) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - endif - else - fxyz_ptmass(:,:) = 0. - dsdt_ptmass(:,:) = 0. - endif - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - dtextforcenew = min(dtextforcenew,C_force*dtf) - if (iverbose >= 3 ) write(iprint,*) "dt_sink_sink",dtextforcenew - !$omp parallel default(none) & - !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext) & - !$omp private(fextx,fexty,fextz) & - !$omp private(fonrmaxi,dtphi2i,phii,pmassi,dtf) & - !$omp reduction(min:dtextforcenew,dtsinkgas,dtphi2) & - !$omp reduction(max:fonrmax) & - !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) - !$omp do - do i=1,npart - fextx = 0. - fexty = 0. - fextz = 0. - call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,& - fextx,fexty,fextz,phii,pmassi,fxyz_ptmass,dsdt_ptmass,fonrmaxi,dtphi2i) - fonrmax = max(fonrmax,fonrmaxi) - dtphi2 = min(dtphi2,dtphi2i) - fext(1,i) = fextx - fext(2,i) = fexty - fext(3,i) = fextz - enddo - !$omp enddo - !$omp end parallel - - if (fonrmax > 0.) then - dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) - endif - if (iverbose >= 3 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas - dtextforcenew = min(dtextforcenew,dtsinkgas) - dtextforce = dtextforcenew - -end subroutine get_force_4th - - -!---------------------------------------------------------------- -!+ -! grad routine for the 4th order scheme (FSI) -!+ -!---------------------------------------------------------------- - - -subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) - use dim, only:maxptmass - use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink - integer, intent(in) :: nptmass,npart - real, intent(inout) :: xyzh(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) - real, intent(inout) :: dt - real, intent(in) :: pmassi - real :: fextx,fexty,fextz - integer :: i - - - if (nptmass>0) then - call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) - !print*,fxyz_ptmass(1,1:5) - else - fxyz_ptmass(:,:) = 0. - endif - - !$omp parallel default(none) & - !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,dt,pmassi) & - !$omp private(fextx,fexty,fextz) & - !$omp reduction(+:fxyz_ptmass) - !$omp do - do i=1,npart - fextx = 0. - fexty = 0. - fextz = 0. - call get_gradf_sink_gas(nptmass,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - xyzmh_ptmass,fextx,fexty,fextz,pmassi,fxyz_ptmass) - fext(1,i) = fext(1,i)+ fextx - fext(2,i) = fext(2,i)+ fexty - fext(3,i) = fext(3,i)+ fextz - enddo - !$omp enddo - !$omp end parallel - -end subroutine get_gradf_4th - - -!---------------------------------------------------------------- -!+ -! Substepping of external and sink particle forces. -! Also updates position of all particles even if no external -! forces applied. This is the internal loop of the RESPA -! algorithm over the "fast" forces. -!+ -!---------------------------------------------------------------- -subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time,nptmass, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) - use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome,itau_alloc,& - do_nucleation,update_muGamma,h2chemistry - use io, only:iverbose,id,master,iprint,warning,fatal - use externalforces, only:externalforce,accrete_particles,update_externalforce, & - update_vdependent_extforce_leapfrog,is_velocity_dependent - use ptmass, only:ptmass_predictor,ptmass_corrector,ptmass_accrete, & - get_accel_sink_gas,get_accel_sink_sink,merge_sinks,f_acc,pt_write_sinkev, & - idxmsi,idymsi,idzmsi,idmsi,idspinxsi,idspinysi,idspinzsi, & - idvxmsi,idvymsi,idvzmsi,idfxmsi,idfymsi,idfzmsi, & - ndptmass,update_ptmass - use options, only:iexternalforce,icooling - use part, only:maxphase,abundance,nabundances,eos_vars,epot_sinksink,eos_vars,& - isdead_or_accreted,iamboundary,igas,iphase,iamtype,massoftype,rhoh,divcurlv, & - fxyz_ptmass_sinksink,dsdt_ptmass_sinksink,dust_temp,tau,& - nucleation,idK2,idmu,idkappa,idgamma,imu,igamma - use chem, only:update_abundances,get_dphot - use cooling_ism, only:dphot0,energ_cooling_ism,dphotflag,abundsi,abundo,abunde,abundc,nabn - use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete,summary_accrete_fail - use timestep, only:bignumber,C_force - use timestep_sts, only:sts_it_n - use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi - use damping, only:calc_damp,apply_damp,idamp - use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation - use cooling, only:energ_cooling,cooling_in_step - use dust_formation, only:evolve_dust,calc_muGamma - use units, only:unit_density -#ifdef KROME - use part, only: T_gas_cool - use krome_interface, only: update_krome -#endif - integer, intent(in) :: npart,ntypes,nptmass - real, intent(in) :: dtsph,time - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:),fxyzu(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - integer(kind=1), intent(in) :: nbinmax - integer(kind=1), intent(inout) :: ibin_wake(:) - integer :: i,itype,nsubsteps,naccreted,nfail,nfaili,merge_n,nlive - integer :: merge_ij(nptmass) - integer(kind=1) :: ibin_wakei - real :: timei,hdt,fextx,fexty,fextz,fextxi,fextyi,fextzi,phii,pmassi - real :: dtphi2,dtphi2i,vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi - real :: dudtcool,fextv(3),poti,ui,rhoi,mui,gammai,ph,ph_tot - real :: dt,dtextforcenew,dtsinkgas,fonrmax,fonrmaxi - real :: dtf,accretedmass,t_end_step,dtextforce_min - real, allocatable :: dptmass(:,:) ! dptmass(ndptmass,nptmass) - real :: damp_fac,dphot - real, save :: dmdt = 0. - real :: abundi(nabn),gmwvar - logical :: accreted,extf_is_velocity_dependent - logical :: last_step,done - - -! -! determine whether or not to use substepping -! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - - timei = time - extf_is_velocity_dependent = is_velocity_dependent(iexternalforce) - accretedmass = 0. - itype = igas - pmassi = massoftype(igas) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - ! allocate memory for dptmass array (avoids ifort bug) - allocate(dptmass(ndptmass,nptmass)) - - substeps: do while (timei <= t_end_step .and. .not.done) - hdt = 0.5*dt - timei = timei + dt - if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) - nsubsteps = nsubsteps + 1 - dtextforcenew = bignumber - dtsinkgas = bignumber - dtphi2 = bignumber - - call calc_damp(time, damp_fac) - - if (.not.last_step .and. iverbose > 1 .and. id==master) then - write(iprint,"(a,f14.6)") '> external/ptmass forces only : t=',timei - endif - ! - ! update time-dependent external forces - ! - call update_externalforce(iexternalforce,timei,dmdt) - - !--------------------------- - ! predictor during substeps - !--------------------------- - ! - ! point mass predictor step - ! - if (nptmass > 0) then - if (id==master) then - call ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - ! - ! get sink-sink forces (and a new sink-sink timestep. Note: fxyz_ptmass is zeroed in this subroutine) - ! pass sink-sink forces to variable fxyz_ptmass_sinksink for later writing. - ! - if (iexternalforce==14) call update_externalforce(iexternalforce,timei,dmdt) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - endif - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf - else - fxyz_ptmass(:,:) = 0. - dsdt_ptmass(:,:) = 0. - endif - call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) - call bcast_mpi(vxyz_ptmass(:,1:nptmass)) - call bcast_mpi(epot_sinksink) - call bcast_mpi(dtf) - dtextforcenew = min(dtextforcenew,C_force*dtf) - endif - - ! - ! predictor step for sink-gas and external forces, also recompute sink-gas and external forces - ! - fonrmax = 0. - !$omp parallel default(none) & - !$omp shared(maxp,maxphase) & - !$omp shared(npart,xyzh,vxyzu,fext,abundance,iphase,ntypes,massoftype) & - !$omp shared(eos_vars,dust_temp,store_dust_temperature) & - !$omp shared(dt,hdt,timei,iexternalforce,extf_is_velocity_dependent,cooling_in_step,icooling) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,idamp,damp_fac) & - !$omp shared(nptmass,nsubsteps,C_force,divcurlv,dphotflag,dphot0) & - !$omp shared(abundc,abundo,abundsi,abunde) & - !$omp shared(nucleation,do_nucleation,update_muGamma,h2chemistry,unit_density) & - !$omp private(dphot,abundi,gmwvar,ph,ph_tot) & - !$omp private(ui,rhoi, mui, gammai) & - !$omp private(i,dudtcool,fxi,fyi,fzi,phii) & - !$omp private(fextx,fexty,fextz,fextxi,fextyi,fextzi,poti,fextv,accreted) & - !$omp private(fonrmaxi,dtphi2i,dtf) & - !$omp private(vxhalfi,vyhalfi,vzhalfi) & - !$omp firstprivate(pmassi,itype) & -#ifdef KROME - !$omp shared(T_gas_cool) & -#endif - !$omp reduction(+:accretedmass) & - !$omp reduction(min:dtextforcenew,dtsinkgas,dtphi2) & - !$omp reduction(max:fonrmax) & - !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) - !$omp do - predictor: do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - if (ntypes > 1 .and. maxphase==maxp) then - itype = iamtype(iphase(i)) - pmassi = massoftype(itype) - endif - ! - ! predict v to the half step - ! - vxyzu(1:3,i) = vxyzu(1:3,i) + hdt*fext(1:3,i) - ! - ! main position update - ! - xyzh(1,i) = xyzh(1,i) + dt*vxyzu(1,i) - xyzh(2,i) = xyzh(2,i) + dt*vxyzu(2,i) - xyzh(3,i) = xyzh(3,i) + dt*vxyzu(3,i) - ! - ! Skip remainder of update if boundary particle; note that fext==0 for these particles - if (iamboundary(itype)) cycle predictor - ! - ! compute and add sink-gas force - ! - fextx = 0. - fexty = 0. - fextz = 0. - if (nptmass > 0) then - call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),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 - ! - ! compute and add external forces - ! - if (iexternalforce > 0) then - call externalforce(iexternalforce,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i), & - timei,fextxi,fextyi,fextzi,poti,dtf,i) - dtextforcenew = min(dtextforcenew,C_force*dtf) - - fextx = fextx + fextxi - fexty = fexty + fextyi - fextz = fextz + fextzi - ! - ! Velocity-dependent external forces require special handling - ! in leapfrog (corrector is implicit) - ! - if (extf_is_velocity_dependent) then - vxhalfi = vxyzu(1,i) - vyhalfi = vxyzu(2,i) - vzhalfi = vxyzu(3,i) - fxi = fextx - fyi = fexty - fzi = fextz - call update_vdependent_extforce_leapfrog(iexternalforce,& - vxhalfi,vyhalfi,vzhalfi, & - fxi,fyi,fzi,fextv,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i)) - fextx = fextx + fextv(1) - fexty = fexty + fextv(2) - fextz = fextz + fextv(3) - endif - endif - if (idamp > 0) then - call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), xyzh(1:3,i), damp_fac) - endif - fext(1,i) = fextx - fext(2,i) = fexty - fext(3,i) = fextz - - if (maxvxyzu >= 4 .and. itype==igas) then - ! NOTE: The chemistry and cooling here is implicitly calculated. That is, - ! dt is *passed in* to the chemistry & cooling routines so that the - ! output will be at the correct time of time + dt. Since this is - ! implicit, there is no cooling timestep. Explicit cooling is - ! calculated in force and requires a cooling timestep. - - dudtcool = 0. - rhoi = rhoh(xyzh(4,i),pmassi) - ! - ! CHEMISTRY - ! - if (h2chemistry) then - ! - ! Get updated abundances of all species, updates 'chemarrays', - ! - dphot = get_dphot(dphotflag,dphot0,xyzh(1,i),xyzh(2,i),xyzh(3,i)) - call update_abundances(vxyzu(4,i),rhoi,abundance(:,i),nabundances,& - dphot,dt,abundi,nabn,eos_vars(imu,i),abundc,abunde,abundo,abundsi) - endif -#ifdef KROME - ! evolve chemical composition and determine new internal energy - ! Krome also computes cooling function but only associated with chemical processes - ui = vxyzu(4,i) - call update_krome(dt,xyzh(:,i),ui,rhoi,abundance(:,i),eos_vars(igamma,i),eos_vars(imu,i),T_gas_cool(i)) - dudtcool = (ui-vxyzu(4,i))/dt -#else - !evolve dust chemistry and compute dust cooling - if (do_nucleation) then - call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) - eos_vars(imu,i) = nucleation(idmu,i) - eos_vars(igamma,i) = nucleation(idgamma,i) - endif - ! - ! COOLING - ! - if (icooling > 0 .and. cooling_in_step) then - if (h2chemistry) then - ! - ! Call cooling routine, requiring total density, some distance measure and - ! abundances in the 'abund' format - ! - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i),abund_in=abundi) - elseif (store_dust_temperature) then - ! cooling with stored dust temperature - if (do_nucleation) then - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) - elseif (update_muGamma) then - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i)) - 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 - 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) - endif - endif -#endif - ! update internal energy - if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool - endif - endif - enddo predictor - !$omp enddo - !$omp end parallel - - if (nptmass > 0 .and. isink_radiation > 0) then - if (itau_alloc == 1) then - call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) - else - call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext) - endif - endif - - ! - ! reduction of sink-gas forces from each MPI thread - ! - if (nptmass > 0) then - call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) - endif - !--------------------------- - ! corrector during substeps - !--------------------------- - ! - ! corrector step on sinks (changes velocities only, does not change position) - ! - if (nptmass > 0) then - if (id==master) then - call ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,iexternalforce) - endif - call bcast_mpi(vxyz_ptmass(:,1:nptmass)) - endif - - ! - ! corrector step on gas particles (also accrete particles at end of step) - ! - accretedmass = 0. - nfail = 0 - naccreted = 0 - nlive = 0 - ibin_wakei = 0 - dptmass(:,:) = 0. - - !$omp parallel default(none) & - !$omp shared(maxp,maxphase) & - !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype,hdt,timei,nptmass,sts_it_n) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & - !$omp shared(iexternalforce) & - !$omp shared(nbinmax,ibin_wake) & - !$omp reduction(+:dptmass) & - !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & - !$omp firstprivate(itype,pmassi,ibin_wakei) & - !$omp reduction(+:accretedmass,nfail,naccreted,nlive) - !$omp do - accreteloop: do i=1,npart - 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 - endif - ! - ! correct v to the full step using only the external force - ! - vxyzu(1:3,i) = vxyzu(1:3,i) + hdt*fext(1:3,i) - - if (iexternalforce > 0) then - call accrete_particles(iexternalforce,xyzh(1,i),xyzh(2,i), & - xyzh(3,i),xyzh(4,i),pmassi,timei,accreted) - if (accreted) accretedmass = accretedmass + pmassi - endif - ! - ! accretion onto sink particles - ! need position, velocities and accelerations of both gas and sinks to be synchronised, - ! otherwise will not conserve momentum - ! Note: requiring sts_it_n since this is supertimestep with the most active particles - ! - if (nptmass > 0 .and. sts_it_n) then - fxi = fext(1,i) - fyi = fext(2,i) - fzi = fext(3,i) - if (ind_timesteps) ibin_wakei = ibin_wake(i) - - call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxi,fyi,fzi,& - itype,pmassi,xyzmh_ptmass,vxyz_ptmass,& - accreted,dptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) - if (accreted) then - naccreted = naccreted + 1 - cycle accreteloop - else - if (ind_timesteps) ibin_wake(i) = ibin_wakei - endif - if (nfaili > 1) nfail = nfail + 1 - endif - nlive = nlive + 1 - endif - enddo accreteloop - !$omp enddo - !$omp end parallel - - if (npart > 2 .and. nlive < 2) then - call fatal('step','all particles accreted',var='nlive',ival=nlive) - endif - - ! - ! reduction of sink particle changes across MPI - ! - if (nptmass > 0) then - call reduce_in_place_mpi('+',dptmass(:,1:nptmass)) - - naccreted = int(reduceall_mpi('+',naccreted)) - nfail = int(reduceall_mpi('+',nfail)) - - if (id==master) call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) - - call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) - call bcast_mpi(vxyz_ptmass(:,1:nptmass)) - call bcast_mpi(fxyz_ptmass(:,1:nptmass)) - endif - - if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a,i4,a)") & - 'Step: at time ',timei,', ',naccreted,' particles were accreted amongst ',nptmass,' sink(s).' - - if (nptmass > 0) then - call summary_accrete_fail(nfail) - call summary_accrete(nptmass) - ! only write to .ev during substeps if no gas particles present - if (npart==0) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & - fxyz_ptmass,fxyz_ptmass_sinksink) - endif - ! - ! check if timestep criterion was violated during substeps - ! - if (nptmass > 0) then - if (fonrmax > 0.) then - dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) - endif - if (iverbose >= 2) write(iprint,*) nsubsteps,'dt(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas - dtextforcenew = min(dtextforcenew,dtsinkgas) - endif - - dtextforcenew = reduceall_mpi('min',dtextforcenew) - - dtextforce_min = min(dtextforce_min,dtextforcenew) - dtextforce = dtextforcenew - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - enddo substeps - - deallocate(dptmass) - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - -end subroutine step_extern - !----------------------------------------------------- !+ ! Check error in v^1 compared to the predicted v^* From dba96b92542cf2c53fb8035c08c3bf8bf6a6b230 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 3 Apr 2024 13:09:45 +0200 Subject: [PATCH 334/814] (radiation) write X and Z infile options when using MESA opacities --- src/main/readwrite_infile.F90 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 016dc9174..c1714055c 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -111,7 +111,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) use dust_formation, only:write_options_dust_formation use nicil_sup, only:write_options_nicil use metric, only:write_options_metric - use eos, only:write_options_eos,ieos + use eos, only:write_options_eos,ieos,X_in,Z_in use ptmass, only:write_options_ptmass use ptmass_radiation,only:write_options_ptmass_radiation use cooling, only:write_options_cooling @@ -283,7 +283,12 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) call write_inopt(exchange_radiation_energy,'gas-rad_exchange','exchange energy between gas and radiation',iwritein) call write_inopt(limit_radiation_flux,'flux_limiter','limit radiation flux',iwritein) call write_inopt(iopacity_type,'iopacity_type','opacity method (0=inf,1=mesa,2=constant,-1=preserve)',iwritein) - if (iopacity_type == 2) call write_inopt(kappa_cgs,'kappa_cgs','constant opacity value in cm2/g',iwritein) + if (iopacity_type == 1) then + call write_inopt(X_in,'X','hydrogen mass fraction for MESA opacity table',iwritein) + call write_inopt(Z_in,'Z','metallicity for MESA opacity table',iwritein) + elseif (iopacity_type == 2) then + call write_inopt(kappa_cgs,'kappa_cgs','constant opacity value in cm2/g',iwritein) + endif if (implicit_radiation) then call write_inopt(tol_rad,'tol_rad','tolerance on backwards Euler implicit solve of dxi/dt',iwritein) call write_inopt(itsmax_rad,'itsmax_rad','max number of iterations allowed in implicit solver',iwritein) From 71d4766c02fdbcf0506e6ef4b8f442d129d822af Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 3 Apr 2024 13:25:48 +0200 Subject: [PATCH 335/814] (moddump_LTE_to_radiation) specify X_in and Z_in for opacity --- src/main/readwrite_infile.F90 | 2 +- src/utils/moddump_LTE_to_rad.f90 | 7 +++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index c1714055c..83278feaf 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -285,7 +285,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) call write_inopt(iopacity_type,'iopacity_type','opacity method (0=inf,1=mesa,2=constant,-1=preserve)',iwritein) if (iopacity_type == 1) then call write_inopt(X_in,'X','hydrogen mass fraction for MESA opacity table',iwritein) - call write_inopt(Z_in,'Z','metallicity for MESA opacity table',iwritein) + call write_inopt(Z_in,'Z','metallicity for MESA opacity table',iwritein) elseif (iopacity_type == 2) then call write_inopt(kappa_cgs,'kappa_cgs','constant opacity value in cm2/g',iwritein) endif diff --git a/src/utils/moddump_LTE_to_rad.f90 b/src/utils/moddump_LTE_to_rad.f90 index 2d03902d9..04b20e5c9 100644 --- a/src/utils/moddump_LTE_to_rad.f90 +++ b/src/utils/moddump_LTE_to_rad.f90 @@ -39,7 +39,10 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) if (.not. do_radiation) call fatal("moddump_LTE_to_rad","Not compiled with radiation") - mu = gmw + X_in=0.687 + Z_in=0.0142 + mu = 0.61821 + gmw = mu gamma_fixed = 5/3. ! gamma should be exactly 5/3, because that is what ieos=12 assumes gamma = gamma_fixed print*,'Assuming gmw = ',mu,' and gamma=',gamma,'X = ',X_in,'Z = ',Z_in ! X and Z are only used for calculating opacity @@ -52,7 +55,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call get_idealplusrad_temp(rho_cgs,vxyzu(4,i)*unit_ergg,mu,tempi,ierr) ! calculate u and xi - ugasi = ugas_from_Tgas(tempi,gamma,gmw) + ugasi = ugas_from_Tgas(tempi,gamma,mu) vxyzu(4,i) = ugasi rad(iradxi,i) = radiation_and_gas_temperature_equal(rhoi,ugasi,gamma,mu) From d74d3586a8c0f0e69a4c45a90084f44285095dbd Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 4 Apr 2024 10:13:24 +1100 Subject: [PATCH 336/814] add main integration routine for subsystems, still need to fix the backup data array... --- src/main/options.f90 | 2 + src/main/sdar_group.f90 | 247 +++++++++++++++++++++++++++++++++++++++- src/main/utils_sdar.f90 | 9 +- 3 files changed, 248 insertions(+), 10 deletions(-) diff --git a/src/main/options.f90 b/src/main/options.f90 index 0312c9371..5e49a8f40 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -60,6 +60,7 @@ module options ! Regularisation method and/or higher order integrator logical, public :: use_fourthorder + logical, public :: use_regnbody public :: set_default_options @@ -175,6 +176,7 @@ subroutine set_default_options use_var_comp = .false. use_fourthorder = .false. + use_regnbody = .false. end subroutine set_default_options diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 3687c41c5..6340c4c25 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -7,6 +7,7 @@ module sdar_group ! ! :Owner: Daniel Price ! + use utils_sdar implicit none public :: group_identify public :: evolve_groups @@ -18,11 +19,11 @@ module sdar_group private contains -! +!----------------------------------------------- ! ! Group identification routines ! -! +!----------------------------------------------- subroutine group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer, intent(in) :: group_info(:,:) @@ -146,11 +147,11 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) enddo end subroutine matrix_construction -! +!--------------------------------------------- ! ! Routines needed to integrate subgroups ! -! +!--------------------------------------------- subroutine evolve_groups(n_group,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) use part, only: igid,igarg,igsize,igcum @@ -174,16 +175,192 @@ subroutine evolve_groups(n_group,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ end subroutine evolve_groups -subroutine integrate_to_time() +subroutine integrate_to_time(start_id,end_id,gsize,ds_init,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & + fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: start_id,end_id,gsize + real, intent(in) :: ds_init + real :: ds(2) + real :: timetable(ck_size) + integer :: switch + integer :: step_count_int,step_count_tsyn,n_step_end + real :: dt,dt_end,step_modif,t_old,W_old + logical :: t_end_flag,backup_flag + integer :: i + + step_count_int = 0 + step_count_tsyn = 0 + n_step_end = 0 + t_end_flag = .false. + backup_flag = .true. + ds = ds_init + switch = 1 + + do while (.true.) + + if (backup_flag) then + call backup_data(gsize,xyzmh_ptmass,vxyz_ptmass,bdata) + else + call restore_state(gsize,xyzmh_ptmass,vxyz_ptmass,tcoord,t_old,W,W_old,bdata) + endif + t_old = tcoord + W_old = W + if (gsize>1) then + do i=1,ck_size + call drift_TTL (gsize,xyzmh_ptmass,vxyz_ptmass,ds(switch)*ck(i), & + tcoord,W,start_id,end_id) + time_table(i) = tcoord + call kick_TTL (gsize,xyzmh_ptmass,vxyz_ptmass,fxyz,gtgrad, & + ds(switch)*dk(i),W,om,start_id,end_id) + enddo + else + call oneStep_bin(gsize,xyzmh_ptmass,vxyz_ptmass,fxyz,gtgrad, & + ds(switch),tcoord,W,om,time_table,start_id,end_id) + endif + dt = tcoord - t_old + + step_count_int = step_count_int + 1 + + if(step_count_int > max_step) then + print*,"MAX STEP NUMBER, ABORT !!!" + call abort + endif + + if ((.not.t_end_flag).and.(dt<0.)) then + !print*,"neg dt !!!",tnext,dt + call regularstepfactor((abs(tnext/dt))**(1./6.),step_modif) + step_modif = min(max(step_modif,0.0625),0.5) + ds(switch) = ds(switch)*step_modif + ds(3-switch) = ds(switch) + + backup_flag = .false. + continue + endif + + if (tcoord < tnext - time_error) then + if (t_end_flag .and. (ds(switch)==ds(3-switch))) then + step_count_tsyn = step_count_tsyn + 1 + dt_end = tnext - tcoord + if (dt<0.) then + call regularstepfactor((abs(tnext/dt))**(1./6.),step_modif) + step_modif = min(max(step_modif,0.0625),0.5) + ds(switch) = ds(switch)*step_modif + ds(3-switch) = ds(switch) + else if ((n_step_end > 1) .and. (dt<0.3*dt_end)) then + ds(3-switch) = ds(switch) * dt_end/dt + else + n_step_end = n_step_end + 1 + endif + endif + ds(switch) = ds(3-switch) + switch = 3 - switch + if (dt>0) then + backup_flag = .true. + else + backup_flag = .false. + endif + + else if (tcoord > tnext + time_error) then + t_end_flag = .true. + backup_flag = .false. + n_step_end = 0 + step_count_tsyn = step_count_tsyn + 1 + + call new_ds_sync_sup(ds,time_table,tnext,switch) + else + exit + endif + enddo end subroutine integrate_to_time +subroutine regularstepfactor(fac_in,fac_out) + real, intent(in) :: fac_in + real, intent(out):: fac_out + fac_out = 1.0 + if (fac_in<1) then + do while (fac_out>fac_in) + fac_out = fac_out*0.5 + enddo + else + do while(fac_out<=fac_in) + fac_out = fac_out *2 + enddo + fac_out = fac_out*0.5 + endif +end subroutine regularstepfactor + +subroutine new_ds_sync_sup(ds,time_table,tnext,switch) + real, intent(inout) :: ds(:) + real, intent(in) :: time_table(:) + real, intent(in) :: tnext + integer, intent(in) :: switch + integer :: i,k + real :: tp,dtk,dstmp + do i=1,ck_size + k = cck_sorted_id(i) + if(tnext Date: Thu, 4 Apr 2024 10:44:46 +1100 Subject: [PATCH 337/814] add gradient acceleration kernel in the python script --- scripts/kernels.py | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/scripts/kernels.py b/scripts/kernels.py index 124b5d4e8..28a7d900f 100755 --- a/scripts/kernels.py +++ b/scripts/kernels.py @@ -622,6 +622,7 @@ def printkernel_phantom(w,R,name): #--double-hump kernel used in drag routines, with normalisation # wdrag = piecewise_fold(w*q*q) + gradf_soft = piecewise_fold(q*diff(fsoft,q)-fsoft) c3Ddrag = sympify(1)/(integrate(4*pi*q*q*wdrag,(q,0,R))) avm83, avm97, avratio = get_avdiss(w,R) lb = "!"+"-"*62 @@ -794,6 +795,30 @@ def printkernel_phantom(w,R,name): print (" fsoft = %s" %fmtp(fsoft)) print ("\nend subroutine kernel_softening\n") print ("!------------------------------------------") + print ("! gradient acceleration kernel needed for") + print ("! use in Foward symplectic integrator") + print ("!------------------------------------------") + print ("pure real function kernel_gradsoftening(q2,q,gradf_soft)") + print (" real, intent(in) :: q2,q") + print (" real, intent(out):: gradf_soft") + print_decl(gradf_soft) + print (" !--double hump %s kernel" %name) + if isinstance(gradf_soft, Piecewise): + for i, (e, c) in enumerate(gradf_soft.args): + if i == 0: + print (" if (%s) then" %fmt(c)) + elif i == len(gradf_soft.args)-1 and c == True: + print (" else") + else: + print (" elseif (%s) then" %fmt(c)) + print_defs(4,fmtp(e)) + print (" gradf_soft = %s" %fmtp(e)) + print (" endif") + else: + print_defs(4,fmtp(gradf_soft)) + print (" gradf_soft = %s" %fmtp(gradf_soft)) + print ("\nend function kernel_gradsoftening\n") + print ("!------------------------------------------") print ("! double-humped version of the kernel for") print ("! use in drag force calculations") print ("!------------------------------------------") @@ -957,7 +982,7 @@ def f6(R): # define which kernel to use #f, name = sinq(R,3) #f, name = m5(R) -f, name = w6(R) +f, name = m4(R) #print_avdiss(f,R) #printvariances(f,R) From fc926ff82c3c8ff35e035029437a90c28876ac63 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 4 Apr 2024 11:31:24 +1100 Subject: [PATCH 338/814] remove kernel in ptmass and fix bad sign --- src/main/ptmass.F90 | 65 +++++++++++++++------------------------------ 1 file changed, 22 insertions(+), 43 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 5a82d13c1..dbee66a25 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -111,27 +111,6 @@ module ptmass private contains - -!---------------------------------------------------------------- -!+ -! Kernel for gradient force calculation, necessary for the FSI -!+ -!---------------------------------------------------------------- -pure subroutine kernel_grad_soft(q2,q,gsoft) - real, intent(in) :: q2,q - real, intent(out) :: gsoft - real :: q4,q6 - - if (q<1.) then - gsoft = q*(-15.*q2*q-24.*q2)/10. - else - q4 = q2*q2 - q6 = q4*q2 - gsoft = (25.*q6-120.*q4*q+150.*q4-10.)/(50.*q2) - endif - -end subroutine kernel_grad_soft - !---------------------------------------------------------------- !+ ! if (tofrom==.true.) Acceleration from/to gas particles due to sink particles; @@ -499,7 +478,7 @@ end subroutine get_accel_sink_sink !---------------------------------------------------------------- subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & pmassi,fxyz_ptmass) - use kernel, only:kernel_softening,radkern + use kernel, only:kernel_softening,kernel_gradsoftening,radkern integer, intent(in) :: nptmass real, intent(in) :: xi,yi,zi,hi,dt real, intent(inout) :: fxi,fyi,fzi @@ -550,7 +529,7 @@ subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & ! first grad term of sink from gas g21 = pmassi*fsoft*ddr - call kernel_grad_soft(q2i,qi,gsoft) + call kernel_gradsoftening(q2i,qi,gsoft) dr3 = ddr*ddr*ddr @@ -560,9 +539,9 @@ subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & ! Second grad term of sink from gas g22 = pmassi*gsoft*dr3*drdotdf - gtmpxi = gtmpxi - gpref*(dfx*g11-dx*g12) - gtmpyi = gtmpyi - gpref*(dfy*g11-dy*g12) - gtmpzi = gtmpzi - gpref*(dfz*g11-dz*g12) + gtmpxi = gtmpxi - gpref*(dfx*g11+dx*g12) + gtmpyi = gtmpyi - gpref*(dfy*g11+dy*g12) + gtmpzi = gtmpzi - gpref*(dfz*g11+dz*g12) else @@ -578,21 +557,21 @@ subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & g21 = pmassi*dr3 ! first grad term of gas due to point mass particle - g12 = 3*pmassj*dr3*ddr*ddr*drdotdf + g12 = -3.*pmassj*dr3*ddr*ddr*drdotdf ! first grad term of sink from gas - g22 = 3*pmassi*dr3*ddr*ddr*drdotdf + g22 = -3.*pmassi*dr3*ddr*ddr*drdotdf - gtmpxi = gtmpxi - gpref*(dfx*g11-dx*g12) - gtmpyi = gtmpyi - gpref*(dfy*g11-dy*g12) - gtmpzi = gtmpzi - gpref*(dfz*g11-dz*g12) + gtmpxi = gtmpxi - gpref*(dfx*g11+dx*g12) + gtmpyi = gtmpyi - gpref*(dfy*g11+dy*g12) + gtmpzi = gtmpzi - gpref*(dfz*g11+dz*g12) endif ! backreaction of gas onto sink - fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + gpref*(dfx*g21 - dx*g22) - fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + gpref*(dfy*g21 - dy*g22) - fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + gpref*(dfz*g21 - dz*g22) + fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + gpref*(dfx*g21 + dx*g22) + fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + gpref*(dfy*g21 + dy*g22) + fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + gpref*(dfz*g21 + dz*g22) enddo ! ! add temporary sums to existing force on gas particle @@ -609,7 +588,7 @@ end subroutine get_gradf_sink_gas !+ !---------------------------------------------------------------- subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) - use kernel, only:kernel_softening,radkern + use kernel, only:kernel_softening,kernel_gradsoftening,radkern integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: fxyz_ptmass(4,nptmass) @@ -680,15 +659,15 @@ subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) ! gradf part 1 of sink1 from sink2 g1 = fsoft*hsoft21*ddr - call kernel_grad_soft(q2i,qi,gsoft) + call kernel_gradsoftening(q2i,qi,gsoft) dr3 = ddr*ddr*ddr ! gradf part 2 of sink1 from sink2 g2 = gsoft*hsoft21*dr3*drdotdf - gxi = gxi - gpref*(dfx*g1 - dx*g2) - gyi = gyi - gpref*(dfy*g1 - dy*g2) - gzi = gzi - gpref*(dfz*g1 - dz*g2) + gxi = gxi - gpref*(dfx*g1 + dx*g2) + gyi = gyi - gpref*(dfy*g1 + dy*g2) + gzi = gzi - gpref*(dfz*g1 + dz*g2) else ! no softening on the sink-sink interaction @@ -697,10 +676,10 @@ subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) ! gradf part 1 of sink1 from sink2 g1 = dr3 ! gradf part 2 of sink1 from sink2 - g2 = 3*dr3*ddr*ddr*drdotdf - gxi = gxi - gpref*(dfx*g1 - dx*g2) - gyi = gyi - gpref*(dfy*g1 - dy*g2) - gzi = gzi - gpref*(dfz*g1 - dz*g2) + g2 = -3.*dr3*ddr*ddr*drdotdf + gxi = gxi - gpref*(dfx*g1 + dx*g2) + gyi = gyi - gpref*(dfy*g1 + dy*g2) + gzi = gzi - gpref*(dfz*g1 + dz*g2) endif enddo ! From 5999850394de8355ee83ff9f14d23e8a16bd16f5 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 5 Apr 2024 13:00:46 +1100 Subject: [PATCH 339/814] remove last comp flag and new version of form group without recursion --- src/main/part.F90 | 8 ++---- src/main/sdar_group.f90 | 54 ++++++++++++++++++++++++----------------- 2 files changed, 34 insertions(+), 28 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index fe849c8d3..9cc2e8c25 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -283,20 +283,16 @@ module part ! !-- Regularisation algorithm allocation ! -#ifdef NBODYREG integer, allocatable :: group_info(:,:) integer(kind=1), allocatable :: nmatrix(:,:) integer, parameter :: igarg = 1 ! idx of the particle member of a group - integer, parameter :: igid = 2 ! id of the group (may be unescessary) - integer, parameter :: igsize = 3 ! size of the group (may be unescessary) - integer, parameter :: igcum = 4 ! cumulative sum of the indices to find the starting and ending point of a group + integer, parameter :: igcum = 2 ! cumulative sum of the indices to find the starting and ending point of a group ! needed for group identification and sorting integer :: ngroup = 0 integer :: n_ingroup = 0 integer :: n_sing = 0 ! Gradient of the time transformation function real, allocatable :: gtgrad(:,:) -#endif ! !--derivatives (only needed if derivs is called) ! @@ -478,7 +474,7 @@ subroutine allocate_part call allocate_array('abundance', abundance, nabundances, maxp_h2) endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) - call allocate_array('group_info', group_info, 4, maxptmass) + call allocate_array('group_info', group_info, 2, maxptmass) call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) call allocate_array("gtgrad", gtgrad, 3, maxptmass) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 6340c4c25..43cfd0366 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -39,49 +39,59 @@ subroutine group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) end subroutine group_identify -subroutine form_group(group_info,nmatrix,nptmass) - use part, only : igid,igarg,igsize,igcum +subroutine form_group(nmatrix,nptmass,group_info) + use part, only : igid,igcum + use dim, only : maxptmass integer(kind=1), intent(in) :: nmatrix(:,:) integer, intent(out):: group_info(:,:) integer, intent(in) :: nptmass - integer :: i - logical :: visited(nptmass) + integer :: i,ncg + logical :: visited(maxptmass) + integer :: stack(maxptmass) do i=1,nptmass if(.not.visited(i)) then n_ingroup = n_ingroup + 1 - call dfs(i,i,visited,group_info,nmatrix,nptmass,n_ingroup) - if (group_info(igsize,i)>1)then + call dfs(i,i,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) + if (ncg>1)then ngroup = ngroup + 1 - group_info(igcum,ngroup+1) = group_info(igsize,i) + group_info(igcum,ngroup) + group_info(igcum,ngroup+1) = ncg + group_info(igcum,ngroup) else - n_ingroup= n_ingroup - 1 - group_info(igsize,i) = 0 + n_ingroup = n_ingroup - 1 group_info(igarg,nptmass-n_sing) = i - group_info(igid,nptmass-n_sing) = 0 n_sing = n_sing + 1 endif endif enddo end subroutine form_group -recursive subroutine dfs(inode,iroot,visited,group_info,nmatrix,npt,n_ingroup) - use part, only : igid,igarg,igsize,igcum - integer, intent(in) :: inode,npt,iroot +subroutine dfs(inode,iroot,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) + use part, only : igarg + integer, intent(in) :: inode,nptmass,iroot + integer, intent(out) :: ncg integer(kind=1), intent(in) :: nmatrix(:,:) integer, intent(inout) :: group_info(:,:) integer, intent(inout) :: n_ingroup + integer, intent(out) :: stack(:) logical, intent(inout) :: visited(:) - integer :: j - !print*,nping,inode + integer :: j,stack_top + + ncg = 1 group_info(igarg,n_ingroup) = inode - group_info(igid,n_ingroup) = iroot - group_info(igsize,iroot) = group_info(igsize,iroot)+1 + stack_top = stack_top + 1 + stack(stack_top) = inode visited(inode) = .true. - do j=1,npt - if (nmatrix(inode,j)==1 .and. (visited(j).eqv..false.)) then - n_ingroup = n_ingroup + 1 - call dfs(j,iroot,visited,group_info,nmatrix,npt,n_ingroup) - endif + do while(stack_top>0) + inode = stack(stack_top) + stack_top = stack_top - 1 + do j= 1,nptmass + if (nmatrix(inode,j)==1 .and. .not.(visited(j))) then + n_ingroup = n_ingroup + 1 + stack_top = stack_top + 1 + stack(stack_top) = j + visited(j) = .true. + group_info(igarg,n_ingroup) = j + endif + enddo enddo end subroutine dfs From 751fd8106bbb2e5611fa27e35eccaa2332615b3f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 5 Apr 2024 13:13:56 +1100 Subject: [PATCH 340/814] parallel version for adjacency matrix construction --- src/main/sdar_group.f90 | 65 +++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 43cfd0366..45d2821c2 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -107,8 +107,12 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) real :: aij,eij,B,rperi integer :: i,j - nmatrix = 0. - + !$omp parallel do default(none) & + !$omp shared(nptmass,r_neigh,C_bin,t_crit,nmatrix) & + !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & + !$omp private(dx,dy,dz,r,r2) & + !$omp private(dvx,dvy,dvz,v2) & + !$omp private(mu,aij,eij,B,r_peri) & do i=1,nptmass xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) @@ -119,42 +123,39 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) vzi = vxyz_ptmass(3,i) do j=1,nptmass if(i==j) cycle - if(j>i) then - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - r2 = dx**2+dy**2+dz**2 - r = sqrt(r2) - if (rr_search) then + nmatrix(i,j) = 0 + cycle + endif + mu = mi + xyzmh_ptmass(4,j) + dvx = vxi - vxyz_ptmass(1,j) + dvy = vyi - vxyz_ptmass(2,j) + dvz = vzi - vxyz_ptmass(3,j) + v2 = dvx**2+dvy**2+dvz**2 + call bindE(v2,r,mu,B) + call extract_a(r,mu,v2,aij) + if (B<0) then + if (aijr_search) then - nmatrix(i,j) = 0 - cycle - endif - mu = mi + xyzmh_ptmass(4,j) - dvx = vxi - vxyz_ptmass(1,j) - dvy = vyi - vxyz_ptmass(2,j) - dvz = vzi - vxyz_ptmass(3,j) - v2 = dvx**2+dvy**2+dvz**2 - call bindE(v2,r,mu,B) - call extract_a(r,mu,v2,aij) - if (B<0) then - if (aij Date: Fri, 5 Apr 2024 16:25:14 +1100 Subject: [PATCH 341/814] add subsytem time_step calculation --- src/main/sdar_group.f90 | 106 +++++++++++++++++++++++++++++--------- src/main/utils_kepler.f90 | 14 +++-- 2 files changed, 94 insertions(+), 26 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 45d2821c2..92588763b 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -16,6 +16,7 @@ module sdar_group real, public :: t_crit = 0.0 real, public :: C_bin = 0.0 real, public :: r_search = 0.0 + real, parameter :: eta_pert = 0.02 private contains @@ -97,7 +98,7 @@ end subroutine dfs subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) - use utils_kepler, only: bindE,extract_a,extract_e,extract_ea + use utils_kepler, only: Espec,extract_a,extract_e,extract_ea integer(kind=1), intent(out):: nmatrix(:,:) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(in) :: vxyz_ptmass(:,:) @@ -140,7 +141,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) dvy = vyi - vxyz_ptmass(2,j) dvz = vzi - vxyz_ptmass(3,j) v2 = dvx**2+dvy**2+dvz**2 - call bindE(v2,r,mu,B) + call Espec(v2,r,mu,B) call extract_a(r,mu,v2,aij) if (B<0) then if (aij 2 + + call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismultiple,ds_init) + step_count_int = 0 step_count_tsyn = 0 n_step_end = 0 @@ -480,7 +487,7 @@ subroutine oneStep_bin(gsize,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,ds,tcoo end subroutine oneStep_bin -subroutine get_force_TTL(xyzmh_ptmass,om,fxyz_ptmass,gtgrad,s_id,e_id) +subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) real, intent(out) :: om @@ -500,10 +507,10 @@ subroutine get_force_TTL(xyzmh_ptmass,om,fxyz_ptmass,gtgrad,s_id,e_id) do i=s_id,e_id gtki = 0. - xi = xyzmh_ptmass(1,j) - yi = xyzmh_ptmass(2,j) - zi = xyzmh_ptmass(3,j) - mi = xyzmh_ptmass(4,j) + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + mi = xyzmh_ptmass(4,i) do j=s_id,e_id if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) @@ -528,34 +535,87 @@ subroutine get_force_TTL(xyzmh_ptmass,om,fxyz_ptmass,gtgrad,s_id,e_id) end subroutine get_force_TTL -subroutine initial_OM(xyzmh_ptmass,om,s_id,e_id) - real, intent(in) :: xyzmh_ptmass(:,:) - real, intent(out) :: om +subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismultiple,ds_init) + use utils_kepler, only :extract_a_dot,extract_a,Espec + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass + real, intent(inout) :: fxyz_ptmass(:,:) + real, intent(out) :: om,ds_init + logical, intent(in) :: ismultiple integer, intent(in) :: s_id,e_id + real :: mi,mj,xi,yi,zi,dx,dy,dz,r2 + real :: vxi,vyi,vzi,dvx,dvy,dvz,v,rdotv,axi,ayi,azi,gravfi + real :: gravf,gtki + real :: Edot,E,semi,semidot integer :: i,j - real :: gtki,dx,dy,dz,xi,yi,zi,r1 + Edot = 0. + E = 0. om = 0. + do i=s_id,e_id + fxyz_ptmass(1,i) = 0. + fxyz_ptmass(2,i) = 0. + fxyz_ptmass(3,i) = 0. + enddo do i=s_id,e_id gtki = 0. + gravfi = 0. xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) mi = xyzmh_ptmass(4,i) + vxi = vxyz_ptmass(1,i) + vyi = vxyz_ptmass(2,i) + vzi = vxyz_ptmass(3,i) do j=s_id,e_id - if (i == j) cycle + if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) - r1 = 1./sqrt(dx**2+dy**2+dz**2) - gtki = gtki + xyzmh_ptmass(4,j)*r1 + dvx = vxi - vxyz_ptmass(1,j) + dvy = vyi - vxyz_ptmass(2,j) + dvz = vzi - vxyz_ptmass(3,j) + r2 = dx**2+dy**2+dz**3 + r = sqrt(r) + mj = xyzmh_ptmass(4,j) + gravf = xyzmh_ptmass(4,j)*(1./r2*r) + gtki = gtki + mj*(1./r) + fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + dx*gravf + fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + dy*gravf + fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + dz*gravf + if (ismultiple) then + rdotv = dx*dvx + dy*dvy + dz*dvz + gravfi = gravfi + gravf*rdotv + else + v2 = dvx**2 + dvy**2 + dvz**2 + v = sqrt(v2) + endif + enddo om = om + gtki*mi + axi = fxyz_ptmass(1,i) + ayi = fxyz_ptmass(2,i) + azi = fxyz_ptmass(3,i) + acc = sqrt(axi**2 + ayi**2 + azi**2) + if (ismultiple) then + vi = sqrt(vxi**2 + vyi**2 + vzi**2) + Edot = Edot + mi*(vi*a - gravfi) + E = E + 0.5*mi*vi**2 - om + else + mu = mi*mj + call extract_a_dot(r2,r,mu,v2,v,acc,semidot) + call extract_a(r,mu,v2,semi) + endif enddo om = om*0.5 -end subroutine initial_OM + if (ismultiple) then + ds_init = eta_pert * (Edot/E) + else + ds_init = eta_pert * (semidot/semi) + endif + +end subroutine initial_int end module sdar_group diff --git a/src/main/utils_kepler.f90 b/src/main/utils_kepler.f90 index 4016871c7..661f3edf1 100644 --- a/src/main/utils_kepler.f90 +++ b/src/main/utils_kepler.f90 @@ -3,21 +3,29 @@ module utils_kepler implicit none contains -subroutine bindE(v2,r,mu,B) +subroutine Espec(v2,r,mu,B) real, intent(in) :: v2,r,mu real, intent(out) :: B B = 0.5*v2 - mu/r -end subroutine bindE +end subroutine Espec subroutine extract_a(r,mu,v2,aij) real, intent(in) :: r,mu,v2 real, intent(out):: aij - aij = (r*mu)/(2*mu-r*v2) + aij = (r*mu)/(2.*mu-r*v2) end subroutine extract_a +subroutine extract_a_dot(r2,r,mu,v2,v,acc,adot) + real, intent(in) :: r2,r,mu,v2,v,acc + real, intent(inout) :: adot + real :: mu2 + mu2 = mu**2 + adot = 2.*(mu2*v+r2*v*acc)/(2.*mu-r*v2)**2 +end subroutine extract_a_dot + subroutine extract_e(x,y,z,vx,vy,vz,mu,r,eij) real, intent(in) :: x,y,z,vx,vy,vz,mu,r real, intent(out):: eij From 9a98c69ae72e6acdcef2ef5474eab84e0ad08fd8 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 5 Apr 2024 21:31:17 +1100 Subject: [PATCH 342/814] updated kernels.py to spit out gradient term needed in 4th order integrator --- scripts/kernels.py | 92 +++++++++++++++++++++++++++++++++------------- 1 file changed, 66 insertions(+), 26 deletions(-) diff --git a/scripts/kernels.py b/scripts/kernels.py index 124b5d4e8..adf42eed6 100755 --- a/scripts/kernels.py +++ b/scripts/kernels.py @@ -84,6 +84,8 @@ def getkernelfuncs(w,R): #--work out the integration constant for the potential # parg = list(pot.args) + lastarg = len(pot.args) - 1 + parg[lastarg] = (sympify(-1/(q)),pot.args[lastarg].cond) if isinstance(pot, Piecewise): for i, (e, c) in reversed(list(enumerate(pot.args))): if i < len(pot.args) - 1: @@ -98,15 +100,28 @@ def getkernelfuncs(w,R): #--derivative of potential with respect to h # dpotdh = pot - parg = list(pot.args) + pharg = list(pot.args) if isinstance(pot, Piecewise): for i, (e, c) in enumerate(pot.args): ep = simplify(-e - q*diff(e,q)) - parg[i] = (ep, c) - tuple(parg) - dpotdh = Piecewise(*parg) + pharg[i] = (ep, c) + tuple(pharg) + dpotdh = Piecewise(*pharg) + + # + #--kernel function needed in gradient acceleration + # for 4th order Forward Symplectic Integrator + # + farg = list(fsoft.args) + if isinstance(fsoft, Piecewise): + for i, (e, c) in enumerate(fsoft.args): + ep = simplify(q*diff(e,q) - e) + farg[i] = (ep, c) + tuple(farg) + gsoft = Piecewise(*farg) - return (dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh) + #gsoft = piecewise_fold(simplify(diff(q*fsoft,q) - fsoft)) + return (dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh, gsoft) #--------------------------------------------- # function to get the variance of the kernel @@ -225,11 +240,12 @@ def printvariances(w,R): # function to print basic kernel information to the screen #----------------------------------------------------------- def printkernel(w,R): - dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh = getkernelfuncs(w,R) + dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh, psi = getkernelfuncs(w,R) print ("\n%s W:" %name) print (w) print ("\nFirst derivative:") print (dw) + #print (fmt(dw)) print ("\n2nd derivative:") print (d2w) print ("\nnormalisation:") @@ -241,6 +257,8 @@ def printkernel(w,R): avnorm = -pi/8*c2D*integrate(q*q*dw,(q,0,R)) print (avnorm) printvariances(w,R) + print ("\n gradient acceleration term:") + print (psi) return #------------------------------------------------------------- @@ -290,6 +308,10 @@ def fmt(e): # replace 15*x with 15.*x as long as it is not **15*x s = re.sub("(?!\*\d+)(\D\d+)\*","\g<1>.*", s) + # replace " 2)" with " 2.)" + # Use re.sub to replace " digit)" with " digit.)" + s = re.sub(r" (\d)\)", r" \1.)", s) + f = sympify(s) # # expand if it makes it shorter @@ -302,6 +324,9 @@ def fmt(e): # replace 1.4000000 with 1.4 g = re.sub("(\.[1-9]*)(0+)(\D|$)","\g<1>\g<3>", g) + # replace " 2)" with " 2.)" + # Use re.sub to replace " digit)" with " digit.)" + g = re.sub(r" (\d)\)", r" \1.)", g) # only return simplify-ed strings if no fully expanded floats 0.345242545.. if re.search("(\.\d\d\d\d\d+)",g): @@ -614,7 +639,7 @@ def print_decl(w): #--------------------------------- def printkernel_phantom(w,R,name): import datetime - dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh = getkernelfuncs(w,R) + dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh, gsoft = getkernelfuncs(w,R) w0 = w.subs(q,0) dpotdh0 = dpotdh.subs(q,0) #print("GOT dpotdh0",simplify(dpotdh0)) @@ -627,31 +652,26 @@ def printkernel_phantom(w,R,name): lb = "!"+"-"*62 print ("!--------------------------------------------------------------------------!") print ("! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. !") - print ("! Copyright (c) 2007-2019 The Authors (see AUTHORS) !") + print ("! Copyright (c) 2007-2024 The Authors (see AUTHORS) !") print ("! See LICENCE file for usage and distribution conditions !") - print ("! http://phantomsph.bitbucket.io/ !") + print ("! http://phantomsph.github.io/ !") print ("!--------------------------------------------------------------------------!") - print ("!+") - print ("! MODULE: kernel") + print ("module kernel") print ("!") - print ("! DESCRIPTION:") - print ("! This module implements the %s kernel" %name) + print ("! This module implements the %s kernel" %name) print ("! DO NOT EDIT - auto-generated by kernels.py") print ("!") - print ("! REFERENCES: None") + print ("! :References: None") print ("!") - print ("! OWNER: Daniel Price") + print ("! :Owner: Daniel Price") print ("!") - print ("! $Id:$") + print ("! :Runtime parameters: None") print ("!") - print ("! RUNTIME PARAMETERS: None") + print ("! :Dependencies: physcon") print ("!") - print ("! DEPENDENCIES: physcon") + print ("! :Generated:",datetime.datetime.now()) print ("!") - print ("! GENERATED:",datetime.datetime.now()) - print ("!+") print ("!--------------------------------------------------------------------------") - print ("module kernel") print (" use physcon, only:pi") print (" implicit none") print (" character(len=%i), public :: kernelname = '%s'" %(len(name),name)) @@ -660,9 +680,9 @@ def printkernel_phantom(w,R,name): print (" real, parameter, public :: cnormk = %s" %fmt(c3D)) print (" real, parameter, public :: wab0 = %s, gradh0 = -3.*wab0" %fmt(w0)) print (" real, parameter, public :: dphidh0 = %s" %fmtp(dpotdh0)) - print (" real, parameter, public :: cnormk_drag = %s " %fmt(c3Ddrag)) + print (" real, parameter, public :: cnormk_drag = %s" %fmt(c3Ddrag)) var, relvar, reldev = getvar(w,R) - print (" real, parameter, public :: hfact_default = %.1f " %(1.2/reldev[2])) + print (" real, parameter, public :: hfact_default = %.1f" %(1.2/reldev[2])) #print " real, parameter, public :: hfact_default = %s " %fmt(reldev[2]) print (" real, parameter, public :: av_factor = %s" %fmt(avratio)) print ("\ncontains\n") @@ -774,7 +794,7 @@ def printkernel_phantom(w,R,name): print ("pure subroutine kernel_softening(q2,q,potensoft,fsoft)") print (" real, intent(in) :: q2,q") print (" real, intent(out) :: potensoft,fsoft") - print_decl(pot) + print_decl(fsoft) if isinstance(dw, Piecewise): for i, (de, c) in enumerate(dw.args): (pote, potc) = pot.args[i] @@ -793,6 +813,26 @@ def printkernel_phantom(w,R,name): print (" potensoft = %s" %fmtp(pot)) print (" fsoft = %s" %fmtp(fsoft)) print ("\nend subroutine kernel_softening\n") + print ("pure subroutine kernel_grad_soft(q2,q,gsoft)") + print (" real, intent(in) :: q2,q") + print (" real, intent(out) :: gsoft") + print_decl(gsoft) + if isinstance(dw, Piecewise): + for i, (de, c) in enumerate(dw.args): + (ge, gc) = gsoft.args[i] + if i == 0: + print (" if (%s) then" %fmt(c)) + elif i == len(dw.args)-1 and c == True: + print (" else") + else: + print (" elseif (%s) then" %fmt(c)) + print_defs(4,fmtp(ge)) + print (" gsoft = %s" %fmtp(ge)) + print (" endif") + else: + print (" gsoft = %s" %fmtp(gsoft)) + print ("\nend subroutine kernel_grad_soft\n") + print ("!------------------------------------------") print ("! double-humped version of the kernel for") print ("! use in drag force calculations") @@ -956,8 +996,8 @@ def f6(R): # define which kernel to use #f, name = sinq(R,3) -#f, name = m5(R) -f, name = w6(R) +f, name = m4(R) +#f, name = w6(R) #print_avdiss(f,R) #printvariances(f,R) From 72d695b843ea55b639289ee225c07b0ae3c8c109 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Apr 2024 10:19:32 +1000 Subject: [PATCH 343/814] build the main step_extern sub for subsystems + adaption of sink_sink force... --- src/main/ptmass.F90 | 97 +++++++++++++-------- src/main/sdar_group.f90 | 21 ++--- src/main/step_extern.f90 | 176 ++++++++++++++++++++++++++++++++------- 3 files changed, 221 insertions(+), 73 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index dbee66a25..a39845103 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -265,7 +265,7 @@ end subroutine get_accel_sink_gas !+ !---------------------------------------------------------------- subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,& - iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass) + iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass,group_info) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -273,14 +273,16 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(out) :: fxyz_ptmass(4,nptmass) - real, intent(out) :: phitot,dtsinksink - integer, intent(in) :: iexternalforce - real, intent(in) :: ti - integer, intent(out) :: merge_ij(:),merge_n - real, intent(out) :: dsdt_ptmass(3,nptmass) + use part, only:igarg,igcum + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(out) :: fxyz_ptmass(4,nptmass) + real, intent(out) :: phitot,dtsinksink + integer, intent(in) :: iexternalforce + real, intent(in) :: ti + integer, intent(out) :: merge_ij(:),merge_n + integer, optional, intent(in) :: group_info(:,:) + real, intent(out) :: dsdt_ptmass(3,nptmass) real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii real :: ddr,dx,dy,dz,rr2,rr2j,dr3,f1,f2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft @@ -288,7 +290,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real :: fterm,pterm,potensoft0,dsx,dsy,dsz real :: J2i,rsinki,shati(3) real :: J2j,rsinkj,shatj(3) - integer :: i,j + integer :: k,l,i,j,start_id,end_id dtsinksink = huge(dtsinksink) fxyz_ptmass(:,:) = 0. @@ -313,7 +315,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !--compute N^2 forces on point mass particles due to each other ! !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & !$omp private(i,xi,yi,zi,pmassi,pmassj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & @@ -323,7 +325,14 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp private(fterm,pterm,J2i,J2j,shati,shatj,rsinki,rsinkj) & !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) - do i=1,nptmass + do k=1,nptmass + if (present(group_info)) then + start_id = group_info(igcum) + 1 + end_id = group_info(igcum) + i = group_info(igarg,k) + else + i = k + endif xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) @@ -339,7 +348,13 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dsx = 0. dsy = 0. dsz = 0. - do j=1,nptmass + do l=1,nptmass + if (present(group_info)) then + j = group_info(igarg,l) + if (j>=start_id .or. j<=end_id) cycle + else + j = l + endif if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) @@ -477,19 +492,19 @@ end subroutine get_accel_sink_sink !+ !---------------------------------------------------------------- subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & - pmassi,fxyz_ptmass) + pmassi,fxyz_ptmass) use kernel, only:kernel_softening,kernel_gradsoftening,radkern - integer, intent(in) :: nptmass - real, intent(in) :: xi,yi,zi,hi,dt - real, intent(inout) :: fxi,fyi,fzi - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(in) :: pmassi - real, intent(inout) :: fxyz_ptmass(4,nptmass) - real :: gtmpxi,gtmpyi,gtmpzi - real :: dx,dy,dz,rr2,ddr,dr3,g11,g12,g21,g22,pmassj - real :: dfx,dfy,dfz,drdotdf - real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft,gpref - integer :: j + integer, intent(in) :: nptmass + real, intent(in) :: xi,yi,zi,hi,dt + real, intent(inout) :: fxi,fyi,fzi + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(in) :: pmassi + real, intent(inout) :: fxyz_ptmass(4,nptmass) + real :: gtmpxi,gtmpyi,gtmpzi + real :: dx,dy,dz,rr2,ddr,dr3,g11,g12,g21,g22,pmassj + real :: dfx,dfy,dfz,drdotdf + real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft,gpref + integer :: j gtmpxi = 0. ! use temporary summation variable gtmpyi = 0. ! (better for round-off, plus we need this bit of @@ -587,17 +602,18 @@ end subroutine get_gradf_sink_gas ! get gradient correction of the force for FSI integrator (sink-gas) !+ !---------------------------------------------------------------- -subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) +subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt,group_info) use kernel, only:kernel_softening,kernel_gradsoftening,radkern - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(inout) :: fxyz_ptmass(4,nptmass) - real, intent(in) :: dt + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(inout) :: fxyz_ptmass(4,nptmass) + real, intent(in) :: dt + integer, optional, intent(in) :: group_info(:,:) real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,gxi,gyi,gzi real :: ddr,dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,dr3,g1,g2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft real :: gpref - integer :: i,j + integer :: i,j,k,l,start_id,end_id if (nptmass <= 1) return if (h_soft_sinksink > 0.) then @@ -611,13 +627,20 @@ subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) !--compute N^2 gradf on point mass particles due to each other ! !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,group_info) & !$omp shared(h_soft_sinksink,hsoft21,dt) & !$omp private(i,xi,yi,zi,pmassi,pmassj) & !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & !$omp private(fxi,fyi,fzi,gxi,gyi,gzi,gpref) & !$omp private(q2i,qi,psoft,fsoft,gsoft) - do i=1,nptmass + do k=1,nptmass + if (present(group_info)) then + start_id = group_info(igcum) + 1 + end_id = group_info(igcum) + i = group_info(igarg,k) + else + i = k + endif xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) @@ -629,7 +652,13 @@ subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) gxi = 0. gyi = 0. gzi = 0. - do j=1,nptmass + do l=1,nptmass + if (present(group_info)) then + j = group_info(igarg,l) + if (j>=start_id .or. j<=end_id) cycle + else + j = l + endif if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 92588763b..bb1e06fe2 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -25,11 +25,12 @@ module sdar_group ! Group identification routines ! !----------------------------------------------- -subroutine group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, intent(in) :: group_info(:,:) - integer(kind=1), intent(inout) :: nmatrix(:,:) - integer, intent(in) :: nptmass +subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(in) :: group_info(:,:) + integer(kind=1), intent(inout) :: nmatrix(:,:) + integer, intent(inout) :: n_group,n_ingroup,n_sing + integer, intent(in) :: nptmass ngroup = 0 n_ingroup = 0 @@ -40,12 +41,13 @@ subroutine group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) end subroutine group_identify -subroutine form_group(nmatrix,nptmass,group_info) - use part, only : igid,igcum +subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + use part, only : igarg,igcum use dim, only : maxptmass integer(kind=1), intent(in) :: nmatrix(:,:) - integer, intent(out):: group_info(:,:) - integer, intent(in) :: nptmass + integer, intent(out) :: group_info(:,:) + integer, intent(in) :: nptmass + integer, intent(inout) :: n_group,n_ingroup,n_sing integer :: i,ncg logical :: visited(maxptmass) integer :: stack(maxptmass) @@ -348,7 +350,6 @@ subroutine backup_data(gsize,xyzmh_ptmass,vxyz_ptmass,bdata) bdata(j,i) = xyzmh_ptmass(j,i) bdata(j+ndim,i) =,vxyz_ptmass(j,i) enddo - !print*,bdata(1,:) enddo end subroutine backup_data diff --git a/src/main/step_extern.f90 b/src/main/step_extern.f90 index 9cb3da671..f22414871 100644 --- a/src/main/step_extern.f90 +++ b/src/main/step_extern.f90 @@ -39,6 +39,7 @@ module step_extern public :: step_extern_sph public :: step_extern_sph_gr public :: step_extern_FSI + public :: step_extern_subsys public :: step_extern_PEFRL contains @@ -509,9 +510,7 @@ subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,x integer, intent(in) :: npart,nptmass real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) - real,parameter :: ck(2) = (/0.5,0.5/) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) real :: dt,t_end_step,dtextforce_min real :: pmassi,timei logical :: done,last_step @@ -583,19 +582,122 @@ subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,x end subroutine step_extern_FSI + !---------------------------------------------------------------- + !+ + ! This is the equivalent of the routine below with no cooling + ! and external forces except ptmass with subsystems algorithms.. + !+ + !---------------------------------------------------------------- +subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & + dsdt_ptmass,gtgrad,group_info,n_group,n_ingroup,n_sing) + use part, only: isdead_or_accreted,igas,massoftype + use io, only:iverbose,id,master,iprint,warning,fatal + use io_summary, only:summary_variable,iosumextr,iosumextt + use sdar_group, only:group_identify,evolve_groups + real, intent(in) :: dtsph,time + integer, intent(in) :: npart,nptmass + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:),gtgrad(:,:) + integer, intent(inout) :: group_info(:,:) + integer, intent(inout) :: n_ingroup,n_group,n_sing + real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) + real,parameter :: ck(2) = (/0.5,0.5/) + real :: dt,t_end_step,dtextforce_min + real :: pmassi,timei + logical :: done,last_step + integer :: nsubsteps + + ! + ! determine whether or not to use substepping + ! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + + timei = time + pmassi = massoftype(igas) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + + substeps: do while (timei <= t_end_step .and. .not.done) + timei = timei + dt + if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + nsubsteps = nsubsteps + 1 + ! + ! Group all the ptmass in the system in multiple small group for regularization + ! + call group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) + call kick_4th (dk(1),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call drift_4th(ck(1),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) + call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) ! Direct calculation of the force and force gradient + call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,group_info) + call kick_4th (dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) + call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) + call kick_4th (dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt + + dtextforce_min = min(dtextforce_min,dtextforce) + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + enddo substeps + + if (nsubsteps > 1) then + if (iverbose>=1 .and. id==master) then + write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + + +end subroutine step_extern_subsys + + + + !---------------------------------------------------------------- !+ ! drift routine for the 4th order scheme !+ !---------------------------------------------------------------- -subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) +subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) use part, only: isdead_or_accreted,ispinx,ispiny,ispinz - real, intent(in) :: dt,ck - integer, intent(in) :: npart,nptmass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) - integer :: i + real, intent(in) :: dt,ck + integer, intent(in) :: npart,nptmass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) + integer, optional, intent(in) :: n_ingroup + integer :: i,istart_ptmass + + istart_ptmass = 1 + if (present(n_ingroup)) istart_ptmass = n_ingroup + 1 + + ! Drift gas particles @@ -616,7 +718,7 @@ subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsd !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ck,dt) & !$omp private(i) - do i=1,nptmass + do i=istart_ptmass,nptmass if (xyzmh_ptmass(4,i) > 0.) then xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ck*dt*vxyz_ptmass(1,i) xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ck*dt*vxyz_ptmass(2,i) @@ -684,18 +786,19 @@ end subroutine kick_4th !+ !---------------------------------------------------------------- -subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - use options, only:iexternalforce +subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) + use options, only:iexternalforce,use_regnbody use dim, only:maxptmass use io, only:iverbose,master,iprint,warning,fatal use part, only:epot_sinksink,fxyz_ptmass_sinksink,dsdt_ptmass_sinksink use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks use timestep, only:bignumber,C_force - integer, intent(in):: nptmass,npart,nsubsteps - real, intent(inout) :: xyzh(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real, intent(inout) :: dtextforce - real, intent(in) :: timei,pmassi + integer, intent(in) :: nptmass,npart,nsubsteps + real, intent(inout) :: xyzh(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + real, intent(inout) :: dtextforce + real, intent(in) :: timei,pmassi + integer, optional,intent(in) :: group_info(:,:) integer :: merge_ij(nptmass) integer :: merge_n integer :: i @@ -708,12 +811,22 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe dtphi2 = bignumber fonrmax = 0 if (nptmass>0) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + if (use_regnbody) then + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info) + endif + else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + endif endif else fxyz_ptmass(:,:) = 0. @@ -763,21 +876,26 @@ end subroutine get_force_4th !---------------------------------------------------------------- -subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) +subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,group_info) use dim, only:maxptmass use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink - integer, intent(in) :: nptmass,npart - real, intent(inout) :: xyzh(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) - real, intent(inout) :: dt - real, intent(in) :: pmassi + use options, only:use_regnbody + integer, intent(in) :: nptmass,npart + real, intent(inout) :: xyzh(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(inout) :: dt + real, intent(in) :: pmassi + integer, optional, intent(in) :: group_info(:,:) real :: fextx,fexty,fextz integer :: i if (nptmass>0) then - call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) - !print*,fxyz_ptmass(1,1:5) + if(use_regnbody) then + call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt,group_info) + else + call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) + endif else fxyz_ptmass(:,:) = 0. endif From d9dc34474e5d3ca590c361f244be76a1085ccc57 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Apr 2024 10:57:20 +1000 Subject: [PATCH 344/814] add mpi support for FSI (just grav) --- src/main/step_extern.f90 | 123 ++++++++++++++++++++++++--------------- 1 file changed, 77 insertions(+), 46 deletions(-) diff --git a/src/main/step_extern.f90 b/src/main/step_extern.f90 index 9cb3da671..326b956ea 100644 --- a/src/main/step_extern.f90 +++ b/src/main/step_extern.f90 @@ -41,6 +41,11 @@ module step_extern public :: step_extern_FSI public :: step_extern_PEFRL + real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) + real,parameter :: ck(2) = (/0.5,0.5/) + + private + contains subroutine step_extern_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) @@ -510,8 +515,6 @@ subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,x real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) - real,parameter :: ck(2) = (/0.5,0.5/) real :: dt,t_end_step,dtextforce_min real :: pmassi,timei logical :: done,last_step @@ -590,7 +593,9 @@ end subroutine step_extern_FSI !---------------------------------------------------------------- subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - use part, only: isdead_or_accreted,ispinx,ispiny,ispinz + use part, only:isdead_or_accreted,ispinx,ispiny,ispinz + use io , only:id,master + use mpiutils, only:bcast_mpi real, intent(in) :: dt,ck integer, intent(in) :: npart,nptmass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -612,21 +617,25 @@ subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsd !$omp end parallel do ! Drift sink particles - - !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ck,dt) & - !$omp private(i) - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ck*dt*vxyz_ptmass(1,i) - xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ck*dt*vxyz_ptmass(2,i) - xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ck*dt*vxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + ck*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + ck*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + ck*dt*dsdt_ptmass(3,i) + if(nptmass>0) then + if(id==master) then + !$omp parallel do default(none) & + !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ck,dt) & + !$omp private(i) + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ck*dt*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ck*dt*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ck*dt*vxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + ck*dt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + ck*dt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + ck*dt*dsdt_ptmass(3,i) + endif + enddo + !$omp end parallel do endif - enddo - !$omp end parallel do + call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) + endif end subroutine drift_4th @@ -638,6 +647,8 @@ end subroutine drift_4th subroutine kick_4th(dk,dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) use part, only: isdead_or_accreted,ispinx,ispiny,ispinz + use io , only:id,master + use mpiutils, only:bcast_mpi real, intent(in) :: dt,dk integer, intent(in) :: npart,nptmass real, intent(in) :: xyzh(:,:) @@ -660,21 +671,26 @@ subroutine kick_4th(dk,dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext !$omp end parallel do ! Kick sink particles + if (nptmass>0) then + if(id==master) then + !$omp parallel do default(none) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,dsdt_ptmass,dk,dt) & + !$omp private(i) + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dk*dt*fxyz_ptmass(1,i) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dk*dt*fxyz_ptmass(2,i) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dk*dt*fxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dk*dt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dk*dt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dk*dt*dsdt_ptmass(3,i) + endif + enddo + !$omp end parallel do - !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,dsdt_ptmass,dk,dt) & - !$omp private(i) - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dk*dt*fxyz_ptmass(1,i) - vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dk*dt*fxyz_ptmass(2,i) - vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dk*dt*fxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dk*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dk*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dk*dt*dsdt_ptmass(3,i) endif - enddo - !$omp end parallel do + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + endif end subroutine kick_4th @@ -687,10 +703,11 @@ end subroutine kick_4th subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) use options, only:iexternalforce use dim, only:maxptmass - use io, only:iverbose,master,iprint,warning,fatal + use io, only:iverbose,master,id,iprint,warning,fatal use part, only:epot_sinksink,fxyz_ptmass_sinksink,dsdt_ptmass_sinksink use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks use timestep, only:bignumber,C_force + use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi integer, intent(in):: nptmass,npart,nsubsteps real, intent(inout) :: xyzh(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) @@ -708,20 +725,25 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe dtphi2 = bignumber fonrmax = 0 if (nptmass>0) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + if (id==master) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + endif + else + fxyz_ptmass(:,:) = 0. + dsdt_ptmass(:,:) = 0. endif - else - fxyz_ptmass(:,:) = 0. - dsdt_ptmass(:,:) = 0. + call bcast_mpi(epot_sinksink) + call bcast_mpi(dtf) + dtextforcenew = min(dtextforcenew,C_force*dtf) endif - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - dtextforcenew = min(dtextforcenew,C_force*dtf) if (iverbose >= 3 ) write(iprint,*) "dt_sink_sink",dtextforcenew !$omp parallel default(none) & !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext) & @@ -746,12 +768,21 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe !$omp enddo !$omp end parallel - if (fonrmax > 0.) then - dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) + if (nptmass > 0) then + call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) + call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + endif + + if(nptmass>0) then + if (fonrmax > 0.) then + dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) + endif + if (iverbose >= 3 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas + dtextforcenew = min(dtextforcenew,dtsinkgas) + dtextforce = dtextforcenew endif - if (iverbose >= 3 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas - dtextforcenew = min(dtextforcenew,dtsinkgas) - dtextforce = dtextforcenew + + dtextforcenew = reduceall_mpi('min',dtextforcenew) end subroutine get_force_4th From 998d84aceb29b2d27e9a3cf016f14ca8f03a406a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Apr 2024 12:05:02 +1000 Subject: [PATCH 345/814] mpi version of gradf --- src/main/step_extern.f90 | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/main/step_extern.f90 b/src/main/step_extern.f90 index 326b956ea..22e7b8f2f 100644 --- a/src/main/step_extern.f90 +++ b/src/main/step_extern.f90 @@ -797,6 +797,7 @@ end subroutine get_force_4th subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) use dim, only:maxptmass use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink + use io, only:id,master integer, intent(in) :: nptmass,npart real, intent(inout) :: xyzh(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) @@ -807,10 +808,11 @@ subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptm if (nptmass>0) then - call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) - !print*,fxyz_ptmass(1,1:5) - else - fxyz_ptmass(:,:) = 0. + if(id==master) then + call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) + else + fxyz_ptmass(:,:) = 0. + endif endif !$omp parallel default(none) & @@ -831,6 +833,11 @@ subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptm !$omp enddo !$omp end parallel + if (nptmass > 0) then + call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) + call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + endif + end subroutine get_gradf_4th From 11e0a27d947abc774013ab1b3322e1f8ab59036b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Apr 2024 14:40:20 +1000 Subject: [PATCH 346/814] fix some oversights --- src/main/sdar_group.f90 | 12 +++++++----- src/main/step_extern.f90 | 20 +++++++++++++------- src/main/step_leapfrog.F90 | 10 ++++++++-- 3 files changed, 28 insertions(+), 14 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index bb1e06fe2..c83dfc566 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -36,7 +36,7 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm n_ingroup = 0 n_sing = 0 call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) - call form_group(group_info,nmatrix,nptmass) + call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) end subroutine group_identify @@ -109,13 +109,16 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu real :: aij,eij,B,rperi integer :: i,j +! +!!TODO MPI Proof version of the matrix construction +! !$omp parallel do default(none) & !$omp shared(nptmass,r_neigh,C_bin,t_crit,nmatrix) & !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & !$omp private(dx,dy,dz,r,r2) & !$omp private(dvx,dvy,dvz,v2) & - !$omp private(mu,aij,eij,B,r_peri) & + !$omp private(mu,aij,eij,B,r_peri) do i=1,nptmass xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) @@ -497,6 +500,8 @@ subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) real :: gravf,gtki integer :: i,j om = 0. + + do i=s_id,e_id fxyz_ptmass(1,i) = 0. fxyz_ptmass(2,i) = 0. @@ -504,9 +509,6 @@ subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) gtgrad(1,i) = 0. gtgrad(2,i) = 0. gtgrad(3,i) = 0. - enddo - - do i=s_id,e_id gtki = 0. xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) diff --git a/src/main/step_extern.f90 b/src/main/step_extern.f90 index eb9c22ed8..718281e2d 100644 --- a/src/main/step_extern.f90 +++ b/src/main/step_extern.f90 @@ -638,7 +638,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex ! ! Group all the ptmass in the system in multiple small group for regularization ! - call group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) @@ -649,8 +649,8 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) ! Direct calculation of the force and force gradient call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,group_info) call kick_4th (dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) call kick_4th (dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) @@ -690,8 +690,8 @@ end subroutine step_extern_subsys !+ !---------------------------------------------------------------- -subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) - use part, only: isdead_or_accreted,ispinx,ispiny,ispinz +subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) + use part, only: isdead_or_accreted,ispinx,ispiny,ispinz,igarg use io , only:id,master use mpiutils, only:bcast_mpi real, intent(in) :: dt,ck @@ -699,7 +699,8 @@ subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsd real, intent(inout) :: xyzh(:,:),vxyzu(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) integer, optional, intent(in) :: n_ingroup - integer :: i,istart_ptmass + integer, optional, intent(in) :: group_info(:,:) + integer :: i,k,istart_ptmass istart_ptmass = 1 if (present(n_ingroup)) istart_ptmass = n_ingroup + 1 @@ -723,8 +724,13 @@ subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsd if(id==master) then !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ck,dt) & - !$omp private(i) - do i=istart_ptmass,nptmass + !$omp private(i,k) + do k=istart_ptmass,nptmass + if (present(n_ingroup)) then + i = group_info(igarg,k) + else + i = k + endif if (xyzmh_ptmass(4,i) > 0.) then xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ck*dt*vxyz_ptmass(1,i) xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ck*dt*vxyz_ptmass(2,i) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 18d197625..53a77c316 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -104,6 +104,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use timestep, only:dterr,bignumber,tolv use mpiutils, only:reduceall_mpi use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,ibin_wake + use part, only:n_group,n_ingroup,n_sing,gtgrad,group_info use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax @@ -121,8 +122,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate - use step_extern, only:step_extern_FSI,step_extern_PEFRL,step_extern_lf, & - step_extern_gr,step_extern_sph_gr,step_extern_sph + use step_extern, only:step_extern_FSI,step_extern_PEFRL,step_extern_lf, & + step_extern_gr,step_extern_sph_gr,step_extern_sph, & + step_extern_subsys integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -238,6 +240,10 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_fourthorder) then call step_extern_FSI(dtextforce,dtsph,t,npart,nptmass,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + elseif(use_regnbody) then + call step_extern_subsys(dtextforce,dtsph,t,npart,nptmass,xyzh,vxyzu,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass, & + gtgrad,group_info,n_group,n_ingroup,n_sing) else call step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) From c7b8de728a08730a905f3e139200f6c6f6a4d312 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Apr 2024 15:16:27 +1000 Subject: [PATCH 347/814] step_extern.f90 -> step_extern.F90 --- src/main/{step_extern.f90 => step_extern.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/main/{step_extern.f90 => step_extern.F90} (100%) diff --git a/src/main/step_extern.f90 b/src/main/step_extern.F90 similarity index 100% rename from src/main/step_extern.f90 rename to src/main/step_extern.F90 From 9899fe22f1fc9933241d16e7a9307ad9b53eb304 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 8 Apr 2024 15:18:05 +1000 Subject: [PATCH 348/814] (kernel) added kernel_cubic with new softening function --- build/Makefile | 2 +- src/main/kernel_cubic.f90 | 20 ++++++++++++++++++++ src/main/ptmass.F90 | 8 ++++---- 3 files changed, 25 insertions(+), 5 deletions(-) diff --git a/build/Makefile b/build/Makefile index 219f2eb0b..bf4757eee 100644 --- a/build/Makefile +++ b/build/Makefile @@ -541,7 +541,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ ${SRCKROME} memory.F90 ${SRCREADWRITE_DUMPS} \ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ - utils_shuffleparticles.F90 evwrite.f90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ + utils_shuffleparticles.F90 evwrite.f90 step_extern.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 diff --git a/src/main/kernel_cubic.f90 b/src/main/kernel_cubic.f90 index bf16cead5..6ec8230a9 100644 --- a/src/main/kernel_cubic.f90 +++ b/src/main/kernel_cubic.f90 @@ -119,6 +119,26 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4 + + if (q < 1.) then + gsoft = q2*q*(1.5*q - 2.4) + elseif (q < 2.) then + q4 = q2*q2 + gsoft = (q4*(-0.5*q2 + 2.4*q - 3.) + 0.2)/q2 + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index dbee66a25..5bd621a6f 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -478,7 +478,7 @@ end subroutine get_accel_sink_sink !---------------------------------------------------------------- subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & pmassi,fxyz_ptmass) - use kernel, only:kernel_softening,kernel_gradsoftening,radkern + use kernel, only:kernel_softening,kernel_grad_soft,radkern integer, intent(in) :: nptmass real, intent(in) :: xi,yi,zi,hi,dt real, intent(inout) :: fxi,fyi,fzi @@ -529,7 +529,7 @@ subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & ! first grad term of sink from gas g21 = pmassi*fsoft*ddr - call kernel_gradsoftening(q2i,qi,gsoft) + call kernel_grad_soft(q2i,qi,gsoft) dr3 = ddr*ddr*ddr @@ -588,7 +588,7 @@ end subroutine get_gradf_sink_gas !+ !---------------------------------------------------------------- subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) - use kernel, only:kernel_softening,kernel_gradsoftening,radkern + use kernel, only:kernel_softening,kernel_grad_soft,radkern integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: fxyz_ptmass(4,nptmass) @@ -659,7 +659,7 @@ subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) ! gradf part 1 of sink1 from sink2 g1 = fsoft*hsoft21*ddr - call kernel_gradsoftening(q2i,qi,gsoft) + call kernel_grad_soft(q2i,qi,gsoft) dr3 = ddr*ddr*ddr From dae95a1f3171306eefdc0adf75f373c5eb04fa1c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 8 Apr 2024 15:28:31 +1000 Subject: [PATCH 349/814] (FSI) added kernel modules needed for FSI integrator --- src/main/kernel_WendlandC2.f90 | 21 +++++++++++++++++- src/main/kernel_WendlandC4.f90 | 40 ++++++++++++++++++++++++++++------ src/main/kernel_WendlandC6.f90 | 24 ++++++++++++++++++++ src/main/kernel_quartic.f90 | 28 ++++++++++++++++++++++++ src/main/kernel_quintic.f90 | 3 +++ 5 files changed, 108 insertions(+), 8 deletions(-) diff --git a/src/main/kernel_WendlandC2.f90 b/src/main/kernel_WendlandC2.f90 index 882b2d4a4..3500fbfa3 100644 --- a/src/main/kernel_WendlandC2.f90 +++ b/src/main/kernel_WendlandC2.f90 @@ -17,6 +17,9 @@ module kernel ! ! :Dependencies: physcon ! +! :Generated: 2024-04-08 15:21:28.635699 +! +!-------------------------------------------------------------------------- use physcon, only:pi implicit none character(len=17), public :: kernelname = 'Wendland 2/3D C^2' @@ -90,7 +93,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, q6 + real :: q4 if (q < 2.) then q4 = q2*q2 @@ -104,6 +107,22 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + + if (q < 2.) then + gsoft = 3.*q2*q*(35.*q2*q - 240.*q2 + 560.*q - 448.)/256. + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations diff --git a/src/main/kernel_WendlandC4.f90 b/src/main/kernel_WendlandC4.f90 index ea1202d65..0b83140f6 100644 --- a/src/main/kernel_WendlandC4.f90 +++ b/src/main/kernel_WendlandC4.f90 @@ -17,6 +17,9 @@ module kernel ! ! :Dependencies: physcon ! +! :Generated: 2024-04-08 15:21:39.886138 +! +!-------------------------------------------------------------------------- use physcon, only:pi implicit none character(len=17), public :: kernelname = 'Wendland 2/3D C^4' @@ -37,8 +40,9 @@ pure subroutine get_kernel(q2,q,wkern,grkern) !--Wendland 2/3D C^4 if (q < 2.) then - wkern = (-q/2. + 1.)**6*(35.*q2/12. + 3.*q + 1.) - grkern = 11.6666666666667*q2*(0.5*q - 1.)**5 + 4.66666666666667*q*(0.5*q - 1.)**5 + wkern = (1 - q/2.)**6*(35.*q2/12. + 3.*q + 1.) + grkern = (1 - q/2.)**6*(35.*q/6. + 3.) - 3.*(1. - q/2.)**5*(35.*q2/12. + 3.*q + & + 1.) else wkern = 0. grkern = 0. @@ -50,7 +54,7 @@ pure elemental real function wkern(q2,q) real, intent(in) :: q2,q if (q < 2.) then - wkern = (-q/2. + 1.)**6*(35.*q2/12. + 3.*q + 1.) + wkern = (1 - q/2.)**6*(35.*q2/12. + 3.*q + 1.) else wkern = 0. endif @@ -61,7 +65,8 @@ pure elemental real function grkern(q2,q) real, intent(in) :: q2,q if (q < 2.) then - grkern = 11.6666666666667*q2*(0.5*q - 1.)**5 + 4.66666666666667*q*(0.5*q - 1.)**5 + grkern = (1 - q/2.)**6*(35.*q/6. + 3.) - 3.*(1. - q/2.)**5*(35.*q2/12. + 3.*q + & + 1.) else grkern = 0. endif @@ -77,8 +82,9 @@ pure subroutine get_kernel_grav1(q2,q,wkern,grkern,dphidh) q4 = q2*q2 q6 = q4*q2 q8 = q6*q2 - wkern = (-q/2. + 1.)**6*(35.*q2/12. + 3.*q + 1.) - grkern = 11.6666666666667*q2*(0.5*q - 1.)**5 + 4.66666666666667*q*(0.5*q - 1.)**5 + wkern = (1 - q/2.)**6*(35.*q2/12. + 3.*q + 1.) + grkern = (1 - q/2.)**6*(35.*q/6. + 3.) - 3.*(1. - q/2.)**5*(35.*q2/12. + 3.*q + & + 1.) dphidh = -1155.*q6*q4/32768. + 55.*q8*q/128. - 17325.*q8/8192. + 165.*q6*q/32. - & 5775.*q6/1024. + 1155.*q4/256. - 495.*q2/128. + 55./32. else @@ -109,6 +115,26 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4, q6 + + if (q < 2.) then + q4 = q2*q2 + q6 = q4*q2 + gsoft = 3.*q2*q*(175.*q6 - 1848.*q4*q + 7700.*q4 - 15400.*q2*q + 13200.*q2 - & + 4928.)/2048. + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations @@ -118,7 +144,7 @@ pure elemental real function wkern_drag(q2,q) !--double hump Wendland 2/3D C^4 kernel if (q < 2.) then - wkern_drag = q2*(-q/2. + 1.)**6*(35.*q2/12. + 3.*q + 1.) + wkern_drag = q2*(1. - q/2.)**6*(35.*q2/12. + 3.*q + 1.) else wkern_drag = 0. endif diff --git a/src/main/kernel_WendlandC6.f90 b/src/main/kernel_WendlandC6.f90 index b7b690789..16bc239fb 100644 --- a/src/main/kernel_WendlandC6.f90 +++ b/src/main/kernel_WendlandC6.f90 @@ -17,6 +17,9 @@ module kernel ! ! :Dependencies: physcon ! +! :Generated: 2024-04-08 15:21:50.637883 +! +!-------------------------------------------------------------------------- use physcon, only:pi implicit none character(len=17), public :: kernelname = 'Wendland 2/3D C^6' @@ -112,6 +115,27 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4, q6, q8 + + if (q < 2.) then + q4 = q2*q2 + q6 = q4*q2 + q8 = q6*q2 + gsoft = 3.*q2*q*(2860.*q8*q - 40425.*q8 + 240240.*q6*q - 764400.*q6 + & + 1345344.*q4*q - 1121120.*q4 + 549120.*q2 - 256256.)/65536. + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations diff --git a/src/main/kernel_quartic.f90 b/src/main/kernel_quartic.f90 index a698e32b6..32708fc27 100644 --- a/src/main/kernel_quartic.f90 +++ b/src/main/kernel_quartic.f90 @@ -17,6 +17,9 @@ module kernel ! ! :Dependencies: physcon ! +! :Generated: 2024-04-08 15:20:17.993158 +! +!-------------------------------------------------------------------------- use physcon, only:pi implicit none character(len=11), public :: kernelname = 'M_5 quartic' @@ -148,6 +151,31 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4, q6 + + if (q < 0.5) then + gsoft = 6.*q2*q*(4.*q2 - 7.)/35. + elseif (q < 1.5) then + q4 = q2*q2 + q6 = q4*q2 + gsoft = (-1024.*q6*q + 4480.*q6 - 5376.*q4*q + 560.*q4 - 1.)/(2240.*q2) + elseif (q < 2.5) then + q4 = q2*q2 + q6 = q4*q2 + gsoft = (512.*q6*q - 4480.*q6 + 13440.*q4*q - 14000.*q4 + 2185.)/(4480.*q2) + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations diff --git a/src/main/kernel_quintic.f90 b/src/main/kernel_quintic.f90 index 64482f474..1c8a0d5fb 100644 --- a/src/main/kernel_quintic.f90 +++ b/src/main/kernel_quintic.f90 @@ -17,6 +17,9 @@ module kernel ! ! :Dependencies: physcon ! +! :Generated: 2024-04-08 15:20:46.747398 +! +!-------------------------------------------------------------------------- use physcon, only:pi implicit none character(len=11), public :: kernelname = 'M_6 quintic' From 1239bfb0ceb23e6f8ee674d22d6c298576ac3ffd Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Apr 2024 16:11:18 +1000 Subject: [PATCH 350/814] fix mpi reduce and step extern name --- src/main/ptmass.F90 | 2 +- src/main/step_extern.F90 | 7 ++++--- src/main/step_leapfrog.F90 | 2 +- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 5bd621a6f..30dbb320e 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -275,7 +275,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use vectorutils, only:unitvec integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(out) :: fxyz_ptmass(4,nptmass) + real, intent(out) :: fxyz_ptmass(4,nptmass),fxyz_ptmass(:,:) real, intent(out) :: phitot,dtsinksink integer, intent(in) :: iexternalforce real, intent(in) :: ti diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 22e7b8f2f..c620a99da 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -770,7 +770,7 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe if (nptmass > 0) then call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + !call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) endif if(nptmass>0) then @@ -797,6 +797,7 @@ end subroutine get_force_4th subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) use dim, only:maxptmass use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink + use mpiutils, only:reduce_in_place_mpi use io, only:id,master integer, intent(in) :: nptmass,npart real, intent(inout) :: xyzh(:,:),fext(:,:) @@ -835,7 +836,7 @@ subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptm if (nptmass > 0) then call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + !call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) endif end subroutine get_gradf_4th @@ -852,7 +853,7 @@ end subroutine get_gradf_4th subroutine step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time,nptmass, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome,itau_alloc,& - do_nucleation,update_muGamma,h2chemistry + do_nucleation,update_muGamma,h2chemistry,ind_timesteps use io, only:iverbose,id,master,iprint,warning,fatal use externalforces, only:externalforce,accrete_particles,update_externalforce, & update_vdependent_extforce_leapfrog,is_velocity_dependent diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 18d197625..3d1a7a928 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -239,7 +239,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call step_extern_FSI(dtextforce,dtsph,t,npart,nptmass,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) else - call step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & + call step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) endif else From cad9f5748bb8d9501e32a3c87b7035706f44ed23 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Apr 2024 16:23:43 +1000 Subject: [PATCH 351/814] correct typo in ptmass and remove PEFRL --- src/main/ptmass.F90 | 2 +- src/main/step_extern.F90 | 80 -------------------------------------- src/main/step_leapfrog.F90 | 4 +- 3 files changed, 3 insertions(+), 83 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 30dbb320e..5bd621a6f 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -275,7 +275,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use vectorutils, only:unitvec integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(out) :: fxyz_ptmass(4,nptmass),fxyz_ptmass(:,:) + real, intent(out) :: fxyz_ptmass(4,nptmass) real, intent(out) :: phitot,dtsinksink integer, intent(in) :: iexternalforce real, intent(in) :: ti diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index c620a99da..f0bcddf37 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -39,7 +39,6 @@ module step_extern public :: step_extern_sph public :: step_extern_sph_gr public :: step_extern_FSI - public :: step_extern_PEFRL real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) real,parameter :: ck(2) = (/0.5,0.5/) @@ -421,85 +420,6 @@ subroutine step_extern_sph(dt,npart,xyzh,vxyzu) end subroutine step_extern_sph - !---------------------------------------------------------------- - !+ - ! This is the equivalent of the routine below with no cooling - ! and external forces except ptmass. (4th order scheme) - !+ - !---------------------------------------------------------------- -subroutine step_extern_PEFRL(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - use part, only: isdead_or_accreted,igas,massoftype - use io, only:iverbose,id,master,iprint,warning,fatal - use io_summary, only:summary_variable,iosumextr,iosumextt - real, intent(in) :: dtsph,time - integer, intent(in) :: npart,nptmass - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real,parameter :: ck(5) = (/0.1786178958448091,-0.06626458266981849,0.77529337365001878,-0.06626458266981849,0.1786178958448091/) - real,parameter :: dk(4) = (/0.7123418310626054,-0.2123418310626054,-0.2123418310626054,0.7123418310626054/) - real :: dt,t_end_step,dtextforce_min - real :: pmassi,timei - logical :: done,last_step - integer :: nsubsteps - integer :: i - - ! - ! determine whether or not to use substepping - ! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - - timei = time - pmassi = massoftype(igas) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - - substeps: do while (timei <= t_end_step .and. .not.done) - timei = timei + dt - if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) - nsubsteps = nsubsteps + 1 - do i=1,4 - call drift_4th(ck(i),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - call kick_4th (dk(i),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - enddo - call drift_4th(ck(5),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - - if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"dt : ",dt - dtextforce_min = min(dtextforce_min,dtextforce) - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - enddo substeps - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - - -end subroutine step_extern_PEFRL - !---------------------------------------------------------------- !+ ! This is the equivalent of the routine below with no cooling diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 3d1a7a928..e13b7d596 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -121,8 +121,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate - use step_extern, only:step_extern_FSI,step_extern_PEFRL,step_extern_lf, & - step_extern_gr,step_extern_sph_gr,step_extern_sph + use step_extern, only:step_extern_FSI,step_extern_lf,step_extern_gr, & + step_extern_sph_gr,step_extern_sph integer, intent(inout) :: npart integer, intent(in) :: nactive From 28b5796591abc4d0473dca56070a1ea302a2ab96 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 08:23:43 +1000 Subject: [PATCH 352/814] (porosity) fixed compiler warnings/error in memory allocation in bin2multi --- src/main/growth.F90 | 15 ++++++++++----- src/main/porosity.f90 | 7 +++---- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/src/main/growth.F90 b/src/main/growth.F90 index 229d21e9e..b86303c66 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -659,7 +659,7 @@ end subroutine set_dustprop !----------------------------------------------------------------------- subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) use part, only:npart,npartoftype,massoftype,ndusttypes,& - ndustlarge,grainsize,dustprop,graindens,& + ndustlarge,grainsize,dustprop,& iamtype,iphase,set_particle_type,idust,filfac use options, only:use_porosity use units, only:udist @@ -670,11 +670,11 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) real, intent(in) :: smax_user logical, intent(inout) :: force_smax logical, intent(in) :: verbose - real :: smaxtmp,smintmp,smax,smin,tolm,fmintmp,fmaxtmp,fmin,fmax,& - mdustold,mdustnew,code_to_mum + real :: smaxtmp,smintmp,smax,smin,tolm + real :: mdustold,mdustnew,code_to_mum logical :: init integer :: nbinsize,nbinsizemax,i,j,itype,ndustold,ndustnew,npartmin,imerge,iu - integer :: nbinfilfac,nbinfilfacmax,ndustsizetypes,ndustfilfactypes + integer :: nbinfilfacmax,ndustsizetypes real, allocatable, dimension(: ) :: grid real, allocatable, dimension(:,:) :: dustpropmcfost !dustpropmcfost(1=size,2=filfac) character(len=20) :: outfile = "bin_distrib.dat" @@ -692,6 +692,7 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) nbinfilfacmax = 10 npartmin = 50 !- limit to find neighbours init = .false. + allocate(dustpropmcfost(2,npart)) !graindens = maxval(dustprop(2,:)) !- loop over particles, find min and max on non-accreted dust particles @@ -713,7 +714,7 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) enddo !- overrule force_smax if particles are small, avoid empty bins - if ((maxval(dustpropmcfost(1,:))*udist < smax_user) .and. force_smax) then + if ((maxval(dustpropmcfost(1,1:npart))*udist < smax_user) .and. force_smax) then force_smax = .false. write(*,*) "Overruled force_smax from T to F" endif @@ -820,6 +821,10 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) grainsize(ndusttypes) = smaxtmp !- only 1 bin, all particles have same size endif + ! clean up + if (allocated(dustpropmcfost)) deallocate(dustpropmcfost) + if (allocated(grid)) deallocate(grid) + end subroutine bin_to_multi !----------------------------------------------------------------------- diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 83d1e514a..60d511d41 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -393,9 +393,6 @@ subroutine get_filfac_frag(mprev,dustprop,filfac,dustgasprop,rhod,VrelVf,dt,filf real :: ekin,pdyn select case (icompact) - case (0) - ! Fragmentation at constant filling factor - filfacfrag = filfac case (1) ! model Garcia + Kataoka mod sdust = get_size(mprev,dustprop(2),filfac) @@ -411,7 +408,9 @@ subroutine get_filfac_frag(mprev,dustprop,filfac,dustgasprop,rhod,VrelVf,dt,filf if (deltavol > vol) deltavol = vol filfacfrag = filfac *(1./(1.-0.5*exp(1-VrelVf**2.)*deltavol/vol))**ncoll - + case default ! (0) + ! Fragmentation at constant filling factor + filfacfrag = filfac end select end subroutine get_filfac_frag From dd36a737d174f95d74c61eb30c25a1ec15b1c496 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 08:28:43 +1000 Subject: [PATCH 353/814] [header-bot] updated file headers --- src/main/deriv.F90 | 8 +++--- src/main/force.F90 | 10 ++++---- src/main/growth.F90 | 3 +-- src/main/initial.F90 | 6 ++--- src/main/porosity.f90 | 27 ++++++++++++++++---- src/main/readwrite_infile.F90 | 8 +++--- src/main/step_leapfrog.F90 | 2 +- src/setup/set_dust_options.f90 | 2 +- src/setup/setup_disc.f90 | 6 ++--- src/utils/moddump_LTE_to_rad.f90 | 3 ++- src/utils/moddump_dustadd.f90 | 6 ++--- src/utils/moddump_removeparticles_radius.f90 | 2 +- 12 files changed, 51 insertions(+), 32 deletions(-) diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index a3ca0746d..cdaa4100d 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -14,10 +14,10 @@ module deriv ! ! :Runtime parameters: None ! -! :Dependencies: cons2prim, densityforce, derivutils, dim, externalforces, -! forces, forcing, growth, io, linklist, metric_tools, options, part, -! ptmass, ptmass_radiation, radiation_implicit, timestep, timestep_ind, -! timing +! :Dependencies: cons2prim, densityforce, derivutils, dim, dust_formation, +! externalforces, forces, forcing, growth, io, linklist, metric_tools, +! options, part, photoevap, porosity, ptmass, ptmass_radiation, +! radiation_implicit, raytracer, timestep, timestep_ind, timing ! implicit none diff --git a/src/main/force.F90 b/src/main/force.F90 index 0d3e6ac1e..4e35d40c3 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -39,11 +39,11 @@ module forces ! ! :Runtime parameters: None ! -! :Dependencies: boundary, cooling, dim, dust, eos, eos_shen, fastmath, io, -! io_summary, kdtree, kernel, linklist, metric_tools, mpiderivs, -! mpiforce, mpimemory, mpiutils, nicil, omputils, options, part, physcon, -! ptmass, ptmass_heating, radiation_utils, timestep, timestep_ind, -! timestep_sts, timing, units, utils_gr, viscosity +! :Dependencies: boundary, cooling, dim, dust, eos, eos_shen, fastmath, +! growth, io, io_summary, kdtree, kernel, linklist, metric_tools, +! mpiderivs, mpiforce, mpimemory, mpiutils, nicil, omputils, options, +! part, physcon, ptmass, ptmass_heating, radiation_utils, timestep, +! timestep_ind, timestep_sts, timing, units, utils_gr, viscosity ! use dim, only:maxfsum,maxxpartveciforce,maxp,ndivcurlB,ndivcurlv,& maxdusttypes,maxdustsmall,do_radiation diff --git a/src/main/growth.F90 b/src/main/growth.F90 index b86303c66..1ad8db8c9 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -23,13 +23,12 @@ module growth ! - flyby : *use primary for keplerian freq. calculation* ! - force_smax : *(mcfost) set manually maximum size for binning* ! - grainsizemin : *minimum allowed grain size in cm* -! - tsmin : *minimum allowed stopping time when porosity is on* ! - ieros : *erosion of dust (0=off,1=on)* ! - ifrag : *fragmentation of dust (0=off,1=on,2=Kobayashi)* -! - ieros : *erosion of dust (0=off,1=on) ! - isnow : *snow line (0=off,1=position based,2=temperature based)* ! - rsnow : *snow line position in AU* ! - size_max_user : *(mcfost) maximum size for binning in cm* +! - tsmincgs : *minimum allowed stopping time* ! - vfrag : *uniform fragmentation threshold in m/s* ! - vfragin : *inward fragmentation threshold in m/s* ! - vfragout : *inward fragmentation threshold in m/s* diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 521bbe6bc..cc9739cf7 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -21,9 +21,9 @@ module initial ! fastmath, fileutils, forcing, growth, inject, io, io_summary, ! krome_interface, linklist, metric_tools, mf_write, mpibalance, ! mpidomain, mpimemory, mpitree, mpiutils, nicil, nicil_sup, omputils, -! options, part, partinject, ptmass, radiation_utils, readwrite_dumps, -! readwrite_infile, timestep, timestep_ind, timestep_sts, timing, -! tmunu2grid, units, writeheader +! options, part, partinject, porosity, ptmass, radiation_utils, +! readwrite_dumps, readwrite_infile, timestep, timestep_ind, +! timestep_sts, timing, tmunu2grid, units, writeheader ! implicit none diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 60d511d41..6fc8a293f 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -1,12 +1,29 @@ +!--------------------------------------------------------------------------! +! 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 porosity ! ! Contains routine for porosity evolution (growth, bouncing, fragmentation, compaction, disruption) ! -! :References: -! Okuzumi et al. (1997), ApJ 752, 106 -! Garcia, Gonzalez (2020), MNRAS 493, 1788 -! Tatsuuma et Kataoka (2021), ApJ 913, 132 -! Michoulier & Gonzalez (2022), MNRAS 517, 3064 +! :References: None +! +! :Owner: Stephane Michoulier +! +! :Runtime parameters: +! - gammaft : *Force to torque efficient of gas flow on dust* +! - ibounce : *bouncing (0=Off,1=On)* +! - icompact : *Compaction during fragmentation (ifrag > 0) (0=off,1=on)* +! - idisrupt : *disruption (0=Off,1=On)* +! - iporosity : *porosity (0=Off,1=On)* +! - smonocgs : *Monomer size in cm (smaller or equal to 1.e-4 cm)* +! - surfenergSI : *Monomer surface energy in J/m**2* +! - youngmodSI : *Monomer young modulus in Pa* +! +! :Dependencies: dim, dust, eos, growth, infile_utils, io, options, part, +! physcon, random, units, viscosity ! use units, only:umass,udist,unit_energ,unit_pressure,unit_density use physcon, only:Ro,pi,fourpi,roottwo diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 28145e9c0..c7aec5707 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -16,6 +16,8 @@ module readwrite_infile ! :Runtime parameters: ! - C_cour : *Courant number* ! - C_force : *dt_force number* +! - X : *hydrogen mass fraction for MESA opacity table* +! - Z : *metallicity for MESA opacity table* ! - alpha : *shock viscosity parameter* ! - alphaB : *shock resistivity parameter* ! - alphamax : *MAXIMUM shock viscosity parameter* @@ -66,9 +68,9 @@ module readwrite_infile ! ! :Dependencies: boundary_dyn, cooling, damping, dim, dust, dust_formation, ! eos, externalforces, forcing, gravwaveutils, growth, infile_utils, -! inject, io, linklist, metric, nicil_sup, options, part, ptmass, -! ptmass_radiation, radiation_implicit, radiation_utils, timestep, -! viscosity +! inject, io, linklist, metric, nicil_sup, options, part, porosity, +! ptmass, ptmass_radiation, radiation_implicit, radiation_utils, +! timestep, viscosity ! use timestep, only:dtmax_dratio,dtmax_max,dtmax_min use options, only:nfulldump,nmaxdumps,twallmax,iexternalforce,tolh, & diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 14aebd044..6fe1643d2 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -25,7 +25,7 @@ module step_lf_global ! :Dependencies: boundary_dyn, chem, cons2prim, cons2primsolver, cooling, ! cooling_ism, damping, deriv, dim, dust_formation, eos, extern_gr, ! externalforces, growth, io, io_summary, krome_interface, metric_tools, -! mpiutils, options, part, ptmass, ptmass_radiation, timestep, +! mpiutils, options, part, porosity, ptmass, ptmass_radiation, timestep, ! timestep_ind, timestep_sts, timing, units ! use dim, only:maxp,maxvxyzu,do_radiation,ind_timesteps diff --git a/src/setup/set_dust_options.f90 b/src/setup/set_dust_options.f90 index 6746601da..94b01d196 100644 --- a/src/setup/set_dust_options.f90 +++ b/src/setup/set_dust_options.f90 @@ -27,7 +27,7 @@ module set_dust_options ! - ndusttypesinp : *number of grain sizes* ! ! :Dependencies: dim, dust, eos, fileutils, growth, infile_utils, io, -! options, part, prompting +! options, part, porosity, prompting ! use dim, only:maxdusttypes,maxdustsmall,maxdustlarge,use_dustgrowth use prompting, only:prompt diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 53aac25ee..8b7a1b5a2 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -90,9 +90,9 @@ module setup ! :Dependencies: centreofmass, dim, dust, eos, extern_binary, ! extern_corotate, extern_lensethirring, externalforces, fileutils, ! growth, infile_utils, io, kernel, memory, options, part, physcon, -! prompting, radiation_utils, set_dust, set_dust_options, setbinary, -! setdisc, setflyby, sethierarchical, spherical, timestep, units, -! vectorutils +! porosity, prompting, radiation_utils, set_dust, set_dust_options, +! setbinary, setdisc, setflyby, sethierarchical, spherical, timestep, +! units, vectorutils ! use dim, only:use_dust,maxalpha,use_dustgrowth,maxdusttypes,& maxdustlarge,maxdustsmall,compiled_with_mcfost diff --git a/src/utils/moddump_LTE_to_rad.f90 b/src/utils/moddump_LTE_to_rad.f90 index 04b20e5c9..58e9a135a 100644 --- a/src/utils/moddump_LTE_to_rad.f90 +++ b/src/utils/moddump_LTE_to_rad.f90 @@ -14,7 +14,8 @@ module moddump ! ! :Runtime parameters: None ! -! :Dependencies: dim, eos, io, part +! :Dependencies: dim, eos, eos_idealplusrad, eos_mesa, io, +! mesa_microphysics, part, radiation_utils, units ! implicit none diff --git a/src/utils/moddump_dustadd.f90 b/src/utils/moddump_dustadd.f90 index f1e35f795..32f97a43f 100644 --- a/src/utils/moddump_dustadd.f90 +++ b/src/utils/moddump_dustadd.f90 @@ -10,12 +10,12 @@ module moddump ! ! :References: None ! -! :Owner: Arnaud Vericel +! :Owner: Stephane Michoulier ! ! :Runtime parameters: None ! -! :Dependencies: dim, dust, growth, options, part, prompting, set_dust, -! table_utils, units +! :Dependencies: dim, dust, growth, options, part, porosity, prompting, +! set_dust, table_utils, units ! use part, only:delete_particles_outside_sphere,igas,idust diff --git a/src/utils/moddump_removeparticles_radius.f90 b/src/utils/moddump_removeparticles_radius.f90 index 1f67632c9..d9bbd3e94 100644 --- a/src/utils/moddump_removeparticles_radius.f90 +++ b/src/utils/moddump_removeparticles_radius.f90 @@ -10,7 +10,7 @@ module moddump ! ! :References: None ! -! :Owner: Arnaud Vericel +! :Owner: Daniel Mentiplay ! ! :Runtime parameters: None ! From 0f5032db14d088a24d891c99d0903b8b78b689f1 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 08:28:58 +1000 Subject: [PATCH 354/814] [space-bot] whitespace at end of lines removed --- src/main/force.F90 | 4 +- src/main/growth.F90 | 2 +- src/main/part.F90 | 4 +- src/main/porosity.f90 | 100 ++++++++++++++++----------------- src/main/step_leapfrog.F90 | 6 +- src/setup/set_dust_options.f90 | 2 +- src/setup/setup_disc.f90 | 2 +- src/tests/test_dust.F90 | 6 +- src/tests/test_growth.f90 | 2 +- src/utils/moddump_dustadd.f90 | 4 +- 10 files changed, 66 insertions(+), 66 deletions(-) diff --git a/src/main/force.F90 b/src/main/force.F90 index 4e35d40c3..0cdb06d7e 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -533,7 +533,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& call write_cell(stack_waiting,cell) else call finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dvdx,& - divBsymm,divcurlv,dBevol,ddustevol,deltav,dustgasprop,fxyz_drag,fext,dragreg,& + divBsymm,divcurlv,dBevol,ddustevol,deltav,dustgasprop,fxyz_drag,fext,dragreg,& filfac,dtcourant,dtforce,dtvisc,dtohm,dthall,dtambi,dtdiff,dtmini,dtmaxi, & #ifdef IND_TIMESTEPS nbinmaxnew,nbinmaxstsnew,ncheckbin, & @@ -2236,7 +2236,7 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, if (use_dust .and. use_dustfrac .and. iamgasi) then do j=1,ndustsmall if (use_dustgrowth) then - if (use_porosity) then + if (use_porosity) then call get_ts(idrag,j,get_size(dustprop(1,i),dustprop(2,i),filfac(j)),& dustprop(2,i)*filfac(j),rhogasi,rhoi*dustfracisum,spsoundi,0.,tstopi(j),iregime) else diff --git a/src/main/growth.F90 b/src/main/growth.F90 index 1ad8db8c9..9dedd332b 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -631,7 +631,7 @@ subroutine set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_i iam = iamtype(iphase(i)) if (iam == idust .or. (iam == igas .and. use_dustfrac)) then dustprop(2,i) = graindenscgs / unit_density - if (sizedistrib) then + if (sizedistrib) then r = sqrt(xyzh(1,i)**2 + xyzh(2,i)**2) h = H_R_ref * R_ref * au / udist * (r * udist / au / R_ref)**(1.5-q_index) dustprop(1,i) = grainsizecgs/udist * (r * udist / au / R_ref)**pwl_sizedistrib * exp(-0.5*xyzh(3,i)**2/h**2) diff --git a/src/main/part.F90 b/src/main/part.F90 index 80f97c636..41fffe38b 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -1751,7 +1751,7 @@ subroutine delete_particles_outside_sphere(center,radius,np,revert,mytype) radius_squared = radius**2 - if (present(mytype)) then + if (present(mytype)) then do i=1,np r = xyzh(1:3,i) - center if (use_revert) then @@ -1768,7 +1768,7 @@ subroutine delete_particles_outside_sphere(center,radius,np,revert,mytype) else if (dot_product(r,r) > radius_squared) call kill_particle(i,npartoftype) endif - enddo + enddo endif call shuffle_part(np) if (np /= sum(npartoftype)) call fatal('del_part_outside_sphere','particles not conserved') diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 6fc8a293f..7fb56ff76 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -30,7 +30,7 @@ module porosity implicit none !--Default values - + integer, public :: iporosity = 0 !--0=Off 1=On (-1=On for checkup, filfac is initialized but does not evolve) integer, public :: icompact = 1 !--0=off 1=on (Compaction of dust grain during fragmentation) integer, public :: ibounce = 0 !--0=off 1=on (Allow dust grains to bounce) @@ -42,12 +42,12 @@ module porosity real, private :: cratio = -0.5801454844 !--common ratio for a power real, private :: b_oku = 0.15 !--parameter b (Okuzumi et al. 2012) real, private :: maxpacking = 0.74048 !--max sphere packing for hexagonal close packing - + real, public :: smono !--monomer size real, public :: mmono !--monomer mass real, public :: surfenerg real, public :: youngmod - real, private :: eroll !--rolling + real, private :: eroll !--rolling real, private :: grainmassminlog real, private :: Yd0 !test for compaction real, private :: Ydpow !test for compaction @@ -73,7 +73,7 @@ subroutine init_porosity(ierr) !--initialise variables in code units smono = smonocgs / udist mmono = fourpi/3 * (graindenscgs / unit_density) * smono**3 - surfenerg = surfenergSI * udist * udist * 1000 / unit_energ + surfenerg = surfenergSI * udist * udist * 1000 / unit_energ youngmod = youngmodSI * 10 / unit_pressure eroll = 302.455974078*(surfenerg**5 * smono**4 / youngmod**2)**(1./3.) @@ -129,15 +129,15 @@ subroutine init_filfac(npart,xyzh,vxyzu) real :: rho,rhogas,cs,cparam,coeff_gei,nu real :: sfrac,s1,s2,s3,filfacmax ! real :: mfrac,m1,m2,m3 - + select case (iporosity) ! add other case for other models here case (1) - + !--initialize filling factor (Garcia & Gonzalez 2020, Suyama et al. 2008, Okuzumi et al. 2012) if (all(filfac(:) == 0.)) then ! check if filfac(i) was already initialize by init_filfac or not - coeff_gei = sqrt(8./(pi*gamma)) + coeff_gei = sqrt(8./(pi*gamma)) do i=1,npart iam = iamtype(iphase(i)) if (iam == idust .or. (iam == igas .and. use_dustfrac)) then @@ -153,7 +153,7 @@ subroutine init_filfac(npart,xyzh,vxyzu) cs = get_spsound(3,xyzh(:,i),rhogas,vxyzu(:,i)) rho = rhogas + rhoh(xyzh(4,i),massoftype(idust)) endif - + !- molecular viscosity nu = get_viscmol_nu(cs,rhogas) @@ -164,15 +164,15 @@ subroutine init_filfac(npart,xyzh,vxyzu) !--transition masses m1/mmono and m2/mmono between hit&stick and Epstein/Stokes regimes with St < 1 s1 = (cparam/(2.*(2.**0.075 - 1.)*coeff_gei))**((1.-cratio)/(1.+8.*cratio)) s2 = (cparam*cs*smono/(9.*nu*(2.**0.2 - 1.)))**((1.-cratio)/(9.*cratio)) - + !--we assume St < 1 here (grainsizecgs < 100-1000 cm) if (s1 < s2) then if (sfrac < s1) then ! filling factor: hit&stick regime - filfac(i) = sfrac**(3.*cratio/(1.-cratio)) + filfac(i) = sfrac**(3.*cratio/(1.-cratio)) else !- transition masses m3/mmono between Epstein and Stokes regimes with St < 1 - s3 = s1**((1.+8.*cratio)/(1.-cratio)) / s2**(9.*cratio/(1.-cratio)) - + s3 = s1**((1.+8.*cratio)/(1.-cratio)) / s2**(9.*cratio/(1.-cratio)) + if (sfrac < s3) then ! filling factor: Epstein regime - St<1 filfac(i) = s1**((1.+8.*cratio)/(3.-3.*cratio))/sfrac**(1./3.) else ! filling factor: Stokes regime - St<1 @@ -183,7 +183,7 @@ subroutine init_filfac(npart,xyzh,vxyzu) if (sfrac < s2) then ! filling factor: hit&stick regime filfac(i) = sfrac**(3.*cratio/(1.-cratio)) else ! filling factor: Stokes regime - St<1 - filfac(i) = s2**(3.*cratio/(1.-cratio)) + filfac(i) = s2**(3.*cratio/(1.-cratio)) endif endif @@ -224,11 +224,11 @@ end subroutine init_filfac !+ ! print information about porosity !+ -!---------------------------------------------------------- -subroutine print_porosity_info(iprint) +!---------------------------------------------------------- +subroutine print_porosity_info(iprint) integer, intent(in) :: iprint - - if (iporosity == 1) then + + if (iporosity == 1) then write(iprint,"(a)") ' Using porosity ' if (icompact == 1) then write(iprint,"(a)") ' Using compaction during fragmentation ' @@ -257,7 +257,7 @@ subroutine get_filfac(npart,xyzh,mprev,filfac,dustprop,dt) integer :: i,iam real :: filfacevol,filfacmin,filfacmax real :: rho,rhod - + select case (iporosity) ! add other cases for other models here case (1) !$omp parallel do default(none) & @@ -267,7 +267,7 @@ subroutine get_filfac(npart,xyzh,mprev,filfac,dustprop,dt) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then iam = iamtype(iphase(i)) - + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then if (dustprop(1,i) > mmono) then !- compute rho = rho_gas + rho_dust @@ -285,7 +285,7 @@ subroutine get_filfac(npart,xyzh,mprev,filfac,dustprop,dt) if (dustprop(1,i) > mprev(i)) then call get_filfac_growth(mprev(i),dustprop(1,i),filfac(i),dustgasprop(:,i),filfacevol) if (ibounce == 1) call get_filfac_bounce(mprev(i),dustprop(2,i),filfac(i),& - dustgasprop(:,i),probastick(i),rhod,dt,filfacevol,filfacmin) + dustgasprop(:,i),probastick(i),rhod,dt,filfacevol,filfacmin) !--if new mass < previous mass, compute the new filling factor due to fragmentation else call get_filfac_frag(mprev(i),dustprop(:,i),filfac(i),dustgasprop(:,i),rhod,VrelVf(i),dt,filfacevol) @@ -326,18 +326,18 @@ subroutine get_filfac_growth(mprev,mass,filfac,dustgasprop,filfacgrowth) real :: j ! Power of the filling factor dependency in mass vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) - + !- kinetic energy condition Ekin/(3*b_oku/eroll) ekincdt = mprev*vrel*vrel/(12.*b_oku*eroll) - !-choose power according to the value of ekincdt + !-choose power according to the value of ekincdt if (ekincdt <= 1.) then j = cratio else j = -0.2 endif - !- filling factor due to growth + !- filling factor due to growth filfacgrowth = filfac*(mass/mprev)**j end subroutine get_filfac_growth @@ -358,18 +358,18 @@ subroutine get_filfac_bounce(mprev,graindens,filfac,dustgasprop,probastick,rhod, real :: ekin,pdyn,coeffrest,filfacbnc real :: vstick,vyield,vend - if (probastick < 1.) then + if (probastick < 1.) then vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) sdust = get_size(mprev,graindens,filfac) vstick = compute_vstick(mprev,sdust) !-compute vstick, i.e. max velocity before bouncing appears - + if (vrel >= vstick) then !-if vrel>=vstick -> bouncing vyield = compute_vyield(vstick) !-compute vyield, i.e. max velocity before inelastic collisions appear vend = compute_vend(vstick) !-compute vend, i.e. max velocity before there is only bouncing => no growth if (vrel < vyield) then !-elastic collision, no compaction filfacbnc = filfac - else !-inelastic collision, compaction + else !-inelastic collision, compaction vol = fourpi/3. * sdust**3 ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !-number of collision in dt ekin = mprev*vrel*vrel/4. @@ -419,7 +419,7 @@ subroutine get_filfac_frag(mprev,dustprop,filfac,dustgasprop,rhod,VrelVf,dt,filf ekin = mprev*vrel*vrel/4. - (2.*mprev - dustprop(1))*0.85697283*eroll/mmono !0.856973 = 3* 1.8 * 48/302.46 pdyn = eroll /((1./filfac - 1./maxpacking)*smono)**3 - deltavol = ekin/pdyn !-ekin is kinetic energy - all energy needed to break monomers + deltavol = ekin/pdyn !-ekin is kinetic energy - all energy needed to break monomers if (deltavol < 0) deltavol = 0. if (deltavol > vol) deltavol = vol @@ -448,7 +448,7 @@ subroutine get_filfac_col(i,rho,mfrac,graindens,dustgasprop,filfaccol) real, intent(out) :: filfaccol real :: cparam,coeff_gei,nu,kwok real :: m1,m2,m3,m4,m5 - + !--compute filling factor due to collisions (Garcia & Gonzalez 2020, Suyama et al. 2008, Okuzumi et al. 2012) !- shared parameter for the following filling factors @@ -486,7 +486,7 @@ subroutine get_filfac_col(i,rho,mfrac,graindens,dustgasprop,filfaccol) endif else if (mfrac < m2) then !- filling factor: hit&stick regime - filfaccol = mfrac**cratio + filfaccol = mfrac**cratio else !- filling factor: Stokes regime - St<1 filfaccol = m2**cratio endif @@ -517,17 +517,17 @@ subroutine get_filfac_min(i,rho,mfrac,graindens,dustgasprop,filfacmin) real, intent(in) :: dustgasprop(:) real, intent(out) :: filfacmin real :: filfaccol,filfacgas,filfacgrav - + call get_filfac_col(i,rho,mfrac,graindens,dustgasprop,filfaccol) - + !--compute filling factor due to gas drag compression (Garcia & Gonzalez 2020, Kataoka et al. 2013a) - filfacgas = ((mmono*smono*dustgasprop(4)*Omega_k(i))/(pi*eroll*dustgasprop(3)))**(3./7.) * mfrac**(1./7.) + filfacgas = ((mmono*smono*dustgasprop(4)*Omega_k(i))/(pi*eroll*dustgasprop(3)))**(3./7.) * mfrac**(1./7.) !--compute filling factor due to self-gravity (Garcia & Gonzalez 2020, Kataoka et al. 2013b) filfacgrav = (mmono*mmono/(pi*smono*eroll))**0.6 * mfrac**0.4 !--return the maximum filling factor between filfaccol, filfacgas and filfacgrav - filfacmin = max(filfaccol,filfacgas,filfacgrav) + filfacmin = max(filfaccol,filfacgas,filfacgrav) end subroutine get_filfac_min @@ -571,7 +571,7 @@ subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) !-compute current, current/2 and min mass in log10 grainmasscurlog = log10(dustprop(1,i)) grainmassmaxlog = log10(dustprop(1,i)/(2.)) - + !--call random number between 2 float values to assign a random mass to dustprop(1) if (grainmassmaxlog > grainmassminlog) then randmass = (grainmassmaxlog - grainmassminlog) * ran2(seed) + grainmassminlog @@ -582,7 +582,7 @@ subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) randmass = grainmasscurlog endif endif - + dustprop(1,i) = 10.**randmass !-compute filfacmin and compare it to filfac(i) @@ -624,12 +624,12 @@ subroutine get_probastick(npart,xyzh,dmdt,dustprop,dustgasprop,filfac) if (.not.isdead_or_accreted(xyzh(4,i))) then iam = iamtype(iphase(i)) if ((iam == idust .or. (iam == igas .and. use_dustfrac))) then - if (filfac(i) >= 0.3 .and. dmdt(i) >= 0.) then + if (filfac(i) >= 0.3 .and. dmdt(i) >= 0.) then vrel = vrelative(dustgasprop(:,i),sqrt(roottwo*Ro*shearparam)*dustgasprop(1,i)) sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) vstick = compute_vstick(dustprop(1,i),sdust) vend = compute_vend(vstick) - + !compute the probability of bounce depending on the velocity if (vrel >= vstick) then if(vrel < vend) then @@ -661,9 +661,9 @@ end subroutine get_probastick subroutine write_options_porosity(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit - + write(iunit,"(/,a)") '# options controlling porosity (require idrag=1)' - call write_inopt(iporosity,'iporosity','porosity (0=off,1=on) ',iunit) + call write_inopt(iporosity,'iporosity','porosity (0=off,1=on) ',iunit) if (iporosity == 1 .or. iporosity == -1) then call write_inopt(icompact, 'icompact', 'Compaction during fragmentation (ifrag > 0) (0=off,1=on)', iunit) call write_inopt(ibounce, 'ibounce', 'Dust bouncing (0=off,1=on)', iunit) @@ -673,7 +673,7 @@ subroutine write_options_porosity(iunit) call write_inopt(youngmodSI,'youngmodSI','Monomer young modulus in Pa',iunit) call write_inopt(gammaft,'gammaft','Force to torque efficient of gas flow on dust',iunit) endif - + end subroutine write_options_porosity !----------------------------------------------------------------------- @@ -686,12 +686,12 @@ subroutine read_options_porosity(name,valstring,imatch,igotall,ierr) character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr - + integer, save :: ngot = 0 - + imatch = .true. igotall = .false. - + select case(trim(name)) case('iporosity') read(valstring,*,iostat=ierr) iporosity @@ -720,11 +720,11 @@ subroutine read_options_porosity(name,valstring,imatch,igotall,ierr) ngot = ngot + 1 case default imatch = .false. - end select + end select if ((iporosity == 0) .and. ngot == 1) igotall = .true. - if ((iporosity /= 0) .and. ngot == 8) igotall = .true. - + if ((iporosity /= 0) .and. ngot == 8) igotall = .true. + end subroutine read_options_porosity !----------------------------------------------------------------------- @@ -735,12 +735,12 @@ end subroutine read_options_porosity subroutine write_porosity_setup_options(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit - + write(iunit,"(/,a)") '# options for porosity' call write_inopt(iporosity,'iporosity','porosity (0=Off,1=On)',iunit) call write_inopt(ibounce,'ibounce','bouncing (0=Off,1=On)',iunit) call write_inopt(idisrupt,'idisrupt','disruption (0=Off,1=On)',iunit) - + end subroutine write_porosity_setup_options !----------------------------------------------------------------------- @@ -753,12 +753,12 @@ subroutine read_porosity_setup_options(db,nerr) use infile_utils, only:read_inopt,inopts type(inopts), allocatable, intent(inout) :: db(:) integer, intent(inout) :: nerr - + call read_inopt(iporosity,'iporosity',db,min=-1,max=1,errcount=nerr) if (iporosity == 1 .or. iporosity == -1) use_porosity = .true. call read_inopt(ibounce,'ibounce',db,min=0,max=1,errcount=nerr) call read_inopt(idisrupt,'idisrupt',db,min=0,max=1,errcount=nerr) - + end subroutine read_porosity_setup_options real function get_coeffrest(vstickvrel,vyieldvrel) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 6fe1643d2..fb23aefd6 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -224,7 +224,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !omp end parallel do if (use_dustgrowth) then if (use_porosity) then - call get_filfac(npart,xyzh,mprev,filfac,dustprop,hdti) + call get_filfac(npart,xyzh,mprev,filfac,dustprop,hdti) endif call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif @@ -365,7 +365,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp end parallel do if (use_dustgrowth) then if (use_porosity) then - call get_filfac(npart,xyzh,dustprop(1,:),filfacpred,dustproppred,hdti) + call get_filfac(npart,xyzh,dustprop(1,:),filfacpred,dustproppred,hdti) endif call check_dustprop(npart,dustproppred(:,:),filfacpred,dustprop(1,:),filfac) endif @@ -661,7 +661,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_dustgrowth) then if (use_porosity) then - call get_filfac(npart,xyzh,mprev,filfac,dustprop,dtsph) + call get_filfac(npart,xyzh,mprev,filfac,dustprop,dtsph) endif call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif diff --git a/src/setup/set_dust_options.f90 b/src/setup/set_dust_options.f90 index 94b01d196..c97bbf0ca 100644 --- a/src/setup/set_dust_options.f90 +++ b/src/setup/set_dust_options.f90 @@ -722,7 +722,7 @@ subroutine write_dust_setup_options(iunit) call write_growth_setup_options(iunit) call write_porosity_setup_options(iunit) endif - + end subroutine write_dust_setup_options !-------------------------------------------------------------------------- diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 8b7a1b5a2..65b5895ef 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -1617,7 +1617,7 @@ subroutine initialise_dustprop(npart) do i=1,npart iam = iamtype(iphase(i)) if (iam==idust .or. (use_dustfrac .and. iam==igas)) then - dustprop(1,i) = fourpi/3.*graindens(1)*grainsize(1)**3 + dustprop(1,i) = fourpi/3.*graindens(1)*grainsize(1)**3 dustprop(2,i) = graindens(1) else dustprop(:,i) = 0. diff --git a/src/tests/test_dust.F90 b/src/tests/test_dust.F90 index de2593e7f..427f239e6 100644 --- a/src/tests/test_dust.F90 +++ b/src/tests/test_dust.F90 @@ -280,7 +280,7 @@ subroutine test_dustybox(ntests,npass) open(unit=lu,file=filename,status='replace') print "(a)",' writing '//trim(filename) endif - + do j=1,npart if (iamdust(iphase(j))) then call checkvalbuf(vxyzu(1,j),vd,tol,'vd',nerr(1),ncheck(1),errmax(1)) @@ -291,11 +291,11 @@ subroutine test_dustybox(ntests,npass) else call checkvalbuf(vxyzu(1,j),vg,tolvg,'vg',nerr(3),ncheck(3),errmax(3)) call checkvalbuf(fxyzu(1,j),-fd,tolfg,'fg',nerr(4),ncheck(4),errmax(4)) - if (write_output) write(lu,*) vxyzu(1,j),fxyzu(1,j),vg,-fd + if (write_output) write(lu,*) vxyzu(1,j),fxyzu(1,j),vg,-fd endif enddo if (write_output) close(lu) - + !call checkval(npart/2-1,vxyzu(1,1:npart),vg,tolvg,nerr(2),'vg') ekin_exact = 0.5*totmass*(vd**2 + vg**2) !print*,' step ',i,'t = ',t,' ekin should be ',ekin_exact, ' got ',ekin,(ekin-ekin_exact)/ekin_exact diff --git a/src/tests/test_growth.f90 b/src/tests/test_growth.f90 index 99d661815..01190a85b 100644 --- a/src/tests/test_growth.f90 +++ b/src/tests/test_growth.f90 @@ -245,7 +245,7 @@ subroutine test_farmingbox(ntests,npass,frag,onefluid) if (use_dust) then dustevol(:,i) = 0. dustfrac(:,i) = 0. - dustprop(1,i) = fourpi/3.*dens*sinit**3 + dustprop(1,i) = fourpi/3.*dens*sinit**3 dustprop(2,i) = dens dustgasprop(:,i) = 0. VrelVf(i) = 0. diff --git a/src/utils/moddump_dustadd.f90 b/src/utils/moddump_dustadd.f90 index 32f97a43f..53993105f 100644 --- a/src/utils/moddump_dustadd.f90 +++ b/src/utils/moddump_dustadd.f90 @@ -48,7 +48,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) integer :: iremoveparttype real :: inradius,outradius,pwl_sizedistrib,R_ref,H_R_ref,q_index logical :: icutinside,icutoutside,sizedistrib - + if (.not. use_dust) then print*,' DOING NOTHING: COMPILE WITH DUST=yes' @@ -119,7 +119,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) else if (use_dustgrowth) then call prompt('Use porosity ? (0=no,1=yes)',iporosity,0,1) - if (iporosity == 1) then + if (iporosity == 1) then use_porosity = .true. endif call prompt('Set dust size via size distribution ?',sizedistrib) From 1b3e7a49ff18b2cd2327ff46f828acfa8fab7e94 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 08:28:59 +1000 Subject: [PATCH 355/814] [author-bot] updated AUTHORS file --- AUTHORS | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/AUTHORS b/AUTHORS index dc6272205..4b972f1d7 100644 --- a/AUTHORS +++ b/AUTHORS @@ -22,8 +22,8 @@ Elisabeth Borchert Ward Homan Christophe Pinte Terrence Tricco -Simone Ceppi Stephane Michoulier +Simone Ceppi Spencer Magnall Caitlyn Hardiman Enrico Ragusa @@ -31,8 +31,8 @@ Sergei Biriukov Cristiano Longarini Giovanni Dipierro Roberto Iaconi -Amena Faruqi Hauke Worpel +Amena Faruqi Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani @@ -49,21 +49,23 @@ Phantom benchmark bot Kieran Hirsh Nicole Rodrigues David Trevascus -Farzana Meru Nicolás Cuello +Farzana Meru +Mike Lau Chris Nixon Miguel Gonzalez-Bolivar -Benoit Commercon -Giulia Ballabio -Joe Fisher -Maxime Lombart -Mike Lau Orsola De Marco +Maxime Lombart +Joe Fisher Zachary Pellow +Benoit Commercon +Giulia Ballabio s-neilson <36410751+s-neilson@users.noreply.github.com> -Cox, Samuel +MICHOULIER Stephane +Steven Rieder Jeremy Smallwood +Cox, Samuel Jorge Cuadra -Steven Rieder Stéven Toupin Taj Jankovič +Chunliang Mu From 4c04aa7a57ea1733d851fe07e7a0e6af2e5d5896 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 08:29:14 +1000 Subject: [PATCH 356/814] [format-bot] end if -> endif; end do -> enddo; if( -> if ( --- src/main/porosity.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 7fb56ff76..60e2f8717 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -632,7 +632,7 @@ subroutine get_probastick(npart,xyzh,dmdt,dustprop,dustgasprop,filfac) !compute the probability of bounce depending on the velocity if (vrel >= vstick) then - if(vrel < vend) then + if (vrel < vend) then probastick(i) = (log(vrel)-log(vend))/(log(vstick)-log(vend)) else probastick(i) = 0. !full bounce -> no growth From 8780feb9690e0db833a79c4acb10a470af7672e0 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 08:29:34 +1000 Subject: [PATCH 357/814] [indent-bot] standardised indentation --- src/main/deriv.F90 | 4 +- src/main/growth.F90 | 18 +- src/main/part.F90 | 2 +- src/main/porosity.f90 | 632 +++++++++++++++++----------------- src/main/step_leapfrog.F90 | 2 +- src/utils/moddump_dustadd.f90 | 4 +- src/utils/struct_part.f90 | 8 +- 7 files changed, 335 insertions(+), 335 deletions(-) diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index cdaa4100d..eded71823 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -187,8 +187,8 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& if (use_dustgrowth) then ! compute growth rate of dust particles call get_growth_rate(npart,xyzh,vxyzu,dustgasprop,VrelVf,dustprop,filfac,ddustprop(1,:))!--we only get dm/dt (i.e 1st dimension of ddustprop) - ! compute growth rate and probability of sticking/bouncing of porous dust - if (use_porosity) call get_probastick(npart,xyzh,ddustprop(1,:),dustprop,dustgasprop,filfac) + ! compute growth rate and probability of sticking/bouncing of porous dust + if (use_porosity) call get_probastick(npart,xyzh,ddustprop(1,:),dustprop,dustgasprop,filfac) endif ! diff --git a/src/main/growth.F90 b/src/main/growth.F90 index 9dedd332b..fe45aa990 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -595,15 +595,15 @@ subroutine check_dustprop(npart,dustprop,filfac,mprev,filfacprev) sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) tsnew = dustgasprop(3,i)*sdustprev*filfacprev(i)/sdust/filfac(i)/Omega_k(i) if (tsnew < tsmin) then - sdustmin = tsmin*sdustprev*filfacprev(i)*Omega_k(i)/filfac(i)/dustgasprop(3,i) - dustprop(1,i) = dustprop(1,i) * (sdustmin/sdust)**3. + sdustmin = tsmin*sdustprev*filfacprev(i)*Omega_k(i)/filfac(i)/dustgasprop(3,i) + dustprop(1,i) = dustprop(1,i) * (sdustmin/sdust)**3. endif else sdust = get_size(dustprop(1,i),dustprop(2,i)) if (sdust < grainsizemin) then dustprop(1,i) = dustprop(1,i) * (grainsizemin/sdust)**3. ! fragmentation at constant density and filling factor endif - endif + endif endif enddo !$omp end parallel do @@ -699,12 +699,12 @@ subroutine bin_to_multi(bins_per_dex,force_smax,smax_user,verbose) itype = iamtype(iphase(i)) if (itype==idust) then if (use_porosity) then - dustpropmcfost(1,i) = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) - dustpropmcfost(2,i) = filfac(i) - else - dustpropmcfost(1,i) = get_size(dustprop(1,i),dustprop(2,i)) - dustpropmcfost(2,i) = 1 - endif + dustpropmcfost(1,i) = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) + dustpropmcfost(2,i) = filfac(i) + else + dustpropmcfost(1,i) = get_size(dustprop(1,i),dustprop(2,i)) + dustpropmcfost(2,i) = 1 + endif if (dustpropmcfost(1,i) < smintmp) smintmp = dustpropmcfost(1,i) if (dustpropmcfost(1,i) > smaxtmp) smaxtmp = dustpropmcfost(1,i) !if (dustpropmcfost(2,i) < fmintmp) fmintmp = dustpropmcfost(2,i) diff --git a/src/main/part.F90 b/src/main/part.F90 index 41fffe38b..331f9de21 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -1768,7 +1768,7 @@ subroutine delete_particles_outside_sphere(center,radius,np,revert,mytype) else if (dot_product(r,r) > radius_squared) call kill_particle(i,npartoftype) endif - enddo + enddo endif call shuffle_part(np) if (np /= sum(npartoftype)) call fatal('del_part_outside_sphere','particles not conserved') diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 60e2f8717..de7886276 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -56,7 +56,7 @@ module porosity public :: init_porosity,print_porosity_info,write_options_porosity,read_options_porosity public :: write_porosity_setup_options,read_porosity_setup_options - contains +contains !------------------------------------------------ !+ @@ -83,13 +83,13 @@ subroutine init_porosity(ierr) grainmassminlog = log10(50.*mmono) if (smono <= 0.) then - call error('init_porosity','smonocgs <= 0',var='smonocgs',val=smonocgs) - ierr = 1 + call error('init_porosity','smonocgs <= 0',var='smonocgs',val=smonocgs) + ierr = 1 endif if (grainsizecgs < smonocgs) then - call error('init_porosity','grainsizecgs < smonocgs',var='smonocgs',val=smonocgs) - ierr = 1 + call error('init_porosity','grainsizecgs < smonocgs',var='smonocgs',val=smonocgs) + ierr = 1 endif if (surfenerg <= 0.) then @@ -134,88 +134,88 @@ subroutine init_filfac(npart,xyzh,vxyzu) select case (iporosity) ! add other case for other models here case (1) - !--initialize filling factor (Garcia & Gonzalez 2020, Suyama et al. 2008, Okuzumi et al. 2012) - - if (all(filfac(:) == 0.)) then ! check if filfac(i) was already initialize by init_filfac or not - coeff_gei = sqrt(8./(pi*gamma)) - do i=1,npart - iam = iamtype(iphase(i)) - if (iam == idust .or. (iam == igas .and. use_dustfrac)) then - sfrac = (dustprop(1,i)/mmono)**(1./3.) - if (sfrac > 1.) then ! if grainsize > monomer size, compute filling factor - !- compute rho, rhogas and cs - if (iam == igas .and. use_dustfrac) then - rho = rhoh(xyzh(4,i),massoftype(igas)) - rhogas = rho*(1-dustfrac(1,i)) - cs = get_spsound(3,xyzh(:,i),rhogas,vxyzu(:,i)) - else - rhogas = rhoh(xyzh(4,i),massoftype(igas)) - cs = get_spsound(3,xyzh(:,i),rhogas,vxyzu(:,i)) - rho = rhogas + rhoh(xyzh(4,i),massoftype(idust)) - endif - - !- molecular viscosity - nu = get_viscmol_nu(cs,rhogas) - - !- shared parameter for the following filling factors - cparam = (243.*pi*roottwo/15625.)*(Ro*shearparam*smono**4*dustprop(2,i)*dustprop(2,i)*cs & + !--initialize filling factor (Garcia & Gonzalez 2020, Suyama et al. 2008, Okuzumi et al. 2012) + + if (all(filfac(:) == 0.)) then ! check if filfac(i) was already initialize by init_filfac or not + coeff_gei = sqrt(8./(pi*gamma)) + do i=1,npart + iam = iamtype(iphase(i)) + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then + sfrac = (dustprop(1,i)/mmono)**(1./3.) + if (sfrac > 1.) then ! if grainsize > monomer size, compute filling factor + !- compute rho, rhogas and cs + if (iam == igas .and. use_dustfrac) then + rho = rhoh(xyzh(4,i),massoftype(igas)) + rhogas = rho*(1-dustfrac(1,i)) + cs = get_spsound(3,xyzh(:,i),rhogas,vxyzu(:,i)) + else + rhogas = rhoh(xyzh(4,i),massoftype(igas)) + cs = get_spsound(3,xyzh(:,i),rhogas,vxyzu(:,i)) + rho = rhogas + rhoh(xyzh(4,i),massoftype(idust)) + endif + + !- molecular viscosity + nu = get_viscmol_nu(cs,rhogas) + + !- shared parameter for the following filling factors + cparam = (243.*pi*roottwo/15625.)*(Ro*shearparam*smono**4*dustprop(2,i)*dustprop(2,i)*cs & *Omega_k(i))/(rho*b_oku*eroll) - !--transition masses m1/mmono and m2/mmono between hit&stick and Epstein/Stokes regimes with St < 1 - s1 = (cparam/(2.*(2.**0.075 - 1.)*coeff_gei))**((1.-cratio)/(1.+8.*cratio)) - s2 = (cparam*cs*smono/(9.*nu*(2.**0.2 - 1.)))**((1.-cratio)/(9.*cratio)) - - !--we assume St < 1 here (grainsizecgs < 100-1000 cm) - if (s1 < s2) then - if (sfrac < s1) then ! filling factor: hit&stick regime - filfac(i) = sfrac**(3.*cratio/(1.-cratio)) - else - !- transition masses m3/mmono between Epstein and Stokes regimes with St < 1 - s3 = s1**((1.+8.*cratio)/(1.-cratio)) / s2**(9.*cratio/(1.-cratio)) - - if (sfrac < s3) then ! filling factor: Epstein regime - St<1 - filfac(i) = s1**((1.+8.*cratio)/(3.-3.*cratio))/sfrac**(1./3.) - else ! filling factor: Stokes regime - St<1 - filfac(i) = s2**(3.*cratio/(1.-cratio)) - endif - endif - else - if (sfrac < s2) then ! filling factor: hit&stick regime - filfac(i) = sfrac**(3.*cratio/(1.-cratio)) - else ! filling factor: Stokes regime - St<1 - filfac(i) = s2**(3.*cratio/(1.-cratio)) - endif - endif - - !- max value of filfac is maxpacking == max compaction - filfacmax = 0.5*maxpacking *(1+ sqrt(1 + 4*(1.-maxpacking)/maxpacking/maxpacking*sfrac**(-3))) - if (filfac(i) > filfacmax) filfac(i) = filfacmax - - !- Compute grain mass of the grain using grain size and filfac - dustprop(1,i) = filfac(i) * dustprop(1,i) - else - filfac(i) = 1. - dustprop(1,i) = mmono - endif + !--transition masses m1/mmono and m2/mmono between hit&stick and Epstein/Stokes regimes with St < 1 + s1 = (cparam/(2.*(2.**0.075 - 1.)*coeff_gei))**((1.-cratio)/(1.+8.*cratio)) + s2 = (cparam*cs*smono/(9.*nu*(2.**0.2 - 1.)))**((1.-cratio)/(9.*cratio)) + + !--we assume St < 1 here (grainsizecgs < 100-1000 cm) + if (s1 < s2) then + if (sfrac < s1) then ! filling factor: hit&stick regime + filfac(i) = sfrac**(3.*cratio/(1.-cratio)) + else + !- transition masses m3/mmono between Epstein and Stokes regimes with St < 1 + s3 = s1**((1.+8.*cratio)/(1.-cratio)) / s2**(9.*cratio/(1.-cratio)) + + if (sfrac < s3) then ! filling factor: Epstein regime - St<1 + filfac(i) = s1**((1.+8.*cratio)/(3.-3.*cratio))/sfrac**(1./3.) + else ! filling factor: Stokes regime - St<1 + filfac(i) = s2**(3.*cratio/(1.-cratio)) + endif + endif + else + if (sfrac < s2) then ! filling factor: hit&stick regime + filfac(i) = sfrac**(3.*cratio/(1.-cratio)) + else ! filling factor: Stokes regime - St<1 + filfac(i) = s2**(3.*cratio/(1.-cratio)) + endif + endif + + !- max value of filfac is maxpacking == max compaction + filfacmax = 0.5*maxpacking *(1+ sqrt(1 + 4*(1.-maxpacking)/maxpacking/maxpacking*sfrac**(-3))) + if (filfac(i) > filfacmax) filfac(i) = filfacmax + + !- Compute grain mass of the grain using grain size and filfac + dustprop(1,i) = filfac(i) * dustprop(1,i) + else + filfac(i) = 1. + dustprop(1,i) = mmono endif - enddo - endif + endif + enddo + endif case (-1) - !--initialize filling factor for compact grains - if (all(filfac(:) == 0.)) then ! check if filfac(i) was already initialize by init_filfac or not - do i=1,npart - iam = iamtype(iphase(i)) - if (iam == idust .or. (iam == igas .and. use_dustfrac)) then - sfrac = (dustprop(1,i)/mmono)**(1./3.) - if (sfrac > 1.) then ! if grainsize > monomer size, compute filling factor - filfac(i) = 1. - else - filfac(i) = 1. - dustprop(1,i) = mmono - endif + !--initialize filling factor for compact grains + if (all(filfac(:) == 0.)) then ! check if filfac(i) was already initialize by init_filfac or not + do i=1,npart + iam = iamtype(iphase(i)) + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then + sfrac = (dustprop(1,i)/mmono)**(1./3.) + if (sfrac > 1.) then ! if grainsize > monomer size, compute filling factor + filfac(i) = 1. + else + filfac(i) = 1. + dustprop(1,i) = mmono endif - enddo - endif + endif + enddo + endif end select end subroutine init_filfac @@ -229,13 +229,13 @@ subroutine print_porosity_info(iprint) integer, intent(in) :: iprint if (iporosity == 1) then - write(iprint,"(a)") ' Using porosity ' - if (icompact == 1) then - write(iprint,"(a)") ' Using compaction during fragmentation ' - endif - write(iprint,"(2(a,1pg10.3),a)")' Monomer size = ',smonocgs,' cm = ',smono,' (code units)' - write(iprint,"(2(a,1pg10.3),a)")' Surface energy = ',surfenergSI,' J/m**2 = ',surfenerg,' (code units)' - write(iprint,"(2(a,1pg10.3),a)")' Young modulus = ',youngmodSI,' Pa = ',youngmod,' (code units)' + write(iprint,"(a)") ' Using porosity ' + if (icompact == 1) then + write(iprint,"(a)") ' Using compaction during fragmentation ' + endif + write(iprint,"(2(a,1pg10.3),a)")' Monomer size = ',smonocgs,' cm = ',smono,' (code units)' + write(iprint,"(2(a,1pg10.3),a)")' Surface energy = ',surfenergSI,' J/m**2 = ',surfenerg,' (code units)' + write(iprint,"(2(a,1pg10.3),a)")' Young modulus = ',youngmodSI,' Pa = ',youngmod,' (code units)' endif end subroutine print_porosity_info @@ -260,53 +260,53 @@ subroutine get_filfac(npart,xyzh,mprev,filfac,dustprop,dt) select case (iporosity) ! add other cases for other models here case (1) - !$omp parallel do default(none) & - !$omp shared(xyzh,npart,iphase,massoftype,use_dustfrac,dustfrac,icompact) & - !$omp shared(mprev,filfac,dustprop,dustgasprop,VrelVf,probastick,mmono,maxpacking,dt,ibounce) & - !$omp private(i,iam,rho,rhod,filfacevol,filfacmin,filfacmax) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - iam = iamtype(iphase(i)) - - if (iam == idust .or. (iam == igas .and. use_dustfrac)) then - if (dustprop(1,i) > mmono) then - !- compute rho = rho_gas + rho_dust - - if (use_dustfrac .and. iam == igas) then - rho = rhoh(xyzh(4,i),massoftype(igas)) - rhod = rho*dustfrac(1,i) - else - rhod = rhoh(xyzh(4,i),massoftype(idust)) - rho = dustgasprop(2,i) + rhod - endif - - call get_filfac_min(i,rho,dustprop(1,i)/mmono,dustprop(2,i),dustgasprop(:,i),filfacmin) - !--if new mass > previous mass, compute the new filling factor due to growth - if (dustprop(1,i) > mprev(i)) then - call get_filfac_growth(mprev(i),dustprop(1,i),filfac(i),dustgasprop(:,i),filfacevol) - if (ibounce == 1) call get_filfac_bounce(mprev(i),dustprop(2,i),filfac(i),& + !$omp parallel do default(none) & + !$omp shared(xyzh,npart,iphase,massoftype,use_dustfrac,dustfrac,icompact) & + !$omp shared(mprev,filfac,dustprop,dustgasprop,VrelVf,probastick,mmono,maxpacking,dt,ibounce) & + !$omp private(i,iam,rho,rhod,filfacevol,filfacmin,filfacmax) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + iam = iamtype(iphase(i)) + + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then + if (dustprop(1,i) > mmono) then + !- compute rho = rho_gas + rho_dust + + if (use_dustfrac .and. iam == igas) then + rho = rhoh(xyzh(4,i),massoftype(igas)) + rhod = rho*dustfrac(1,i) + else + rhod = rhoh(xyzh(4,i),massoftype(idust)) + rho = dustgasprop(2,i) + rhod + endif + + call get_filfac_min(i,rho,dustprop(1,i)/mmono,dustprop(2,i),dustgasprop(:,i),filfacmin) + !--if new mass > previous mass, compute the new filling factor due to growth + if (dustprop(1,i) > mprev(i)) then + call get_filfac_growth(mprev(i),dustprop(1,i),filfac(i),dustgasprop(:,i),filfacevol) + if (ibounce == 1) call get_filfac_bounce(mprev(i),dustprop(2,i),filfac(i),& dustgasprop(:,i),probastick(i),rhod,dt,filfacevol,filfacmin) - !--if new mass < previous mass, compute the new filling factor due to fragmentation - else - call get_filfac_frag(mprev(i),dustprop(:,i),filfac(i),dustgasprop(:,i),rhod,VrelVf(i),dt,filfacevol) - endif - filfac(i) = filfacevol - - !--check if the filling factor is smaller than the minimum filling factor - filfac(i) = max(filfac(i),filfacmin) - !-- max value of filfac is maxpacking == max compaction - filfacmax = maxpacking + (1.-maxpacking)*mmono/dustprop(1,i) - filfac(i) = min(filfac(i),filfacmax) - else - filfac(i) = 1. - dustprop(1,i) = mmono - endif - endif + !--if new mass < previous mass, compute the new filling factor due to fragmentation + else + call get_filfac_frag(mprev(i),dustprop(:,i),filfac(i),dustgasprop(:,i),rhod,VrelVf(i),dt,filfacevol) + endif + filfac(i) = filfacevol + + !--check if the filling factor is smaller than the minimum filling factor + filfac(i) = max(filfac(i),filfacmin) + !-- max value of filfac is maxpacking == max compaction + filfacmax = maxpacking + (1.-maxpacking)*mmono/dustprop(1,i) + filfac(i) = min(filfac(i),filfacmax) else - filfac(i) = 0. + filfac(i) = 1. + dustprop(1,i) = mmono endif - enddo - !$omp end parallel do + endif + else + filfac(i) = 0. + endif + enddo + !$omp end parallel do end select end subroutine get_filfac @@ -332,9 +332,9 @@ subroutine get_filfac_growth(mprev,mass,filfac,dustgasprop,filfacgrowth) !-choose power according to the value of ekincdt if (ekincdt <= 1.) then - j = cratio + j = cratio else - j = -0.2 + j = -0.2 endif !- filling factor due to growth @@ -359,40 +359,40 @@ subroutine get_filfac_bounce(mprev,graindens,filfac,dustgasprop,probastick,rhod, real :: vstick,vyield,vend if (probastick < 1.) then - vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) - sdust = get_size(mprev,graindens,filfac) - vstick = compute_vstick(mprev,sdust) !-compute vstick, i.e. max velocity before bouncing appears - - if (vrel >= vstick) then !-if vrel>=vstick -> bouncing - vyield = compute_vyield(vstick) !-compute vyield, i.e. max velocity before inelastic collisions appear - vend = compute_vend(vstick) !-compute vend, i.e. max velocity before there is only bouncing => no growth - - if (vrel < vyield) then !-elastic collision, no compaction - filfacbnc = filfac - else !-inelastic collision, compaction - vol = fourpi/3. * sdust**3 - ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !-number of collision in dt - ekin = mprev*vrel*vrel/4. - coeffrest = get_coeffrest(vstick/vrel,vyield/vrel) !-coefficient of restitution - !pdyn = eroll * (filfac/(maxpacking - filfac)/smono)**3 - pdyn = eroll /((1./filfac - 1./maxpacking)*smono)**3 - deltavol = (1.-coeffrest*coeffrest)*ekin/pdyn - if (deltavol > vol) deltavol = vol - - filfacbnc = filfac *(1./(1.-0.5*(deltavol/vol)))**ncoll - if (filfacbnc > maxpacking) filfacbnc = maxpacking - endif - - if (vrel < vend) then !-final filfac is a combination of filfac due to growth + bouncing - if (filfacevol < filfacmin) filfacevol = filfacmin - filfacevol = filfacevol*probastick + (1-probastick)*filfacbnc - else - filfacevol = filfacbnc - endif - endif + vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + sdust = get_size(mprev,graindens,filfac) + vstick = compute_vstick(mprev,sdust) !-compute vstick, i.e. max velocity before bouncing appears + + if (vrel >= vstick) then !-if vrel>=vstick -> bouncing + vyield = compute_vyield(vstick) !-compute vyield, i.e. max velocity before inelastic collisions appear + vend = compute_vend(vstick) !-compute vend, i.e. max velocity before there is only bouncing => no growth + + if (vrel < vyield) then !-elastic collision, no compaction + filfacbnc = filfac + else !-inelastic collision, compaction + vol = fourpi/3. * sdust**3 + ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !-number of collision in dt + ekin = mprev*vrel*vrel/4. + coeffrest = get_coeffrest(vstick/vrel,vyield/vrel) !-coefficient of restitution + !pdyn = eroll * (filfac/(maxpacking - filfac)/smono)**3 + pdyn = eroll /((1./filfac - 1./maxpacking)*smono)**3 + deltavol = (1.-coeffrest*coeffrest)*ekin/pdyn + if (deltavol > vol) deltavol = vol + + filfacbnc = filfac *(1./(1.-0.5*(deltavol/vol)))**ncoll + if (filfacbnc > maxpacking) filfacbnc = maxpacking + endif + + if (vrel < vend) then !-final filfac is a combination of filfac due to growth + bouncing + if (filfacevol < filfacmin) filfacevol = filfacmin + filfacevol = filfacevol*probastick + (1-probastick)*filfacbnc + else + filfacevol = filfacbnc + endif + endif endif - end subroutine get_filfac_bounce +end subroutine get_filfac_bounce !----------------------------------------------------------------------- !+ @@ -411,26 +411,26 @@ subroutine get_filfac_frag(mprev,dustprop,filfac,dustgasprop,rhod,VrelVf,dt,filf select case (icompact) case (1) - ! model Garcia + Kataoka mod - sdust = get_size(mprev,dustprop(2),filfac) - vol = fourpi/3. * sdust**3 - vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) - ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !number of collisions in dt + ! model Garcia + Kataoka mod + sdust = get_size(mprev,dustprop(2),filfac) + vol = fourpi/3. * sdust**3 + vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !number of collisions in dt - ekin = mprev*vrel*vrel/4. - (2.*mprev - dustprop(1))*0.85697283*eroll/mmono !0.856973 = 3* 1.8 * 48/302.46 - pdyn = eroll /((1./filfac - 1./maxpacking)*smono)**3 - deltavol = ekin/pdyn !-ekin is kinetic energy - all energy needed to break monomers + ekin = mprev*vrel*vrel/4. - (2.*mprev - dustprop(1))*0.85697283*eroll/mmono !0.856973 = 3* 1.8 * 48/302.46 + pdyn = eroll /((1./filfac - 1./maxpacking)*smono)**3 + deltavol = ekin/pdyn !-ekin is kinetic energy - all energy needed to break monomers - if (deltavol < 0) deltavol = 0. - if (deltavol > vol) deltavol = vol + if (deltavol < 0) deltavol = 0. + if (deltavol > vol) deltavol = vol - filfacfrag = filfac *(1./(1.-0.5*exp(1-VrelVf**2.)*deltavol/vol))**ncoll + filfacfrag = filfac *(1./(1.-0.5*exp(1-VrelVf**2.)*deltavol/vol))**ncoll case default ! (0) ! Fragmentation at constant filling factor filfacfrag = filfac end select - end subroutine get_filfac_frag +end subroutine get_filfac_frag !----------------------------------------------------------------------- !+ @@ -462,9 +462,9 @@ subroutine get_filfac_col(i,rho,mfrac,graindens,dustgasprop,filfaccol) !- Kwok (1975) correction for supersonic drag is important if (dragreg(i) == 2) then - kwok = sqrt(1.+9.*pi/128.*dustgasprop(4)*dustgasprop(4)/(dustgasprop(1)*dustgasprop(1))) + kwok = sqrt(1.+9.*pi/128.*dustgasprop(4)*dustgasprop(4)/(dustgasprop(1)*dustgasprop(1))) else - kwok = 1. + kwok = 1. endif !--transition sizes m1/mmono and m2/mmono between hit&stick and Epstein/Stokes regimes with St < 1 @@ -472,35 +472,35 @@ subroutine get_filfac_col(i,rho,mfrac,graindens,dustgasprop,filfaccol) m2 = (cparam*dustgasprop(1)*smono/(9.*nu*(2.**0.2 - 1.)))**(1./(3.*cratio)) if (dustgasprop(3) <= 1) then !- Stokes < 1 - if (m1 < m2) then - if (mfrac < m1) then !- filling factor: hit&stick regime - filfaccol = mfrac**cratio - else - !- transition masses m3/mmono between Epstein and Stokes regimes with St < 1 - m3 = m1**(8.*cratio+1.) / m2**(8*cratio) - if (mfrac < m3) then !- filling factor: Epstein regime - St<1 - filfaccol = m1**(cratio+0.125)/mfrac**(0.125) - else !- filling factor: Stokes regime - St<1 - filfaccol = m2**cratio - endif - endif - else - if (mfrac < m2) then !- filling factor: hit&stick regime - filfaccol = mfrac**cratio - else !- filling factor: Stokes regime - St<1 + if (m1 < m2) then + if (mfrac < m1) then !- filling factor: hit&stick regime + filfaccol = mfrac**cratio + else + !- transition masses m3/mmono between Epstein and Stokes regimes with St < 1 + m3 = m1**(8.*cratio+1.) / m2**(8*cratio) + if (mfrac < m3) then !- filling factor: Epstein regime - St<1 + filfaccol = m1**(cratio+0.125)/mfrac**(0.125) + else !- filling factor: Stokes regime - St<1 filfaccol = m2**cratio - endif - endif + endif + endif + else + if (mfrac < m2) then !- filling factor: hit&stick regime + filfaccol = mfrac**cratio + else !- filling factor: Stokes regime - St<1 + filfaccol = m2**cratio + endif + endif else !- Stokes > 1 - !--transition masses m4/mmono and m5/mmono between hit&stick and Epstein/Stokes regimes with St > 1 - m4 = (rho*coeff_gei*kwok*dustgasprop(1)/(graindens*smono*Omega_k(i)))**4 / m1**((cratio+0.125)/0.375) - m5 = (9.*nu*rho/(2.*graindens*smono**2*Omega_k(i)))**1.5 / m2**(0.5*cratio) - - if (m4 < m5) then !- filling factor: Epstein regime - St>1 - filfaccol = m1**(cratio+0.125) * m4**0.075 / mfrac**0.2 - else !- filling factor: Stokes regime - St>1 - filfaccol = m2**cratio * (m5/mfrac)**0.2 - endif + !--transition masses m4/mmono and m5/mmono between hit&stick and Epstein/Stokes regimes with St > 1 + m4 = (rho*coeff_gei*kwok*dustgasprop(1)/(graindens*smono*Omega_k(i)))**4 / m1**((cratio+0.125)/0.375) + m5 = (9.*nu*rho/(2.*graindens*smono**2*Omega_k(i)))**1.5 / m2**(0.5*cratio) + + if (m4 < m5) then !- filling factor: Epstein regime - St>1 + filfaccol = m1**(cratio+0.125) * m4**0.075 / mfrac**0.2 + else !- filling factor: Stokes regime - St>1 + filfaccol = m2**cratio * (m5/mfrac)**0.2 + endif endif end subroutine get_filfac_col @@ -546,53 +546,53 @@ subroutine get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) select case (idisrupt) case(1) - !$omp parallel do default(none) & - !$omp shared(xyzh,npart,massoftype,iphase,use_dustfrac) & - !$omp shared(filfac,dustprop,dustgasprop,mmono,smono,grainmassminlog,surfenerg,gammaft) & - !$omp private(grainmasscurlog,grainmassmaxlog,randmass,seed) & - !$omp private(i,iam,rho,filfacmin,stress,strength) - do i=1, npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - iam = iamtype(iphase(i)) - if (iam == idust .or. (iam == igas .and. use_dustfrac)) then - - stress = 25./36. * dustprop(2,i) * filfac(i) * gammaft**2 * dustgasprop(4,i)**2 - strength = 0.6*filfac(i)**(1.8)*surfenerg/smono - seed = int(stress) - - if (stress >= strength) then !-grain is rotationnaly disrupted - !-compute rho to compute filfacmin - if (use_dustfrac .and. iam == igas) then - rho = rhoh(xyzh(4,i),massoftype(igas)) - else - rho = dustgasprop(2,i) + rhoh(xyzh(4,i),massoftype(idust)) - endif - - !-compute current, current/2 and min mass in log10 - grainmasscurlog = log10(dustprop(1,i)) - grainmassmaxlog = log10(dustprop(1,i)/(2.)) - - !--call random number between 2 float values to assign a random mass to dustprop(1) - if (grainmassmaxlog > grainmassminlog) then - randmass = (grainmassmaxlog - grainmassminlog) * ran2(seed) + grainmassminlog - else - if (grainmasscurlog > grainmassminlog) then - randmass = grainmassminlog - else - randmass = grainmasscurlog - endif - endif - - dustprop(1,i) = 10.**randmass - - !-compute filfacmin and compare it to filfac(i) - call get_filfac_min(i,rho,dustprop(1,i)/mmono,dustprop(2,i),dustgasprop(:,i),filfacmin) - filfac(i) = max(filfac(i),filfacmin) - endif + !$omp parallel do default(none) & + !$omp shared(xyzh,npart,massoftype,iphase,use_dustfrac) & + !$omp shared(filfac,dustprop,dustgasprop,mmono,smono,grainmassminlog,surfenerg,gammaft) & + !$omp private(grainmasscurlog,grainmassmaxlog,randmass,seed) & + !$omp private(i,iam,rho,filfacmin,stress,strength) + do i=1, npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + iam = iamtype(iphase(i)) + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then + + stress = 25./36. * dustprop(2,i) * filfac(i) * gammaft**2 * dustgasprop(4,i)**2 + strength = 0.6*filfac(i)**(1.8)*surfenerg/smono + seed = int(stress) + + if (stress >= strength) then !-grain is rotationnaly disrupted + !-compute rho to compute filfacmin + if (use_dustfrac .and. iam == igas) then + rho = rhoh(xyzh(4,i),massoftype(igas)) + else + rho = dustgasprop(2,i) + rhoh(xyzh(4,i),massoftype(idust)) + endif + + !-compute current, current/2 and min mass in log10 + grainmasscurlog = log10(dustprop(1,i)) + grainmassmaxlog = log10(dustprop(1,i)/(2.)) + + !--call random number between 2 float values to assign a random mass to dustprop(1) + if (grainmassmaxlog > grainmassminlog) then + randmass = (grainmassmaxlog - grainmassminlog) * ran2(seed) + grainmassminlog + else + if (grainmasscurlog > grainmassminlog) then + randmass = grainmassminlog + else + randmass = grainmasscurlog + endif + endif + + dustprop(1,i) = 10.**randmass + + !-compute filfacmin and compare it to filfac(i) + call get_filfac_min(i,rho,dustprop(1,i)/mmono,dustprop(2,i),dustgasprop(:,i),filfacmin) + filfac(i) = max(filfac(i),filfacmin) endif - endif - enddo - !$omp end parallel do + endif + endif + enddo + !$omp end parallel do end select end subroutine get_disruption @@ -616,39 +616,39 @@ subroutine get_probastick(npart,xyzh,dmdt,dustprop,dustgasprop,filfac) real :: vrel,vstick,vend,sdust if (ibounce == 1) then - !$omp parallel do default(none) & - !$omp shared(xyzh,npart,iphase,use_dustfrac) & - !$omp shared(filfac,dmdt,dustprop,dustgasprop,probastick,shearparam) & - !$omp private(i,iam,vrel,vstick,vend,sdust) - do i=1, npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - iam = iamtype(iphase(i)) - if ((iam == idust .or. (iam == igas .and. use_dustfrac))) then - if (filfac(i) >= 0.3 .and. dmdt(i) >= 0.) then - vrel = vrelative(dustgasprop(:,i),sqrt(roottwo*Ro*shearparam)*dustgasprop(1,i)) - sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) - vstick = compute_vstick(dustprop(1,i),sdust) - vend = compute_vend(vstick) - - !compute the probability of bounce depending on the velocity - if (vrel >= vstick) then - if (vrel < vend) then - probastick(i) = (log(vrel)-log(vend))/(log(vstick)-log(vend)) - else - probastick(i) = 0. !full bounce -> no growth - endif - else - probastick(i) = 1. - endif - else - probastick(i) = 1. - endif - !compute new growth rate - dmdt(i) = dmdt(i)*probastick(i) + !$omp parallel do default(none) & + !$omp shared(xyzh,npart,iphase,use_dustfrac) & + !$omp shared(filfac,dmdt,dustprop,dustgasprop,probastick,shearparam) & + !$omp private(i,iam,vrel,vstick,vend,sdust) + do i=1, npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + iam = iamtype(iphase(i)) + if ((iam == idust .or. (iam == igas .and. use_dustfrac))) then + if (filfac(i) >= 0.3 .and. dmdt(i) >= 0.) then + vrel = vrelative(dustgasprop(:,i),sqrt(roottwo*Ro*shearparam)*dustgasprop(1,i)) + sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) + vstick = compute_vstick(dustprop(1,i),sdust) + vend = compute_vend(vstick) + + !compute the probability of bounce depending on the velocity + if (vrel >= vstick) then + if (vrel < vend) then + probastick(i) = (log(vrel)-log(vend))/(log(vstick)-log(vend)) + else + probastick(i) = 0. !full bounce -> no growth + endif + else + probastick(i) = 1. + endif + else + probastick(i) = 1. endif - endif - enddo - !$omp end parallel do + !compute new growth rate + dmdt(i) = dmdt(i)*probastick(i) + endif + endif + enddo + !$omp end parallel do endif end subroutine get_probastick @@ -665,13 +665,13 @@ subroutine write_options_porosity(iunit) write(iunit,"(/,a)") '# options controlling porosity (require idrag=1)' call write_inopt(iporosity,'iporosity','porosity (0=off,1=on) ',iunit) if (iporosity == 1 .or. iporosity == -1) then - call write_inopt(icompact, 'icompact', 'Compaction during fragmentation (ifrag > 0) (0=off,1=on)', iunit) - call write_inopt(ibounce, 'ibounce', 'Dust bouncing (0=off,1=on)', iunit) - call write_inopt(idisrupt, 'idisrupt', 'Rotational disruption (0=off,1=on)', iunit) - call write_inopt(smonocgs,'smonocgs','Monomer size in cm (smaller or equal to 1.e-4 cm)',iunit) - call write_inopt(surfenergSI,'surfenergSI','Monomer surface energy in J/m**2',iunit) - call write_inopt(youngmodSI,'youngmodSI','Monomer young modulus in Pa',iunit) - call write_inopt(gammaft,'gammaft','Force to torque efficient of gas flow on dust',iunit) + call write_inopt(icompact, 'icompact', 'Compaction during fragmentation (ifrag > 0) (0=off,1=on)', iunit) + call write_inopt(ibounce, 'ibounce', 'Dust bouncing (0=off,1=on)', iunit) + call write_inopt(idisrupt, 'idisrupt', 'Rotational disruption (0=off,1=on)', iunit) + call write_inopt(smonocgs,'smonocgs','Monomer size in cm (smaller or equal to 1.e-4 cm)',iunit) + call write_inopt(surfenergSI,'surfenergSI','Monomer surface energy in J/m**2',iunit) + call write_inopt(youngmodSI,'youngmodSI','Monomer young modulus in Pa',iunit) + call write_inopt(gammaft,'gammaft','Force to torque efficient of gas flow on dust',iunit) endif end subroutine write_options_porosity @@ -694,32 +694,32 @@ subroutine read_options_porosity(name,valstring,imatch,igotall,ierr) select case(trim(name)) case('iporosity') - read(valstring,*,iostat=ierr) iporosity - ngot = ngot + 1 - if (iporosity == 1 .or. iporosity == -1) use_porosity = .true. + read(valstring,*,iostat=ierr) iporosity + ngot = ngot + 1 + if (iporosity == 1 .or. iporosity == -1) use_porosity = .true. case('icompact') - read(valstring,*,iostat=ierr) icompact - ngot = ngot + 1 + read(valstring,*,iostat=ierr) icompact + ngot = ngot + 1 case('ibounce') - read(valstring,*,iostat=ierr) ibounce - ngot = ngot + 1 + read(valstring,*,iostat=ierr) ibounce + ngot = ngot + 1 case('idisrupt') - read(valstring,*,iostat=ierr) idisrupt - ngot = ngot + 1 + read(valstring,*,iostat=ierr) idisrupt + ngot = ngot + 1 case('smonocgs') - read(valstring,*,iostat=ierr) smonocgs - ngot = ngot + 1 + read(valstring,*,iostat=ierr) smonocgs + ngot = ngot + 1 case('surfenergSI') - read(valstring,*,iostat=ierr) surfenergSI - ngot = ngot + 1 + read(valstring,*,iostat=ierr) surfenergSI + ngot = ngot + 1 case('youngmodSI') - read(valstring,*,iostat=ierr) youngmodSI - ngot = ngot + 1 + read(valstring,*,iostat=ierr) youngmodSI + ngot = ngot + 1 case('gammaft') - read(valstring,*,iostat=ierr) gammaft - ngot = ngot + 1 + read(valstring,*,iostat=ierr) gammaft + ngot = ngot + 1 case default - imatch = .false. + imatch = .false. end select if ((iporosity == 0) .and. ngot == 1) igotall = .true. @@ -765,9 +765,9 @@ real function get_coeffrest(vstickvrel,vyieldvrel) real, intent(in) :: vstickvrel,vyieldvrel if (vyieldvrel >= 1.) then - get_coeffrest = sqrt(1.-vstickvrel*vstickvrel) + get_coeffrest = sqrt(1.-vstickvrel*vstickvrel) else - get_coeffrest = sqrt(1.2*sqrt(3.)*(1.-(vyieldvrel*vyieldvrel/6.))*& + get_coeffrest = sqrt(1.2*sqrt(3.)*(1.-(vyieldvrel*vyieldvrel/6.))*& sqrt(1./(1.+2.*sqrt((1.2/(vyieldvrel*vyieldvrel))-0.2)))-(vstickvrel*vstickvrel)) endif @@ -776,19 +776,19 @@ end function get_coeffrest !--velocity limit between full sticking regime and partial sticking + bouncing regime real function compute_vstick(mass,size) real, intent(in) ::mass,size - compute_vstick = 8.76*((surfenerg**5 * size**4)/(mass**3*youngmod**2))**(1./6.) + compute_vstick = 8.76*((surfenerg**5 * size**4)/(mass**3*youngmod**2))**(1./6.) end function !--velocity limit between elastic and inelastic bouncing regime real function compute_vyield(vstick) real, intent(in) ::vstick - compute_vyield = 10.*vstick + compute_vyield = 10.*vstick end function !--velocity limit between partial sticking + bouncing regime and full bouncing regime real function compute_vend(vstick) real, intent(in) ::vstick - compute_vend = 24343220.*vstick + compute_vend = 24343220.*vstick end function end module porosity diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index fb23aefd6..a211f5dd9 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -590,7 +590,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call get_filfac(npart,xyzh,mprev,filfac,dustprop,dtsph) endif call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) - endif + endif if (gr) then call check_velocity_error(errmax,p2mean,np,its,tolv,dtsph,timei,idamp,dterr,errmaxmean,converged) diff --git a/src/utils/moddump_dustadd.f90 b/src/utils/moddump_dustadd.f90 index 53993105f..588a74707 100644 --- a/src/utils/moddump_dustadd.f90 +++ b/src/utils/moddump_dustadd.f90 @@ -130,7 +130,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call prompt('Enter H/R at R_ref',H_R_ref,0.) call prompt('Enter q index',q_index) else - call prompt('Enter initial grain size in cm',grainsizecgs,0.) + call prompt('Enter initial grain size in cm',grainsizecgs,0.) endif else call prompt('Enter grain size in cm',grainsizecgs,0.) @@ -192,7 +192,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) enddo endif if (use_dustgrowth) then - call set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_index) + call set_dustprop(npart,xyzh,sizedistrib,pwl_sizedistrib,R_ref,H_R_ref,q_index) endif endif !Delete particles if necessary diff --git a/src/utils/struct_part.f90 b/src/utils/struct_part.f90 index 99640148d..781a3c2fd 100644 --- a/src/utils/struct_part.f90 +++ b/src/utils/struct_part.f90 @@ -149,10 +149,10 @@ subroutine get_structure_fn(sf,nbins,norder,distmin,distmax,xbins,ncount,npart,x !$omp reduction(+:sf) do ipt=1,npts !$ if (.false.) then - if (mod(ipt,100)==0) then - call cpu_time(tcpu2) - print*,' ipt = ',ipt,tcpu2-tcpu1 - endif + if (mod(ipt,100)==0) then + call cpu_time(tcpu2) + print*,' ipt = ',ipt,tcpu2-tcpu1 + endif !$ endif i = list(ipt) xpt(1) = xyz(1,i) From d7ae79829e8a80f8b20dc2deb885b0239c931408 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 08:46:37 +1000 Subject: [PATCH 358/814] (porosity) fix build failures, small cleanups --- src/main/deriv.F90 | 7 +------ src/main/initial.F90 | 4 ++-- src/main/porosity.f90 | 30 +++++++++++++++++++----------- 3 files changed, 22 insertions(+), 19 deletions(-) diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index eded71823..773741675 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -55,8 +55,6 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& use photoevap, only:find_ionfront,photo_ionize use part, only:massoftype #endif - use dust_formation, only:calc_kappa_bowen,idust_opacity - use part, only:ikappa,tau,nucleation use raytracer use growth, only:get_growth_rate use porosity, only:get_disruption,get_probastick @@ -130,13 +128,10 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& call do_timing('link',tlast,tcpulast,start=.true.) - -#ifdef DUSTGROWTH ! ! compute disruption of dust particles ! - if (use_porosity) call get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) -#endif + if (use_dustgrowth .and. use_porosity) call get_disruption(npart,xyzh,filfac,dustprop,dustgasprop) ! ! calculate density by direct summation ! diff --git a/src/main/initial.F90 b/src/main/initial.F90 index cc9739cf7..314b72644 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -314,7 +314,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) ! !--get total number of particles (on all processors) ! - ntot = reduceall_mpi('+',npart) + ntot = reduceall_mpi('+',npart) call update_npartoftypetot if (id==master) write(iprint,"(a,i12)") ' npart total = ',ntot if (npart > 0) then @@ -608,7 +608,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) 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,dustfrac,eos_vars,time,0.,dtnew_first,pxyzu,dens,metrics) + ddustevol,filfac,dustfrac,eos_vars,time,0.,dtnew_first,pxyzu,dens,metrics) if (do_radiation) call set_radiation_and_gas_temperature_equal(npart,xyzh,vxyzu,massoftype,rad) #endif diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index de7886276..2477bec8a 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -6,9 +6,14 @@ !--------------------------------------------------------------------------! module porosity ! -! Contains routine for porosity evolution (growth, bouncing, fragmentation, compaction, disruption) +! Contains routine for porosity evolution (growth, bouncing, +! fragmentation, compaction, disruption) ! -! :References: None +! :References: +! Okuzumi et al. (1997), ApJ 752, 106 +! Garcia, Gonzalez (2020), MNRAS 493, 1788 +! Tatsuuma et Kataoka (2021), ApJ 913, 132 +! Michoulier & Gonzalez (2022), MNRAS 517, 3064 ! ! :Owner: Stephane Michoulier ! @@ -39,23 +44,26 @@ module porosity real, public :: surfenergSI = 0.20 !--surface energy of monomers in SI: J/m**2 (here for Si: Kimura et al. 2020) real, public :: youngmodSI = 72e9 !--young modulus of monomers in SI: Pa (here for Si: Yamamoto et al. 2014) real, public :: gammaft = 0.1 !--force-to-torque efficiency (Tatsuuma et al. 2021) - real, private :: cratio = -0.5801454844 !--common ratio for a power - real, private :: b_oku = 0.15 !--parameter b (Okuzumi et al. 2012) - real, private :: maxpacking = 0.74048 !--max sphere packing for hexagonal close packing + + real, parameter :: cratio = -0.5801454844 !--common ratio for a power + real, parameter :: b_oku = 0.15 !--parameter b (Okuzumi et al. 2012) + real, parameter :: maxpacking = 0.74048 !--max sphere packing for hexagonal close packing real, public :: smono !--monomer size real, public :: mmono !--monomer mass real, public :: surfenerg real, public :: youngmod - real, private :: eroll !--rolling - real, private :: grainmassminlog - real, private :: Yd0 !test for compaction - real, private :: Ydpow !test for compaction + real :: eroll !--rolling + real :: grainmassminlog + real :: Yd0 !test for compaction + real :: Ydpow !test for compaction - public :: get_filfac,init_filfac,get_disruption + public :: get_filfac,init_filfac,get_disruption,get_probastick public :: init_porosity,print_porosity_info,write_options_porosity,read_options_porosity public :: write_porosity_setup_options,read_porosity_setup_options + private + contains !------------------------------------------------ @@ -262,7 +270,7 @@ subroutine get_filfac(npart,xyzh,mprev,filfac,dustprop,dt) case (1) !$omp parallel do default(none) & !$omp shared(xyzh,npart,iphase,massoftype,use_dustfrac,dustfrac,icompact) & - !$omp shared(mprev,filfac,dustprop,dustgasprop,VrelVf,probastick,mmono,maxpacking,dt,ibounce) & + !$omp shared(mprev,filfac,dustprop,dustgasprop,VrelVf,probastick,mmono,dt,ibounce) & !$omp private(i,iam,rho,rhod,filfacevol,filfacmin,filfacmax) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then From 540cdde932baa1b7f105a6f69a07766b6fde0c88 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 09:23:10 +1000 Subject: [PATCH 359/814] (porosity) fix bug with DEBUG=yes in dustybox test; return s=0 in get_size if dens=0 or filfac=0 --- src/main/growth.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/main/growth.F90 b/src/main/growth.F90 index fe45aa990..ca74020ee 100644 --- a/src/main/growth.F90 +++ b/src/main/growth.F90 @@ -1042,7 +1042,11 @@ real function get_size(mass,dens,filfac) f = 1.0 endif - get_size = ( 3.*mass / (fourpi*dens*f) )**(1./3.) + if (dens > 0. .and. f > 0.) then + get_size = ( 3.*mass / (fourpi*dens*f) )**(1./3.) + else + get_size = 0. + endif end function get_size From b6336f97ff1e9f9236fe5215f26bec0b18843807 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 09:28:41 +1000 Subject: [PATCH 360/814] (#55) .F90->.f90 for dust subroutines with no ifdefs --- build/Makefile | 8 ++------ src/main/{growth.F90 => growth.f90} | 0 src/tests/{test_dust.F90 => test_dust.f90} | 0 3 files changed, 2 insertions(+), 6 deletions(-) rename src/main/{growth.F90 => growth.f90} (100%) rename src/tests/{test_dust.F90 => test_dust.f90} (100%) diff --git a/build/Makefile b/build/Makefile index e976cdaf5..019f125a1 100644 --- a/build/Makefile +++ b/build/Makefile @@ -96,7 +96,7 @@ ifndef SRCNIMHD endif ifndef SRCDUST - SRCDUST = dust.F90 growth.F90 porosity.f90 + SRCDUST = dust.f90 growth.f90 porosity.f90 endif ifdef SMOL @@ -111,10 +111,6 @@ else SRCINJECT=utils_binary.f90 set_binary.f90 inject_wind.f90 endif -#ifndef SRCGROWTH -# SRCGROWTH = growth.F90 -#endif - #--- live feedback from mcfost ifeq ($(MCFOST), yes) ANALYSIS= analysis_mcfost.f90 @@ -685,7 +681,7 @@ else endif SRCTESTS=utils_testsuite.f90 ${TEST_FASTMATH} test_kernel.f90 \ - test_dust.F90 test_growth.f90 test_smol.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/src/main/growth.F90 b/src/main/growth.f90 similarity index 100% rename from src/main/growth.F90 rename to src/main/growth.f90 diff --git a/src/tests/test_dust.F90 b/src/tests/test_dust.f90 similarity index 100% rename from src/tests/test_dust.F90 rename to src/tests/test_dust.f90 From 28bfcf3e645d77c7c842f6ee44b80b14adc92ff2 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 09:48:33 +1000 Subject: [PATCH 361/814] (#55) .F90->.f90 for modules where ifdefs have been successfully removed --- build/Makefile | 2 +- build/Makefile_setups | 16 ++++++++-------- src/main/{checksetup.F90 => checksetup.f90} | 0 src/setup/{setup_shock.F90 => setup_shock.f90} | 0 ...testparticles.F90 => setup_testparticles.f90} | 0 .../{interpolate3D.F90 => interpolate3D.f90} | 16 ++++++++-------- 6 files changed, 17 insertions(+), 17 deletions(-) rename src/main/{checksetup.F90 => checksetup.f90} (100%) rename src/setup/{setup_shock.F90 => setup_shock.f90} (100%) rename src/setup/{setup_testparticles.F90 => setup_testparticles.f90} (100%) rename src/utils/{interpolate3D.F90 => interpolate3D.f90} (98%) diff --git a/build/Makefile b/build/Makefile index 019f125a1..a780e1c0d 100644 --- a/build/Makefile +++ b/build/Makefile @@ -539,7 +539,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.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 + checksetup.f90 initial.F90 # Needed as einsteintk_wrapper depends on initial ifeq ($(GR),yes) diff --git a/build/Makefile_setups b/build/Makefile_setups index ae562595d..85ccc0e0e 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -420,7 +420,7 @@ endif ifeq ($(SETUP), shock) # shock tube tests PERIODIC=yes - SETUPFILE= setup_shock.F90 + SETUPFILE= setup_shock.f90 KERNEL=quintic KNOWN_SETUP=yes endif @@ -428,7 +428,7 @@ endif ifeq ($(SETUP), dustyshock) # shock tube tests with dust PERIODIC=yes - SETUPFILE= setup_shock.F90 + SETUPFILE= setup_shock.f90 DUST=yes KERNEL=quintic KNOWN_SETUP=yes @@ -437,7 +437,7 @@ endif ifeq ($(SETUP), mhdshock) # Ryu & Brio-Wu shock tube tests PERIODIC=yes - SETUPFILE= setup_shock.F90 + SETUPFILE= setup_shock.f90 MHD=yes KERNEL=quintic KNOWN_SETUP=yes @@ -446,7 +446,7 @@ endif ifeq ($(SETUP), nimhdshock) # non-ideal mhd standing and C shock tests PERIODIC=yes - SETUPFILE= setup_shock.F90 + SETUPFILE= setup_shock.f90 MHD=yes STS_TIMESTEPS=no NONIDEALMHD=yes @@ -460,7 +460,7 @@ ifeq ($(SETUP), radshock) # shock tube in radiation hydrodynamics PERIODIC=yes RADIATION=yes - SETUPFILE= setup_shock.F90 + SETUPFILE= setup_shock.f90 KERNEL=quintic KNOWN_SETUP=yes endif @@ -468,7 +468,7 @@ endif ifeq ($(SETUP), srshock) # special relativistic sod shock tube test PERIODIC=yes - SETUPFILE= setup_shock.F90 + SETUPFILE= setup_shock.f90 KERNEL=quintic GR=yes METRIC=minkowski @@ -479,7 +479,7 @@ endif ifeq ($(SETUP), testparticles) # test particles - SETUPFILE= setup_testparticles.F90 + SETUPFILE= setup_testparticles.f90 KNOWN_SETUP=yes MAXP=500000 ANALYSIS= analysis_1particle.f90 @@ -1037,7 +1037,7 @@ ifeq ($(SETUP), testgr) endif ifeq ($(SETUP), flrw) -# constant density FLRW cosmology with perturbations +# constant density FLRW cosmology with perturbations GR=yes KNOWN_SETUP=yes IND_TIMESTEPS=no diff --git a/src/main/checksetup.F90 b/src/main/checksetup.f90 similarity index 100% rename from src/main/checksetup.F90 rename to src/main/checksetup.f90 diff --git a/src/setup/setup_shock.F90 b/src/setup/setup_shock.f90 similarity index 100% rename from src/setup/setup_shock.F90 rename to src/setup/setup_shock.f90 diff --git a/src/setup/setup_testparticles.F90 b/src/setup/setup_testparticles.f90 similarity index 100% rename from src/setup/setup_testparticles.F90 rename to src/setup/setup_testparticles.f90 diff --git a/src/utils/interpolate3D.F90 b/src/utils/interpolate3D.f90 similarity index 98% rename from src/utils/interpolate3D.F90 rename to src/utils/interpolate3D.f90 index 1a6d0d75e..95fe2d7d6 100644 --- a/src/utils/interpolate3D.F90 +++ b/src/utils/interpolate3D.f90 @@ -17,7 +17,7 @@ module interpolations3D ! :Dependencies: einsteintk_utils, kernel ! use einsteintk_utils, only:exact_rendering - use kernel, only:radkern2,radkern,cnormk,wkern + use kernel, only:radkern2,radkern,cnormk,wkern implicit none integer, parameter :: doub_prec = kind(0.d0) real :: cnormk3D = cnormk @@ -990,12 +990,12 @@ pure elemental real function soft_func(x,eps) result(f) end function soft_func - !-------------------------------------------------------------------------- - ! - ! utility to wrap pixel index around periodic domain - ! indices that roll beyond the last position are re-introduced at the first - ! - !-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- +! +! utility to wrap pixel index around periodic domain +! indices that roll beyond the last position are re-introduced at the first +! +!-------------------------------------------------------------------------- pure integer function iroll(i,n) integer, intent(in) :: i,n @@ -1008,5 +1008,5 @@ pure integer function iroll(i,n) endif end function iroll -end module interpolations3D +end module interpolations3D From b5d18c7c0c25c986baa9278fdffdb12bba89fd5b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 09:52:55 +1000 Subject: [PATCH 362/814] (gr) cleanup extern_gr --- src/main/extern_gr.F90 | 212 ++++++++++++++++------------------------- 1 file changed, 81 insertions(+), 131 deletions(-) diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.F90 index 8696ffd10..3d3aacdb2 100644 --- a/src/main/extern_gr.F90 +++ b/src/main/extern_gr.F90 @@ -6,9 +6,12 @@ !--------------------------------------------------------------------------! module extern_gr ! -! None +! Compute terms related to derivatives of the metric which appear +! on the right hand side of the momentum equation ! -! :References: None +! :References: +! Liptai & Price (2019), MNRAS 485, 819 +! Magnall, Price, Lasky & Macpherson (2023), Phys. Rev D. 108, 103534 ! ! :Owner: Spencer Magnall ! @@ -49,6 +52,12 @@ subroutine get_grforce(xyzhi,metrici,metricderivsi,veli,densi,ui,pi,fexti,dtf) end subroutine get_grforce +!--------------------------------------------------------------- +!+ +! Wrapper of the above, computing accelerations due to metric +! gradients on all particles +!+ +!--------------------------------------------------------------- subroutine get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtexternal) use timestep, only:C_force use eos, only:ieos,get_pressure @@ -77,8 +86,12 @@ subroutine get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtext end subroutine get_grforce_all -!--- Subroutine to calculate the timestep constraint from the 'external force' -! this is multiplied by the safety factor C_force elsewhere +!--------------------------------------------------------------------------- +!+ +! Subroutine to calculate the timestep constraint from the 'external force' +! this is multiplied by the safety factor C_force elsewhere +!+ +!--------------------------------------------------------------------------- subroutine dt_grforce(xyzh,fext,dtf) use physcon, only:pi use metric_tools, only:imetric,imet_schwarzschild,imet_kerr @@ -107,7 +120,6 @@ subroutine dt_grforce(xyzh,fext,dtf) end subroutine dt_grforce - !---------------------------------------------------------------- !+ ! Compute the source terms required on the right hand side of @@ -139,20 +151,19 @@ pure subroutine forcegr(x,metrici,metricderivsi,v,dens,u,p,fterm,ierr) ! energy-momentum tensor times sqrtg on 2rho* do i=0,3 - term(0:3,i) = 0.5*(enth*uzero*v4(0:3)*v4(i) + P*gcon(0:3,i)/(dens*uzero)) + term(0:3,i) = 0.5*(enth*uzero*v4(0:3)*v4(i) + P*gcon(0:3,i)/(dens*uzero)) enddo ! source term fterm = 0. do i=0,3 - fterm(1) = fterm(1) + dot_product(term(:,i),metricderivsi(:,i,1)) - fterm(2) = fterm(2) + dot_product(term(:,i),metricderivsi(:,i,2)) - fterm(3) = fterm(3) + dot_product(term(:,i),metricderivsi(:,i,3)) + fterm(1) = fterm(1) + dot_product(term(:,i),metricderivsi(:,i,1)) + fterm(2) = fterm(2) + dot_product(term(:,i),metricderivsi(:,i,2)) + fterm(3) = fterm(3) + dot_product(term(:,i),metricderivsi(:,i,3)) enddo end subroutine forcegr - !-------- I don't think this is actually being used at the moment.... subroutine update_grforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,densi,ui,pi) use io, only:fatal @@ -220,82 +231,45 @@ subroutine update_grforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi, end subroutine update_grforce_leapfrog +!---------------------------------------------------------------- +!+ +! compute stress energy tensor on all particles +!+ +!---------------------------------------------------------------- subroutine get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - use eos, only:ieos,get_pressure - use part, only:isdead_or_accreted + use eos, only:ieos,get_pressure + use part, only:isdead_or_accreted integer, intent(in) :: npart real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) real :: pi integer :: i - logical :: verbose - verbose = .false. - ! TODO write openmp parallel code !$omp parallel do default(none) & !$omp shared(npart,xyzh,metrics,vxyzu,dens,ieos,tmunus) & - !$omp private(i,pi,verbose) - do i=1, npart - !print*, "i: ", i - if (i==1) then - verbose = .true. - else - verbose = .false. - endif + !$omp private(i,pi) + do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) - call get_tmunu(xyzh(:,i),metrics(:,:,:,i),& - vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i),verbose) + call get_tmunu(xyzh(:,i),metrics(:,:,:,i),vxyzu(1:3,i),& + dens(i),vxyzu(4,i),pi,tmunus(:,:,i)) endif enddo !$omp end parallel do - !print*, "tmunu calc val is: ", tmunus(0,0,5) -end subroutine get_tmunu_all - -subroutine get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - use eos, only:ieos,get_pressure - use part, only:isdead_or_accreted - integer, intent(in) :: npart - real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) - real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) - real :: pi - integer :: i - logical :: firstpart - real :: tmunu(4,4) - !print*, "entered get tmunu_all_exact" - tmunu = 0. - firstpart = .true. - ! TODO write openmp parallel code - do i=1, npart - if (.not.isdead_or_accreted(xyzh(4,i)) .and. firstpart) then - pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) - call get_tmunu_exact(xyzh(:,i),metrics(:,:,:,i), metricderivs(:,:,:,i), & - vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i)) - !print*, "finished get_tmunu call!" - firstpart = .false. - !print*, "tmunu: ", tmunu - !print*, "tmunus: ", tmunus(:,:,i) - tmunu(:,:) = tmunus(:,:,i) - !print*, "Got tmunu val: ", tmunu - !stop - else - !print*, "setting tmunu for part: ", i - tmunus(:,:,i) = tmunu(:,:) - endif - - enddo - !print*, "tmunu calc val is: ", tmunus(0,0,5) -end subroutine get_tmunu_all_exact +end subroutine get_tmunu_all -! Subroutine to calculate the covariant form of the stress energy tensor -! For a particle at position p -subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) - use metric_tools, only:unpack_metric +!------------------------------------------------------------------------- +!+ +! calculate the covariant form of the stress energy tensor +! for a particle at position x +!+ +!------------------------------------------------------------------------- +subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu) + use metric_tools, only:unpack_metric use utils_gr, only:get_u0 real, intent(in) :: x(3),metrici(:,:,:),v(3),dens,u,p real, intent(out) :: tmunu(0:3,0:3) - logical, optional, intent(in) :: verbose real :: w,v4(0:3),uzero,u_upper(0:3),u_lower(0:3) real :: gcov(0:3,0:3), gcon(0:3,0:3) real :: gammaijdown(1:3,1:3),betadown(3),alpha @@ -318,42 +292,7 @@ subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) ! Get cov and con versions of the metric + spatial metric and lapse and shift ! Not entirely convinced that the lapse and shift calculations are acccurate for the general case!! - !print*, "Before unpack metric " call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) - !print*, "After unpack metric" - -! if (present(verbose) .and. verbose) then -! ! Do we get sensible values -! print*, "Unpacked metric quantities..." -! print*, "gcov: ", gcov -! print*, "gcon: ", gcon -! print*, "gammaijdown: ", gammaijdown -! print* , "alpha: ", alpha -! print*, "betadown: ", betadown -! print*, "v4: ", v4 -! endif - - ! ! Need to change Betadown to betaup - ! ! Won't matter at this point as it is allways zero - ! ! get big V - ! bigV(:) = (v(:) + betadown)/alpha - - ! ! We need the covariant version of the 3 velocity - ! ! gamma_ij v^j = v_i where gamma_ij is the spatial metric - ! do i=1, 3 - ! vcov(i) = gammaijdown(i,1)*bigv(1) + gammaijdown(i,2)*bigv(2) + gammaijdown(i,3)*bigv(3) - ! enddo - - - ! ! Calculate the lorentz factor - ! lorentz = (1. - (vcov(1)*bigv(1) + vcov(2)*bigv(2) + vcov(3)*bigv(3)))**(-0.5) - - ! ! Calculate the 4-velocity - ! velshiftterm = vcov(1)*betadown(1) + vcov(2)*betadown(2) + vcov(3)*betadown(3) - ! v4(0) = lorentz*(-alpha + velshiftterm) - ! ! This should be vcov not v - ! v4(1:3) = lorentz*vcov(1:3) - ! We are going to use the same Tmunu calc as force GR ! And then lower it using the metric @@ -363,7 +302,6 @@ subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) v4(0) = 1. v4(1:3) = v(:) - ! first component of the upper-case 4-velocity (contravariant) call get_u0(gcov,v,uzero,ierr) @@ -380,34 +318,14 @@ subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu,verbose) enddo enddo - -! if (present(verbose) .and. verbose) then -! ! Do we get sensible values -! print*, "Unpacked metric quantities..." -! print*, "gcov: ", gcov -! print*, "gcon: ", gcon -! print*, "gammaijdown: ", gammaijdown -! print* , "alpha: ", alpha -! print*, "betadown: ", betadown -! print*, "v4: ", v4 -! endif - -! if (verbose) then -! print*, "tmunu part: ", tmunu -! print*, "dens: ", dens -! print*, "w: ", w -! print*, "p: ", p -! print*, "gcov: ", gcov -! endif - - ! print*, "tmunu part: ", tmunu - ! print*, "dens: ", dens - ! print*, "w: ", w - ! print*, "p: ", p - ! print*, "gcov: ", gcov - ! stop end subroutine get_tmunu +!------------------------------------------------------------------------- +!+ +! the following two routines are for testing purposes +! and could be deleted at some stage (as used in Magnall et al. 2023) +!+ +!------------------------------------------------------------------------- subroutine get_tmunu_exact(x,metrici,metricderivsi,v,dens,u,p,tmunu) use metric_tools, only:unpack_metric use utils_gr, only:get_sqrtg @@ -443,10 +361,10 @@ subroutine get_tmunu_exact(x,metrici,metricderivsi,v,dens,u,p,tmunu) rhostar = 13.294563008157013D0 call get_sqrtg(gcov,negsqrtg) + ! Set/Calculate primitive density using rhostar exactly rhoprim = rhostar/(negsqrtg/alpha) - ! Stress energy tensor do j=0,3 do i=0,3 @@ -454,8 +372,40 @@ subroutine get_tmunu_exact(x,metrici,metricderivsi,v,dens,u,p,tmunu) enddo enddo +end subroutine get_tmunu_exact +!------------------------------------------------------------------------- +!+ +! see above: for testing purposes and could be deleted at some stage +! (as used in Magnall et al. 2023) +!+ +!------------------------------------------------------------------------- +subroutine get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + use eos, only:ieos,get_pressure + use part, only:isdead_or_accreted + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) + real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) + real :: pi + integer :: i + logical :: firstpart + real :: tmunu(4,4) -end subroutine get_tmunu_exact + tmunu = 0. + firstpart = .true. + ! TODO write openmp parallel code + do i=1, npart + if (.not.isdead_or_accreted(xyzh(4,i)) .and. firstpart) then + pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) + call get_tmunu_exact(xyzh(:,i),metrics(:,:,:,i), metricderivs(:,:,:,i), & + vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i)) + firstpart = .false. + tmunu(:,:) = tmunus(:,:,i) + else + tmunus(:,:,i) = tmunu(:,:) + endif + enddo + +end subroutine get_tmunu_all_exact end module extern_gr From bc0f0072fd12f89e8a4d5d1e0cef7fc3032e9e20 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 10:02:19 +1000 Subject: [PATCH 363/814] (#55) more .F90->.f90 and minor cleanups --- build/Makefile | 10 +++++----- src/main/{extern_gr.F90 => extern_gr.f90} | 0 src/main/{interp_metric.F90 => interp_metric.f90} | 9 ++++++--- src/main/{lumin_nsdisc.F90 => lumin_nsdisc.f90} | 0 src/main/{memory.F90 => memory.f90} | 2 +- ...ite_dumps_common.F90 => readwrite_dumps_common.f90} | 0 6 files changed, 12 insertions(+), 9 deletions(-) rename src/main/{extern_gr.F90 => extern_gr.f90} (100%) rename src/main/{interp_metric.F90 => interp_metric.f90} (91%) rename src/main/{lumin_nsdisc.F90 => lumin_nsdisc.f90} (100%) rename src/main/{memory.F90 => memory.f90} (99%) rename src/main/{readwrite_dumps_common.F90 => readwrite_dumps_common.f90} (100%) diff --git a/build/Makefile b/build/Makefile index a780e1c0d..7e77b79ec 100644 --- a/build/Makefile +++ b/build/Makefile @@ -465,7 +465,7 @@ SRCPOTS= extern_gr.F90 \ extern_spiral.f90 \ extern_lensethirring.f90 \ extern_gnewton.f90 \ - lumin_nsdisc.F90 extern_prdrag.f90 \ + lumin_nsdisc.f90 extern_prdrag.f90 \ extern_Bfield.f90 \ extern_densprofile.f90 \ extern_staticsine.f90 \ @@ -508,9 +508,9 @@ 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.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 + 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 - SRCREADWRITE_DUMPS= readwrite_dumps_common.F90 readwrite_dumps_fortran.F90 readwrite_dumps.F90 + SRCREADWRITE_DUMPS= readwrite_dumps_common.f90 readwrite_dumps_fortran.F90 readwrite_dumps.F90 endif ifeq ($(KROME), krome) @@ -534,7 +534,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ partinject.F90 utils_inject.f90 dust_formation.f90 ptmass_radiation.f90 ptmass_heating.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ - ${SRCKROME} memory.F90 ${SRCREADWRITE_DUMPS} \ + ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} \ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ @@ -616,7 +616,7 @@ SRCDUMP= physcon.f90 ${CONFIG} ${SRCKERNEL} utils_omp.F90 io.F90 units.f90 \ centreofmass.f90 \ timestep.f90 ${SRCEOS} cullendehnen.f90 dust_formation.f90 \ ${SRCGR} ${SRCPOT} \ - memory.F90 \ + memory.f90 \ utils_sphNG.f90 \ setup_params.f90 ${SRCFASTMATH} checkoptions.F90 \ viscosity.f90 damping.f90 options.f90 checkconserved.f90 prompting.f90 ${SRCDUST} \ diff --git a/src/main/extern_gr.F90 b/src/main/extern_gr.f90 similarity index 100% rename from src/main/extern_gr.F90 rename to src/main/extern_gr.f90 diff --git a/src/main/interp_metric.F90 b/src/main/interp_metric.f90 similarity index 91% rename from src/main/interp_metric.F90 rename to src/main/interp_metric.f90 index 362eb129f..a6037037d 100644 --- a/src/main/interp_metric.F90 +++ b/src/main/interp_metric.f90 @@ -6,9 +6,10 @@ !--------------------------------------------------------------------------! module metric_interp ! -! metric_interp +! Interpolate a tabulated metric onto the particle positions ! -! :References: None +! :References: +! Magnall, Price, Lasky & Macpherson (2023), Phys. Rev D. 108, 103534 ! ! :Owner: Spencer Magnall ! @@ -16,13 +17,16 @@ module metric_interp ! ! :Dependencies: einsteintk_utils ! + implicit none interface trilinear_interp module procedure interp_g, interp_sqrtg, interp_gderiv end interface trilinear_interp + contains subroutine interp_g() + end subroutine interp_g subroutine interp_sqrtg() @@ -54,7 +58,6 @@ pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) ylower = ylower + 1 zlower = zlower + 1 - end subroutine get_grid_neighbours end module metric_interp diff --git a/src/main/lumin_nsdisc.F90 b/src/main/lumin_nsdisc.f90 similarity index 100% rename from src/main/lumin_nsdisc.F90 rename to src/main/lumin_nsdisc.f90 diff --git a/src/main/memory.F90 b/src/main/memory.f90 similarity index 99% rename from src/main/memory.F90 rename to src/main/memory.f90 index 5275c132a..b20dae9f4 100644 --- a/src/main/memory.F90 +++ b/src/main/memory.f90 @@ -6,7 +6,7 @@ !--------------------------------------------------------------------------! module memory ! -! None +! Wrapper routines for memory allocation ! ! :References: None ! diff --git a/src/main/readwrite_dumps_common.F90 b/src/main/readwrite_dumps_common.f90 similarity index 100% rename from src/main/readwrite_dumps_common.F90 rename to src/main/readwrite_dumps_common.f90 From d78d5211efca74e8786af1a27963c53d0d29139b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 12:56:07 +1000 Subject: [PATCH 364/814] (porosity) build/test failures fixed --- src/setup/setup_disc.f90 | 2 +- src/tests/test_dust.f90 | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 65b5895ef..590f8a2b4 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -111,7 +111,7 @@ module setup iJ2,ispinx,ispinz,iReff,igas,& idust,iphase,dustprop,dustfrac,ndusttypes,ndustsmall,& ndustlarge,grainsize,graindens,nptmass,iamtype,dustgasprop,& - VrelVf,,filfac,probastick,rad,radprop,ikappa,iradxi + VrelVf,filfac,probastick,rad,radprop,ikappa,iradxi use physcon, only:au,solarm,jupiterm,earthm,pi,twopi,years,hours,deg_to_rad use setdisc, only:scaled_sigma,get_disc_mass,maxbins use set_dust_options, only:set_dust_default_options,dust_method,dust_to_gas,& diff --git a/src/tests/test_dust.f90 b/src/tests/test_dust.f90 index 427f239e6..a969958ba 100644 --- a/src/tests/test_dust.f90 +++ b/src/tests/test_dust.f90 @@ -45,7 +45,7 @@ subroutine test_dust(ntests,npass) use physcon, only:solarm,au use units, only:set_units,unit_density,udist use eos, only:gamma - use dim, only:use_dust + use dim, only:use_dust,use_dustgrowth use mpiutils, only:barrier_mpi use options, only:use_dustfrac use table_utils, only:logspace @@ -71,10 +71,10 @@ subroutine test_dust(ntests,npass) call init_drag(ierr) call checkval(ierr,0,0,nfailed(idrag),'drag initialisation') enddo -#ifdef DUSTGROWTH - call init_growth(ierr) - call checkval(ierr,0,0,nfailed(3),'growth initialisation') -#endif + if (use_dustgrowth) then + call init_growth(ierr) + call checkval(ierr,0,0,nfailed(3),'growth initialisation') + endif call update_test_scores(ntests,nfailed,npass) idrag = 1 From 8c3717c21feec7f0ff72caa33f94221cc7561cfa Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 13:02:15 +1000 Subject: [PATCH 365/814] (porosity) build failure with variable precision arithmetic fixed --- src/main/porosity.f90 | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 2477bec8a..547584f34 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -330,10 +330,11 @@ subroutine get_filfac_growth(mprev,mass,filfac,dustgasprop,filfacgrowth) real, intent(in) :: mprev,mass,filfac real, intent(in) :: dustgasprop(:) real, intent(out) :: filfacgrowth - real :: ekincdt,vrel + real :: ekincdt,vrel,vt real :: j ! Power of the filling factor dependency in mass - vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + vt = sqrt(roottwo*Ro*shearparam)*dustgasprop(1) + vrel = vrelative(dustgasprop,vt) !- kinetic energy condition Ekin/(3*b_oku/eroll) ekincdt = mprev*vrel*vrel/(12.*b_oku*eroll) @@ -364,10 +365,11 @@ subroutine get_filfac_bounce(mprev,graindens,filfac,dustgasprop,probastick,rhod, real, intent(inout) :: filfacevol real :: sdust,vrel,ncoll,vol,deltavol real :: ekin,pdyn,coeffrest,filfacbnc - real :: vstick,vyield,vend + real :: vstick,vyield,vend,vt if (probastick < 1.) then - vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + vt = sqrt(roottwo*Ro*shearparam)*dustgasprop(1) + vrel = vrelative(dustgasprop,vt) sdust = get_size(mprev,graindens,filfac) vstick = compute_vstick(mprev,sdust) !-compute vstick, i.e. max velocity before bouncing appears @@ -415,14 +417,15 @@ subroutine get_filfac_frag(mprev,dustprop,filfac,dustgasprop,rhod,VrelVf,dt,filf real, intent(in) :: dustprop(:),dustgasprop(:) real, intent(out) :: filfacfrag real :: sdust,vrel,ncoll,vol,deltavol!,compfactor - real :: ekin,pdyn + real :: ekin,pdyn,vt select case (icompact) case (1) ! model Garcia + Kataoka mod sdust = get_size(mprev,dustprop(2),filfac) vol = fourpi/3. * sdust**3 - vrel = vrelative(dustgasprop,sqrt(roottwo*Ro*shearparam)*dustgasprop(1)) + vt = sqrt(roottwo*Ro*shearparam)*dustgasprop(1) + vrel = vrelative(dustgasprop,vt) ncoll = fourpi*sdust**2*rhod*vrel*dt/mprev !number of collisions in dt ekin = mprev*vrel*vrel/4. - (2.*mprev - dustprop(1))*0.85697283*eroll/mmono !0.856973 = 3* 1.8 * 48/302.46 @@ -621,19 +624,20 @@ subroutine get_probastick(npart,xyzh,dmdt,dustprop,dustgasprop,filfac) real, intent(in) :: xyzh(:,:),dustprop(:,:),dustgasprop(:,:) real, intent(inout) :: dmdt(:) integer :: i,iam - real :: vrel,vstick,vend,sdust + real :: vrel,vstick,vend,sdust,vt if (ibounce == 1) then !$omp parallel do default(none) & !$omp shared(xyzh,npart,iphase,use_dustfrac) & !$omp shared(filfac,dmdt,dustprop,dustgasprop,probastick,shearparam) & - !$omp private(i,iam,vrel,vstick,vend,sdust) + !$omp private(i,iam,vrel,vstick,vend,sdust,vt) do i=1, npart if (.not.isdead_or_accreted(xyzh(4,i))) then iam = iamtype(iphase(i)) if ((iam == idust .or. (iam == igas .and. use_dustfrac))) then if (filfac(i) >= 0.3 .and. dmdt(i) >= 0.) then - vrel = vrelative(dustgasprop(:,i),sqrt(roottwo*Ro*shearparam)*dustgasprop(1,i)) + vt = sqrt(roottwo*Ro*shearparam)*dustgasprop(1,i) + vrel = vrelative(dustgasprop(:,i),vt) sdust = get_size(dustprop(1,i),dustprop(2,i),filfac(i)) vstick = compute_vstick(dustprop(1,i),sdust) vend = compute_vend(vstick) From bcffd8517789cfbbde0bffe3a5b2c5dcab5bdb5e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 9 Apr 2024 15:02:50 +1000 Subject: [PATCH 366/814] add option use_fourthorder in ptmass file + new simple setup for testing --- build/Makefile_setups | 6 + src/main/checksetup.F90 | 16 ++ src/main/options.f90 | 6 - src/main/ptmass.F90 | 4 + src/main/step_leapfrog.F90 | 5 +- src/setup/setup_nbody_test.f90 | 261 +++++++++++++++++++++++++++++++++ 6 files changed, 290 insertions(+), 8 deletions(-) create mode 100644 src/setup/setup_nbody_test.f90 diff --git a/build/Makefile_setups b/build/Makefile_setups index ae562595d..0ee5a0b74 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -345,6 +345,12 @@ ifeq ($(SETUP), galcen) KNOWN_SETUP=yes endif +ifeq ($(SETUP), nbody) +# Cluster of stars (ptmass) + SETUPFILE= setup_nbody_test.f90 + KNOWN_SETUP=yes +endif + #--- Bondi accretion/wind --------------------------- ifeq ($(SETUP), bondi) # Bondi accretion flow diff --git a/src/main/checksetup.F90 b/src/main/checksetup.F90 index a14201b96..abbe26d7f 100644 --- a/src/main/checksetup.F90 +++ b/src/main/checksetup.F90 @@ -56,6 +56,7 @@ subroutine check_setup(nerror,nwarn,restart) use nicil, only:n_nden use metric_tools, only:imetric,imet_minkowski use physcon, only:au,solarm + use ptmass, only:use_fourthorder integer, intent(out) :: nerror,nwarn logical, intent(in), optional :: restart integer :: i,nbad,itype,iu,ndead @@ -429,6 +430,10 @@ subroutine check_setup(nerror,nwarn,restart) !--check centre of mass ! call get_centreofmass(xcom,vcom,npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) +! +!--check Forward symplectic integration method imcompatiblity +! + if (use_fourthorder) call check_setup_FSI (nerror,iexternalforce) if (.not.h2chemistry .and. maxvxyzu >= 4 .and. icooling == 3 .and. iexternalforce/=iext_corotate .and. nptmass==0) then if (dot_product(xcom,xcom) > 1.e-2) then @@ -999,4 +1004,15 @@ subroutine check_setup_radiation(npart,nerror,nwarn,radprop,rad) end subroutine check_setup_radiation +subroutine check_setup_FSI(nerror,iexternalforce) + use externalforces, only: is_velocity_dependent + integer, intent(inout) :: nerror + integer, intent(in) :: iexternalforce + if (is_velocity_dependent(iexternalforce)) then + print "(/,a,/)","ERROR in setup: velocity dependant external forces..." + nerror = nerror + 1 + endif + +end subroutine check_setup_FSI + end module checksetup diff --git a/src/main/options.f90 b/src/main/options.f90 index 0312c9371..85887742a 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -58,10 +58,6 @@ module options logical, public :: exchange_radiation_energy, limit_radiation_flux, implicit_radiation logical, public :: implicit_radiation_store_drad -! Regularisation method and/or higher order integrator - logical, public :: use_fourthorder - - public :: set_default_options public :: ieos,idamp public :: iopacity_type @@ -174,8 +170,6 @@ subroutine set_default_options ! variable composition use_var_comp = .false. - use_fourthorder = .false. - end subroutine set_default_options end module options diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 5bd621a6f..00d25bd3a 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -68,6 +68,7 @@ module ptmass real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius real, public :: f_crit_override = 0.0 ! 1000. + logical, public :: use_fourthorder = .false. ! Note for above: if f_crit_override > 0, then will unconditionally make a sink when rho > f_crit_override*rho_crit_cgs ! This is a dangerous parameter since failure to form a sink might be indicative of another problem. ! This is a hard-coded parameter due to this danger, but will appear in the .in file if set > 0. @@ -2064,6 +2065,7 @@ subroutine write_options_ptmass(iunit) call write_inopt(f_acc,'f_acc','particles < f_acc*h_acc accreted without checks',iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) + call write_inopt(use_fourthorder, 'use_fourthorder', 'FSI integration method (4th order)', iunit) end subroutine write_options_ptmass @@ -2138,6 +2140,8 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) r_merge_cond if (r_merge_cond > 0. .and. r_merge_cond < r_merge_uncond) call fatal(label,'0 < r_merge_cond < r_merge_uncond') ngot = ngot + 1 + case('use_fourthorder') + read(valstring,*,iostat=ierr) use_fourthorder case default imatch = .false. end select diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index e13b7d596..030ba9931 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -92,7 +92,7 @@ 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 io, only:iprint,fatal,iverbose,id,master,warning - use options, only:iexternalforce,use_dustfrac,implicit_radiation,use_fourthorder + 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,& @@ -121,8 +121,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate - use step_extern, only:step_extern_FSI,step_extern_lf,step_extern_gr, & + use step_extern, only:step_extern_FSI,step_extern_lf,step_extern_gr, & step_extern_sph_gr,step_extern_sph + use ptmass, only: use_fourthorder integer, intent(inout) :: npart integer, intent(in) :: nactive diff --git a/src/setup/setup_nbody_test.f90 b/src/setup/setup_nbody_test.f90 new file mode 100644 index 000000000..c02933307 --- /dev/null +++ b/src/setup/setup_nbody_test.f90 @@ -0,0 +1,261 @@ +!--------------------------------------------------------------------------! +! 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 setup +! +! Setup for simulations of the Galactic Centre +! Adapted by Daniel Price in collaboration with Jorge Cuadra +! +! :References: Paumard et al. (2006) +! +! :Owner: Daniel Price +! +! :Runtime parameters: +! - datafile : *filename for star data (m,x,y,z,vx,vy,vz)* +! - h_sink : *sink particle radii in arcsec at 8kpc* +! - m_gas : *gas mass resolution in solar masses* +! +! :Dependencies: datafiles, dim, eos, infile_utils, io, part, physcon, +! prompting, spherical, timestep, units +! + implicit none + public :: setpart + + ! + ! setup options and default values for these + ! + character(len=120) :: datafile = 'ic01.txt' + real :: m_gas = 1.e-6 ! gas mass resolution in Msun + real :: h_sink = 0.0 ! sink particle radii in arcsec at 8kpc + + private + +contains + +!---------------------------------------------------------------- +!+ +! setup for galactic centre simulation (no gas) +!+ +!---------------------------------------------------------------- +subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas + use units, only:set_units,umass,unit_velocity !,udist + use physcon, only:solarm,kpc,pi,au,years,pc + use io, only:fatal,iprint,master + use eos, only:gmw + use timestep, only:dtmax + use spherical, only:set_sphere + use datafiles, only:find_phantom_datafile + use ptmass, only:use_fourthorder + integer, intent(in) :: id + integer, intent(inout) :: npart + integer, intent(out) :: npartoftype(:) + real, intent(out) :: xyzh(:,:) + real, intent(out) :: massoftype(:) + real, intent(out) :: polyk,gamma,hfact + real, intent(inout) :: time + character(len=20), intent(in) :: fileprefix + real, intent(out) :: vxyzu(:,:) + character(len=len(fileprefix)+6) :: setupfile + character(len=len(datafile)) :: filename + integer :: ierr,i + real :: xcom(3),vcom(3),mtot + real :: psep +! +! units (mass = mass of black hole, length = 1 arcsec at 8kpc) +! + call set_units(mass=solarm,dist=1*pc,G=1.d0) +! +! general parameters +! + xcom = 0. + vcom = 0. + time = 0. + hfact = 1.2 + polyk = 0. + gamma = 5./3. + gmw = 0.6 ! completely ionized, solar abu; eventually needs to be WR abu + dtmax = 0.01 + use_fourthorder = .true. + m_gas = 1.e-20 + ! + ! read setup parameters from the .setup file + ! if file does not exist, then ask for user input + ! + setupfile = trim(fileprefix)//'.setup' + call read_setupfile(setupfile,iprint,ierr) + if (ierr /= 0 .and. id==master) then + call interactive_setup() ! read setup options from user + call write_setupfile(setupfile,iprint) ! write .setup file with defaults + endif +! +! space available for injected gas particles +! + npart = 0 + npartoftype(:) = 0 + massoftype = m_gas*(solarm/umass) ! mass resolution + + xyzh(:,:) = 0. + vxyzu(:,:) = 0. + xyzmh_ptmass(:,:) = 0. + vxyz_ptmass (:,:) = 0. +! +! Read positions, masses and velocities of stars from file +! + filename = datafile + call read_ptmass_data(filename,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr) + + mtot = sum(xyzmh_ptmass(4,:)) + + do i=1,nptmass + xcom(1:3) = xcom(1:3) + xyzmh_ptmass(4,i)*xyzmh_ptmass(1:3,i) + vcom(1:3) = vcom(1:3) + xyzmh_ptmass(4,i)*vxyz_ptmass(1:3,i) + enddo + xcom = xcom/mtot + vcom = vcom/mtot + + print*,"xcom",xcom + print*,"vcom",vcom + + do i=1,nptmass + xyzmh_ptmass(1:3,i) = xyzmh_ptmass(1:3,i) - xcom(1:3) + vxyz_ptmass(1:3,i) = vxyz_ptmass(1:3,i) - vcom(1:3) + xyzmh_ptmass(ihacc,i) = h_sink + xyzmh_ptmass(ihsoft,i) = h_sink + enddo + + +! +! setup initial sphere of particles to prevent initialisation problems +! + psep = 1.0 + call set_sphere('cubic',id,master,0.,0.002,psep,hfact,npart,xyzh) + vxyzu(4,:) = 5.317e-4 + npartoftype(igas) = npart + + print*,"npart : ", npart + + if (nptmass == 0) call fatal('setup','no particles setup') + if (ierr /= 0) call fatal('setup','ERROR during setup') + +end subroutine setpart + +!---------------------------------------------------------------- +!+ +! read sink particle masses, positions and velocities from file +!+ +!---------------------------------------------------------------- +subroutine read_ptmass_data(filename,xyzmh_ptmass,vxyz_ptmass,n,ierr) + use io, only:error + use units, only : unit_velocity + character(len=*), intent(in) :: filename + real, intent(out) :: xyzmh_ptmass(:,:), vxyz_ptmass(:,:) + integer, intent(inout) :: n + integer, intent(out) :: ierr + integer :: iunit,n_input + + n_input = n + open(newunit=iunit,file=filename,status='old',action='read',iostat=ierr) + if (ierr /= 0) then + print "(/,2(a,/))",' ERROR opening "'//trim(filename)//'" for read of point mass data', & + ' -> this file should contain m,x,y,z,vx,vy,vz for each point mass, one per line' + endif + do while(ierr==0) + n = n + 1 + if (n > size(xyzmh_ptmass(1,:))) then + ierr = 66 + else + read(iunit,*,iostat=ierr) xyzmh_ptmass(4,n),xyzmh_ptmass(1:3,n),vxyz_ptmass(1:3,n) + endif + vxyz_ptmass(1:3,n) = (vxyz_ptmass(1:3,n)*1.e5)/unit_velocity + if (ierr /= 0) n = n - 1 + enddo + print "(a,i4,a)",' READ',n - n_input,' point masses from '//trim(filename) + if (ierr==66) then + call error('read_ptmass_data','array size exceeded in read_ptmass_data, recompile with MAXPTMASS=n',var='n',ival=n+1) + endif + + ! end of file error is OK + if (ierr < 0) ierr = 0 + +end subroutine read_ptmass_data + +!------------------------------------------ +!+ +! Write setup parameters to .setup file +!+ +!------------------------------------------ +subroutine write_setupfile(filename,iprint) + use infile_utils, only:write_inopt + use dim, only:tagline + character(len=*), intent(in) :: filename + integer, intent(in) :: iprint + integer :: lu,ierr1,ierr2 + + write(iprint,"(a)") ' Writing '//trim(filename)//' with setup options' + open(newunit=lu,file=filename,status='replace',form='formatted') + write(lu,"(a)") '# '//trim(tagline) + write(lu,"(a)") '# input file for Phantom galactic centre setup' + + write(lu,"(/,a)") '# datafile' + call write_inopt(datafile,'datafile','filename for star data (m,x,y,z,vx,vy,vz)',lu,ierr1) + + write(lu,"(/,a)") '# resolution' + call write_inopt(m_gas, 'm_gas','gas mass resolution in solar masses',lu,ierr2) + call write_inopt(h_sink, 'h_sink','sink particle radii in parsec',lu,ierr2) + close(lu) + +end subroutine write_setupfile + +!------------------------------------------ +!+ +! Read setup parameters from input file +!+ +!------------------------------------------ +subroutine read_setupfile(filename,iprint,ierr) + use infile_utils, only:open_db_from_file,inopts,close_db,read_inopt + use dim, only:maxvxyzu + character(len=*), intent(in) :: filename + integer, parameter :: lu = 21 + integer, intent(in) :: iprint + integer, intent(out) :: ierr + integer :: nerr + type(inopts), allocatable :: db(:) + + call open_db_from_file(db,filename,lu,ierr) + if (ierr /= 0) return + write(iprint, '(1x,2a)') 'Setup_Nbody_test: Reading setup options from ',trim(filename) + + nerr = 0 + call read_inopt(datafile,'datafile',db,errcount=nerr) + call read_inopt(m_gas,'m_gas',db,errcount=nerr) + call read_inopt(h_sink,'h_sink',db,errcount=nerr) + + if (nerr > 0) then + print "(1x,a,i2,a)",'Setup_Nbody_test: ',nerr,' error(s) during read of setup file' + ierr = 1 + endif + call close_db(db) + +end subroutine read_setupfile + +!------------------------------------------ +!+ +! Prompt user for setup options +!+ +!------------------------------------------ +subroutine interactive_setup() + use prompting, only:prompt + + print "(2(/,a),/)",'*** Nbody test setup. You can put any cluster of stars that you want to evolve with gas.',& + ' ... With or without primordial binaries, mass(msun), pos (pc), vel(kms)***' + call prompt('Enter filename for star data',datafile,noblank=.true.) + call prompt('Enter sink particle radii in parsec',h_sink,1.e-15,1.e-4) + print "(a)" + +end subroutine interactive_setup + +end module setup From 531221d9ba2a10c4de11c49355622c56bb6917fe Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 9 Apr 2024 15:05:16 +1000 Subject: [PATCH 367/814] add new extrapolation method for FSI (still in test...) --- src/main/ptmass.F90 | 77 +++++++++++++++++++++-------- src/main/step_extern.F90 | 101 +++++++++++++++++++++++++++++++++------ 2 files changed, 142 insertions(+), 36 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 00d25bd3a..18534adc5 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -123,7 +123,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) + pmassi,fxyz_ptmass,dsdt_ptmass,fonrmax,dtphi2,extrapfac) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -134,7 +134,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, real, intent(in) :: xi,yi,zi,hi real, intent(inout) :: fxi,fyi,fzi,phi real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, optional, intent(in) :: pmassi + real, optional, intent(in) :: pmassi,extrapfac real, optional, intent(inout) :: fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) real, optional, intent(out) :: fonrmax,dtphi2 real :: ftmpxi,ftmpyi,ftmpzi @@ -142,7 +142,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft real :: fxj,fyj,fzj,dsx,dsy,dsz integer :: j - logical :: tofrom + logical :: tofrom,extrap ! ! Determine if acceleration is from/to gas, or to gas ! @@ -153,6 +153,14 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, tofrom = .false. endif + ! check if it is a force computed using Omelyan extrapolation method for FSI + if (present(extrapfac)) then + extrap = .true. + else + extrap = .false. + endif + + ftmpxi = 0. ! use temporary summation variable ftmpyi = 0. ! (better for round-off, plus we need this bit of ftmpzi = 0. ! the force to calculate the dtphi timestep) @@ -160,9 +168,15 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, f2 = 0. do j=1,nptmass - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) + if (extrap)then + dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fxyz_ptmass(1,j)) + dy = yi - (xyzmh_ptmass(2,j) + extrapfac*fxyz_ptmass(2,j)) + dz = zi - (xyzmh_ptmass(3,j) + extrapfac*fxyz_ptmass(3,j)) + else + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + endif pmassj = xyzmh_ptmass(4,j) hsoft = xyzmh_ptmass(ihsoft,j) J2 = xyzmh_ptmass(iJ2,j) @@ -266,7 +280,7 @@ end subroutine get_accel_sink_gas !+ !---------------------------------------------------------------- subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,& - iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass) + iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass,extrapfac) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -274,14 +288,15 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(out) :: fxyz_ptmass(4,nptmass) - real, intent(out) :: phitot,dtsinksink - integer, intent(in) :: iexternalforce - real, intent(in) :: ti - integer, intent(out) :: merge_ij(:),merge_n - real, intent(out) :: dsdt_ptmass(3,nptmass) + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(out) :: fxyz_ptmass(4,nptmass) + real, intent(out) :: phitot,dtsinksink + integer, intent(in) :: iexternalforce + real, intent(in) :: ti + integer, intent(out) :: merge_ij(:),merge_n + real, intent(out) :: dsdt_ptmass(3,nptmass) + real, optional, intent(in) :: extrapfac real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii real :: ddr,dx,dy,dz,rr2,rr2j,dr3,f1,f2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft @@ -290,6 +305,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real :: J2i,rsinki,shati(3) real :: J2j,rsinkj,shatj(3) integer :: i,j + logical :: extrap dtsinksink = huge(dtsinksink) fxyz_ptmass(:,:) = 0. @@ -298,6 +314,12 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin merge_n = 0 merge_ij = 0 if (nptmass <= 1) return + ! check if it is a force computed using Omelyan extrapolation method for FSI + if (present(extrapfac)) then + extrap = .true. + else + extrap = .false. + endif ! !--get self-contribution to the potential if sink-sink softening is used ! @@ -316,6 +338,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp parallel do default(none) & !$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) & !$omp private(i,xi,yi,zi,pmassi,pmassj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & @@ -325,9 +348,15 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) do i=1,nptmass - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) + if (extrap)then + xi = xyzmh_ptmass(1,i) + extrapfac*fxyz_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + extrapfac*fxyz_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + extrapfac*fxyz_ptmass(3,i) + else + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + endif pmassi = xyzmh_ptmass(4,i) !hsofti = xyzmh_ptmass(5,i) if (pmassi < 0.) cycle @@ -342,9 +371,15 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dsz = 0. do j=1,nptmass if (i==j) cycle - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) + if (extrap)then + dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fxyz_ptmass(1,j)) + dy = yi - (xyzmh_ptmass(2,j) + extrapfac*fxyz_ptmass(2,j)) + dz = zi - (xyzmh_ptmass(3,j) + extrapfac*fxyz_ptmass(3,j)) + else + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + endif pmassj = xyzmh_ptmass(4,j) !hsoftj = xyzmh_ptmass(5,j) if (pmassj < 0.) cycle diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index f0bcddf37..bb54636c0 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -463,20 +463,18 @@ subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,x if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) nsubsteps = nsubsteps + 1 call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) call kick_4th (dk(1),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call drift_4th(ck(1),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Direct calculation of the force and force gradient + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Direct calculation of the force and force gradient + !call get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + ! xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt) ! extrapolation method Omelyan call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) - ! call get_force_extrapol_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - ! xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Extrapolation of the modified force using Omelyan technique - call kick_4th (dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - !print*,xyzmh_ptmass(1,1:20) call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) call kick_4th (dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt @@ -628,22 +626,23 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks use timestep, only:bignumber,C_force use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi - integer, intent(in):: nptmass,npart,nsubsteps - real, intent(inout) :: xyzh(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real, intent(inout) :: dtextforce - real, intent(in) :: timei,pmassi + integer, intent(in) :: nptmass,npart,nsubsteps + real, intent(inout) :: xyzh(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) + real, intent(inout) :: dtextforce + real, intent(in) :: timei,pmassi integer :: merge_ij(nptmass) integer :: merge_n integer :: i real :: dtf,dtextforcenew,dtsinkgas,dtphi2,fonrmax real :: fextx,fexty,fextz - real :: fonrmaxi,phii,dtphi2i + real :: fonrmaxi,phii,dtphi2i,extrapfac dtextforcenew = bignumber dtsinkgas = bignumber dtphi2 = bignumber fonrmax = 0 + if (nptmass>0) then if (id==master) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& @@ -669,7 +668,7 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext) & !$omp private(fextx,fexty,fextz) & !$omp private(fonrmaxi,dtphi2i,phii,pmassi,dtf) & - !$omp reduction(min:dtextforcenew,dtsinkgas,dtphi2) & + !$omp reduction(min:dtextforcenew,dtphi2) & !$omp reduction(max:fonrmax) & !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) !$omp do @@ -690,7 +689,7 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe if (nptmass > 0) then call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - !call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) endif if(nptmass>0) then @@ -761,6 +760,78 @@ subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptm end subroutine get_gradf_4th + !---------------------------------------------------------------- + !+ + ! grad routine for the 4th order scheme (FSI), extrapolation method + !+ + !---------------------------------------------------------------- + + +subroutine get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh, & + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt) + use options, only:iexternalforce + use dim, only:maxptmass + use part, only:epot_sinksink + use io, only:iverbose,master,id,iprint,warning,fatal + use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks + use timestep, only:bignumber + use mpiutils, only:reduce_in_place_mpi + integer, intent(in) :: nptmass,npart,nsubsteps + real, intent(inout) :: xyzh(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) + real, intent(inout) :: dtextforce + real, intent(in) :: timei,pmassi,dt + integer :: merge_ij(nptmass) + integer :: merge_n + integer :: i + real :: dtf + real :: fextx,fexty,fextz,xi,yi,zi + real :: fonrmaxi,phii,dtphi2i,extrapfac + + if (nptmass>0) then + if (id==master) then + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,extrapfac) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,extrapfac) + endif + else + fxyz_ptmass(:,:) = 0. + dsdt_ptmass(:,:) = 0. + endif + endif + + + !$omp parallel default(none) & + !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,extrapfac) & + !$omp private(fextx,fexty,fextz,xi,yi,zi) & + !$omp private(fonrmaxi,dtphi2i,phii,pmassi,dtf) & + !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) + !$omp do + do i=1,npart + fextx = 0. + fexty = 0. + fextz = 0. + xi = xyzh(1,i) + extrapfac*fext(1,i) + xi = xyzh(1,i) + extrapfac*fext(1,i) + xi = xyzh(1,i) + extrapfac*fext(1,i) + 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) + fext(1,i) = fextx + fext(2,i) = fexty + fext(3,i) = fextz + enddo + !$omp enddo + !$omp end parallel + + if (nptmass > 0) then + call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) + call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + endif +end subroutine get_gradf_extrap_4th + !---------------------------------------------------------------- !+ From f82ea70955169265d28a501a31a8a3e367cd97a2 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 17:19:36 +1000 Subject: [PATCH 368/814] (utils) build failures in diffdumps fixed --- build/Makefile | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/build/Makefile b/build/Makefile index 7e77b79ec..32282cb91 100644 --- a/build/Makefile +++ b/build/Makefile @@ -606,10 +606,9 @@ edit: checksetup #---------------------------------------------------- # these are the sources for anything which uses the readwrite_dumps module # -SRCDUMP= physcon.f90 ${CONFIG} ${SRCKERNEL} utils_omp.F90 io.F90 units.f90 \ - boundary.f90 boundary_dynamic.f90 mpi_utils.F90 \ +SRCDUMP= physcon.f90 ${CONFIG} ${SRCKERNEL} utils_omp.F90 io.F90 units.f90 mpi_utils.F90 \ utils_timing.f90 utils_infiles.f90 dtype_kdtree.f90 utils_allocate.f90 part.F90 \ - ${DOMAIN} mpi_dens.F90 mpi_force.F90 \ + ${DOMAIN} mpi_dens.F90 mpi_force.F90 boundary.f90 boundary_dynamic.f90 \ mpi_balance.F90 mpi_memory.f90 mpi_derivs.F90 mpi_tree.F90 kdtree.F90 linklist_kdtree.F90 \ utils_dumpfiles.f90 utils_vectors.f90 utils_mathfunc.f90 \ utils_datafiles.f90 utils_filenames.f90 utils_system.f90 utils_tables.f90 datafiles.f90 gitinfo.f90 \ @@ -619,7 +618,7 @@ SRCDUMP= physcon.f90 ${CONFIG} ${SRCKERNEL} utils_omp.F90 io.F90 units.f90 \ memory.f90 \ utils_sphNG.f90 \ setup_params.f90 ${SRCFASTMATH} checkoptions.F90 \ - viscosity.f90 damping.f90 options.f90 checkconserved.f90 prompting.f90 ${SRCDUST} \ + viscosity.f90 damping.f90 options.f90 checkconserved.f90 prompting.f90 dust.f90 \ ${SRCREADWRITE_DUMPS} \ utils_sort.f90 sort_particles.f90 OBJDUMP1= $(SRCDUMP:.f90=.o) From 6b57fc2652beb8da0ef657634fdf438e0744c5dd Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 17:47:51 +1000 Subject: [PATCH 369/814] (porosity) bug fix with uninitialised variables; drop resolution in dust tests so they are faster --- src/main/growth.f90 | 9 ++++++--- src/main/part.F90 | 2 +- src/tests/test_dust.f90 | 9 +++++---- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/main/growth.f90 b/src/main/growth.f90 index ca74020ee..a2d35aec7 100644 --- a/src/main/growth.f90 +++ b/src/main/growth.f90 @@ -280,9 +280,12 @@ subroutine get_growth_rate(npart,xyzh,vxyzu,dustgasprop,VrelVf,dustprop,filfac,d case(2) dmdt(i) = -fourpi*sdust**2*rhod*vrel*(VrelVf(i)**2)/(1+VrelVf(i)**2) ! Kobayashi model end select - endif !sqrt(0.0123)=0.110905 !1.65 -> surface energy in cgs - if (ieros == 1 .and. (dustgasprop(4,i) >= 0.110905*sqrt(1.65*utime*utime/umass/dustprop(2,i)/dsize))) then - dmdt(i) = dmdt(i) - fourpi*sdust*dustprop(2,i)*dustgasprop(2,i)*(dustgasprop(4,i)**3)*(dsize**2)/(3.*cohacc) ! Erosion model + endif + if (ieros == 1) then !sqrt(0.0123)=0.110905 !1.65 -> surface energy in cgs + ! Erosion model of Rozner, Grishin & Perets (2020) + if (dustgasprop(4,i) >= 0.110905*sqrt(1.65*utime*utime/umass/dustprop(2,i)/dsize)) then + dmdt(i) = dmdt(i) - fourpi*sdust*dustprop(2,i)*dustgasprop(2,i)*(dustgasprop(4,i)**3)*(dsize**2)/(3.*cohacc) + endif endif endif else diff --git a/src/main/part.F90 b/src/main/part.F90 index 331f9de21..652935668 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -70,7 +70,7 @@ module part ! !--storage of dust growth properties ! - real, allocatable :: dustprop(:,:) !- mass and intrinsic density + real, allocatable :: dustprop(:,:) !- mass and intrinsic density real, allocatable :: dustgasprop(:,:) !- gas related quantites interpolated on dust particles (see Force.F90) real, allocatable :: VrelVf(:) character(len=*), parameter :: dustprop_label(2) = (/'grainmass','graindens'/) diff --git a/src/tests/test_dust.f90 b/src/tests/test_dust.f90 index a969958ba..3fdaab497 100644 --- a/src/tests/test_dust.f90 +++ b/src/tests/test_dust.f90 @@ -196,7 +196,7 @@ subroutine test_dustybox(ntests,npass) ! setup for dustybox problem ! call init_part() - nx = 32 + nx = 16 deltax = 1./nx dz = 2.*sqrt(6.)/nx call set_boundary(-0.5,0.5,-0.25,0.25,-dz,dz) @@ -359,7 +359,7 @@ subroutine test_dustydiffuse(ntests,npass) ! ! setup uniform box ! - nx = 32 + nx = 16 deltax = 1./nx call init_part() call set_boundary(-0.5,0.5,-0.5,0.5,-0.5,0.5) @@ -529,6 +529,7 @@ subroutine test_drag(ntests,npass) use vectorutils, only:cross_product3D use units, only:udist,unit_density use mpidomain, only:i_belong + use physcon, only:pi integer, intent(inout) :: ntests,npass integer(kind=8) :: npartoftypetot(maxtypes) integer :: nx,i,j,nfailed(7),itype,iseed,npart_previous,iu @@ -543,7 +544,7 @@ subroutine test_drag(ntests,npass) ! ! set up particles in random distribution ! - nx = 50 + nx = 25 psep = 1./nx iseed= -14255 call init_part() @@ -595,7 +596,7 @@ subroutine test_drag(ntests,npass) if (use_dustgrowth) then dustprop(:,:) = 0. - dustprop(1,:) = grainsize(1) + dustprop(1,:) = 4./3.*pi*grainsize(1)**3*graindens(1) dustprop(2,:) = graindens(1) endif ! From 8d158c58cb35a697a77fb0365e85ca14e3a74e3f Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 9 Apr 2024 17:48:39 +1000 Subject: [PATCH 370/814] (porosity) bug fix with uninitialised variables; drop resolution in dust tests so they are faster --- src/tests/test_dust.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/test_dust.f90 b/src/tests/test_dust.f90 index 3fdaab497..71106c7e6 100644 --- a/src/tests/test_dust.f90 +++ b/src/tests/test_dust.f90 @@ -359,7 +359,7 @@ subroutine test_dustydiffuse(ntests,npass) ! ! setup uniform box ! - nx = 16 + nx = 32 deltax = 1./nx call init_part() call set_boundary(-0.5,0.5,-0.5,0.5,-0.5,0.5) From 81bda3625deb76f2071503cdd7887703f859d79b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 08:23:18 +1000 Subject: [PATCH 371/814] (porosity) #55 remove spurious ifdef PHOTO/obsolete functionality; restore changes which should not differ from master branch --- src/main/dens.F90 | 2 +- src/main/deriv.F90 | 9 ++------- src/main/force.F90 | 2 +- 3 files changed, 4 insertions(+), 9 deletions(-) diff --git a/src/main/dens.F90 b/src/main/dens.F90 index 65ad2c82f..4c2ddf816 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -99,7 +99,7 @@ module densityforce !real, parameter :: cnormk = 1./pi, wab0 = 1., gradh0 = -3.*wab0, radkern2 = 4F.0 integer, parameter :: isizecellcache = 1000 integer, parameter :: isizeneighcache = 0 - integer, parameter :: maxdensits = 100 + integer, parameter :: maxdensits = 50 !--statistics which can be queried later integer, private :: maxneighact,nrelink diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index 773741675..fd6b06ceb 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -16,8 +16,8 @@ module deriv ! ! :Dependencies: cons2prim, densityforce, derivutils, dim, dust_formation, ! externalforces, forces, forcing, growth, io, linklist, metric_tools, -! options, part, photoevap, porosity, ptmass, ptmass_radiation, -! radiation_implicit, raytracer, timestep, timestep_ind, timing +! options, part, porosity, ptmass, ptmass_radiation, radiation_implicit, +! timestep, timestep_ind, timing ! implicit none @@ -51,11 +51,6 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& #ifdef DRIVING use forcing, only:forceit #endif -#ifdef PHOTO - use photoevap, only:find_ionfront,photo_ionize - use part, only:massoftype -#endif - use raytracer use growth, only:get_growth_rate use porosity, only:get_disruption,get_probastick use ptmass_radiation, only:get_dust_temperature diff --git a/src/main/force.F90 b/src/main/force.F90 index 0cdb06d7e..7586fc82a 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -3087,7 +3087,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv elseif (use_dust .and. .not.use_dustfrac) then tstop(:,i) = ts_min if (drag_implicit) then - dtdrag = 90*ts_min + dtdrag = 90.*ts_min else dtdrag = 0.9*ts_min endif From a461b5a2469cff5b697de4e45bc8d91e5fe26359 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 08:23:43 +1000 Subject: [PATCH 372/814] (test_dust) increase resolution on dustybox to nx=24 to fix test failure --- src/tests/test_dust.f90 | 64 +++++++++++++++++------------------------ 1 file changed, 27 insertions(+), 37 deletions(-) diff --git a/src/tests/test_dust.f90 b/src/tests/test_dust.f90 index 71106c7e6..371059769 100644 --- a/src/tests/test_dust.f90 +++ b/src/tests/test_dust.f90 @@ -51,7 +51,7 @@ subroutine test_dust(ntests,npass) use table_utils, only:logspace use growth, only:init_growth integer, intent(inout) :: ntests,npass - integer :: nfailed(3),ierr,iregime + integer :: nfailed(3),ierr,iregime,j real :: rhoi,rhogasi,rhodusti,spsoundi,tsi,grainsizei,graindensi if (use_dust) then @@ -94,36 +94,23 @@ subroutine test_dust(ntests,npass) call test_epsteinstokes(ntests,npass) call barrier_mpi() - if (id==master) write(*,"(/,a)") '--> testing drag with EXPLICIT scheme' use_dustfrac = .false. - ! - ! Test that drag conserves momentum and energy with explicit scheme - ! + do j=1,2 + drag_implicit = .false. + if (j==2) drag_implicit = .true. + ! + ! Test that drag conserves momentum and energy with explicit/implicit scheme + ! + call test_drag(ntests,npass) + call barrier_mpi() + + ! + ! DUSTYBOX test with explicit/implicit scheme + ! + call test_dustybox(ntests,npass) + call barrier_mpi() + enddo drag_implicit = .false. - call test_drag(ntests,npass) - call barrier_mpi() - - ! - ! DUSTYBOX test with explicit scheme - ! - drag_implicit = .false. - call test_dustybox(ntests,npass) - call barrier_mpi() - - if (id==master) write(*,"(/,a)") '--> testing DRAG with IMPLICIT scheme' - ! - ! Test that drag conserves momentum and energy with implicit scheme - ! - drag_implicit = .true. - call test_drag(ntests,npass) - call barrier_mpi() - - ! - ! DUSTYBOX test with explicit scheme - ! - drag_implicit = .true. - call test_dustybox(ntests,npass) - call barrier_mpi() ! ! DUSTYDIFFUSE test @@ -152,7 +139,7 @@ subroutine test_dustybox(ntests,npass) use energies, only:compute_energies,ekin use testutils, only:checkvalbuf,checkvalbuf_end use eos, only:ieos,polyk,gamma - use dust, only:K_code,idrag + use dust, only:K_code,idrag,drag_implicit use options, only:alpha,alphamax use unifdis, only:set_unifdis use dim, only:periodic,mhd,use_dust,use_dustgrowth @@ -174,7 +161,7 @@ subroutine test_dustybox(ntests,npass) real :: vg, vd, deltav, ekin_exact, fd real :: tol,tolvg,tolfg,tolfd logical :: write_output = .false. - character(len=60) :: filename + character(len=60) :: filename,string integer, parameter :: lu = 36 if (index(kernelname,'quintic') /= 0) then @@ -184,19 +171,19 @@ subroutine test_dustybox(ntests,npass) endif if (periodic .and. use_dust) then - if (id==master) write(*,"(/,a)") '--> testing DUSTYBOX' + string = '(explicit drag)' + if (drag_implicit) string = '(implicit drag)' + if (id==master) write(*,"(/,a)") '--> testing DUSTYBOX '//trim(string) else if (id==master) write(*,"(/,a)") '--> skipping DUSTYBOX (need -DPERIODIC and -DDUST)' return endif - if (use_dustgrowth .and. id==master) write(*,"(/,a)") '--> Adding dv interpolation test' - ! ! setup for dustybox problem ! call init_part() - nx = 16 + nx = 24 deltax = 1./nx dz = 2.*sqrt(6.)/nx call set_boundary(-0.5,0.5,-0.25,0.25,-dz,dz) @@ -519,7 +506,7 @@ subroutine test_drag(ntests,npass) use options, only:use_dustfrac use eos, only:polyk,ieos use kernel, only:hfact_default - use dust, only:K_code,idrag + use dust, only:K_code,idrag,drag_implicit use boundary, only:dxbound,dybound,dzbound,xmin,xmax,ymin,ymax,zmin,zmax,set_boundary use io, only:iverbose use unifdis, only:set_unifdis @@ -535,12 +522,15 @@ subroutine test_drag(ntests,npass) integer :: nx,i,j,nfailed(7),itype,iseed,npart_previous,iu real :: da(3),dl(3),temp(3) real :: psep,time,rhozero,totmass,dekin,deint + character(len=10) :: string real, parameter :: tol_mom = 1.e-7 real, parameter :: tol_ang = 5.e-4 real, parameter :: tol_enj = 1.e-6 - if (id==master) write(*,"(/,a)") '--> testing DUST DRAG' + string = '(explicit)' + if (drag_implicit) string = '(implicit)' + if (id==master) write(*,"(/,a)") '--> testing DUST DRAG '//trim(string) ! ! set up particles in random distribution ! From dddb81ada96bc23fcc2c1032ce2af3a8d8c4bd2e Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 11:16:06 +1000 Subject: [PATCH 373/814] (dustfrac) fix seg fault with ifort on MacOS reading dustfrac from file --- src/main/readwrite_dumps_fortran.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 2d80c89b4..cc15cfd5d 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -1159,6 +1159,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto logical :: got_filfac,got_divcurlv(4),got_rad(maxirad),got_radprop(maxradprop),got_pxyzu(4),got_iorig character(len=lentag) :: tag,tagarr(64) integer :: k,i,iarr,ik,ndustfraci + real, allocatable :: tmparray(:) ! !--read array type 1 arrays @@ -1193,6 +1194,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto got_iorig = .false. ndustfraci = 0 + if (use_dust) allocate(tmparray(size(dustfrac,2))) over_arraylengths: do iarr=1,narraylengths do k=1,ndatatypes @@ -1226,8 +1228,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto if (use_dust) then if (any(tag == dustfrac_label)) then ndustfraci = ndustfraci + 1 - call read_array(dustfrac(ndustfraci,:),dustfrac_label(ndustfraci),got_dustfrac(ndustfraci), & + call read_array(dustfrac,dustfrac_label(ndustfraci),got_dustfrac(ndustfraci), & ik,i1,i2,noffset,idisk1,tag,match,ierr) + dustfrac(ndustfraci,i1:i2) = tmparray(i1:i2) endif endif if (h2chemistry) then @@ -1289,6 +1292,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto enddo enddo over_arraylengths + if (allocated(tmparray)) deallocate(tmparray) ! ! check for errors ! From 4a5791cacc99f9217c23998905b50d20ff3a647c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 11:41:35 +1000 Subject: [PATCH 374/814] (rwdumps) fix numbering of errors in write_array calls; just use a cumulative error count; remove obsolete ifdef #55 --- src/main/readwrite_dumps_fortran.F90 | 158 +++++++++++---------------- src/main/utils_dumpfiles.f90 | 68 ++++++++---- 2 files changed, 112 insertions(+), 114 deletions(-) diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index cc15cfd5d..7a20b5480 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -178,23 +178,6 @@ subroutine end_threadwrite(id) end subroutine end_threadwrite -!-------------------------------------------------------------------- -!+ -! extract dump size used in Phantom from the fileid string -!+ -!-------------------------------------------------------------------- -subroutine get_dump_size(fileid,smalldump) - character(len=lenid), intent(in) :: fileid - logical, intent(out) :: smalldump - ! - if (fileid(1:1)=='S') then - smalldump = .true. - else - smalldump = .false. - endif - -end subroutine get_dump_size - !-------------------------------------------------------------------- !+ ! subroutine to write output to full dump file @@ -225,9 +208,6 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) use mpiutils, only:reduce_mpi,reduceall_mpi use timestep, only:dtmax,idtmax_n,idtmax_frac use part, only:ibin,krome_nmols,T_gas_cool -#ifdef PRDRAG - use lumin_nsdisc, only:beta -#endif use metric_tools, only:imetric, imet_et real, intent(in) :: t character(len=*), intent(in) :: dumpfile @@ -239,7 +219,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) integer(kind=8) :: ilen(4) integer :: nums(ndatatypes,4) integer :: ipass,k,l,ioffset - integer :: ierr,ierrs(30) + integer :: ierr,nerr integer :: nblocks,nblockarrays,narraylengths integer(kind=8) :: nparttot logical :: sphNGdump,write_itype,use_gas @@ -334,7 +314,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) call start_threadwrite(id,idump,dumpfile) - ierrs = 0 + nerr = 0 nums = 0 ilen = 0_8 if (sphNGdump) then @@ -344,134 +324,127 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) endif do ipass=1,2 do k=1,ndatatypes + nerr = 0 ! ! Block 1 arrays (hydrodynamics) ! ilen(1) = int(npart,kind=8) - if (write_itype) call write_array(1,iphase,'itype',npart,k,ipass,idump,nums,ierrs(1),func=iamtype_int11) - call write_array(1,xyzh,xyzh_label,3,npart,k,ipass,idump,nums,ierrs(2)) + if (write_itype) call write_array(1,iphase,'itype',npart,k,ipass,idump,nums,nerr,func=iamtype_int11) + call write_array(1,xyzh,xyzh_label,3,npart,k,ipass,idump,nums,nerr) if (use_dustgrowth) then - call write_array(1,dustprop,dustprop_label,2,npart,k,ipass,idump,nums,ierrs(3)) - call write_array(1,VrelVf,VrelVf_label,npart,k,ipass,idump,nums,ierrs(3)) - call write_array(1,dustgasprop,dustgasprop_label,4,npart,k,ipass,idump,nums,ierrs(3)) - if (use_porosity) call write_array(1,filfac,filfac_label,npart,k,ipass,idump,nums,ierrs(3)) + call write_array(1,dustprop,dustprop_label,2,npart,k,ipass,idump,nums,nerr) + call write_array(1,VrelVf,VrelVf_label,npart,k,ipass,idump,nums,nerr) + call write_array(1,dustgasprop,dustgasprop_label,4,npart,k,ipass,idump,nums,nerr) + if (use_porosity) call write_array(1,filfac,filfac_label,npart,k,ipass,idump,nums,nerr) endif - if (h2chemistry) call write_array(1,abundance,abundance_label,nabundances,npart,k,ipass,idump,nums,ierrs(5)) - if (use_dust) call write_array(1,dustfrac,dustfrac_label,ndusttypes,npart,k,ipass,idump,nums,ierrs(7)) - if (use_dust) call write_array(1,tstop,tstop_label,ndustsmall,npart,k,ipass,idump,nums,ierrs(8)) + if (h2chemistry) call write_array(1,abundance,abundance_label,nabundances,npart,k,ipass,idump,nums,nerr) + if (use_dust) call write_array(1,dustfrac,dustfrac_label,ndusttypes,npart,k,ipass,idump,nums,nerr) + if (use_dust) call write_array(1,tstop,tstop_label,ndustsmall,npart,k,ipass,idump,nums,nerr) if (use_dustfrac) then do l=1,ndustsmall - call write_array(1,deltav(:,l,:),deltav_label,3,npart,k,ipass,idump,nums,ierrs(10)) + call write_array(1,deltav(:,l,:),deltav_label,3,npart,k,ipass,idump,nums,nerr) enddo endif if (gr) then - call write_array(1,pxyzu,pxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,dens,'dens prim',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,pxyzu,pxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,nerr) + call write_array(1,dens,'dens prim',npart,k,ipass,idump,nums,nerr) if (imetric==imet_et) then ! Output metric if imetric=iet - call write_array(1,metrics(1,1,1,:), 'gtt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metrics(1,1,1,:), 'gtt (covariant)',npart,k,ipass,idump,nums,nerr) ! call write_array(1,metrics(1,2,1,:), 'gtx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) ! call write_array(1,metrics(1,3,1,:), 'gty (covariant)',npart,k,ipass,idump,nums,ierrs(8)) ! call write_array(1,metrics(1,2,1,:), 'gtz (covariant)',npart,k,ipass,idump,nums,ierrs(8)) ! call write_array(1,metrics(1,2,1,:), 'gtx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metrics(2,2,1,:), 'gxx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metrics(3,3,1,:), 'gyy (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metrics(4,4,1,:), 'gzz (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metrics(2,2,1,:), 'gxx (covariant)',npart,k,ipass,idump,nums,nerr) + call write_array(1,metrics(3,3,1,:), 'gyy (covariant)',npart,k,ipass,idump,nums,nerr) + call write_array(1,metrics(4,4,1,:), 'gzz (covariant)',npart,k,ipass,idump,nums,nerr) - call write_array(1,metricderivs(1,1,1,:), 'dxgtt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metricderivs(2,2,1,:), 'dxgxx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metricderivs(3,3,1,:), 'dxgyy (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metricderivs(4,4,1,:), 'dxgzz (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metricderivs(1,1,1,:), 'dxgtt (covariant)',npart,k,ipass,idump,nums,nerr) + call write_array(1,metricderivs(2,2,1,:), 'dxgxx (covariant)',npart,k,ipass,idump,nums,nerr) + call write_array(1,metricderivs(3,3,1,:), 'dxgyy (covariant)',npart,k,ipass,idump,nums,nerr) + call write_array(1,metricderivs(4,4,1,:), 'dxgzz (covariant)',npart,k,ipass,idump,nums,nerr) - call write_array(1,tmunus(1,1,:), 'tmunutt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,tmunus(1,1,:), 'tmunutt (covariant)',npart,k,ipass,idump,nums,nerr) endif endif if (eos_is_non_ideal(ieos) .or. (.not.store_dust_temperature .and. icooling > 0)) then - call write_array(1,eos_vars(itemp,:),eos_vars_label(itemp),npart,k,ipass,idump,nums,ierrs(12)) + call write_array(1,eos_vars(itemp,:),eos_vars_label(itemp),npart,k,ipass,idump,nums,nerr) endif - if (eos_is_non_ideal(ieos)) call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,ierrs(12)) + if (eos_is_non_ideal(ieos)) call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,nerr) - call write_array(1,vxyzu,vxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,ierrs(4)) + call write_array(1,vxyzu,vxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,nerr) ! write pressure to file if ((eos_outputs_gasP(ieos) .or. eos_is_non_ideal(ieos)) .and. k==i_real) then - call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,ierrs(13),index=igasP) + call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,nerr,index=igasP) endif ! write X, Z, mu to file if (eos_outputs_mu(ieos)) then - call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,ierrs(13),index=imu) + call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,nerr,index=imu) if (use_var_comp) then - call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,ierrs(13),index=iX) - call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,ierrs(13),index=iZ) + call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,nerr,index=iX) + call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,nerr,index=iZ) endif 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) - if (maxalpha==maxp) call write_array(1,alphaind,(/'alpha'/),1,npart,k,ipass,idump,nums,ierrs(15)) + call write_array(1,xyzh,xyzh_label,1,npart,k,ipass,idump,nums,nerr,use_kind=4,index=4) + if (maxalpha==maxp) call write_array(1,alphaind,(/'alpha'/),1,npart,k,ipass,idump,nums,nerr) !if (maxalpha==maxp) then ! (uncomment this to write alphaloc to the full dumps) ! call write_array(1,alphaind,(/'alpha ','alphaloc'/),2,npart,k,ipass,idump,nums,ierrs(10)) !endif - if (ndivcurlv >= 1) call write_array(1,divcurlv,divcurlv_label,ndivcurlv,npart,k,ipass,idump,nums,ierrs(16)) + if (ndivcurlv >= 1) call write_array(1,divcurlv,divcurlv_label,ndivcurlv,npart,k,ipass,idump,nums,nerr) !if (maxdvdx==maxp) call write_array(1,dvdx,dvdx_label,9,npart,k,ipass,idump,nums,ierrs(17)) if (gravity .and. maxgrav==maxp) then - call write_array(1,poten,'poten',npart,k,ipass,idump,nums,ierrs(17)) + call write_array(1,poten,'poten',npart,k,ipass,idump,nums,nerr) endif if (ind_timesteps) then if (.not.allocated(temparr)) allocate(temparr(npart)) temparr(1:npart) = dtmax/2.**ibin(1:npart) - call write_array(1,temparr,'dt',npart,k,ipass,idump,nums,ierrs(18),use_kind=4) + call write_array(1,temparr,'dt',npart,k,ipass,idump,nums,nerr,use_kind=4) endif - call write_array(1,iorig,'iorig',npart,k,ipass,idump,nums,ierrs(29)) + call write_array(1,iorig,'iorig',npart,k,ipass,idump,nums,nerr) -#ifdef PRDRAG - if (k==i_real) then - if (.not.allocated(temparr)) allocate(temparr(npart)) - do l=1,npart - temparr(l) = real4(beta(xyzh(1,l), xyzh(2,l), xyzh(3,l))) - enddo - call write_array(1,temparr,'beta_pr',npart,k,ipass,idump,nums,ierrs(19)) - endif -#endif if (lightcurve) then - call write_array(1,luminosity,'luminosity',npart,k,ipass,idump,nums,ierrs(20)) + call write_array(1,luminosity,'luminosity',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,ierrs(21)) - call write_array(1,T_gas_cool,'temp',npart,k,ipass,idump,nums,ierrs(24)) + 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) endif if (update_muGamma .or. use_krome) then - call write_array(1,eos_vars(imu,:),eos_vars_label(imu),npart,k,ipass,idump,nums,ierrs(12)) - call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,ierrs(12)) + call write_array(1,eos_vars(imu,:),eos_vars_label(imu),npart,k,ipass,idump,nums,nerr) + call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,nerr) endif if (do_nucleation) then - call write_array(1,nucleation,nucleation_label,n_nucleation,npart,k,ipass,idump,nums,ierrs(25)) + call write_array(1,nucleation,nucleation_label,n_nucleation,npart,k,ipass,idump,nums,nerr) endif If (itau_alloc == 1) then - call write_array(1,tau,'tau',npart,k,ipass,idump,nums,ierrs(30)) + call write_array(1,tau,'tau',npart,k,ipass,idump,nums,nerr) endif If (itauL_alloc == 1) then - call write_array(1,tau_lucy,'tau_lucy',npart,k,ipass,idump,nums,ierrs(30)) + call write_array(1,tau_lucy,'tau_lucy',npart,k,ipass,idump,nums,nerr) endif if (store_dust_temperature) then - call write_array(1,dust_temp,'Tdust',npart,k,ipass,idump,nums,ierrs(26)) + call write_array(1,dust_temp,'Tdust',npart,k,ipass,idump,nums,nerr) endif if (do_radiation) then - call write_array(1,rad,rad_label,maxirad,npart,k,ipass,idump,nums,ierrs(27)) - call write_array(1,radprop,radprop_label,maxradprop,npart,k,ipass,idump,nums,ierrs(28)) + call write_array(1,rad,rad_label,maxirad,npart,k,ipass,idump,nums,nerr) + call write_array(1,radprop,radprop_label,maxradprop,npart,k,ipass,idump,nums,nerr) endif - if (any(ierrs(1:28) /= 0)) call error('write_dump','error writing hydro arrays') + if (nerr > 0) call error('write_dump','error writing hydro arrays') enddo + nerr = 0 do k=1,ndatatypes ! ! Block 2 arrays (sink particles) ! if (.not. sphNGdump .and. nptmass > 0 .and. nptmass <= maxptmass) then ilen(2) = int(nptmass,kind=8) - call write_array(2,xyzmh_ptmass,xyzmh_ptmass_label,nsinkproperties,nptmass,k,ipass,idump,nums,ierrs(1)) - call write_array(2,vxyz_ptmass,vxyz_ptmass_label,3,nptmass,k,ipass,idump,nums,ierrs(2)) - if (any(ierrs(1:2) /= 0)) call error('write_dump','error writing sink particle arrays') + call write_array(2,xyzmh_ptmass,xyzmh_ptmass_label,nsinkproperties,nptmass,k,ipass,idump,nums,nerr) + call write_array(2,vxyz_ptmass,vxyz_ptmass_label,3,nptmass,k,ipass,idump,nums,nerr) + if (nerr > 0) call error('write_dump','error writing sink particle arrays') endif enddo @@ -480,18 +453,20 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ! Block 4 arrays (MHD) ! if (mhd) then + nerr = 0 ilen(4) = int(npart,kind=8) - call write_array(4,Bxyz,Bxyz_label,3,npart,k,ipass,idump,nums,ierrs(1)) ! Bx,By,Bz - call write_array(4,Bevol,Bevol_label,1,npart,k,ipass,idump,nums,ierrs(1),index=4) ! psi + call write_array(4,Bxyz,Bxyz_label,3,npart,k,ipass,idump,nums,nerr) ! Bx,By,Bz + call write_array(4,Bevol,Bevol_label,1,npart,k,ipass,idump,nums,nerr,index=4) ! psi if (ndivcurlB >= 1) then - call write_array(4,divcurlB,divcurlB_label,ndivcurlB,npart,k,ipass,idump,nums,ierrs(2)) + call write_array(4,divcurlB,divcurlB_label,ndivcurlB,npart,k,ipass,idump,nums,nerr) else - call write_array(4,divBsymm,'divBsymm',npart,k,ipass,idump,nums,ierrs(2)) + call write_array(4,divBsymm,'divBsymm',npart,k,ipass,idump,nums,nerr) endif - if (any(ierrs(1:2) /= 0)) call error('write_dump','error writing MHD arrays') + if (nerr > 0) call error('write_dump','error writing MHD arrays') if (mhd_nonideal) then - call write_array(4,eta_nimhd,eta_nimhd_label,4,npart,k,ipass,idump,nums,ierrs(1)) - if (ierrs(1) /= 0) call error('write_dump','error writing non-ideal MHD arrays') + nerr = 0 + call write_array(4,eta_nimhd,eta_nimhd_label,4,npart,k,ipass,idump,nums,nerr) + if (nerr > 0) call error('write_dump','error writing non-ideal MHD arrays') endif endif enddo @@ -515,7 +490,6 @@ end subroutine write_fulldump_fortran ! (faked to look like the default real is real*4) !+ !------------------------------------------------------------------- - subroutine write_smalldump_fortran(t,dumpfile) use dim, only:maxp,maxtypes,use_dust,lightcurve,use_dustgrowth,h2chemistry use options, only:use_porosity @@ -559,7 +533,7 @@ subroutine write_smalldump_fortran(t,dumpfile) call open_dumpfile_w(idump,dumpfile,fileident('ST'),ierr,singleprec=.true.) if (ierr /= 0) then - call error('write_smalldump','can''t create new dumpfile '//trim(dumpfile)) + call error('write_smalldump','could not write new dumpfile '//trim(dumpfile)) return endif ! @@ -587,6 +561,7 @@ subroutine write_smalldump_fortran(t,dumpfile) call start_threadwrite(id,idump,dumpfile) nums = 0 + ierr = 0 ilen = 0_8 write_itype = (maxphase==maxp .and. any(npartoftypetot(2:) > 0)) do ipass=1,2 @@ -643,7 +618,6 @@ end subroutine write_smalldump_fortran ! and also from standard sphNG dump files !+ !------------------------------------------------------------------- - subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ierr,headeronly,dustydisc) use memory, only:allocate_memory use dim, only:maxp,maxvxyzu,gravity,lightcurve,mhd,maxp_hard,inject_parts,mpi @@ -651,7 +625,7 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie use part, only:xyzh,vxyzu,massoftype,npart,npartoftype,maxtypes,iphase, & maxphase,isetphase,nptmass,nsinkproperties,maxptmass,get_pmass, & xyzmh_ptmass,vxyz_ptmass - use dump_utils, only:skipblock,skip_arrays,check_tag,lenid,ndatatypes,read_header, & + use dump_utils, only:get_dump_size,skipblock,skip_arrays,check_tag,lenid,ndatatypes,read_header, & open_dumpfile_r,get_error_text,ierr_realsize,free_header,read_block_header use mpiutils, only:reduce_mpi,reduceall_mpi use sphNGutils, only:convert_sinks_sphNG,mass_sphng @@ -1228,7 +1202,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto if (use_dust) then if (any(tag == dustfrac_label)) then ndustfraci = ndustfraci + 1 - call read_array(dustfrac,dustfrac_label(ndustfraci),got_dustfrac(ndustfraci), & + call read_array(tmparray,dustfrac_label(ndustfraci),got_dustfrac(ndustfraci), & ik,i1,i2,noffset,idisk1,tag,match,ierr) dustfrac(ndustfraci,i1:i2) = tmparray(i1:i2) endif diff --git a/src/main/utils_dumpfiles.f90 b/src/main/utils_dumpfiles.f90 index 7691ea5c7..11b73a4ab 100644 --- a/src/main/utils_dumpfiles.f90 +++ b/src/main/utils_dumpfiles.f90 @@ -24,7 +24,7 @@ module dump_utils public :: open_dumpfile_w, open_dumpfile_r, get_error_text public :: tag,check_tag,match_tag public :: skipblock,skip_arrays,skip_headerblock - public :: get_dumpname + public :: get_dumpname,get_dump_size public :: add_to_header,add_to_rheader,add_to_iheader public :: num_in_header,reset_header,extract public :: read_array_from_file @@ -174,6 +174,23 @@ function get_dumpname(filename,id) end function get_dumpname +!-------------------------------------------------------------------- +!+ +! extract dump size (full or small) from the fileid string +!+ +!-------------------------------------------------------------------- +subroutine get_dump_size(fileid,smalldump) + character(len=lenid), intent(in) :: fileid + logical, intent(out) :: smalldump + ! + if (fileid(1:1)=='S') then + smalldump = .true. + else + smalldump = .false. + endif + +end subroutine get_dump_size + !-------------------------------------------------------------------- !+ ! small utility to skip an entire block in a file @@ -1588,12 +1605,12 @@ end subroutine write_header ! Write int*1 array to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_int1(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,ierr,func) +subroutine write_array_int1(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,nerr,func) integer(kind=1), intent(in) :: iarr(:) character(len=*), intent(in) :: my_tag integer, intent(in) :: ib,len,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr !procedure(integer(kind=1)), pointer, optional :: func interface integer(kind=1) pure function func(x) @@ -1602,7 +1619,7 @@ end function func end interface optional :: func !integer(kind=1), optional :: func - integer :: i + integer :: i,ierr ierr = 0 ! check if kind matches @@ -1618,6 +1635,7 @@ end function func endif endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_int1 @@ -1626,12 +1644,12 @@ end subroutine write_array_int1 ! Write int*4 array to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_int4(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,ierr,func) +subroutine write_array_int4(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,nerr,func) integer(kind=4), intent(in) :: iarr(:) character(len=*), intent(in) :: my_tag integer, intent(in) :: ib,len,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr !procedure(integer(kind=1)), pointer, optional :: func interface integer(kind=4) pure function func(x) @@ -1640,7 +1658,7 @@ end function func end interface optional :: func !integer(kind=1), optional :: func - integer :: i + integer :: i,ierr ierr = 0 ! check if kind matches @@ -1656,6 +1674,7 @@ end function func endif endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_int4 @@ -1664,12 +1683,12 @@ end subroutine write_array_int4 ! Write int*4 array to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_int8(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,ierr,func) +subroutine write_array_int8(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,nerr,func) integer(kind=8), intent(in) :: iarr(:) character(len=*), intent(in) :: my_tag integer, intent(in) :: ib,len,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr !procedure(integer(kind=1)), pointer, optional :: func interface integer(kind=8) pure function func(x) @@ -1678,7 +1697,7 @@ end function func end interface optional :: func !integer(kind=1), optional :: func - integer :: i + integer :: i,ierr ierr = 0 ! check if kind matches @@ -1694,6 +1713,7 @@ end function func endif endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_int8 @@ -1702,12 +1722,12 @@ end subroutine write_array_int8 ! Write real*4 array to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_real4(ib,arr,my_tag,len,ikind,ipass,iunit,nums,ierr,func,use_kind,singleprec) +subroutine write_array_real4(ib,arr,my_tag,len,ikind,ipass,iunit,nums,nerr,func,use_kind,singleprec) real(kind=4), intent(in) :: arr(:) character(len=*), intent(in) :: my_tag integer, intent(in) :: ib,len,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr interface real(kind=4) pure function func(x) real(kind=4), intent(in) :: x @@ -1717,7 +1737,7 @@ end function func !real(kind=4), optional :: func integer, intent(in), optional :: use_kind logical, intent(in), optional :: singleprec - integer :: i,imatch + integer :: i,imatch,ierr ierr = 0 ! use default real if it matches, unless kind is specified @@ -1739,6 +1759,7 @@ end function func endif endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_real4 @@ -1747,12 +1768,12 @@ end subroutine write_array_real4 ! Write real*4 array to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_real8(ib,arr,my_tag,len,ikind,ipass,iunit,nums,ierr,func,use_kind,singleprec) +subroutine write_array_real8(ib,arr,my_tag,len,ikind,ipass,iunit,nums,nerr,func,use_kind,singleprec) real(kind=8), intent(in) :: arr(:) character(len=*), intent(in) :: my_tag integer, intent(in) :: ib,len,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr interface real(kind=8) pure function func(x) real(kind=8), intent(in) :: x @@ -1762,7 +1783,7 @@ end function func !real(kind=8), optional :: func integer, intent(in), optional :: use_kind logical, intent(in), optional :: singleprec - integer :: i,imatch + integer :: i,imatch,ierr logical :: use_singleprec ierr = 0 @@ -1798,6 +1819,7 @@ end function func endif endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_real8 @@ -1807,15 +1829,15 @@ end subroutine write_array_real8 ! to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_real4arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,ierr,use_kind,index,singleprec) +subroutine write_array_real4arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,nerr,use_kind,index,singleprec) real(kind=4), intent(in) :: arr(:,:) character(len=*), intent(in) :: my_tag(:) integer, intent(in) :: ib,len1,len2,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr integer, intent(in), optional :: use_kind,index logical, intent(in), optional :: singleprec - integer :: j,i,imatch,istart,iend + integer :: j,i,imatch,istart,iend,ierr ierr = 0 ! use default real if it matches, unless kind is specified @@ -1843,6 +1865,7 @@ subroutine write_array_real4arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,i enddo endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_real4arr @@ -1852,15 +1875,15 @@ end subroutine write_array_real4arr ! to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_real8arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,ierr,use_kind,index,singleprec) +subroutine write_array_real8arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,nerr,use_kind,index,singleprec) real(kind=8), intent(in) :: arr(:,:) character(len=*), intent(in) :: my_tag(:) integer, intent(in) :: ib,len1,len2,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr integer, intent(in), optional :: use_kind,index logical, intent(in), optional :: singleprec - integer :: j,i,imatch,istart,iend + integer :: j,i,imatch,istart,iend,ierr logical :: use_singleprec ierr = 0 @@ -1902,6 +1925,7 @@ subroutine write_array_real8arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,i enddo endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_real8arr From 2912d0a0ef4c25aeb8d49025b87ec432b522f522 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 12:50:20 +1000 Subject: [PATCH 375/814] add an additionnal array for FSI gradient force computation + few tweaks on FSI routines --- src/main/part.F90 | 4 +- src/main/ptmass.F90 | 63 ++++++++++++----------- src/main/step_extern.F90 | 101 +++++++++++++++++++++---------------- src/main/step_leapfrog.F90 | 4 +- 4 files changed, 97 insertions(+), 75 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index 652935668..8fd586af6 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -206,7 +206,7 @@ module part integer, parameter :: iJ2 = 19 ! 2nd gravity moment due to oblateness real, allocatable :: xyzmh_ptmass(:,:) real, allocatable :: vxyz_ptmass(:,:) - real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:) + real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:),fsink_old(:,:) real, allocatable :: dsdt_ptmass(:,:),dsdt_ptmass_sinksink(:,:) integer :: nptmass = 0 ! zero by default real :: epot_sinksink @@ -431,6 +431,7 @@ subroutine allocate_part call allocate_array('vxyz_ptmass', vxyz_ptmass, 3, maxptmass) call allocate_array('fxyz_ptmass', fxyz_ptmass, 4, maxptmass) call allocate_array('fxyz_ptmass_sinksink', fxyz_ptmass_sinksink, 4, maxptmass) + call allocate_array('fsink_old', fsink_old, 4, maxptmass) call allocate_array('dsdt_ptmass', dsdt_ptmass, 3, maxptmass) call allocate_array('dsdt_ptmass_sinksink', dsdt_ptmass_sinksink, 3, maxptmass) call allocate_array('poten', poten, maxgrav) @@ -517,6 +518,7 @@ subroutine deallocate_part if (allocated(vxyz_ptmass)) deallocate(vxyz_ptmass) if (allocated(fxyz_ptmass)) deallocate(fxyz_ptmass) if (allocated(fxyz_ptmass_sinksink)) deallocate(fxyz_ptmass_sinksink) + if (allocated(fsink_old)) deallocate(fsink_old) if (allocated(dsdt_ptmass)) deallocate(dsdt_ptmass) if (allocated(dsdt_ptmass_sinksink)) deallocate(dsdt_ptmass_sinksink) if (allocated(poten)) deallocate(poten) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 18534adc5..eab603fea 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -123,7 +123,8 @@ 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) + pmassi,fxyz_ptmass,dsdt_ptmass,fonrmax, & + dtphi2,extrapfac,fsink_old) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -136,6 +137,7 @@ 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(in) :: fsink_old(4,nptmass) real, optional, intent(out) :: fonrmax,dtphi2 real :: ftmpxi,ftmpyi,ftmpzi real :: dx,dy,dz,rr2,ddr,dr3,f1,f2,pmassj,J2,shat(3),Rsink @@ -169,9 +171,9 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, do j=1,nptmass if (extrap)then - dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fxyz_ptmass(1,j)) - dy = yi - (xyzmh_ptmass(2,j) + extrapfac*fxyz_ptmass(2,j)) - dz = zi - (xyzmh_ptmass(3,j) + extrapfac*fxyz_ptmass(3,j)) + dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fsink_old(1,j)) + dy = yi - (xyzmh_ptmass(2,j) + extrapfac*fsink_old(2,j)) + dz = zi - (xyzmh_ptmass(3,j) + extrapfac*fsink_old(3,j)) else dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) @@ -280,7 +282,7 @@ end subroutine get_accel_sink_gas !+ !---------------------------------------------------------------- subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,& - iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass,extrapfac) + iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass,extrapfac,fsink_old) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -297,6 +299,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin integer, intent(out) :: merge_ij(:),merge_n real, intent(out) :: dsdt_ptmass(3,nptmass) real, optional, intent(in) :: extrapfac + real, optional, intent(in) :: fsink_old(4,nptmass) real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii real :: ddr,dx,dy,dz,rr2,rr2j,dr3,f1,f2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft @@ -315,7 +318,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin merge_ij = 0 if (nptmass <= 1) return ! check if it is a force computed using Omelyan extrapolation method for FSI - if (present(extrapfac)) then + if (present(extrapfac) .and. present(fsink_old)) then extrap = .true. else extrap = .false. @@ -338,7 +341,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp parallel do default(none) & !$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) & + !$omp shared(extrapfac,extrap,fsink_old) & !$omp private(i,xi,yi,zi,pmassi,pmassj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & @@ -349,9 +352,9 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp reduction(+:phitot,merge_n) do i=1,nptmass if (extrap)then - xi = xyzmh_ptmass(1,i) + extrapfac*fxyz_ptmass(1,i) - yi = xyzmh_ptmass(2,i) + extrapfac*fxyz_ptmass(2,i) - zi = xyzmh_ptmass(3,i) + extrapfac*fxyz_ptmass(3,i) + xi = xyzmh_ptmass(1,i) + extrapfac*fsink_old(1,i) + yi = xyzmh_ptmass(2,i) + extrapfac*fsink_old(2,i) + zi = xyzmh_ptmass(3,i) + extrapfac*fsink_old(3,i) else xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) @@ -372,9 +375,9 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin do j=1,nptmass if (i==j) cycle if (extrap)then - dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fxyz_ptmass(1,j)) - dy = yi - (xyzmh_ptmass(2,j) + extrapfac*fxyz_ptmass(2,j)) - dz = zi - (xyzmh_ptmass(3,j) + extrapfac*fxyz_ptmass(3,j)) + dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fsink_old(1,j)) + dy = yi - (xyzmh_ptmass(2,j) + extrapfac*fsink_old(2,j)) + dz = zi - (xyzmh_ptmass(3,j) + extrapfac*fsink_old(3,j)) else dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) @@ -513,7 +516,7 @@ end subroutine get_accel_sink_sink !+ !---------------------------------------------------------------- subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & - pmassi,fxyz_ptmass) + pmassi,fxyz_ptmass,fsink_old) use kernel, only:kernel_softening,kernel_grad_soft,radkern integer, intent(in) :: nptmass real, intent(in) :: xi,yi,zi,hi,dt @@ -521,6 +524,7 @@ subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(in) :: pmassi real, intent(inout) :: fxyz_ptmass(4,nptmass) + real, intent(in) :: fsink_old(4,nptmass) real :: gtmpxi,gtmpyi,gtmpzi real :: dx,dy,dz,rr2,ddr,dr3,g11,g12,g21,g22,pmassj real :: dfx,dfy,dfz,drdotdf @@ -535,9 +539,9 @@ subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) - dfx = fxi - fxyz_ptmass(1,j) - dfy = fyi - fxyz_ptmass(2,j) - dfz = fzi - fxyz_ptmass(3,j) + dfx = fxi - fsink_old(1,j) + dfy = fyi - fsink_old(2,j) + dfz = fzi - fsink_old(3,j) pmassj = xyzmh_ptmass(4,j) hsoft = xyzmh_ptmass(ihsoft,j) if (hsoft > 0.0) hsoft = max(hsoft,hi) @@ -623,12 +627,13 @@ end subroutine get_gradf_sink_gas ! get gradient correction of the force for FSI integrator (sink-gas) !+ !---------------------------------------------------------------- -subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) +subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old) use kernel, only:kernel_softening,kernel_grad_soft,radkern - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: fxyz_ptmass(4,nptmass) - real, intent(in) :: dt + real, intent(in) :: fsink_old(4,nptmass) + real, intent(in) :: dt real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,gxi,gyi,gzi real :: ddr,dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,dr3,g1,g2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft @@ -647,7 +652,7 @@ subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) !--compute N^2 gradf on point mass particles due to each other ! !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,fsink_old) & !$omp shared(h_soft_sinksink,hsoft21,dt) & !$omp private(i,xi,yi,zi,pmassi,pmassj) & !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & @@ -659,9 +664,9 @@ subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) zi = xyzmh_ptmass(3,i) pmassi = xyzmh_ptmass(4,i) if (pmassi < 0.) cycle - fxi = fxyz_ptmass(1,i) - fyi = fxyz_ptmass(2,i) - fzi = fxyz_ptmass(3,i) + fxi = fsink_old(1,i) + fyi = fsink_old(2,i) + fzi = fsink_old(3,i) gxi = 0. gyi = 0. gzi = 0. @@ -670,14 +675,14 @@ subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) - dfx = fxi - fxyz_ptmass(1,j) - dfy = fyi - fxyz_ptmass(2,j) - dfz = fzi - fxyz_ptmass(3,j) + dfx = fxi - fsink_old(1,j) + dfy = fyi - fsink_old(2,j) + dfz = fzi - fsink_old(3,j) pmassj = xyzmh_ptmass(4,j) if (pmassj < 0.) cycle rr2 = dx*dx + dy*dy + dz*dz + epsilon(rr2) - drdotdf = dx*dfx + dy*dfy + dz*dfz +epsilon(drdotdf) + drdotdf = dx*dfx + dy*dfy + dz*dfz ddr = 1./sqrt(rr2) gpref = pmassj*((dt**2)/24.) diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index bb54636c0..69fb57ccb 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -426,7 +426,8 @@ end subroutine step_extern_sph ! and external forces except ptmass. (4th order scheme) !+ !---------------------------------------------------------------- -subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) +subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fsink_old,dsdt_ptmass) use part, only: isdead_or_accreted,igas,massoftype use io, only:iverbose,id,master,iprint,warning,fatal use io_summary, only:summary_variable,iosumextr,iosumextt @@ -434,7 +435,7 @@ subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,x integer, intent(in) :: npart,nptmass real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass),fsink_old(4,nptmass) real :: dt,t_end_step,dtextforce_min real :: pmassi,timei logical :: done,last_step @@ -468,9 +469,10 @@ subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,x call drift_4th(ck(1),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Direct calculation of the force and force gradient - !call get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - ! xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt) ! extrapolation method Omelyan - call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) + fsink_old=fxyz_ptmass + call get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& + xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,fsink_old) ! extrapolation method Omelyan + !call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old) call kick_4th (dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& @@ -518,18 +520,21 @@ subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsd integer, intent(in) :: npart,nptmass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) + real :: ckdt integer :: i + ckdt = ck*dt + ! Drift gas particles !$omp parallel do default(none) & - !$omp shared(npart,xyzh,vxyzu,dt,ck) & + !$omp shared(npart,xyzh,vxyzu,ckdt) & !$omp private(i) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then - xyzh(1,i) = xyzh(1,i) + ck*dt*vxyzu(1,i) - xyzh(2,i) = xyzh(2,i) + ck*dt*vxyzu(2,i) - xyzh(3,i) = xyzh(3,i) + ck*dt*vxyzu(3,i) + xyzh(1,i) = xyzh(1,i) + ckdt*vxyzu(1,i) + xyzh(2,i) = xyzh(2,i) + ckdt*vxyzu(2,i) + xyzh(3,i) = xyzh(3,i) + ckdt*vxyzu(3,i) endif enddo !$omp end parallel do @@ -538,16 +543,16 @@ subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsd if(nptmass>0) then if(id==master) then !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ck,dt) & + !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ckdt) & !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then - xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ck*dt*vxyz_ptmass(1,i) - xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ck*dt*vxyz_ptmass(2,i) - xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ck*dt*vxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + ck*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + ck*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + ck*dt*dsdt_ptmass(3,i) + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ckdt*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ckdt*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ckdt*vxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + ckdt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + ckdt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + ckdt*dsdt_ptmass(3,i) endif enddo !$omp end parallel do @@ -573,17 +578,20 @@ subroutine kick_4th(dk,dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext real, intent(inout) :: vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) integer :: i + real :: dkdt + + dkdt = dk*dt ! Kick gas particles !$omp parallel do default(none) & - !$omp shared(npart,fext,xyzh,vxyzu,dt,dk) & + !$omp shared(npart,fext,xyzh,vxyzu,dkdt) & !$omp private(i) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then - vxyzu(1,i) = vxyzu(1,i) + dk*dt*fext(1,i) - vxyzu(2,i) = vxyzu(2,i) + dk*dt*fext(2,i) - vxyzu(3,i) = vxyzu(3,i) + dk*dt*fext(3,i) + vxyzu(1,i) = vxyzu(1,i) + dkdt*fext(1,i) + vxyzu(2,i) = vxyzu(2,i) + dkdt*fext(2,i) + vxyzu(3,i) = vxyzu(3,i) + dkdt*fext(3,i) endif enddo !$omp end parallel do @@ -592,16 +600,16 @@ subroutine kick_4th(dk,dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext if (nptmass>0) then if(id==master) then !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,dsdt_ptmass,dk,dt) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,dsdt_ptmass,dkdt) & !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then - vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dk*dt*fxyz_ptmass(1,i) - vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dk*dt*fxyz_ptmass(2,i) - vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dk*dt*fxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dk*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dk*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dk*dt*dsdt_ptmass(3,i) + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dkdt*fxyz_ptmass(1,i) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dkdt*fxyz_ptmass(2,i) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dkdt*fxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) endif enddo !$omp end parallel do @@ -636,7 +644,7 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe integer :: i real :: dtf,dtextforcenew,dtsinkgas,dtphi2,fonrmax real :: fextx,fexty,fextz - real :: fonrmaxi,phii,dtphi2i,extrapfac + real :: fonrmaxi,phii,dtphi2i dtextforcenew = bignumber dtsinkgas = bignumber @@ -713,7 +721,7 @@ end subroutine get_force_4th !---------------------------------------------------------------- -subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) +subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old) use dim, only:maxptmass use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink use mpiutils, only:reduce_in_place_mpi @@ -721,6 +729,7 @@ subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptm integer, intent(in) :: nptmass,npart real, intent(inout) :: xyzh(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) + real, intent(in) :: fsink_old(4,nptmass) real, intent(inout) :: dt real, intent(in) :: pmassi real :: fextx,fexty,fextz @@ -729,23 +738,23 @@ subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptm if (nptmass>0) then if(id==master) then - call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) + call get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old) else fxyz_ptmass(:,:) = 0. endif endif !$omp parallel default(none) & - !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,dt,pmassi) & + !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,dt,pmassi,fsink_old) & !$omp private(fextx,fexty,fextz) & !$omp reduction(+:fxyz_ptmass) !$omp do do i=1,npart - fextx = 0. - fexty = 0. - fextz = 0. + fextx = fext(1,i) + fexty = fext(2,i) + fextz = fext(3,i) call get_gradf_sink_gas(nptmass,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - xyzmh_ptmass,fextx,fexty,fextz,pmassi,fxyz_ptmass) + xyzmh_ptmass,fextx,fexty,fextz,pmassi,fxyz_ptmass,fsink_old) fext(1,i) = fext(1,i)+ fextx fext(2,i) = fext(2,i)+ fexty fext(3,i) = fext(3,i)+ fextz @@ -768,17 +777,18 @@ end subroutine get_gradf_4th subroutine get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh, & - fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt) + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,fsink_old) use options, only:iexternalforce use dim, only:maxptmass use part, only:epot_sinksink - use io, only:iverbose,master,id,iprint,warning,fatal + use io, only:master,id use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks use timestep, only:bignumber use mpiutils, only:reduce_in_place_mpi integer, intent(in) :: nptmass,npart,nsubsteps real, intent(inout) :: xyzh(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) + real, intent(in) :: fsink_old(4,nptmass) real, intent(inout) :: dtextforce real, intent(in) :: timei,pmassi,dt integer :: merge_ij(nptmass) @@ -788,14 +798,18 @@ subroutine get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce, real :: fextx,fexty,fextz,xi,yi,zi real :: fonrmaxi,phii,dtphi2i,extrapfac + extrapfac = (1/24.)*dt**2 + if (nptmass>0) then if (id==master) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,extrapfac) + dtf,iexternalforce,timei,merge_ij,merge_n, & + dsdt_ptmass,extrapfac,fsink_old) if (merge_n > 0) then call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,extrapfac) + dtf,iexternalforce,timei,merge_ij,merge_n, & + dsdt_ptmass,extrapfac,fsink_old) endif else fxyz_ptmass(:,:) = 0. @@ -805,7 +819,7 @@ subroutine get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce, !$omp parallel default(none) & - !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,extrapfac) & + !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,extrapfac,fsink_old) & !$omp private(fextx,fexty,fextz,xi,yi,zi) & !$omp private(fonrmaxi,dtphi2i,phii,pmassi,dtf) & !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) @@ -815,10 +829,11 @@ subroutine get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce, fexty = 0. fextz = 0. xi = xyzh(1,i) + extrapfac*fext(1,i) - xi = xyzh(1,i) + extrapfac*fext(1,i) - xi = xyzh(1,i) + extrapfac*fext(1,i) + yi = xyzh(2,i) + extrapfac*fext(2,i) + zi = xyzh(3,i) + extrapfac*fext(3,i) 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) + fextx,fexty,fextz,phii,pmassi,fxyz_ptmass, & + dsdt_ptmass,fonrmaxi,dtphi2i,extrapfac,fsink_old) fext(1,i) = fextx fext(2,i) = fexty fext(3,i) = fextz diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 6edbd45a0..f643d4c5e 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -104,7 +104,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use deriv, only:derivs use timestep, only:dterr,bignumber,tolv use mpiutils, only:reduceall_mpi - use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,ibin_wake + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fsink_old,ibin_wake use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax @@ -250,7 +250,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then if (use_fourthorder) then call step_extern_FSI(dtextforce,dtsph,t,npart,nptmass,xyzh,vxyzu,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fsink_old,dsdt_ptmass) else call step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) From 1ef7a43a57abed85355beb3d17389a936ae3dd41 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 14:16:36 +1000 Subject: [PATCH 376/814] setp extern switch to .F90 --- src/main/{step_extern.f90 => step_extern.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/main/{step_extern.f90 => step_extern.F90} (100%) diff --git a/src/main/step_extern.f90 b/src/main/step_extern.F90 similarity index 100% rename from src/main/step_extern.f90 rename to src/main/step_extern.F90 From 8c18418e8361f5da71a71d7eaa96b38d6434a70d Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 14:45:47 +1000 Subject: [PATCH 377/814] fix subsystem flag --- src/main/ptmass.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 1bb20e6f6..2960a8705 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -65,10 +65,11 @@ module ptmass real, public :: f_acc = 0.8 real, public :: h_soft_sinkgas = 0.0 real, public :: h_soft_sinksink = 0.0 - real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch - real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius - real, public :: f_crit_override = 0.0 ! 1000. - logical, public :: use_fourthorder = .false. + real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch + real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius + real, public :: f_crit_override = 0.0 ! 1000. + logical, public :: use_fourthorder = .false. ! FSI switch + logical, public :: use_regnbody = .false. ! subsystems switch ! Note for above: if f_crit_override > 0, then will unconditionally make a sink when rho > f_crit_override*rho_crit_cgs ! This is a dangerous parameter since failure to form a sink might be indicative of another problem. ! This is a hard-coded parameter due to this danger, but will appear in the .in file if set > 0. @@ -2135,6 +2136,7 @@ subroutine write_options_ptmass(iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) call write_inopt(use_fourthorder, 'use_fourthorder', 'FSI integration method (4th order)', iunit) + call write_inopt(use_regnbody, 'use_regnboby', 'Subsystem (SD and secular and AR) integration method', iunit) end subroutine write_options_ptmass @@ -2211,6 +2213,8 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) ngot = ngot + 1 case('use_fourthorder') read(valstring,*,iostat=ierr) use_fourthorder + case('use_regnbody') + read(valstring,*,iostat=ierr) use_regnbody case default imatch = .false. end select From ce4d08f6cbc3e13995d4901056aafdc3dac2dda6 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 16:34:09 +1000 Subject: [PATCH 378/814] first compilation --- build/Makefile | 1 + src/main/options.f90 | 6 - src/main/part.F90 | 2 +- src/main/ptmass.F90 | 17 +-- src/main/sdar_group.f90 | 232 ++++++++++++++++++++----------------- src/main/step_extern.F90 | 34 +++--- src/main/step_leapfrog.F90 | 4 +- 7 files changed, 160 insertions(+), 136 deletions(-) diff --git a/build/Makefile b/build/Makefile index 3de3e2347..ef6f571b8 100644 --- a/build/Makefile +++ b/build/Makefile @@ -535,6 +535,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} \ + utils_sdar.f90 utils_kepler.f90 sdar_group.f90\ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 step_extern.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ diff --git a/src/main/options.f90 b/src/main/options.f90 index be508498a..36bc7e5eb 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -170,12 +170,6 @@ subroutine set_default_options ! variable composition use_var_comp = .false. - <<<<<<< HEAD - use_fourthorder = .false. - use_regnbody = .false. - - ======= - >>>>>>> 4thorder_scheme end subroutine set_default_options end module options diff --git a/src/main/part.F90 b/src/main/part.F90 index c1078db6c..f81e934fc 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -296,7 +296,7 @@ module part integer, parameter :: igarg = 1 ! idx of the particle member of a group integer, parameter :: igcum = 2 ! cumulative sum of the indices to find the starting and ending point of a group ! needed for group identification and sorting - integer :: ngroup = 0 + integer :: n_group = 0 integer :: n_ingroup = 0 integer :: n_sing = 0 ! Gradient of the time transformation function diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 2960a8705..1aa9b797d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -345,7 +345,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & !$omp shared(extrapfac,extrap,fsink_old) & - !$omp private(i,xi,yi,zi,pmassi,pmassj) & + !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & + !$omp private(start_id,end_id) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & !$omp private(fextx,fexty,fextz,phiext) & @@ -355,8 +356,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp reduction(+:phitot,merge_n) do k=1,nptmass if (present(group_info)) then - start_id = group_info(igcum) + 1 - end_id = group_info(igcum) + start_id = group_info(igcum,k) + 1 + end_id = group_info(igcum,k) i = group_info(igarg,k) else i = k @@ -644,7 +645,8 @@ end subroutine get_gradf_sink_gas !+ !---------------------------------------------------------------- subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) - use kernel, only:kernel_softening,kernel_grad_soft,radkern + use kernel, only:kernel_softening,kernel_grad_soft,radkern + use part, only:igarg,igcum integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: fxyz_ptmass(4,nptmass) @@ -671,14 +673,15 @@ subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,gro !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) & !$omp shared(h_soft_sinksink,hsoft21,dt) & - !$omp private(i,xi,yi,zi,pmassi,pmassj) & + !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & + !$omp private(start_id,end_id) & !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & !$omp private(fxi,fyi,fzi,gxi,gyi,gzi,gpref) & !$omp private(q2i,qi,psoft,fsoft,gsoft) do k=1,nptmass if (present(group_info)) then - start_id = group_info(igcum) + 1 - end_id = group_info(igcum) + start_id = group_info(igcum,k) + 1 + end_id = group_info(igcum,k) i = group_info(igarg,k) else i = k diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index c83dfc566..b7c2eaa38 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -5,18 +5,20 @@ module sdar_group ! ! :References: Makino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 ! -! :Owner: Daniel Price +! :Owner: Yann BERNARD ! use utils_sdar implicit none public :: group_identify public :: evolve_groups ! parameters for group identification - real, public :: r_neigh = 0.0 - real, public :: t_crit = 0.0 - real, public :: C_bin = 0.0 - real, public :: r_search = 0.0 real, parameter :: eta_pert = 0.02 + real, parameter :: time_error = 1e-10 + real, parameter :: max_step = 100000 + real, parameter, public :: r_neigh = 0.001 + real, public :: t_crit = 0.0 + real, public :: C_bin = 0.02 + real, public :: r_search = 100.*r_neigh private contains @@ -27,12 +29,12 @@ module sdar_group !----------------------------------------------- subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, intent(in) :: group_info(:,:) + integer, intent(inout) :: group_info(:,:) integer(kind=1), intent(inout) :: nmatrix(:,:) integer, intent(inout) :: n_group,n_ingroup,n_sing integer, intent(in) :: nptmass - ngroup = 0 + n_group = 0 n_ingroup = 0 n_sing = 0 call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) @@ -54,10 +56,10 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) do i=1,nptmass if(.not.visited(i)) then n_ingroup = n_ingroup + 1 - call dfs(i,i,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) + call dfs(i,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) if (ncg>1)then - ngroup = ngroup + 1 - group_info(igcum,ngroup+1) = ncg + group_info(igcum,ngroup) + n_group = n_group + 1 + group_info(igcum,n_group+1) = ncg + group_info(igcum,n_group) else n_ingroup = n_ingroup - 1 group_info(igarg,nptmass-n_sing) = i @@ -67,18 +69,19 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) enddo end subroutine form_group -subroutine dfs(inode,iroot,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) +subroutine dfs(iroot,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) use part, only : igarg - integer, intent(in) :: inode,nptmass,iroot + integer, intent(in) :: nptmass,iroot integer, intent(out) :: ncg integer(kind=1), intent(in) :: nmatrix(:,:) integer, intent(inout) :: group_info(:,:) integer, intent(inout) :: n_ingroup integer, intent(out) :: stack(:) logical, intent(inout) :: visited(:) - integer :: j,stack_top + integer :: j,stack_top,inode ncg = 1 + inode = iroot group_info(igarg,n_ingroup) = inode stack_top = stack_top + 1 stack(stack_top) = inode @@ -114,11 +117,12 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) ! !$omp parallel do default(none) & - !$omp shared(nptmass,r_neigh,C_bin,t_crit,nmatrix) & + !$omp shared(nptmass,C_bin,t_crit,nmatrix) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,r_search) & !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & !$omp private(dx,dy,dz,r,r2) & !$omp private(dvx,dvy,dvz,v2) & - !$omp private(mu,aij,eij,B,r_peri) + !$omp private(mu,aij,eij,B,rperi) do i=1,nptmass xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) @@ -171,7 +175,7 @@ end subroutine matrix_construction !--------------------------------------------- subroutine evolve_groups(n_group,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - use part, only: igid,igarg,igsize,igcum + use part, only: igarg,igcum real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) integer, intent(inout) :: n_group @@ -179,14 +183,15 @@ subroutine evolve_groups(n_group,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ integer :: i,start_id,end_id,gsize !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& - !$omp shared(tnext)& - !$omp private(i,start_id,end_id,gsize)& + !$omp shared(tnext,group_info,gtgrad)& + !$omp private(i,start_id,end_id,gsize) do i=1,n_group start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) gsize = end_id - start_id call integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) enddo + !$omp end parallel do end subroutine evolve_groups @@ -196,11 +201,13 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: start_id,end_id,gsize real, intent(in) :: tnext + real, allocatable :: bdata(:) real :: ds(2) - real :: timetable(ck_size) + real :: time_table(ck_size) integer :: switch integer :: step_count_int,step_count_tsyn,n_step_end real :: dt,ds_init,dt_end,step_modif,t_old,W_old + real :: W,tcoord logical :: t_end_flag,backup_flag,ismultiple integer :: i @@ -209,7 +216,9 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas ismultiple = gsize > 2 - call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismultiple,ds_init) + call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,W,start_id,end_id,ismultiple,ds_init) + + allocate(bdata(gsize*9)) step_count_int = 0 step_count_tsyn = 0 @@ -222,23 +231,20 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas do while (.true.) if (backup_flag) then - call backup_data(gsize,xyzmh_ptmass,vxyz_ptmass,bdata) + call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,bdata) else - call restore_state(gsize,xyzmh_ptmass,vxyz_ptmass,tcoord,t_old,W,W_old,bdata) + call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,tcoord,t_old,W,W_old,bdata) endif t_old = tcoord W_old = W if (gsize>1) then do i=1,ck_size - call drift_TTL (gsize,xyzmh_ptmass,vxyz_ptmass,ds(switch)*ck(i), & - tcoord,W,start_id,end_id) + call drift_TTL (tcoord,W,ds(switch)*ck(i),xyzmh_ptmass,vxyz_ptmass,start_id,end_id) time_table(i) = tcoord - call kick_TTL (gsize,xyzmh_ptmass,vxyz_ptmass,fxyz,gtgrad, & - ds(switch)*dk(i),W,om,start_id,end_id) + call kick_TTL (ds(switch)*dk(i),W,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,start_id,end_id) enddo else - call oneStep_bin(gsize,xyzmh_ptmass,vxyz_ptmass,fxyz,gtgrad, & - ds(switch),tcoord,W,om,time_table,start_id,end_id) + call oneStep_bin(tcoord,W,ds(switch),xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,start_id,end_id) endif dt = tcoord - t_old @@ -295,6 +301,8 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas endif enddo + deallocate(bdata) + end subroutine integrate_to_time @@ -320,7 +328,7 @@ subroutine new_ds_sync_sup(ds,time_table,tnext,switch) real, intent(in) :: tnext integer, intent(in) :: switch integer :: i,k - real :: tp,dtk,dstmp + real :: tp,dtc,dstmp do i=1,ck_size k = cck_sorted_id(i) if(tnext 0) then call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info) + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) endif else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 62b0ed4f6..b8f2d249d 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -105,7 +105,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use timestep, only:dterr,bignumber,tolv use mpiutils, only:reduceall_mpi use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fsink_old,ibin_wake - use part, only:n_group,n_ingroup,n_sing,gtgrad,group_info + use part, only:n_group,n_ingroup,n_sing,gtgrad,group_info,nmatrix use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax @@ -256,7 +256,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) elseif(use_regnbody) then call step_extern_subsys(dtextforce,dtsph,t,npart,nptmass,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass, & - fsink_old,gtgrad,group_info,n_group,n_ingroup,n_sing) + fsink_old,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) else call step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) From 4902d9645058da9ddd174f16cd97582f63076a9b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 16:38:30 +1000 Subject: [PATCH 379/814] (readwrite_dumps) cleanup: remove ifdefs #55 and move helper routines into utility modules --- src/main/mpi_utils.F90 | 59 ++++++++ src/main/readwrite_dumps_fortran.F90 | 211 +++++---------------------- src/main/utils_dumpfiles.f90 | 89 +++++++++++ 3 files changed, 186 insertions(+), 173 deletions(-) diff --git a/src/main/mpi_utils.F90 b/src/main/mpi_utils.F90 index e725bc020..03816c05d 100644 --- a/src/main/mpi_utils.F90 +++ b/src/main/mpi_utils.F90 @@ -110,6 +110,7 @@ module mpiutils public :: fill_buffer, unfill_buf public :: reduceloc_mpi public :: waitmyturn,endmyturn + public :: start_threadwrite,end_threadwrite private @@ -227,6 +228,64 @@ subroutine endmyturn(myid) end subroutine endmyturn +!-------------------------------------------------------------------- +!+ +! utility for initialising each thread +!+ +!-------------------------------------------------------------------- +subroutine start_threadwrite(id,iunit,filename) +#ifdef MPI + use mpi +#endif + use io, only:error,iverbose + implicit none + integer, intent(in) :: id, iunit + character(len=*), intent(in) :: filename + integer :: nowgo,ierr + + if (iverbose >= 3) print *,id,' : starting write...' + nowgo = 0 + if (id > 0) then +#ifdef MPI + call MPI_RECV(nowgo,1,MPI_INTEGER,id-1,99,MPI_COMM_WORLD,status,mpierr) +#endif + open(unit=iunit,file=filename,status='old',form='unformatted',position='append',iostat=ierr) + if (ierr /= 0) then + call error('start_threadwrite','can''t append to dumpfile '//trim(filename)) + else + if (iverbose >= 3) print*,'thread ',id,': opened file '//trim(filename) + endif + endif + +end subroutine start_threadwrite + +!-------------------------------------------------------------------- +!+ +! utility for finalising each thread +!+ +!-------------------------------------------------------------------- +subroutine end_threadwrite(id) + use io, only:iverbose +#ifdef MPI + use mpi + use io, only:nprocs +#endif + implicit none + integer, intent(in) :: id +#ifdef MPI + integer :: nowgo +#endif + + if (iverbose >= 3) print *,' thread ',id,' : finished write.' +#ifdef MPI + if (id < nprocs-1) then + nowgo = 1 + call MPI_SEND(nowgo,1,MPI_INTEGER,id+1,99,MPI_COMM_WORLD,mpierr) + endif +#endif + +end subroutine end_threadwrite + !-------------------------------------------------------------------- !+ ! MPI barrier interface (no-op if called in non-mpi code) diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 7a20b5480..e0ceb38e1 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -39,144 +39,6 @@ module readwrite_dumps_fortran private contains -!-------------------------------------------------------------------- -!+ -! utility to determine whether to read a particular block -! in the dump file, in whole or in part. -! Allows limited changes to number of threads. -!+ -!-------------------------------------------------------------------- -subroutine get_blocklimits(npartblock,nblocks,nthreads,id,iblock,noffset,npartread) - use io, only:die,fatal - integer(kind=8), intent(in) :: npartblock - integer, intent(in) :: nblocks,nthreads,id,iblock - integer, intent(out) :: noffset,npartread - integer :: nblocksperthread,nthreadsperblock - character(len=15), parameter :: tag = 'get_blocklimits' -! -!--check for errors in input -! - if (npartblock < 0) call fatal(tag,'block in dump file has npartinblock < 0') - if (npartblock > huge(npartread)) call fatal(tag,'npart in block exceeds 32 bit limit') -! -!--usual situation: nblocks = nprocessors -! read whole block if id = iblock -! - if (nblocks==nthreads) then - if (id==iblock-1) then - !--read whole block - npartread = int(npartblock) - noffset = 0 - else - !--do not read block - npartread = 0 - noffset = 0 - endif - - elseif (nblocks > nthreads .and. mod(nblocks,nthreads)==0) then -! -!--if more blocks than processes and nblocks exactly divisible by nthreads, -! then just read more than one block per thread -! - nblocksperthread = nblocks/nthreads - if (id==(iblock-1)/nblocksperthread) then - npartread = int(npartblock) - noffset = 0 - else - npartread = 0 - noffset = 0 - endif - - elseif (nthreads > nblocks .and. mod(nthreads,nblocks)==0) then -! -!--if more threads than blocks, and exactly divisible, read fractions of blocks only -! - nthreadsperblock = nthreads/nblocks - if (id/nthreadsperblock==iblock-1) then - npartread = int((npartblock-1)/nthreadsperblock) + 1 - noffset = mod(id,nthreadsperblock)*npartread - - if (mod(id,nthreadsperblock)==nthreadsperblock-1) then - !--last thread has remainder for non-exactly divisible numbers of particles - npartread = int(npartblock) - (nthreadsperblock-1)*npartread - !--die if we would need to load balance between more than the last processor. - if (npartread < 0) then - print*,' npart to read from last block =',npartread - call fatal(tag,'error assigning npart to last thread') - endif - endif - else - npartread = 0 - noffset = 0 - endif - else - noffset = 0 - npartread = 0 - print*,' ERROR: rearrangement of ',nblocks,' blocks to ',nthreads,' threads not implemented' - call die - endif - -end subroutine get_blocklimits - -!-------------------------------------------------------------------- -!+ -! utility for initialising each thread -!+ -!-------------------------------------------------------------------- -subroutine start_threadwrite(id,iunit,filename) -#ifdef MPI - use mpi - use mpiutils, only:status,mpierr -#endif - use io, only:fatal,iverbose - implicit none - integer, intent(in) :: id, iunit - character(len=*), intent(in) :: filename - integer :: nowgo,ierr - - if (iverbose >= 3) print *,id,' : starting write...' - nowgo = 0 - if (id > 0) then -#ifdef MPI - call MPI_RECV(nowgo,1,MPI_INTEGER,id-1,99,MPI_COMM_WORLD,status,mpierr) -#endif - open(unit=iunit,file=filename,status='old',form='unformatted',position='append',iostat=ierr) - if (ierr /= 0) then - call fatal('start_threadwrite','can''t append to dumpfile '//trim(filename)) - else - if (iverbose >= 3) print*,'thread ',id,': opened file '//trim(filename) - endif - endif - -end subroutine start_threadwrite - -!-------------------------------------------------------------------- -!+ -! utility for finalising each thread -!+ -!-------------------------------------------------------------------- -subroutine end_threadwrite(id) - use io, only:iverbose -#ifdef MPI - use mpi - use mpiutils, only:mpierr - use io, only:nprocs -#endif - implicit none - integer, intent(in) :: id -#ifdef MPI - integer :: nowgo -#endif - - if (iverbose >= 3) print *,' thread ',id,' : finished write.' -#ifdef MPI - if (id < nprocs-1) then - nowgo = 1 - call MPI_SEND(nowgo,1,MPI_INTEGER,id+1,99,MPI_COMM_WORLD,mpierr) - endif -#endif - -end subroutine end_threadwrite !-------------------------------------------------------------------- !+ @@ -187,7 +49,7 @@ end subroutine end_threadwrite 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 + ind_timesteps,mhd_nonideal,use_krome,h2chemistry,update_muGamma,mpi 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 use part, only:xyzh,xyzh_label,vxyzu,vxyzu_label,Bevol,Bevol_label,Bxyz,Bxyz_label,npart,maxtypes, & @@ -205,7 +67,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) use options, only:use_dustfrac,use_porosity,use_var_comp,icooling use dump_utils, only:tag,open_dumpfile_w,allocate_header,& free_header,write_header,write_array,write_block_header - use mpiutils, only:reduce_mpi,reduceall_mpi + use mpiutils, only:reduce_mpi,reduceall_mpi,start_threadwrite,end_threadwrite use timestep, only:dtmax,idtmax_n,idtmax_frac use part, only:ibin,krome_nmols,T_gas_cool use metric_tools, only:imetric, imet_et @@ -231,21 +93,21 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) !--collect global information from MPI threads ! !--allow non-MPI calls to create MPI dump files -#ifdef MPI - nparttot = reduceall_mpi('+',npart) - call update_npartoftypetot -#else - if (present(ntotal)) then - nparttot = ntotal + if (mpi) then + nparttot = reduceall_mpi('+',npart) call update_npartoftypetot - if (all(npartoftypetot==0)) then - npartoftypetot(1) = ntotal - endif else - nparttot = npart - call update_npartoftypetot + if (present(ntotal)) then + nparttot = ntotal + call update_npartoftypetot + if (all(npartoftypetot==0)) then + npartoftypetot(1) = ntotal + endif + else + nparttot = npart + call update_npartoftypetot + endif endif -#endif nblocks = nprocs sphNGdump = .false. @@ -504,7 +366,7 @@ subroutine write_smalldump_fortran(t,dumpfile) rad,rad_label,do_radiation,maxirad,luminosity 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 + use mpiutils, only:reduceall_mpi,start_threadwrite,end_threadwrite real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer(kind=8) :: ilen(4) @@ -626,7 +488,8 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie maxphase,isetphase,nptmass,nsinkproperties,maxptmass,get_pmass, & xyzmh_ptmass,vxyz_ptmass use dump_utils, only:get_dump_size,skipblock,skip_arrays,check_tag,lenid,ndatatypes,read_header, & - open_dumpfile_r,get_error_text,ierr_realsize,free_header,read_block_header + open_dumpfile_r,get_error_text,ierr_realsize,free_header,read_block_header,& + get_blocklimits use mpiutils, only:reduce_mpi,reduceall_mpi use sphNGutils, only:convert_sinks_sphNG,mass_sphng use options, only:use_dustfrac @@ -646,6 +509,7 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie logical :: tagged,phantomdump,smalldump real :: dumr,alphafile character(len=lenid) :: fileidentr + character(len=12) :: string type(dump_h) :: hdr integer :: i,ierrh @@ -778,7 +642,11 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie ! Also handles MPI -> non-MPI dump conversion and vice-versa. ! Can be used by non-MPI codes to read isolated blocks only. ! - call get_blocklimits(nhydrothisblock,nblocks,nprocs,id,iblock,noffset,npartread) + call get_blocklimits(nhydrothisblock,nblocks,nprocs,id,iblock,noffset,npartread,ierr) + if (ierr /= 0) then + call error('read_dump','could not map blocks in dump to number of threads') + return + endif i1 = i2 + 1 i2 = i1 + (npartread - 1) npart = npart + npartread @@ -791,13 +659,10 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie endif cycle overblocks elseif (npartread > 0) then -#ifdef MPI - write(*,"(a,i5,2(a,i10),a,i5,a,i10,'-',i10)") & - 'thread ',id,' reading particles ',noffset+1,':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 -#else - write(*,"(2(a,i10),a,i5,a,i10,'-',i10)") & - ' reading particles ',noffset+1,':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 -#endif + string = '' + if (nprocs > 1) write(string,'(a,i5)') 'thread',iblock + write(*,"(2(a,i10),a,i5,a,i10,'-',i10)") trim(string)//' reading particles ',noffset+1,& + ':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 else write(*,"(a,i10,a)") ' WARNING! block contains no SPH particles, reading ',nptmass,' point mass particles only' endif @@ -889,7 +754,7 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro use part, only:npart,npartoftype,maxtypes,nptmass,nsinkproperties,maxptmass, & massoftype use dump_utils, only:skipblock,skip_arrays,check_tag,open_dumpfile_r,get_error_text,& - ierr_realsize,read_header,extract,free_header,read_block_header + ierr_realsize,read_header,extract,free_header,read_block_header,get_blocklimits use mpiutils, only:reduce_mpi,reduceall_mpi use options, only:use_dustfrac character(len=*), intent(in) :: dumpfile @@ -907,6 +772,7 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro logical :: tagged,phantomdump,smalldump real :: alphafile character(len=lenid) :: fileidentr + character(len=12) :: string type(dump_h) :: hdr integer :: i @@ -1023,17 +889,19 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro ! Also handles MPI -> non-MPI dump conversion and vice-versa. ! Can be used by non-MPI codes to read isolated blocks only. ! - call get_blocklimits(nhydrothisblock,nblocks,nprocs,id,iblock,noffset,npartread) + call get_blocklimits(nhydrothisblock,nblocks,nprocs,id,iblock,noffset,npartread,ierr) + if (ierr /= 0) then + call error('read_dump','could not map blocks in dump to number of threads') + return + endif i1 = i2 + 1 i2 = i1 + (npartread - 1) npart = npart + npartread -#ifdef MPI if (npart > maxp) then write(*,*) 'npart > maxp in readwrite_dumps' ierr = 1 return endif -#endif if (npartread <= 0 .and. nptmass <= 0) then call skipblock(idisk1,nums(:,1),nums(:,2),nums(:,3),nums(:,4),tagged,ierr) if (ierr /= 0) then @@ -1042,13 +910,10 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro endif cycle overblocks elseif (npartread > 0) then -#ifdef MPI - write(*,"(a,i5,2(a,i10),a,i5,a,i10,'-',i10)") & - 'thread ',id,' reading particles ',noffset+1,':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 -#else - write(*,"(2(a,i10),a,i5,a,i10,'-',i10)") & - ' reading particles ',noffset+1,':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 -#endif + string = '' + if (nprocs > 1) write(string,'(a,i5)') 'thread',iblock + write(*,"(2(a,i10),a,i5,a,i10,'-',i10)") trim(string)//' reading particles ',noffset+1,& + ':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 else write(*,"(a,i10,a)") ' WARNING! block contains no SPH particles, reading ',nptmass,' point mass particles only' endif diff --git a/src/main/utils_dumpfiles.f90 b/src/main/utils_dumpfiles.f90 index 11b73a4ab..875c843d0 100644 --- a/src/main/utils_dumpfiles.f90 +++ b/src/main/utils_dumpfiles.f90 @@ -100,6 +100,7 @@ module dump_utils public :: write_header, read_header public :: allocate_header, free_header public :: print_header + public :: get_blocklimits ! generic interface to extract quantities from header interface extract @@ -1968,6 +1969,94 @@ subroutine read_block_header(nblocks,number,nums,iunit,ierr) end subroutine read_block_header +!-------------------------------------------------------------------- +!+ +! utility to determine whether to read a particular block +! in the dump file, in whole or in part. +! Allows limited changes to number of threads. +!+ +!-------------------------------------------------------------------- +subroutine get_blocklimits(npartblock,nblocks,nthreads,id,iblock,noffset,npartread,ierr) + integer(kind=8), intent(in) :: npartblock + integer, intent(in) :: nblocks,nthreads,id,iblock + integer, intent(out) :: noffset,npartread,ierr + integer :: nblocksperthread,nthreadsperblock + character(len=15), parameter :: tag = 'get_blocklimits' +! +!--check for errors in input +! + ierr = 0 + if (npartblock < 0) then + write(*,*) 'get_blocklimits: block in dump file has npartinblock < 0' + ierr = 1 + elseif (npartblock > huge(npartread)) then + write(*,*) 'get_blocklimits: number of particles in block exceeds 32 bit limit' + ierr = 2 + endif + if (ierr /= 0) return +! +!--usual situation: nblocks = nprocessors +! read whole block if id = iblock +! + if (nblocks==nthreads) then + if (id==iblock-1) then + !--read whole block + npartread = int(npartblock) + noffset = 0 + else + !--do not read block + npartread = 0 + noffset = 0 + endif + + elseif (nblocks > nthreads .and. mod(nblocks,nthreads)==0) then +! +!--if more blocks than processes and nblocks exactly divisible by nthreads, +! then just read more than one block per thread +! + nblocksperthread = nblocks/nthreads + if (id==(iblock-1)/nblocksperthread) then + npartread = int(npartblock) + noffset = 0 + else + npartread = 0 + noffset = 0 + endif + + elseif (nthreads > nblocks .and. mod(nthreads,nblocks)==0) then +! +!--if more threads than blocks, and exactly divisible, read fractions of blocks only +! + nthreadsperblock = nthreads/nblocks + if (id/nthreadsperblock==iblock-1) then + npartread = int((npartblock-1)/nthreadsperblock) + 1 + noffset = mod(id,nthreadsperblock)*npartread + + if (mod(id,nthreadsperblock)==nthreadsperblock-1) then + !--last thread has remainder for non-exactly divisible numbers of particles + npartread = int(npartblock) - (nthreadsperblock-1)*npartread + !--die if we would need to load balance between more than the last processor. + if (npartread < 0) then + print*,' npart to read from last block =',npartread + print*,trim(tag)//' error assigning npart to last thread' + ierr = 3 + return + endif + endif + else + npartread = 0 + noffset = 0 + endif + else + noffset = 0 + npartread = 0 + ierr = 4 + print*,' ERROR: rearrangement of ',nblocks,' blocks to ',nthreads,' threads not implemented' + return + endif + +end subroutine get_blocklimits + !-------------------------------------------------------------------- !+ ! Routine for extracting int*1 array from main block in dump files From 63bd1305637cd4c79119307cd16f440128cdc9c4 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 16:45:49 +1000 Subject: [PATCH 380/814] #55 .F90->.f90 --- .../{readwrite_dumps_fortran.F90 => readwrite_dumps_fortran.f90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/main/{readwrite_dumps_fortran.F90 => readwrite_dumps_fortran.f90} (100%) diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.f90 similarity index 100% rename from src/main/readwrite_dumps_fortran.F90 rename to src/main/readwrite_dumps_fortran.f90 From b6721100a71af54f393d1b5ce9b2e2685145e8e3 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 16:50:00 +1000 Subject: [PATCH 381/814] (setup_binary) bug fix: do not set oblateness by default --- src/setup/setup_binary.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 28a0efac9..796c97f53 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -75,6 +75,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& integer :: ierr,i,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 + logical, parameter :: set_oblateness = .false. ! !--general parameters ! @@ -192,7 +193,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& accradius1 = xyzmh_ptmass(ihacc,nptmass+1) xyzmh_ptmass(:,nptmass) = xyzmh_ptmass(:,nptmass+1) vxyz_ptmass(:,nptmass) = vxyz_ptmass(:,nptmass+1) - else + elseif (set_oblateness) then ! set J2 for sink particle 1 to be equal to oblateness of Saturn xyzmh_ptmass(iJ2,1) = 0.01629 angle = 30.*deg_to_rad From aaff1cb07293e9d10fb36a406aa03a6bf1b9fd91 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 16:52:29 +1000 Subject: [PATCH 382/814] fix typo --- src/main/ptmass.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 1aa9b797d..ec5b1f2fd 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -2139,7 +2139,7 @@ subroutine write_options_ptmass(iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) call write_inopt(use_fourthorder, 'use_fourthorder', 'FSI integration method (4th order)', iunit) - call write_inopt(use_regnbody, 'use_regnboby', 'Subsystem (SD and secular and AR) integration method', iunit) + call write_inopt(use_regnbody, 'use_regnbody', 'Subsystem (SD and secular and AR) integration method', iunit) end subroutine write_options_ptmass From e932154a29c35cb5786c13eedd15edf3e37f2e4a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 17:15:02 +1000 Subject: [PATCH 383/814] fix group detection... --- src/main/sdar_group.f90 | 39 +++++++++++++++++++++++---------------- 1 file changed, 23 insertions(+), 16 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index b7c2eaa38..049b8130f 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -28,6 +28,7 @@ module sdar_group ! !----------------------------------------------- subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + use io ,only:id,master,iverbose,iprint real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer, intent(inout) :: group_info(:,:) integer(kind=1), intent(inout) :: nmatrix(:,:) @@ -37,26 +38,31 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm n_group = 0 n_ingroup = 0 n_sing = 0 + call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + if (id==master .and. iverbose>1) then + write(iprint,"(i6,a,i6,a,i6,a)") n_group," groups identified, ",n_ingroup," in a group, ",n_sing," singles..." + endif + end subroutine group_identify subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) use part, only : igarg,igcum - use dim, only : maxptmass - integer(kind=1), intent(in) :: nmatrix(:,:) - integer, intent(out) :: group_info(:,:) - integer, intent(in) :: nptmass - integer, intent(inout) :: n_group,n_ingroup,n_sing + integer, intent(in) :: nptmass + integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) + integer, intent(inout) :: group_info(2,nptmass) + integer, intent(inout) :: n_group,n_ingroup,n_sing integer :: i,ncg - logical :: visited(maxptmass) - integer :: stack(maxptmass) + logical :: visited(nptmass) + visited = .false. + group_info(igcum,1) = 1 do i=1,nptmass if(.not.visited(i)) then n_ingroup = n_ingroup + 1 - call dfs(i,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) + call dfs(i,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) if (ncg>1)then n_group = n_group + 1 group_info(igcum,n_group+1) = ncg + group_info(igcum,n_group) @@ -69,15 +75,15 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) enddo end subroutine form_group -subroutine dfs(iroot,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) +subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) use part, only : igarg - integer, intent(in) :: nptmass,iroot - integer, intent(out) :: ncg - integer(kind=1), intent(in) :: nmatrix(:,:) - integer, intent(inout) :: group_info(:,:) - integer, intent(inout) :: n_ingroup - integer, intent(out) :: stack(:) - logical, intent(inout) :: visited(:) + integer, intent(in) :: nptmass,iroot + integer, intent(out) :: ncg + integer(kind=1), intent(in) :: nmatrix(nptmass,nptmass) + integer, intent(inout) :: group_info(2,nptmass) + integer, intent(inout) :: n_ingroup + logical, intent(inout) :: visited(nptmass) + integer :: stack(nptmass) integer :: j,stack_top,inode ncg = 1 @@ -92,6 +98,7 @@ subroutine dfs(iroot,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) do j= 1,nptmass if (nmatrix(inode,j)==1 .and. .not.(visited(j))) then n_ingroup = n_ingroup + 1 + ncg = ncg + 1 stack_top = stack_top + 1 stack(stack_top) = j visited(j) = .true. From 2965aff499c0b16458b75384b64c35787be98f6d Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 20:10:05 +1000 Subject: [PATCH 384/814] (setup_binary) ifort warning fixed --- src/setup/setup_binary.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 796c97f53..311183cc6 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -62,6 +62,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& use centreofmass, only:reset_centreofmass use setunits, only:mass_unit,dist_unit use physcon, only:deg_to_rad + use kernel, only:hfact_default integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -84,6 +85,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& time = 0. polyk = 0. gamma = 1. + hfact = hfact_default ! !--space available for injected gas particles ! in case only sink particles are used From e9421ec6debec56fb7bc2c221e3366e1fc977239 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 20:10:26 +1000 Subject: [PATCH 385/814] (prompting) add missing implicit none --- src/utils/prompting.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/prompting.f90 b/src/utils/prompting.f90 index c87e5f77c..b68033c5f 100644 --- a/src/utils/prompting.f90 +++ b/src/utils/prompting.f90 @@ -104,7 +104,7 @@ module prompting ! 06/05/11: D. Price: ! Added prompt for integer arrays ! - + implicit none private ! @@ -492,7 +492,7 @@ recursive subroutine string_prompt(text, string, length, case, noblank, list) integer, optional, intent(out) :: length integer, optional, intent(in) :: case logical, optional, intent(in) :: noblank - integer :: is, ia + integer :: is,ia,i integer, parameter :: aoffset = 32 logical :: allowblank,inlist character(len=*), intent(in), optional :: list(:) From 8068b748ece1529605bf78e68176662194026b4b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 20:10:54 +1000 Subject: [PATCH 386/814] (set_unifdis) remove obsolete comment --- src/setup/set_unifdis.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/setup/set_unifdis.f90 b/src/setup/set_unifdis.f90 index b4dece1de..782d6c3af 100644 --- a/src/setup/set_unifdis.f90 +++ b/src/setup/set_unifdis.f90 @@ -56,7 +56,6 @@ subroutine set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax, & nptot,npy,npz,npnew_in,rhofunc,massfunc,inputiseed,verbose,centre,dir,geom,mask,err) use random, only:ran2 use stretchmap, only:set_density_profile - !use mpidomain, only:i_belong character(len=*), intent(in) :: lattice integer, intent(in) :: id,master integer, intent(inout) :: np From e4398cbe1c57be1bbcd97213c8cd8e3de2081c74 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 21:24:45 +1000 Subject: [PATCH 387/814] (build) use -warn all with ifort; fix a bunch of ifort compiler warnings; remove unused blocks of commented-out code --- build/Makefile_defaults_ifort | 2 +- src/main/cooling_koyamainutsuka.f90 | 2 + src/main/dtype_kdtree.F90 | 2 + src/main/kdtree.F90 | 18 +-- src/main/metric_minkowski.f90 | 5 +- src/main/mpi_dens.F90 | 3 + src/main/mpi_derivs.F90 | 17 +++ src/main/mpi_force.F90 | 3 + src/main/mpi_tree.F90 | 3 + src/main/ptmass.F90 | 1 + src/main/tmunu2grid.f90 | 166 +--------------------------- src/main/utils_cpuinfo.f90 | 2 +- src/main/utils_datafiles.f90 | 6 +- src/main/utils_omp.F90 | 14 ++- src/utils/interpolate3D.f90 | 4 +- 15 files changed, 58 insertions(+), 190 deletions(-) diff --git a/build/Makefile_defaults_ifort b/build/Makefile_defaults_ifort index 1fb1d19c3..7bea74335 100644 --- a/build/Makefile_defaults_ifort +++ b/build/Makefile_defaults_ifort @@ -1,7 +1,7 @@ # default settings for ifort compiler # override these in the Makefile FC= ifort -FFLAGS= -O3 -inline-factor=500 -shared-intel -warn uninitialized -warn unused -warn truncated_source -no-wrap-margin +FFLAGS= -O3 -inline-factor=500 -shared-intel -warn all -no-wrap-margin DBLFLAG= -r8 DEBUGFLAG= -check all -WB -traceback -g -debug all # -fpe0 -fp-stack-check -debug all -noarg_temp_created #DEBUGFLAG= -g -traceback -check all -check bounds -check uninit -ftrapuv -debug all -warn all,nodec,interfaces,nousage -fpe0 -fp-stack-check -WB -no-diag-error-limit -no-wrap-margin -O0 -noarg_temp_created diff --git a/src/main/cooling_koyamainutsuka.f90 b/src/main/cooling_koyamainutsuka.f90 index eee002b73..2548d180c 100644 --- a/src/main/cooling_koyamainutsuka.f90 +++ b/src/main/cooling_koyamainutsuka.f90 @@ -45,6 +45,7 @@ subroutine init_cooling_KI02(ierr) use units, only:utime,umass,udist integer, intent(out) :: ierr + ierr = 0 LambdaKI_coef = GammaKI_cgs*umass*utime**3/(mass_proton_cgs**2 * udist**5) GammaKI = GammaKI_cgs*utime**3/(mass_proton_cgs*udist**2) call init_hv4table(ierr) @@ -229,6 +230,7 @@ subroutine read_options_cooling_KI02(name,valstring,imatch,igotall,ierr) imatch = .true. igotall = .true. ! nothing to read + ierr = 0 end subroutine read_options_cooling_KI02 diff --git a/src/main/dtype_kdtree.F90 b/src/main/dtype_kdtree.F90 index 6cf50144f..fcb1a04f5 100644 --- a/src/main/dtype_kdtree.F90 +++ b/src/main/dtype_kdtree.F90 @@ -51,9 +51,11 @@ module dtypekdtree real :: xcen(ndimtree) real :: size real :: hmax + real :: dum ! avoid ifort warning: align on 4-byte boundary integer :: leftchild integer :: rightchild integer :: parent + integer :: idum ! avoid ifort warning: align on 4-byte boundary #ifdef GRAVITY real :: mass real :: quads(6) diff --git a/src/main/kdtree.F90 b/src/main/kdtree.F90 index 9b70a7f1f..e9a0c9e9f 100644 --- a/src/main/kdtree.F90 +++ b/src/main/kdtree.F90 @@ -30,8 +30,6 @@ module kdtree integer, public, allocatable :: inoderange(:,:) integer, public, allocatable :: inodeparts(:) type(kdnode), allocatable :: refinementnode(:) - integer, allocatable :: list(:) - !$omp threadprivate(list) ! !--tree parameters @@ -81,9 +79,6 @@ subroutine allocate_kdtree call allocate_array('inoderange', inoderange, 2, ncellsmax+1) call allocate_array('inodeparts', inodeparts, maxp) if (mpi) call allocate_array('refinementnode', refinementnode, ncellsmax+1) - !$omp parallel - call allocate_array('list', list, maxp) - !$omp end parallel end subroutine allocate_kdtree @@ -93,10 +88,6 @@ subroutine deallocate_kdtree if (allocated(inodeparts)) deallocate(inodeparts) if (mpi .and. allocated(refinementnode)) deallocate(refinementnode) - !$omp parallel - if (allocated(list)) deallocate(list) - !$omp end parallel - end subroutine deallocate_kdtree @@ -206,7 +197,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, list, .false.) + ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, .false.) if (wassplit) then ! add children to back of queue if (istack+2 > istacksize) call fatal('maketree',& @@ -256,7 +247,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, list, .false.) + ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, .false.) if (wassplit) then ! add children to top of stack if (istack+2 > istacksize) call fatal('maketree',& @@ -465,7 +456,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, list, & + ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, & global_build) use dim, only:maxtypes,mpi use part, only:massoftype,igas,iamtype,maxphase,maxp,npartoftype @@ -484,7 +475,6 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, integer, intent(inout) :: maxlevel, minlevel real, intent(in) :: xyzh(:,:) logical, intent(out) :: wassplit - integer, intent(out) :: list(:) ! not actually sent out, but to avoid repeated memory allocation/deallocation logical, intent(in) :: global_build real :: xyzcofm(ndim) @@ -1552,7 +1542,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, list, & + ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, & .true.) if (.not.wassplit) then diff --git a/src/main/metric_minkowski.f90 b/src/main/metric_minkowski.f90 index 3562abad8..8164301c0 100644 --- a/src/main/metric_minkowski.f90 +++ b/src/main/metric_minkowski.f90 @@ -202,8 +202,9 @@ subroutine read_options_metric(name,valstring,imatch,igotall,ierr) logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr - ! imatch = .true. - ! igotall = .true. + imatch = .true. + igotall = .true. + ierr = 0 end subroutine read_options_metric diff --git a/src/main/mpi_dens.F90 b/src/main/mpi_dens.F90 index d578658e3..5948afce0 100644 --- a/src/main/mpi_dens.F90 +++ b/src/main/mpi_dens.F90 @@ -74,6 +74,7 @@ module mpidens integer :: maxlength = 0 integer :: n = 0 integer :: number + integer :: idum ! to avoid ifort warning end type stackdens contains @@ -227,6 +228,8 @@ subroutine free_mpitype_of_celldens(dtype) integer :: mpierr call MPI_Type_free(dtype,mpierr) +#else + dtype = 0 #endif end subroutine free_mpitype_of_celldens diff --git a/src/main/mpi_derivs.F90 b/src/main/mpi_derivs.F90 index a9b2b2641..1847cbd6c 100644 --- a/src/main/mpi_derivs.F90 +++ b/src/main/mpi_derivs.F90 @@ -137,7 +137,12 @@ subroutine init_celldens_exchange(xbufrecv,ireq,thread_complete,ncomplete_mpi,dt ncomplete_mpi = 0 !$omp end master thread_complete(omp_thread_num()+1) = .false. +#else + ncomplete_mpi = 0 + ireq = 0 + dtype = 0 #endif + end subroutine init_celldens_exchange subroutine init_cellforce_exchange(xbufrecv,ireq,thread_complete,ncomplete_mpi,dtype) @@ -177,6 +182,10 @@ subroutine init_cellforce_exchange(xbufrecv,ireq,thread_complete,ncomplete_mpi,d ncomplete_mpi = 0 !$omp end master thread_complete(omp_thread_num()+1) = .false. +#else + ncomplete_mpi = 0 + ireq = 0 + dtype = 0 #endif end subroutine init_cellforce_exchange @@ -209,6 +218,8 @@ subroutine send_celldens(cell,targets,irequestsend,xsendbuf,counters,dtype) counters(newproc+1,isent) = counters(newproc+1,isent) + 1 endif enddo +#else + xsendbuf = cell #endif end subroutine send_celldens @@ -237,6 +248,8 @@ subroutine send_cellforce(cell,targets,irequestsend,xsendbuf,counters,dtype) counters(newproc+1,isent) = counters(newproc+1,isent) + 1 endif enddo +#else + xsendbuf = cell #endif end subroutine send_cellforce @@ -260,6 +273,8 @@ subroutine check_send_finished(irequestsend,idone) enddo !--never test self; always set to true idone(id+1) = .true. +#else + idone = .true. #endif end subroutine check_send_finished @@ -619,6 +634,8 @@ subroutine check_complete(counters,ncomplete_mpi) endif endif enddo +#else + ncomplete_mpi = 1 #endif end subroutine check_complete diff --git a/src/main/mpi_force.F90 b/src/main/mpi_force.F90 index 3dab68ded..2fe66c34f 100644 --- a/src/main/mpi_force.F90 +++ b/src/main/mpi_force.F90 @@ -76,6 +76,7 @@ module mpiforce integer :: maxlength = 0 integer :: n = 0 integer :: number + integer :: ibuffer ! to avoid ifort error end type stackforce contains @@ -236,6 +237,8 @@ subroutine free_mpitype_of_cellforce(dtype) integer :: mpierr call MPI_Type_free(dtype,mpierr) +#else + dtype = 0 #endif end subroutine free_mpitype_of_cellforce diff --git a/src/main/mpi_tree.F90 b/src/main/mpi_tree.F90 index fe49e3c22..8b24ace8c 100644 --- a/src/main/mpi_tree.F90 +++ b/src/main/mpi_tree.F90 @@ -132,6 +132,9 @@ subroutine get_group_cofm(xyzcofm,totmass_node,level,cofmsum,totmassg) call MPI_ALLREDUCE(totmass_node,totmassg,1,MPI_REAL8,MPI_SUM,comm_cofm(level+1),mpierr) call MPI_ALLREDUCE(cofmpart,cofmsum,3,MPI_REAL8,MPI_SUM,comm_cofm(level+1),mpierr) cofmsum = cofmsum / totmassg +#else + cofmsum = xyzcofm*totmass_node + totmassg = totmass_node #endif end subroutine get_group_cofm diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e36d26066..8cf6a0088 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -685,6 +685,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & integer :: j real :: mpt,drdv,angmom2,angmomh2,epart,dxj,dyj,dzj,dvxj,dvyj,dvzj,rj2,vj2,epartj logical :: mostbound +!$ external :: omp_set_lock,omp_unset_lock accreted = .false. ifail = 0 diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index 5d41bbe10..b03307a5b 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -66,16 +66,14 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) weights = weight itype = 1 - !call get_cfac(cfac,rho) - !print*, "Weighting for particle smoothing is: ", weight - !weight = 1. + ! For now we can set this to the origin, but it might need to be ! set to the grid origin of the CCTK_grid since we have boundary points ! TODO This should also be the proper phantom values and not a magic number !xmin(:) = gridorigin(:) - 0.5*dxgrid(:) ! We move the origin back by 0.5*dx to make a pseudo cell-centered grid - xmininterp(1) = xmin -dxgrid(1) !- 0.5*dxgrid(1) - xmininterp(2) = ymin -dxgrid(2) !- 0.5*dxgrid(2) - xmininterp(3) = zmin-dxgrid(3) !- 0.5*dxgrid(3) + xmininterp(1) = xmin - dxgrid(1) !- 0.5*dxgrid(1) + xmininterp(2) = ymin - dxgrid(2) !- 0.5*dxgrid(2) + xmininterp(3) = zmin - dxgrid(3) !- 0.5*dxgrid(3) call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) @@ -97,10 +95,7 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) periodicy = .true. periodicz = .true. - - ! tt component - tmunugrid = 0. datsmooth = 0. @@ -119,7 +114,6 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) enddo enddo enddo -!stop ilendat = 16 call interpolate3D_vecexact(xyzh,weights,dat,ilendat,itype,npart,& @@ -139,113 +133,6 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) !print*, datsmooth((i-1)*4 + j, 10,10,10) enddo enddo -!stop -! do k=1,4 -! do j=1,4 -! do i=1,4 -! print*, "Lock index is: ", (k-1)*16+ (j-1)*4 + i -! enddo -! enddo -! enddo - -! tmunugrid(0,0,:,:,:) = datsmooth(1,:,:,:) - - ! TODO Unroll this loop for speed + using symmetries - ! Possiblly cleanup the messy indexing -! do k=1,4 -! do j=1,4 -! do i=1, npart -! dat(i) = tmunus(k,j,i) -! enddo - -! ! Get the position of the first grid cell x,y,z -! ! Call to interpolate 3D -! ! COMMENTED OUT AS NOT USED BY NEW INTERPOLATE ROUTINE -! ! call interpolate3D(xyzh,weight,npart, & -! ! xmininterp,tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper), & -! ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) - -! !print*, "Interpolated grid values are: ", datsmooth(4:38,4:38,4:38) -! !stop -! ! NEW INTERPOLATION ROUTINE -! call interpolate3D(xyzh,weights,dat,itype,npart,& -! xmininterp(1),xmininterp(2),xmininterp(3), & -! tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper),& -! ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& -! normalise,periodicx,periodicy,periodicz) -! enddo -! enddo - - ! RHOSTARGRID CALCULATION IS NOW HANDLED BY AN EXTERNAL ROUTINE - ! THIS IS COMMENTED OUT IN CASE I BREAK EVERYTHING AND NEED TO GO BACK - ! Get the conserved density on the particles - ! dat = 0. - ! do i=1, npart - ! ! Get the smoothing length - ! h = xyzh(4,i) - ! ! Get pmass - ! pmass = massoftype(igas) - ! rho = rhoh(h,pmass) - ! dat(i) = rho - ! enddo - - ! Commented out as not used by new interpolate routine - ! call interpolate3D(xyzh,weight,npart, & - ! xmininterp,rhostargrid(ilower:iupper,jlower:jupper,klower:kupper), & - ! nnodes,dxgrid,.true.,dat,ngrid,vertexcen) - - - ! Calculate the total mass on the grid - !totalmassgrid = 0. - ! do i=ilower,iupper - ! do j=jlower,jupper - ! do k=klower, kupper - ! totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) - - ! enddo - ! enddo - ! enddo - ! Explicitly set pressure to be 0 - ! Need to do this in the phantom setup file later - ! tmunugrid(1,0:3,:,:,:) = 0. - ! tmunugrid(2,0:3,:,:,:) = 0. - ! tmunugrid(3,0:3,:,:,:) = 0. - !tmunugrid(0,0,:,:,:) = tmunus(1,1,1) - ! Correction for kernel bias code - ! Hardcoded values for the cubic spline computed using - ! a constant density flrw universe. - ! Ideally this should be in a more general form - ! cfac = totalmass/totalmassgrid - ! ! Output total mass on grid, total mass on particles - ! ! and the residuals - ! !cfac = 0.99917535781746514D0 - ! tmunugrid = tmunugrid*cfac - ! if (iteration==0) then - ! write(666,*) "iteration ", "Mass(Grid) ", "Mass(Particles) ", "Mass(Grid-Particles)" - ! endif - ! write(666,*) iteration, totalmassgrid, totalmass, abs(totalmassgrid-totalmass) - ! close(unit=666) - ! iteration = iteration + 1 - - ! New rho/smoothing length calc based on correction?? - ! not sure that this is a valid thing to do - ! do i=1, npart - ! rho = rhoh(xyzh(i,4),pmass) - ! rho = rho*cfac - ! xyzh(i,4) = hfact*(pmass/rho)**(1./3.) - - ! enddo - - ! Correct rhostargrid using cfac - !rhostargrid = cfac*rhostargrid - - ! Calculate rho(prim), P and e on the grid - ! Apply kernel correction to primatives?? - ! Then calculate a stress energy tensor per grid and fill tmunu - ! A good consistency check would be to do it both ways and compare values - - ! Primative density - end subroutine get_tmunugrid_all @@ -257,38 +144,6 @@ subroutine get_weight(pmass,h,rhoi,weight) end subroutine get_weight -subroutine get_dat(tmunus,dat) - real, intent(in) :: tmunus - real, intent(out) :: dat - -end subroutine get_dat - - ! subroutine get_primdens(dens,dat) - ! real, intent(in) :: dens - ! real, intent(out) :: dat - ! integer :: i, npart - - ! ! Get the primative density on the particles - ! dat = 0. - ! do i=1, npart - ! dat(i) = dens(i) - ! enddo - - ! end subroutine get_primdens - - ! subroutine get_4velocity(vxyzu,dat) - ! real, intent(in) :: vxyzu(:,:) - ! real, intent(out) :: dat(:,:) - ! integer :: i,npart - - ! ! Get the primative density on the particles - ! dat = 0. - ! do i=1, npart - ! dat(:,i) = vxyzu(1:3,i) - ! enddo - - ! end subroutine get_4velocity - subroutine get_particle_domain(gridorigin,xmin,xmax,dxgrid,ilower,iupper) real, intent(in) :: gridorigin, xmin,xmax, dxgrid integer, intent(out) :: ilower, iupper @@ -316,8 +171,6 @@ subroutine interpolate_to_grid(gridarray,dat) use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax use part, only:npart,xyzh,massoftype,igas,rhoh real :: weight,h,rho,pmass - !real, save :: cfac - !integer, save :: iteration = 0 real :: xmininterp(3) integer :: ngrid(3) integer :: nnodes,i, ilower, iupper, jlower, jupper, klower, kupper @@ -329,7 +182,6 @@ subroutine interpolate_to_grid(gridarray,dat) real, intent(in) :: dat(:) ! The particle data to interpolate to grid real, allocatable :: interparray(:,:,:) - xmininterp(1) = xmin - dxgrid(1)!- 0.5*dxgrid(1) xmininterp(2) = ymin - dxgrid(2) !- 0.5*dxgrid(2) xmininterp(3) = zmin - dxgrid(3) !- 0.5*dxgrid(3) @@ -355,8 +207,6 @@ subroutine interpolate_to_grid(gridarray,dat) periodicy = .true. periodicz = .true. - - do i=1, npart h = xyzh(4,i) ! Get pmass @@ -372,14 +222,10 @@ subroutine interpolate_to_grid(gridarray,dat) ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) call interpolate3D(xyzh,weights,dat,itype,npart,& xmininterp(1),xmininterp(2),xmininterp(3), & - !interparray, & gridarray(ilower:iupper,jlower:jupper,klower:kupper),& ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& normalise,periodicx,periodicy,periodicz) - - - end subroutine interpolate_to_grid subroutine check_conserved_dens(rhostargrid,cfac) @@ -391,7 +237,6 @@ subroutine check_conserved_dens(rhostargrid,cfac) real :: totalmassgrid,totalmasspart integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper - call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) @@ -401,7 +246,6 @@ subroutine check_conserved_dens(rhostargrid,cfac) do j=jlower,jupper do k=klower, kupper totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) - enddo enddo enddo @@ -452,4 +296,4 @@ subroutine check_conserved_p(pgrid,cfac) end subroutine check_conserved_p -end module tmunu2grid +end module tmunu2grid \ No newline at end of file diff --git a/src/main/utils_cpuinfo.f90 b/src/main/utils_cpuinfo.f90 index 5e50794c9..a8d49006b 100644 --- a/src/main/utils_cpuinfo.f90 +++ b/src/main/utils_cpuinfo.f90 @@ -105,7 +105,7 @@ subroutine get_cpuinfo(ncpu,ncpureal,cpuspeed,cpumodel,cachesize,ierr) !--On a Mac, we have to use the sysctl utility ! tempfile='cpuinfo.tmp' - call system('sysctl -a hw machdep > '//trim(tempfile)) + call execute_command_line('sysctl -a hw machdep > '//trim(tempfile)) !--check to see if this file exists inquire(file=tempfile,exist=iexist) if (iexist) then diff --git a/src/main/utils_datafiles.f90 b/src/main/utils_datafiles.f90 index f3212a0dd..f994d58b3 100644 --- a/src/main/utils_datafiles.f90 +++ b/src/main/utils_datafiles.f90 @@ -161,7 +161,7 @@ subroutine retrieve_remote_file(url,file,dir,localfile,ierr) ierr = 0 ! check that wget utility exists !call execute_command_line('type -p wget > /dev/null',wait=.true.,exitstat=ierr,cmdstat=ierr1) - call system('type -p curl > /dev/null') + call execute_command_line('type -p curl > /dev/null') if (ierr /= 0) then print "(a)",' ERROR: curl utility does not exist' @@ -169,11 +169,11 @@ subroutine retrieve_remote_file(url,file,dir,localfile,ierr) if (len_trim(dir) > 0) then !call execute_command_line(trim(cmd)//' '//trim(url)//trim(file)//' -O '//trim(dir)//trim(file),wait=.true.,& ! exitstat=ierr,cmdstat=ierr1) - call system(trim(cmd)//' '//trim(url)//trim(file)//' -o '//trim(dir)//trim(file)) + call execute_command_line(trim(cmd)//' '//trim(url)//trim(file)//' -o '//trim(dir)//trim(file)) localfile = trim(dir)//trim(file) else !call execute_command_line(trim(cmd)//' '//trim(url)//trim(file),wait=.true.,exitstat=ierr,cmdstat=ierr1) - call system(trim(cmd)//' '//trim(url)//trim(file)//' -o '//trim(file)) + call execute_command_line(trim(cmd)//' '//trim(url)//trim(file)//' -o '//trim(file)) localfile = trim(file) endif endif diff --git a/src/main/utils_omp.F90 b/src/main/utils_omp.F90 index 07b462298..eca6876fc 100644 --- a/src/main/utils_omp.F90 +++ b/src/main/utils_omp.F90 @@ -33,7 +33,7 @@ module omputils !---------------------------------------------------------------- subroutine info_omp #ifdef _OPENMP - integer omp_get_num_threads + integer, external :: omp_get_num_threads !$omp parallel !$omp master @@ -57,7 +57,8 @@ end subroutine info_omp subroutine init_omp #ifdef _OPENMP !$ integer :: i - integer :: omp_get_num_threads +!$ external :: omp_init_lock + integer, external :: omp_get_num_threads !$ do i = 0, nlocks !$ call omp_init_lock(ipart_omp_lock(i)) @@ -83,8 +84,8 @@ subroutine limits_omp (n1,n2,i1,i2) integer, intent(in) :: n1,n2 integer, intent(out) :: i1,i2 #ifdef _OPENMP - integer :: omp_get_num_threads, omp_get_thread_num - logical :: omp_in_parallel + integer, external :: omp_get_num_threads, omp_get_thread_num + logical, external :: omp_in_parallel if (omp_in_parallel()) then i1 = n1 + ((omp_get_thread_num() )*n2)/omp_get_num_threads() @@ -112,7 +113,8 @@ subroutine limits_omp_work (n1,n2,i1,i2,work,mask,iskip) integer, intent(in) :: mask(n2) #ifdef _OPENMP - integer :: omp_get_num_threads, omp_get_thread_num, num_threads,id + integer, external :: omp_get_num_threads, omp_get_thread_num + integer :: num_threads,id real :: chunk,my_chunk integer :: my_thread,i @@ -158,7 +160,7 @@ end subroutine limits_omp_work integer function omp_thread_num() #ifdef _OPENMP - integer :: omp_get_thread_num + integer, external :: omp_get_thread_num omp_thread_num = omp_get_thread_num() #else omp_thread_num = 0 diff --git a/src/utils/interpolate3D.f90 b/src/utils/interpolate3D.f90 index 95fe2d7d6..3b9e849f5 100644 --- a/src/utils/interpolate3D.f90 +++ b/src/utils/interpolate3D.f90 @@ -85,7 +85,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !logical, parameter :: exact_rendering = .true. ! use exact rendering y/n integer :: usedpart, negflag -!$ integer :: omp_get_num_threads,omp_get_thread_num +!$ integer, external :: omp_get_num_threads,omp_get_thread_num integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits ! Fill the particle data with xyzh @@ -425,7 +425,7 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& integer :: usedpart, negflag -!$ integer :: omp_get_num_threads,omp_get_thread_num +!$ integer, external :: omp_get_num_threads,omp_get_thread_num integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits ! Fill the particle data with xyzh From f6b509020e1fd3aa03c6276a48e1f12ece00be6c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 21:34:58 +1000 Subject: [PATCH 388/814] fix #516 --- src/main/tmunu2grid.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index b03307a5b..ea91589c1 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -232,8 +232,8 @@ subroutine check_conserved_dens(rhostargrid,cfac) use part, only:npart,massoftype,igas use einsteintk_utils, only: dxgrid, gridorigin use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax - real, intent(in) :: rhostargrid(:,:,:) - real(kind=16), intent(out) :: cfac + real, intent(in) :: rhostargrid(:,:,:) + real, intent(out) :: cfac real :: totalmassgrid,totalmasspart integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper @@ -266,8 +266,8 @@ subroutine check_conserved_p(pgrid,cfac) use part, only:npart,massoftype,igas use einsteintk_utils, only: dxgrid, gridorigin use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax - real, intent(in) :: pgrid(:,:,:) - real(kind=16), intent(out) :: cfac + real, intent(in) :: pgrid(:,:,:) + real, intent(out) :: cfac real :: totalmomentumgrid,totalmomentumpart integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper From 9e0e641061c17077411005d864e26ea89ac02eb3 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 21:44:41 +1000 Subject: [PATCH 389/814] fix build failure, fixes #516 --- src/utils/einsteintk_wrapper.f90 | 68 ++++++-------------------------- 1 file changed, 13 insertions(+), 55 deletions(-) diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 8bd6b847b..4b9e477eb 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -122,29 +122,6 @@ subroutine et2phantom(rho,nx,ny,nz) ! send grid limits end subroutine et2phantom - ! DONT THINK THIS IS USED ANYWHERE!!! - ! subroutine step_et2phantom(infile,dt_et) - ! use einsteintk_utils - ! use evolve, only:evol_step - ! use tmunu2grid - ! character(len=*), intent(in) :: infile - ! real, intent(inout) :: dt_et - ! character(len=500) :: logfile,evfile,dumpfile,path - - - ! ! Print the values of logfile, evfile, dumpfile to check they are sensible - ! !print*, "logfile, evfile, dumpfile: ", logfile, evfile, dumpfile - ! print*, "stored values of logfile, evfile, dumpfile: ", logfilestor, evfilestor, dumpfilestor - - ! ! Interpolation stuff - ! ! Call et2phantom (construct global grid, metric, metric derivs, determinant) - ! ! Run phantom for a step - ! call evol_step(infile,logfilestor,evfilestor,dumpfilestor,dt_et) - ! ! Interpolation stuff back to et - ! !call get_tmunugrid_all() - ! ! call phantom2et (Tmunu_grid) - - ! end subroutine step_et2phantom subroutine phantom2et() ! should take in the cctk_array for tmunu?? @@ -208,7 +185,7 @@ subroutine et2phantom_tmunu() use linklist, only:set_linklist real :: stressmax - real(kind=16) :: cfac + real :: cfac stressmax = 0. @@ -237,15 +214,13 @@ subroutine et2phantom_tmunu() call check_conserved_dens(rhostargrid,cfac) ! Correct Tmunu - ! Convert to 8byte real to stop compiler warning - tmunugrid = real(cfac)*tmunugrid - + tmunugrid = cfac*tmunugrid 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 + use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& + Bevol,rad,radprop,metrics,igas,rhoh,alphaind,dvdx,gradh use densityforce, only:densityiterate use metric_tools, only:init_metric use linklist, only:set_linklist @@ -253,7 +228,7 @@ subroutine phantom2et_consvar() use tmunu2grid, only:check_conserved_dens real :: stressmax - real(kind=16) :: cfac + real :: cfac ! Init metric call init_metric(npart,xyzh,metrics) @@ -276,7 +251,6 @@ subroutine phantom2et_consvar() ! Interpolate entropy to grid call phantom2et_entropy - ! Conserved quantity checks + corrections ! Density check vs particles @@ -285,12 +259,9 @@ subroutine phantom2et_consvar() ! Momentum check vs particles ! Correct momentum and Density - ! Conversion of cfac to 8byte real to avoid - ! compiler warning - rhostargrid = real(cfac)*rhostargrid - pxgrid = real(cfac)*pxgrid - entropygrid = real(cfac)*entropygrid - + rhostargrid = cfac*rhostargrid + pxgrid = cfac*pxgrid + entropygrid = cfac*entropygrid end subroutine phantom2et_consvar @@ -348,7 +319,6 @@ subroutine phantom2et_entropy() real :: dat(npart) integer :: i - ! Get new cons density from new particle positions somehow (maybe)? ! Set linklist to update the tree for neighbour finding ! Calculate the density for the new particle positions @@ -385,7 +355,6 @@ subroutine phantom2et_momentum() real :: dat(3,npart) integer :: i - ! Pi is directly updated at the end of each MoL add ! Interpolate from particles to grid @@ -410,12 +379,8 @@ subroutine phantom2et_momentum() ! pz component call interpolate_to_grid(pxgrid(3,:,:,:),dat(3,:)) - - end subroutine phantom2et_momentum - - ! Subroutine for performing a phantom dump from einstein toolkit subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) use einsteintk_utils @@ -506,7 +471,7 @@ subroutine get_metricderivs_all(dtextforce_min,dt_et) dtextforce_min = bignumber !$omp parallel do default(none) & - !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & + !$omp shared(npart,xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & !$omp firstprivate(pri) & !$omp private(i,dtf) & !$omp reduction(min:dtextforce_min) @@ -517,25 +482,18 @@ subroutine get_metricderivs_all(dtextforce_min,dt_et) dtextforce_min = min(dtextforce_min,C_force*dtf) enddo !$omp end parallel do - ! manually add v contribution from gr - ! do i=1, npart - ! !fxyzu(:,i) = fxyzu(:,i) + fext(:,i) - ! vxyzu(1:3,i) = vxyzu(1:3,i) + fext(:,i)*dt_et - ! enddo + end subroutine get_metricderivs_all subroutine get_eos_quantities(densi,en) use cons2prim, only:cons2primall - use part, only:dens,vxyzu,npart,metrics,xyzh,pxyzu,eos_vars + use part, only:dens,vxyzu,npart,metrics,xyzh,pxyzu,eos_vars real, intent(out) :: densi,en - !call h2dens(densi,xyzhi,metrici,vi) ! Compute dens from h - densi = dens(1) ! Feed the newly computed dens back out of the routine - !call cons2primall(npart,xyzh,metrics,vxyzu,dens,pxyzu,.true.) + densi = dens(1) ! Feed the newly computed dens back out of the routine call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) - ! print*,"pxyzu: ",pxyzu(:,1) - ! print*, "vxyzu: ",vxyzu(:,1) en = vxyzu(4,1) + end subroutine get_eos_quantities From 3d196319ae7845ee7c1a14a3339e6377c0ef97a0 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 10 Apr 2024 21:52:34 +1000 Subject: [PATCH 390/814] (ifort) revert -warn all in order to compile Krome --- build/Makefile_defaults_ifort | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build/Makefile_defaults_ifort b/build/Makefile_defaults_ifort index 7bea74335..1fb1d19c3 100644 --- a/build/Makefile_defaults_ifort +++ b/build/Makefile_defaults_ifort @@ -1,7 +1,7 @@ # default settings for ifort compiler # override these in the Makefile FC= ifort -FFLAGS= -O3 -inline-factor=500 -shared-intel -warn all -no-wrap-margin +FFLAGS= -O3 -inline-factor=500 -shared-intel -warn uninitialized -warn unused -warn truncated_source -no-wrap-margin DBLFLAG= -r8 DEBUGFLAG= -check all -WB -traceback -g -debug all # -fpe0 -fp-stack-check -debug all -noarg_temp_created #DEBUGFLAG= -g -traceback -check all -check bounds -check uninit -ftrapuv -debug all -warn all,nodec,interfaces,nousage -fpe0 -fp-stack-check -WB -no-diag-error-limit -no-wrap-margin -O0 -noarg_temp_created From e5fda5acc412490c9da339b49ead45236f974678 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 10 Apr 2024 16:34:33 +0100 Subject: [PATCH 391/814] restoring upstream changes part 1 --- AUTHORS | 31 ------ README.md | 38 +++----- build/Makefile_defaults_aocc | 1 + build/Makefile_fastmath | 4 +- data/forcing/README | 10 ++ docs/developer-guide/index.rst | 3 +- docs/examples/CE.rst | 12 ++- docs/getting-started/gitinfo.rst | 39 +++----- docs/user-guide/hdf5.rst | 32 +++---- scripts/HEADER-module | 2 +- scripts/HEADER-program | 2 +- src/lib/NICIL/src/nicil.F90 | 20 +++- src/main/bondiexact.f90 | 2 +- src/main/bondiexact_gr.f90 | 2 +- src/main/boundary.f90 | 2 +- src/main/boundary_dynamic.f90 | 4 +- src/main/centreofmass.f90 | 2 +- src/main/checkconserved.f90 | 6 +- src/main/checkoptions.F90 | 14 ++- src/main/checksetup.f90 | 95 ++++++++++--------- src/main/config.F90 | 8 +- src/main/cons2prim.f90 | 19 ++-- src/main/cons2primsolver.f90 | 10 +- src/main/cooling.F90 | 18 ++-- src/main/cooling_functions.f90 | 2 +- src/main/cooling_gammie.f90 | 2 +- src/main/cooling_gammie_PL.f90 | 2 +- src/main/cooling_ism.f90 | 2 +- src/main/cooling_koyamainutsuka.f90 | 2 +- src/main/cooling_molecular.f90 | 2 +- src/main/cooling_solver.f90 | 2 +- src/main/cullendehnen.f90 | 11 ++- src/main/datafiles.f90 | 2 +- src/main/eos.F90 | 3 +- src/main/utils_indtimesteps.F90 | 4 +- src/main/utils_inject.f90 | 2 +- src/main/utils_mathfunc.f90 | 2 +- src/main/utils_omp.F90 | 2 +- src/main/utils_raytracer.f90 | 2 +- src/main/utils_shuffleparticles.F90 | 2 +- src/main/utils_sort.f90 | 2 +- src/main/utils_sphNG.f90 | 2 +- src/main/utils_spline.f90 | 2 +- src/main/utils_summary.F90 | 2 +- src/main/utils_supertimestep.F90 | 2 +- src/main/utils_system.f90 | 2 +- src/main/utils_tables.f90 | 2 +- src/main/utils_vectors.f90 | 2 +- src/main/viscosity.f90 | 2 +- src/main/wind.F90 | 24 ++--- src/main/wind_equations.f90 | 10 +- src/main/writeheader.F90 | 2 +- src/utils/acc2ang.f90 | 2 +- src/utils/adaptivemesh.f90 | 2 +- src/utils/analysis_1particle.f90 | 2 +- src/utils/analysis_CoM.f90 | 2 +- src/utils/analysis_GalMerger.f90 | 2 +- src/utils/analysis_MWpdf.f90 | 2 +- src/utils/analysis_NSmerger.f90 | 2 +- src/utils/analysis_alpha.f90 | 2 +- src/utils/analysis_angmom.f90 | 2 +- src/utils/analysis_angmomvec.f90 | 2 +- src/utils/analysis_average_orb_en.f90 | 2 +- src/utils/analysis_binarydisc.f90 | 7 +- src/utils/analysis_bzrms.f90 | 2 +- .../analysis_collidingcloudevolution.f90 | 2 +- .../analysis_collidingcloudhistograms.f90 | 2 +- src/utils/analysis_cooling.f90 | 2 +- src/utils/analysis_disc.f90 | 2 +- src/utils/analysis_disc_MFlow.f90 | 2 +- src/utils/analysis_disc_eccentric.f90 | 2 +- src/utils/analysis_disc_mag.f90 | 2 +- src/utils/analysis_disc_planet.f90 | 2 +- src/utils/analysis_disc_stresses.f90 | 2 +- src/utils/analysis_dtheader.f90 | 2 +- src/utils/analysis_dustmass.f90 | 2 +- src/utils/analysis_dustydisc.f90 | 2 +- src/utils/analysis_etotgr.f90 | 2 +- src/utils/analysis_getneighbours.f90 | 2 +- src/utils/analysis_gws.f90 | 2 +- src/utils/analysis_jet.f90 | 2 +- src/utils/analysis_kepler.f90 | 2 +- src/utils/analysis_macctrace.f90 | 2 +- src/utils/analysis_mapping_mass.f90 | 2 +- src/utils/analysis_mcfost.f90 | 2 +- src/utils/analysis_mcfostcmdline.f90 | 2 +- src/utils/analysis_pairing.f90 | 2 +- src/utils/analysis_particle.f90 | 2 +- src/utils/analysis_pdfs.f90 | 2 +- src/utils/analysis_phantom_dump.f90 | 2 +- src/utils/analysis_polytropes.f90 | 2 +- src/utils/analysis_prdrag.f90 | 2 +- src/utils/analysis_ptmass.f90 | 2 +- src/utils/analysis_raytracer.f90 | 2 +- src/utils/analysis_sinkmass.f90 | 2 +- src/utils/analysis_sphere.f90 | 2 +- src/utils/analysis_structurefn.f90 | 2 +- src/utils/analysis_tde.f90 | 2 +- src/utils/analysis_torus.f90 | 2 +- src/utils/analysis_trackbox.f90 | 2 +- src/utils/analysis_tracks.f90 | 2 +- .../analysis_velocitydispersion_vs_scale.f90 | 2 +- src/utils/analysis_velocityshear.f90 | 2 +- src/utils/combinedustdumps.f90 | 2 +- src/utils/cubicsolve.f90 | 2 +- src/utils/diffdumps.f90 | 2 +- src/utils/dustywaves.f90 | 2 +- src/utils/ev2kdot.f90 | 2 +- src/utils/ev2mdot.f90 | 2 +- src/utils/evol_dustywaves.f90 | 2 +- src/utils/get_struct_slope.f90 | 2 +- src/utils/getmathflags.f90 | 2 +- src/utils/grid2pdf.f90 | 2 +- src/utils/hdf5utils.f90 | 2 +- src/utils/icosahedron.f90 | 2 +- src/utils/io_grid.f90 | 2 +- src/utils/io_structurefn.f90 | 2 +- src/utils/leastsquares.f90 | 2 +- src/utils/libphantom-splash.f90 | 2 +- src/utils/lombperiod.f90 | 2 +- src/utils/mflow.f90 | 2 +- src/utils/moddump_CoM.f90 | 2 +- src/utils/moddump_addflyby.f90 | 2 +- src/utils/moddump_addplanets.f90 | 2 +- src/utils/moddump_binary.f90 | 2 +- src/utils/moddump_binarystar.f90 | 2 +- src/utils/moddump_changemass.f90 | 2 +- src/utils/moddump_default.f90 | 2 +- src/utils/moddump_disc.f90 | 2 +- src/utils/moddump_dustadd.f90 | 2 +- src/utils/moddump_extenddisc.f90 | 2 +- src/utils/moddump_growthtomultigrain.f90 | 2 +- src/utils/moddump_mergepart.f90 | 2 +- src/utils/moddump_messupSPH.f90 | 2 +- src/utils/moddump_perturbgas.f90 | 2 +- src/utils/moddump_polytrope.f90 | 2 +- src/utils/moddump_rad_to_LTE.f90 | 4 +- src/utils/moddump_recalcuT.f90 | 2 +- .../moddump_removeparticles_cylinder.f90 | 2 +- src/utils/moddump_removeparticles_radius.f90 | 2 +- src/utils/moddump_rotate.f90 | 2 +- src/utils/moddump_sink.f90 | 4 +- src/utils/moddump_sinkbinary.f90 | 2 +- src/utils/moddump_sphNG2phantom.f90 | 2 +- src/utils/moddump_sphNG2phantom_addBfield.f90 | 2 +- src/utils/moddump_sphNG2phantom_disc.f90 | 2 +- src/utils/moddump_splitpart.f90 | 2 +- src/utils/moddump_taylorgreen.f90 | 2 +- src/utils/moddump_tidal.f90 | 2 +- src/utils/moddump_torus.f90 | 2 +- src/utils/multirun.f90 | 2 +- src/utils/multirun_mach.f90 | 2 +- src/utils/pdfs.f90 | 2 +- src/utils/phantom2divb.f90 | 2 +- src/utils/phantom2divv.f90 | 2 +- src/utils/phantom2gadget.f90 | 2 +- src/utils/phantom2hdf5.f90 | 2 +- src/utils/phantom2sphNG.f90 | 2 +- src/utils/phantom_moddump.f90 | 2 +- src/utils/phantomanalysis.f90 | 5 +- src/utils/phantomevcompare.f90 | 2 +- src/utils/phantomextractsinks.f90 | 2 +- src/utils/plot_kernel.f90 | 2 +- src/utils/powerspectrums.f90 | 2 +- src/utils/prompting.f90 | 2 +- src/utils/quartic.f90 | 2 +- src/utils/rhomach.f90 | 2 +- src/utils/showarrays.f90 | 2 +- src/utils/showheader.f90 | 6 +- src/utils/solvelinearsystem.f90 | 2 +- src/utils/splitpart.f90 | 2 +- src/utils/struct2struct.f90 | 2 +- src/utils/test_binary.f90 | 2 +- src/utils/testbinary.f90 | 2 +- src/utils/utils_disc.f90 | 2 +- src/utils/utils_ephemeris.f90 | 2 +- src/utils/utils_evfiles.f90 | 2 +- src/utils/utils_gravwave.f90 | 2 +- src/utils/utils_linalg.f90 | 2 +- src/utils/utils_mpc.f90 | 2 +- src/utils/utils_orbits.f90 | 2 +- src/utils/utils_splitmerge.f90 | 2 +- src/utils/velfield.f90 | 2 +- 183 files changed, 367 insertions(+), 385 deletions(-) create mode 100644 data/forcing/README diff --git a/AUTHORS b/AUTHORS index 7c163a247..4b972f1d7 100644 --- a/AUTHORS +++ b/AUTHORS @@ -31,15 +31,9 @@ Sergei Biriukov Cristiano Longarini Giovanni Dipierro Roberto Iaconi -fhu Hauke Worpel -<<<<<<< HEAD -Simone Ceppi -Amena Faruqi -======= Amena Faruqi Alison Young ->>>>>>> upstream/master Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi @@ -54,25 +48,6 @@ Jolien Malfait Phantom benchmark bot Kieran Hirsh Nicole Rodrigues -<<<<<<< HEAD -Amena Faruqi -David Trevascus -Chris Nixon -Megha Sharma -Nicolas Cuello -Benoit Commercon -Giulia Ballabio -Joe Fisher -Maxime Lombart -Megha Sharma -Orsola De Marco -Zachary Pellow -s-neilson <36410751+s-neilson@users.noreply.github.com> -Alison Young -Cox, Samuel -Jorge Cuadra -Nicolás Cuello -======= David Trevascus Nicolás Cuello Farzana Meru @@ -87,16 +62,10 @@ Benoit Commercon Giulia Ballabio s-neilson <36410751+s-neilson@users.noreply.github.com> MICHOULIER Stephane ->>>>>>> upstream/master Steven Rieder Jeremy Smallwood Cox, Samuel Jorge Cuadra Stéven Toupin -<<<<<<< HEAD -Terrence Tricco -mats esseldeurs -======= Taj Jankovič Chunliang Mu ->>>>>>> upstream/master diff --git a/README.md b/README.md index 600d757b6..bcb9f6dc1 100644 --- a/README.md +++ b/README.md @@ -10,21 +10,17 @@ Phantom is a 3D Smoothed Particle Hydrodynamics and Magnetohydrodynamics code fo Status ------ -![testkd](https://github.com/danieljprice/phantom/workflows/testkd/badge.svg) -![test2](https://github.com/danieljprice/phantom/workflows/test2/badge.svg) -![testcyl](https://github.com/danieljprice/phantom/workflows/testcyl/badge.svg) -![mpi](https://github.com/danieljprice/phantom/workflows/mpi/badge.svg) -![GR](https://github.com/danieljprice/phantom/workflows/GR/badge.svg) -![dust](https://github.com/danieljprice/phantom/workflows/dust/badge.svg) -![dust growth](https://github.com/danieljprice/phantom/workflows/growth/badge.svg) -![non-ideal mhd](https://github.com/danieljprice/phantom/workflows/nimhd/badge.svg) -![utils](https://github.com/danieljprice/phantom/workflows/utils/badge.svg) + +[![build](https://github.com/danieljprice/phantom/actions/workflows/build.yml/badge.svg)](https://github.com/danieljprice/phantom/actions/workflows/build.yml) +[![test](https://github.com/danieljprice/phantom/actions/workflows/test.yml/badge.svg)](https://github.com/danieljprice/phantom/actions/workflows/test.yml) +[![mpi](https://github.com/danieljprice/phantom/actions/workflows/mpi.yml/badge.svg)](https://github.com/danieljprice/phantom/actions/workflows/mpi.yml) +[![mcfost](https://github.com/danieljprice/phantom/actions/workflows/mcfost.yml/badge.svg)](https://github.com/danieljprice/phantom/actions/workflows/mcfost.yml) [![Documentation](https://readthedocs.org/projects/phantomsph/badge/?version=latest)](https://phantomsph.readthedocs.io/en/latest/?badge=latest) Links ----- -- Project homepage: http://phantomsph.bitbucket.io/ +- Project homepage: http://phantomsph.github.io/ - Code repository: https://github.com/danieljprice/phantom/ - Documentation: https://phantomsph.readthedocs.org/ - Code paper: http://adsabs.harvard.edu/abs/2018PASA...35...31P @@ -48,7 +44,12 @@ Getting help If you need help, please try the following, in order: 1. Check the [documentation](https://phantomsph.readthedocs.org/). -2. File an issue, as a [bug report](https://github.com/danieljprice/phantom/issues/new) or [feature request](https://github.com/danieljprice/phantom/issues/new), using the issue tracker. +2. If you encounter a bug, [file an issue](https://github.com/danieljprice/phantom/issues/new) +3. If you want to request a feature, [file an issue](https://github.com/danieljprice/phantom/issues/new), using the issue tracker. +4. If you need help on how to use phantom, [file an issue](https://github.com/danieljprice/phantom/issues/new) + +We welcome general discussion about Phantom, Smoothed Particle Hydrodynamics, +and astrophysics at the [Phantom Slack](https://phantomsph.slack.com/). However, please use the github issues for support requests. Contributing ------------ @@ -58,25 +59,16 @@ We welcome contributions, including (but not limited to): 2. Documentation, also by [pull request](https://github.com/danieljprice/phantom/pulls). Docs can be edited in the docs/ directory of the main code. 3. Suggestions for features or bug reports, via the [issue tracker](https://github.com/danieljprice/phantom/issues/new). Please file bugs via github rather than by email. -Slack ------ - -We welcome general discussion about Phantom, Smoothed Particle Hydrodynamics, -and astrophysics at the [Phantom Slack](https://phantomsph.slack.com/). - Citation -------- Please cite [Price et al. (2018)](http://adsabs.harvard.edu/abs/2018PASA...35...31P) when using Phantom. Wherever possible, please try to also cite original references for the algorithms you are using. A partial list can be found in `docs/phantom.bib` file, or by reading the relevant sections of the paper. -Licence -------- +Other things +------------- +For CHANGES see the release notes: https://phantomsph.readthedocs.io/en/latest/releasenotes.html. See LICENCE file for usage and distribution conditions. Copyright (c) 2007-2023 Daniel Price and contributors (see AUTHORS file). -Release notes -------------- - -For CHANGES see the release notes: https://phantomsph.readthedocs.io/en/latest/releasenotes.html. diff --git a/build/Makefile_defaults_aocc b/build/Makefile_defaults_aocc index 452ef08bd..17c20121e 100644 --- a/build/Makefile_defaults_aocc +++ b/build/Makefile_defaults_aocc @@ -12,3 +12,4 @@ KNOWN_SYSTEM=yes OMPFLAGS= -fopenmp +AOCC = yes diff --git a/build/Makefile_fastmath b/build/Makefile_fastmath index 0e05134d1..a148a96c0 100644 --- a/build/Makefile_fastmath +++ b/build/Makefile_fastmath @@ -29,7 +29,7 @@ endif ifeq ($(FASTMATH), yes) SRCFASTMATH=fastmath.o - TEST_FASTMATH=test_fastmath.F90 + TEST_FASTMATH=test_fastmath.f90 FPPFLAGS+=-DFINVSQRT else SRCFASTMATH= @@ -38,7 +38,7 @@ endif fastmath.o: fastmath.f90 $(FC) $(FFLAGS) -o $@ -c $< || ${MAKE} fastmathlinkerr -test_fastmath.o: test_fastmath.F90 +test_fastmath.o: test_fastmath.f90 $(FC) $(FFLAGS) -o $@ -c $< || ${MAKE} fastmathlinkerr getmathflags.o: getmathflags.f90 $(FC) $(FFLAGS) -o $@ -c $< || ${MAKE} fastmathlinkerr diff --git a/data/forcing/README b/data/forcing/README new file mode 100644 index 000000000..99065dec1 --- /dev/null +++ b/data/forcing/README @@ -0,0 +1,10 @@ +The forcing data file is too large to be stored in the Phantom git repository +It will be downloaded automatically when you run the code + +or can be retrieved manually using wget from the phantom website, e.g.: + +wget http://users.monash.edu.au/~dprice/phantom/data/forcing.dat + +The files are: + +forcing.dat diff --git a/docs/developer-guide/index.rst b/docs/developer-guide/index.rst index 1c29a8046..b9d169785 100644 --- a/docs/developer-guide/index.rst +++ b/docs/developer-guide/index.rst @@ -6,13 +6,14 @@ Here is the Phantom developer guide. .. toctree:: :maxdepth: 1 + fork fortran vscode philosophy styleguide setup testing + bots datafiles staging - fork sort diff --git a/docs/examples/CE.rst b/docs/examples/CE.rst index 12e80f8a0..2c38b5f86 100644 --- a/docs/examples/CE.rst +++ b/docs/examples/CE.rst @@ -73,7 +73,7 @@ Use SETUP=star or SETUP=dustystar and if not specified, the default options. 2.2 make setup 2.3 ./phantomsetup star (option 5 MESA star, input profile = Jan_Star_Phantom_Profile.data, desired EOS = 10, use constant entropy profile, Relax star automatically = yes). The core radius is the softening radius (2-3Ro) - the core mass is the same as the one you have measured from MESA (0.46Mo in Jan_Star_Phantom_Profile). + the core mass is the same as the one you have measured from MESA (0.46Mo in Jan_Star_Phantom_Profile.data). This produces a file called star.setup - this file has all the options so you can edit it. 2.4 vim star.setup, (write_rho_to_file = T) @@ -126,3 +126,13 @@ if you come from 2.10, then use as initial model (hereafter initial_nnnnn) one o softening length for the primary core = 1., softening length for companion = 0.1) 2.16 vim binary.in (optional, tmax=200.00, dtmax=0.100) 2.17 ./phantom binary.in + + +**D. Setup sink properties (luminosity)** + +:: + + 2.18 ./phantommoddump binary_00000.tmp dusty_binary_00000.tmp 0.0 + option 9, 12 lum + 2.19 vim dusty_binary.in (adapt isink_radiation, idust_opacity) + 2.20 ./phantom dusty_binary.in diff --git a/docs/getting-started/gitinfo.rst b/docs/getting-started/gitinfo.rst index 46c179d38..de0ab83e4 100644 --- a/docs/getting-started/gitinfo.rst +++ b/docs/getting-started/gitinfo.rst @@ -8,9 +8,7 @@ Getting your first copy Once you have a GitHub account, you must create your own :doc:`fork `. This is done using the “fork” button (the big button on top right of the -repo page). You can then clone your fork to your computer: - -:: +repo page). You can then clone your fork to your computer:: git clone https://github.com/USERNAME/phantom.git @@ -21,9 +19,7 @@ Setting your username and email address --------------------------------------- Before you can push changes, you must ensure that your name and email -address are set, as follows: - -:: +address are set, as follows:: cd phantom git config --global user.name "Joe Bloggs" @@ -35,9 +31,7 @@ in the commit logs (and in the AUTHORS file) Receiving updates from your fork -------------------------------- -Procedure is: stash your changes, pull the updates, reapply your changes - -:: +Procedure is: stash your changes, pull the updates, reapply your changes:: git stash git pull @@ -47,18 +41,14 @@ Receiving updates from the master branch ---------------------------------------- Before you can receive updates from the master branch, you must first link -your fork to the master branch: - -:: +your fork to the master branch:: git remote add upstream https://github.com/danieljprice/phantom.git This only needs to be done once. To update, the procedure is: stash your changes, pull the updates, -reapply your changes - -:: +reapply your changes:: git stash git fetch upstream @@ -72,23 +62,17 @@ Committing changes to your fork Submit changes to Phantom carefully! The first thing is to pull any upstream changes as described above. Once you have done this, first -check what you will commit: - -:: +check what you will commit:: git diff then go through each subset of changes you have made and commit the -file(s) with a message: - -:: +file(s) with a message:: git commit -m 'changed units in dim file for problem x' src/main/dim_myprob.f90 and so on, for all the files that you want to commit. Then, when you’re -ready to push the changeset back to your fork use - -:: +ready to push the changeset back to your fork use:: git push @@ -96,10 +80,9 @@ Note that you will only be allowed to push changes if you have already updated your copy to the latest version. If you have just updated your code from the master repo, simply update -your fork via +your fork via:: -:: - git commit + git commit -m 'merge' git push This will push all the remote changes to your forked version of Phantom. @@ -108,7 +91,7 @@ Committing changes to the master branch --------------------------------------- This is done through a “pull request”. To do this, -you can click the big “pull request” button on the GitHub page to request +you can click the “contribute” button on the GitHub page to request that your changes be pulled into the master copy of Phantom. Please do this frequently. Many small pull requests are much better than one giant pull request! diff --git a/docs/user-guide/hdf5.rst b/docs/user-guide/hdf5.rst index c08aca9ad..bbccd0a60 100644 --- a/docs/user-guide/hdf5.rst +++ b/docs/user-guide/hdf5.rst @@ -38,7 +38,7 @@ On macOS you can install HDF5 with Homebrew. brew install hdf5 The shared object library and include files are at -``/usr/local/opt/hdf5``. Use this directory as ``HDF5ROOT`` (see below). +``/usr/local/opt/hdf5``. Use this directory as ``HDF5_DIR`` (see below). On Ubuntu 18.04, for example, you can install HDF5 with apt. @@ -48,7 +48,7 @@ On Ubuntu 18.04, for example, you can install HDF5 with apt. The location of the library is then ``/usr/lib/x86_64-linux-gnu/hdf5/serial``. Use this directory as -``HDF5ROOT`` (see below). +``HDF5_DIR`` (see below). Compiling ~~~~~~~~~ @@ -93,25 +93,19 @@ Compiling Phantom Writing HDF5 output is a compile time option and requires access to the Fortran HDF5 library. To compile for HDF5 output set ``HDF5_DIR``, for -example if HDF5 was installed with Homebrew on macOS - -:: +example if HDF5 was installed with Homebrew on macOS:: HDF5_DIR=/usr/local/opt/hdf5 -or if it was installed with APT on Ubuntu - -:: +or if it was installed with APT on Ubuntu:: HDF5_DIR=/usr/lib/x86_64-linux-gnu/hdf5/serial -Then compile with - -:: +Then compile with:: - make HDF5=yes HDF5ROOT=$HDF5_DIR + make HDF5=yes -The variable ``HDF5ROOT`` specifies the location of the HDF5 library. +The variable ``HDF5_DIR`` specifies the location of the HDF5 library. .. note:: @@ -127,19 +121,15 @@ Ozstar On Ozstar you need to make sure that the OpenMPI and HDF5 modules are loaded. The variable ``HDF5_DIR`` gives the location of the HDF5 library -once the HDF5 module is loaded. - -:: +once the HDF5 module is loaded:: module load iccifort/2018.1.163-gcc-6.4.0 module load openmpi/3.0.0 module load hdf5/1.10.1 -Then when you compile Phantom use ``HDF5_DIR`` for ``HDF5ROOT``: - -:: +Then when you compile Phantom ensure ``HDF5_DIR`` is set correctly:: - make SYSTEM=ozstar HDF5=yes HDF5ROOT=$HDF5_DIR phantom setup + make SYSTEM=ozstar HDF5=yes phantom setup Note that you must have the HDF5 module loaded when running phantom, phantomsetup, etc. So make sure to put ``module load hdf5/1.10.1`` in @@ -163,7 +153,7 @@ then you would compile ``phantom2hdf5`` as follows :: - make SETUP=dustydisc MAXP=10000000 HDF5=yes HDF5ROOT=$HDF5_DIR phantom2hdf5 + make SETUP=dustydisc MAXP=10000000 HDF5=yes phantom2hdf5 Recall that you will need to set ``HDF5_DIR`` appropriately for your system. diff --git a/scripts/HEADER-module b/scripts/HEADER-module index 5f72a072c..e6f5a8618 100644 --- a/scripts/HEADER-module +++ b/scripts/HEADER-module @@ -2,7 +2,7 @@ ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! ! Copyright (c) 2007-THISYEAR The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! -! http://phantomsph.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! ! :MODULE: [generated automatically] ! diff --git a/scripts/HEADER-program b/scripts/HEADER-program index fef7841e9..59d916bd4 100644 --- a/scripts/HEADER-program +++ b/scripts/HEADER-program @@ -2,7 +2,7 @@ ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! ! Copyright (c) 2007-THISYEAR The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! -! http://phantomsph.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! ! PROGRAM: [generated automatically] ! diff --git a/src/lib/NICIL/src/nicil.F90 b/src/lib/NICIL/src/nicil.F90 index ccb4e706d..cefc345ff 100644 --- a/src/lib/NICIL/src/nicil.F90 +++ b/src/lib/NICIL/src/nicil.F90 @@ -1239,6 +1239,7 @@ pure subroutine nicil_update_nimhd(icall,eta_ohm,eta_hall,eta_ambi,Bfield,rho,T, else nden_electronR = nicil_ionR_get_ne(nden_save(1:iire)) ! in this case, need to calculate electron density from ions n_g_tot = 0. ! to prevent compiler warnings + zeta = 0. ! prevent compiler warnings endif !--Sum the ion populations from thermal and cosmic ray ionisation @@ -1294,6 +1295,7 @@ pure subroutine nicil_update_nimhd(icall,eta_ohm,eta_hall,eta_ambi,Bfield,rho,T, else !--Return constant coefficient version and exit call nicil_nimhd_get_eta_cnst(eta_ohm,eta_hall,eta_ambi,Bfield,rho) + if (present(data_out)) data_out = 0. endif if (present(itry)) itry = itry_n0 @@ -2288,9 +2290,14 @@ end subroutine nicil_get_dt_nimhd pure subroutine nicil_get_halldrift(eta_hall,Bx,By,Bz,jcurrent,vdrift) real, intent(in) :: eta_hall,Bx,By,Bz,jcurrent(3) real, intent(out) :: vdrift(3) - real :: B1 + real :: B1,B2 - B1 = 1.0/sqrt(Bx*Bx + By*By + Bz*Bz) + B2 = Bx*Bx + By*By + Bz*Bz + if (B2 > 0.) then + B1 = 1.0/sqrt(B2) + else + B1 = 0. + endif vdrift = -eta_hall*jcurrent*B1 end subroutine nicil_get_halldrift @@ -2302,9 +2309,14 @@ end subroutine nicil_get_halldrift pure subroutine nicil_get_ambidrift(eta_ambi,Bx,By,Bz,jcurrent,vdrift) real, intent(in) :: eta_ambi,Bx,By,Bz,jcurrent(3) real, intent(out) :: vdrift(3) - real :: B21 + real :: B2,B21 - B21 = 1.0/(Bx*Bx + By*By + Bz*Bz) + B2 = Bx*Bx + By*By + Bz*Bz + if (B2 > 0.) then + B21 = 1.0/B2 + else + B21 = 0. + endif vdrift(1) = eta_ambi*( jcurrent(2)*Bz - jcurrent(3)*By )*B21 vdrift(2) = eta_ambi*( jcurrent(3)*Bx - jcurrent(1)*Bz )*B21 vdrift(3) = eta_ambi*( jcurrent(1)*By - jcurrent(2)*Bx )*B21 diff --git a/src/main/bondiexact.f90 b/src/main/bondiexact.f90 index 35abcd9e8..e39ddd970 100644 --- a/src/main/bondiexact.f90 +++ b/src/main/bondiexact.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module bondiexact ! diff --git a/src/main/bondiexact_gr.f90 b/src/main/bondiexact_gr.f90 index ceb08100a..869fc061a 100644 --- a/src/main/bondiexact_gr.f90 +++ b/src/main/bondiexact_gr.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module bondiexact ! diff --git a/src/main/boundary.f90 b/src/main/boundary.f90 index ac732f48e..08bb0fd34 100644 --- a/src/main/boundary.f90 +++ b/src/main/boundary.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module boundary ! diff --git a/src/main/boundary_dynamic.f90 b/src/main/boundary_dynamic.f90 index 29786f8f7..88642a872 100644 --- a/src/main/boundary_dynamic.f90 +++ b/src/main/boundary_dynamic.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module boundary_dyn ! @@ -360,7 +360,7 @@ subroutine find_dynamic_boundaries(npart,nptmass,dtmax,xyz_n_all,xyz_x_all,ierr) ! add uninteresting particles to the averages if (.not.bdy_is_interesting) then n_bkg = n_bkg + 1 - v_bkg = v_bkg + vxyzu(:,i) + v_bkg = v_bkg + vxyzu(1:3,i) if (mhd) B_bkg = B_bkg + Bevol(:,i)*rhoi endif endif diff --git a/src/main/centreofmass.f90 b/src/main/centreofmass.f90 index 29ee1788b..88fb0fb70 100644 --- a/src/main/centreofmass.f90 +++ b/src/main/centreofmass.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module centreofmass ! diff --git a/src/main/checkconserved.f90 b/src/main/checkconserved.f90 index 32b54f110..e47e96955 100644 --- a/src/main/checkconserved.f90 +++ b/src/main/checkconserved.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module checkconserved ! @@ -39,7 +39,7 @@ subroutine init_conservation_checks(should_conserve_energy,should_conserve_momen should_conserve_angmom,should_conserve_dustmass) use options, only:icooling,ieos,ipdv_heating,ishock_heating,& iresistive_heating,use_dustfrac,iexternalforce - use dim, only:mhd,maxvxyzu,periodic,particles_are_injected + use dim, only:mhd,maxvxyzu,periodic,inject_parts use part, only:iboundary,npartoftype use boundary_dyn,only:dynamic_bdy logical, intent(out) :: should_conserve_energy,should_conserve_momentum @@ -73,7 +73,7 @@ subroutine init_conservation_checks(should_conserve_energy,should_conserve_momen ! ! Each injection routine will need to bookeep conserved quantities, but until then... ! - if (particles_are_injected .or. dynamic_bdy) then + if (inject_parts .or. dynamic_bdy) then should_conserve_energy = .false. should_conserve_momentum = .false. should_conserve_angmom = .false. diff --git a/src/main/checkoptions.F90 b/src/main/checkoptions.F90 index fe21f493c..d230f40bf 100644 --- a/src/main/checkoptions.F90 +++ b/src/main/checkoptions.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module checkoptions ! @@ -14,7 +14,7 @@ module checkoptions ! ! :Runtime parameters: None ! -! :Dependencies: dim, io, metric_tools, part +! :Dependencies: dim, io, metric_tools, mpiutils, part ! implicit none public :: check_compile_time_settings @@ -143,10 +143,16 @@ subroutine check_compile_time_settings(ierr) #endif #ifdef DUSTGROWTH - if (.not. use_dustgrowth) call error(string,'-DDUSTGROWTH but use_dustgrowth = .false.') + if (.not. use_dustgrowth) then + call error(string,'-DDUSTGROWTH but use_dustgrowth = .false.') + ierr = 16 + endif #endif - return + if (mpi .and. inject_parts) call error(string,'MPI currently not compatible with particle injection') + + call barrier_mpi + end subroutine check_compile_time_settings end module checkoptions diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index f35039f6e..e4e0c17cd 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module checksetup ! @@ -16,7 +16,7 @@ module checksetup ! ! :Dependencies: boundary, boundary_dyn, centreofmass, dim, dust, eos, ! externalforces, io, metric_tools, nicil, options, part, physcon, -! sortutils, timestep, units, utils_gr +! ptmass_radiation, sortutils, timestep, units, utils_gr ! implicit none public :: check_setup @@ -91,12 +91,6 @@ subroutine check_setup(nerror,nwarn,restart) print*,'ERROR: sum of npartoftype /= npart: np=',npart,' but sum=',sum(npartoftype) nerror = nerror + 1 endif -#ifndef KROME - if (gamma <= 0.) then - print*,'WARNING! gamma not set (should be set > 0 even if not used)' - nwarn = nwarn + 1 - endif -#endif if (hfact < 1. .or. isnan(hfact)) then print*,'ERROR: hfact = ',hfact,', should be >= 1' nerror = nerror + 1 @@ -105,7 +99,6 @@ subroutine check_setup(nerror,nwarn,restart) print*,'ERROR: polyk = ',polyk,', should be >= 0' nerror = nerror + 1 endif - if (use_krome) then if (ieos /= 19) then print*, 'KROME setup. Only eos=19 makes sense.' @@ -121,12 +114,6 @@ subroutine check_setup(nerror,nwarn,restart) nwarn = nwarn + 1 endif endif -#else - if (polyk < tiny(0.) .and. ieos /= 2) then - print*,'WARNING! polyk = ',polyk,' in setup, speed of sound will be zero in equation of state' - nwarn = nwarn + 1 - endif -#endif if (npart < 0) then print*,'ERROR: npart = ',npart,', should be >= 0' nerror = nerror + 1 @@ -307,7 +294,8 @@ subroutine check_setup(nerror,nwarn,restart) ! warn about external force settings ! if (iexternalforce==iext_star .and. nptmass==0) then - print*,'WARNING: iexternalforce=1 does not conserve momentum - use a sink particle at r=0 if you care about this' + if (id==master) print "(a,/,a)",'WARNING: iexternalforce=1 does not conserve momentum:',& + ' use a sink particle at r=0 if you care about this' nwarn = nwarn + 1 endif ! @@ -345,9 +333,9 @@ subroutine check_setup(nerror,nwarn,restart) if (gravity .or. nptmass > 0) then if (.not.G_is_unity()) then if (gravity) then - print*,'ERROR: self-gravity ON but G /= 1 in code units, got G=',get_G_code() + if (id==master) print*,'ERROR: self-gravity ON but G /= 1 in code units, got G=',get_G_code() elseif (nptmass > 0) then - print*,'ERROR: sink particles used but G /= 1 in code units, got G=',get_G_code() + if (id==master) print*,'ERROR: sink particles used but G /= 1 in code units, got G=',get_G_code() endif fix_units = .true. if (fix_units) then @@ -360,7 +348,7 @@ subroutine check_setup(nerror,nwarn,restart) endif endif if (.not. gr .and. (gravity .or. mhd) .and. ien_type == ien_etotal) then - print*,'Cannot use total energy with self gravity or mhd' + if (id==master) print*,'Cannot use total energy with self gravity or mhd' nerror = nerror + 1 endif ! @@ -368,12 +356,12 @@ subroutine check_setup(nerror,nwarn,restart) ! if (mhd) then if (all(abs(Bxyz(:,1:npart)) < tiny(0.))) then - print*,'WARNING: MHD is ON but magnetic field is zero everywhere' + if (id==master) print*,'WARNING: MHD is ON but magnetic field is zero everywhere' nwarn = nwarn + 1 endif if (mhd_nonideal) then if (n_nden /= n_nden_phantom) then - print*,'ERROR: n_nden in nicil.f90 needs to match n_nden_phantom in config.F90; n_nden = ',n_nden + if (id==master) print*,'ERROR: n_nden in nicil.f90 needs to match n_nden_phantom in config.F90; n_nden = ',n_nden nerror = nerror + 1 endif endif @@ -424,7 +412,7 @@ subroutine check_setup(nerror,nwarn,restart) ! !--check radiation setup ! - if (do_radiation) call check_setup_radiation(npart,nerror,radprop,rad) + if (do_radiation) call check_setup_radiation(npart,nerror,nwarn,radprop,rad) ! !--check dust growth arrays ! @@ -660,7 +648,7 @@ end subroutine check_setup_ptmass !+ !------------------------------------------------------------------ subroutine check_setup_growth(npart,nerror) - use part, only:dustprop,dustprop_label + use part, only:dustprop,dustprop_label,iamdust,iphase,maxphase,maxp integer, intent(in) :: npart integer, intent(inout) :: nerror integer :: i,j,nbad(4) @@ -669,12 +657,16 @@ subroutine check_setup_growth(npart,nerror) !-- Check that all the parameters are > 0 when needed do i=1,npart do j=1,2 - if (dustprop(j,i) < 0.) nbad(j) = nbad(j) + 1 + if (maxphase==maxp) then + if (iamdust(iphase(i)) .and. dustprop(j,i) <= 0.) nbad(j) = nbad(j) + 1 + elseif (dustprop(j,i) < 0.) then + nbad(j) = nbad(j) + 1 + endif enddo enddo do j=1,2 if (nbad(j) > 0) then - print*,'ERROR: ',nbad(j),' of ',npart,' particles with '//trim(dustprop_label(j))//' < 0' + print*,'ERROR: dustgrowth: ',nbad(j),' of ',npart,' particles with '//trim(dustprop_label(j))//' <= 0' nerror = nerror + 1 endif enddo @@ -762,13 +754,13 @@ subroutine check_setup_dustgrid(nerror,nwarn) nerror = nerror + 1 endif enddo + do i=1,ndusttypes + if (grainsize(i) > 10.*km/udist) then + print*,'WARNING: grainsize is HUGE (>10km) in dust bin ',i,': s = ',grainsize(i)*udist/km,' km' + nwarn = nwarn + 1 + endif + enddo endif - do i=1,ndusttypes - if (grainsize(i) > 10.*km/udist) then - print*,'WARNING: grainsize is HUGE (>10km) in dust bin ',i,': s = ',grainsize(i)*udist/km,' km' - nwarn = nwarn + 1 - endif - enddo end subroutine check_setup_dustgrid @@ -954,46 +946,57 @@ end subroutine check_for_identical_positions !------------------------------------------------------------------ !+ -! 1) check for optically thin particles when mcfost is disabled, -! as the particles will then be overlooked if they are flagged as thin -! 2) check that radiation energy is never negative to begin with -! 3) check for NaNs +! 1) check for optically thin particles when mcfost is disabled, +! as the particles will then be overlooked if they are flagged as thin +! 2) check that radiation energy is never negative to begin with +! 3) check for NaNs !+ !------------------------------------------------------------------ -subroutine check_setup_radiation(npart, nerror, radprop, rad) +subroutine check_setup_radiation(npart,nerror,nwarn,radprop,rad) use part, only:ithick, iradxi, ikappa integer, intent(in) :: npart - integer, intent(inout) :: nerror + integer, intent(inout) :: nerror,nwarn real, intent(in) :: rad(:,:), radprop(:,:) - integer :: i, nthin, nradEn, nkappa + integer :: i,nthin,nradEn,nkappa,nwarn_en nthin = 0 nradEn = 0 nkappa = 0 - do i=1, npart - if (radprop(ithick, i) < 0.5) nthin=nthin + 1 - if (rad(iradxi, i) < 0.) nradEn=nradEn + 1 - if (radprop(ikappa, i) <= 0.0 .or. isnan(radprop(ikappa,i))) nkappa=nkappa + 1 + nwarn_en = 0 + do i=1,npart + if (radprop(ithick, i) < 0.5) nthin = nthin + 1 + if (rad(iradxi, i) < 0.) nradEn = nradEn + 1 + if (radprop(ikappa, i) <= 0.0 .or. isnan(radprop(ikappa,i))) nkappa = nkappa + 1 + if (rad(iradxi, i) <= 0.) nwarn_en = nwarn_en + 1 enddo if (nthin > 0) then - print "(/,a,i10,a,i10,a,/)",' WARNING in setup: ',nthin,' of ',npart,& + print "(/,a,i10,a,i10,a,/)",' ERROR in setup: ',nthin,' of ',npart,& ' particles are being treated as optically thin without MCFOST being compiled' nerror = nerror + 1 endif if (nradEn > 0) then - print "(/,a,i10,a,i10,a,/)",' WARNING in setup: ',nradEn,' of ',npart,& - ' particles have negative radiation Energy' + print "(/,a,i10,a,i10,a,/)",' ERROR in setup: ',nradEn,' of ',npart,& + ' particles have negative radiation energy' nerror = nerror + 1 endif + if (nwarn_en > 0) then + print "(/,a,i10,a,i10,a,/)",' WARNING in setup: ',nwarn_en,' of ',npart,& + ' particles have radiation energy equal to zero' + nwarn = nwarn + 1 + endif + if (nkappa > 0) then - print "(/,a,i10,a,i10,a,/)",' WARNING in setup: ',nkappa,' of ',npart,& + print "(/,a,i10,a,i10,a,/)",' ERROR in setup: ',nkappa,' of ',npart,& ' particles have opacity <= 0.0 or NaN' nerror = nerror + 1 endif + call check_NaN(npart,rad,'radiation_energy',nerror) + call check_NaN(npart,radprop,'radiation properties',nerror) + end subroutine check_setup_radiation end module checksetup diff --git a/src/main/config.F90 b/src/main/config.F90 index e75941504..069005dd4 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module dim ! @@ -22,8 +22,6 @@ module dim integer, parameter, public :: phantom_version_minor = PHANTOM_VERSION_MINOR integer, parameter, public :: phantom_version_micro = PHANTOM_VERSION_MICRO character(len=*), parameter, public :: phantom_version_string = PHANTOM_VERSION_STRING - character(len=80), parameter :: & ! module version - modid="$Id$" public @@ -322,9 +320,9 @@ module dim ! logical for bookkeeping !-------------------- #ifdef INJECT_PARTICLES - logical, parameter :: particles_are_injected = .true. + logical, parameter :: inject_parts = .true. #else - logical, parameter :: particles_are_injected = .false. + logical, parameter :: inject_parts = .false. #endif !-------------------- diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 8969d0dee..151dc9337 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cons2prim ! @@ -177,7 +177,8 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& iohm,ihall,nden_nimhd,eta_nimhd,iambi,get_partinfo,iphase,this_is_a_test,& ndustsmall,itemp,ikappa,idmu,idgamma,icv 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 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 @@ -271,7 +272,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& endif if (use_krome) gammai = eos_vars(igamma,i) if (maxvxyzu >= 4) then - uui = utherm(vxyzu(:,i),rhogas,gammai) + uui = vxyzu(4,i) if (uui < 0.) call warning('cons2prim','Internal energy < 0',i,'u',uui) 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) @@ -283,7 +284,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& eos_vars(igasP,i) = p_on_rhogas*rhogas eos_vars(ics,i) = spsound eos_vars(itemp,i) = temperaturei - if (use_var_comp .or. eos_outputs_mu(ieos) .or. do_nucleation .or. update_muGamma or. (ieos==21)) eos_vars(imu,i) = mui + if (use_var_comp .or. eos_outputs_mu(ieos) .or. do_nucleation .or. update_muGamma) eos_vars(imu,i) = mui if (do_radiation) then if (temperaturei > tiny(0.)) then @@ -295,11 +296,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 @@ -330,6 +327,10 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& ! if (mhd_nonideal) then Bi = sqrt(Bxi*Bxi + Byi*Byi + Bzi*Bzi) + ! sanity check the temperature + if (temperaturei < 1.) call warning('cons2prim',& + 'T < 1K in non-ideal MHD library',i,'T',temperaturei) + call nicil_update_nimhd(0,eta_nimhd(iohm,i),eta_nimhd(ihall,i),eta_nimhd(iambi,i), & Bi,rhoi,temperaturei,nden_nimhd(:,i),ierrlist) endif diff --git a/src/main/cons2primsolver.f90 b/src/main/cons2primsolver.f90 index af64a5e59..10e81529d 100644 --- a/src/main/cons2primsolver.f90 +++ b/src/main/cons2primsolver.f90 @@ -2,13 +2,17 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cons2primsolver ! -! None +! Internal routines containing the GR conservative to +! primitive variable solver, as described in section 7 +! of Liptai & Price (2019) ! -! :References: None +! :References: +! Liptai & Price (2019), MNRAS 485, 819 +! Tejeda (2012), PhD thesis, IAS Trieste ! ! :Owner: David Liptai ! diff --git a/src/main/cooling.F90 b/src/main/cooling.F90 index 3c0817808..582838213 100644 --- a/src/main/cooling.F90 +++ b/src/main/cooling.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cooling ! @@ -15,7 +15,7 @@ module cooling ! 5 = Koyama & Inutuska (2002) [explicit] ! 6 = Koyama & Inutuska (2002) [implicit] ! 7 = Gammie cooling power law [explicit] -! 8 = Stamatellos et al. (2007) [implicit] +! 9 = Stamatellos et al. (2007) [implicit] ! ! :References: ! Gail & Sedlmayr textbook Physics and chemistry of Circumstellar dust shells @@ -89,7 +89,7 @@ subroutine init_cooling(id,master,iprint,ierr) case(9) if (ieos /= 21 .and. ieos /=2) call fatal('cooling','icooling=9 requires ieos=21',& var='ieos',ival=ieos) - if (irealvisc > 0 .and. od_method == 2) call warning('cooling',& + 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) @@ -99,7 +99,6 @@ subroutine init_cooling(id,master,iprint,ierr) call fatal('cooling','Do radiation was switched on!') endif call init_star() - cooling_in_step = .false. case(6) call init_cooling_KI02(ierr) case(5) @@ -111,20 +110,22 @@ subroutine init_cooling(id,master,iprint,ierr) case(7) ! Gammie PL cooling_in_step = .false. + case(8) + cooling_in_step = .false. case default call init_cooling_solver(ierr) end select !--calculate the energy floor in code units - if (Tfloor > 0.) then + if (icooling == 9) then + ufloor = 0. ! because we calculate & use umin separately + elseif (Tfloor > 0.) then if (gamma > 1.) then ufloor = kboltz*Tfloor/((gamma-1.)*gmw*mass_proton_cgs)/unit_ergg else ufloor = 3.0*kboltz*Tfloor/(2.0*gmw*mass_proton_cgs)/unit_ergg endif if (maxvxyzu < 4) ierr = 1 - elseif (icooling == 9) then - ufloor = 0. ! because we calculate & use umin separately else ufloor = 0. endif @@ -136,9 +137,8 @@ end subroutine init_cooling ! this routine returns the effective cooling rate du/dt ! !----------------------------------------------------------------------- -! my version: subroutine energ_cooling(xi,yi,zi,ui,dudt,rho,dt,Tdust_in,mu_in,gamma_in,K2_in,kappa_in,dudti_sph,part_id) -subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2_in,kappa_in,abund_in) +subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2_in,kappa_in,abund_in,dudti_sph,part_id) use io, only:fatal use dim, only:nabundances use eos, only:gmw,gamma,ieos,get_temperature_from_u diff --git a/src/main/cooling_functions.f90 b/src/main/cooling_functions.f90 index 407f5d983..229afeaef 100644 --- a/src/main/cooling_functions.f90 +++ b/src/main/cooling_functions.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cooling_functions ! diff --git a/src/main/cooling_gammie.f90 b/src/main/cooling_gammie.f90 index 0b36b09d8..3fffe3565 100644 --- a/src/main/cooling_gammie.f90 +++ b/src/main/cooling_gammie.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cooling_gammie ! diff --git a/src/main/cooling_gammie_PL.f90 b/src/main/cooling_gammie_PL.f90 index 16a685a91..15ae40733 100644 --- a/src/main/cooling_gammie_PL.f90 +++ b/src/main/cooling_gammie_PL.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cooling_gammie_PL ! diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index 21eaba17b..60d574c75 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cooling_ism ! diff --git a/src/main/cooling_koyamainutsuka.f90 b/src/main/cooling_koyamainutsuka.f90 index 1d1485153..eee002b73 100644 --- a/src/main/cooling_koyamainutsuka.f90 +++ b/src/main/cooling_koyamainutsuka.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cooling_koyamainutsuka ! diff --git a/src/main/cooling_molecular.f90 b/src/main/cooling_molecular.f90 index 507c0eb55..48055b2c9 100644 --- a/src/main/cooling_molecular.f90 +++ b/src/main/cooling_molecular.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cooling_molecular ! diff --git a/src/main/cooling_solver.f90 b/src/main/cooling_solver.f90 index 3eb2295fb..8775b5c7f 100644 --- a/src/main/cooling_solver.f90 +++ b/src/main/cooling_solver.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cooling_solver ! diff --git a/src/main/cullendehnen.f90 b/src/main/cullendehnen.f90 index 11566c10c..5ebd2e7c9 100644 --- a/src/main/cullendehnen.f90 +++ b/src/main/cullendehnen.f90 @@ -2,13 +2,15 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cullendehnen ! -! cullendehnen +! Utility routines for the Cullen & Dehnen shock detection switch ! -! :References: None +! :References: +! Cullen & Dehnen (2010), MNRAS 408, 669 +! Price et al. (2018), PASA 35, e031 ! ! :Owner: Elisabeth Borchert ! @@ -26,7 +28,6 @@ module cullendehnen !+ !------------------------------------------------------------------------------- pure real function get_alphaloc(divvdti,spsoundi,hi,xi_limiter,alphamin,alphamax) - !use kernel, only:radkern real, intent(in) :: divvdti,spsoundi,hi,xi_limiter,alphamin,alphamax real :: source real :: temp @@ -62,7 +63,7 @@ pure real function xi_limiter(dvdx) fac = max(-divv,0.)**2 traceS = curlvx**2 + curlvy**2 + curlvz**2 - if (fac + traceS > 0.) then + if (fac + traceS > epsilon(0.)) then xi_limiter = fac/(fac + traceS) else xi_limiter = 1. diff --git a/src/main/datafiles.f90 b/src/main/datafiles.f90 index 4bef68eaa..b5f68a30d 100644 --- a/src/main/datafiles.f90 +++ b/src/main/datafiles.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module datafiles ! diff --git a/src/main/eos.F90 b/src/main/eos.F90 index 238d68919..9204baaf0 100644 --- a/src/main/eos.F90 +++ b/src/main/eos.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos ! @@ -1586,6 +1586,7 @@ subroutine read_options_eos(name,valstring,imatch,igotall,ierr) store_dust_temperature = .true. update_muGamma = .true. endif + if (ieos == 21) update_muGamma = .true. case('mu') read(valstring,*,iostat=ierr) gmw ! not compulsory to read in diff --git a/src/main/utils_indtimesteps.F90 b/src/main/utils_indtimesteps.F90 index d3262157f..14ad9f826 100644 --- a/src/main/utils_indtimesteps.F90 +++ b/src/main/utils_indtimesteps.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module timestep_ind ! @@ -43,7 +43,7 @@ pure real function get_dt(dtmax,ibini) real, intent(in) :: dtmax integer(kind=1), intent(in) :: ibini - get_dt = dtmax/2**ibini + get_dt = dtmax/2.**ibini end function get_dt diff --git a/src/main/utils_inject.f90 b/src/main/utils_inject.f90 index f1e7844e1..ca43b16ff 100644 --- a/src/main/utils_inject.f90 +++ b/src/main/utils_inject.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module injectutils ! diff --git a/src/main/utils_mathfunc.f90 b/src/main/utils_mathfunc.f90 index ee2fe826e..e133bdbb7 100644 --- a/src/main/utils_mathfunc.f90 +++ b/src/main/utils_mathfunc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mathfunc ! diff --git a/src/main/utils_omp.F90 b/src/main/utils_omp.F90 index c120e9f88..07b462298 100644 --- a/src/main/utils_omp.F90 +++ b/src/main/utils_omp.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module omputils ! diff --git a/src/main/utils_raytracer.f90 b/src/main/utils_raytracer.f90 index 8899cfa82..fe327480b 100644 --- a/src/main/utils_raytracer.f90 +++ b/src/main/utils_raytracer.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module raytracer ! diff --git a/src/main/utils_shuffleparticles.F90 b/src/main/utils_shuffleparticles.F90 index 7f9f9afe4..4d519b273 100644 --- a/src/main/utils_shuffleparticles.F90 +++ b/src/main/utils_shuffleparticles.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module utils_shuffleparticles ! diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index 627a347be..97031f2d2 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module sortutils ! diff --git a/src/main/utils_sphNG.f90 b/src/main/utils_sphNG.f90 index 7f8240246..c0fe72c0a 100644 --- a/src/main/utils_sphNG.f90 +++ b/src/main/utils_sphNG.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module sphNGutils ! diff --git a/src/main/utils_spline.f90 b/src/main/utils_spline.f90 index bb6a14158..2d97899f7 100644 --- a/src/main/utils_spline.f90 +++ b/src/main/utils_spline.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module splineutils ! diff --git a/src/main/utils_summary.F90 b/src/main/utils_summary.F90 index 5b0ce0c63..e3c780c39 100644 --- a/src/main/utils_summary.F90 +++ b/src/main/utils_summary.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module io_summary ! diff --git a/src/main/utils_supertimestep.F90 b/src/main/utils_supertimestep.F90 index 7e255dcb0..4f59faa67 100644 --- a/src/main/utils_supertimestep.F90 +++ b/src/main/utils_supertimestep.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module timestep_sts ! diff --git a/src/main/utils_system.f90 b/src/main/utils_system.f90 index 82890cb0b..35c718e1b 100644 --- a/src/main/utils_system.f90 +++ b/src/main/utils_system.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module systemutils ! diff --git a/src/main/utils_tables.f90 b/src/main/utils_tables.f90 index 5e22b2359..47320b69c 100644 --- a/src/main/utils_tables.f90 +++ b/src/main/utils_tables.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module table_utils ! diff --git a/src/main/utils_vectors.f90 b/src/main/utils_vectors.f90 index e11805b38..e529d5f36 100644 --- a/src/main/utils_vectors.f90 +++ b/src/main/utils_vectors.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module vectorutils ! diff --git a/src/main/viscosity.f90 b/src/main/viscosity.f90 index fd8b2d4eb..114165a0e 100644 --- a/src/main/viscosity.f90 +++ b/src/main/viscosity.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module viscosity ! diff --git a/src/main/wind.F90 b/src/main/wind.F90 index 7997d3b9c..259e21e5c 100644 --- a/src/main/wind.F90 +++ b/src/main/wind.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module wind ! @@ -29,8 +29,8 @@ module wind private ! Shared variables - real, parameter :: Tdust_stop = 1.d-2 ! Temperature at outer boundary of wind simulation - real, parameter :: dtmin = 1.d-3 ! Minimum allowed timsestep (for 1D integration) + real, parameter :: Tdust_stop = 0.01 ! Temperature at outer boundary of wind simulation + real, parameter :: dtmin = 1.d-3 ! Minimum allowed timsestep (for 1D integration) integer, parameter :: wind_emitting_sink = 1 character(len=*), parameter :: label = 'wind' @@ -67,7 +67,7 @@ subroutine setup_wind(Mstar_cg, Mdot_code, u_to_T, r0, T0, v0, rsonic, tsonic, s Mstar_cgs = Mstar_cg wind_gamma = gamma - Mdot_cgs = Mdot_code * umass/utime + Mdot_cgs = real(Mdot_code * umass/utime) u_to_temperature_ratio = u_to_T if (idust_opacity == 2) then @@ -121,14 +121,14 @@ subroutine init_wind(r0, v0, T0, time_end, state, tau_lucy_init) Mstar_cgs = xyzmh_ptmass(4,wind_emitting_sink)*umass state%dt = 1000. - if (time_end > 0.d0) then + if (time_end > 0.) then ! integration stops when time = time_end state%find_sonic_solution = .false. state%time_end = time_end else ! integration stops once the sonic point is reached state%find_sonic_solution = .true. - state%time_end = -1.d0 + state%time_end = -1. endif state%time = 0. state%r_old = 0. @@ -315,7 +315,7 @@ subroutine wind_step(state) call calc_cooling_rate(Q_code,dlnQ_dlnT,state%rho/unit_density,state%Tg,state%Tdust,& state%mu,state%gamma,state%K2,state%kappa) state%Q = Q_code*unit_ergg - state%dQ_dr = (state%Q-Q_old)/(1.d-10+state%r-state%r_old) + state%dQ_dr = (state%Q-Q_old)/(1.e-10+state%r-state%r_old) endif state%time = state%time + state%dt @@ -446,10 +446,10 @@ subroutine wind_step(state) !apply cooling if (icooling > 0) then Q_old = state%Q - call calc_cooling_rate(Q_code,dlnQ_dlnT,state%rho/unit_density,state%Tg,state%Tdust,& + call calc_cooling_rate(Q_code,dlnQ_dlnT,real(state%rho/unit_density),state%Tg,state%Tdust,& state%mu,state%gamma,state%K2,state%kappa) state%Q = Q_code*unit_ergg - state%dQ_dr = (state%Q-Q_old)/(1.d-10+state%r-state%r_old) + state%dQ_dr = (state%Q-Q_old)/(1.e-10+state%r-state%r_old) endif if (state%time_end > 0. .and. state%time + state%dt > state%time_end) then @@ -915,7 +915,7 @@ subroutine interp_wind_profile(time, local_time, r, v, u, rho, e, GM, fdone, JKm e = .5*v**2 - GM/r + gammai*u if (local_time == 0.) then - fdone = 1.d0 + fdone = 1. else fdone = ltime/(local_time*utime) endif @@ -934,7 +934,7 @@ subroutine save_windprofile(r0, v0, T0, rout, tend, tcross, filename) real, intent(in) :: r0, v0, T0, tend, rout real, intent(out) :: tcross !time to cross the entire integration domain character(*), intent(in) :: filename - real, parameter :: Tdust_stop = 1.d0 ! Temperature at outer boundary of wind simulation + real, parameter :: Tdust_stop = 1. ! Temperature at outer boundary of wind simulation integer, parameter :: nlmax = 8192 ! maxium number of steps store in the 1D profile real :: time_end, tau_lucy_init real :: r_incr,v_incr,T_incr,mu_incr,gamma_incr,r_base,v_base,T_base,mu_base,gamma_base,eps @@ -963,7 +963,7 @@ subroutine save_windprofile(r0, v0, T0, rout, tend, tcross, filename) eps = 0.01 iter = 0 itermax = int(huge(itermax)/10.) !this number is huge but may be needed for RK6 solver - tcross = 1.d99 + tcross = huge(0.) writeline = 0 r_base = state%r diff --git a/src/main/wind_equations.f90 b/src/main/wind_equations.f90 index a42ae4dbc..ac0a78922 100644 --- a/src/main/wind_equations.f90 +++ b/src/main/wind_equations.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module wind_equations ! @@ -109,10 +109,10 @@ subroutine evolve_hydro(dt, rvT, Rstar_cgs, Mdot_cgs, mu, gamma, alpha, dalpha_d rvT = new_rvT !constrain timestep so the changes in r,v & T do not exceed dt_tol - dt_next = min(dt_next,1.d-2*au/new_rvt(2),& - dt_tol*dt*abs(rvt(1)/(1.d-10+(new_rvt(1)-rvt(1)))),& - dt_tol*dt*abs(rvt(2)/(1.d-10+(new_rvt(2)-rvt(2)))),& - dt_tol*dt*abs(rvt(3)/(1.d-10+(new_rvt(3)-rvt(3))))) + dt_next = min(dt_next,1e-2*real(au/new_rvt(2)),& + dt_tol*dt*abs(rvt(1)/(1e-10+(new_rvt(1)-rvt(1)))),& + dt_tol*dt*abs(rvt(2)/(1e-10+(new_rvt(2)-rvt(2)))),& + dt_tol*dt*abs(rvt(3)/(1e-10+(new_rvt(3)-rvt(3))))) spcode = 0 if (numerator < -num_tol .and. denominator > -denom_tol) spcode = 1 !no solution for stationary wind diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index 1eb9ab6d4..0d32e639b 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module writeheader ! diff --git a/src/utils/acc2ang.f90 b/src/utils/acc2ang.f90 index df76f6491..56058bbb5 100644 --- a/src/utils/acc2ang.f90 +++ b/src/utils/acc2ang.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program get_ang ! diff --git a/src/utils/adaptivemesh.f90 b/src/utils/adaptivemesh.f90 index 21fd65cc4..2072329a5 100644 --- a/src/utils/adaptivemesh.f90 +++ b/src/utils/adaptivemesh.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module adaptivemesh ! diff --git a/src/utils/analysis_1particle.f90 b/src/utils/analysis_1particle.f90 index b2cb53133..eb96fac59 100644 --- a/src/utils/analysis_1particle.f90 +++ b/src/utils/analysis_1particle.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_CoM.f90 b/src/utils/analysis_CoM.f90 index 3410eb43b..199caa247 100644 --- a/src/utils/analysis_CoM.f90 +++ b/src/utils/analysis_CoM.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_GalMerger.f90 b/src/utils/analysis_GalMerger.f90 index 8933337c5..4dc4d3352 100644 --- a/src/utils/analysis_GalMerger.f90 +++ b/src/utils/analysis_GalMerger.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_MWpdf.f90 b/src/utils/analysis_MWpdf.f90 index 2bdc9edf8..84f49013c 100644 --- a/src/utils/analysis_MWpdf.f90 +++ b/src/utils/analysis_MWpdf.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_NSmerger.f90 b/src/utils/analysis_NSmerger.f90 index 1f78050cf..053402dff 100644 --- a/src/utils/analysis_NSmerger.f90 +++ b/src/utils/analysis_NSmerger.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_alpha.f90 b/src/utils/analysis_alpha.f90 index 9bd33f774..d96f6fe49 100644 --- a/src/utils/analysis_alpha.f90 +++ b/src/utils/analysis_alpha.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_angmom.f90 b/src/utils/analysis_angmom.f90 index 960439d11..f27a87c2c 100644 --- a/src/utils/analysis_angmom.f90 +++ b/src/utils/analysis_angmom.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_angmomvec.f90 b/src/utils/analysis_angmomvec.f90 index 7bafc874b..31c6d6c3d 100644 --- a/src/utils/analysis_angmomvec.f90 +++ b/src/utils/analysis_angmomvec.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_average_orb_en.f90 b/src/utils/analysis_average_orb_en.f90 index fa6047ca7..f9c99a3af 100644 --- a/src/utils/analysis_average_orb_en.f90 +++ b/src/utils/analysis_average_orb_en.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_binarydisc.f90 b/src/utils/analysis_binarydisc.f90 index c71d0912a..0894b7133 100644 --- a/src/utils/analysis_binarydisc.f90 +++ b/src/utils/analysis_binarydisc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! @@ -482,7 +482,7 @@ end subroutine read_dotin !----------------------------------------------------------------------- subroutine get_binary_params(ipri,isec,xyzmh_ptmass,vxyz_ptmass,time,a,ecc,G) !----------------------------------------------------------------------- - use io, only:fatal + use io, only:fatal,warning implicit none @@ -516,7 +516,7 @@ subroutine get_binary_params(ipri,isec,xyzmh_ptmass,vxyz_ptmass,time,a,ecc,G) Lmag = sqrt(dot_product(L,L)) E = 0.5*dot_product(dv,dv) - G*(mpri+msec)/rbin - if (abs(E) < tiny(E)) stop 'binary energy problem' + if (abs(E) < tiny(E)) call warning(analysistype, 'E=0 for binary') call get_ae(Lmag,E,mpri,msec,a,ecc) if (time <= tiny(time)) then @@ -548,7 +548,6 @@ subroutine get_ae(Lmag,E,m1,m2,a,ecc) real,intent(in) :: Lmag,E,m1,m2 if (Lmag < tiny(Lmag)) stop 'Lmag is zero in get_ae' - if (abs(E) < tiny(E)) stop 'E is zero in get_ae' ! Hence obtain the binary eccentricity ecc = sqrt(1.0 + (2.0*E*Lmag**2)/((m1+m2)**2)) diff --git a/src/utils/analysis_bzrms.f90 b/src/utils/analysis_bzrms.f90 index d314f6807..e5b6443e2 100644 --- a/src/utils/analysis_bzrms.f90 +++ b/src/utils/analysis_bzrms.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_collidingcloudevolution.f90 b/src/utils/analysis_collidingcloudevolution.f90 index da9125d01..52cfdec52 100644 --- a/src/utils/analysis_collidingcloudevolution.f90 +++ b/src/utils/analysis_collidingcloudevolution.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_collidingcloudhistograms.f90 b/src/utils/analysis_collidingcloudhistograms.f90 index bf60b57bf..c17daaddb 100644 --- a/src/utils/analysis_collidingcloudhistograms.f90 +++ b/src/utils/analysis_collidingcloudhistograms.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_cooling.f90 b/src/utils/analysis_cooling.f90 index e97271720..ed70fc07e 100644 --- a/src/utils/analysis_cooling.f90 +++ b/src/utils/analysis_cooling.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_disc.f90 b/src/utils/analysis_disc.f90 index 053466f37..1f3e9f07f 100644 --- a/src/utils/analysis_disc.f90 +++ b/src/utils/analysis_disc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_disc_MFlow.f90 b/src/utils/analysis_disc_MFlow.f90 index 170dd1fb5..9cb995cae 100644 --- a/src/utils/analysis_disc_MFlow.f90 +++ b/src/utils/analysis_disc_MFlow.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_disc_eccentric.f90 b/src/utils/analysis_disc_eccentric.f90 index e203204e1..caf029f94 100644 --- a/src/utils/analysis_disc_eccentric.f90 +++ b/src/utils/analysis_disc_eccentric.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_disc_mag.f90 b/src/utils/analysis_disc_mag.f90 index d0ad3a51a..10f91136d 100644 --- a/src/utils/analysis_disc_mag.f90 +++ b/src/utils/analysis_disc_mag.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_disc_planet.f90 b/src/utils/analysis_disc_planet.f90 index bf267ae92..aad84a586 100644 --- a/src/utils/analysis_disc_planet.f90 +++ b/src/utils/analysis_disc_planet.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index 5b375c92d..f6ffe0648 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_dtheader.f90 b/src/utils/analysis_dtheader.f90 index 51e0ab65b..d36b73452 100644 --- a/src/utils/analysis_dtheader.f90 +++ b/src/utils/analysis_dtheader.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_dustmass.f90 b/src/utils/analysis_dustmass.f90 index 07cea5567..a072aedbe 100644 --- a/src/utils/analysis_dustmass.f90 +++ b/src/utils/analysis_dustmass.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_dustydisc.f90 b/src/utils/analysis_dustydisc.f90 index 7824cfacf..c7f2d879b 100644 --- a/src/utils/analysis_dustydisc.f90 +++ b/src/utils/analysis_dustydisc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_etotgr.f90 b/src/utils/analysis_etotgr.f90 index 9acfbed46..be1a500aa 100644 --- a/src/utils/analysis_etotgr.f90 +++ b/src/utils/analysis_etotgr.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_getneighbours.f90 b/src/utils/analysis_getneighbours.f90 index 021ddb8e7..fb20606c7 100644 --- a/src/utils/analysis_getneighbours.f90 +++ b/src/utils/analysis_getneighbours.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_gws.f90 b/src/utils/analysis_gws.f90 index 9ca705e63..9be0e4330 100644 --- a/src/utils/analysis_gws.f90 +++ b/src/utils/analysis_gws.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_jet.f90 b/src/utils/analysis_jet.f90 index 8cffd8658..86c86dca8 100644 --- a/src/utils/analysis_jet.f90 +++ b/src/utils/analysis_jet.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_kepler.f90 b/src/utils/analysis_kepler.f90 index 9ed372f14..e6e63d942 100644 --- a/src/utils/analysis_kepler.f90 +++ b/src/utils/analysis_kepler.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_macctrace.f90 b/src/utils/analysis_macctrace.f90 index 9699bdcb5..26b1e224c 100644 --- a/src/utils/analysis_macctrace.f90 +++ b/src/utils/analysis_macctrace.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_mapping_mass.f90 b/src/utils/analysis_mapping_mass.f90 index 5e0c2ea84..892b5fb4c 100644 --- a/src/utils/analysis_mapping_mass.f90 +++ b/src/utils/analysis_mapping_mass.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_mcfost.f90 b/src/utils/analysis_mcfost.f90 index 1f323a9e3..05259161b 100644 --- a/src/utils/analysis_mcfost.f90 +++ b/src/utils/analysis_mcfost.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_mcfostcmdline.f90 b/src/utils/analysis_mcfostcmdline.f90 index 23c2c70f4..2e3b10dc9 100644 --- a/src/utils/analysis_mcfostcmdline.f90 +++ b/src/utils/analysis_mcfostcmdline.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_pairing.f90 b/src/utils/analysis_pairing.f90 index 539822289..fbef57fe5 100644 --- a/src/utils/analysis_pairing.f90 +++ b/src/utils/analysis_pairing.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_particle.f90 b/src/utils/analysis_particle.f90 index 88df31857..5691ff0a9 100644 --- a/src/utils/analysis_particle.f90 +++ b/src/utils/analysis_particle.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_pdfs.f90 b/src/utils/analysis_pdfs.f90 index 0846c6264..96c64fc73 100644 --- a/src/utils/analysis_pdfs.f90 +++ b/src/utils/analysis_pdfs.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_phantom_dump.f90 b/src/utils/analysis_phantom_dump.f90 index 64dca841d..0ffc60048 100644 --- a/src/utils/analysis_phantom_dump.f90 +++ b/src/utils/analysis_phantom_dump.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_polytropes.f90 b/src/utils/analysis_polytropes.f90 index fa8df727f..bd0c57df8 100644 --- a/src/utils/analysis_polytropes.f90 +++ b/src/utils/analysis_polytropes.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_prdrag.f90 b/src/utils/analysis_prdrag.f90 index ddd71172b..14160df8a 100644 --- a/src/utils/analysis_prdrag.f90 +++ b/src/utils/analysis_prdrag.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_ptmass.f90 b/src/utils/analysis_ptmass.f90 index 79f013b42..85477e1d4 100644 --- a/src/utils/analysis_ptmass.f90 +++ b/src/utils/analysis_ptmass.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index b8197dbfb..2a8305c9e 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_sinkmass.f90 b/src/utils/analysis_sinkmass.f90 index d5b8bb38a..7993d3664 100644 --- a/src/utils/analysis_sinkmass.f90 +++ b/src/utils/analysis_sinkmass.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_sphere.f90 b/src/utils/analysis_sphere.f90 index 3a4ee3f7b..837a5257a 100644 --- a/src/utils/analysis_sphere.f90 +++ b/src/utils/analysis_sphere.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_structurefn.f90 b/src/utils/analysis_structurefn.f90 index c93e77b2d..0e91bedde 100644 --- a/src/utils/analysis_structurefn.f90 +++ b/src/utils/analysis_structurefn.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_tde.f90 b/src/utils/analysis_tde.f90 index cacc90c70..e0aa5ae7e 100644 --- a/src/utils/analysis_tde.f90 +++ b/src/utils/analysis_tde.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_torus.f90 b/src/utils/analysis_torus.f90 index 83cadc742..f6a745703 100644 --- a/src/utils/analysis_torus.f90 +++ b/src/utils/analysis_torus.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_trackbox.f90 b/src/utils/analysis_trackbox.f90 index 3bbd3193b..efbe6e251 100644 --- a/src/utils/analysis_trackbox.f90 +++ b/src/utils/analysis_trackbox.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_tracks.f90 b/src/utils/analysis_tracks.f90 index 48ef90829..3812cc3b4 100644 --- a/src/utils/analysis_tracks.f90 +++ b/src/utils/analysis_tracks.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_velocitydispersion_vs_scale.f90 b/src/utils/analysis_velocitydispersion_vs_scale.f90 index e96af593f..7bd2daa9d 100644 --- a/src/utils/analysis_velocitydispersion_vs_scale.f90 +++ b/src/utils/analysis_velocitydispersion_vs_scale.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_velocityshear.f90 b/src/utils/analysis_velocityshear.f90 index 3c56397a8..16637d2d6 100644 --- a/src/utils/analysis_velocityshear.f90 +++ b/src/utils/analysis_velocityshear.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/combinedustdumps.f90 b/src/utils/combinedustdumps.f90 index 3a675c463..7dbbdf2d5 100755 --- a/src/utils/combinedustdumps.f90 +++ b/src/utils/combinedustdumps.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program combinedustdumps ! diff --git a/src/utils/cubicsolve.f90 b/src/utils/cubicsolve.f90 index 46db8aad2..3d88f97f5 100644 --- a/src/utils/cubicsolve.f90 +++ b/src/utils/cubicsolve.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cubic ! diff --git a/src/utils/diffdumps.f90 b/src/utils/diffdumps.f90 index c54a093ba..9423c6960 100644 --- a/src/utils/diffdumps.f90 +++ b/src/utils/diffdumps.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program diffdumps ! diff --git a/src/utils/dustywaves.f90 b/src/utils/dustywaves.f90 index af14457ed..2d671513f 100644 --- a/src/utils/dustywaves.f90 +++ b/src/utils/dustywaves.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module dustywaves ! diff --git a/src/utils/ev2kdot.f90 b/src/utils/ev2kdot.f90 index 1e32e39ca..dced7d521 100644 --- a/src/utils/ev2kdot.f90 +++ b/src/utils/ev2kdot.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program get_kdot ! diff --git a/src/utils/ev2mdot.f90 b/src/utils/ev2mdot.f90 index e9f899484..40374442b 100644 --- a/src/utils/ev2mdot.f90 +++ b/src/utils/ev2mdot.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program get_mdot ! diff --git a/src/utils/evol_dustywaves.f90 b/src/utils/evol_dustywaves.f90 index 777c3e67d..e9584604c 100644 --- a/src/utils/evol_dustywaves.f90 +++ b/src/utils/evol_dustywaves.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program ekin ! diff --git a/src/utils/get_struct_slope.f90 b/src/utils/get_struct_slope.f90 index 157d82e18..789e39854 100644 --- a/src/utils/get_struct_slope.f90 +++ b/src/utils/get_struct_slope.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program get_struct_slope ! diff --git a/src/utils/getmathflags.f90 b/src/utils/getmathflags.f90 index f5800c35c..fbe9f872e 100644 --- a/src/utils/getmathflags.f90 +++ b/src/utils/getmathflags.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program getmathflags ! diff --git a/src/utils/grid2pdf.f90 b/src/utils/grid2pdf.f90 index 262f40216..8ae7ad563 100644 --- a/src/utils/grid2pdf.f90 +++ b/src/utils/grid2pdf.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program grid2pdf ! diff --git a/src/utils/hdf5utils.f90 b/src/utils/hdf5utils.f90 index fbbed0413..34031f068 100644 --- a/src/utils/hdf5utils.f90 +++ b/src/utils/hdf5utils.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module hdf5utils ! diff --git a/src/utils/icosahedron.f90 b/src/utils/icosahedron.f90 index 9ac9dbada..d0b00c594 100644 --- a/src/utils/icosahedron.f90 +++ b/src/utils/icosahedron.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module icosahedron ! diff --git a/src/utils/io_grid.f90 b/src/utils/io_grid.f90 index 9e74dfe43..a54cec7fe 100644 --- a/src/utils/io_grid.f90 +++ b/src/utils/io_grid.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module io_grid ! diff --git a/src/utils/io_structurefn.f90 b/src/utils/io_structurefn.f90 index e91667800..ca736c360 100644 --- a/src/utils/io_structurefn.f90 +++ b/src/utils/io_structurefn.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module io_structurefn ! diff --git a/src/utils/leastsquares.f90 b/src/utils/leastsquares.f90 index 644985262..f71fd3473 100644 --- a/src/utils/leastsquares.f90 +++ b/src/utils/leastsquares.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module leastsquares ! diff --git a/src/utils/libphantom-splash.f90 b/src/utils/libphantom-splash.f90 index 37063007d..2c0fc772a 100644 --- a/src/utils/libphantom-splash.f90 +++ b/src/utils/libphantom-splash.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module libphantomsplash ! diff --git a/src/utils/lombperiod.f90 b/src/utils/lombperiod.f90 index 295dc7147..d9b7a668e 100644 --- a/src/utils/lombperiod.f90 +++ b/src/utils/lombperiod.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program lombperiod ! diff --git a/src/utils/mflow.f90 b/src/utils/mflow.f90 index 163ef7eec..ea284e3fa 100644 --- a/src/utils/mflow.f90 +++ b/src/utils/mflow.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program mflow ! diff --git a/src/utils/moddump_CoM.f90 b/src/utils/moddump_CoM.f90 index 13ea42ec8..72df6ef41 100644 --- a/src/utils/moddump_CoM.f90 +++ b/src/utils/moddump_CoM.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_addflyby.f90 b/src/utils/moddump_addflyby.f90 index 350e2db20..59bb9ca36 100644 --- a/src/utils/moddump_addflyby.f90 +++ b/src/utils/moddump_addflyby.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_addplanets.f90 b/src/utils/moddump_addplanets.f90 index ee71c218d..9f913bb0c 100644 --- a/src/utils/moddump_addplanets.f90 +++ b/src/utils/moddump_addplanets.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_binary.f90 b/src/utils/moddump_binary.f90 index 03e7ec38d..c4c1077c3 100644 --- a/src/utils/moddump_binary.f90 +++ b/src/utils/moddump_binary.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_binarystar.f90 b/src/utils/moddump_binarystar.f90 index 27e9fbc42..4e15def00 100644 --- a/src/utils/moddump_binarystar.f90 +++ b/src/utils/moddump_binarystar.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_changemass.f90 b/src/utils/moddump_changemass.f90 index 7d8acfa6f..a407d17e7 100644 --- a/src/utils/moddump_changemass.f90 +++ b/src/utils/moddump_changemass.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_default.f90 b/src/utils/moddump_default.f90 index 076fb2b9b..0ae0f2a97 100644 --- a/src/utils/moddump_default.f90 +++ b/src/utils/moddump_default.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_disc.f90 b/src/utils/moddump_disc.f90 index fb9157e68..13a7bd473 100644 --- a/src/utils/moddump_disc.f90 +++ b/src/utils/moddump_disc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_dustadd.f90 b/src/utils/moddump_dustadd.f90 index dc9fb58f9..588a74707 100644 --- a/src/utils/moddump_dustadd.f90 +++ b/src/utils/moddump_dustadd.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_extenddisc.f90 b/src/utils/moddump_extenddisc.f90 index 1998cfa5c..1f16281da 100644 --- a/src/utils/moddump_extenddisc.f90 +++ b/src/utils/moddump_extenddisc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_growthtomultigrain.f90 b/src/utils/moddump_growthtomultigrain.f90 index 5574e9cc0..0c5e599df 100644 --- a/src/utils/moddump_growthtomultigrain.f90 +++ b/src/utils/moddump_growthtomultigrain.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_mergepart.f90 b/src/utils/moddump_mergepart.f90 index 813d6cf56..17d42b67b 100644 --- a/src/utils/moddump_mergepart.f90 +++ b/src/utils/moddump_mergepart.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_messupSPH.f90 b/src/utils/moddump_messupSPH.f90 index 5cbc89761..1f0b8a257 100644 --- a/src/utils/moddump_messupSPH.f90 +++ b/src/utils/moddump_messupSPH.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_perturbgas.f90 b/src/utils/moddump_perturbgas.f90 index 44562425a..8e895aafa 100644 --- a/src/utils/moddump_perturbgas.f90 +++ b/src/utils/moddump_perturbgas.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_polytrope.f90 b/src/utils/moddump_polytrope.f90 index 7e8b9e5bd..ed9554b90 100644 --- a/src/utils/moddump_polytrope.f90 +++ b/src/utils/moddump_polytrope.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_rad_to_LTE.f90 b/src/utils/moddump_rad_to_LTE.f90 index a2abc1295..7b14b0ee0 100644 --- a/src/utils/moddump_rad_to_LTE.f90 +++ b/src/utils/moddump_rad_to_LTE.f90 @@ -2,11 +2,11 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! -! moddump +! Convert radiation dump to LTE dump (ieos=12) ! ! :References: None ! diff --git a/src/utils/moddump_recalcuT.f90 b/src/utils/moddump_recalcuT.f90 index 5aa1792a7..814c275cf 100644 --- a/src/utils/moddump_recalcuT.f90 +++ b/src/utils/moddump_recalcuT.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_removeparticles_cylinder.f90 b/src/utils/moddump_removeparticles_cylinder.f90 index faca53808..eed6b214f 100644 --- a/src/utils/moddump_removeparticles_cylinder.f90 +++ b/src/utils/moddump_removeparticles_cylinder.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_removeparticles_radius.f90 b/src/utils/moddump_removeparticles_radius.f90 index 53a2e0cd6..d9bbd3e94 100644 --- a/src/utils/moddump_removeparticles_radius.f90 +++ b/src/utils/moddump_removeparticles_radius.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_rotate.f90 b/src/utils/moddump_rotate.f90 index 8cf4cca41..34a6a069f 100644 --- a/src/utils/moddump_rotate.f90 +++ b/src/utils/moddump_rotate.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_sink.f90 b/src/utils/moddump_sink.f90 index 4cbf7c449..444a45e22 100644 --- a/src/utils/moddump_sink.f90 +++ b/src/utils/moddump_sink.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! @@ -77,7 +77,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) xyzmh_ptmass(1,isinkpart) = newx print*,'x-coordinate changed to ',xyzmh_ptmass(1,isinkpart) - Lnuc = xyzmh_ptmass(1,ilum) + Lnuc = xyzmh_ptmass(ilum,isinkpart) Lnuc_cgs = Lnuc * unit_energ / utime call prompt('Enter new sink heating luminosity in erg/s:',Lnuc_cgs,0.) xyzmh_ptmass(ilum,isinkpart) = Lnuc_cgs / unit_energ * utime diff --git a/src/utils/moddump_sinkbinary.f90 b/src/utils/moddump_sinkbinary.f90 index 94a73f429..46a128db7 100644 --- a/src/utils/moddump_sinkbinary.f90 +++ b/src/utils/moddump_sinkbinary.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_sphNG2phantom.f90 b/src/utils/moddump_sphNG2phantom.f90 index 682843b10..ad1b1feb7 100644 --- a/src/utils/moddump_sphNG2phantom.f90 +++ b/src/utils/moddump_sphNG2phantom.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_sphNG2phantom_addBfield.f90 b/src/utils/moddump_sphNG2phantom_addBfield.f90 index 423925306..e33c1cb92 100644 --- a/src/utils/moddump_sphNG2phantom_addBfield.f90 +++ b/src/utils/moddump_sphNG2phantom_addBfield.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_sphNG2phantom_disc.f90 b/src/utils/moddump_sphNG2phantom_disc.f90 index d274101eb..833b765cf 100644 --- a/src/utils/moddump_sphNG2phantom_disc.f90 +++ b/src/utils/moddump_sphNG2phantom_disc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_splitpart.f90 b/src/utils/moddump_splitpart.f90 index a3cb83619..9f932cffc 100644 --- a/src/utils/moddump_splitpart.f90 +++ b/src/utils/moddump_splitpart.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_taylorgreen.f90 b/src/utils/moddump_taylorgreen.f90 index 3d3630111..f165d49b6 100644 --- a/src/utils/moddump_taylorgreen.f90 +++ b/src/utils/moddump_taylorgreen.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_tidal.f90 b/src/utils/moddump_tidal.f90 index 35db33aae..a4a1b4b51 100644 --- a/src/utils/moddump_tidal.f90 +++ b/src/utils/moddump_tidal.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/moddump_torus.f90 b/src/utils/moddump_torus.f90 index 241a124af..3de87ae9a 100644 --- a/src/utils/moddump_torus.f90 +++ b/src/utils/moddump_torus.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module moddump ! diff --git a/src/utils/multirun.f90 b/src/utils/multirun.f90 index 8bf04032e..5536cdcf5 100644 --- a/src/utils/multirun.f90 +++ b/src/utils/multirun.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program multirun ! diff --git a/src/utils/multirun_mach.f90 b/src/utils/multirun_mach.f90 index 6e6407880..df2cb5b97 100644 --- a/src/utils/multirun_mach.f90 +++ b/src/utils/multirun_mach.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program multirun ! diff --git a/src/utils/pdfs.f90 b/src/utils/pdfs.f90 index 93bbe84dc..fd306041d 100644 --- a/src/utils/pdfs.f90 +++ b/src/utils/pdfs.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module pdfs ! diff --git a/src/utils/phantom2divb.f90 b/src/utils/phantom2divb.f90 index 88ea4e22f..cac56bccd 100644 --- a/src/utils/phantom2divb.f90 +++ b/src/utils/phantom2divb.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantom2divb ! diff --git a/src/utils/phantom2divv.f90 b/src/utils/phantom2divv.f90 index 613c932cf..0befaad7d 100644 --- a/src/utils/phantom2divv.f90 +++ b/src/utils/phantom2divv.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantom2divv ! diff --git a/src/utils/phantom2gadget.f90 b/src/utils/phantom2gadget.f90 index 77422aaef..1681ff9cc 100644 --- a/src/utils/phantom2gadget.f90 +++ b/src/utils/phantom2gadget.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantom2gadget ! diff --git a/src/utils/phantom2hdf5.f90 b/src/utils/phantom2hdf5.f90 index 6d327dba2..d4d032e0c 100644 --- a/src/utils/phantom2hdf5.f90 +++ b/src/utils/phantom2hdf5.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantom2hdf5 ! diff --git a/src/utils/phantom2sphNG.f90 b/src/utils/phantom2sphNG.f90 index f0717c272..b4532fbef 100644 --- a/src/utils/phantom2sphNG.f90 +++ b/src/utils/phantom2sphNG.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantom2sphNG ! diff --git a/src/utils/phantom_moddump.f90 b/src/utils/phantom_moddump.f90 index 0ec474738..a6ed9bb0d 100644 --- a/src/utils/phantom_moddump.f90 +++ b/src/utils/phantom_moddump.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantommoddump ! diff --git a/src/utils/phantomanalysis.f90 b/src/utils/phantomanalysis.f90 index 60c16c288..a0b88c2d2 100644 --- a/src/utils/phantomanalysis.f90 +++ b/src/utils/phantomanalysis.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantomanalysis ! @@ -58,7 +58,8 @@ program phantomanalysis ! if (iarg==1) then - iloc = index(dumpfile,'_0') + !iloc = index(dumpfile,'_0') + iloc = index(dumpfile,'_',.true.) !to load dump > 9999 if (iloc > 1) then fileprefix = trim(dumpfile(1:iloc-1)) diff --git a/src/utils/phantomevcompare.f90 b/src/utils/phantomevcompare.f90 index 7cc6d7339..8a0d15062 100644 --- a/src/utils/phantomevcompare.f90 +++ b/src/utils/phantomevcompare.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantomevcompare ! diff --git a/src/utils/phantomextractsinks.f90 b/src/utils/phantomextractsinks.f90 index 158f6ecd6..1e4577fde 100644 --- a/src/utils/phantomextractsinks.f90 +++ b/src/utils/phantomextractsinks.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantomextractsinks ! diff --git a/src/utils/plot_kernel.f90 b/src/utils/plot_kernel.f90 index bf6525be9..35b176884 100644 --- a/src/utils/plot_kernel.f90 +++ b/src/utils/plot_kernel.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program plot_kernel ! diff --git a/src/utils/powerspectrums.f90 b/src/utils/powerspectrums.f90 index 446c128cd..0ffd56515 100644 --- a/src/utils/powerspectrums.f90 +++ b/src/utils/powerspectrums.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module powerspectrums ! diff --git a/src/utils/prompting.f90 b/src/utils/prompting.f90 index 7150a9045..c87e5f77c 100644 --- a/src/utils/prompting.f90 +++ b/src/utils/prompting.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module prompting ! diff --git a/src/utils/quartic.f90 b/src/utils/quartic.f90 index 2ac30de9f..4ae9ee375 100644 --- a/src/utils/quartic.f90 +++ b/src/utils/quartic.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module quartic ! diff --git a/src/utils/rhomach.f90 b/src/utils/rhomach.f90 index 730f96a85..8164eb3a2 100644 --- a/src/utils/rhomach.f90 +++ b/src/utils/rhomach.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module rhomach ! diff --git a/src/utils/showarrays.f90 b/src/utils/showarrays.f90 index e3cb34833..64762b59c 100644 --- a/src/utils/showarrays.f90 +++ b/src/utils/showarrays.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program showarrays ! diff --git a/src/utils/showheader.f90 b/src/utils/showheader.f90 index 9e6b797b6..b70b1a884 100644 --- a/src/utils/showheader.f90 +++ b/src/utils/showheader.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program showheader ! @@ -43,7 +43,7 @@ program showheader ! try to open it as a small dump close(iu) call open_dumpfile_r(iu,dumpfile,fileid,ierr,singleprec=.true.) - if (ierr == 0) call read_header(iu,hdr,.true.,ierr,singleprec=.true.) + if (ierr == 0) call read_header(iu,hdr,ierr,singleprec=.true.) else print "(a)",' ERROR opening '//trim(dumpfile) endif @@ -51,7 +51,7 @@ program showheader ! ! read and print the file header ! - call read_header(iu,hdr,.true.,ierr) + call read_header(iu,hdr,ierr) endif if (ierr == 0) then if (nargs > 1) print "(/,':: ',a,' ::',/)",trim(dumpfile) diff --git a/src/utils/solvelinearsystem.f90 b/src/utils/solvelinearsystem.f90 index a74d3b407..fefb6c08e 100644 --- a/src/utils/solvelinearsystem.f90 +++ b/src/utils/solvelinearsystem.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module solvelinearsystem ! diff --git a/src/utils/splitpart.f90 b/src/utils/splitpart.f90 index bde83db10..c6847e607 100644 --- a/src/utils/splitpart.f90 +++ b/src/utils/splitpart.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module splitpart ! diff --git a/src/utils/struct2struct.f90 b/src/utils/struct2struct.f90 index bc7470b63..2d22707f3 100644 --- a/src/utils/struct2struct.f90 +++ b/src/utils/struct2struct.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program struct2struct ! diff --git a/src/utils/test_binary.f90 b/src/utils/test_binary.f90 index ca149e2bd..4dd432524 100644 --- a/src/utils/test_binary.f90 +++ b/src/utils/test_binary.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testbinary ! diff --git a/src/utils/testbinary.f90 b/src/utils/testbinary.f90 index a58d51db3..f7da761f8 100644 --- a/src/utils/testbinary.f90 +++ b/src/utils/testbinary.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program testbin ! diff --git a/src/utils/utils_disc.f90 b/src/utils/utils_disc.f90 index b38f09bd9..91b783c29 100644 --- a/src/utils/utils_disc.f90 +++ b/src/utils/utils_disc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module discanalysisutils ! diff --git a/src/utils/utils_ephemeris.f90 b/src/utils/utils_ephemeris.f90 index fe9666b07..c6d0a689c 100644 --- a/src/utils/utils_ephemeris.f90 +++ b/src/utils/utils_ephemeris.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module ephemeris ! diff --git a/src/utils/utils_evfiles.f90 b/src/utils/utils_evfiles.f90 index fef0a7090..515da58e6 100644 --- a/src/utils/utils_evfiles.f90 +++ b/src/utils/utils_evfiles.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module evutils ! diff --git a/src/utils/utils_gravwave.f90 b/src/utils/utils_gravwave.f90 index db9348a6b..225f091b6 100644 --- a/src/utils/utils_gravwave.f90 +++ b/src/utils/utils_gravwave.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module gravwaveutils ! diff --git a/src/utils/utils_linalg.f90 b/src/utils/utils_linalg.f90 index 8c22b1fac..c4c6c22bd 100644 --- a/src/utils/utils_linalg.f90 +++ b/src/utils/utils_linalg.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module linalg ! diff --git a/src/utils/utils_mpc.f90 b/src/utils/utils_mpc.f90 index 5eda889e4..3a90abd94 100644 --- a/src/utils/utils_mpc.f90 +++ b/src/utils/utils_mpc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mpc ! diff --git a/src/utils/utils_orbits.f90 b/src/utils/utils_orbits.f90 index 94e97e6f7..a92cd3da9 100644 --- a/src/utils/utils_orbits.f90 +++ b/src/utils/utils_orbits.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module orbits_data ! diff --git a/src/utils/utils_splitmerge.f90 b/src/utils/utils_splitmerge.f90 index c8c91312e..87ec4670c 100644 --- a/src/utils/utils_splitmerge.f90 +++ b/src/utils/utils_splitmerge.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module splitmergeutils ! diff --git a/src/utils/velfield.f90 b/src/utils/velfield.f90 index fbdcb70a9..4792a65f7 100644 --- a/src/utils/velfield.f90 +++ b/src/utils/velfield.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module velfield ! From c04a21a0c28ba8c928866fadebb362cdff82fdc1 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 10 Apr 2024 17:03:02 +0100 Subject: [PATCH 392/814] restoring upstream changes part 2 --- src/main/damping.f90 | 2 +- src/main/dens.F90 | 4 +- src/main/deriv.F90 | 27 +- src/main/dtype_kdtree.F90 | 2 +- src/main/{dust.F90 => dust.f90} | 4 +- ...{dust_formation.F90 => dust_formation.f90} | 0 src/main/energies.F90 | 196 ++++--- src/main/eos_barotropic.f90 | 2 +- src/main/eos_gasradrec.f90 | 2 +- src/main/eos_helmholtz.f90 | 2 +- src/main/eos_idealplusrad.f90 | 2 +- src/main/eos_mesa.f90 | 2 +- src/main/eos_mesa_microphysics.f90 | 2 +- src/main/eos_piecewise.f90 | 2 +- src/main/eos_shen.f90 | 2 +- src/main/eos_stratified.f90 | 2 +- src/main/evwrite.F90 | 505 ------------------ src/main/extern_Bfield.f90 | 2 +- src/main/extern_binary.f90 | 2 +- src/main/extern_binary_gw.f90 | 2 +- src/main/extern_corotate.f90 | 2 +- src/main/extern_densprofile.f90 | 2 +- ...{extern_gnewton.F90 => extern_gnewton.f90} | 2 +- src/main/extern_gwinspiral.f90 | 2 +- src/main/extern_lensethirring.f90 | 2 +- .../{extern_prdrag.F90 => extern_prdrag.f90} | 2 +- src/main/extern_spiral.f90 | 2 +- src/main/extern_staticsine.f90 | 2 +- src/main/externalforces.F90 | 2 +- src/main/externalforces_gr.F90 | 2 +- src/main/kdtree.F90 | 2 +- src/main/readwrite_dumps_hdf5.F90 | 4 +- ...{sort_particles.F90 => sort_particles.f90} | 2 +- src/main/step_supertimestep.F90 | 2 +- src/main/{timestep.F90 => timestep.f90} | 2 +- src/main/units.f90 | 16 +- src/main/utils_allocate.f90 | 2 +- src/main/utils_binary.f90 | 32 +- src/main/utils_cpuinfo.f90 | 2 +- src/main/utils_datafiles.f90 | 10 +- src/main/utils_dumpfiles.f90 | 95 ++-- src/main/utils_dumpfiles_hdf5.f90 | 2 +- src/main/utils_gr.F90 | 2 +- src/main/utils_hdf5.f90 | 2 +- src/main/utils_healpix.f90 | 2 +- src/main/utils_infiles.f90 | 2 +- 46 files changed, 247 insertions(+), 716 deletions(-) rename src/main/{dust.F90 => dust.f90} (99%) rename src/main/{dust_formation.F90 => dust_formation.f90} (100%) delete mode 100644 src/main/evwrite.F90 rename src/main/{extern_gnewton.F90 => extern_gnewton.f90} (98%) rename src/main/{extern_prdrag.F90 => extern_prdrag.f90} (99%) rename src/main/{sort_particles.F90 => sort_particles.f90} (98%) rename src/main/{timestep.F90 => timestep.f90} (99%) diff --git a/src/main/damping.f90 b/src/main/damping.f90 index 87d3c98ce..d7c83f925 100644 --- a/src/main/damping.f90 +++ b/src/main/damping.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module damping ! diff --git a/src/main/dens.F90 b/src/main/dens.F90 index a596f78dc..daece1767 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module densityforce ! @@ -939,7 +939,7 @@ pure subroutine calculate_divcurlv_from_sums(rhosum,termnorm,divcurlvi,ndivcurlv !--time derivative of div v, needed for Cullen-Dehnen switch if (nalpha >= 2) then !--Divvdt For switch - if (use_exact_linear) then + if (use_exact_linear .and. abs(denom) > tiny(denom)) then ddenom = 1./denom call exactlinear(gradaxdx,gradaxdy,gradaxdz,rhosum(idaxdxi),rhosum(idaxdyi),rhosum(idaxdzi),rmatrix,ddenom) call exactlinear(gradaydx,gradaydy,gradaydz,rhosum(idaydxi),rhosum(idaydyi),rhosum(idaydzi),rmatrix,ddenom) diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index dc2dd9876..fd6b06ceb 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module deriv ! @@ -20,8 +20,6 @@ module deriv ! timestep, timestep_ind, timing ! implicit none - character(len=80), parameter, public :: & ! module version - modid="$Id$" public :: derivs, get_derivs_global real, private :: stressmax @@ -40,7 +38,7 @@ 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) use dim, only:maxvxyzu,mhd,fast_divcurlB,gr,periodic,do_radiation,& - sink_radiation,use_dustgrowth + sink_radiation,use_dustgrowth,ind_timesteps use io, only:iprint,fatal,error use linklist, only:set_linklist use densityforce, only:densityiterate @@ -48,12 +46,8 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& use externalforces, only:externalforce use part, only:dustgasprop,dvdx,Bxyz,set_boundaries_to_active,& nptmass,xyzmh_ptmass,sinks_have_heating,dust_temp,VrelVf,fxyz_drag -#ifdef IND_TIMESTEPS use timestep_ind, only:nbinmax -#else - use timestep, only:dtcourant,dtforce,dtrad -#endif - use timestep, only:dtmax + use timestep, only:dtmax,dtcourant,dtforce,dtrad #ifdef DRIVING use forcing, only:forceit #endif @@ -149,7 +143,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& set_boundaries_to_active = .false. ! boundary particles are no longer treated as active call do_timing('dens',tlast,tcpulast) endif - + if (gr) then call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) else @@ -163,8 +157,9 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& if (do_radiation .and. implicit_radiation .and. dt > 0.) then call do_radiation_implicit(dt,npart,rad,xyzh,vxyzu,radprop,drad,ierr) if (ierr /= 0 .and. ierr /= ierr_failed_to_converge) call fatal('radiation','Failed in radiation') + call do_timing('radiation',tlast,tcpulast) endif - + ! ! compute forces ! @@ -204,11 +199,11 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& ! ! set new timestep from Courant/forces condition ! -#ifdef IND_TIMESTEPS - dtnew = dtmax/2**nbinmax ! minimum timestep over all particles -#else - dtnew = min(dtforce,dtcourant,dtrad,dtmax) -#endif + if (ind_timesteps) then + dtnew = dtmax/2.**nbinmax ! minimum timestep over all particles + else + dtnew = min(dtforce,dtcourant,dtrad,dtmax) + endif call do_timing('total',t1,tcpu1,lunit=iprint) diff --git a/src/main/dtype_kdtree.F90 b/src/main/dtype_kdtree.F90 index 3cee3685c..6cf50144f 100644 --- a/src/main/dtype_kdtree.F90 +++ b/src/main/dtype_kdtree.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module dtypekdtree ! diff --git a/src/main/dust.F90 b/src/main/dust.f90 similarity index 99% rename from src/main/dust.F90 rename to src/main/dust.f90 index 44b92240d..8270c5ea9 100644 --- a/src/main/dust.F90 +++ b/src/main/dust.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module dust ! @@ -410,7 +410,7 @@ subroutine read_options_dust(name,valstring,imatch,igotall,ierr) end select !--Check that we have just the *necessary* parameters - if (all(ineed == igot)) igotall = .true. + if (all(igot >= ineed)) igotall = .true. end subroutine read_options_dust diff --git a/src/main/dust_formation.F90 b/src/main/dust_formation.f90 similarity index 100% rename from src/main/dust_formation.F90 rename to src/main/dust_formation.f90 diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 20d229c8c..27684ce97 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module energies ! @@ -17,9 +17,9 @@ module energies ! :Runtime parameters: None ! ! :Dependencies: boundary_dyn, centreofmass, dim, dust, eos, eos_piecewise, -! externalforces, fastmath, gravwaveutils, io, kernel, metric_tools, -! mpiutils, nicil, options, part, ptmass, timestep, units, utils_gr, -! vectorutils, viscosity +! externalforces, gravwaveutils, io, kernel, metric_tools, mpiutils, +! nicil, options, part, ptmass, timestep, units, utils_gr, vectorutils, +! viscosity ! use dim, only:maxdusttypes,maxdustsmall use units, only:utime @@ -62,7 +62,7 @@ module energies !---------------------------------------------------------------- subroutine compute_energies(t) use dim, only:maxp,maxvxyzu,maxalpha,maxtypes,mhd_nonideal,maxp_hard,& - lightcurve,use_dust,maxdusttypes,do_radiation,gr + lightcurve,use_dust,maxdusttypes,do_radiation,gr,use_krome use part, only:rhoh,xyzh,vxyzu,massoftype,npart,maxphase,iphase,& alphaind,Bevol,divcurlB,iamtype,igamma,& igas,idust,iboundary,istar,idarkmatter,ibulge,& @@ -74,7 +74,7 @@ subroutine compute_energies(t) use part, only:pxyzu,fxyzu,fext use gravwaveutils, only:calculate_strain,calc_gravitwaves use centreofmass, only:get_centreofmass_accel - use eos, only:polyk,utherm,gamma,eos_is_non_ideal,eos_outputs_gasP + use eos, only:polyk,gamma,eos_is_non_ideal,eos_outputs_gasP use eos_piecewise, only:gamma_pwp use io, only:id,fatal,master use externalforces, only:externalforce,externalforce_vdependent,was_accreted,accradius1 @@ -83,19 +83,14 @@ subroutine compute_energies(t) use ptmass, only:get_accel_sink_gas use viscosity, only:irealvisc,shearfunc use nicil, only:nicil_update_nimhd,nicil_get_halldrift,nicil_get_ambidrift, & - use_ohm,use_hall,use_ambi,n_data_out,n_warn + use_ohm,use_hall,use_ambi,n_data_out,n_warn,eta_constant use boundary_dyn, only:dynamic_bdy,find_dynamic_boundaries use kernel, only:radkern use timestep, only:dtmax -#ifdef GR use part, only:metrics use metric_tools, only:unpack_metric use utils_gr, only:dot_product_gr,get_geodesic_accel use vectorutils, only:cross_product3D -#ifdef FINVSQRT - use fastmath, only:finvsqrt -#endif -#endif use part, only:luminosity use dust, only:get_ts,idrag real, intent(in) :: t @@ -113,10 +108,8 @@ subroutine compute_energies(t) real :: curlBi(3),vhalli(3),vioni(3),data_out(n_data_out) real :: erotxi,erotyi,erotzi,fdum(3),x0(3),v0(3),a0(3),xyz_x_all(3),xyz_n_all(3) real :: ethermi -#ifdef GR real :: pdotv,bigvi(1:3),alpha_gr,beta_gr_UP(1:3),lorentzi,pxi,pyi,pzi real :: gammaijdown(1:3,1:3),angi(1:3),fourvel_space(3) -#endif integer :: i,j,itype,iu integer :: ierrlist(n_warn) integer(kind=8) :: np,npgas,nptot,np_rho(maxtypes),np_rho_thread(maxtypes) @@ -174,14 +167,14 @@ subroutine compute_energies(t) !$omp shared(alphaind,massoftype,irealvisc,iu) & !$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) & +!$omp shared(use_ohm,use_hall,use_ambi,nden_nimhd,eta_nimhd,eta_constant) & !$omp shared(ev_data,np_rho,erot_com,calc_erot,gas_only,track_mass) & !$omp shared(calc_gravitwaves) & !$omp shared(iev_erad,iev_rho,iev_dt,iev_entrop,iev_rhop,iev_alpha) & !$omp shared(iev_B,iev_divB,iev_hdivB,iev_beta,iev_temp,iev_etao,iev_etah) & !$omp shared(iev_etaa,iev_vel,iev_vhall,iev_vion,iev_n) & !$omp shared(iev_dtg,iev_ts,iev_macc,iev_totlum,iev_erot,iev_viscrat) & -!$omp shared(eos_vars,grainsize,graindens,ndustsmall) & +!$omp shared(eos_vars,grainsize,graindens,ndustsmall,metrics) & !$omp private(i,j,xi,yi,zi,hi,rhoi,vxi,vyi,vzi,Bxi,Byi,Bzi,Bi,B2i,epoti,vsigi,v2i,vi1) & !$omp private(ponrhoi,spsoundi,gammai,spsound2i,va2cs2,rho1cs2,ethermi,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & !$omp private(rho1i,shearparam_art,shearparam_phys,ratio_phys_to_av,betai) & @@ -190,10 +183,7 @@ subroutine compute_energies(t) !$omp private(erotxi,erotyi,erotzi,fdum) & !$omp private(ev_data_thread,np_rho_thread) & !$omp firstprivate(alphai,itype,pmassi) & -#ifdef GR -!$omp shared(metrics) & !$omp private(pxi,pyi,pzi,gammaijdown,alpha_gr,beta_gr_UP,bigvi,lorentzi,pdotv,angi,fourvel_space) & -#endif !$omp shared(idrag) & !$omp private(tsi,iregime,idusttype) & !$omp shared(luminosity,track_lum) & @@ -247,57 +237,53 @@ subroutine compute_energies(t) vyi = vxyzu(2,i) vzi = vxyzu(3,i) -#ifdef GR - pxi = pxyzu(1,i) - pyi = pxyzu(2,i) - pzi = pxyzu(3,i) - - ! linear momentum - xmom = xmom + pmassi*pxi - ymom = ymom + pmassi*pyi - zmom = zmom + pmassi*pzi - - call unpack_metric(metrics(:,:,:,i),betaUP=beta_gr_UP,alpha=alpha_gr,gammaijdown=gammaijdown) - bigvi = (vxyzu(1:3,i)+beta_gr_UP)/alpha_gr - v2i = dot_product_gr(bigvi,bigvi,gammaijdown) -#ifdef FINVSQRT - lorentzi = finvsqrt(1.-v2i) -#else - lorentzi = 1./sqrt(1.-v2i) -#endif - pdotv = pxi*vxi + pyi*vyi + pzi*vzi - - ! angular momentum - fourvel_space = (lorentzi/alpha_gr)*vxyzu(1:3,i) - call cross_product3D(xyzh(1:3,i),fourvel_space,angi) ! position cross with four-velocity - angx = angx + pmassi*angi(1) - angy = angy + pmassi*angi(2) - angz = angz + pmassi*angi(3) - - ! kinetic energy - ekin = ekin + pmassi*(pdotv + alpha_gr/lorentzi - 1.) ! The 'kinetic term' in total specific energy, minus rest mass - mtot = mtot + pmassi -#else - ! centre of mass - xcom = xcom + pmassi*xi - ycom = ycom + pmassi*yi - zcom = zcom + pmassi*zi - mtot = mtot + pmassi - - ! linear momentum - xmom = xmom + pmassi*vxi - ymom = ymom + pmassi*vyi - zmom = zmom + pmassi*vzi - - ! angular momentum - angx = angx + pmassi*(yi*vzi - zi*vyi) - angy = angy + pmassi*(zi*vxi - xi*vzi) - angz = angz + pmassi*(xi*vyi - yi*vxi) - - ! kinetic energy & rms velocity - v2i = vxi*vxi + vyi*vyi + vzi*vzi - ekin = ekin + pmassi*v2i -#endif + if (gr) then + pxi = pxyzu(1,i) + pyi = pxyzu(2,i) + pzi = pxyzu(3,i) + + ! linear momentum + xmom = xmom + pmassi*pxi + ymom = ymom + pmassi*pyi + zmom = zmom + pmassi*pzi + + call unpack_metric(metrics(:,:,:,i),betaUP=beta_gr_UP,alpha=alpha_gr,gammaijdown=gammaijdown) + bigvi = (vxyzu(1:3,i)+beta_gr_UP)/alpha_gr + v2i = dot_product_gr(bigvi,bigvi,gammaijdown) + lorentzi = 1./sqrt(1.-v2i) + pdotv = pxi*vxi + pyi*vyi + pzi*vzi + + ! angular momentum + fourvel_space = (lorentzi/alpha_gr)*vxyzu(1:3,i) + call cross_product3D(xyzh(1:3,i),fourvel_space,angi) ! position cross with four-velocity + angx = angx + pmassi*angi(1) + angy = angy + pmassi*angi(2) + angz = angz + pmassi*angi(3) + + ! kinetic energy + ekin = ekin + pmassi*(pdotv + alpha_gr/lorentzi - 1.) ! The 'kinetic term' in total specific energy, minus rest mass + mtot = mtot + pmassi + else + ! centre of mass + xcom = xcom + pmassi*xi + ycom = ycom + pmassi*yi + zcom = zcom + pmassi*zi + mtot = mtot + pmassi + + ! linear momentum + xmom = xmom + pmassi*vxi + ymom = ymom + pmassi*vyi + zmom = zmom + pmassi*vzi + + ! angular momentum + angx = angx + pmassi*(yi*vzi - zi*vyi) + angy = angy + pmassi*(zi*vxi - xi*vzi) + angz = angz + pmassi*(xi*vyi - yi*vxi) + + ! kinetic energy & rms velocity + v2i = vxi*vxi + vyi*vyi + vzi*vzi + ekin = ekin + pmassi*v2i + endif vrms = vrms + v2i @@ -369,10 +355,9 @@ subroutine compute_energies(t) spsoundi = eos_vars(ics,i) gammai = eos_vars(igamma,i) if (maxvxyzu >= 4) then - ethermi = pmassi*utherm(vxyzu(:,i),rhoi,gamma)*gasfrac -#ifdef GR - ethermi = (alpha_gr/lorentzi)*ethermi -#endif + ethermi = pmassi*vxyzu(4,i)*gasfrac + if (gr) ethermi = (alpha_gr/lorentzi)*ethermi + etherm = etherm + ethermi if (vxyzu(iu,i) < tiny(vxyzu(iu,i))) np_e_eq_0 = np_e_eq_0 + 1 @@ -475,24 +460,26 @@ subroutine compute_energies(t) call ev_data_update(ev_data_thread,iev_vel, sqrt(v2i) ) call ev_data_update(ev_data_thread,iev_vion, vion ) endif - n_ion = 0 - do j = 9,21 - n_ion = n_ion + data_out(j) - enddo - n_total = data_out(5) - if (n_total > 0.) then - n_total1 = 1.0/n_total - else - n_total1 = 0.0 ! only possible if eta_constant = .true. + if (.not.eta_constant) then + n_ion = 0 + do j = 9,21 + n_ion = n_ion + data_out(j) + enddo + n_total = data_out(5) + if (n_total > 0.) then + n_total1 = 1.0/n_total + else + n_total1 = 0.0 ! only possible if eta_constant = .true. + endif + eta_nimhd(iion,i) = n_ion*n_total1 ! Save ionisation fraction for the dump file + call ev_data_update(ev_data_thread,iev_n(1),n_ion*n_total1) + call ev_data_update(ev_data_thread,iev_n(2),data_out( 8)*n_total1) + call ev_data_update(ev_data_thread,iev_n(3),data_out( 8)) + call ev_data_update(ev_data_thread,iev_n(4),n_total-n_ion) + call ev_data_update(ev_data_thread,iev_n(5),data_out(24)) + call ev_data_update(ev_data_thread,iev_n(6),data_out(23)) + call ev_data_update(ev_data_thread,iev_n(7),data_out(22)) endif - eta_nimhd(iion,i) = n_ion*n_total1 ! Save ionisation fraction for the dump file - call ev_data_update(ev_data_thread,iev_n(1),n_ion*n_total1) - call ev_data_update(ev_data_thread,iev_n(2),data_out( 8)*n_total1) - call ev_data_update(ev_data_thread,iev_n(3),data_out( 8)) - call ev_data_update(ev_data_thread,iev_n(4),n_total-n_ion) - call ev_data_update(ev_data_thread,iev_n(5),data_out(24)) - call ev_data_update(ev_data_thread,iev_n(6),data_out(23)) - call ev_data_update(ev_data_thread,iev_n(7),data_out(22)) endif endif endif isgas @@ -718,20 +705,20 @@ subroutine compute_energies(t) if (calc_gravitwaves) then pmassi = massoftype(igas) x0 = 0.; v0 = 0.; a0 = 0. ! use the origin by default -#ifdef GR - !call get_geodesic_accel(axyz,npart,vxyzu(1:3,:),metrics,metricderivs) - !call calculate_strain(hx,hp,pmassi,x0,v0,a0,npart,xyzh,vxyzu,axyz) - call calculate_strain(hx,hp,pmassi,ddq_xy,x0,v0,a0,npart,xyzh,vxyzu(1:3,:),fxyzu,& - fext,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass) -#else - if (iexternalforce==0) then ! if no external forces, use centre of mass of particles - x0 = (/xcom,ycom,zcom/) - v0 = (/xmom,ymom,zmom/) - call get_centreofmass_accel(a0,npart,xyzh,fxyzu,fext,nptmass,xyzmh_ptmass,fxyz_ptmass) + if (gr) then + !call get_geodesic_accel(axyz,npart,vxyzu(1:3,:),metrics,metricderivs) + !call calculate_strain(hx,hp,pmassi,x0,v0,a0,npart,xyzh,vxyzu,axyz) + call calculate_strain(hx,hp,pmassi,ddq_xy,x0,v0,a0,npart,xyzh,vxyzu(1:3,:),fxyzu,& + fext,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass) + else + if (iexternalforce==0) then ! if no external forces, use centre of mass of particles + x0 = (/xcom,ycom,zcom/) + v0 = (/xmom,ymom,zmom/) + call get_centreofmass_accel(a0,npart,xyzh,fxyzu,fext,nptmass,xyzmh_ptmass,fxyz_ptmass) + endif + call calculate_strain(hx,hp,pmassi,ddq_xy,x0,v0,a0,npart,xyzh,vxyzu(1:3,:),fxyzu,& + fext,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass) endif - call calculate_strain(hx,hp,pmassi,ddq_xy,x0,v0,a0,npart,xyzh,vxyzu(1:3,:),fxyzu,& - fext,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass) -#endif ev_data(iev_sum,iev_gws(1)) = hx(1) ev_data(iev_sum,iev_gws(2)) = hp(1) ev_data(iev_sum,iev_gws(3)) = hx(2) @@ -762,7 +749,6 @@ subroutine compute_energies(t) if (ierr==1) call fatal('energies','there is no high density gas for the dynamic boundaries') endif - return end subroutine compute_energies !---------------------------------------------------------------- !+ diff --git a/src/main/eos_barotropic.f90 b/src/main/eos_barotropic.f90 index df0ec4b8b..93f32e64c 100644 --- a/src/main/eos_barotropic.f90 +++ b/src/main/eos_barotropic.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos_barotropic ! diff --git a/src/main/eos_gasradrec.f90 b/src/main/eos_gasradrec.f90 index c478d7290..d8e949aba 100644 --- a/src/main/eos_gasradrec.f90 +++ b/src/main/eos_gasradrec.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos_gasradrec ! diff --git a/src/main/eos_helmholtz.f90 b/src/main/eos_helmholtz.f90 index d7a835899..882967eba 100644 --- a/src/main/eos_helmholtz.f90 +++ b/src/main/eos_helmholtz.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos_helmholtz ! diff --git a/src/main/eos_idealplusrad.f90 b/src/main/eos_idealplusrad.f90 index ecb29e49c..b48c73974 100644 --- a/src/main/eos_idealplusrad.f90 +++ b/src/main/eos_idealplusrad.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos_idealplusrad ! diff --git a/src/main/eos_mesa.f90 b/src/main/eos_mesa.f90 index 7f1a6f25c..216f04deb 100644 --- a/src/main/eos_mesa.f90 +++ b/src/main/eos_mesa.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos_mesa ! diff --git a/src/main/eos_mesa_microphysics.f90 b/src/main/eos_mesa_microphysics.f90 index 30fdd716e..aa9268c13 100644 --- a/src/main/eos_mesa_microphysics.f90 +++ b/src/main/eos_mesa_microphysics.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mesa_microphysics ! diff --git a/src/main/eos_piecewise.f90 b/src/main/eos_piecewise.f90 index a3ebb2ed9..8462e4bcf 100644 --- a/src/main/eos_piecewise.f90 +++ b/src/main/eos_piecewise.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos_piecewise ! diff --git a/src/main/eos_shen.f90 b/src/main/eos_shen.f90 index 5749b8122..7c2548677 100644 --- a/src/main/eos_shen.f90 +++ b/src/main/eos_shen.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos_shen ! diff --git a/src/main/eos_stratified.f90 b/src/main/eos_stratified.f90 index 3f3cd8a44..37f9bcd14 100644 --- a/src/main/eos_stratified.f90 +++ b/src/main/eos_stratified.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos_stratified ! diff --git a/src/main/evwrite.F90 b/src/main/evwrite.F90 deleted file mode 100644 index 9d063e020..000000000 --- a/src/main/evwrite.F90 +++ /dev/null @@ -1,505 +0,0 @@ -!--------------------------------------------------------------------------! -! 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.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module evwrite -! -! Calculates conserved quantities etc and writes to .ev file; -! Also writes log output -! To Developer: To add values to the .ev file, follow the following procedure. -! In the init_evfile subroutine in evwrite.F90, add the following command: -! call fill_ev_label(ev_fmt,ev_tag_int,ev_tag_char,action,i,j) -! and in compute_energies subroutine in energies.F90, add the following command: -! call ev_data_update(ev_data_thread,ev_tag_int,value) -! where -! ev_fmt,ev_data_thread,i,j: pre-defined quantities to included verbatim -! ev_tag_char: a string to identify the quantity for use in the header -! (e.g. 'c_s' for sound speed) -! ev_tag_int: an integer to identify the quantity (e.g. 'iev_cs' for sound speed); -! this integer must be included in energies (as a public variable, -! and in the openmp declarations), and passed to evwrite via use energies. -! ev_value: the value of the quantity for particle i (e.g., spsoundi for sound speed) -! action: a string identifying what action(s) you would like performed -! on the quantity. The available options are -! 0: no action taken (e.g. for time) -! s: sum quantity (e.g. for entropy) -! x: print the maximum quantity -! a: print the average (mean) quantity -! n: print the minimum quantity -! where any or all of x,a,n can be used as a single action. Although 0 & s are treated -! the same, they are kept separate for clarity without added computational cost -! -! :References: None -! -! :Owner: James Wurster -! -! :Runtime parameters: None -! -! :Dependencies: boundary, boundary_dyn, dim, energies, eos, extern_binary, -! externalforces, fileutils, gravwaveutils, io, mpiutils, nicil, options, -! part, ptmass, timestep, units, viscosity -! - use io, only:fatal,iverbose - use options, only:iexternalforce - use timestep, only:dtmax_dratio - use externalforces, only:iext_binary,was_accreted - use energies, only:inumev,iquantities,ev_data - use energies, only:ndead,npartall - use energies, only:gas_only,track_mass,track_lum - use energies, only:iev_sum,iev_max,iev_min,iev_ave - use energies, only:iev_time,iev_ekin,iev_etherm,iev_emag,iev_epot,iev_etot,iev_totmom,iev_com,& - iev_angmom,iev_rho,iev_dt,iev_dtx,iev_entrop,iev_rmsmach,iev_vrms,iev_rhop,iev_alpha,& - iev_B,iev_divB,iev_hdivB,iev_beta,iev_temp,iev_etao,iev_etah,& - iev_etaa,iev_vel,iev_vhall,iev_vion,iev_n,& - iev_dtg,iev_ts,iev_dm,iev_momall,iev_angall,iev_angall,iev_maccsink,& - iev_macc,iev_eacc,iev_totlum,iev_erot,iev_viscrat,iev_erad,iev_gws,iev_mass,iev_bdy - - implicit none - public :: init_evfile, write_evfile, write_evlog - private :: fill_ev_tag, fill_ev_header - - integer, private :: ielements - integer, private :: ev_cmd(inumev) ! array of the actions to be taken - character(len=19),private :: ev_label(inumev) ! to make the header for the .ev file - - private - -contains - -!---------------------------------------------------------------- -!+ -! opens the .ev file for output -!+ -!---------------------------------------------------------------- -subroutine init_evfile(iunit,evfile,open_file) - use io, only:id,master,warning - use dim, only:maxtypes,maxalpha,maxp,maxp_hard,mhd,mhd_nonideal,lightcurve - use options, only:calc_erot,ishock_heating,ipdv_heating,use_dustfrac - use units, only:c_is_unity - use part, only:igas,idust,iboundary,istar,idarkmatter,ibulge,npartoftype,ndusttypes,maxtypes - use nicil, only:use_ohm,use_hall,use_ambi - use viscosity, only:irealvisc - use mpiutils, only:reduceall_mpi - use eos, only:ieos,eos_is_non_ideal,eos_outputs_gasP - use gravwaveutils, only:calc_gravitwaves - use boundary_dyn, only:dynamic_bdy - integer, intent(in) :: iunit - character(len= *), intent(in) :: evfile - logical, intent(in) :: open_file - character(len= 27) :: ev_fmt - character(len= 11) :: dustname - integer :: i,j,k - integer(kind=8) :: npartoftypetot(maxtypes) - ! - !--Initialise additional variables - ! - npartoftypetot = reduceall_mpi('+', npartoftype) - gas_only = .true. - do i = 2,maxtypes - if (npartoftypetot(i) > 0) gas_only = .false. - enddo - write(ev_fmt,'(a)') "(1x,'[',i2.2,1x,a11,']',2x)" - ! - !--Define all the variables to be included in the .ev file and their supplementary information - ! - i = 1 - j = 1 - call fill_ev_tag(ev_fmt,iev_time, 'time', '0', i,j) - call fill_ev_tag(ev_fmt,iev_ekin, 'ekin', '0', i,j) - call fill_ev_tag(ev_fmt,iev_etherm, 'etherm', '0', i,j) - call fill_ev_tag(ev_fmt,iev_emag, 'emag', '0', i,j) - call fill_ev_tag(ev_fmt,iev_epot, 'epot', '0', i,j) - call fill_ev_tag(ev_fmt,iev_etot, 'etot', '0', i,j) - call fill_ev_tag(ev_fmt,iev_erad, 'erad', '0', i,j) - call fill_ev_tag(ev_fmt,iev_totmom, 'totmom', '0', i,j) - call fill_ev_tag(ev_fmt,iev_angmom, 'angtot', '0', i,j) - call fill_ev_tag(ev_fmt,iev_rho, 'rho', 'xa',i,j) - call fill_ev_tag(ev_fmt,iev_dt, 'dt', '0', i,j) - if (dtmax_dratio > 0.) then - call fill_ev_tag(ev_fmt,iev_dtx, 'dtmax', '0', i,j) - endif - if (maxp==maxp_hard) then - call fill_ev_tag(ev_fmt,iev_mass,'mass', '0', i,j) - endif - call fill_ev_tag(ev_fmt,iev_entrop, 'totentrop','s', i,j) - call fill_ev_tag(ev_fmt,iev_rmsmach,'rmsmach', '0', i,j) - call fill_ev_tag(ev_fmt,iev_vrms, 'vrms', '0', i,j) - call fill_ev_tag(ev_fmt,iev_com(1), 'xcom', '0', i,j) - call fill_ev_tag(ev_fmt,iev_com(2), 'ycom', '0', i,j) - call fill_ev_tag(ev_fmt,iev_com(3), 'zcom', '0', i,j) - if (.not. gas_only) then - if (npartoftypetot(igas) > 0) call fill_ev_tag(ev_fmt,iev_rhop(1),'rho gas', 'xa',i,j) - if (npartoftypetot(idust) > 0) call fill_ev_tag(ev_fmt,iev_rhop(2),'rho dust','xa',i,j) - if (npartoftypetot(iboundary) > 0) call fill_ev_tag(ev_fmt,iev_rhop(3),'rho bdy', 'xa',i,j) - if (npartoftypetot(istar) > 0) call fill_ev_tag(ev_fmt,iev_rhop(4),'rho star','xa',i,j) - if (npartoftypetot(idarkmatter) > 0) call fill_ev_tag(ev_fmt,iev_rhop(5),'rho dm', 'xa',i,j) - if (npartoftypetot(ibulge) > 0) call fill_ev_tag(ev_fmt,iev_rhop(6),'rho blg', 'xa',i,j) - endif - if (maxalpha==maxp) then - call fill_ev_tag(ev_fmt, iev_alpha, 'alpha', 'x', i,j) - endif - if (eos_is_non_ideal(ieos) .or. eos_outputs_gasP(ieos)) then - call fill_ev_tag(ev_fmt, iev_temp, 'temp', 'xan',i,j) - endif - if ( mhd ) then - call fill_ev_tag(ev_fmt, iev_B, 'B', 'xan',i,j) - call fill_ev_tag(ev_fmt, iev_divB, 'divB', 'xa' ,i,j) - call fill_ev_tag(ev_fmt, iev_hdivB, 'hdivB/B','xa' ,i,j) - call fill_ev_tag(ev_fmt, iev_beta, 'beta_P', 'xan',i,j) - if (mhd_nonideal) then - if (use_ohm) then - call fill_ev_tag(ev_fmt,iev_etao, 'eta_o', 'xan',i,j) - endif - if (use_hall) then - call fill_ev_tag(ev_fmt,iev_etah(1),'eta_h', 'xan',i,j) - call fill_ev_tag(ev_fmt,iev_etah(2),'|eta_h|', 'xan',i,j) - call fill_ev_tag(ev_fmt,iev_vhall, 'v_hall', 'xan',i,j) - endif - if (use_ambi) then - call fill_ev_tag(ev_fmt,iev_etaa, 'eta_a', 'xan',i,j) - call fill_ev_tag(ev_fmt,iev_vel, 'velocity', 'xan',i,j) - call fill_ev_tag(ev_fmt,iev_vion, 'v_ion', 'xan',i,j) - endif - call fill_ev_tag(ev_fmt, iev_n(1), 'ni/n(i+n)','xan',i,j) - call fill_ev_tag(ev_fmt, iev_n(2), 'ne/n(i+n)','xan',i,j) - call fill_ev_tag(ev_fmt, iev_n(3), 'n_e', 'xa', i,j) - call fill_ev_tag(ev_fmt, iev_n(4), 'n_n', 'xa', i,j) - call fill_ev_tag(ev_fmt, iev_n(5), 'n_g(Z=-1)','xa', i,j) - call fill_ev_tag(ev_fmt, iev_n(6), 'n_g(Z= 0)','xa', i,j) - call fill_ev_tag(ev_fmt, iev_n(7), 'n_g(Z=+1)','xa', i,j) - endif - endif - if (use_dustfrac) then - call fill_ev_tag(ev_fmt, iev_dtg,'dust/gas', 'xan',i,j) - call fill_ev_tag(ev_fmt, iev_ts, 't_s', 'xn', i,j) - do k=1,ndusttypes - write(dustname,'(a,I3)') 'DustMass',k - call fill_ev_tag(ev_fmt,iev_dm(k), dustname, '0', i,j) - enddo - endif - if (iexternalforce > 0) then - call fill_ev_tag(ev_fmt, iev_momall,'totmomall', '0',i,j) - call fill_ev_tag(ev_fmt, iev_angall,'angall', '0',i,j) - if (iexternalforce==iext_binary) then - call fill_ev_tag(ev_fmt,iev_maccsink(1),'Macc sink 1', '0',i,j) - call fill_ev_tag(ev_fmt,iev_maccsink(2),'Macc sink 2', '0',i,j) - endif - endif - if (was_accreted(iexternalforce,-1.0)) then - call fill_ev_tag(ev_fmt,iev_macc, 'accretedmas', 's',i,j) - call fill_ev_tag(ev_fmt,iev_eacc, 'eacc', '0',i,j) - track_mass = .true. - else - track_mass = .false. - endif - if (ishock_heating==0 .or. ipdv_heating==0 .or. lightcurve) then - call fill_ev_tag(ev_fmt,iev_totlum,'tot lum', '0',i,j) - track_lum = .true. - else - track_lum = .false. - endif - if (calc_erot) then - call fill_ev_tag(ev_fmt,iev_erot(1),'erot_x', 's',i,j) - call fill_ev_tag(ev_fmt,iev_erot(2),'erot_y', 's',i,j) - call fill_ev_tag(ev_fmt,iev_erot(3),'erot_z', 's',i,j) - call fill_ev_tag(ev_fmt,iev_erot(4),'erot', '0',i,j) - endif - if (irealvisc /= 0) then - call fill_ev_tag(ev_fmt,iev_viscrat,'visc_rat','xan',i,j) - endif - - if (calc_gravitwaves) then - call fill_ev_tag(ev_fmt,iev_gws(1),'hx_0','0',i,j) - call fill_ev_tag(ev_fmt,iev_gws(2),'hp_0','0',i,j) - call fill_ev_tag(ev_fmt,iev_gws(3),'hx_{30}','0',i,j) - call fill_ev_tag(ev_fmt,iev_gws(4),'hp_{30}','0',i,j) - call fill_ev_tag(ev_fmt,iev_gws(5),'hx_{60}','0',i,j) - call fill_ev_tag(ev_fmt,iev_gws(6),'hp_{60}','0',i,j) - call fill_ev_tag(ev_fmt,iev_gws(7),'hx_{90}','0',i,j) - call fill_ev_tag(ev_fmt,iev_gws(8),'hp_{90}','0',i,j) - endif - if (dynamic_bdy) then - call fill_ev_tag(ev_fmt,iev_bdy(1,1),'min_x','0',i,j) - call fill_ev_tag(ev_fmt,iev_bdy(1,2),'max_x','0',i,j) - call fill_ev_tag(ev_fmt,iev_bdy(2,1),'min_y','0',i,j) - call fill_ev_tag(ev_fmt,iev_bdy(2,2),'max_y','0',i,j) - call fill_ev_tag(ev_fmt,iev_bdy(3,1),'min_z','0',i,j) - call fill_ev_tag(ev_fmt,iev_bdy(3,2),'max_z','0',i,j) - endif - iquantities = i - 1 ! The number of different quantities to analyse - ielements = j - 1 ! The number of values to be calculated (i.e. the number of columns in .ve) - ! - !--all threads do above, but only master writes file - ! (the open_file is to prevent an .ev file from being made during the test suite) - ! - if (open_file .and. id == master) then - ! - !--open the file for output - ! - open(unit=iunit,file=evfile,form='formatted',status='replace') - ! - !--write a header line - ! - write(ev_fmt,'(a,I3,a)') '(',ielements+1,'a)' - write(iunit,ev_fmt)'#',ev_label(1:ielements) - endif - -end subroutine init_evfile -! -!---------------------------------------------------------------- -!+ -! creates up to three lables per input value, and fills the required -! tracking arrays; this includes a check to verify the actions are legal -!+ -!---------------------------------------------------------------- -subroutine fill_ev_tag(ev_fmt,itag,label,cmd,i,j) - integer, intent(inout) :: i,j - integer, intent(out) :: itag - character(len=*), intent(in) :: ev_fmt,label,cmd - integer :: ki,kj,iindex,joffset - - ! initialise command - itag = i - joffset = 1 - ev_cmd(i) = 0 - ! - ! make the headers & set ev_cmd - if (index(cmd,'0') > 0) call fill_ev_header(ev_fmt,label,'0',j,joffset) - if (index(cmd,'s') > 0) call fill_ev_header(ev_fmt,label,'s',j,joffset) - if (index(cmd,'x') > 0) then - call fill_ev_header(ev_fmt,label,'x',j,joffset) - ev_cmd(i) = ev_cmd(i) + 1 - joffset = joffset + 1 - endif - if (index(cmd,'a') > 0) then - call fill_ev_header(ev_fmt,label,'a',j,joffset) - ev_cmd(i) = ev_cmd(i) + 2 - joffset = joffset + 1 - endif - if (index(cmd,'n') > 0) then - call fill_ev_header(ev_fmt,label,'n',j,joffset) - ev_cmd(i) = ev_cmd(i) + 5 - endif - i = i + 1 - j = j + len(trim(cmd)) - ! - ! verify action command is legal - if ( (index(cmd,'x') > 0) .or. (index(cmd,'a') > 0) .or. (index(cmd,'n') > 0) ) then - iindex = 1 - else - iindex = 0 - endif - if ( index(cmd,'0') + index(cmd,'s') + iindex > 1) & - call fatal('fill_ev_tag','using an invalid sequence of actions for element', var=cmd) - do ki = 1,len(cmd)-1 - do kj = ki+1,len(cmd) - if ( cmd(ki:ki)==cmd(kj:kj) ) then - call fatal('fill_ev_tag','using duplicate actions for the same quantity', var=cmd) - endif - enddo - enddo - ! -end subroutine fill_ev_tag -!---------------------------------------------------------------- -!+ -! Fill an array to be used for the header of the .ev file -!+ -!---------------------------------------------------------------- -subroutine fill_ev_header(ev_fmt,label,cxmn,j,joffset) - integer, intent(in) :: j,joffset - character(len=* ), intent(in) :: ev_fmt,label - character(len= 1), intent(in) :: cxmn - character(len=11) :: label0 - character(len= 3) :: ext - integer :: j_actual - - if (len(label)>11 .and. (cxmn=='0' .or. cxmn=='s') ) then - label0 = label(1:11) - elseif (len(label)>9 .and. (cxmn=='x' .or. cxmn=='a' .or. cxmn=='n')) then - label0 = label(1:9) - else - label0 = label - endif - ext = "" - if (len(label)<=7) then - if (cxmn=='x') ext = "max" - if (cxmn=='a') ext = "ave" - if (cxmn=='n') ext = "min" - elseif (len(label)<=9) then - if (cxmn=='x') ext = "X" - if (cxmn=='a') ext = "A" - if (cxmn=='n') ext = "N" - endif - if (ext/="") write(label0,'(a,1x,a)')trim(label0),trim(ext); - ! - j_actual = j + joffset - 1 - if (j_actual > 99) then - write(ev_label(j_actual),ev_fmt) 100-j_actual,trim(label0) - else - write(ev_label(j_actual),ev_fmt) j_actual,trim(label0) - endif - -end subroutine fill_ev_header -!---------------------------------------------------------------- -!+ -! calculates total energy, etc, and writes line to .ev file -!+ -!---------------------------------------------------------------- -subroutine write_evfile(t,dt) - use energies, only:compute_energies,ev_data_update - use io, only:id,master,ievfile -#ifndef GR - use timestep, only:dtmax_user - use options, only:iexternalforce - use extern_binary, only:accretedmass1,accretedmass2 -#endif - real, intent(in) :: t,dt - integer :: i,j - real :: ev_data_out(ielements) - character(len=35) :: ev_format - - call compute_energies(t) - - if (id==master) then - !--fill in additional details that are not calculated in energies.f -#ifndef GR - ev_data(iev_sum,iev_dt) = dt - ev_data(iev_sum,iev_dtx) = dtmax_user - if (iexternalforce==iext_binary) then - ev_data(iev_sum,iev_maccsink(1)) = accretedmass1 - ev_data(iev_sum,iev_maccsink(2)) = accretedmass2 - endif -#endif - ! Fill in the data_out array - j = 1 - do i = 1,iquantities - if (ev_cmd(i)==0) then - ! include the total value - ev_data_out(j) = ev_data(iev_sum,i) - j = j + 1 - else - if (ev_cmd(i)==1 .or. ev_cmd(i)==3 .or. ev_cmd(i)==6 .or. ev_cmd(i)==8) then - ! include the maximum value - ev_data_out(j) = ev_data(iev_max,i) - j = j + 1 - endif - if (ev_cmd(i)==2 .or. ev_cmd(i)==3 .or. ev_cmd(i)==7 .or. ev_cmd(i)==8) then - ! include the average value - ev_data_out(j) = ev_data(iev_ave,i) - j = j + 1 - endif - if (ev_cmd(i)==5 .or. ev_cmd(i)==6 .or. ev_cmd(i)==7 .or. ev_cmd(i)==8) then - ! include the minimum value - ev_data_out(j) = ev_data(iev_min,i) - j = j + 1 - endif - endif - enddo - ! - !--write line to .ev file (should correspond to header, below) - ! - write(ev_format,'(a,I3,a)')"(",ielements,"(1pe18.10,1x))" - write(ievfile,ev_format) ev_data_out - call flush(ievfile) - endif - - return -end subroutine write_evfile -!---------------------------------------------------------------- -!+ -! Writes nicely formatted output to the log file/screen -! Must be called *after* a call to compute energies has been -! performed -!+ -!---------------------------------------------------------------- -subroutine write_evlog(iprint) - use dim, only:maxp,maxalpha,mhd,maxvxyzu,periodic,mhd_nonideal,& - use_dust,maxdusttypes,do_radiation,particles_are_injected - use energies, only:ekin,etherm,emag,epot,etot,rmsmach,vrms,accretedmass,mdust,mgas,xyzcom - use energies, only:erad - use part, only:nptmass,ndusttypes - use viscosity, only:irealvisc,shearparam - use boundary, only:dxbound,dybound,dzbound - use units, only:unit_density - use options, only:use_dustfrac - use fileutils, only:make_tags_unique - use ptmass, only:icreate_sinks - integer, intent(in) :: iprint - character(len=120) :: string,Mdust_label(maxdusttypes) - integer :: i - - if (ndead > 0 .or. nptmass > 0 .or. icreate_sinks > 0 .or. particles_are_injected .or. iverbose > 0) then - write(iprint,"(1x,4(a,I10))") 'npart=',npartall,', n_alive=',npartall-ndead, & - ', n_dead_or_accreted=',ndead,', nptmass=',nptmass - endif - - write(iprint,"(1x,3('E',a,'=',es10.3,', '),('E',a,'=',es10.3))") 'tot',etot,'kin',ekin,'therm',etherm,'pot',epot - - if (mhd) write(iprint,"(1x,('E',a,'=',es10.3))") 'mag',emag - if (do_radiation) write(iprint,"(1x,('E',a,'=',es10.3))") 'rad',erad - if (track_mass) write(iprint,"(1x,('E',a,'=',es10.3))") 'acc',ev_data(iev_sum,iev_eacc) - write(iprint,"(1x,1(a,'=',es10.3,', '),(a,'=',es10.3))") & - 'Linm',ev_data(iev_sum,iev_totmom),'Angm',ev_data(iev_sum,iev_angmom) - if (iexternalforce > 0) then - if (abs(ev_data(iev_sum,iev_angall)-ev_data(iev_sum,iev_angmom)) > tiny(0.)) then - write(iprint,"(1x,1(a,'=',es10.3,', '),(a,'=',es10.3),a)") & - 'Linm',ev_data(iev_sum,iev_momall),'Angm',ev_data(iev_sum,iev_angall),' [including accreted particles]' - endif - endif - write(iprint,"(1x,3(a,es10.3))") "Centre of Mass = ",xyzcom(1),", ",xyzcom(2),", ",xyzcom(3) - - write(iprint,"(1x,a,'(max)=',es10.3,' (mean)=',es10.3,' (max)=',es10.3,a)") & - 'density ',ev_data(iev_max,iev_rho),ev_data(iev_ave,iev_rho),ev_data(iev_max,iev_rho)*unit_density,' g/cm^3' - - if (use_dustfrac) then - write(iprint,"(1x,a,'(max)=',es10.3,1x,'(mean)=',es10.3,1x,'(min)=',es10.3)") & - 'dust2gas ',ev_data(iev_max,iev_dtg),ev_data(iev_ave,iev_dtg),ev_data(iev_min,iev_dtg) - write(iprint,"(3x,a,'(mean)=',es10.3,1x,'(min)=',es10.3)") 't_stop ',ev_data(iev_ave,iev_ts),ev_data(iev_min,iev_ts) - endif - if (use_dust) then - write(iprint,"(1x,'Mgas = ',es10.3)") mgas - Mdust_label = 'Mdust' - call make_tags_unique(ndusttypes,Mdust_label) - do i=1,ndusttypes - write(iprint,"(1x,1(a,' = ',es10.3))") trim(Mdust_label(i)),mdust(i) - enddo - endif - - if (track_mass) write(iprint,"(1x,1(a,'=',es10.3))") 'Accreted mass',accretedmass - - string = '' - if (maxalpha==maxp) then - write(string,"(a,'(max)=',es10.3)") ' alpha',ev_data(iev_max,iev_alpha) - endif - if (len_trim(string) > 0) write(iprint,"(a)") trim(string) - - if (irealvisc /= 0) then - if (periodic) then - if (irealvisc==1) then - write(iprint,"(1x,1(a,'=',es10.3,', '),(a,'=',es10.3))") & - 'RMS Mach #',rmsmach,'Reynolds # ',vrms*min(dxbound,dybound,dzbound)/shearparam - endif - endif - write(iprint,"(1x,1(a,'(max)=',es10.3,', '),('(mean)=',es10.3),(' (min)=',es10.3))") & - 'Ratio of physical-to-art. visc',ev_data(iev_max,iev_viscrat),ev_data(iev_min,iev_viscrat) - else - write(iprint,"(1x,1(a,'=',es10.3))") & - 'RMS Mach #',rmsmach - endif - - if (mhd) then - write(iprint,"(1x,1(a,'(max)=',es10.3,', '),(a,'(mean)=',es10.3))") & - 'div B ',ev_data(iev_max,iev_divB),'div B ',ev_data(iev_ave,iev_divB) - write(iprint,"(1x,1(a,'(max)=',es10.3,', '),(a,'(mean)=',es10.3))") & - 'h|div B|/B ',ev_data(iev_max,iev_hdivB),'h|div B|/B ',ev_data(iev_ave,iev_hdivB) - if (ev_data(iev_max,iev_hdivB) > 10.) & - write(iprint,'(a)') 'WARNING! h|div B|/B is growing! Recommend increasing hdivbbmax_max for better stability' - endif - write(iprint,"(/)") - - return -end subroutine write_evlog -!---------------------------------------------------------------- -end module evwrite diff --git a/src/main/extern_Bfield.f90 b/src/main/extern_Bfield.f90 index 908411d22..1b4319e70 100644 --- a/src/main/extern_Bfield.f90 +++ b/src/main/extern_Bfield.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_Bfield ! diff --git a/src/main/extern_binary.f90 b/src/main/extern_binary.f90 index 88ffde885..d22725666 100644 --- a/src/main/extern_binary.f90 +++ b/src/main/extern_binary.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_binary ! diff --git a/src/main/extern_binary_gw.f90 b/src/main/extern_binary_gw.f90 index 50814ee54..c41bcd59b 100644 --- a/src/main/extern_binary_gw.f90 +++ b/src/main/extern_binary_gw.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_binary ! diff --git a/src/main/extern_corotate.f90 b/src/main/extern_corotate.f90 index 89ddbb143..72eedd4e5 100644 --- a/src/main/extern_corotate.f90 +++ b/src/main/extern_corotate.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_corotate ! diff --git a/src/main/extern_densprofile.f90 b/src/main/extern_densprofile.f90 index e2ef14160..e16d09be2 100644 --- a/src/main/extern_densprofile.f90 +++ b/src/main/extern_densprofile.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_densprofile ! diff --git a/src/main/extern_gnewton.F90 b/src/main/extern_gnewton.f90 similarity index 98% rename from src/main/extern_gnewton.F90 rename to src/main/extern_gnewton.f90 index d5508125d..75a8563e9 100644 --- a/src/main/extern_gnewton.F90 +++ b/src/main/extern_gnewton.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_gnewton ! diff --git a/src/main/extern_gwinspiral.f90 b/src/main/extern_gwinspiral.f90 index 224a22287..3d6df7205 100644 --- a/src/main/extern_gwinspiral.f90 +++ b/src/main/extern_gwinspiral.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_gwinspiral ! diff --git a/src/main/extern_lensethirring.f90 b/src/main/extern_lensethirring.f90 index 62ddf2e89..d039422cb 100644 --- a/src/main/extern_lensethirring.f90 +++ b/src/main/extern_lensethirring.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_lensethirring ! diff --git a/src/main/extern_prdrag.F90 b/src/main/extern_prdrag.f90 similarity index 99% rename from src/main/extern_prdrag.F90 rename to src/main/extern_prdrag.f90 index a8356d305..78456bd68 100644 --- a/src/main/extern_prdrag.F90 +++ b/src/main/extern_prdrag.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_prdrag ! diff --git a/src/main/extern_spiral.f90 b/src/main/extern_spiral.f90 index f84598934..b485802f4 100644 --- a/src/main/extern_spiral.f90 +++ b/src/main/extern_spiral.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_spiral ! diff --git a/src/main/extern_staticsine.f90 b/src/main/extern_staticsine.f90 index a3f6385a6..bbb12be75 100644 --- a/src/main/extern_staticsine.f90 +++ b/src/main/extern_staticsine.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_staticsine ! diff --git a/src/main/externalforces.F90 b/src/main/externalforces.F90 index 0d9b707d1..ffd8ba7fc 100644 --- a/src/main/externalforces.F90 +++ b/src/main/externalforces.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module externalforces ! diff --git a/src/main/externalforces_gr.F90 b/src/main/externalforces_gr.F90 index b43123e8b..ae3f37a96 100644 --- a/src/main/externalforces_gr.F90 +++ b/src/main/externalforces_gr.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module externalforces ! diff --git a/src/main/kdtree.F90 b/src/main/kdtree.F90 index be9a663aa..9b70a7f1f 100644 --- a/src/main/kdtree.F90 +++ b/src/main/kdtree.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module kdtree ! diff --git a/src/main/readwrite_dumps_hdf5.F90 b/src/main/readwrite_dumps_hdf5.F90 index cb0ae30c6..3e929d7b4 100644 --- a/src/main/readwrite_dumps_hdf5.F90 +++ b/src/main/readwrite_dumps_hdf5.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module readwrite_dumps_hdf5 ! @@ -35,8 +35,6 @@ module readwrite_dumps_hdf5 externalforce_hdf5 implicit none - character(len=80), parameter, public :: & ! module version - modid="$Id$" public :: read_dump_hdf5,read_smalldump_hdf5 public :: write_smalldump_hdf5,write_fulldump_hdf5,write_dump_hdf5 diff --git a/src/main/sort_particles.F90 b/src/main/sort_particles.f90 similarity index 98% rename from src/main/sort_particles.F90 rename to src/main/sort_particles.f90 index a8343c1f9..89cba893a 100644 --- a/src/main/sort_particles.F90 +++ b/src/main/sort_particles.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module sort_particles ! diff --git a/src/main/step_supertimestep.F90 b/src/main/step_supertimestep.F90 index 0833435b9..413f0615b 100644 --- a/src/main/step_supertimestep.F90 +++ b/src/main/step_supertimestep.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module supertimestep ! diff --git a/src/main/timestep.F90 b/src/main/timestep.f90 similarity index 99% rename from src/main/timestep.F90 rename to src/main/timestep.f90 index d0ca11800..99bd0e172 100644 --- a/src/main/timestep.F90 +++ b/src/main/timestep.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module timestep ! diff --git a/src/main/units.f90 b/src/main/units.f90 index f133cd4d5..62cae18aa 100644 --- a/src/main/units.f90 +++ b/src/main/units.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module units ! @@ -35,7 +35,7 @@ module units public :: get_G_code, get_c_code, get_radconst_code, get_kbmh_code public :: c_is_unity, G_is_unity, in_geometric_units public :: is_time_unit, is_length_unit - public :: in_solarr, in_solarm + public :: in_solarr, in_solarm, in_solarl contains @@ -464,5 +464,17 @@ real(kind=8) function in_solarr(val) result(rval) rval = val*(udist/solarr) end function in_solarr +!--------------------------------------------------------------------------- +!+ +! function to convert a luminosity value from code units to solar luminosity +!+ +!--------------------------------------------------------------------------- +real(kind=8) function in_solarl(val) result(rval) + use physcon, only:solarl + real, intent(in) :: val + + rval = val*(unit_luminosity/solarl) + +end function in_solarl end module units diff --git a/src/main/utils_allocate.f90 b/src/main/utils_allocate.f90 index 76e2abf2f..d3c704cc1 100644 --- a/src/main/utils_allocate.f90 +++ b/src/main/utils_allocate.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module allocutils ! diff --git a/src/main/utils_binary.f90 b/src/main/utils_binary.f90 index dfb78aeee..5f9ca8851 100644 --- a/src/main/utils_binary.f90 +++ b/src/main/utils_binary.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module binaryutils ! @@ -62,7 +62,13 @@ real function get_E_from_mean_anomaly(M_ref,ecc) result(E) M_guess = M_ref - 2.*tol do while (abs(M_ref - M_guess) > tol) - M_guess = E_guess - ecc*sin(E_guess) + if (ecc < 1.) then ! eccentric + M_guess = E_guess - ecc*sin(E_guess) + elseif (ecc > 1.) then ! hyperbolic + M_guess = ecc*sinh(E_guess) - E_guess + else ! parabolic + M_guess = E_guess + 1./3.*E_guess**3 + endif if (M_guess > M_ref) then E_right = E_guess else @@ -75,13 +81,33 @@ real function get_E_from_mean_anomaly(M_ref,ecc) result(E) end function get_E_from_mean_anomaly +!--------------------------------------------------------------- +!+ +! Get eccentric (or parabolic/hyperbolic) anomaly from true anomaly +! https://space.stackexchange.com/questions/23128/design-of-an-elliptical-transfer-orbit/23130#23130 +!+ +!--------------------------------------------------------------- +real function get_E_from_true_anomaly(theta,ecc) result(E) + real, intent(in) :: theta ! true anomaly in radians + real, intent(in) :: ecc ! eccentricity + + if (ecc < 1.) then + E = atan2(sqrt(1. - ecc**2)*sin(theta),(ecc + cos(theta))) + elseif (ecc > 1.) then ! hyperbolic + !E = atanh(sqrt(ecc**2 - 1.)*sin(theta)/(ecc + cos(theta))) + E = 2.*atanh(sqrt((ecc - 1.)/(ecc + 1.))*tan(0.5*theta)) + else ! parabolic + E = tan(0.5*theta) + endif + +end function get_E_from_true_anomaly + !----------------------------------------------------------------------- !+ ! Calculate semi-major axis, ecc, ra and rp from radius(3), velocity(3) ! mass of central object and iexternalforce (for LT corrections) !+ !----------------------------------------------------------------------- - subroutine get_orbit_bits(vel,rad,m1,iexternalforce,semia,ecc,ra,rp) real, intent(in) :: m1, vel(3), rad(3) integer, intent(in) :: iexternalforce diff --git a/src/main/utils_cpuinfo.f90 b/src/main/utils_cpuinfo.f90 index 5c78bb27e..5e50794c9 100644 --- a/src/main/utils_cpuinfo.f90 +++ b/src/main/utils_cpuinfo.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cpuinfo ! diff --git a/src/main/utils_datafiles.f90 b/src/main/utils_datafiles.f90 index 8d5977c51..f3212a0dd 100644 --- a/src/main/utils_datafiles.f90 +++ b/src/main/utils_datafiles.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module datautils ! @@ -209,10 +209,10 @@ logical function has_write_permission(dir) has_write_permission = .true. open(newunit=iunit,file=trim(dir)//'data.tmp.abcd',action='write',iostat=ierr) - if (ierr /= 0) then - has_write_permission = .false. - endif - close(iunit,status='delete') + if (ierr /= 0) has_write_permission = .false. + + close(iunit,status='delete',iostat=ierr) + if (ierr /= 0) has_write_permission = .false. end function has_write_permission diff --git a/src/main/utils_dumpfiles.f90 b/src/main/utils_dumpfiles.f90 index 99501cdb5..7691ea5c7 100644 --- a/src/main/utils_dumpfiles.f90 +++ b/src/main/utils_dumpfiles.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module dump_utils ! @@ -1121,12 +1121,13 @@ end subroutine open_dumpfile_w ! open a dump file and read the file id ! and generic header information !----------------------------------------- -subroutine open_dumpfile_r(iunit,filename,fileid,ierr,singleprec,requiretags) +subroutine open_dumpfile_r(iunit,filename,fileid,ierr,singleprec,requiretags,tagged) integer, intent(in) :: iunit character(len=*), intent(in) :: filename character(len=lenid), intent(out) :: fileid integer, intent(out) :: ierr - logical, intent(in), optional :: singleprec,requiretags + logical, intent(in), optional :: singleprec,requiretags + logical, intent(out), optional :: tagged integer(kind=4) :: int1i,int2i,int3i integer :: iversion_file,ierr1 logical :: r4,must_have_tags @@ -1193,6 +1194,11 @@ subroutine open_dumpfile_r(iunit,filename,fileid,ierr,singleprec,requiretags) endif endif + ! return whether or not file is in tagged format + if (present(tagged)) then + tagged = (fileid(2:2) == 'T' .or. fileid(2:2) == 't') + endif + end subroutine open_dumpfile_r !------------------------------------------------------- @@ -1230,19 +1236,22 @@ end function get_error_text ! read the file header into the dump_header structure !+ !------------------------------------------------------- -subroutine read_header(iunit,hdr,tagged,ierr,singleprec) +subroutine read_header(iunit,hdr,ierr,singleprec,tagged) integer, intent(in) :: iunit type(dump_h), intent(out) :: hdr - logical, intent(in) :: tagged integer, intent(out) :: ierr logical, intent(in), optional :: singleprec - logical :: convert_prec + logical, intent(in), optional :: tagged + logical :: convert_prec,tags integer :: i,n real(kind=4), allocatable :: dumr4(:) convert_prec = .false. if (present(singleprec)) convert_prec = singleprec + tags = .true. + if (present(tagged)) tags = tagged + do i=1,ndatatypes read (iunit, iostat=ierr) n if (n < 0) n = 0 @@ -1250,66 +1259,66 @@ subroutine read_header(iunit,hdr,tagged,ierr,singleprec) select case(i) case(i_int) allocate(hdr%inttags(n),hdr%intvals(n),stat=ierr) - hdr%inttags(:) = '' if (n > 0) then - if (tagged) read(iunit, iostat=ierr) hdr%inttags(1:n) - read(iunit, iostat=ierr) hdr%intvals(1:n) + hdr%inttags(:) = '' + if (tags) read(iunit, iostat=ierr) hdr%inttags + read(iunit, iostat=ierr) hdr%intvals endif case(i_int1) allocate(hdr%int1tags(n),hdr%int1vals(n),stat=ierr) - hdr%int1tags(:) = '' if (n > 0) then - if (tagged) read(iunit, iostat=ierr) hdr%int1tags(1:n) - read(iunit, iostat=ierr) hdr%int1vals(1:n) + hdr%int1tags(:) = '' + if (tags) read(iunit, iostat=ierr) hdr%int1tags + read(iunit, iostat=ierr) hdr%int1vals endif case(i_int2) allocate(hdr%int2tags(n),hdr%int2vals(n),stat=ierr) - hdr%int2tags(:) = '' if (n > 0) then - if (tagged) read(iunit, iostat=ierr) hdr%int2tags(1:n) - read(iunit, iostat=ierr) hdr%int2vals(1:n) + hdr%int2tags(:) = '' + if (tags) read(iunit, iostat=ierr) hdr%int2tags + read(iunit, iostat=ierr) hdr%int2vals endif case(i_int4) allocate(hdr%int4tags(n),hdr%int4vals(n),stat=ierr) - hdr%int4tags(:) = '' if (n > 0) then - if (tagged) read(iunit, iostat=ierr) hdr%int4tags(1:n) - read(iunit, iostat=ierr) hdr%int4vals(1:n) + hdr%int4tags(:) = '' + if (tags) read(iunit, iostat=ierr) hdr%int4tags + read(iunit, iostat=ierr) hdr%int4vals endif case(i_int8) allocate(hdr%int8tags(n),hdr%int8vals(n),stat=ierr) - hdr%int8tags(:) = '' if (n > 0) then - if (tagged) read(iunit, iostat=ierr) hdr%int8tags(1:n) - read(iunit, iostat=ierr) hdr%int8vals(1:n) + hdr%int8tags(:) = '' + if (tags) read(iunit, iostat=ierr) hdr%int8tags + read(iunit, iostat=ierr) hdr%int8vals endif case(i_real) allocate(hdr%realtags(n),hdr%realvals(n),stat=ierr) - hdr%realtags(:) = '' if (n > 0) then - if (tagged) read(iunit, iostat=ierr) hdr%realtags(1:n) + hdr%realtags(:) = '' + if (tags) read(iunit, iostat=ierr) hdr%realtags if (convert_prec .and. kind(0.) /= 4) then allocate(dumr4(n),stat=ierr) - read(iunit, iostat=ierr) dumr4(1:n) + read(iunit, iostat=ierr) dumr4 hdr%realvals(1:n) = real(dumr4(1:n)) deallocate(dumr4) else - read(iunit, iostat=ierr) hdr%realvals(1:n) + read(iunit, iostat=ierr) hdr%realvals endif endif case(i_real4) allocate(hdr%real4tags(n),hdr%real4vals(n),stat=ierr) - hdr%real4tags(:) = '' if (n > 0) then - if (tagged) read(iunit, iostat=ierr) hdr%real4tags(1:n) - read(iunit, iostat=ierr) hdr%real4vals(1:n) + hdr%real4tags(:) = '' + if (tags) read(iunit, iostat=ierr) hdr%real4tags + read(iunit, iostat=ierr) hdr%real4vals endif case(i_real8) allocate(hdr%real8tags(n),hdr%real8vals(n),stat=ierr) - hdr%real8tags(:) = '' if (n > 0) then - if (tagged) read(iunit, iostat=ierr) hdr%real8tags(1:n) - read(iunit, iostat=ierr) hdr%real8vals(1:n) + hdr%real8tags(:) = '' + if (tags) read(iunit, iostat=ierr) hdr%real8tags + read(iunit, iostat=ierr) hdr%real8vals endif end select enddo @@ -2054,6 +2063,10 @@ subroutine read_array_real4(arr,arr_tag,got_arr,ikind,i1,i2,noffset,iunit,tag,ma matched = .true. if (match_datatype) then got_arr = .true. + if (i2 > size(arr)) then + print*,'ERROR: array size too small reading array: need ',i2,' got ',size(arr) + read(iunit,iostat=ierr) + endif read(iunit,iostat=ierr) (dum,i=1,noffset),arr(i1:i2) else print*,'ERROR: wrong datatype for '//trim(tag)//' (is not real4)' @@ -2071,21 +2084,22 @@ end subroutine read_array_real4 !-------------------------------------------------------------------- subroutine read_array_real4arr(arr,arr_tag,got_arr,ikind,i1,i2,noffset,iunit,tag,matched,ierr) real(kind=4), intent(inout) :: arr(:,:) - character(len=*), intent(in) :: arr_tag(size(arr(1,:))),tag - logical, intent(inout) :: got_arr(size(arr(1,:))) + character(len=*), intent(in) :: arr_tag(:),tag + logical, intent(inout) :: got_arr(:) integer, intent(in) :: ikind,i1,i2,noffset,iunit logical, intent(inout) :: matched integer, intent(out) :: ierr integer :: i,j,nread real(kind=4) :: dum real(kind=8) :: dumr8 + real(kind=4), allocatable :: dummy(:) real(kind=8), allocatable :: dummyr8(:) logical :: match_datatype if (matched .or. ikind < i_real) return match_datatype = (ikind==i_real4 .or. (kind(0.)==4 .and. ikind==i_real)) - do j=1,size(arr(:,1)) + do j=1,min(size(arr(:,1)),size(arr_tag)) if (match_tag(tag,arr_tag(j)) .and. .not.matched) then matched = .true. if (match_datatype) then @@ -2095,7 +2109,12 @@ subroutine read_array_real4arr(arr,arr_tag,got_arr,ikind,i1,i2,noffset,iunit,tag ierr = ierr_arraysize return endif - read(iunit,iostat=ierr) (dum,i=1,noffset),arr(j,i1:i2) + nread = i2-i1+1 + allocate(dummy(nread)) + read(iunit,iostat=ierr) (dum,i=1,noffset),dummy(1:nread) + arr(j,i1:i2) = dummy + deallocate(dummy) + !read(iunit,iostat=ierr) (dum,i=1,noffset),arr(j,i1:i2) elseif (ikind==i_real4) then got_arr(j) = .true. !print*,'WARNING: converting '//trim(tag)//' from real*8->real*4' @@ -2173,8 +2192,8 @@ end subroutine read_array_real8 !-------------------------------------------------------------------- subroutine read_array_real8arr(arr,arr_tag,got_arr,ikind,i1,i2,noffset,iunit,tag,matched,ierr) real(kind=8), intent(inout) :: arr(:,:) - character(len=*), intent(in) :: arr_tag(size(arr(1,:))),tag - logical, intent(inout) :: got_arr(size(arr(1,:))) + character(len=*), intent(in) :: arr_tag(:),tag + logical, intent(inout) :: got_arr(:) integer, intent(in) :: ikind,i1,i2,noffset,iunit logical, intent(inout) :: matched integer, intent(out) :: ierr @@ -2188,7 +2207,7 @@ subroutine read_array_real8arr(arr,arr_tag,got_arr,ikind,i1,i2,noffset,iunit,tag if (matched .or. ikind < i_real) return match_datatype = (ikind==i_real8 .or. (kind(0.)==8 .and. ikind==i_real)) - do j=1,size(arr(:,1)) + do j=1,min(size(arr(:,1)),size(arr_tag)) if (match_tag(tag,arr_tag(j)) .and. .not.matched) then matched = .true. if (match_datatype) then diff --git a/src/main/utils_dumpfiles_hdf5.f90 b/src/main/utils_dumpfiles_hdf5.f90 index 787580de6..581d06cd8 100644 --- a/src/main/utils_dumpfiles_hdf5.f90 +++ b/src/main/utils_dumpfiles_hdf5.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module utils_dumpfiles_hdf5 ! diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index a00aa68a0..479476ca6 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module utils_gr ! diff --git a/src/main/utils_hdf5.f90 b/src/main/utils_hdf5.f90 index 42f2ee222..2afa77842 100644 --- a/src/main/utils_hdf5.f90 +++ b/src/main/utils_hdf5.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module utils_hdf5 ! diff --git a/src/main/utils_healpix.f90 b/src/main/utils_healpix.f90 index 52c246ece..407761514 100644 --- a/src/main/utils_healpix.f90 +++ b/src/main/utils_healpix.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module healpix ! diff --git a/src/main/utils_infiles.f90 b/src/main/utils_infiles.f90 index 30ea78959..c40332b25 100644 --- a/src/main/utils_infiles.f90 +++ b/src/main/utils_infiles.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module infile_utils ! From f708580a204d0789f91c02d0e107b629e3e384c6 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 08:12:52 +1000 Subject: [PATCH 393/814] build failures fixed; revert to call system instead of execute_command_line --- src/main/utils_cpuinfo.f90 | 3 ++- src/main/utils_datafiles.f90 | 7 ++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/main/utils_cpuinfo.f90 b/src/main/utils_cpuinfo.f90 index a8d49006b..fd9d8f011 100644 --- a/src/main/utils_cpuinfo.f90 +++ b/src/main/utils_cpuinfo.f90 @@ -75,6 +75,7 @@ subroutine get_cpuinfo(ncpu,ncpureal,cpuspeed,cpumodel,cachesize,ierr) character(len=80) :: line character(len=40) :: tempfile real :: cachesizel2,cachesizel3 + external :: system ! !--on Linux, cpu info will be located in the /proc/cpuinfo file ! So we look in this file first @@ -105,7 +106,7 @@ subroutine get_cpuinfo(ncpu,ncpureal,cpuspeed,cpumodel,cachesize,ierr) !--On a Mac, we have to use the sysctl utility ! tempfile='cpuinfo.tmp' - call execute_command_line('sysctl -a hw machdep > '//trim(tempfile)) + call system('sysctl -a hw machdep > '//trim(tempfile)) !--check to see if this file exists inquire(file=tempfile,exist=iexist) if (iexist) then diff --git a/src/main/utils_datafiles.f90 b/src/main/utils_datafiles.f90 index f994d58b3..13aeb1158 100644 --- a/src/main/utils_datafiles.f90 +++ b/src/main/utils_datafiles.f90 @@ -153,6 +153,7 @@ subroutine retrieve_remote_file(url,file,dir,localfile,ierr) integer :: ilen,iunit!,ierr1 logical :: iexist character(len=*), parameter :: cmd = 'curl -k' + external :: system print "(80('-'))" print "(a)",' Downloading '//trim(file)//' from '//trim(url) @@ -161,7 +162,7 @@ subroutine retrieve_remote_file(url,file,dir,localfile,ierr) ierr = 0 ! check that wget utility exists !call execute_command_line('type -p wget > /dev/null',wait=.true.,exitstat=ierr,cmdstat=ierr1) - call execute_command_line('type -p curl > /dev/null') + call system('type -p curl > /dev/null') if (ierr /= 0) then print "(a)",' ERROR: curl utility does not exist' @@ -169,11 +170,11 @@ subroutine retrieve_remote_file(url,file,dir,localfile,ierr) if (len_trim(dir) > 0) then !call execute_command_line(trim(cmd)//' '//trim(url)//trim(file)//' -O '//trim(dir)//trim(file),wait=.true.,& ! exitstat=ierr,cmdstat=ierr1) - call execute_command_line(trim(cmd)//' '//trim(url)//trim(file)//' -o '//trim(dir)//trim(file)) + call system(trim(cmd)//' '//trim(url)//trim(file)//' -o '//trim(dir)//trim(file)) localfile = trim(dir)//trim(file) else !call execute_command_line(trim(cmd)//' '//trim(url)//trim(file),wait=.true.,exitstat=ierr,cmdstat=ierr1) - call execute_command_line(trim(cmd)//' '//trim(url)//trim(file)//' -o '//trim(file)) + call system(trim(cmd)//' '//trim(url)//trim(file)//' -o '//trim(file)) localfile = trim(file) endif endif From ec7a72d43da61d4e36be990330a96fb86328b2cc Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 08:24:08 +1000 Subject: [PATCH 394/814] bug fix in stats script --- scripts/stats.sh | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/scripts/stats.sh b/scripts/stats.sh index 9c9cc7d94..4ee99e17e 100755 --- a/scripts/stats.sh +++ b/scripts/stats.sh @@ -59,12 +59,12 @@ get_lines_of_code() } get_setup_count() { - nsetup=`cd $phantomdir; grep 'ifeq ($(SETUP)' build/Makefile | grep -v skip | cut -d, -f 2 | cut -d')' -f 1 | wc -l`; + nsetup=`cd $phantomdir; grep 'ifeq ($(SETUP)' build/Makefile_setups | grep -v skip | cut -d, -f 2 | cut -d')' -f 1 | wc -l`; echo "$nsetup"; } get_system_count() { - nsystem=`cd $phantomdir; grep 'ifeq ($(SYSTEM)' build/Makefile | cut -d, -f 2 | cut -d')' -f 1 | wc -l`; + nsystem=`cd $phantomdir; grep 'ifeq ($(SYSTEM)' build/Makefile_systems | cut -d, -f 2 | cut -d')' -f 1 | wc -l`; echo $nsystem; } # @@ -129,7 +129,8 @@ nifdef="$(count_unique_matches '#ifdef')"; subcount="$(get_subroutine_count)"; nsetup="$(get_setup_count)"; nsystem="$(get_system_count)"; -echo "Lines of code: $ncode"; +echo "Lines of code: main setup tests utils"; +echo " $ncode"; echo "Number of modules, subroutines, functions: $subcount"; echo "Number of #ifdef statements : $nifdef"; echo "Number of authors : $nauthors"; From f2a6dc0ca492db819003909b28ba0013fa6b0795 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 08:47:40 +1000 Subject: [PATCH 395/814] unmaintained/unpublished lumin_nsdisc functionality removed; revert to constant beta for prdrag as non-constant beta would be better handled with phantom+mcfost --- build/Makefile | 2 +- src/main/extern_prdrag.f90 | 25 +- src/main/externalforces.f90 | 11 +- src/main/lumin_nsdisc.f90 | 1118 ----------------------------------- 4 files changed, 14 insertions(+), 1142 deletions(-) delete mode 100644 src/main/lumin_nsdisc.f90 diff --git a/build/Makefile b/build/Makefile index 32282cb91..16de5fcc0 100644 --- a/build/Makefile +++ b/build/Makefile @@ -465,7 +465,7 @@ SRCPOTS= extern_gr.F90 \ extern_spiral.f90 \ extern_lensethirring.f90 \ extern_gnewton.f90 \ - lumin_nsdisc.f90 extern_prdrag.f90 \ + extern_prdrag.f90 \ extern_Bfield.f90 \ extern_densprofile.f90 \ extern_staticsine.f90 \ diff --git a/src/main/extern_prdrag.f90 b/src/main/extern_prdrag.f90 index 78456bd68..3ea8ac216 100644 --- a/src/main/extern_prdrag.f90 +++ b/src/main/extern_prdrag.f90 @@ -29,7 +29,7 @@ module extern_prdrag ! ! :Runtime parameters: None ! -! :Dependencies: eos, infile_utils, io, lumin_nsdisc, units +! :Dependencies: eos, infile_utils, io, units ! use eos, only:qfacdisc @@ -41,6 +41,7 @@ module extern_prdrag real, private :: k2 = 1. ! transverse drag real, private :: k0 = 1. ! radiation pressure real, private :: k1 = 1. ! redshift + real, private :: beta = 0.01 public :: get_prdrag_spatial_force, get_prdrag_vdependent_force public :: update_prdrag_leapfrog @@ -56,7 +57,6 @@ module extern_prdrag !+ !------------------------------------------------ subroutine get_prdrag_spatial_force(xi,yi,zi,MStar,fextxi,fextyi,fextzi,phi) - use lumin_nsdisc, only:beta use units, only:get_G_code real, intent(in) :: xi,yi,zi,Mstar real, intent(inout) :: fextxi,fextyi,fextzi @@ -66,7 +66,7 @@ subroutine get_prdrag_spatial_force(xi,yi,zi,MStar,fextxi,fextyi,fextzi,phi) gcode = get_G_code() r2 = xi*xi + yi*yi + zi*zi - betai = beta(xi,yi,zi) + betai = beta rbetai = k0*betai if (r2 > epsilon(r2)) then dr = 1./sqrt(r2) @@ -86,8 +86,7 @@ end subroutine get_prdrag_spatial_force !+ !----------------------------------------------------------------------- subroutine get_prdrag_vdependent_force(xyzi,vel,Mstar,fexti) - use lumin_nsdisc, only:beta !Change your Poynting-Robertson here. - use units, only:get_c_code,get_G_code + use units, only:get_c_code,get_G_code real, intent(in) :: xyzi(3), vel(3) real, intent(in) :: Mstar real, intent(out) :: fexti(3) @@ -104,7 +103,7 @@ subroutine get_prdrag_vdependent_force(xyzi,vel,Mstar,fexti) rhat = xyzi/r vr = dot_product(vel, rhat) - betai = beta( xyzi(1), xyzi(2), xyzi(3) ) + betai = beta fexti = (-betai*Mstar*gcode/ccode)* & ( (vr/r3)*xyzi*k1 + vel/r2*k2 ) @@ -112,7 +111,6 @@ subroutine get_prdrag_vdependent_force(xyzi,vel,Mstar,fexti) end subroutine get_prdrag_vdependent_force subroutine update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,Mstar) - use lumin_nsdisc, only:beta use units, only:get_c_code use io, only:warn real, intent(in) :: dt,xi,yi,zi, Mstar @@ -137,7 +135,7 @@ subroutine update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,y r3 = r*r2 vrhalf = vhalfx*xi + vhalfy*yi + vhalfz*zi - betai = beta( xi, yi, zi ) + betai = beta Q = Mstar*betai*dt/(2.*ccode*r*r) twoQondt = 2.*Q/dt denominator = -r2*( k2*kd*Q*Q + (kd-k2)*Q - 1 ) @@ -169,11 +167,11 @@ end subroutine update_prdrag_leapfrog !----------------------------------------------------------------------- subroutine write_options_prdrag(iunit) use infile_utils, only:write_inopt - use lumin_nsdisc, only:write_options_lumin_nsdisc integer, intent(in) :: iunit write(iunit,"(/,a)") '# options relating to Poynting-Robertson drag' + call write_inopt(beta,'beta','beta parameter',iunit) call write_inopt(k0, 'RadiationPressure', & 'Radiation pressure multiplier', iunit) call write_inopt(k2, 'TransverseDrag', & @@ -181,8 +179,6 @@ subroutine write_options_prdrag(iunit) call write_inopt(k1, 'Redshift', & 'Redshift multiplier', iunit) - call write_options_lumin_nsdisc(iunit) - end subroutine write_options_prdrag !----------------------------------------------------------------------- @@ -191,8 +187,7 @@ end subroutine write_options_prdrag !+ !----------------------------------------------------------------------- subroutine read_options_prdrag(name,valstring,imatch,igotall,ierr) - use io, only:fatal, warning - use lumin_nsdisc, only:read_options_lumin_nsdisc + use io, only:fatal, warning character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr @@ -203,6 +198,9 @@ subroutine read_options_prdrag(name,valstring,imatch,igotall,ierr) igotall = .false. select case(trim(name)) + case('beta') + read(valstring,*,iostat=ierr) beta + ngot = ngot + 1 case('RadiationPressure') read(valstring,*,iostat=ierr) k0 ngot = ngot + 1 @@ -214,7 +212,6 @@ subroutine read_options_prdrag(name,valstring,imatch,igotall,ierr) ngot = ngot + 1 case default imatch = .false. - call read_options_lumin_nsdisc(name,valstring,imatch,igotall,ierr) end select igotall = (ngot >= 1) diff --git a/src/main/externalforces.f90 b/src/main/externalforces.f90 index 51f3ecd3c..26c40eb92 100644 --- a/src/main/externalforces.f90 +++ b/src/main/externalforces.f90 @@ -21,7 +21,7 @@ module externalforces ! :Dependencies: dump_utils, extern_Bfield, extern_binary, extern_corotate, ! extern_densprofile, extern_geopot, extern_gnewton, extern_gwinspiral, ! extern_lensethirring, extern_prdrag, extern_spiral, extern_staticsine, -! infile_utils, io, lumin_nsdisc, part, units +! infile_utils, io, part, units ! use extern_binary, only:accradius1,mass1,accretedmass1,accretedmass2 use extern_corotate, only:omega_corotate ! so public from this module @@ -525,8 +525,7 @@ end subroutine update_vdependent_extforce_leapfrog !+ !----------------------------------------------------------------------- subroutine update_externalforce(iexternalforce,ti,dmdt) - use io, only:iprint,iverbose,warn - use lumin_nsdisc, only:set_Lstar,BurstProfile,LumAcc,make_beta_grids + use io, only:warn use part, only:xyzh,vxyzu,massoftype,npartoftype,igas,npart,nptmass,& xyzmh_ptmass,vxyz_ptmass use extern_gwinspiral, only:gw_still_inspiralling,get_gw_force @@ -538,12 +537,6 @@ subroutine update_externalforce(iexternalforce,ti,dmdt) select case(iexternalforce) case(iext_binary,iext_corot_binary) call update_binary(ti) - case(iext_prdrag) - call make_beta_grids( xyzh, massoftype(igas), npartoftype(igas) ) - call set_Lstar( BurstProfile, ti, dmdt, mass1 ) - if (iverbose >= 1) then - write(iprint,*) 'updating prdrag at t = ',ti,' Mdot = ',dmdt,' LAcc = ',LumAcc - endif case(iext_gwinspiral) call gw_still_inspiralling(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,stopped_now) call get_gw_force() diff --git a/src/main/lumin_nsdisc.f90 b/src/main/lumin_nsdisc.f90 deleted file mode 100644 index 90db88923..000000000 --- a/src/main/lumin_nsdisc.f90 +++ /dev/null @@ -1,1118 +0,0 @@ -!--------------------------------------------------------------------------! -! 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 lumin_nsdisc -! -! This module contains routines for calculating beta, the -! ratio of radiation to gravitational force, for an accretion disc -! surrounding a neutron star. It contains associated functions -! for calculating opacity, accretion luminosity, etc. -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: eos, infile_utils, io, physcon, units -! - - use physcon, only: pi - implicit none - - real :: LumAcc = 0.0 ! luminosity from accretion - integer, public :: BurstProfile = 0 ! Burst luminosity / profile - real, private :: Lstar = 0.0 ! total luminosity of star as a fraction of Eddington - real, private :: LEdd = 0.0 ! Eddington luminosity in code units - real, private :: frac_X = 0.7 ! Hydrogen fraction - integer, private :: rad_trans = 0 ! Radiation transport prescription - real :: AccLumEff = 1.0 ! Fraction of accretion luminosity that - ! participates in radiation force. This is - ! mostly only relevant for compact objects. - ! number of gridpoints for the rho, tau, beta grids - integer, parameter :: nr = 63, nth=16 , nph=24, nz=30 - real :: ringrid(0:nr), cyl_ringrid(0:nr), thmingrid(0:nth), phmingrid(0:nph), zmingrid(0:nz) - integer :: npgrid(0:nr-1,0:nth-1,0:nph-1), w92npart( 0:nr-1 ), cyl_npgrid(0:nr-1,0:nz,0:nph-1) - real :: densitygrid(0:nr-1,0:nth-1,0:nph-1), ldensitygrid(0:nr-1,0:nth-1,0:nph-1) - real :: tauradgrid(0:nr-1,0:nth-1,0:nph-1), ltauradgrid(0:nr-1,0:nth-1,0:nph-1) - real :: betagrid(0:nr-1,0:nth-1,0:nph-1), lbetagrid(0:nr-1,0:nth-1,0:nph-1) !the grids - - real :: cyl_densitygrid(0:nr-1,0:nz,0:nph-1), cyl_ldensitygrid(0:nr-1,0:nz,0:nph-1) - real :: cyl_tauradgrid(0:nr-1,0:nz,0:nph-1), cyl_ltauradgrid(0:nr-1,0:nz,0:nph-1) - real :: cyl_betagrid(0:nr-1,0:nz,0:nph-1), cyl_lbetagrid(0:nr-1,0:nz,0:nph-1) !cylindrical grids - - real :: w92betagrid( 0:nr-1 ), w92sumbeta( 0:nr-1 ) !cylindrical grid for comparison with W92 - real :: thetamin = 0.0, thetamax = pi, rmin = 1.0, rmax = 1001.0 - real :: zmin = -200, zmax=200 - real :: phimax = 2*pi, phimin=0 - real :: Lstar_burst - real, parameter :: eps = 1.e-6 - integer, private :: made_grid_points = 0 - - public :: beta, set_Lstar, calc_sigma, calc_scaleheight - public :: read_options_lumin_nsdisc, write_options_lumin_nsdisc - public :: LumAcc, Lstar_burst, AccLumEff, ringrid, thmingrid, thetamin, thetamax, rmin, rmax - public :: nr, nth, nph, densitygrid, tauradgrid, betagrid, lbetagrid, make_beta_grids - public :: get_grid_points, bilin_interp, get_grid_bins, sphere_segment, get_bracket_grid_points - public :: ldensitygrid, ltauradgrid, careful_log, phmingrid, phimin, phimax, w92betagrid - public :: cyl_ringrid, zmingrid, cyl_npgrid, cyl_densitygrid, cyl_ldensitygrid, cyl_tauradgrid - public :: cyl_ltauradgrid, cyl_betagrid, cyl_lbetagrid, zmin, zmax, nz - - private :: calc_kappa, eps - - private - -contains - -!---------------------------------------------------------------- -!+ -! Sets the location of the grid points -!+ -!---------------------------------------------------------------- - -subroutine make_grid_points() - use physcon, only:pi, twopi - integer :: rbin, thbin, phbin, zbin - real :: A, B, C, tempr - A = (rmax-rmin)/(nr*nr) - B = 2.*(thetamin-thetamax)/nth - C = 2.*(zmin-zmax)/nz - - do rbin=0, nr-1 - tempr = rmin + A*rbin**2 - ringrid(rbin) = tempr - w92betagrid(rbin) = tempr - cyl_ringrid(rbin) = tempr - enddo - - thmingrid(0)=thetamin - do thbin=1,nth/2-1 - thmingrid(thbin) = B*(1.0*thbin*thbin/nth-thbin)+thetamin - thmingrid(nth-thbin) = thetamax - thmingrid(thbin) - enddo - thmingrid(nth/2) = (thetamin+thetamax)/2; - - zmingrid(0)=zmin - do zbin=1,nz/2-1 - zmingrid(zbin) = C*(1.0*zbin*zbin/nz-zbin)+zmin - zmingrid(nz-zbin) = (zmax+zmin)/2. - zmingrid(zbin) - enddo - zmingrid(nz/2) = (zmin+zmax)/2. - - do phbin=0,nph-1 - phmingrid(phbin) = phbin * twopi/nph - enddo - - made_grid_points = 1 - -end subroutine make_grid_points - -!---------------------------------------------------------------- -!+ -! Given a set of coordinates r, theta, phi, finds the cell -! those coords are in -!+ -!---------------------------------------------------------------- - -subroutine get_grid_bins( r, zt, rbin, ztbin, phi, phibin ) - use physcon, only:pi, twopi - use io, only : fatal - real, intent(in) :: r, phi, zt - integer, intent(out) :: rbin, ztbin, phibin - real :: B, C, ztnew - - rbin = int( nr*sqrt( (r-rmin)/(rmax-rmin))) - - B = 2.*(thetamin-thetamax)/(nth) - C = 2.*(zmin-zmax)/nz - - select case(rad_trans) - case(2) - if ( zt < (zmin+zmax)/2. ) then - ztbin = int( (sqrt( (nz*C)**2 + 4*nz*C*(zt-zmin) ) + nz*C)/(2.*C) ) - else - ztnew = zmin + zmax - zt - ztbin = int( (sqrt( (nz*C)**2 + 4*nz*C*(ztnew-zmin) ) + nz*C)/(2.*C) ) - ztbin = nz-ztbin-1 - endif - if ( ztbin>nz ) ztbin = nz - if ( ztbin<0 ) ztbin = 0 - case default ! 0,1 - if ( zt < (thetamin+thetamax)/2. ) then - ztbin = int( (sqrt( (nth*B)**2 + 4*nth*B*(zt-thetamin) ) + nth*B)/(2.*B) ) - else - ztnew = thetamin + thetamax - zt - ztbin = int( (sqrt( (nth*B)**2 + 4*nth*B*(ztnew-thetamin) ) + nth*B)/(2.*B) ) - ztbin = nth-ztbin-1 - endif - if ( ztbin < 0 .or. ztbin>nth-1 ) then - call fatal( 'lumin_nsdisc', 'Array out of bounds error in get_grid_bins (theta)' ) - endif - end select - - phibin = int( phi*nph/twopi) - if ( rbin>nr-1 ) rbin=nr-1 ! Avoids segfaults for distant particles - if ( rbin<0 ) rbin = 0 ! Avoids segfaults for accreted particles - -end subroutine get_grid_bins - -!---------------------------------------------------------------- -!+ -! Given a bin in an array, finds the inner and outer edges, and the -! midpoint -!+ -!---------------------------------------------------------------- - -subroutine get_grid_points( array, ix, nx, maxx, xin, xout, xmid ) - use io, only : fatal - integer, intent(in) :: nx, ix - real, intent(in) :: array(0:nx-1), maxx - real, intent(out) :: xin, xout, xmid - if ( ix<0.or.ix>=nx ) then - call fatal( 'lumin_nsdisc', 'Array out of bounds error in get_grid_points' ) - endif - xin = array(ix) - - if ( ix==nx-1 ) then - xout = maxx - else - xout = array(ix+1) - endif - - xmid = ( xin + xout )/2. - -end subroutine get_grid_points - -!---------------------------------------------------------------- -!+ -! Given a bin in an array, finds the midpoints of that bin and the next -! one out. This is called in preparation for bilin_interp -!+ -!---------------------------------------------------------------- - -subroutine get_bracket_grid_points( array, ix, nx, maxx, x1, x2 ) - use io, only : fatal - integer, intent(in) :: nx, ix - real, intent(in) :: array(0:nx-1), maxx - real, intent(out) :: x1, x2 - real :: minimum, maximum, boundary - - if ( ix<0.or.ix>=nx-1 ) then - call fatal( 'lumin_nsdisc', 'Array out of bounds error in get_bracket_grid_points' ) - !this should never happen. Checks in the calling function should avoid passing bad ix values. - endif - - minimum = array(ix) - boundary = array(ix+1) - - if ( ix==nx-2 ) then - maximum = maxx - else - maximum = array(ix+2) - endif - - x1 = minimum + (boundary-minimum)/2. - x2 = boundary + (maximum-boundary)/2. - -end subroutine get_bracket_grid_points - -!---------------------------------------------------------------- -!+ -! Generates a set of grids containing rho, tau, and beta -! Calculates density by counting the number of particles in -! each spherical r,theta bin -! Calculates tau by integrating radially from NS surface -! Calculates beta = exp(-tau). You still need to multiply beta -! by L*/LEdd to get the true beta used to calculate PR drag -!+ -!---------------------------------------------------------------- - -subroutine make_beta_grids(xyzh,particlemass,npart) - use units, only: udist, umass - - integer, intent(in) :: npart - real, intent(in) :: xyzh(:,:) - real, intent(in) :: particlemass - real :: theta, r, phi, kappa, r_cyl - real :: dr, dz, cell_phin, cell_phout, cell_phmid - real :: cell_rin, cell_rout, cell_rmid, cell_thin, cell_thout, cell_thmid - real :: cell_zin, cell_zout, cell_zmid - real :: cell_volume, logzero, x, y, z - integer :: rbin, thbin, phbin, zbin, ipart, totpart - - kappa = real(calc_kappa( frac_X, 2. ) * (umass/(udist*udist))) !kappa in code units - - logzero = careful_log( 0.0 ) - - call make_grid_points() - do rbin=0, nr-1 !clear the density grid, since it is retained after every call - do phbin=0, nph-1 - do thbin=0, nth-1 - ldensitygrid( rbin, thbin, phbin ) = logzero - densitygrid( rbin, thbin, phbin ) = 0.0 - npgrid( rbin, thbin, phbin ) = 0 - enddo - do zbin=0, nz - cyl_ldensitygrid(rbin, zbin, phbin) = logzero - cyl_densitygrid(rbin, zbin, phbin) = 0.0 - cyl_npgrid(rbin, zbin, phbin) = 0 - enddo - enddo - enddo - - totpart = 0 - do ipart=1, npart !fills the density grid by counting particles and assigning - !each one to a cell - x = xyzh(1, ipart) - y = xyzh(2, ipart) - z = xyzh(3, ipart) - - if ( isnan(x).or.isnan(y).or.isnan(z) ) then - x=0. - y=0. - z=0. - endif - - r = sqrt( x**2 + y**2 + z**2 ) - r_cyl = sqrt(x**2 + y**2) - - if ( r>rmin.and.r thetamax ) theta = thetamax - if ( theta < thetamin ) theta = thetamin - - phi = pi + atan2( y, x ) - endif - if (phbin >= nph ) then !phi is cyclic - phbin = phbin - nph - endif - cell_phin = phmingrid( phbin ) - if ( phbin == nph-1 ) then - cell_phout = phimax - else - cell_phout = phmingrid( phbin+1 ) - endif - if ( r>rmin.and.r=0).and.(rbin=0).and.(thbin=0).and.(phbinzmax ) z=zmax-eps - if ( z=0).and.(rbin=0).and.(zbin=0).and.(phbin thetamax ) theta = thetamax - if ( theta < thetamin ) theta = thetamin - phi = pi + atan2( y, x ) - if ( r_cyl>= 0) then - call get_grid_bins( r_cyl, 0., rbin, thbin, 0., phbin ) - else - rbin=-1 - thbin=-1 - phbin=-1 - endif - if ( rbin>=0.and.rbin= taubig ) then - tau_to_beta = 0. - else - tau_to_beta = exp(-tau) - endif - -end function tau_to_beta - -!------------------------------------------------ -!+ -! Calculates the total luminosity of the star, -! including perhaps luminosity from accretion -!+ -!------------------------------------------------ - -subroutine set_Lstar( BurstProfile, time, dmdt, Mstar ) - use units, only:utime, umass, udist - use physcon, only:fourpi - real, intent(in) :: time, dmdt, Mstar - integer, intent(in) :: BurstProfile - real :: ptime, ptime2 - -!this assumes c=G=1. - LEdd = real(fourpi*Mstar/(calc_kappa( frac_X, 2. ) / ( udist*udist / umass ))) - ptime = real(time*utime) - ptime2 = ptime*ptime - - select case( BurstProfile ) - - case(-1) ! Test case. I will modify this one frequently. - if ( time < 9999.) then - Lstar_burst=0.0 - AccLumEff=0.0 - else - Lstar_burst=1.0 - AccLumEff=0.0 - endif - case(0) ! No luminosity, either from burning or from accretion feedback - Lstar_burst = 0.0 - AccLumEff = 0.0 - case(1) !Time-variable luminosity profile. - ! 00.00 - 00.25 = no luminosity at all to remove initial transient - ! 00.25 - 01.00 = no L*, linearly ramp up accretion feedback from 0 to 1 - ! 01.00 - 01.50 = Linear rise in L* from 0 to LEdd/2 - ! 01.50 - 10.00 = Quadratic decay back to zero - ! 10.00 - = L* = 0, AccLumEff = 1. - if ( ptime < 0.25 ) then - Lstar_burst = 0.0 - AccLumEff = 0.0 - elseif ( ptime < 1.0 ) then - Lstar_burst = 0.0 - AccLumEff = (ptime*4. - 1.)/3. - elseif ( ptime < 1.5 ) then - Lstar_burst = (ptime - 1.) - AccLumEff = 1. - elseif ( ptime < 10. ) then - Lstar_burst = (2*ptime2 - 40*ptime + 200)/289.0 - AccLumEff = 1. - else - Lstar_burst = 0.0 - AccLumEff = 1. - endif - case(2) ! No burning, but ramp up AccLumEff after initial transient - Lstar_burst = 0.0 - if ( ptime < 0.25 ) then - AccLumEff = 0.0 - elseif ( ptime < 1.0 ) then - AccLumEff = (ptime*4. - 1.)/3. - else - AccLumEff = 1.0 - endif - case(3) ! No burning, but ramp up AccLumEff half as fast as in case(2) - Lstar_burst = 0.0 - if ( ptime < 0.25 ) then - AccLumEff = 0.0 - elseif ( ptime < 1.75 ) then - AccLumEff = (ptime*4. - 1.)/6. - else - AccLumEff = 1.0 - endif - case(4) ! Remove initial transient; ramp up acclum over 3/4 second; allow to settle to 10s; - ! impose a half eddington burst at 10s - Lstar_burst = 0.0 - if ( ptime < 0.25 ) then !remove initial transient - AccLumEff = 0.0 - elseif ( ptime < 1.00 ) then !ramp up AccLum - AccLumEff = (ptime*4. - 1.)/3. - elseif ( ptime < 10.00 ) then !Settle disc - AccLumEff = 1.0 - elseif ( ptime < 10.5 ) then !Burst rise - AccLumEff = 1.0 - Lstar_burst = (ptime-10) - elseif ( ptime < 20.5 ) then !Burst decay - AccLumEff = 1.0 - Lstar_burst = (4*ptime2 - 164*ptime + 1681)/800. - else !Post burst - AccLumEff = 1.0 - Lstar_burst = 0.0 - endif - case(5) ! Eddington luminosity from beginning of simulation - Lstar_burst = 1.0 - AccLumEff = 1.0 - case(6) ! Remove initial transient; ramp up acclum over 3/4 second; allow to settle to 10s; - ! impose a half eddington burst at 10s - Lstar_burst = 0.0 - if ( ptime < 0.25 ) then !remove initial transient - AccLumEff = 0.0 - elseif ( ptime < 1.00 ) then !ramp up AccLum - AccLumEff = (ptime*4. - 1.)/3. - elseif ( ptime < 10.00 ) then !Settle disc - AccLumEff = 1.0 - elseif ( ptime < 10.5 ) then !Burst rise - AccLumEff = 1.0 - Lstar_burst = (ptime-10)*2 - elseif ( ptime < 20.5 ) then !Burst decay - AccLumEff = 1.0 - Lstar_burst = (4*ptime2 - 164*ptime + 1681)/400. - else !Post burst - AccLumEff = 1.0 - Lstar_burst = 0.0 - endif - case(7) !Fit to a type-1 nonPRE burst from 1636-536. Since I'll be starting from an already settled simulation, no need to adjust time - ptime2 = ptime-3 - Lstar_burst = 0.0 - AccLumEff = 0.0 - if ( ptime > 2. .and. ptime <3. ) then - Lstar_burst=0 - AccLumEff = ptime-2. - endif - if ( ptime>3 ) then - Lstar_burst = 9.4*ptime2**1.6*exp(-2.9*ptime2**0.4) - AccLumEff = 1. - endif - case(8) !0.1 L_Edd from beginning of simulation, used for prtest - Lstar_burst = 0.10 - AccLumEff = 0.00 - end select - - if ( AccLumEff > 1.e-16 ) then !If we are including luminosity feedback - LumAcc = AccLumEff * get_AccLum( dmdt, Mstar ) - else - LumAcc = 0.0 - endif - Lstar = Lstar_burst + LumAcc - -end subroutine set_Lstar - -!---------------------------------------------------- -!+ -! Converts accretion rate into luminosity -!+ -!---------------------------------------------------- - -real function get_AccLum( dmdt, Mstar ) !Luminosity from accretion - use units, only:get_G_code - real, intent(in) :: dmdt, Mstar - real :: ggcode, Rstar - - ggcode = get_G_code() - Rstar = 1. - - get_AccLum = (ggcode * Mstar * dmdt / Rstar) / LEdd - -end function get_AccLum - -!---------------------------------------------- -!+ -! function computing kappa opacity from hydrogen -! fraction X and temperature kT (in keV). -! Returns opacity in cm^2 g^{-1} -! -! See Lewin et al 1993, SSR, 62, 233 (p. 276 4.13b) -!+ -!---------------------------------------------- - -real function calc_kappa( X, kT ) - real, intent(in) :: X, kT - real :: k0, tempcorr - k0 = 0.2*(1.0 + X) - tempcorr = 1.0 + ( kT/39.2 )**0.86 - calc_kappa = k0/tempcorr -end function calc_kappa - -!---------------------------------------------- -!+ -! function computing the beta parameter -!+ -!---------------------------------------------- -real function beta(x,y,z) - use physcon, only:c, gg, fourpi, pi, roottwo, rpiontwo - use io, only:fatal - use units, only:umass,udist - real, intent(in) :: x,y,z - real :: r, theta, phi, rcyl, H, kappa, tau - integer :: rbin, thetabin, phibin, zbin - - beta = 0. - rcyl = sqrt( x*x + y*y ) - phi = pi + atan2(y,x) - r = sqrt(x**2 + y**2 + z**2) - theta=acos(z/r) - - select case( rad_trans ) - case( 0 ) - r = sqrt(x**2 + y**2 + z**2) - theta = acos( z/r ) - if ( theta > thetamax ) theta = thetamax - if ( theta < thetamin ) theta = thetamin - if ( r>rmin.and.rrmin.and.rcyl Lstar ) then - beta = Lstar !hopefully unnecessary sanity checks - endif - if ( beta < 0. ) beta = 0. - -end function beta - -!---------------------------------------------- -!+ -! Calculates a beta by calling bilin_interp -!+ -!--------------------------------------------- -real function beta_by_interp(r, theta, phi) - real, intent(in) :: r, theta, phi - real :: betain, betaout - integer :: rbin, thetabin, phibin - - beta_by_interp = 0 - rbin=0 - thetabin=0 - phibin=0 - call get_grid_bins( r, theta, rbin, thetabin, phi, phibin ) - - if ( rbin >= nr-1 ) rbin = nr-1 - - if ( r<=rmin ) then - betain = 0. - betaout = 0. - elseif ( frac_X < 0. ) then - betain = 1. - betaout = 1. - elseif ( rbin>=nr-1 ) then - betain = lbetagrid(nr-1, thetabin, phibin) - betain = min(exp(betain), 1.) - betaout = betain - else - betain = bilin_interp( lbetagrid, ringrid(rbin), theta, phi) - betain = exp(betain) - - betaout = bilin_interp( lbetagrid, ringrid(rbin+1), theta, phi ) - betaout = exp(betaout) - endif - - if ( npgrid( rbin, thetabin, phibin )==0) then - beta_by_interp = betain - else - beta_by_interp = (betaout + (betain-betaout)/npgrid( rbin, thetabin, phibin )) - - endif - -end function beta_by_interp - -!---------------------------------------------- -!+ -! Calculates a beta by calling bilin_interp on a cylindrical grid -!+ -!--------------------------------------------- -real function beta_by_interp_cyl(r, z, phi) - real, intent(in) :: r, z, phi - real :: betain, betaout - integer :: rbin, zbin, phibin - real :: znew - znew=z - if ( z > zmax ) znew = zmax - eps - if ( z < zmin ) znew = zmin + eps - rbin=0 - zbin=0 - phibin=0 - call get_grid_bins( r, z, rbin, zbin, phi, phibin ) - if ( r<=rmin ) then - betain = 0. - betaout = 0. - elseif ( frac_X < 0. ) then - betain = 1. - betaout = 1. - elseif ( rbin>=nr-1 ) then - betain = bilin_interp_cyl( cyl_lbetagrid, r, z, phi ) - betain = min(exp(betain), 1.) - betaout = betain - else - betain = bilin_interp_cyl( cyl_lbetagrid, r, z, phi ) - betain = exp(betain) - betaout = bilin_interp_cyl( cyl_lbetagrid, r, z, phi ) - betaout = exp(betaout) - endif - - if ( cyl_npgrid( rbin, zbin, phibin )==0) then - beta_by_interp_cyl = betain - else - beta_by_interp_cyl = (betaout + (betain-betaout)/cyl_npgrid( rbin, zbin, phibin )) - endif - -end function beta_by_interp_cyl - -!---------------------------------------------- -!+ -! Finds a value by bilinearly interpolating on a grid -!+ -!---------------------------------------------- - -real function bilin_interp( array, r, theta, phi ) - use physcon, only: twopi - real, intent(in) :: array(0:nr-1, 0:nth-1, 0:nph-1), phi, theta, r - real :: t1, t2, p1, p2, ft1p1, ft2p1,ft1p2, ft2p2, tmid, pmid - real :: ftp, dta, dtb, dpa, dpb, dummy - integer :: tbin1, tbin2, pbin1, pbin2, tbin0, pbin0, rbin0 - - bilin_interp = 0. - if ( r>rmin) then - call get_grid_bins( r, theta, rbin0, tbin0, phi, pbin0 ) - else - call get_grid_bins( rmin+eps, theta, rbin0, tbin0, phi, pbin0 ) - rbin0=0 - endif - call get_grid_points( thmingrid, tbin0, nth, thetamax, t1, t2, tmid ) - - if ( tbin0 == 0.and.thetatmid ) then - call get_bracket_grid_points( thmingrid, nth-2, nth, thetamax, t1, t2 ) - tbin1 = nth-2 - elseif ( theta > tmid ) then - call get_bracket_grid_points( thmingrid, tbin0, nth, thetamax, t1, t2 ) - tbin1 = tbin0 - else - call get_bracket_grid_points( thmingrid, tbin0-1, nth, thetamax, t1, t2 ) - tbin1 = tbin0-1 - endif - - call get_grid_points( phmingrid, pbin0, nph, phimax, p1, p2, pmid ) - - if ( pbin0 == 0.and.phipmid ) then - call get_bracket_grid_points( phmingrid, nph-2, nph, phimax, p1, dummy ) - call get_bracket_grid_points( phmingrid, 0, nph, phimax, dummy, p2 ) - p2 = p2 + twopi - pbin1 = nph-1 - pbin2 = 0 - elseif ( phi>pmid ) then - call get_bracket_grid_points( phmingrid, pbin0, nph, phimax, p1, p2 ) - pbin1 = pbin0 - pbin2 = pbin0+1 - else - call get_bracket_grid_points( phmingrid, pbin0-1, nph, phimax, p1, p2 ) - pbin1 = pbin0-1 - pbin2 = pbin0 - endif - - tbin2=tbin1+1 - - if ( pbin1<0 ) pbin1 = nph-1 - if ( pbin2>nph-1 ) pbin2 = 0 - - ft1p1 = array( rbin0, tbin1, pbin1 ) - ft1p2 = array( rbin0, tbin1, pbin2 ) - ft2p1 = array( rbin0, tbin2, pbin1 ) - ft2p2 = array( rbin0, tbin2, pbin2 ) - - dta = theta - t1 - dtb = t2 - theta - dpa = phi - p1 - dpb = p2 - phi - - ftp = ft1p1*dtb*dpb & - + ft2p1*dta*dpb & - + ft1p2*dtb*dpa & - + ft2p2*dta*dpa - - bilin_interp = ftp/( (t2-t1)*(p2-p1) ) - -end function bilin_interp - -!---------------------------------------------- -!+ -! Finds a value by bilinearly interpolating on a cylindrical grid -!+ -!---------------------------------------------- - -real function bilin_interp_cyl( array, r, z, phi ) - use physcon, only: twopi - real, intent(in) :: array(0:nr-1, 0:nz, 0:nph-1), phi, z, r - real :: r1, r2, p1, p2, fr1p1, fr2p1,fr1p2, fr2p2, rmid, pmid - real :: frp, dra, drb, dpa, dpb, dummy - integer :: rbin1, rbin2, pbin1, pbin2, zbin0, pbin0, rbin0 - real :: znew - znew=z - zbin0=0 - if ( z>zmax ) znew = zmax - eps - if ( zrmid ) then - call get_bracket_grid_points( cyl_ringrid, nr-2, nr, rmax, r1, r2 ) - rbin1 = nr-2 - elseif ( r > rmid ) then - call get_bracket_grid_points( cyl_ringrid, rbin0, nr, rmax, r1, r2 ) - rbin1 = rbin0 - else - call get_bracket_grid_points( cyl_ringrid, rbin0-1, nr, rmax, r1, r2 ) - rbin1 = rbin0-1 - endif - - call get_grid_points( phmingrid, pbin0, nph, phimax, p1, p2, pmid ) - - if ( pbin0 == 0.and.phipmid ) then - call get_bracket_grid_points( phmingrid, nph-2, nph, phimax, p1, dummy ) - call get_bracket_grid_points( phmingrid, 0, nph, phimax, dummy, p2 ) - p2 = p2 + twopi - pbin1 = nph-1 - pbin2 = 0 - elseif ( phi>pmid ) then - call get_bracket_grid_points( phmingrid, pbin0, nph, phimax, p1, p2 ) - pbin1 = pbin0 - pbin2 = pbin0+1 - else - call get_bracket_grid_points( phmingrid, pbin0-1, nph, phimax, p1, p2 ) - pbin1 = pbin0-1 - pbin2 = pbin0 - endif - - rbin2=rbin1+1 - - if ( pbin1<0 ) pbin1 = nph-1 - if ( pbin2>nph-1 ) pbin2 = 0 - - fr1p1 = array( rbin1, zbin0, pbin1 ) - fr1p2 = array( rbin1, zbin0, pbin2 ) - fr2p1 = array( rbin2, zbin0, pbin1 ) - fr2p2 = array( rbin2, zbin0, pbin2 ) - - dra = r - r1 - drb = r2 - r - dpa = phi - p1 - dpb = p2 - phi - - frp = fr1p1*drb*dpb & - + fr2p1*dra*dpb & - + fr1p2*drb*dpa & - + fr2p2*dra*dpa - - bilin_interp_cyl = frp/( (r2-r1)*(p2-p1) ) - -end function bilin_interp_cyl - -!---------------------------------------------- -!+ -! Returns the natural logarithm of a number, -! or a very large negative number if given a negative -!+ -!---------------------------------------------- - -real function careful_log( x ) - real, intent(in) :: x - real, parameter :: xbig = range(x)*log(10.) - if ( x <= 0. ) then - careful_log = -100. - else - careful_log = max(log(x), -xbig/2.) - endif -end function careful_log - -!---------------------------------------------- -!+ -! function computing the disc scale height -!+ -!---------------------------------------------- -real function calc_scaleheight( r ) - use eos, only:polyk, qfacdisc - real, intent(in) :: r - real :: omega, cs - if ( r > 0. ) then - omega = 1.0/r**(1.5) - cs = sqrt(polyk) * r**(-qfacdisc) - calc_scaleheight = (cs/omega) - else - calc_scaleheight = -1000. !sentinel value for star interior - endif -end function calc_scaleheight - -!---------------------------------------------- -!+ -! function computing the disc surface density -!+ -!---------------------------------------------- -real function calc_sigma( r ) - use units, only:umass - use physcon, only:solarm - real, intent(in) :: r - real :: R_in = 1., Mdisc - - Mdisc = real(1.4d0*solarm/umass*5.d-16) - - if ( r>r_In ) then - calc_sigma = sqrt(R_in) * Mdisc * r**(-3./2.)*(1-sqrt(R_in/r)) - else - calc_sigma = 0. - endif - -end function calc_sigma - -!----------------------------------------------------------------------- -!+ -! writes input options to the input file -!+ -!----------------------------------------------------------------------- -subroutine write_options_lumin_nsdisc(iunit) - use infile_utils, only:write_inopt - integer, intent(in) :: iunit - - write(iunit,"(/,a)") '# options relating to the neutron star disc' - call write_inopt(BurstProfile,'BurstProfile',& - 'Burst Profile',iunit) - ! Between 0 and 1 = constant luminosity - ! Any negative value = burst profile as described in set_Lstar - - call write_inopt(frac_X,'frac_X',& - 'Hydrogen fraction (-ve for zero opacity)',iunit) - - call write_inopt(rad_trans, 'rad_trans', & - 'Radiation transport prescription', iunit) - -end subroutine write_options_lumin_nsdisc - -!----------------------------------------------------------------------- -!+ -! reads input options from the input file -!+ -!----------------------------------------------------------------------- -subroutine read_options_lumin_nsdisc(name,valstring,imatch,igotall,ierr) - use io, only:fatal, warning - 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_lumin_nsdisc' - - imatch = .true. - igotall = .false. - - select case(trim(name)) - case('BurstProfile') - read(valstring,*,iostat=ierr) BurstProfile - case('frac_X') - read(valstring,*,iostat=ierr) frac_X - case('rad_trans') - read(valstring,*,iostat=ierr) rad_trans - case default - imatch = .false. - end select - igotall = (ngot >= 1) - -end subroutine read_options_lumin_nsdisc - -end module lumin_nsdisc From 1dc6825ddbeeee853126053ac2bb7272ac3d3617 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 09:06:29 +1000 Subject: [PATCH 396/814] build failure: remove external declaration on call system as breaks gfortran --- src/main/utils_cpuinfo.f90 | 1 - src/main/utils_datafiles.f90 | 1 - 2 files changed, 2 deletions(-) diff --git a/src/main/utils_cpuinfo.f90 b/src/main/utils_cpuinfo.f90 index fd9d8f011..5e50794c9 100644 --- a/src/main/utils_cpuinfo.f90 +++ b/src/main/utils_cpuinfo.f90 @@ -75,7 +75,6 @@ subroutine get_cpuinfo(ncpu,ncpureal,cpuspeed,cpumodel,cachesize,ierr) character(len=80) :: line character(len=40) :: tempfile real :: cachesizel2,cachesizel3 - external :: system ! !--on Linux, cpu info will be located in the /proc/cpuinfo file ! So we look in this file first diff --git a/src/main/utils_datafiles.f90 b/src/main/utils_datafiles.f90 index 13aeb1158..f3212a0dd 100644 --- a/src/main/utils_datafiles.f90 +++ b/src/main/utils_datafiles.f90 @@ -153,7 +153,6 @@ subroutine retrieve_remote_file(url,file,dir,localfile,ierr) integer :: ilen,iunit!,ierr1 logical :: iexist character(len=*), parameter :: cmd = 'curl -k' - external :: system print "(80('-'))" print "(a)",' Downloading '//trim(file)//' from '//trim(url) From 634060e17ecb4e792241ea544b933646febde7c4 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 09:07:21 +1000 Subject: [PATCH 397/814] (einsteintoolkit) removed unused functionality/commented out code --- src/main/tmunu2grid.f90 | 14 ------- src/utils/einsteintk_wrapper.f90 | 66 ++++---------------------------- 2 files changed, 8 insertions(+), 72 deletions(-) diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index ea91589c1..856ba55a7 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -58,11 +58,6 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) ! Get density rho = rhoh(h,pmass) call get_weight(pmass,h,rho,weight) - ! Correct for Kernel Bias, find correction factor - ! Wrap this into it's own subroutine - if (present(calc_cfac)) then - if (calc_cfac) call get_cfac(cfac,rho) - endif weights = weight itype = 1 @@ -156,15 +151,6 @@ subroutine get_particle_domain(gridorigin,xmin,xmax,dxgrid,ilower,iupper) ! domain but the upper is not; can't have both? end subroutine get_particle_domain -subroutine get_cfac(cfac,rho) - real, intent(in) :: rho - real, intent(out) :: cfac - real :: rhoexact - rhoexact = 13.294563008157013D0 - cfac = rhoexact/rho - -end subroutine get_cfac - subroutine interpolate_to_grid(gridarray,dat) use einsteintk_utils, only: dxgrid, gridorigin use interpolations3D, only: interpolate3D diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 4b9e477eb..312374352 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -29,37 +29,16 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) use io, only:id,master,nprocs,set_io_unit_numbers,die use mpiutils, only:init_mpi,finalise_mpi use initial, only:initialise,finalise,startrun,endrun - !use evolve, only:evol_init use tmunu2grid use einsteintk_utils use extern_gr use metric - use part, only:npart!, tmunus - - + use part, only:npart implicit none character(len=*), intent(in) :: infilestart real, intent(in) :: dt_et integer, intent(inout) :: nophantompart real, intent(out) :: dtout - !character(len=500) :: logfile,evfile,dumpfile,path - !integer :: i,j,k,pathstringlength - - ! For now we just hardcode the infile, to see if startrun actually works! - ! I'm not sure what the best way to actually do this is? - ! Do we store the phantom.in file in par and have it read from there? - !infile = "/Users/spencer/phantomET/phantom/test/flrw.in" - !infile = trim(infile)//'.in' - !print*, "phantom_path: ", phantom_path - !infile = phantom_path // "flrw.in" - !infile = trim(path) // "flrw.in" - !infile = 'flrw.in' - !infile = trim(infile) - !print*, "Phantom path is: ", path - !print*, "Infile is: ", infile - ! Use system call to copy phantom files to simulation directory - ! This is a digusting temporary fix - !call SYSTEM('cp ~/phantomET/phantom/test/flrw* ./') ! The infile from ET infilestor = infilestart @@ -72,27 +51,12 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) ! setup io call set_io_unit_numbers ! routine that starts a phantom run - print*, "Start run called!" - ! Do we want to pass dt in here?? call startrun(infilestor,logfilestor,evfilestor,dumpfilestor) - print*, "Start run finished!" - !print*, "tmunugrid: ", tmunugrid(1,1,6,6,6) - !stop - ! Intialises values for the evol routine: t, dt, etc.. - !call evol_init(infilestor,logfilestor,evfilestor,dumpfilestor,dt_et,nophantompart) - !print*, "Evolve init finished!" + nophantompart = npart - ! Calculate the stress energy tensor for each particle - ! Might be better to do this in evolve init - !call get_tmunugrid_all - ! Calculate the stress energy tensor - call get_metricderivs_all(dtout,dt_et) ! commented out to try and fix prim2cons - !call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) ! commented out to try and fix prim2cons - !call get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - ! Interpolate stress energy tensor from particles back - ! to grid - !call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac=.true.) ! commented out to try and fix cons2prim + call get_metricderivs_all(dtout,dt_et) ! commented out to try and fix prim2cons + call get_phantom_dt(dtout) end subroutine init_et2phantom @@ -167,7 +131,6 @@ subroutine step_et2phantom_MoL(infile,dt_et,dtout) ! to grid call get_phantom_dt(dtout) - end subroutine step_et2phantom_MoL subroutine et2phantom_tmunu() @@ -291,9 +254,9 @@ subroutine phantom2et_rhostar() ! Get the conserved density on the particles dat = 0. pmass = massoftype(igas) - ! $omp parallel do default(none) & - ! $omp shared(npart,xyzh,dat,pmass) & - ! $omp private(i,h,rho) + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,dat,pmass) & + !$omp private(i,h,rho) do i=1, npart ! Get the smoothing length h = xyzh(4,i) @@ -302,7 +265,7 @@ subroutine phantom2et_rhostar() rho = rhoh(h,pmass) dat(i) = rho enddo - ! $omp end parallel do + !$omp end parallel do rhostargrid = 0. call interpolate_to_grid(rhostargrid,dat) @@ -389,9 +352,6 @@ subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) use fileutils, only:getnextfilename use tmunu2grid, only:check_conserved_dens real, intent(in) :: time, dt_et - !real(kind=16) :: cfac - !logical, intent(in), optional :: checkpoint - !integer, intent(in) :: checkpointno character(*),optional, intent(in) :: checkpointfile logical :: createcheckpoint @@ -416,15 +376,6 @@ subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) call write_fulldump(time,checkpointfile) endif - ! Quick and dirty write cfac to txtfile - - ! Density check vs particles -! call check_conserved_dens(rhostargrid,cfac) -! open(unit=777, file="cfac.txt", action='write', position='append') -! print*, time, cfac -! write(777,*) time, cfac -! close(unit=777) - end subroutine et2phantom_dumphydro ! Provides the RHS derivs for a particle at index i @@ -496,5 +447,4 @@ subroutine get_eos_quantities(densi,en) end subroutine get_eos_quantities - end module einsteintk_wrapper From c1873a793414eac7ddefda231af74de8d34300e4 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 10:05:10 +1000 Subject: [PATCH 398/814] (einsteintk) fix unused variable warning; remove obsolete cfac stuff --- src/main/tmunu2grid.f90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index 856ba55a7..db90dda00 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -19,7 +19,7 @@ module tmunu2grid implicit none contains -subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) +subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) use einsteintk_utils, only: dxgrid, gridorigin,gridsize,tmunugrid,rhostargrid use interpolations3D, only: interpolate3D,interpolate3D_vecexact use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax @@ -27,10 +27,8 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) integer, intent(in) :: npart real, intent(in) :: vxyzu(:,:), tmunus(:,:,:) real, intent(inout) :: xyzh(:,:) - logical, intent(in), optional :: calc_cfac real :: weight,h,rho,pmass real :: weights(npart) - real, save :: cfac real :: xmininterp(3) integer :: ngrid(3) real,allocatable :: datsmooth(:,:,:,:), dat(:,:) From 3faa5fa64fb98ec73e061fdd148cc900797d9a7b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 10:05:48 +1000 Subject: [PATCH 399/814] (build) remove obsolete MAXP specification in Makefile_setups --- build/Makefile_setups | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/build/Makefile_setups b/build/Makefile_setups index 85ccc0e0e..2e9769ea9 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -256,7 +256,6 @@ ifeq ($(SETUP), gwdisc) DISC_VISCOSITY=yes SETUPFILE= setup_gwdisc.f90 ANALYSIS= analysis_disc.f90 - MAXP=2000000 IND_TIMESTEPS=yes ISOTHERMAL=yes MULTIRUNFILE= multirun.f90 @@ -266,7 +265,6 @@ endif ifeq ($(SETUP), nshwdisc) # disc around a neutron star - FPPFLAGS= -DPRDRAG SETUPFILE= setup_nsdisc.f90 ANALYSIS= analysis_disc.f90 MODFILE= moddump_changemass.f90 @@ -290,7 +288,6 @@ ifeq ($(SETUP), binarydiscMFlow) SETUPFILE= setup_disc.f90 ANALYSIS= analysis_disc_MFlow.f90 # ANALYSIS= analysis_binarydisc.f90 - MAXP=1000000 ISOTHERMAL=yes CURLV=yes LIVE_ANALYSIS=no @@ -473,7 +470,6 @@ ifeq ($(SETUP), srshock) GR=yes METRIC=minkowski KNOWN_SETUP=yes - MAXP=900000 CONST_AV=yes endif @@ -481,7 +477,6 @@ ifeq ($(SETUP), testparticles) # test particles SETUPFILE= setup_testparticles.f90 KNOWN_SETUP=yes - MAXP=500000 ANALYSIS= analysis_1particle.f90 endif @@ -491,7 +486,6 @@ ifeq ($(SETUP), gr_testparticles) GR=yes METRIC=kerr KNOWN_SETUP=yes - MAXP=1000 ANALYSIS= analysis_1particle.f90 endif @@ -591,7 +585,6 @@ ifeq ($(SETUP), sedov) SETUPFILE= setup_sedov.f90 IND_TIMESTEPS=yes KNOWN_SETUP=yes - MAXP=2100000 endif ifeq ($(SETUP), srblast) @@ -688,7 +681,6 @@ ifeq ($(SETUP), mhdblast) PERIODIC=yes MHD=yes KNOWN_SETUP=yes - MAXP=3000000 endif ifeq ($(SETUP), mhdwave) @@ -697,7 +689,6 @@ ifeq ($(SETUP), mhdwave) PERIODIC=yes MHD=yes KNOWN_SETUP=yes - MAXP=3000000 endif ifeq ($(SETUP), cluster) @@ -710,7 +701,6 @@ ifeq ($(SETUP), cluster) IND_TIMESTEPS=yes KNOWN_SETUP=yes MAXPTMASS=1000 - MAXP=3500000 endif ifeq ($(SETUP), binary) From 1b0a3a5cca3b51af33f3ec9e7616d28ec6938cea Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 10:06:06 +1000 Subject: [PATCH 400/814] (setup_testparticles) fix typo in setup_testparticles --- src/setup/setup_testparticles.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_testparticles.f90 b/src/setup/setup_testparticles.f90 index edbd8ab47..fbc4f0410 100644 --- a/src/setup/setup_testparticles.f90 +++ b/src/setup/setup_testparticles.f90 @@ -100,7 +100,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, period = 0. if (gr) call prompt('black hole spin',spin,-1.,1.) - call prompt('select orbit type (1=cirlce, 2=precession, 3=epicycle, 4=vertical-oscillation, 0=custom)',orbtype,0,4) + call prompt('select orbit type (1=circle, 2=precession, 3=epicycle, 4=vertical-oscillation, 0=custom)',orbtype,0,4) select case(orbtype) case(1) ! circular From 87024a442360fbe3a38364e997ff76045adc392f Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 11:32:19 +1000 Subject: [PATCH 401/814] (externalforces) unused variable warning fixed --- src/main/externalforces.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/externalforces.f90 b/src/main/externalforces.f90 index 26c40eb92..134c4c84b 100644 --- a/src/main/externalforces.f90 +++ b/src/main/externalforces.f90 @@ -526,7 +526,7 @@ end subroutine update_vdependent_extforce_leapfrog !----------------------------------------------------------------------- subroutine update_externalforce(iexternalforce,ti,dmdt) use io, only:warn - use part, only:xyzh,vxyzu,massoftype,npartoftype,igas,npart,nptmass,& + use part, only:xyzh,vxyzu,igas,npart,nptmass,& xyzmh_ptmass,vxyz_ptmass use extern_gwinspiral, only:gw_still_inspiralling,get_gw_force use extern_binary, only:update_binary From a190dd27ddecb34b234da7d4d3ff7b8a7f7575d3 Mon Sep 17 00:00:00 2001 From: fhu Date: Thu, 11 Apr 2024 16:40:58 +1000 Subject: [PATCH 402/814] (moddump_radiotde) calculate u, s and p for ieos=12 --- src/utils/moddump_radiotde.f90 | 63 ++++++++++++++++++++++++++++++---- 1 file changed, 56 insertions(+), 7 deletions(-) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 5bea8c7ec..6f5475ac3 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -56,7 +56,8 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) use physcon, only:solarm,years,mass_proton_cgs,kb_on_mh,kboltz,radconst use setup_params, only:npart_total use part, only:igas,set_particle_type,pxyzu,delete_particles_inside_radius, & - delete_particles_outside_sphere,kill_particle,shuffle_part + delete_particles_outside_sphere,kill_particle,shuffle_part, & + eos_vars,itemp,igamma,igasP use io, only:fatal,master,id use units, only:umass,udist,utime,set_units,unit_density,unit_ergg use timestep, only:dtmax,tmax @@ -72,7 +73,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) real, intent(inout) :: massoftype(:) integer :: i,ierr,iunit=12,iprof integer :: np_sphere,npart_old - real :: totmass,delta,r + real :: totmass,delta,r,rhofr,presi character(len=120) :: fileset,fileprefix='radio' logical :: read_temp,setexists real, allocatable :: masstab(:),temp_prof(:) @@ -89,7 +90,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) !--Set default values temperature = 10. ! Temperature in Kelvin - mu = 2. ! mean molecular weight + mu = 1. ! mean molecular weight ieos_in = 2 ignore_radius = 1.e14 ! in cm use_func = .true. @@ -169,6 +170,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) endif ieos = ieos_in gmw = mu + write(*,'(a,1x,i2)') ' Using eos =', ieos !--Everything to code unit ignore_radius = ignore_radius/udist @@ -230,11 +232,17 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) do i = npart_old+1,npart call set_particle_type(i,igas) r = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) + rhofr = rhof(r) if (read_temp) temperature = get_temp_r(r,rad_prof,temp_prof) - vxyzu(4,i) = uerg(rhof(r),temperature) + vxyzu(4,i) = uerg(rhofr,temperature,ieos) vxyzu(1:3,i) = 0. ! stationary for now - pxyzu(4,i) = (kb_on_mh / mu * log(temperature**1.5/(rhof(r)*unit_density))) / kboltz/ unit_ergg + pxyzu(4,i) = entropy(rhofr,temperature,ieos) + pxyzu(1:3,i) = 0. + eos_vars(itemp,i) = temperature + presi = pressure(rhofr,temperature,ieos) + eos_vars(igamma,i) = 1. + presi/(rhofr*vxyzu(4,i)) enddo + if (ieos == 12) write(*,'(a,1x,f10.4)') ' Mean gamma =', sum(eos_vars(igamma,npart_old+1:npart))/(npart - npart_old) !--Set timesteps tmax = 3.*years/utime @@ -308,19 +316,60 @@ real function get_temp_r(r,rad_prof,temp_prof) end function get_temp_r -real function uerg(rho,T) +real function uerg(rho,T,ieos) use physcon, only:kb_on_mh,radconst use units, only:unit_density,unit_ergg real, intent(in) :: rho,T + integer, intent(in) :: ieos real :: ucgs_gas,ucgs_rad,rhocgs rhocgs = rho*unit_density ucgs_gas = 1.5*kb_on_mh*T/mu - ucgs_rad = 0. !radconst*T**4/rhocgs + if (ieos == 12) then + ucgs_rad = radconst*T**4/rhocgs + else + ucgs_rad = 0. !radconst*T**4/rhocgs + endif uerg = (ucgs_gas+ucgs_rad)/unit_ergg end function uerg +real function entropy(rho,T,ieos) + use physcon, only:kb_on_mh,radconst,kboltz + use units, only:unit_density,unit_ergg + real, intent(in) :: rho,T + integer, intent(in) :: ieos + real :: ent_gas,ent_rad,rhocgs + + rhocgs = rho*unit_density + ent_gas = kb_on_mh/mu*log(T**1.5/rhocgs) + if (ieos == 12) then + ent_rad = 4.*radconst*T**3/(3.*rhocgs) + else + ent_rad = 0. + endif + entropy = (ent_gas+ent_rad)/kboltz/ unit_ergg + +end function entropy + +real function pressure(rho,T,ieos) + use physcon, only:kb_on_mh,radconst + use units, only:unit_density,unit_pressure + real, intent(in) :: rho,T + integer, intent(in) :: ieos + real :: p_gas,p_rad,rhocgs + + rhocgs = rho*unit_density + p_gas = rhocgs*kb_on_mh*T/mu + if (ieos == 12) then + p_rad = radconst*T**4/3. + else + p_rad = 0. + endif + pressure = (p_gas+p_rad)/ unit_pressure + +end function pressure + subroutine calc_rhobreak() integer :: i From 7cd0cfac3e27ba47507ef45f922d34cd19e62b86 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 11 Apr 2024 18:12:42 +1000 Subject: [PATCH 403/814] beginning of the step extern routine to get a more general pattern --- src/main/step_extern.F90 | 238 ++++++++++++++++++++++++--------------- 1 file changed, 145 insertions(+), 93 deletions(-) diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 69fb57ccb..d2ee2a819 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -848,6 +848,138 @@ subroutine get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce, end subroutine get_gradf_extrap_4th + +! NOTE: The chemistry and cooling here is implicitly calculated. That is, +! dt is *passed in* to the chemistry & cooling routines so that the +! output will be at the correct time of time + dt. Since this is +! implicit, there is no cooling timestep. Explicit cooling is +! calculated in force and requires a cooling timestep. + +subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,idK2,idmu,idkappa, & + idgamma,imu,igamma,nabn,dphotflag,nabundances) + use dim, only:h2chemistry,do_nucleation,use_krome,update_muGamma,store_dust_temperature + use options, only:icooling + use chem, only:update_abundances,get_dphot + use dust_formation, only:evolve_dust + use cooling, only:energ_cooling,cooling_in_step + use part, only:rhoh +#ifdef KROME + use part, only: T_gas_cool + use krome_interface, only: update_krome +#endif + real, intent(inout) :: vxyzu(:,:),xyzh(:,:) + real, intent(inout) :: eos_vars(:,:),abundance(:,:) + real, intent(inout) :: nucleation(:,:),dust_temp(:) + real(kind=4), intent(in) :: divcurlv(:,:) + real, intent(inout) :: abundc,abunde,abundo,abundsi + real, intent(in) :: dt,dphot0,pmassi + integer, intent(in) :: idK2,idmu,idkappa,idgamma,imu,igamma + integer, intent(in) :: i,nabn,dphotflag,nabundances + + real :: dudtcool,rhoi,ui,dphot + real :: abundi(nabn) + + dudtcool = 0. + rhoi = rhoh(xyzh(4,i),pmassi) + ! + ! CHEMISTRY + ! + if (h2chemistry) then + ! + ! Get updated abundances of all species, updates 'chemarrays', + ! + dphot = get_dphot(dphotflag,dphot0,xyzh(1,i),xyzh(2,i),xyzh(3,i)) + call update_abundances(vxyzu(4,i),rhoi,abundance(:,i),nabundances,& + dphot,dt,abundi,nabn,eos_vars(imu,i),abundc,abunde,abundo,abundsi) + endif +#ifdef KROME + ! evolve chemical composition and determine new internal energy + ! Krome also computes cooling function but only associated with chemical processes + ui = vxyzu(4,i) + call update_krome(dt,xyzh(:,i),ui,rhoi,abundance(:,i),eos_vars(igamma,i),eos_vars(imu,i),T_gas_cool(i)) + dudtcool = (ui-vxyzu(4,i))/dt +#else + !evolve dust chemistry and compute dust cooling + if (do_nucleation) then + call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) + eos_vars(imu,i) = nucleation(idmu,i) + eos_vars(igamma,i) = nucleation(idgamma,i) + endif + ! + ! COOLING + ! + if (icooling > 0 .and. cooling_in_step) then + if (h2chemistry) then + ! + ! Call cooling routine, requiring total density, some distance measure and + ! abundances in the 'abund' format + ! + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i),abund_in=abundi) + elseif (store_dust_temperature) then + ! cooling with stored dust temperature + if (do_nucleation) then + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) + elseif (update_muGamma) then + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i)) + 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 + 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) + endif + endif +#endif + ! update internal energy + if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool + + +end subroutine cooling_abundances_update + + + +subroutine external_force_update(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew,dtf,dt, & + fextx,fexty,fextz,extf_is_velocity_dependent,iexternalforce) + use timestep, only:C_force + use externalforces, only: externalforce,update_vdependent_extforce_leapfrog + real, intent(in) :: xi,yi,zi,hi,vxi,vyi,vzi,timei,dt + real, intent(inout) :: dtextforcenew,dtf,fextx,fexty,fextz + integer, intent(in) :: iexternalforce,i + logical, intent(in) :: extf_is_velocity_dependent + real :: fextxi,fextyi,fextzi,poti + real :: fextv(3) + + call externalforce(iexternalforce,xi,yi,zi,hi, & + timei,fextxi,fextyi,fextzi,poti,dtf,i) + dtextforcenew = min(dtextforcenew,C_force*dtf) + + fextx = fextx + fextxi + fexty = fexty + fextyi + fextz = fextz + fextzi +! +! Velocity-dependent external forces require special handling +! in leapfrog (corrector is implicit) +! + if (extf_is_velocity_dependent) then + fextxi = fextx + fextyi = fexty + fextzi = fextz + call update_vdependent_extforce_leapfrog(iexternalforce,vxi,vyi,vzi, & + fextxi,fextyi,fextzi,fextv,dt,xi,yi,zi) + fextx = fextx + fextv(1) + fexty = fexty + fextv(2) + fextz = fextz + fextv(3) + endif + + +end subroutine external_force_update + + + !---------------------------------------------------------------- !+ ! Substepping of external and sink particle forces. @@ -869,7 +1001,7 @@ subroutine step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,ti idvxmsi,idvymsi,idvzmsi,idfxmsi,idfymsi,idfzmsi, & ndptmass,update_ptmass use options, only:iexternalforce,icooling - use part, only:maxphase,abundance,nabundances,eos_vars,epot_sinksink,eos_vars,& + use part, only:maxphase,abundance,nabundances,epot_sinksink,eos_vars,& isdead_or_accreted,iamboundary,igas,iphase,iamtype,massoftype,rhoh,divcurlv, & fxyz_ptmass_sinksink,dsdt_ptmass_sinksink,dust_temp,tau,& nucleation,idK2,idmu,idkappa,idgamma,imu,igamma @@ -1011,8 +1143,7 @@ subroutine step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,ti #ifdef KROME !$omp shared(T_gas_cool) & #endif - !$omp reduction(+:accretedmass) & - !$omp reduction(min:dtextforcenew,dtsinkgas,dtphi2) & + !$omp reduction(min:dtextforcenew,dtphi2) & !$omp reduction(max:fonrmax) & !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) !$omp do @@ -1051,103 +1182,24 @@ subroutine step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,ti ! compute and add external forces ! if (iexternalforce > 0) then - call externalforce(iexternalforce,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i), & - timei,fextxi,fextyi,fextzi,poti,dtf,i) - dtextforcenew = min(dtextforcenew,C_force*dtf) - - fextx = fextx + fextxi - fexty = fexty + fextyi - fextz = fextz + fextzi - ! - ! Velocity-dependent external forces require special handling - ! in leapfrog (corrector is implicit) - ! - if (extf_is_velocity_dependent) then - vxhalfi = vxyzu(1,i) - vyhalfi = vxyzu(2,i) - vzhalfi = vxyzu(3,i) - fxi = fextx - fyi = fexty - fzi = fextz - call update_vdependent_extforce_leapfrog(iexternalforce,& - vxhalfi,vyhalfi,vzhalfi, & - fxi,fyi,fzi,fextv,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i)) - fextx = fextx + fextv(1) - fexty = fexty + fextv(2) - fextz = fextz + fextv(3) - endif + call external_force_update(xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i), & + vxyzu(1,i),vxyzu(1,i),vxyzu(1,i),timei,i, & + dtextforcenew,dtf,dt,fextx,fexty,fextz, & + extf_is_velocity_dependent,iexternalforce) endif + if (idamp > 0) then call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), xyzh(1:3,i), damp_fac) endif - fext(1,i) = fextx - fext(2,i) = fexty - fext(3,i) = fextz if (maxvxyzu >= 4 .and. itype==igas) then - ! NOTE: The chemistry and cooling here is implicitly calculated. That is, - ! dt is *passed in* to the chemistry & cooling routines so that the - ! output will be at the correct time of time + dt. Since this is - ! implicit, there is no cooling timestep. Explicit cooling is - ! calculated in force and requires a cooling timestep. - - dudtcool = 0. - rhoi = rhoh(xyzh(4,i),pmassi) - ! - ! CHEMISTRY - ! - if (h2chemistry) then - ! - ! Get updated abundances of all species, updates 'chemarrays', - ! - dphot = get_dphot(dphotflag,dphot0,xyzh(1,i),xyzh(2,i),xyzh(3,i)) - call update_abundances(vxyzu(4,i),rhoi,abundance(:,i),nabundances,& - dphot,dt,abundi,nabn,eos_vars(imu,i),abundc,abunde,abundo,abundsi) - endif -#ifdef KROME - ! evolve chemical composition and determine new internal energy - ! Krome also computes cooling function but only associated with chemical processes - ui = vxyzu(4,i) - call update_krome(dt,xyzh(:,i),ui,rhoi,abundance(:,i),eos_vars(igamma,i),eos_vars(imu,i),T_gas_cool(i)) - dudtcool = (ui-vxyzu(4,i))/dt -#else - !evolve dust chemistry and compute dust cooling - if (do_nucleation) then - call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) - eos_vars(imu,i) = nucleation(idmu,i) - eos_vars(igamma,i) = nucleation(idgamma,i) - endif - ! - ! COOLING - ! - if (icooling > 0 .and. cooling_in_step) then - if (h2chemistry) then - ! - ! Call cooling routine, requiring total density, some distance measure and - ! abundances in the 'abund' format - ! - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i),abund_in=abundi) - elseif (store_dust_temperature) then - ! cooling with stored dust temperature - if (do_nucleation) then - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) - elseif (update_muGamma) then - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i)) - 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 - 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) - endif - endif -#endif - ! update internal energy - if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool + call cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,idK2,idmu,idkappa, & + idgamma,imu,igamma,nabn,dphotflag,nabundances) endif + fext(1,i) = fextx + fext(2,i) = fexty + fext(3,i) = fextz endif enddo predictor !$omp enddo From 2c802a94a0cc8e48e54403ec9f118b93a6447622 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 11 Apr 2024 12:24:19 +0100 Subject: [PATCH 404/814] restoring upstream changes part 3 --- src/main/checksetup.f90 | 2 +- src/main/eos.F90 | 2 +- src/main/evwrite.f90 | 500 ++ src/main/extern_binary_gw.f90 | 2 +- src/main/extern_densprofile.f90 | 2 +- src/main/extern_gr.f90 | 411 ++ src/main/extern_gwinspiral.f90 | 2 +- src/main/extern_lensethirring.f90 | 2 +- src/main/extern_spiral.f90 | 2 +- src/main/extern_staticsine.f90 | 2 +- ...{externalforces.F90 => externalforces.f90} | 6 +- ...nalforces_gr.F90 => externalforces_gr.f90} | 4 +- src/main/fastmath.f90 | 2 +- src/main/force.F90 | 2 +- src/main/forcing.F90 | 30 +- src/main/fs_data.f90 | 2 +- src/main/geometry.f90 | 2 +- src/main/gitinfo.f90 | 2 +- src/main/growth_smol.f90 | 2 +- src/main/h2chem.f90 | 4 +- src/main/inject_BHL.f90 | 17 +- src/main/inject_bondi.f90 | 10 +- src/main/inject_firehose.f90 | 9 +- src/main/inject_galcen_winds.f90 | 10 +- src/main/inject_keplerianshear.f90 | 29 +- src/main/inject_rochelobe.f90 | 10 +- src/main/inject_sne.f90 | 10 +- src/main/inject_unifwind.f90 | 10 +- src/main/{inject_wind.F90 => inject_wind.f90} | 0 src/main/inverse4x4.f90 | 2 +- src/main/io.F90 | 2 +- src/main/ionization.f90 | 2 +- src/main/kernel_WendlandC2.f90 | 2 +- src/main/kernel_WendlandC4.f90 | 2 +- src/main/kernel_WendlandC6.f90 | 2 +- src/main/kernel_cubic.f90 | 2 +- src/main/kernel_quartic.f90 | 2 +- src/main/kernel_quintic.f90 | 2 +- src/main/krome.f90 | 2 +- src/main/linklist_kdtree.F90 | 4 +- src/main/lumin_nsdisc.f90 | 12 +- src/main/memory.f90 | 16 +- src/main/metric_kerr-schild.f90 | 2 +- src/main/metric_kerr.f90 | 2 +- src/main/metric_minkowski.f90 | 2 +- src/main/metric_schwarzschild.f90 | 2 +- src/main/metric_tools.F90 | 2 +- src/main/mf_write.f90 | 2 +- src/main/mol_data.f90 | 2 +- src/main/mpi_balance.F90 | 36 +- src/main/mpi_dens.F90 | 2 +- src/main/mpi_derivs.F90 | 2 +- src/main/mpi_domain.F90 | 4 +- src/main/mpi_force.F90 | 2 +- src/main/mpi_memory.F90 | 2 +- src/main/mpi_memory.f90 | 317 ++ src/main/mpi_tree.F90 | 2 +- src/main/mpi_utils.F90 | 2 +- src/main/nicil_supplement.F90 | 2 +- src/main/nicil_supplement.f90 | 236 + src/main/options.f90 | 3 +- src/main/part.F90 | 40 +- src/main/phantom.F90 | 2 +- src/main/photoevap.f90 | 432 -- src/main/physcon.f90 | 2 +- ...{ptmass_heating.F90 => ptmass_heating.f90} | 0 ...ass_radiation.F90 => ptmass_radiation.f90} | 2 +- src/main/quitdump.f90 | 2 +- src/main/radiation_utils.f90 | 2 +- src/main/random.f90 | 2 +- src/main/readwrite_dumps.F90 | 7 +- src/main/readwrite_dumps_fortran.F90 | 158 +- src/main/step_leapfrog.F90 | 143 +- src/utils/analysis_BRhoOrientation.F90 | 2 +- src/utils/analysis_clumpfind.F90 | 2 +- src/utils/analysis_clumpfindWB23.F90 | 2 +- src/utils/analysis_common_envelope.F90 | 4594 ----------------- src/utils/analysis_dustywind.F90 | 348 -- src/utils/analysis_kdtree.F90 | 2 +- src/utils/analysis_protostar_environ.F90 | 2 +- src/utils/analysis_write_kdtree.F90 | 2 +- src/utils/interpolate3D_amr.F90 | 2 +- src/utils/struct_part.F90 | 269 - src/utils/utils_getneighbours.F90 | 2 +- src/utils/utils_raytracer_all.F90 | 1199 ----- 85 files changed, 1823 insertions(+), 7159 deletions(-) create mode 100644 src/main/evwrite.f90 create mode 100644 src/main/extern_gr.f90 rename src/main/{externalforces.F90 => externalforces.f90} (99%) rename src/main/{externalforces_gr.F90 => externalforces_gr.f90} (99%) rename src/main/{inject_wind.F90 => inject_wind.f90} (100%) create mode 100644 src/main/mpi_memory.f90 create mode 100644 src/main/nicil_supplement.f90 delete mode 100644 src/main/photoevap.f90 rename src/main/{ptmass_heating.F90 => ptmass_heating.f90} (100%) rename src/main/{ptmass_radiation.F90 => ptmass_radiation.f90} (99%) delete mode 100644 src/utils/analysis_common_envelope.F90 delete mode 100644 src/utils/analysis_dustywind.F90 delete mode 100644 src/utils/struct_part.F90 delete mode 100644 src/utils/utils_raytracer_all.F90 diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index e4e0c17cd..a14201b96 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -996,7 +996,7 @@ subroutine check_setup_radiation(npart,nerror,nwarn,radprop,rad) call check_NaN(npart,rad,'radiation_energy',nerror) call check_NaN(npart,radprop,'radiation properties',nerror) - + end subroutine check_setup_radiation end module checksetup diff --git a/src/main/eos.F90 b/src/main/eos.F90 index 9204baaf0..e90d18aeb 100644 --- a/src/main/eos.F90 +++ b/src/main/eos.F90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos ! diff --git a/src/main/evwrite.f90 b/src/main/evwrite.f90 new file mode 100644 index 000000000..8c8e5b76f --- /dev/null +++ b/src/main/evwrite.f90 @@ -0,0 +1,500 @@ +!--------------------------------------------------------------------------! +! 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 evwrite +! +! Calculates conserved quantities etc and writes to .ev file; +! Also writes log output +! To Developer: To add values to the .ev file, follow the following procedure. +! In the init_evfile subroutine in evwrite.F90, add the following command: +! call fill_ev_label(ev_fmt,ev_tag_int,ev_tag_char,action,i,j) +! and in compute_energies subroutine in energies.F90, add the following command: +! call ev_data_update(ev_data_thread,ev_tag_int,value) +! where +! ev_fmt,ev_data_thread,i,j: pre-defined quantities to included verbatim +! ev_tag_char: a string to identify the quantity for use in the header +! (e.g. 'c_s' for sound speed) +! ev_tag_int: an integer to identify the quantity (e.g. 'iev_cs' for sound speed); +! this integer must be included in energies (as a public variable, +! and in the openmp declarations), and passed to evwrite via use energies. +! ev_value: the value of the quantity for particle i (e.g., spsoundi for sound speed) +! action: a string identifying what action(s) you would like performed +! on the quantity. The available options are +! 0: no action taken (e.g. for time) +! s: sum quantity (e.g. for entropy) +! x: print the maximum quantity +! a: print the average (mean) quantity +! n: print the minimum quantity +! where any or all of x,a,n can be used as a single action. Although 0 & s are treated +! the same, they are kept separate for clarity without added computational cost +! +! :References: None +! +! :Owner: James Wurster +! +! :Runtime parameters: None +! +! :Dependencies: boundary, boundary_dyn, dim, energies, eos, +! externalforces, fileutils, gravwaveutils, io, mpiutils, nicil, options, +! part, ptmass, timestep, units, viscosity +! + use io, only:fatal,iverbose + use options, only:iexternalforce + use timestep, only:dtmax_dratio + use externalforces, only:iext_binary,was_accreted + use energies, only:inumev,iquantities,ev_data + use energies, only:ndead,npartall + use energies, only:gas_only,track_mass,track_lum + use energies, only:iev_sum,iev_max,iev_min,iev_ave + use energies, only:iev_time,iev_ekin,iev_etherm,iev_emag,iev_epot,iev_etot,iev_totmom,iev_com,& + iev_angmom,iev_rho,iev_dt,iev_dtx,iev_entrop,iev_rmsmach,iev_vrms,iev_rhop,iev_alpha,& + iev_B,iev_divB,iev_hdivB,iev_beta,iev_temp,iev_etao,iev_etah,& + iev_etaa,iev_vel,iev_vhall,iev_vion,iev_n,& + iev_dtg,iev_ts,iev_dm,iev_momall,iev_angall,iev_angall,iev_maccsink,& + iev_macc,iev_eacc,iev_totlum,iev_erot,iev_viscrat,iev_erad,iev_gws,iev_mass,iev_bdy + + implicit none + public :: init_evfile, write_evfile, write_evlog + private :: fill_ev_tag, fill_ev_header + + integer, private :: ielements + integer, private :: ev_cmd(inumev) ! array of the actions to be taken + character(len=19),private :: ev_label(inumev) ! to make the header for the .ev file + + private + +contains + +!---------------------------------------------------------------- +!+ +! opens the .ev file for output +!+ +!---------------------------------------------------------------- +subroutine init_evfile(iunit,evfile,open_file) + use io, only:id,master,warning + use dim, only:maxtypes,maxalpha,maxp,maxp_hard,mhd,mhd_nonideal,lightcurve + use options, only:calc_erot,ishock_heating,ipdv_heating,use_dustfrac + use units, only:c_is_unity + use part, only:igas,idust,iboundary,istar,idarkmatter,ibulge,npartoftype,ndusttypes,maxtypes + use nicil, only:use_ohm,use_hall,use_ambi + use viscosity, only:irealvisc + use mpiutils, only:reduceall_mpi + use eos, only:ieos,eos_is_non_ideal,eos_outputs_gasP + use gravwaveutils, only:calc_gravitwaves + use boundary_dyn, only:dynamic_bdy + integer, intent(in) :: iunit + character(len= *), intent(in) :: evfile + logical, intent(in) :: open_file + character(len= 27) :: ev_fmt + character(len= 11) :: dustname + integer :: i,j,k + integer(kind=8) :: npartoftypetot(maxtypes) + ! + !--Initialise additional variables + ! + npartoftypetot = reduceall_mpi('+', npartoftype) + gas_only = .true. + do i = 2,maxtypes + if (npartoftypetot(i) > 0) gas_only = .false. + enddo + write(ev_fmt,'(a)') "(1x,'[',i2.2,1x,a11,']',2x)" + ! + !--Define all the variables to be included in the .ev file and their supplementary information + ! + i = 1 + j = 1 + call fill_ev_tag(ev_fmt,iev_time, 'time', '0', i,j) + call fill_ev_tag(ev_fmt,iev_ekin, 'ekin', '0', i,j) + call fill_ev_tag(ev_fmt,iev_etherm, 'etherm', '0', i,j) + call fill_ev_tag(ev_fmt,iev_emag, 'emag', '0', i,j) + call fill_ev_tag(ev_fmt,iev_epot, 'epot', '0', i,j) + call fill_ev_tag(ev_fmt,iev_etot, 'etot', '0', i,j) + call fill_ev_tag(ev_fmt,iev_erad, 'erad', '0', i,j) + call fill_ev_tag(ev_fmt,iev_totmom, 'totmom', '0', i,j) + call fill_ev_tag(ev_fmt,iev_angmom, 'angtot', '0', i,j) + call fill_ev_tag(ev_fmt,iev_rho, 'rho', 'xa',i,j) + call fill_ev_tag(ev_fmt,iev_dt, 'dt', '0', i,j) + if (dtmax_dratio > 0.) then + call fill_ev_tag(ev_fmt,iev_dtx, 'dtmax', '0', i,j) + endif + if (maxp==maxp_hard) then + call fill_ev_tag(ev_fmt,iev_mass,'mass', '0', i,j) + endif + call fill_ev_tag(ev_fmt,iev_entrop, 'totentrop','s', i,j) + call fill_ev_tag(ev_fmt,iev_rmsmach,'rmsmach', '0', i,j) + call fill_ev_tag(ev_fmt,iev_vrms, 'vrms', '0', i,j) + call fill_ev_tag(ev_fmt,iev_com(1), 'xcom', '0', i,j) + call fill_ev_tag(ev_fmt,iev_com(2), 'ycom', '0', i,j) + call fill_ev_tag(ev_fmt,iev_com(3), 'zcom', '0', i,j) + if (.not. gas_only) then + if (npartoftypetot(igas) > 0) call fill_ev_tag(ev_fmt,iev_rhop(1),'rho gas', 'xa',i,j) + if (npartoftypetot(idust) > 0) call fill_ev_tag(ev_fmt,iev_rhop(2),'rho dust','xa',i,j) + if (npartoftypetot(iboundary) > 0) call fill_ev_tag(ev_fmt,iev_rhop(3),'rho bdy', 'xa',i,j) + if (npartoftypetot(istar) > 0) call fill_ev_tag(ev_fmt,iev_rhop(4),'rho star','xa',i,j) + if (npartoftypetot(idarkmatter) > 0) call fill_ev_tag(ev_fmt,iev_rhop(5),'rho dm', 'xa',i,j) + if (npartoftypetot(ibulge) > 0) call fill_ev_tag(ev_fmt,iev_rhop(6),'rho blg', 'xa',i,j) + endif + if (maxalpha==maxp) then + call fill_ev_tag(ev_fmt, iev_alpha, 'alpha', 'x', i,j) + endif + if (eos_is_non_ideal(ieos) .or. eos_outputs_gasP(ieos)) then + call fill_ev_tag(ev_fmt, iev_temp, 'temp', 'xan',i,j) + endif + if ( mhd ) then + call fill_ev_tag(ev_fmt, iev_B, 'B', 'xan',i,j) + call fill_ev_tag(ev_fmt, iev_divB, 'divB', 'xa' ,i,j) + call fill_ev_tag(ev_fmt, iev_hdivB, 'hdivB/B','xa' ,i,j) + call fill_ev_tag(ev_fmt, iev_beta, 'beta_P', 'xan',i,j) + if (mhd_nonideal) then + if (use_ohm) then + call fill_ev_tag(ev_fmt,iev_etao, 'eta_o', 'xan',i,j) + endif + if (use_hall) then + call fill_ev_tag(ev_fmt,iev_etah(1),'eta_h', 'xan',i,j) + call fill_ev_tag(ev_fmt,iev_etah(2),'|eta_h|', 'xan',i,j) + call fill_ev_tag(ev_fmt,iev_vhall, 'v_hall', 'xan',i,j) + endif + if (use_ambi) then + call fill_ev_tag(ev_fmt,iev_etaa, 'eta_a', 'xan',i,j) + call fill_ev_tag(ev_fmt,iev_vel, 'velocity', 'xan',i,j) + call fill_ev_tag(ev_fmt,iev_vion, 'v_ion', 'xan',i,j) + endif + call fill_ev_tag(ev_fmt, iev_n(1), 'ni/n(i+n)','xan',i,j) + call fill_ev_tag(ev_fmt, iev_n(2), 'ne/n(i+n)','xan',i,j) + call fill_ev_tag(ev_fmt, iev_n(3), 'n_e', 'xa', i,j) + call fill_ev_tag(ev_fmt, iev_n(4), 'n_n', 'xa', i,j) + call fill_ev_tag(ev_fmt, iev_n(5), 'n_g(Z=-1)','xa', i,j) + call fill_ev_tag(ev_fmt, iev_n(6), 'n_g(Z= 0)','xa', i,j) + call fill_ev_tag(ev_fmt, iev_n(7), 'n_g(Z=+1)','xa', i,j) + endif + endif + if (use_dustfrac) then + call fill_ev_tag(ev_fmt, iev_dtg,'dust/gas', 'xan',i,j) + call fill_ev_tag(ev_fmt, iev_ts, 't_s', 'xn', i,j) + do k=1,ndusttypes + write(dustname,'(a,I3)') 'DustMass',k + call fill_ev_tag(ev_fmt,iev_dm(k), dustname, '0', i,j) + enddo + endif + if (iexternalforce > 0) then + call fill_ev_tag(ev_fmt, iev_momall,'totmomall', '0',i,j) + call fill_ev_tag(ev_fmt, iev_angall,'angall', '0',i,j) + if (iexternalforce==iext_binary) then + call fill_ev_tag(ev_fmt,iev_maccsink(1),'Macc sink 1', '0',i,j) + call fill_ev_tag(ev_fmt,iev_maccsink(2),'Macc sink 2', '0',i,j) + endif + endif + if (was_accreted(iexternalforce,-1.0)) then + call fill_ev_tag(ev_fmt,iev_macc, 'accretedmas', 's',i,j) + call fill_ev_tag(ev_fmt,iev_eacc, 'eacc', '0',i,j) + track_mass = .true. + else + track_mass = .false. + endif + if (ishock_heating==0 .or. ipdv_heating==0 .or. lightcurve) then + call fill_ev_tag(ev_fmt,iev_totlum,'tot lum', '0',i,j) + track_lum = .true. + else + track_lum = .false. + endif + if (calc_erot) then + call fill_ev_tag(ev_fmt,iev_erot(1),'erot_x', 's',i,j) + call fill_ev_tag(ev_fmt,iev_erot(2),'erot_y', 's',i,j) + call fill_ev_tag(ev_fmt,iev_erot(3),'erot_z', 's',i,j) + call fill_ev_tag(ev_fmt,iev_erot(4),'erot', '0',i,j) + endif + if (irealvisc /= 0) then + call fill_ev_tag(ev_fmt,iev_viscrat,'visc_rat','xan',i,j) + endif + + if (calc_gravitwaves) then + call fill_ev_tag(ev_fmt,iev_gws(1),'hx_0','0',i,j) + call fill_ev_tag(ev_fmt,iev_gws(2),'hp_0','0',i,j) + call fill_ev_tag(ev_fmt,iev_gws(3),'hx_{30}','0',i,j) + call fill_ev_tag(ev_fmt,iev_gws(4),'hp_{30}','0',i,j) + call fill_ev_tag(ev_fmt,iev_gws(5),'hx_{60}','0',i,j) + call fill_ev_tag(ev_fmt,iev_gws(6),'hp_{60}','0',i,j) + call fill_ev_tag(ev_fmt,iev_gws(7),'hx_{90}','0',i,j) + call fill_ev_tag(ev_fmt,iev_gws(8),'hp_{90}','0',i,j) + endif + if (dynamic_bdy) then + call fill_ev_tag(ev_fmt,iev_bdy(1,1),'min_x','0',i,j) + call fill_ev_tag(ev_fmt,iev_bdy(1,2),'max_x','0',i,j) + call fill_ev_tag(ev_fmt,iev_bdy(2,1),'min_y','0',i,j) + call fill_ev_tag(ev_fmt,iev_bdy(2,2),'max_y','0',i,j) + call fill_ev_tag(ev_fmt,iev_bdy(3,1),'min_z','0',i,j) + call fill_ev_tag(ev_fmt,iev_bdy(3,2),'max_z','0',i,j) + endif + iquantities = i - 1 ! The number of different quantities to analyse + ielements = j - 1 ! The number of values to be calculated (i.e. the number of columns in .ve) + ! + !--all threads do above, but only master writes file + ! (the open_file is to prevent an .ev file from being made during the test suite) + ! + if (open_file .and. id == master) then + ! + !--open the file for output + ! + open(unit=iunit,file=evfile,form='formatted',status='replace') + ! + !--write a header line + ! + write(ev_fmt,'(a,I3,a)') '(',ielements+1,'a)' + write(iunit,ev_fmt)'#',ev_label(1:ielements) + endif + +end subroutine init_evfile + +!---------------------------------------------------------------- +!+ +! creates up to three lables per input value, and fills the required +! tracking arrays; this includes a check to verify the actions are legal +!+ +!---------------------------------------------------------------- +subroutine fill_ev_tag(ev_fmt,itag,label,cmd,i,j) + integer, intent(inout) :: i,j + integer, intent(out) :: itag + character(len=*), intent(in) :: ev_fmt,label,cmd + integer :: ki,kj,iindex,joffset + + ! initialise command + itag = i + joffset = 1 + ev_cmd(i) = 0 + ! + ! make the headers & set ev_cmd + if (index(cmd,'0') > 0) call fill_ev_header(ev_fmt,label,'0',j,joffset) + if (index(cmd,'s') > 0) call fill_ev_header(ev_fmt,label,'s',j,joffset) + if (index(cmd,'x') > 0) then + call fill_ev_header(ev_fmt,label,'x',j,joffset) + ev_cmd(i) = ev_cmd(i) + 1 + joffset = joffset + 1 + endif + if (index(cmd,'a') > 0) then + call fill_ev_header(ev_fmt,label,'a',j,joffset) + ev_cmd(i) = ev_cmd(i) + 2 + joffset = joffset + 1 + endif + if (index(cmd,'n') > 0) then + call fill_ev_header(ev_fmt,label,'n',j,joffset) + ev_cmd(i) = ev_cmd(i) + 5 + endif + i = i + 1 + j = j + len(trim(cmd)) + ! + ! verify action command is legal + if ( (index(cmd,'x') > 0) .or. (index(cmd,'a') > 0) .or. (index(cmd,'n') > 0) ) then + iindex = 1 + else + iindex = 0 + endif + if ( index(cmd,'0') + index(cmd,'s') + iindex > 1) & + call fatal('fill_ev_tag','using an invalid sequence of actions for element', var=cmd) + do ki = 1,len(cmd)-1 + do kj = ki+1,len(cmd) + if ( cmd(ki:ki)==cmd(kj:kj) ) then + call fatal('fill_ev_tag','using duplicate actions for the same quantity', var=cmd) + endif + enddo + enddo + +end subroutine fill_ev_tag +!---------------------------------------------------------------- +!+ +! Fill an array to be used for the header of the .ev file +!+ +!---------------------------------------------------------------- +subroutine fill_ev_header(ev_fmt,label,cxmn,j,joffset) + integer, intent(in) :: j,joffset + character(len=* ), intent(in) :: ev_fmt,label + character(len= 1), intent(in) :: cxmn + character(len=11) :: label0 + character(len= 3) :: ext + integer :: j_actual + + if (len(label)>11 .and. (cxmn=='0' .or. cxmn=='s') ) then + label0 = label(1:11) + elseif (len(label)>9 .and. (cxmn=='x' .or. cxmn=='a' .or. cxmn=='n')) then + label0 = label(1:9) + else + label0 = label + endif + ext = "" + if (len(label)<=7) then + if (cxmn=='x') ext = "max" + if (cxmn=='a') ext = "ave" + if (cxmn=='n') ext = "min" + elseif (len(label)<=9) then + if (cxmn=='x') ext = "X" + if (cxmn=='a') ext = "A" + if (cxmn=='n') ext = "N" + endif + if (ext/="") write(label0,'(a,1x,a)')trim(label0),trim(ext); + ! + j_actual = j + joffset - 1 + if (j_actual > 99) then + write(ev_label(j_actual),ev_fmt) 100-j_actual,trim(label0) + else + write(ev_label(j_actual),ev_fmt) j_actual,trim(label0) + endif + +end subroutine fill_ev_header +!---------------------------------------------------------------- +!+ +! calculates total energy, etc, and writes line to .ev file +!+ +!---------------------------------------------------------------- +subroutine write_evfile(t,dt) + use energies, only:compute_energies,ev_data_update + use io, only:id,master,ievfile + use timestep, only:dtmax_user + use options, only:iexternalforce + use externalforces,only:accretedmass1,accretedmass2 + real, intent(in) :: t,dt + integer :: i,j + real :: ev_data_out(ielements) + character(len=35) :: ev_format + + call compute_energies(t) + + if (id==master) then + !--fill in additional details that are not calculated in energies.f + ev_data(iev_sum,iev_dt) = dt + ev_data(iev_sum,iev_dtx) = dtmax_user + if (iexternalforce==iext_binary) then + ev_data(iev_sum,iev_maccsink(1)) = accretedmass1 + ev_data(iev_sum,iev_maccsink(2)) = accretedmass2 + endif + ! Fill in the data_out array + j = 1 + do i = 1,iquantities + if (ev_cmd(i)==0) then + ! include the total value + ev_data_out(j) = ev_data(iev_sum,i) + j = j + 1 + else + if (ev_cmd(i)==1 .or. ev_cmd(i)==3 .or. ev_cmd(i)==6 .or. ev_cmd(i)==8) then + ! include the maximum value + ev_data_out(j) = ev_data(iev_max,i) + j = j + 1 + endif + if (ev_cmd(i)==2 .or. ev_cmd(i)==3 .or. ev_cmd(i)==7 .or. ev_cmd(i)==8) then + ! include the average value + ev_data_out(j) = ev_data(iev_ave,i) + j = j + 1 + endif + if (ev_cmd(i)==5 .or. ev_cmd(i)==6 .or. ev_cmd(i)==7 .or. ev_cmd(i)==8) then + ! include the minimum value + ev_data_out(j) = ev_data(iev_min,i) + j = j + 1 + endif + endif + enddo + ! + !--write line to .ev file (should correspond to header, below) + ! + write(ev_format,'(a,I3,a)')"(",ielements,"(1pe18.10,1x))" + write(ievfile,ev_format) ev_data_out + call flush(ievfile) + endif + +end subroutine write_evfile +!---------------------------------------------------------------- +!+ +! Writes nicely formatted output to the log file/screen +! Must be called *after* a call to compute energies has been +! performed +!+ +!---------------------------------------------------------------- +subroutine write_evlog(iprint) + use dim, only:maxp,maxalpha,mhd,maxvxyzu,periodic,mhd_nonideal,& + use_dust,maxdusttypes,do_radiation,inject_parts + use energies, only:ekin,etherm,emag,epot,etot,rmsmach,vrms,accretedmass,mdust,mgas,xyzcom + use energies, only:erad + use part, only:nptmass,ndusttypes + use viscosity, only:irealvisc,shearparam + use boundary, only:dxbound,dybound,dzbound + use units, only:unit_density + use options, only:use_dustfrac + use fileutils, only:make_tags_unique + use ptmass, only:icreate_sinks + integer, intent(in) :: iprint + character(len=120) :: string,Mdust_label(maxdusttypes) + integer :: i + + if (ndead > 0 .or. nptmass > 0 .or. icreate_sinks > 0 .or. inject_parts .or. iverbose > 0) then + write(iprint,"(1x,4(a,I10))") 'npart=',npartall,', n_alive=',npartall-ndead, & + ', n_dead_or_accreted=',ndead,', nptmass=',nptmass + endif + + write(iprint,"(1x,3('E',a,'=',es10.3,', '),('E',a,'=',es10.3))") 'tot',etot,'kin',ekin,'therm',etherm,'pot',epot + + if (mhd) write(iprint,"(1x,('E',a,'=',es10.3))") 'mag',emag + if (do_radiation) write(iprint,"(1x,('E',a,'=',es10.3))") 'rad',erad + if (track_mass) write(iprint,"(1x,('E',a,'=',es10.3))") 'acc',ev_data(iev_sum,iev_eacc) + write(iprint,"(1x,1(a,'=',es10.3,', '),(a,'=',es10.3))") & + 'Linm',ev_data(iev_sum,iev_totmom),'Angm',ev_data(iev_sum,iev_angmom) + if (iexternalforce > 0) then + if (abs(ev_data(iev_sum,iev_angall)-ev_data(iev_sum,iev_angmom)) > tiny(0.)) then + write(iprint,"(1x,1(a,'=',es10.3,', '),(a,'=',es10.3),a)") & + 'Linm',ev_data(iev_sum,iev_momall),'Angm',ev_data(iev_sum,iev_angall),' [including accreted particles]' + endif + endif + write(iprint,"(1x,3(a,es10.3))") "Centre of Mass = ",xyzcom(1),", ",xyzcom(2),", ",xyzcom(3) + + if (ev_data(iev_max,iev_rho) > 0.) then ! avoid floating point exception if no gas particles + write(iprint,"(1x,a,'(max)=',es10.3,' (mean)=',es10.3,' (max)=',es10.3,a)") & + 'density ',ev_data(iev_max,iev_rho),ev_data(iev_ave,iev_rho),ev_data(iev_max,iev_rho)*unit_density,' g/cm^3' + endif + + if (use_dustfrac) then + write(iprint,"(1x,a,'(max)=',es10.3,1x,'(mean)=',es10.3,1x,'(min)=',es10.3)") & + 'dust2gas ',ev_data(iev_max,iev_dtg),ev_data(iev_ave,iev_dtg),ev_data(iev_min,iev_dtg) + write(iprint,"(3x,a,'(mean)=',es10.3,1x,'(min)=',es10.3)") 't_stop ',ev_data(iev_ave,iev_ts),ev_data(iev_min,iev_ts) + endif + if (use_dust) then + write(iprint,"(1x,'Mgas = ',es10.3)") mgas + Mdust_label = 'Mdust' + call make_tags_unique(ndusttypes,Mdust_label) + do i=1,ndusttypes + write(iprint,"(1x,1(a,' = ',es10.3))") trim(Mdust_label(i)),mdust(i) + enddo + endif + + if (track_mass) write(iprint,"(1x,1(a,'=',es10.3))") 'Accreted mass',accretedmass + + string = '' + if (maxalpha==maxp) then + if (ev_data(iev_max,iev_alpha) > 0.) write(string,"(a,'(max)=',es10.3)") ' alpha',ev_data(iev_max,iev_alpha) + endif + if (len_trim(string) > 0) write(iprint,"(a)") trim(string) + + if (irealvisc /= 0 .and. npartall > 0) then + if (periodic) then + if (irealvisc==1) then + write(iprint,"(1x,1(a,'=',es10.3,', '),(a,'=',es10.3))") & + 'RMS Mach #',rmsmach,'Reynolds # ',vrms*min(dxbound,dybound,dzbound)/shearparam + endif + endif + write(iprint,"(1x,1(a,'(max)=',es10.3,', '),('(mean)=',es10.3),(' (min)=',es10.3))") & + 'Ratio of physical-to-art. visc',ev_data(iev_max,iev_viscrat),ev_data(iev_min,iev_viscrat) + elseif (npartall > 0) then + write(iprint,"(1x,1(a,'=',es10.3))") 'RMS Mach #',rmsmach + endif + + if (mhd) then + write(iprint,"(1x,1(a,'(max)=',es10.3,', '),(a,'(mean)=',es10.3))") & + 'div B ',ev_data(iev_max,iev_divB),'div B ',ev_data(iev_ave,iev_divB) + write(iprint,"(1x,1(a,'(max)=',es10.3,', '),(a,'(mean)=',es10.3))") & + 'h|div B|/B ',ev_data(iev_max,iev_hdivB),'h|div B|/B ',ev_data(iev_ave,iev_hdivB) + if (ev_data(iev_max,iev_hdivB) > 10.) & + write(iprint,'(a)') 'WARNING! h|div B|/B is growing! Recommend increasing hdivbbmax_max for better stability' + endif + write(iprint,"(/)") + +end subroutine write_evlog + +end module evwrite diff --git a/src/main/extern_binary_gw.f90 b/src/main/extern_binary_gw.f90 index c41bcd59b..db906d239 100644 --- a/src/main/extern_binary_gw.f90 +++ b/src/main/extern_binary_gw.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_binary ! diff --git a/src/main/extern_densprofile.f90 b/src/main/extern_densprofile.f90 index e16d09be2..407e50fae 100644 --- a/src/main/extern_densprofile.f90 +++ b/src/main/extern_densprofile.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_densprofile ! diff --git a/src/main/extern_gr.f90 b/src/main/extern_gr.f90 new file mode 100644 index 000000000..3d3aacdb2 --- /dev/null +++ b/src/main/extern_gr.f90 @@ -0,0 +1,411 @@ +!--------------------------------------------------------------------------! +! 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 extern_gr +! +! Compute terms related to derivatives of the metric which appear +! on the right hand side of the momentum equation +! +! :References: +! Liptai & Price (2019), MNRAS 485, 819 +! Magnall, Price, Lasky & Macpherson (2023), Phys. Rev D. 108, 103534 +! +! :Owner: Spencer Magnall +! +! :Runtime parameters: None +! +! :Dependencies: eos, io, metric_tools, part, physcon, timestep, utils_gr +! + implicit none + + public :: get_grforce, get_grforce_all, update_grforce_leapfrog, get_tmunu_all, get_tmunu_all_exact, get_tmunu + + private + +contains + +!--------------------------------------------------------------- +!+ +! Wrapper subroutine for computing the force due to spacetime curvature +! (This may be useful in the future if there is something that indicates +! whether a particle is gas or test particle.) +!+ +!--------------------------------------------------------------- +subroutine get_grforce(xyzhi,metrici,metricderivsi,veli,densi,ui,pi,fexti,dtf) + use io, only:iprint,fatal,error + real, intent(in) :: xyzhi(4),metrici(:,:,:),metricderivsi(0:3,0:3,3),veli(3),densi,ui,pi + real, intent(out) :: fexti(3) + real, intent(out), optional :: dtf + integer :: ierr + + call forcegr(xyzhi(1:3),metrici,metricderivsi,veli,densi,ui,pi,fexti,ierr) + if (ierr > 0) then + write(iprint,*) 'x,y,z = ',xyzhi(1:3) + call error('get_u0 in extern_gr','1/sqrt(-v_mu v^mu) ---> non-negative: v_mu v^mu') + call fatal('get_grforce','could not compute forcegr at r = ',val=sqrt(dot_product(xyzhi(1:3),xyzhi(1:3))) ) + endif + + if (present(dtf)) call dt_grforce(xyzhi,fexti,dtf) + +end subroutine get_grforce + +!--------------------------------------------------------------- +!+ +! Wrapper of the above, computing accelerations due to metric +! gradients on all particles +!+ +!--------------------------------------------------------------- +subroutine get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtexternal) + use timestep, only:C_force + use eos, only:ieos,get_pressure + use part, only:isdead_or_accreted + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) + real, intent(inout) :: vxyzu(:,:) + real, intent(out) :: fext(:,:), dtexternal + integer :: i + real :: dtf,pi + + dtexternal = huge(dtexternal) + + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,ieos,C_force) & + !$omp private(i,dtf,pi) & + !$omp reduction(min:dtexternal) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) + call get_grforce(xyzh(:,i),metrics(:,:,:,i),metricderivs(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,fext(1:3,i),dtf) + dtexternal = min(dtexternal,C_force*dtf) + endif + enddo + !$omp end parallel do + +end subroutine get_grforce_all + +!--------------------------------------------------------------------------- +!+ +! Subroutine to calculate the timestep constraint from the 'external force' +! this is multiplied by the safety factor C_force elsewhere +!+ +!--------------------------------------------------------------------------- +subroutine dt_grforce(xyzh,fext,dtf) + use physcon, only:pi + use metric_tools, only:imetric,imet_schwarzschild,imet_kerr + real, intent(in) :: xyzh(4),fext(3) + real, intent(out) :: dtf + real :: r,r2,dtf1,dtf2,f2i + integer, parameter :: steps_per_orbit = 100 + + f2i = fext(1)*fext(1) + fext(2)*fext(2) + fext(3)*fext(3) + if (f2i > 0.) then + dtf1 = sqrt(xyzh(4)/sqrt(f2i)) ! This is not really accurate since fi is a component of dp/dt, not da/dt + else + dtf1 = huge(dtf1) + endif + + select case (imetric) + case (imet_schwarzschild,imet_kerr) + r2 = xyzh(1)*xyzh(1) + xyzh(2)*xyzh(2) + xyzh(3)*xyzh(3) + r = sqrt(r2) + dtf2 = (2.*pi*sqrt(r*r2))/steps_per_orbit + case default + dtf2 = huge(dtf2) + end select + + dtf = min(dtf1,dtf2) + +end subroutine dt_grforce + +!---------------------------------------------------------------- +!+ +! Compute the source terms required on the right hand side of +! the relativistic momentum equation. These are of the form: +! T^\mu\nu dg_\mu\nu/dx^i +!+ +!---------------------------------------------------------------- +pure subroutine forcegr(x,metrici,metricderivsi,v,dens,u,p,fterm,ierr) + use metric_tools, only:unpack_metric + use utils_gr, only:get_u0 + real, intent(in) :: x(3),metrici(:,:,:),metricderivsi(0:3,0:3,3),v(3),dens,u,p + real, intent(out) :: fterm(3) + integer, intent(out) :: ierr + real :: gcov(0:3,0:3), gcon(0:3,0:3) + real :: v4(0:3), term(0:3,0:3) + real :: enth, uzero + integer :: i + + call unpack_metric(metrici,gcov=gcov,gcon=gcon) + + enth = 1. + u + p/dens + + ! lower-case 4-velocity + v4(0) = 1. + v4(1:3) = v(:) + + ! first component of the upper-case 4-velocity + call get_u0(gcov,v,uzero,ierr) + + ! energy-momentum tensor times sqrtg on 2rho* + do i=0,3 + term(0:3,i) = 0.5*(enth*uzero*v4(0:3)*v4(i) + P*gcon(0:3,i)/(dens*uzero)) + enddo + + ! source term + fterm = 0. + do i=0,3 + fterm(1) = fterm(1) + dot_product(term(:,i),metricderivsi(:,i,1)) + fterm(2) = fterm(2) + dot_product(term(:,i),metricderivsi(:,i,2)) + fterm(3) = fterm(3) + dot_product(term(:,i),metricderivsi(:,i,3)) + enddo + +end subroutine forcegr + +!-------- I don't think this is actually being used at the moment.... +subroutine update_grforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,densi,ui,pi) + use io, only:fatal + real, intent(in) :: dt,xi,yi,zi + real, intent(in) :: vhalfx,vhalfy,vhalfz + real, intent(inout) :: fxi,fyi,fzi + real, intent(inout) :: fexti(3) + real, intent(in) :: densi,ui,pi +! real :: fextv(3) +! real :: v1x, v1y, v1z, v1xold, v1yold, v1zold, vhalf2, erri, dton2 +! logical :: converged +! integer :: its, itsmax +! integer, parameter :: maxitsext = 50 ! maximum number of iterations on external force +! real, parameter :: tolv = 1.e-2 +! real, parameter :: tolv2 = tolv*tolv +! real,dimension(3) :: pos,vel +! real :: dtf +! +! itsmax = maxitsext +! its = 0 +! converged = .false. +! dton2 = 0.5*dt +! +! v1x = vhalfx +! v1y = vhalfy +! v1z = vhalfz +! vhalf2 = vhalfx*vhalfx + vhalfy*vhalfy + vhalfz*vhalfz +! fextv = 0. ! to avoid compiler warning +! +! iterations : do while (its < itsmax .and. .not.converged) +! its = its + 1 +! erri = 0. +! v1xold = v1x +! v1yold = v1y +! v1zold = v1z +! pos = (/xi,yi,zi/) +! vel = (/v1x,v1y,v1z/) +! call get_grforce(pos,vel,densi,ui,pi,fextv,dtf) +! ! xi = pos(1) +! ! yi = pos(2) +! ! zi = pos(3) +! v1x = vel(1) +! v1y = vel(2) +! v1z = vel(3) +! +! v1x = vhalfx + dton2*(fxi + fextv(1)) +! v1y = vhalfy + dton2*(fyi + fextv(2)) +! v1z = vhalfz + dton2*(fzi + fextv(3)) +! +! erri = (v1x - v1xold)**2 + (v1y - v1yold)**2 + (v1z - v1zold)**2 +! erri = erri / vhalf2 +! converged = (erri < tolv2) +! +! enddo iterations +! +! if (its >= maxitsext) call fatal('update_grforce_leapfrog','VELOCITY ITERATIONS ON EXTERNAL FORCE NOT CONVERGED!!') +! +! fexti(1) = fextv(1) +! fexti(2) = fextv(2) +! fexti(3) = fextv(3) +! +! fxi = fxi + fexti(1) +! fyi = fyi + fexti(2) +! fzi = fzi + fexti(3) + +end subroutine update_grforce_leapfrog + +!---------------------------------------------------------------- +!+ +! compute stress energy tensor on all particles +!+ +!---------------------------------------------------------------- +subroutine get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + use eos, only:ieos,get_pressure + use part, only:isdead_or_accreted + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) + real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) + real :: pi + integer :: i + + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,metrics,vxyzu,dens,ieos,tmunus) & + !$omp private(i,pi) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) + call get_tmunu(xyzh(:,i),metrics(:,:,:,i),vxyzu(1:3,i),& + dens(i),vxyzu(4,i),pi,tmunus(:,:,i)) + endif + enddo + !$omp end parallel do + +end subroutine get_tmunu_all + +!------------------------------------------------------------------------- +!+ +! calculate the covariant form of the stress energy tensor +! for a particle at position x +!+ +!------------------------------------------------------------------------- +subroutine get_tmunu(x,metrici,v,dens,u,p,tmunu) + use metric_tools, only:unpack_metric + use utils_gr, only:get_u0 + real, intent(in) :: x(3),metrici(:,:,:),v(3),dens,u,p + real, intent(out) :: tmunu(0:3,0:3) + real :: w,v4(0:3),uzero,u_upper(0:3),u_lower(0:3) + real :: gcov(0:3,0:3), gcon(0:3,0:3) + real :: gammaijdown(1:3,1:3),betadown(3),alpha + integer :: ierr,mu,nu + + ! Reference for all the variables used in this routine: + ! w - the enthalpy + ! gcov - the covariant form of the metric tensor + ! gcon - the contravariant form of the metric tensor + ! gammaijdown - the covariant form of the spatial metric + ! alpha - the lapse + ! betadown - the covariant component of the shift + ! v4 - the uppercase 4 velocity in covariant form + ! v - the fluid velocity v^x + ! vcov - the covariant form of big V_i + ! bigV - the uppercase contravariant V^i + + ! Calculate the enthalpy + w = 1 + u + p/dens + + ! Get cov and con versions of the metric + spatial metric and lapse and shift + ! Not entirely convinced that the lapse and shift calculations are acccurate for the general case!! + call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) + + ! We are going to use the same Tmunu calc as force GR + ! And then lower it using the metric + ! i.e calc T^{\mu\nu} and then lower it using the metric + ! tensor + ! lower-case 4-velocity (contravariant) + v4(0) = 1. + v4(1:3) = v(:) + + ! first component of the upper-case 4-velocity (contravariant) + call get_u0(gcov,v,uzero,ierr) + + u_upper = uzero*v4 + do mu=0,3 + u_lower(mu) = gcov(mu,0)*u_upper(0) + gcov(mu,1)*u_upper(1) & + + gcov(mu,2)*u_upper(2) + gcov(mu,3)*u_upper(3) + enddo + + ! Stress energy tensor in contravariant form + do nu=0,3 + do mu=0,3 + tmunu(mu,nu) = w*dens*u_lower(mu)*u_lower(nu) + p*gcov(mu,nu) + enddo + enddo + +end subroutine get_tmunu + +!------------------------------------------------------------------------- +!+ +! the following two routines are for testing purposes +! and could be deleted at some stage (as used in Magnall et al. 2023) +!+ +!------------------------------------------------------------------------- +subroutine get_tmunu_exact(x,metrici,metricderivsi,v,dens,u,p,tmunu) + use metric_tools, only:unpack_metric + use utils_gr, only:get_sqrtg + real, intent(in) :: x(3),metrici(:,:,:),metricderivsi(0:3,0:3,3),v(3),dens,u,p + real, intent(out) :: tmunu(0:3,0:3) + real :: w,v4(0:3),vcov(3),lorentz + real :: gcov(0:3,0:3), gcon(0:3,0:3) + real :: gammaijdown(1:3,1:3),betadown(3),alpha + real :: velshiftterm + real :: rhostar,rhoprim,negsqrtg + integer :: i,j + + ! Calculate the enthalpy + ! enthalpy should be 1 as we have zero pressure + ! or should have zero pressure + w = 1 + ! Calculate the exact value of density from conserved density + + call unpack_metric(metrici,gcov=gcov,gcon=gcon,gammaijdown=gammaijdown,alpha=alpha,betadown=betadown) + ! We need the covariant version of the 3 velocity + ! gamma_ij v^j = v_i where gamma_ij is the spatial metric + do i=1, 3 + vcov(i) = gammaijdown(i,1)*v(1) + gammaijdown(i,2)*v(2) + gammaijdown(i,3)*v(3) + enddo + + ! Calculate the lorentz factor + lorentz = (1. - (vcov(1)*v(1) + vcov(2)*v(2) + vcov(3)*v(3)))**(-0.5) + + ! Calculate the 4-velocity + velshiftterm = vcov(1)*betadown(1) + vcov(2)*betadown(2) + vcov(3)*betadown(3) + v4(0) = lorentz*(-alpha + velshiftterm) + v4(1:3) = lorentz*v(1:3) + + rhostar = 13.294563008157013D0 + call get_sqrtg(gcov,negsqrtg) + + ! Set/Calculate primitive density using rhostar exactly + rhoprim = rhostar/(negsqrtg/alpha) + + ! Stress energy tensor + do j=0,3 + do i=0,3 + tmunu(i,j) = rhoprim*w*v4(i)*v4(j) ! + p*gcov(i,j) neglect the pressure term as we don't care + enddo + enddo + +end subroutine get_tmunu_exact + +!------------------------------------------------------------------------- +!+ +! see above: for testing purposes and could be deleted at some stage +! (as used in Magnall et al. 2023) +!+ +!------------------------------------------------------------------------- +subroutine get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) + use eos, only:ieos,get_pressure + use part, only:isdead_or_accreted + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:), metrics(:,:,:,:), metricderivs(:,:,:,:), dens(:) + real, intent(inout) :: vxyzu(:,:),tmunus(:,:,:) + real :: pi + integer :: i + logical :: firstpart + real :: tmunu(4,4) + + tmunu = 0. + firstpart = .true. + ! TODO write openmp parallel code + do i=1, npart + if (.not.isdead_or_accreted(xyzh(4,i)) .and. firstpart) then + pi = get_pressure(ieos,xyzh(:,i),dens(i),vxyzu(:,i)) + call get_tmunu_exact(xyzh(:,i),metrics(:,:,:,i), metricderivs(:,:,:,i), & + vxyzu(1:3,i),dens(i),vxyzu(4,i),pi,tmunus(:,:,i)) + firstpart = .false. + tmunu(:,:) = tmunus(:,:,i) + else + tmunus(:,:,i) = tmunu(:,:) + endif + enddo + +end subroutine get_tmunu_all_exact + +end module extern_gr diff --git a/src/main/extern_gwinspiral.f90 b/src/main/extern_gwinspiral.f90 index 3d6df7205..460cb5c3b 100644 --- a/src/main/extern_gwinspiral.f90 +++ b/src/main/extern_gwinspiral.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_gwinspiral ! diff --git a/src/main/extern_lensethirring.f90 b/src/main/extern_lensethirring.f90 index d039422cb..cfc6b9b03 100644 --- a/src/main/extern_lensethirring.f90 +++ b/src/main/extern_lensethirring.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_lensethirring ! diff --git a/src/main/extern_spiral.f90 b/src/main/extern_spiral.f90 index b485802f4..ddeb68966 100644 --- a/src/main/extern_spiral.f90 +++ b/src/main/extern_spiral.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_spiral ! diff --git a/src/main/extern_staticsine.f90 b/src/main/extern_staticsine.f90 index bbb12be75..8d71b1c14 100644 --- a/src/main/extern_staticsine.f90 +++ b/src/main/extern_staticsine.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module extern_staticsine ! diff --git a/src/main/externalforces.F90 b/src/main/externalforces.f90 similarity index 99% rename from src/main/externalforces.F90 rename to src/main/externalforces.f90 index ffd8ba7fc..51f3ecd3c 100644 --- a/src/main/externalforces.F90 +++ b/src/main/externalforces.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module externalforces ! @@ -23,14 +23,14 @@ module externalforces ! extern_lensethirring, extern_prdrag, extern_spiral, extern_staticsine, ! infile_utils, io, lumin_nsdisc, part, units ! - use extern_binary, only:accradius1,mass1 + use extern_binary, only:accradius1,mass1,accretedmass1,accretedmass2 use extern_corotate, only:omega_corotate ! so public from this module implicit none private public :: externalforce,externalforce_vdependent public :: accrete_particles,was_accreted - public :: accradius1,omega_corotate + public :: accradius1,omega_corotate,accretedmass1,accretedmass2 public :: write_options_externalforces,read_options_externalforces public :: initialise_externalforces,is_velocity_dependent public :: update_vdependent_extforce_leapfrog diff --git a/src/main/externalforces_gr.F90 b/src/main/externalforces_gr.f90 similarity index 99% rename from src/main/externalforces_gr.F90 rename to src/main/externalforces_gr.f90 index ae3f37a96..562660310 100644 --- a/src/main/externalforces_gr.F90 +++ b/src/main/externalforces_gr.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module externalforces ! @@ -39,6 +39,8 @@ module externalforces public :: mass1 ! exported from metric module real, public :: accradius1 = 0. real, public :: accradius1_hard = 0. + real, public :: accretedmass1 = 0. + real, public :: accretedmass2 = 0. logical, public :: extract_iextern_from_hdr = .false. diff --git a/src/main/fastmath.f90 b/src/main/fastmath.f90 index 7b22fc762..59bb2a052 100644 --- a/src/main/fastmath.f90 +++ b/src/main/fastmath.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module fastmath ! diff --git a/src/main/force.F90 b/src/main/force.F90 index a7e063d2a..2caa4f23f 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module forces ! diff --git a/src/main/forcing.F90 b/src/main/forcing.F90 index 070d9b534..878e88f86 100644 --- a/src/main/forcing.F90 +++ b/src/main/forcing.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module forcing ! @@ -963,9 +963,7 @@ subroutine forceit(t,npart,xyzh,vxyzu,fxyzu) real, intent(out) :: fxyzu(:,:) logical :: update_accel = .true. -#ifdef STIR_FROM_FILE - real :: tinfile -#endif +! real :: tinfile logical, parameter :: Debug = .false. !!=================================================================== @@ -977,25 +975,25 @@ subroutine forceit(t,npart,xyzh,vxyzu,fxyzu) if (t > (tprev + st_dtfreq)) then tprev = st_dtfreq*int(t/st_dtfreq) ! round to last full dtfreq update_accel = .true. -#ifdef STIR_FROM_FILE - call read_stirring_data_from_file(forcingfile,t,tinfile) - !if (id==master .and. iverbose >= 2) print*,' got new accel, tinfile = ',tinfile -#endif + if (stir_from_file) then + call read_stirring_data_from_file(forcingfile,t,tinfile) + !if (id==master .and. iverbose >= 2) print*,' got new accel, tinfile = ',tinfile + endif endif if (Debug) print *, 'stir: stirring start' call st_calcAccel(npart,xyzh,fxyzu) -#ifndef STIR_FROM_FILE - if (update_accel) then - if (Debug) print*,'updating accelerations...' - call st_ounoiseupdate(6*st_nmodes, st_OUphases, st_OUvar, st_dtfreq, st_decay) - call st_calcPhases() - !! Store random seed in memory for later checkpoint. - call random_seed (get = st_randseed) + if (.not. stir_from_file) then + if (update_accel) then + if (Debug) print*,'updating accelerations...' + call st_ounoiseupdate(6*st_nmodes, st_OUphases, st_OUvar, st_dtfreq, st_decay) + call st_calcPhases() + !! Store random seed in memory for later checkpoint. + call random_seed (get = st_randseed) + endif endif -#endif if (Debug) print *, 'stir: stirring end' diff --git a/src/main/fs_data.f90 b/src/main/fs_data.f90 index ed04c3664..2e5c0718f 100644 --- a/src/main/fs_data.f90 +++ b/src/main/fs_data.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module fs_data ! diff --git a/src/main/geometry.f90 b/src/main/geometry.f90 index db5d816f3..e0fcf88d2 100644 --- a/src/main/geometry.f90 +++ b/src/main/geometry.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module geometry ! diff --git a/src/main/gitinfo.f90 b/src/main/gitinfo.f90 index f1840f72e..8ea06264e 100644 --- a/src/main/gitinfo.f90 +++ b/src/main/gitinfo.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module gitinfo ! diff --git a/src/main/growth_smol.f90 b/src/main/growth_smol.f90 index d5a4e290b..0a818364f 100644 --- a/src/main/growth_smol.f90 +++ b/src/main/growth_smol.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module growth_smol ! diff --git a/src/main/h2chem.f90 b/src/main/h2chem.f90 index 126e5556f..a79faa951 100644 --- a/src/main/h2chem.f90 +++ b/src/main/h2chem.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module chem ! @@ -261,7 +261,7 @@ subroutine evolve_abundances(ui,rhoi,chemarrays,nchem,dphot,dt) nstep2=1 tstep2=tstep elseif (abco <= 0.d0) then - nstep2=int(rhoi*1000.d0) + nstep2=int(rhoi*1000.d0)+1 tstep2=tstep/nstep2 else ! tsteptest=-abco/(k0*abcp*beta*np1*np1 - gamma_co*abco*np1) diff --git a/src/main/inject_BHL.f90 b/src/main/inject_BHL.f90 index e5cc3c3fe..860dcf058 100644 --- a/src/main/inject_BHL.f90 +++ b/src/main/inject_BHL.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inject ! @@ -29,7 +29,8 @@ module inject implicit none character(len=*), parameter, public :: inject_type = 'BHL' - public :: init_inject,inject_particles,write_options_inject,read_options_inject + public :: init_inject,inject_particles,write_options_inject,read_options_inject,& + set_default_options_inject ! !--runtime settings for this module ! @@ -100,7 +101,11 @@ subroutine init_inject(ierr) size_y = ceiling(3.*wind_cylinder_radius/psep) size_z = ceiling(3.*wind_cylinder_radius/(sqrt(3.)*psep/2.)) do pass=1,2 - if (pass == 2) allocate(layer_even(2,neven), layer_odd(2,nodd)) + if (pass == 2) then + if (allocated(layer_even)) deallocate(layer_even) + if (allocated(layer_odd)) deallocate(layer_odd) + allocate(layer_even(2,neven), layer_odd(2,nodd)) + endif neven = 0 nodd = 0 do i=1,size_y @@ -253,6 +258,7 @@ subroutine inject_or_update_particles(ifirst, n, position, velocity, h, u, bound call add_or_update_particle(itype,position_u,velocity_u,h(i)/udist,u(i)/(udist**2/utime**2),& ifirst+i-1,npart,npartoftype,xyzh,vxyzu) enddo + end subroutine inject_or_update_particles !----------------------------------------------------------------------- @@ -329,4 +335,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) igotall = (ngot >= 8) end subroutine read_options_inject +subroutine set_default_options_inject(flag) + + integer, optional, intent(in) :: flag +end subroutine set_default_options_inject + end module inject diff --git a/src/main/inject_bondi.f90 b/src/main/inject_bondi.f90 index 1e7ceca6f..8eb40aec7 100644 --- a/src/main/inject_bondi.f90 +++ b/src/main/inject_bondi.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inject ! @@ -30,7 +30,8 @@ module inject public :: init_inject, & inject_particles, & write_options_inject, & - read_options_inject + read_options_inject, & + set_default_options_inject !-- Runtime variables read from input file real, public :: rin = 18.1 @@ -316,4 +317,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) end subroutine read_options_inject +subroutine set_default_options_inject(flag) + + integer, optional, intent(in) :: flag +end subroutine set_default_options_inject + end module inject diff --git a/src/main/inject_firehose.f90 b/src/main/inject_firehose.f90 index 043a0774f..92bf578c0 100644 --- a/src/main/inject_firehose.f90 +++ b/src/main/inject_firehose.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inject ! @@ -26,7 +26,7 @@ module inject character(len=*), parameter, public :: inject_type = 'firehose' public :: inject_particles, write_options_inject, read_options_inject - public :: init_inject + public :: init_inject, set_default_options_inject real, private :: Mdot = 0. real, private :: Mdotcode = 0. @@ -273,4 +273,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) end subroutine read_options_inject +subroutine set_default_options_inject(flag) + + integer, optional, intent(in) :: flag +end subroutine set_default_options_inject + end module inject diff --git a/src/main/inject_galcen_winds.f90 b/src/main/inject_galcen_winds.f90 index 29156a92c..231367852 100644 --- a/src/main/inject_galcen_winds.f90 +++ b/src/main/inject_galcen_winds.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inject ! @@ -25,7 +25,8 @@ module inject implicit none character(len=*), parameter, public :: inject_type = 'galcen_winds' - public :: init_inject,inject_particles,write_options_inject,read_options_inject + public :: init_inject,inject_particles,write_options_inject,read_options_inject,& + set_default_options_inject real :: outer_boundary = 20. character(len=120) :: datafile = 'winddata.txt' @@ -303,4 +304,9 @@ subroutine read_wind_data(filename,nstars) end subroutine read_wind_data +subroutine set_default_options_inject(flag) + + integer, optional, intent(in) :: flag +end subroutine set_default_options_inject + end module inject diff --git a/src/main/inject_keplerianshear.f90 b/src/main/inject_keplerianshear.f90 index d2f44be91..ac93e0858 100644 --- a/src/main/inject_keplerianshear.f90 +++ b/src/main/inject_keplerianshear.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inject ! @@ -49,7 +49,8 @@ module inject implicit none character(len=*), parameter, public :: inject_type = 'keplerianshear' - public :: init_inject,inject_particles,write_options_inject,read_options_inject + public :: init_inject,inject_particles,write_options_inject,read_options_inject,& + set_default_options_inject public :: set_injection_parameters type injectparams @@ -206,6 +207,7 @@ subroutine write_options_inject(iunit) call write_inopt(injp%HoverR, 'HoverR', 'disc aspect ratio at inner sector radius', iunit) call write_inopt(injp%disc_mass,'disc_mass', 'total disc mass', iunit) call write_inopt(injp%object_mass,'object_mass', 'mass of the central object', iunit) + end subroutine write_options_inject !----------------------------------------------------------------------- @@ -274,6 +276,11 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) end subroutine read_options_inject +subroutine set_default_options_inject(flag) + + integer, optional, intent(in) :: flag +end subroutine set_default_options_inject + subroutine set_injection_parameters(R_in, R_out, Rsect_in,Rsect_out,dr_bound,& phimax,phi_inject,p_index,q_index,HoverR,disc_mass,object_mass) @@ -375,14 +382,11 @@ subroutine determine_particle_status(nqueue, nkill, nboundary, ndomain, nexit) enddo - return end subroutine determine_particle_status - !---- ! Subroutine fills the injection zones with boundary particles !--- - subroutine replenish_injection_zone(ninject,time,dtlast,injected) use eos, only:polyk,gamma use io, only:id,master @@ -501,15 +505,12 @@ subroutine replenish_injection_zone(ninject,time,dtlast,injected) enddo - return end subroutine replenish_injection_zone !---------------------------------- ! Rotates a particle in the z axis !---------------------------------- - subroutine rotate_particle_z(xyz,vxyz,phi) - real, intent(inout) :: phi, xyz(3), vxyz(3) real :: x,y,vx,vy @@ -525,12 +526,11 @@ subroutine rotate_particle_z(xyz,vxyz,phi) vxyz(1) = vx*cos(phi) - vy*sin(phi) vxyz(2) = vx*sin(phi) + vy*cos(phi) - return end subroutine rotate_particle_z !---------------------------------- !+ -! Rotates a single vector in the z axis +! Rotates a single vector in the z axis !+ !----------------------------------- @@ -541,15 +541,13 @@ subroutine rotate_vector_z(oldvec,newvec,phi) newvec(1) = oldvec(1)*cos(phi) - oldvec(2)*sin(phi) newvec(2) = oldvec(1)*sin(phi) + oldvec(2)*cos(phi) - return end subroutine rotate_vector_z -! +!----------------------------------------------------------------------- !+ ! Helper function to calculate polar co-ordinates from x,y !+ -! - +!----------------------------------------------------------------------- subroutine calc_polar_coordinates(r,phi,x,y) real, intent(in) :: x,y @@ -558,17 +556,14 @@ subroutine calc_polar_coordinates(r,phi,x,y) r = sqrt(x*x + y*y) phi = atan2(y,x) - return end subroutine calc_polar_coordinates - !----------------------------------------------------------------------- !+ ! Simple function to calculate the disc's surface density normalisation ! for a disc mass, inner and outer radii and the powerlaw index !+ !----------------------------------------------------------------------- - real function sigma0(Mdisc, Rinner, Router, p_index) real, intent(in) :: Mdisc,Rinner, Router, p_index diff --git a/src/main/inject_rochelobe.f90 b/src/main/inject_rochelobe.f90 index 2c9b015a7..ffe84d4dd 100644 --- a/src/main/inject_rochelobe.f90 +++ b/src/main/inject_rochelobe.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inject ! @@ -24,7 +24,8 @@ module inject implicit none character(len=*), parameter, public :: inject_type = 'rochelobe' - public :: init_inject,inject_particles,write_options_inject,read_options_inject + public :: init_inject,inject_particles,write_options_inject,read_options_inject,& + set_default_options_inject real, private :: Mdot = 1.0e-9 real, private :: Mdotcode = 0. @@ -337,4 +338,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) end subroutine read_options_inject +subroutine set_default_options_inject(flag) + + integer, optional, intent(in) :: flag +end subroutine set_default_options_inject + end module inject diff --git a/src/main/inject_sne.f90 b/src/main/inject_sne.f90 index e74e9bc67..24d3bc2ab 100644 --- a/src/main/inject_sne.f90 +++ b/src/main/inject_sne.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inject ! @@ -19,7 +19,8 @@ module inject implicit none character(len=*), parameter, public :: inject_type = 'supernovae' - public :: init_inject,inject_particles,write_options_inject,read_options_inject + public :: init_inject,inject_particles,write_options_inject,read_options_inject,& + set_default_options_inject integer, parameter :: maxsn = 30 real, parameter :: xyz_sn(3,maxsn) = & @@ -174,4 +175,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) end subroutine read_options_inject +subroutine set_default_options_inject(flag) + + integer, optional, intent(in) :: flag +end subroutine set_default_options_inject + end module inject diff --git a/src/main/inject_unifwind.f90 b/src/main/inject_unifwind.f90 index b7c2ace45..d1a456ff6 100644 --- a/src/main/inject_unifwind.f90 +++ b/src/main/inject_unifwind.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inject ! @@ -22,7 +22,8 @@ module inject implicit none character(len=*), parameter, public :: inject_type = 'unifwind' - public :: init_inject,inject_particles,write_options_inject,read_options_inject + public :: init_inject,inject_particles,write_options_inject,read_options_inject,& + set_default_options_inject real, public :: wind_density = 7.2d-16 real, public :: wind_velocity = 29. @@ -180,4 +181,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) igotall = (ngot >= 4) end subroutine read_options_inject +subroutine set_default_options_inject(flag) + + integer, optional, intent(in) :: flag +end subroutine set_default_options_inject + end module inject diff --git a/src/main/inject_wind.F90 b/src/main/inject_wind.f90 similarity index 100% rename from src/main/inject_wind.F90 rename to src/main/inject_wind.f90 diff --git a/src/main/inverse4x4.f90 b/src/main/inverse4x4.f90 index 341f965ae..2107fae70 100644 --- a/src/main/inverse4x4.f90 +++ b/src/main/inverse4x4.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inverse4x4 ! diff --git a/src/main/io.F90 b/src/main/io.F90 index 183166ce4..97e2bb204 100644 --- a/src/main/io.F90 +++ b/src/main/io.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module io ! diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index 65fc3065a..032bc9ad6 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module ionization_mod ! diff --git a/src/main/kernel_WendlandC2.f90 b/src/main/kernel_WendlandC2.f90 index 52b0c1e5d..882b2d4a4 100644 --- a/src/main/kernel_WendlandC2.f90 +++ b/src/main/kernel_WendlandC2.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module kernel ! diff --git a/src/main/kernel_WendlandC4.f90 b/src/main/kernel_WendlandC4.f90 index b5fe7a638..ea1202d65 100644 --- a/src/main/kernel_WendlandC4.f90 +++ b/src/main/kernel_WendlandC4.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module kernel ! diff --git a/src/main/kernel_WendlandC6.f90 b/src/main/kernel_WendlandC6.f90 index edf471d83..b7b690789 100644 --- a/src/main/kernel_WendlandC6.f90 +++ b/src/main/kernel_WendlandC6.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module kernel ! diff --git a/src/main/kernel_cubic.f90 b/src/main/kernel_cubic.f90 index 8a851253d..bf16cead5 100644 --- a/src/main/kernel_cubic.f90 +++ b/src/main/kernel_cubic.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module kernel ! diff --git a/src/main/kernel_quartic.f90 b/src/main/kernel_quartic.f90 index 7fdb09ddc..a698e32b6 100644 --- a/src/main/kernel_quartic.f90 +++ b/src/main/kernel_quartic.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module kernel ! diff --git a/src/main/kernel_quintic.f90 b/src/main/kernel_quintic.f90 index 79e8fd149..64482f474 100644 --- a/src/main/kernel_quintic.f90 +++ b/src/main/kernel_quintic.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module kernel ! diff --git a/src/main/krome.f90 b/src/main/krome.f90 index d0f632675..4ece40748 100644 --- a/src/main/krome.f90 +++ b/src/main/krome.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module krome_interface ! diff --git a/src/main/linklist_kdtree.F90 b/src/main/linklist_kdtree.F90 index 553365dcc..4913f0925 100644 --- a/src/main/linklist_kdtree.F90 +++ b/src/main/linklist_kdtree.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module linklist ! @@ -25,8 +25,6 @@ module linklist use part, only:ll use dtypekdtree, only:kdnode implicit none - character(len=80), parameter, public :: & ! module version - modid="$Id$" integer, allocatable :: cellatid(:) integer, public, allocatable :: ifirstincell(:) diff --git a/src/main/lumin_nsdisc.f90 b/src/main/lumin_nsdisc.f90 index 0c5936a03..90db88923 100644 --- a/src/main/lumin_nsdisc.f90 +++ b/src/main/lumin_nsdisc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module lumin_nsdisc ! @@ -17,7 +17,7 @@ module lumin_nsdisc ! ! :Runtime parameters: None ! -! :Dependencies: eos, fastmath, infile_utils, io, physcon, units +! :Dependencies: eos, infile_utils, io, physcon, units ! use physcon, only: pi @@ -120,17 +120,11 @@ end subroutine make_grid_points subroutine get_grid_bins( r, zt, rbin, ztbin, phi, phibin ) use physcon, only:pi, twopi use io, only : fatal -#ifdef FINVSQRT - use fastmath, only:finvsqrt -#endif real, intent(in) :: r, phi, zt integer, intent(out) :: rbin, ztbin, phibin real :: B, C, ztnew -#ifdef FINVSQRT - rbin = int( nr*finvsqrt( (rmax-rmin)/((r-rmin)))) !optimized for speed not readability -#else + rbin = int( nr*sqrt( (r-rmin)/(rmax-rmin))) -#endif B = 2.*(thetamin-thetamax)/(nth) C = 2.*(zmin-zmax)/nz diff --git a/src/main/memory.f90 b/src/main/memory.f90 index ccd3f4fb0..b20dae9f4 100644 --- a/src/main/memory.f90 +++ b/src/main/memory.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module memory ! @@ -15,7 +15,7 @@ module memory ! :Runtime parameters: None ! ! :Dependencies: allocutils, dim, io, linklist, mpibalance, mpiderivs, -! mpimemory, mpitree, part, photoevap +! mpimemory, mpitree, part ! implicit none @@ -34,9 +34,6 @@ subroutine allocate_memory(ntot, part_only) use mpibalance, only:allocate_balance_arrays use mpiderivs, only:allocate_cell_comms_arrays use mpitree, only:allocate_tree_comms_arrays -#ifdef PHOTO - use photoevap, only:allocate_photoevap -#endif integer(kind=8), intent(in) :: ntot logical, optional, intent(in) :: part_only @@ -86,9 +83,6 @@ subroutine allocate_memory(ntot, part_only) call allocate_part if (.not. part_only_) then call allocate_linklist -#ifdef PHOTO - call allocate_photoevap -#endif if (mpi) then call allocate_mpi_memory(npart=n) call allocate_balance_arrays @@ -113,9 +107,6 @@ subroutine deallocate_memory(part_only) use dim, only:update_max_sizes,mpi use part, only:deallocate_part use linklist, only:deallocate_linklist -#ifdef PHOTO - use photoevap, only:deallocate_photoevap -#endif use mpimemory, only:deallocate_mpi_memory use mpibalance, only:deallocate_balance_arrays use mpiderivs, only:deallocate_cell_comms_arrays @@ -134,9 +125,6 @@ subroutine deallocate_memory(part_only) call deallocate_part if (.not. part_only_) then call deallocate_linklist -#ifdef PHOTO - call deallocate_photoevap -#endif endif if (mpi) then diff --git a/src/main/metric_kerr-schild.f90 b/src/main/metric_kerr-schild.f90 index 240ba7034..59ada6922 100644 --- a/src/main/metric_kerr-schild.f90 +++ b/src/main/metric_kerr-schild.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module metric ! diff --git a/src/main/metric_kerr.f90 b/src/main/metric_kerr.f90 index de31643b5..b270e4111 100644 --- a/src/main/metric_kerr.f90 +++ b/src/main/metric_kerr.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module metric ! diff --git a/src/main/metric_minkowski.f90 b/src/main/metric_minkowski.f90 index 1d4e62579..3562abad8 100644 --- a/src/main/metric_minkowski.f90 +++ b/src/main/metric_minkowski.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module metric ! diff --git a/src/main/metric_schwarzschild.f90 b/src/main/metric_schwarzschild.f90 index 8f496edec..6add9d242 100644 --- a/src/main/metric_schwarzschild.f90 +++ b/src/main/metric_schwarzschild.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module metric ! diff --git a/src/main/metric_tools.F90 b/src/main/metric_tools.F90 index 2cf9f92c0..8fd54fdf0 100644 --- a/src/main/metric_tools.F90 +++ b/src/main/metric_tools.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module metric_tools ! diff --git a/src/main/mf_write.f90 b/src/main/mf_write.f90 index 84745ed05..486ec1bf7 100644 --- a/src/main/mf_write.f90 +++ b/src/main/mf_write.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mf_write ! diff --git a/src/main/mol_data.f90 b/src/main/mol_data.f90 index 1dc804833..fe91bae89 100644 --- a/src/main/mol_data.f90 +++ b/src/main/mol_data.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mol_data ! diff --git a/src/main/mpi_balance.F90 b/src/main/mpi_balance.F90 index 6fcf162f7..1679dda42 100644 --- a/src/main/mpi_balance.F90 +++ b/src/main/mpi_balance.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mpibalance ! @@ -44,19 +44,33 @@ module mpibalance contains -subroutine allocate_balance_arrays +!---------------------------------------------------------------- +!+ +! allocate memory +!+ +!---------------------------------------------------------------- +subroutine allocate_balance_arrays() use allocutils, only:allocate_array + call allocate_array('nsent', nsent, nprocs) call allocate_array('nexpect', nexpect, nprocs) call allocate_array('nrecv', nrecv, nprocs) call allocate_array('countrequest',countrequest,nprocs) + end subroutine allocate_balance_arrays -subroutine deallocate_balance_arrays +!---------------------------------------------------------------- +!+ +! deallocate memory +!+ +!---------------------------------------------------------------- +subroutine deallocate_balance_arrays() + if (allocated(nsent )) deallocate(nsent ) if (allocated(nexpect )) deallocate(nexpect ) if (allocated(nrecv )) deallocate(nrecv ) if (allocated(countrequest)) deallocate(countrequest) + end subroutine deallocate_balance_arrays !---------------------------------------------------------------- @@ -164,14 +178,18 @@ end subroutine balancedomains !+ !---------------------------------------------------------------- subroutine balance_init(npart) + use part, only:fill_sendbuf integer, intent(in) :: npart - integer :: i + integer :: i,nbuf + + ! use a dummy call to fill_sendbuf to find out the buffer size + call fill_sendbuf(1,xbuffer,nbuf) ! just fill for particle #1 !--use persistent communication type for receives ! cannot do same for sends as there are different destination, ! unless we make a request for each processor ! - call MPI_RECV_INIT(xbuffer,size(xbuffer),MPI_DEFAULT_REAL,MPI_ANY_SOURCE, & + call MPI_RECV_INIT(xbuffer,nbuf,MPI_DEFAULT_REAL,MPI_ANY_SOURCE, & MPI_ANY_TAG,comm_balance,irequestrecv(1),mpierr) ! !--post a non-blocking receive so that we can receive particles @@ -198,7 +216,6 @@ subroutine balance_init(npart) ! ncomplete = 0 - return end subroutine balance_init !----------------------------------------------------------------------- @@ -276,6 +293,7 @@ subroutine send_part(i,newproc,replace) integer, intent(in) :: i,newproc logical, intent(in), optional :: replace logical :: idone,doreplace + integer :: nbuf if (present(replace)) then doreplace = replace @@ -287,9 +305,9 @@ subroutine send_part(i,newproc,replace) if (newproc < 0 .or. newproc > nprocs-1) then call fatal('balance','error in ibelong',ival=newproc,var='ibelong') else - call fill_sendbuf(i,xsendbuf) + call fill_sendbuf(i,xsendbuf,nbuf) ! tag cannot be i, because some MPI implementations do not support large values for the tag - call MPI_ISEND(xsendbuf,size(xsendbuf),MPI_DEFAULT_REAL,newproc,0,comm_balance,irequestsend(1),mpierr) + call MPI_ISEND(xsendbuf,nbuf,MPI_DEFAULT_REAL,newproc,0,comm_balance,irequestsend(1),mpierr) !--wait for send to complete, receive whilst doing so idone = .false. @@ -302,7 +320,7 @@ subroutine send_part(i,newproc,replace) call kill_particle(i) nsent(newproc+1) = nsent(newproc+1) + 1 - return + end subroutine send_part !---------------------------------------------------------------- diff --git a/src/main/mpi_dens.F90 b/src/main/mpi_dens.F90 index f6f1480f9..d578658e3 100644 --- a/src/main/mpi_dens.F90 +++ b/src/main/mpi_dens.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mpidens ! diff --git a/src/main/mpi_derivs.F90 b/src/main/mpi_derivs.F90 index a8deacbd0..a9b2b2641 100644 --- a/src/main/mpi_derivs.F90 +++ b/src/main/mpi_derivs.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mpiderivs ! diff --git a/src/main/mpi_domain.F90 b/src/main/mpi_domain.F90 index b8ff8cb95..b58c49fed 100644 --- a/src/main/mpi_domain.F90 +++ b/src/main/mpi_domain.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mpidomain ! @@ -22,8 +22,6 @@ module mpidomain use io, only:nprocs use part, only:ibelong implicit none - character(len=80), parameter, public :: & ! module version - modid="$Id$" integer, parameter :: ndim = 3 diff --git a/src/main/mpi_force.F90 b/src/main/mpi_force.F90 index faeb48e36..3dab68ded 100644 --- a/src/main/mpi_force.F90 +++ b/src/main/mpi_force.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mpiforce ! diff --git a/src/main/mpi_memory.F90 b/src/main/mpi_memory.F90 index bb61caeb9..5d635f2d4 100644 --- a/src/main/mpi_memory.F90 +++ b/src/main/mpi_memory.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mpimemory ! diff --git a/src/main/mpi_memory.f90 b/src/main/mpi_memory.f90 new file mode 100644 index 000000000..5d635f2d4 --- /dev/null +++ b/src/main/mpi_memory.f90 @@ -0,0 +1,317 @@ +!--------------------------------------------------------------------------! +! 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 mpimemory +! +! None +! +! :References: None +! +! :Owner: Conrad Chan +! +! :Runtime parameters: None +! +! :Dependencies: dim, io, mpidens, mpiforce +! + use io, only:fatal,iprint + use mpidens, only:celldens,stackdens + use mpiforce, only:cellforce,stackforce + + implicit none + + interface allocate_stack + module procedure allocate_stack_dens,allocate_stack_force + end interface allocate_stack + + interface swap_stacks ! force doesn't require a stack swap + module procedure swap_stacks_dens + end interface swap_stacks + + interface push_onto_stack + module procedure push_onto_stack_dens,push_onto_stack_force + end interface push_onto_stack + + interface get_cell + module procedure get_cell_dens,get_cell_force + end interface get_cell + + interface write_cell + module procedure write_cell_dens,write_cell_force + end interface write_cell + + interface reserve_stack + module procedure reserve_stack_dens,reserve_stack_force + end interface reserve_stack + + public :: allocate_mpi_memory + public :: deallocate_mpi_memory + public :: allocate_stack + public :: swap_stacks + public :: push_onto_stack + public :: get_cell + public :: write_cell + public :: reserve_stack + public :: reset_stacks + public :: increase_mpi_memory + + ! stacks to be referenced from density and force routines + type(stackdens), public :: dens_stack_1 + type(stackdens), public :: dens_stack_2 + type(stackdens), public :: dens_stack_3 + type(stackforce), public :: force_stack_1 + type(stackforce), public :: force_stack_2 + + integer, public :: stacksize + + private + + ! primary chunk of memory requested using alloc + type(celldens), allocatable, target :: dens_cells(:,:) + type(cellforce), allocatable, target :: force_cells(:,:) + +contains + +subroutine allocate_mpi_memory(npart, stacksize_in) + integer, optional, intent(in) :: npart + integer, optional, intent(in) :: stacksize_in + integer :: allocstat + + allocstat = 0 + + if (present(stacksize_in)) stacksize = stacksize_in + if (present(npart)) call calculate_stacksize(npart) + + if (allocated(dens_cells)) then + if (stacksize /= size(dens_cells,1)) then + call fatal('stack', 'dens_cells already allocated with a different size') + endif + endif + + if (allocated(force_cells)) then + if (stacksize /= size(force_cells,1)) then + call fatal('stack', 'force_cells already allocated with a different size') + endif + endif + + if (.not. allocated(dens_cells)) allocate(dens_cells(stacksize,3), stat=allocstat) + if (allocstat /= 0) call fatal('stack','fortran memory allocation error') + call allocate_stack(dens_stack_1, 1) + call allocate_stack(dens_stack_2, 2) + call allocate_stack(dens_stack_3, 3) + + if (.not. allocated(force_cells)) allocate(force_cells(stacksize,2), stat=allocstat) + if (allocstat /= 0) call fatal('stack','fortran memory allocation error') + call allocate_stack(force_stack_1, 1) + call allocate_stack(force_stack_2, 2) + +end subroutine allocate_mpi_memory + +subroutine increase_mpi_memory + use io, only:id + real, parameter :: factor = 1.5 + integer :: stacksize_new + integer :: allocstat + + ! temporary memory for increasing stack sizes + type(celldens), allocatable, target :: dens_cells_tmp(:,:) + type(cellforce), allocatable, target :: force_cells_tmp(:,:) + + stacksize_new = int(real(stacksize) * factor) + write(iprint, *) 'MPI dens stack exceeded on', id, 'increasing size to', stacksize_new + + ! Expand density + call move_alloc(dens_cells, dens_cells_tmp) + allocate(dens_cells(stacksize_new,3), stat=allocstat) + if (allocstat /= 0) call fatal('stack', 'error increasing dens stack size') + dens_cells(1:stacksize,:) = dens_cells_tmp(:,:) + deallocate(dens_cells_tmp) + + ! Expand force + call move_alloc(force_cells, force_cells_tmp) + allocate(force_cells(stacksize_new,2), stat=allocstat) + if (allocstat /= 0) call fatal('stack', 'error increasing force stack size') + force_cells(1:stacksize,:) = force_cells_tmp(:,:) + deallocate(force_cells_tmp) + + stacksize = stacksize_new + call allocate_stack(force_stack_1, 1) + call allocate_stack(force_stack_2, 2) + call allocate_stack(dens_stack_1, dens_stack_1%number) + call allocate_stack(dens_stack_2, dens_stack_2%number) + call allocate_stack(dens_stack_3, dens_stack_3%number) +end subroutine increase_mpi_memory + +subroutine calculate_stacksize(npart) + use dim, only:mpi,minpart + use io, only:nprocs,id,master + integer, intent(in) :: npart + integer, parameter :: safety = 8 + + ! size of the stack needed for communication, + ! should be at least the maximum number of cells that need + ! to be exported to other tasks. + ! + ! if it is not large enough, it will be automatically expanded + + ! number of particles per cell, divided by number of tasks + if (mpi .and. nprocs > 1) then + ! assume that every cell will be exported, with some safety factor + stacksize = (npart / minpart / nprocs) * safety + + if (id == master) then + write(iprint, *) 'MPI memory stack size = ', stacksize + write(iprint, *) ' (total number of cells that can be exported by a single task)' + endif + else + stacksize = 0 + endif + +end subroutine calculate_stacksize + +subroutine deallocate_mpi_memory + if (allocated(dens_cells )) deallocate(dens_cells ) + if (allocated(force_cells)) deallocate(force_cells) +end subroutine deallocate_mpi_memory + +subroutine allocate_stack_dens(stack, i) + type(stackdens), intent(inout) :: stack + integer, intent(in) :: i + + stack%number = i + stack%cells => dens_cells(1:stacksize,stack%number) + stack%maxlength = stacksize + +end subroutine allocate_stack_dens + +subroutine allocate_stack_force(stack, i) + type(stackforce), intent(inout) :: stack + integer, intent(in) :: i + + stack%number = i + stack%cells => force_cells(1:stacksize,stack%number) + stack%maxlength = stacksize + +end subroutine allocate_stack_force + +subroutine swap_stacks_dens(stack_a, stack_b) + type(stackdens), intent(inout) :: stack_a + type(stackdens), intent(inout) :: stack_b + + integer :: temp_n + integer :: temp_number + + if (stack_a%maxlength /= stack_b%maxlength) call fatal('stack', 'stack swap of unequal size') + + ! counters + temp_n = stack_a%n + stack_a%n = stack_b%n + stack_b%n = temp_n + + ! addresses + temp_number = stack_a%number + stack_a%number = stack_b%number + stack_b%number = temp_number + + ! change pointers + stack_a%cells => dens_cells(1:stacksize,stack_a%number) + stack_b%cells => dens_cells(1:stacksize,stack_b%number) + +end subroutine swap_stacks_dens + +subroutine push_onto_stack_dens(stack,cell) + type(stackdens), intent(inout) :: stack + type(celldens), intent(in) :: cell + + integer :: i + + call reserve_stack(stack,i) + + ! no other thread will write to the same position, so it is threadsafe to write without a critical section + stack%cells(i) = cell +end subroutine push_onto_stack_dens + +subroutine push_onto_stack_force(stack,cell) + type(stackforce), intent(inout) :: stack + type(cellforce), intent(in) :: cell + + integer :: i + + call reserve_stack(stack,i) + + ! no other thread will write to the same position, so it is threadsafe to write without a critical section + stack%cells(i) = cell +end subroutine push_onto_stack_force + +type(celldens) function get_cell_dens(stack,i) + type(stackdens), intent(in) :: stack + integer, intent(in) :: i + + if (stack%n < i) call fatal('dens','attempting to read invalid stack address') + get_cell_dens = stack%cells(i) +end function get_cell_dens + +type(cellforce) function get_cell_force(stack,i) + type(stackforce), intent(in) :: stack + integer, intent(in) :: i + + if (stack%n < i) call fatal('force','attempting to read invalid stack address') + get_cell_force = stack%cells(i) +end function get_cell_force + +subroutine write_cell_dens(stack,cell) + type(stackdens), intent(inout) :: stack + type(celldens), intent(inout) :: cell + + if (cell%waiting_index > stack%maxlength) call fatal('dens','attempting to write to invalid stack address') + stack%cells(cell%waiting_index) = cell + +end subroutine write_cell_dens + +subroutine write_cell_force(stack,cell) + type(stackforce), intent(inout) :: stack + type(cellforce), intent(inout) :: cell + + if (cell%waiting_index > stack%maxlength) call fatal('force','attempting to write to invalid stack address') + stack%cells(cell%waiting_index) = cell + +end subroutine write_cell_force + +subroutine reserve_stack_dens(stack,i) + type(stackdens), intent(inout) :: stack + integer, intent(out) :: i + + !$omp atomic capture + stack%n = stack%n + 1 + i = stack%n + !$omp end atomic + + if (i > stack%maxlength) call fatal('dens','MPI stack exceeded') + +end subroutine reserve_stack_dens + +subroutine reserve_stack_force(stack,i) + type(stackforce), intent(inout) :: stack + integer, intent(out) :: i + + !$omp atomic capture + stack%n = stack%n + 1 + i = stack%n + !$omp end atomic + + if (i > stack%maxlength) call fatal('force','MPI stack exceeded') + +end subroutine reserve_stack_force + +subroutine reset_stacks + dens_stack_1%n=0 + dens_stack_2%n=0 + dens_stack_3%n=0 + + force_stack_1%n=0 + force_stack_2%n=0 +end subroutine reset_stacks + +end module mpimemory diff --git a/src/main/mpi_tree.F90 b/src/main/mpi_tree.F90 index 77f496c19..fe49e3c22 100644 --- a/src/main/mpi_tree.F90 +++ b/src/main/mpi_tree.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mpitree ! diff --git a/src/main/mpi_utils.F90 b/src/main/mpi_utils.F90 index 5dea33e2b..e725bc020 100644 --- a/src/main/mpi_utils.F90 +++ b/src/main/mpi_utils.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module mpiutils ! diff --git a/src/main/nicil_supplement.F90 b/src/main/nicil_supplement.F90 index 0f53c0ded..33533c07b 100644 --- a/src/main/nicil_supplement.F90 +++ b/src/main/nicil_supplement.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module nicil_sup ! diff --git a/src/main/nicil_supplement.f90 b/src/main/nicil_supplement.f90 new file mode 100644 index 000000000..c0d5fbfd3 --- /dev/null +++ b/src/main/nicil_supplement.f90 @@ -0,0 +1,236 @@ +!--------------------------------------------------------------------------! +! 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 nicil_sup +! +! Contains wrapper routines so that NICIL can be used in Phantom +! +! :References: Wurster (2016) +! Wurster (2021) +! +! :Owner: Daniel Price +! +! :Runtime parameters: +! - C_AD : *constant coefficient for ambipolar diffusion* +! - C_HE : *constant coefficient for the Hall effect (incl. sign)* +! - C_OR : *constant coefficient for ohmic resistivity* +! - Cdt_diff : *coefficient to control the Ohmic & ambipolar timesteps* +! - Cdt_hall : *coefficient to control the Hall timestep* +! - a0_grain : *grain radius (cm)* +! - alpha_AD : *power law exponent for ambipolar diffusion* +! - an_grain : *minimum grain radius (cm)* +! - ax_grain : *maximum grain radius (cm)* +! - eta_const_type : *Coefficient type: (1) phys.cnst+B+rho (2) C_NI+B+rho (3) constant* +! - eta_constant : *Use constant coefficients for all non-ideal MHD terms* +! - fdg : *dust-to-gas mass ratio* +! - gamma_AD : *ion-neutral coupling coefficient for ambipolar diffusion* +! - hall_lt_zero : *sign of the hall coefficient (<0 if T)* +! - n_e_cnst : *constant electron number density* +! - rho_bulk : *bulk grain density (g/cm^3)* +! - rho_i_cnst : *ionisation density for ambipolar diffusion* +! - rho_n_cnst : *neutral density for ambipolar diffusion* +! - use_ambi : *Calculate the coefficient for ambipolar diffusion* +! - use_hall : *Calculate the coefficient for the Hall effect* +! - use_ohm : *Calculate the coefficient for Ohmic resistivity* +! - zeta : *cosmic ray ionisation rate (s^-1)* +! +! :Dependencies: infile_utils, nicil, physcon +! + use nicil, only: use_ohm,use_hall,use_ambi,na, & + fdg,rho_bulk,a0_grain,an_grain,ax_grain,zeta_cgs,Cdt_diff,Cdt_hall, & + eta_constant,eta_const_type,icnstphys,icnstsemi,icnst,C_OR,C_HE,C_AD, & + n_e_cnst,hall_lt_zero,rho_i_cnst,rho_n_cnst,alpha_AD,gamma_AD + implicit none + ! + !--Subroutines + public :: use_consistent_gmw,write_options_nicil,read_options_nicil + + private + +contains + +!----------------------------------------------------------------------- +!+ +! Ensures a consistent meanmolecular mass is used +!+ +!----------------------------------------------------------------------- +subroutine use_consistent_gmw(ierr,gmw_eos,gmw_nicil) + use nicil, only:meanmolmass + integer, intent(out) :: ierr + real, intent(out) :: gmw_nicil + real, intent(inout) :: gmw_eos + + gmw_nicil = meanmolmass + if (abs(meanmolmass-gmw_eos) > epsilon(gmw_eos)) then + ierr = 1 + gmw_eos = meanmolmass + endif + +end subroutine use_consistent_gmw +!----------------------------------------------------------------------- +!+ +! writes input options to the input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_nicil(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + write(iunit,"(/,a)") '# options controlling non-ideal MHD' + call write_inopt(use_ohm , 'use_ohm' ,'Calculate the coefficient for Ohmic resistivity',iunit) + call write_inopt(use_hall, 'use_hall' ,'Calculate the coefficient for the Hall effect',iunit) + call write_inopt(use_ambi, 'use_ambi' ,'Calculate the coefficient for ambipolar diffusion',iunit) + call write_inopt(eta_constant,'eta_constant','Use constant coefficients for all non-ideal MHD terms',iunit) + if ( eta_constant ) then + call write_inopt(eta_const_type,'eta_const_type','Coefficient type: (1) phys.cnst+B+rho (2) C_NI+B+rho (3) constant',iunit) + if ( eta_const_type==1 ) then + if ( use_ohm .or. use_hall ) then + call write_inopt(n_e_cnst,'n_e_cnst' ,'constant electron number density',iunit) + if ( use_hall ) call write_inopt(hall_lt_zero, 'hall_lt_zero' ,'sign of the hall coefficient (<0 if T)',iunit) + endif + if ( use_ambi ) then + call write_inopt(gamma_AD, 'gamma_AD', 'ion-neutral coupling coefficient for ambipolar diffusion',iunit) + call write_inopt(rho_i_cnst, 'rho_i_cnst','ionisation density for ambipolar diffusion',iunit) + call write_inopt(rho_n_cnst, 'rho_n_cnst','neutral density for ambipolar diffusion',iunit) + call write_inopt(alpha_AD, 'alpha_AD', 'power law exponent for ambipolar diffusion',iunit) + endif + elseif ( eta_const_type==2 ) then + if ( use_ohm ) call write_inopt(C_OR,'C_OR', 'semi-constant coefficient for ohmic resistivity',iunit) + if ( use_hall ) call write_inopt(C_HE,'C_HE', 'semi-constant coefficient for the Hall effect (incl. sign)',iunit) + if ( use_ambi ) call write_inopt(C_AD,'C_AD', 'semi-constant coefficient for ambipolar diffusion',iunit) + elseif ( eta_const_type==3 ) then + if ( use_ohm ) call write_inopt(C_OR,'C_OR', 'constant coefficient for ohmic resistivity',iunit) + if ( use_hall ) call write_inopt(C_HE,'C_HE', 'constant coefficient for the Hall effect (incl. sign)',iunit) + if ( use_ambi ) call write_inopt(C_AD,'C_AD', 'constant coefficient for ambipolar diffusion',iunit) + endif + endif + call write_inopt(Cdt_diff, 'Cdt_diff', 'coefficient to control the Ohmic & ambipolar timesteps',iunit) + call write_inopt(Cdt_hall, 'Cdt_hall', 'coefficient to control the Hall timestep',iunit) + if ( .not. eta_constant ) then + write(iunit,"(/,a)") '# options controlling ionisation' + call write_inopt(fdg, 'fdg', 'dust-to-gas mass ratio',iunit) + call write_inopt(rho_bulk, 'rho_bulk', 'bulk grain density (g/cm^3)',iunit) + if ( na==1 ) then + call write_inopt(a0_grain, 'a0_grain', 'grain radius (cm)',iunit) + else + call write_inopt(an_grain, 'an_grain', 'minimum grain radius (cm)',iunit) + call write_inopt(ax_grain, 'ax_grain', 'maximum grain radius (cm)',iunit) + endif + call write_inopt(zeta_cgs, 'zeta', 'cosmic ray ionisation rate (s^-1)',iunit) + endif + +end subroutine write_options_nicil +!----------------------------------------------------------------------- +!+ +! reads input options from the input file +!+ +!----------------------------------------------------------------------- +subroutine read_options_nicil(name,valstring,imatch,igotall,ierr) + use physcon, only:fourpi + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer, intent(out) :: ierr + integer :: ngotmax + integer, save :: ngot = 0 + + !--Initialise parameters + imatch = .true. + igotall = .false. + !--Number of input parameters + ngotmax = 6 + + !--Read input parameters + select case(trim(name)) + case('use_ohm') + read(valstring,*,iostat=ierr) use_ohm + ngot = ngot + 1 + case('use_hall') + read(valstring,*,iostat=ierr) use_hall + ngot = ngot + 1 + case('use_ambi') + read(valstring,*,iostat=ierr) use_ambi + ngot = ngot + 1 + case('eta_constant') + read(valstring,*,iostat=ierr) eta_constant + ngot = ngot + 1 + if (eta_constant) then + ngotmax = ngotmax + 1 + else + ngotmax = ngotmax + 4 + if (na==1) ngotmax = ngotmax + 1 + endif + case('eta_const_type') + read(valstring,*,iostat=ierr) eta_const_type + ngot = ngot + 1 + if (eta_const_type==1) then + if (use_ohm ) ngotmax = ngotmax + 1 + if (use_hall) ngotmax = ngotmax + 2 + if (use_ambi) ngotmax = ngotmax + 4 + elseif (eta_const_type==2 .or. eta_const_type==3) then + if (use_ohm ) ngotmax = ngotmax + 1 + if (use_hall) ngotmax = ngotmax + 1 + if (use_ambi) ngotmax = ngotmax + 1 + endif + case('C_OR') + read(valstring,*,iostat=ierr) C_OR + ngot = ngot + 1 + case('C_HE') + read(valstring,*,iostat=ierr) C_HE + ngot = ngot + 1 + case('C_AD') + read(valstring,*,iostat=ierr) C_AD + ngot = ngot + 1 + case('n_e_cnst') + read(valstring,*,iostat=ierr) n_e_cnst + ngot = ngot + 1 + case('hall_lt_zero') + read(valstring,*,iostat=ierr) hall_lt_zero + ngot = ngot + 1 + case('gamma_AD') + read(valstring,*,iostat=ierr) gamma_AD + ngot = ngot + 1 + case('rho_i_cnst') + read(valstring,*,iostat=ierr) rho_i_cnst + ngot = ngot + 1 + case('rho_n_cnst') + read(valstring,*,iostat=ierr) rho_n_cnst + ngot = ngot + 1 + case('alpha_AD') + read(valstring,*,iostat=ierr) alpha_AD + ngot = ngot + 1 + case('fdg') + read(valstring,*,iostat=ierr) fdg + ngot = ngot + 1 + case('rho_bulk') + read(valstring,*,iostat=ierr) rho_bulk + ngot = ngot + 1 + case('a0_grain') + read(valstring,*,iostat=ierr) a0_grain + ngot = ngot + 1 + case('an_grain') + read(valstring,*,iostat=ierr) an_grain + ngot = ngot + 1 + case('ax_grain') + read(valstring,*,iostat=ierr) ax_grain + ngot = ngot + 1 + case('zeta') + read(valstring,*,iostat=ierr) zeta_cgs + ngot = ngot + 1 + case('Cdt_diff') + read(valstring,*,iostat=ierr) Cdt_diff + ngot = ngot + 1 + case('Cdt_hall') + read(valstring,*,iostat=ierr) Cdt_hall + ngot = ngot + 1 + case default + imatch = .false. + end select + if ( ngot >= ngotmax ) igotall = .true. + +end subroutine read_options_nicil + +!----------------------------------------------------------------------- +end module nicil_sup diff --git a/src/main/options.f90 b/src/main/options.f90 index 403d48be5..36bc7e5eb 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module options ! @@ -167,7 +167,6 @@ subroutine set_default_options endif implicit_radiation_store_drad = .false. - ! variable composition use_var_comp = .false. diff --git a/src/main/part.F90 b/src/main/part.F90 index 383d7f89b..652935668 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module part ! @@ -39,8 +39,6 @@ module part use krome_user, only: krome_nmols #endif implicit none - character(len=80), parameter, public :: & ! module version - modid="$Id$" ! !--basic storage needed for read/write of particle data ! @@ -57,6 +55,7 @@ module part character(len=*), parameter :: vxyzu_label(4) = (/'vx','vy','vz','u '/) character(len=*), parameter :: Bxyz_label(3) = (/'Bx','By','Bz'/) character(len=*), parameter :: Bevol_label(4) = (/'Bx/rho','By/rho','Bz/rho','psi '/) + character(len=*), parameter :: alphaind_label(3) = (/'alpha ','alphaloc','div_a '/) ! !--tracking particle IDs @@ -139,6 +138,13 @@ module part 'ne/nH: fraction of electrons ',& 'nCO/nH: fraction of Carbon Monoxide '/) +! +!--make a public krome_nmols variable to avoid ifdefs elsewhere +! +#ifndef KROME + integer, parameter :: krome_nmols = 0 +#endif + ! !--eos_variables ! @@ -223,9 +229,7 @@ module part integer, parameter :: ihall = 2 ! eta_hall integer, parameter :: iambi = 3 ! eta_ambi integer, parameter :: iion = 4 ! ionisation fraction -#ifdef NONIDEALMHD character(len=*), parameter :: eta_nimhd_label(4) = (/'eta_{OR}','eta_{HE}','eta_{AD}','ne/n '/) -#endif ! !-- Ray tracing : optical depth ! @@ -340,6 +344,7 @@ module part ! integer, parameter, private :: usedivcurlv = min(ndivcurlv,1) integer, parameter :: ipartbufsize = 129 + real :: hfact,Bextx,Bexty,Bextz integer :: npart integer(kind=8) :: ntot @@ -386,6 +391,7 @@ module part private :: hrho4,hrho8,hrho4_pmass,hrho8_pmass,hrhomixed_pmass private :: get_ntypes_i4,get_ntypes_i8 + contains subroutine allocate_part @@ -464,7 +470,6 @@ subroutine allocate_part call allocate_array('nucleation', nucleation, n_nucleation, maxp_nucleation*inucleation) call allocate_array('tau', tau, maxp*itau_alloc) call allocate_array('tau_lucy', tau_lucy, maxp*itauL_alloc) - if (use_krome) then call allocate_array('abundance', abundance, krome_nmols, maxp_krome) else @@ -472,6 +477,7 @@ subroutine allocate_part endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) + end subroutine allocate_part subroutine deallocate_part @@ -607,11 +613,11 @@ subroutine init_part endif if (store_dust_temperature) dust_temp = -1. !-- Initialise dust properties to zero -#ifdef DUSTGROWTH - dustprop(:,:) = 0. - dustgasprop(:,:) = 0. - VrelVf(:) = 0. -#endif + if (use_dustgrowth) then + dustprop(:,:) = 0. + dustgasprop(:,:) = 0. + VrelVf(:) = 0. + endif if (ind_timesteps) then ibin(:) = 0 ibin_old(:) = 0 @@ -1312,7 +1318,7 @@ subroutine reorder_particles(iorder,np) integer, intent(in) :: iorder(:) integer, intent(in) :: np - integer :: isrc + integer :: isrc,nbuf real :: xtemp(ipartbufsize) do i=1,np @@ -1324,7 +1330,7 @@ subroutine reorder_particles(iorder,np) enddo ! Swap particles around - call fill_sendbuf(i,xtemp) + call fill_sendbuf(i,xtemp,nbuf) call copy_particle_all(isrc,i,.false.) call unfill_buffer(isrc,xtemp) @@ -1430,12 +1436,12 @@ end subroutine change_status_pos ! to send to another processor !+ !---------------------------------------------------------------- -subroutine fill_sendbuf(i,xtemp) +subroutine fill_sendbuf(i,xtemp,nbuf) use io, only:fatal use mpiutils, only:fill_buffer integer, intent(in) :: i real, intent(out) :: xtemp(ipartbufsize) - integer :: nbuf + integer, intent(out) :: nbuf ! !--package particle information into one simple wrapper ! @@ -1511,9 +1517,8 @@ subroutine fill_sendbuf(i,xtemp) endif call fill_buffer(xtemp,iorig(i),nbuf) endif - if (nbuf /= ipartbufsize) call fatal('fill_sendbuf','error in send buffer size') + if (nbuf > ipartbufsize) call fatal('fill_sendbuf','error: send buffer size overflow',var='nbuf',ival=nbuf) - return end subroutine fill_sendbuf !---------------------------------------------------------------- @@ -1602,7 +1607,6 @@ subroutine unfill_buffer(ipart,xbuf) divBsymm(ipart) = 0. endif - return end subroutine unfill_buffer !---------------------------------------------------------------- diff --git a/src/main/phantom.F90 b/src/main/phantom.F90 index f8c0becf7..3046d69ba 100644 --- a/src/main/phantom.F90 +++ b/src/main/phantom.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantom ! diff --git a/src/main/photoevap.f90 b/src/main/photoevap.f90 deleted file mode 100644 index a985bf61b..000000000 --- a/src/main/photoevap.f90 +++ /dev/null @@ -1,432 +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 photoevap -! -! This module contains all the subroutines necessary for the -! photoevaporation switch -! -! :References: Alexander, Clarke & Pringle (2006), MNRAS 369, 216-228 -! -! :Owner: Daniel Price -! -! :Runtime parameters: -! - ionflux_cgs : *Stellar EUV flux rate* -! - mu_cgs : *Mean molecular weight* -! - recombrate_cgs : *Recombination rate (alpha)* -! -! :Dependencies: allocutils, dim, eos, externalforces, infile_utils, io, -! physcon, units -! - - implicit none - - !--# of grid nodes for photoevaporation grid - integer, parameter :: Nr = 400 - integer, parameter :: Nphi = 400 - integer, parameter :: Ntheta = 400 - - !--Index to identify which cell particles belong - integer, allocatable :: Rnum(:) - integer, allocatable :: Thetanum(:) - integer, allocatable :: Phinum(:) - - !--# of particles per cell and ray. - integer :: Cellpartnum(Nr-1,Ntheta-1,Nphi-1) - integer :: Raypartnum(Ntheta-1,Nphi-1) - - !--Location of ionization front and # of ionized particles in ray - integer :: Ionfront(Ntheta-1,Nphi-1) - integer :: Nion(Ntheta-1,Nphi-1) - - !--Reciprical of cell volume - real :: rCellvol(Nr-1,Nphi-1) - - !--Fraction of ions to neutrals in boundary cell - real :: Ionfrac(Ntheta-1,Nphi-1) - - !--Change in # of ions per unit time due to stellar flux (constant in time) - real :: dN_ion(Ntheta-1) - - !--Photoevaporation grid minimums and increment values - real :: Rgrid_min, Thetagrid_min, Phigrid_min - real :: dr_grid, dphi_grid, dtheta_grid - - !--Recombination rate, ionization flux, mean Mol. weight, temperature of ions - real :: recombrate - real :: recombrate_cgs = 2.6d-13 - real :: ionflux - real :: ionflux_cgs = 1.d41 - real :: mu - real :: mu_cgs = 1.26 - real :: mH - real :: temp_ion - real :: energy_to_temperature_ratio - - real :: prev_time - - public :: allocate_photoevap - public :: deallocate_photoevap - public :: write_options_photoevap - public :: read_options_photoevap - public :: photo_ionize - public :: find_ionfront - public :: set_photoevap_grid - - private - -contains - -!*************************************************************************************** -!*************************************************************************************** - -subroutine allocate_photoevap - use dim, only:maxp - use allocutils, only:allocate_array - - call allocate_array('Rnum', Rnum, maxp) - call allocate_array('Thetanum', Thetanum, maxp) - call allocate_array('Phinum', Phinum, maxp) - -end subroutine allocate_photoevap - -subroutine deallocate_photoevap - - deallocate(Rnum) - deallocate(Thetanum) - deallocate(Phinum) - -end subroutine deallocate_photoevap - -!---------------------------------------------------------------- -!+ -! This subroutine makes a spherical grid for photoevaporation -! Note: this routine is ment to be called only once at the -! beginning of the simulation to get the grid spacing. -!+ -!---------------------------------------------------------------- -subroutine set_photoevap_grid - use units, only:udist,umass,utime - use physcon, only:pi,atomic_mass_unit,mass_proton_cgs,kboltz,Rg - use externalforces, only:accradius1 - use eos, only:gamma - - integer :: i,j - - !--Inner and outer radius of grid - real :: R_in - real :: R_out - - !--Photoevaporation grid min and max in each direction - real :: Rgrid_max - real :: Thetagrid_max - real :: Phigrid_max - - !--photoevaporation grid in r,theta directions - real :: r_grid(Nr) - real :: theta_grid(Ntheta) - - !--TODO: try to read these in from setup_photoevap - R_in = accradius1 - R_out = 10.0 - - !--Set the temperature of ions to 10,000 K - temp_ion = 1.d4 - - !--Constant that converts specific energy density (u) to temperature in K. - ! Note: the (udist/utime)**2 comes from adding physical units back onto u. - !energy_to_temperature_ratio = Rg/(mu*(gamma-1.))/(udist/utime)**2 - energy_to_temperature_ratio = kboltz/((gamma-1.)*mu*atomic_mass_unit)*(utime/udist)**2 - - !--Mass of hydrogen gas molecule in code units - mH = mu*mass_proton_cgs/umass - - !--Time at previous time step (Initialized to zero here) - prev_time = 0. - - !--photoevaporation grid's inner/outer radius and other dimensions - Rgrid_min = R_in - Rgrid_max = 1.3*R_out - Thetagrid_min = 0. - Thetagrid_max = pi - Phigrid_min = -pi - Phigrid_max = pi - - !--photoevaporation grid spacing in each direction (with Nr x Nphi x Ntheta nodes) - dr_grid = (Rgrid_max - Rgrid_min )/(Nr-1) - dtheta_grid = (Thetagrid_max - Thetagrid_min)/(Ntheta-1) - dphi_grid = (Phigrid_max - Phigrid_min )/(Nphi-1) - - !--photoevaporation grid in r,theta directions - r_grid = (/( Rgrid_min + dr_grid*i , i = 0, Nr-1 )/) - theta_grid = (/( Thetagrid_min + dtheta_grid*i, i = 0, Ntheta-1 )/) - - do i = 1,Ntheta-1 - do j = 1,Nr-1 - !--Calculate the volume of each grid cell (symmetrical in phi so only need two dimensional array) - rCellvol(j,i) = (0.5*(r_grid(j)+r_grid(j+1)))**2*sin(0.5*(theta_grid(i)+theta_grid(i+1)))*dr_grid*dtheta_grid*dphi_grid - enddo - - !--Calculate the ionization rate in each ray (symmetrical in phi so only need one dimensional array) - dN_ion(i) = (0.25/pi*sin(0.5*(theta_grid(j)+theta_grid(j+1)))*dtheta_grid*dphi_grid)*ionflux - enddo - - !--Because the reciprical of Cellvol is only ever used: rCellvol = 1/Cellvol - rCellvol = 1./rCellvol - -end subroutine set_photoevap_grid - -!----------------------------------------------------------------------- -!+ -! Subroutine to identify in which grid cell particles reside, solve the -! ionization/recombination balance for each ray, and finally find the -! location for the ionization front. -!+ -!----------------------------------------------------------------------- -subroutine find_ionfront(timei,npart,xyzh,pmassi) - use io, only:fatal - integer, intent(in) :: npart - real, intent(in) :: timei - real, intent(in) :: pmassi - real, intent(in) :: xyzh(:,:) - - integer :: i,j,k - - !--Cumulative sum of particles along ray just below current cell - integer :: curr_ray_count - - !--Change in # of ions per unit time due to recombination rate - real :: dN_recomb - - !--Position of particle in spherical coordinates - real :: r_pos,theta_pos,phi_pos - - real :: pmass_on_mH - real :: dt - - !--Find how much time has elapsed since the last call - dt = timei - prev_time - - if ( dt == 0. ) then - print*,'WARNING! find_ionfront was called needlessly!' - else - - !--Gives the number of hydrogen gas molecules per SPH particle - pmass_on_mH = pmassi/mH - -!$omp parallel do private(i,r_pos,theta_pos,phi_pos) schedule(static) - do i = 1,npart - r_pos = sqrt(sum(xyzh(1:3,i)**2)) - theta_pos = acos(xyzh(3,i)/r_pos) - phi_pos = atan2(xyzh(2,i),xyzh(1,i)) - - ! Find the (*INTEGER*) grid node just below the particle in each direction - Rnum(i) = int((r_pos-Rgrid_min)/dr_grid)+1 - Thetanum(i) = int((theta_pos-Thetagrid_min)/dtheta_grid)+1 - Phinum(i) = int((phi_pos-Phigrid_min)/dphi_grid)+1 - enddo -!$omp end parallel do - - !--Re-initialize/re-calculate Cellpartnum every time step - Cellpartnum = 0 -!$omp parallel do private(i) schedule(static) - do i = 1,npart - Cellpartnum(Rnum(i),Thetanum(i),Phinum(i)) = Cellpartnum(Rnum(i),Thetanum(i),Phinum(i)) + 1 - enddo -!$omp end parallel do - - !--Find the total number of particles along each ray (used to speed up loop below if ray is empty) - Raypartnum(:,:) = sum(Cellpartnum,1) - - ! - !--Solve for ionization/recombination balance and update Nion, ionization - ! front, and fraction of ionized particles at the front - ! -!$omp parallel do default(none) & -!$omp private(i,j,k,dN_recomb,curr_ray_count) & -!$omp shared(Ionfrac,Ionfront,Raypartnum,Cellpartnum,rCellvol,recombrate,dN_ion,Nion,dt,pmass_on_mH) & -!$omp schedule(dynamic) - do i = 1,Nphi-1 - do j = 1,Ntheta-1 - !--Save radial location of ionfront for current ray in k - k = Ionfront(j,i) - - !--Find the change in Nion due to recombination - if ( k == 1 ) then - dN_recomb = Ionfrac(j,i)*Cellpartnum(k,j,i)**2*rCellvol(k,j) - else - dN_recomb = sum(Cellpartnum(1:k-1,j,i)**2*rCellvol(1:k-1,j)) + Ionfrac(j,i)*Cellpartnum(k,j,i)**2*rCellvol(k,j) - endif - dN_recomb = recombrate*dN_recomb*pmass_on_mH - - !--Update the # of ionized particles in each radial column - if ( Raypartnum(j,i) > 0 ) then - Nion(j,i) = Nion(j,i) + nint(dt*(dN_ion(j)/pmass_on_mH-dN_recomb)) - - !--Make sure that flux doesn't "build-up" in the fully ionized columns - ! (i.e. the excess light escapes the system) - if ( Nion(j,i) > Raypartnum(j,i) ) then - Nion(j,i) = Raypartnum(j,i) - endif - -!!!!!! -! print*,dN_ion(j)/pmass_on_mH,dN_recomb,Nion(j,i) -!!!!!! - - if ( Nion(j,i) < 0 ) then - print*,'Warning! Negative ion number!',Nion(j,i),j,i - Nion(j,i) = 0 - endif - else - Nion(j,i) = 0 !--If no particles, then Nion must be reset - endif - - !--Now that we have the # of ions in each column, integrate from the star - ! out to Nion to find where the ionization front is located - k = 1 - curr_ray_count = Cellpartnum(k,j,i) - do while ( curr_ray_count < Nion(j,i) ) - if ( k < Nr-1 ) then - k = k+1 - else - exit - endif - curr_ray_count = curr_ray_count + Cellpartnum(k,j,i) - enddo - - !--Save the new ionization front radial cell # for the next iteration - Ionfront(j,i) = k - - !--Find the fraction of ions to neutrals in the ionization front - ! This only needs to be done for cells with more particles than Nion - if ( Raypartnum(j,i) <= Nion(j,i) ) then - Ionfrac(j,i) = 1. - else - if ( Cellpartnum(k,j,i) == 0 ) then - Ionfrac(j,i) = 1. - else - Ionfrac(j,i) = (Nion(j,i)-(curr_ray_count-Cellpartnum(k,j,i)))/real(Cellpartnum(k,j,i)) - endif - endif - - if ( Ionfrac(j,i) < 0 ) then - call fatal('find_ionfront','Ionfrac is less than zero!') - elseif ( Ionfrac(j,i) > 1 ) then - call fatal('find_ionfront','Ionfrac is greater than 1!') - endif - - enddo - enddo -!$omp end parallel do - - prev_time = timei - endif - -end subroutine find_ionfront - -!----------------------------------------------------------------------- -!+ -! Update the temperatures of the particles (Ionized,Boundary,Neutral) -!+ -!----------------------------------------------------------------------- -subroutine photo_ionize(vxyzu,npart) - use io, only:fatal - integer, intent(in) :: npart - real, intent(inout) :: vxyzu(:,:) - - integer :: ipart - - !--Temperature of the particle in Kelvin - real :: temperature,tempi - - if ( size(vxyzu,1) /= 4 ) then - call fatal('photoevap','no u in vxyzu variable: compile with ISOTHERMAL=no') - endif - -!$omp parallel do default(none) & -!$omp private(ipart,tempi,temperature) & -!$omp shared(npart,vxyzu,energy_to_temperature_ratio,Rnum,Thetanum,Phinum,Ionfrac,Ionfront,temp_ion) - do ipart = 1,npart - tempi = vxyzu(4,ipart)/energy_to_temperature_ratio - - if ( Rnum(ipart) < Ionfront(Thetanum(ipart),Phinum(ipart)).or. & - Rnum(ipart) >= Nr ) then - ! Above ionization front (ionized particles) - temperature = temp_ion - - elseif ( Rnum(ipart) == Ionfront(Thetanum(ipart),Phinum(ipart)) ) then - ! Ionization front (fractionally ionized) - temperature = Ionfrac(Thetanum(ipart),Phinum(ipart))*temp_ion + & - (1.-Ionfrac(Thetanum(ipart),Phinum(ipart)))*tempi - - else - ! Below ionization front (neutral particles) - temperature = tempi - - endif - - vxyzu(4,ipart) = temperature*energy_to_temperature_ratio - - enddo -!$omp end parallel do - -end subroutine photo_ionize - -!----------------------------------------------------------------------- -!+ -! writes input options to the input file -!+ -!----------------------------------------------------------------------- -subroutine write_options_photoevap(iunit) - use infile_utils, only:write_inopt - - integer, intent(in) :: iunit - - write(iunit,"(/,a)") '# options controlling photoevaporation' - call write_inopt(mu_cgs,'mu_cgs','Mean molecular weight',iunit) - call write_inopt(recombrate_cgs,'recombrate_cgs','Recombination rate (alpha)',iunit) - call write_inopt(ionflux_cgs,'ionflux_cgs','Stellar EUV flux rate',iunit) - -end subroutine write_options_photoevap - -!----------------------------------------------------------------------- -!+ -! reads input options from the input file -!+ -!----------------------------------------------------------------------- -subroutine read_options_photoevap(name,valstring,imatch,igotall,ierr) - use units, only:udist,utime - - character(len=*), intent(in) :: name,valstring - logical, intent(out) :: imatch,igotall - integer, intent(out) :: ierr - integer, save :: ngot = 0 - - imatch = .false. - igotall = .true. - ierr = 0 - - select case(trim(name)) - case('mu_cgs') - read(valstring,*,iostat=ierr) mu_cgs - mu = mu_cgs - ngot = ngot + 1 - case('recombrate_cgs') - read(valstring,*,iostat=ierr) recombrate_cgs - recombrate = recombrate_cgs*utime/udist**3 - ngot = ngot + 1 - case('ionflux_cgs') - read(valstring,*,iostat=ierr) ionflux_cgs - ionflux = ionflux_cgs*utime - ngot = ngot + 1 - case default - imatch = .false. - end select - igotall = ( ngot >= 3 ) - -end subroutine read_options_photoevap - -end module photoevap diff --git a/src/main/physcon.f90 b/src/main/physcon.f90 index e395009e3..2577d5fd6 100644 --- a/src/main/physcon.f90 +++ b/src/main/physcon.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module physcon ! diff --git a/src/main/ptmass_heating.F90 b/src/main/ptmass_heating.f90 similarity index 100% rename from src/main/ptmass_heating.F90 rename to src/main/ptmass_heating.f90 diff --git a/src/main/ptmass_radiation.F90 b/src/main/ptmass_radiation.f90 similarity index 99% rename from src/main/ptmass_radiation.F90 rename to src/main/ptmass_radiation.f90 index d8bbb78ff..18954ec84 100644 --- a/src/main/ptmass_radiation.F90 +++ b/src/main/ptmass_radiation.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module ptmass_radiation ! diff --git a/src/main/quitdump.f90 b/src/main/quitdump.f90 index c2761ddbb..5f0159905 100644 --- a/src/main/quitdump.f90 +++ b/src/main/quitdump.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module quitdump ! diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index 8c9f3aeb2..468a0be97 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module radiation_utils ! diff --git a/src/main/random.f90 b/src/main/random.f90 index 6a8ea2ce0..e77444401 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module random ! diff --git a/src/main/readwrite_dumps.F90 b/src/main/readwrite_dumps.F90 index 2b33cbcf3..ff82e7935 100644 --- a/src/main/readwrite_dumps.F90 +++ b/src/main/readwrite_dumps.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module readwrite_dumps ! @@ -27,8 +27,13 @@ module readwrite_dumps public :: write_smalldump,write_fulldump,read_smalldump,read_dump,write_gadgetdump +#ifdef AOCC + logical, pointer, public :: opened_full_dump + logical, pointer, public :: dt_read_in +#else logical, pointer, public :: opened_full_dump => opened_full_dump_fortran ! for use in analysis files if user wishes to skip small dumps logical, pointer, public :: dt_read_in => dt_read_in_fortran ! to determine if dt has been read in so that ibin & ibinold can be set on restarts +#endif integer, parameter, public :: is_small_dump = 1978 integer, parameter, public :: is_not_mhd = 1979 diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index fa606f937..389bb7fef 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module readwrite_dumps_fortran ! @@ -19,7 +19,7 @@ module readwrite_dumps_fortran ! :Runtime parameters: None ! ! :Dependencies: boundary, boundary_dyn, checkconserved, dim, dump_utils, -! dust, dust_formation, eos, eos_stamatellos, externalforces, fileutils, io, lumin_nsdisc, +! dust, dust_formation, eos, externalforces, fileutils, io, lumin_nsdisc, ! memory, metric_tools, mpi, mpiutils, options, part, ! readwrite_dumps_common, setup_params, sphNGutils, timestep, units ! @@ -27,8 +27,6 @@ module readwrite_dumps_fortran i_real,i_real4,i_real8,int1,int2,int1o,int2o,dump_h,lentag use readwrite_dumps_common, only:check_arrays,fileident,get_options_from_fileid implicit none - character(len=80), parameter, public :: & ! module version - modid="$Id$" public :: write_smalldump_fortran,write_fulldump_fortran,read_smalldump_fortran,read_dump_fortran @@ -150,7 +148,6 @@ subroutine start_threadwrite(id,iunit,filename) endif endif - return end subroutine start_threadwrite !-------------------------------------------------------------------- @@ -179,7 +176,6 @@ subroutine end_threadwrite(id) endif #endif - return end subroutine end_threadwrite !-------------------------------------------------------------------- @@ -199,7 +195,6 @@ subroutine get_dump_size(fileid,smalldump) end subroutine get_dump_size - !-------------------------------------------------------------------- !+ ! subroutine to write output to full dump file @@ -234,8 +229,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) use lumin_nsdisc, only:beta #endif use metric_tools, only:imetric, imet_et - use eos_stamatellos, only:gradP_cool,Gpot_cool,doFLD,urad_FLD - + use eos_stamatellos, only:gradP_cool,doFLD,urad_FLD,ttherm_store,teqi_store,opac_store real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer, intent(in), optional :: iorder(:) @@ -243,7 +237,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) integer(kind=8), intent(in), optional :: ntotal integer, parameter :: isteps_sphNG = 0, iphase0 = 0 - integer(kind=8) :: ilen(4),i + integer(kind=8) :: ilen(4) integer :: nums(ndatatypes,4) integer :: ipass,k,l,ioffset integer :: ierr,ierrs(30) @@ -254,7 +248,6 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) character(len=120) :: blankarray type(dump_h) :: hdr real, allocatable :: temparr(:) - real :: r ! !--collect global information from MPI threads ! @@ -299,13 +292,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) !--open dumpfile ! 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)' - ! 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) - ! enddo - ! close(10) + if (idtmax_frac==0) then write(iprint,"(/,/,'--------> TIME = ',g12.4,': full dump written to file ',a,' <--------',/)") t,trim(dumpfile) else @@ -418,11 +405,13 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,ierrs(13),index=iZ) endif endif - ! write urad to file (stamatellos + FLD) - if (icooling == 9 .and. doFLD) then - call write_array(1,urad_FLD,'urad',npart,k,ipass,idump,nums,ierrs(13)) + ! 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)) + 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 call write_array(1,xyzh,xyzh_label,1,npart,k,ipass,idump,nums,ierrs(14),use_kind=4,index=4) if (maxalpha==maxp) call write_array(1,alphaind,(/'alpha'/),1,npart,k,ipass,idump,nums,ierrs(15)) @@ -434,11 +423,11 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) if (gravity .and. maxgrav==maxp) then call write_array(1,poten,'poten',npart,k,ipass,idump,nums,ierrs(17)) endif -#ifdef IND_TIMESTEPS - if (.not.allocated(temparr)) allocate(temparr(npart)) - temparr(1:npart) = dtmax/2**ibin(1:npart) - call write_array(1,temparr,'dt',npart,k,ipass,idump,nums,ierrs(18),use_kind=4) -#endif + if (ind_timesteps) then + if (.not.allocated(temparr)) allocate(temparr(npart)) + temparr(1:npart) = dtmax/2.**ibin(1:npart) + call write_array(1,temparr,'dt',npart,k,ipass,idump,nums,ierrs(18),use_kind=4) + endif call write_array(1,iorig,'iorig',npart,k,ipass,idump,nums,ierrs(29)) #ifdef PRDRAG @@ -450,10 +439,10 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) call write_array(1,temparr,'beta_pr',npart,k,ipass,idump,nums,ierrs(19)) endif #endif -#ifdef LIGHTCURVE if (lightcurve) then call write_array(1,luminosity,'luminosity',npart,k,ipass,idump,nums,ierrs(20)) endif + if (use_krome) then call write_array(1,abundance,abundance_label,krome_nmols,npart,k,ipass,idump,nums,ierrs(21)) call write_array(1,T_gas_cool,'temp',npart,k,ipass,idump,nums,ierrs(24)) @@ -462,6 +451,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) call write_array(1,eos_vars(imu,:),eos_vars_label(imu),npart,k,ipass,idump,nums,ierrs(12)) call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,ierrs(12)) endif + if (do_nucleation) then call write_array(1,nucleation,nucleation_label,n_nucleation,npart,k,ipass,idump,nums,ierrs(25)) endif @@ -507,12 +497,10 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) call write_array(4,divBsymm,'divBsymm',npart,k,ipass,idump,nums,ierrs(2)) endif if (any(ierrs(1:2) /= 0)) call error('write_dump','error writing MHD arrays') -#ifdef NONIDEALMHD if (mhd_nonideal) then call write_array(4,eta_nimhd,eta_nimhd_label,4,npart,k,ipass,idump,nums,ierrs(1)) if (ierrs(1) /= 0) call error('write_dump','error writing non-ideal MHD arrays') endif -#endif endif enddo if (ipass==1) call write_block_header(narraylengths,ilen,nums,idump,ierr) @@ -551,9 +539,6 @@ subroutine write_smalldump_fortran(t,dumpfile) 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 -#ifdef LIGHTCURVE - use part, only:luminosity -#endif real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer(kind=8) :: ilen(4) @@ -629,9 +614,8 @@ subroutine write_smalldump_fortran(t,dumpfile) if (use_dust) & call write_array(1,dustfrac,dustfrac_label,ndusttypes,npart,k,ipass,idump,nums,ierr,singleprec=.true.) call write_array(1,xyzh,xyzh_label,4,npart,k,ipass,idump,nums,ierr,index=4,use_kind=4) -#ifdef LIGHTCURVE + if (lightcurve) call write_array(1,luminosity,'luminosity',npart,k,ipass,idump,nums,ierr,singleprec=.true.) -#endif if (do_radiation) call write_array(1,rad,rad_label,maxirad,npart,k,ipass,idump,nums,ierr,singleprec=.true.) enddo ! @@ -657,7 +641,6 @@ subroutine write_smalldump_fortran(t,dumpfile) close(unit=idump) call end_threadwrite(id) - return end subroutine write_smalldump_fortran @@ -671,7 +654,7 @@ end subroutine write_smalldump_fortran subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ierr,headeronly,dustydisc) use memory, only:allocate_memory - use dim, only:maxp,maxvxyzu,gravity,lightcurve,mhd,maxp_hard + use dim, only:maxp,maxvxyzu,gravity,lightcurve,mhd,maxp_hard,inject_parts,mpi use io, only:real4,master,iverbose,error,warning ! do not allow calls to fatal in this routine use part, only:xyzh,vxyzu,massoftype,npart,npartoftype,maxtypes,iphase, & maxphase,isetphase,nptmass,nsinkproperties,maxptmass,get_pmass, & @@ -742,7 +725,7 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie ! ! read header from the dump file ! - call read_header(idisk1,hdr,tagged,ierr) + call read_header(idisk1,hdr,ierr,tagged=tagged) if (ierr /= 0) then call error('read_dump','error reading header from file') return @@ -809,19 +792,18 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie if (present(headeronly)) then if (headeronly) return endif - - if (iblock==1) then ! -!--Allocate main arrays +!--allocate main arrays ! - if (dynamic_bdy) then - call allocate_memory(int(maxp_hard,kind=8)) + if (iblock==1) then + if (dynamic_bdy .or. inject_parts) then + if (mpi) then + call allocate_memory(max(nparttot,int(maxp_hard/nprocs,kind=8))) + else + call allocate_memory(max(nparttot,int(maxp_hard,kind=8))) + endif else -#ifdef INJECT_PARTICLES - call allocate_memory(max(nparttot,int(maxp_hard,kind=8))) -#else call allocate_memory(nparttot) -#endif endif endif ! @@ -836,7 +818,6 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie npart = npart + npartread if (npartread <= 0 .and. nptmass <= 0) then - print*,' SKIPPING BLOCK npartread = ',npartread call skipblock(idisk1,nums(:,1),nums(:,2),nums(:,3),nums(:,4),tagged,ierr) if (ierr /= 0) then print*,' error skipping block' @@ -910,10 +891,14 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie call check_npartoftype(npartoftype,npart) write(iprint,"(a,/)") ' <<< ERROR! end of file reached in data read' ierr = 666 - return end subroutine read_dump_fortran +!-------------------------------------------------------------------- +!+ +! sanity check on npartoftype +!+ +!------------------------------------------------------------------- subroutine check_npartoftype(npartoftype,npart) integer, intent(inout) :: npartoftype(:) integer, intent(in) :: npart @@ -924,16 +909,16 @@ subroutine check_npartoftype(npartoftype,npart) endif end subroutine check_npartoftype + !-------------------------------------------------------------------- !+ ! subroutine to read a small dump from file, as written ! in write_smalldump !+ !------------------------------------------------------------------- - subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ierr,headeronly,dustydisc) use memory, only:allocate_memory - use dim, only:maxvxyzu,mhd,maxphase,maxp,maxp_hard + use dim, only:maxvxyzu,mhd,maxphase,maxp use io, only:real4,master,iverbose,error,warning ! do not allow calls to fatal in this routine use part, only:npart,npartoftype,maxtypes,nptmass,nsinkproperties,maxptmass, & massoftype @@ -941,7 +926,6 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro ierr_realsize,read_header,extract,free_header,read_block_header use mpiutils, only:reduce_mpi,reduceall_mpi use options, only:use_dustfrac - use boundary_dyn, only:dynamic_bdy character(len=*), intent(in) :: dumpfile real, intent(out) :: tfile,hfactfile integer, intent(in) :: idisk1,iprint,id,nprocs @@ -995,7 +979,7 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro ! !--single values ! - call read_header(idisk1,hdr,tagged,ierr,singleprec=.true.) + call read_header(idisk1,hdr,ierr,singleprec=.true.,tagged=tagged) if (ierr /= 0) then call error('read_smalldump','error reading header from file') return @@ -1017,17 +1001,10 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro call free_header(hdr,ierr) ! - !--Allocate main arrays + !--Allocate main arrays (no need for extra space here re: particle injection + ! as small dumps are only read for visualisation/analysis purposes) ! - if (dynamic_bdy) then - call allocate_memory(int(maxp_hard,kind=8)) - else -#ifdef INJECT_PARTICLES - call allocate_memory(int(maxp_hard,kind=8)) -#else - call allocate_memory(nparttot) -#endif - endif + call allocate_memory(nparttot) ! !--arrays ! @@ -1161,28 +1138,28 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto massoftype,nptmass,nsinkproperties,phantomdump,tagged,singleprec,& tfile,alphafile,idisk1,iprint,ierr) 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 - use part, only:xyzh,xyzh_label,vxyzu,vxyzu_label,dustfrac,abundance,abundance_label, & + 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 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, & Bevol,Bxyz,Bxyz_label,nabundances,iphase,idust, & eos_vars,eos_vars_label,maxeosvars,dustprop,dustprop_label,divcurlv,divcurlv_label,iX,iZ,imu, & 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,igasP,itemp + ithick,ilambda,iorig,dt_in,krome_nmols,T_gas_cool use sphNGutils, only:mass_sphng,got_mass,set_gas_particle_mass use options, only:use_porosity - use eos, only:ieos,eos_is_non_ideal,eos_outputs_gasP integer, intent(in) :: i1,i2,noffset,narraylengths,nums(:,:),npartread,npartoftype(:),idisk1,iprint real, intent(in) :: massoftype(:) integer, intent(in) :: nptmass,nsinkproperties logical, intent(in) :: phantomdump,singleprec,tagged real, intent(in) :: tfile,alphafile integer, intent(out) :: ierr - logical :: got_dustfrac(maxdusttypes) logical :: match - logical :: got_iphase,got_xyzh(4),got_vxyzu(4),got_abund(nabundances),got_alpha,got_poten + logical :: got_dustfrac(maxdusttypes) + logical :: got_iphase,got_xyzh(4),got_vxyzu(4),got_abund(nabundances),got_alpha(1),got_poten logical :: got_sink_data(nsinkproperties),got_sink_vels(3),got_Bxyz(3) 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 @@ -1205,8 +1182,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto got_sink_vels = .false. got_Bxyz = .false. got_psi = .false. - got_gasP = .false. - got_temp = .false. + got_eosvars = .false. got_dustprop = .false. got_VrelVf = .false. got_filfac = .false. @@ -1217,13 +1193,10 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto got_krome_gamma = .false. got_krome_mu = .false. got_krome_T = .false. - got_x = .false. - got_z = .false. - got_mu = .false. got_nucleation = .false. got_ray_tracer = .false. - got_raden = .false. - got_kappa = .false. + got_rad = .false. + got_radprop = .false. got_pxyzu = .false. got_iorig = .false. @@ -1284,16 +1257,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto if (store_dust_temperature) then call read_array(dust_temp,'Tdust',got_Tdust,ik,i1,i2,noffset,idisk1,tag,match,ierr) endif - 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 - call read_array(eos_vars(itemp,:),eos_vars_label(itemp),got_temp,ik,i1,i2,noffset,idisk1,tag,match,ierr) - 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) - if (maxalpha==maxp) call read_array(alphaind(1,:),'alpha',got_alpha,ik,i1,i2,noffset,idisk1,tag,match,ierr) + call read_array(eos_vars,eos_vars_label,got_eosvars,ik,i1,i2,noffset,idisk1,tag,match,ierr) + + if (maxalpha==maxp) call read_array(alphaind,(/'alpha'/),got_alpha,ik,i1,i2,noffset,idisk1,tag,match,ierr) ! ! read divcurlv if it is in the file ! @@ -1302,23 +1268,17 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto ! read gravitational potential if it is in the file ! if (gravity .and. maxgrav==maxp) call read_array(poten,'poten',got_poten,ik,i1,i2,noffset,idisk1,tag,match,ierr) -#ifdef IND_TIMESTEPS ! ! read dt if it is in the file ! - call read_array(dt_in,'dt',dt_read_in_fortran,ik,i1,i2,noffset,idisk1,tag,match,ierr) -#endif + if (ind_timesteps) call read_array(dt_in,'dt',dt_read_in_fortran,ik,i1,i2,noffset,idisk1,tag,match,ierr) + ! read particle ID's call read_array(iorig,'iorig',got_iorig,ik,i1,i2,noffset,idisk1,tag,match,ierr) if (do_radiation) then - call read_array(rad,rad_label,got_raden,ik,i1,i2,noffset,idisk1,tag,match,ierr) - call read_array(radprop(ikappa,:),radprop_label(ikappa),got_kappa,ik,i1,i2,noffset,idisk1,tag,match,ierr) - call read_array(radprop(ithick,:),radprop_label(ithick),got_kappa,ik,i1,i2,noffset,idisk1,tag,match,ierr) - call read_array(radprop(ilambda,:),radprop_label(ilambda),got_kappa,ik,i1,i2,noffset,idisk1,tag,match,ierr) - call read_array(radprop(ifluxx,:),radprop_label(ifluxx),got_kappa,ik,i1,i2,noffset,idisk1,tag,match,ierr) - call read_array(radprop(ifluxy,:),radprop_label(ifluxy),got_kappa,ik,i1,i2,noffset,idisk1,tag,match,ierr) - call read_array(radprop(ifluxz,:),radprop_label(ifluxz),got_kappa,ik,i1,i2,noffset,idisk1,tag,match,ierr) + call read_array(rad,rad_label,got_rad,ik,i1,i2,noffset,idisk1,tag,match,ierr) + call read_array(radprop,radprop_label,got_radprop,ik,i1,i2,noffset,idisk1,tag,match,ierr) endif case(2) call read_array(xyzmh_ptmass,xyzmh_ptmass_label,got_sink_data,ik,1,nptmass,0,idisk1,tag,match,ierr) @@ -1342,9 +1302,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto ! call check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkproperties,massoftype,& alphafile,tfile,phantomdump,got_iphase,got_xyzh,got_vxyzu,got_alpha, & - got_krome_mols,got_krome_gamma,got_krome_mu,got_krome_T,got_x,got_z,got_mu, & + got_krome_mols,got_krome_gamma,got_krome_mu,got_krome_T, & got_abund,got_dustfrac,got_sink_data,got_sink_vels,got_Bxyz,got_psi,got_dustprop,got_pxyzu,got_VrelVf, & - got_dustgasprop,got_temp,got_raden,got_kappa,got_Tdust,got_nucleation,got_iorig,iphase,& + 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) if (.not. phantomdump) then print *, "Calling set_gas_particle_mass" diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 45a96dd18..9f878498e 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -1,8 +1,8 @@ - !--------------------------------------------------------------------------! +!--------------------------------------------------------------------------! ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module step_lf_global ! @@ -33,9 +33,7 @@ module step_lf_global use part, only:radpred use timestep_ind, only:maxbins,itdt,ithdt,itdt1,ittwas implicit none - character(len=80), parameter, public :: & ! module version - modid="$Id$" - real :: ibin_dts(4,0:maxbins) + real :: ibin_dts(4,0:maxbins) contains @@ -94,7 +92,7 @@ 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 io, only:iprint,fatal,iverbose,id,master,warning - use options, only:iexternalforce,use_dustfrac,implicit_radiation,icooling + 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,& @@ -111,7 +109,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax use timestep, only:dtmax,dtmax_ifactor,dtdiff - use timestep_ind, only:get_dt,nbinmax,decrease_dtmax,ibinnow,dt_too_small + use timestep_ind, only:get_dt,nbinmax,decrease_dtmax,dt_too_small use timestep_sts, only:sts_get_dtau_next,use_sts,ibin_sts,sts_it_n use part, only:ibin,ibin_old,twas,iactive,ibin_wake use part, only:metricderivs @@ -134,8 +132,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) real, intent(out) :: dtnew integer :: i,its,np,ntypes,itype,nwake,nvfloorp,nvfloorps,nvfloorc,ialphaloc real :: timei,erri,errmax,v2i,errmaxmean - real :: vxi,vyi,vzi,eni,vxoldi,vyoldi,vzoldi,hdtsph,pmassi - real :: alphaloci,divvdti,source,tdecay1,hi,rhoi,ddenom,spsoundi + real :: vxi,vyi,vzi,eni,hdtsph,pmassi + real :: alphaloci,source,tdecay1,hi,rhoi,ddenom,spsoundi real :: v2mean,hdti real(kind=4) :: t1,t2,tcpu1,tcpu2 real :: pxi,pyi,pzi,p2i,p2mean @@ -195,8 +193,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! if (gr) then pxyzu(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) - elseif (icooling == 9) then - vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) else if (icooling /= 9) then vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) @@ -271,16 +267,16 @@ 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,icooling) & +!$omp shared(pxyzu,ppred) & !$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) & !$omp shared(alphaind,ieos,alphamax,ialphaloc) & -!$omp shared(eos_vars,ufloor) & +!$omp shared(eos_vars,ufloor,icooling) & !$omp shared(twas,timei) & !$omp shared(rad,drad,radpred)& !$omp private(hi,rhoi,tdecay1,source,ddenom,hdti) & -!$omp private(i,spsoundi,alphaloci,divvdti) & +!$omp private(i,spsoundi,alphaloci) & !$omp firstprivate(pmassi,itype,avdecayconst,alpha) & !$omp reduction(+:nvfloorps) predict_sph: do i=1,npart @@ -320,8 +316,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then ppred(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) - elseif (icooling == 9) then - vpred(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) else vpred(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif @@ -441,16 +435,16 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp parallel default(none) & !$omp shared(xyzh,vxyzu,vpred,fxyzu,npart,hdtsph,store_itype) & !$omp shared(pxyzu,ppred) & -!$omp shared(Bevol,dBevol,iphase,its,icooling) & +!$omp shared(Bevol,dBevol,iphase,its) & !$omp shared(dustevol,ddustevol,use_dustfrac) & !$omp shared(dustprop,ddustprop,dustproppred) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass,massoftype) & !$omp shared(dtsph,ieos,ufloor,icooling) & !$omp shared(ibin,ibin_old,ibin_sts,twas,timei,use_sts,dtsph_next,ibin_wake,sts_it_n) & -!$omp shared(ibin_dts,nbinmax,ibinnow) & +!$omp shared(ibin_dts,nbinmax) & !$omp private(dti,hdti) & !$omp shared(rad,radpred,drad)& -!$omp private(i,vxi,vyi,vzi,vxoldi,vyoldi,vzoldi) & +!$omp private(i,vxi,vyi,vzi) & !$omp private(pxi,pyi,pzi,p2i) & !$omp private(erri,v2i,eni) & !$omp reduction(max:errmax) & @@ -481,8 +475,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + dti*fxyzu(:,i) - elseif (icooling == 9) then - vxyzu(1:3,i) = vxyzu(1:3,i) + dti*fxyzu(1:3,i) else if (icooling /= 9) then vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) @@ -512,7 +504,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) elseif (icooling /= 9) then vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) else - vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) + vxyzu(1:3,i) = vxyzu(1:3,i) + dti*fxyzu(1:3,i) endif !--floor the thermal energy if requested and required @@ -542,15 +534,48 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ibin(i) = ibin_wake(i) ibin_wake(i) = 0 ! reset flag endif - endif + else ! not individual timesteps == global timestepping + ! + ! For velocity-dependent forces compare the new v + ! with the predicted v used in the force evaluation. + ! Determine whether or not we need to iterate. + ! - if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) + hdti*ddustprop(:,i) - if (itype==igas) then - if (mhd) Bevol(:,i) = Bevol(:,i) + hdti*dBevol(:,i) - if (do_radiation) rad(:,i) = rad(:,i) + hdti*drad(:,i) - if (use_dustfrac) then - dustevol(:,i) = dustevol(:,i) + hdti*ddustevol(:,i) - if (use_dustgrowth) dustprop(:,i) = dustprop(:,i) + hdti*ddustprop(:,i) + if (gr) then + pxi = pxyzu(1,i) + hdtsph*fxyzu(1,i) + pyi = pxyzu(2,i) + hdtsph*fxyzu(2,i) + pzi = pxyzu(3,i) + hdtsph*fxyzu(3,i) + eni = pxyzu(4,i) + hdtsph*fxyzu(4,i) + + erri = (pxi - ppred(1,i))**2 + (pyi - ppred(2,i))**2 + (pzi - ppred(3,i))**2 + errmax = max(errmax,erri) + + p2i = pxi*pxi + pyi*pyi + pzi*pzi + p2mean = p2mean + p2i + np = np + 1 + + pxyzu(1,i) = pxi + pxyzu(2,i) = pyi + pxyzu(3,i) = pzi + pxyzu(4,i) = eni + else + 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) + + erri = (vxi - vpred(1,i))**2 + (vyi - vpred(2,i))**2 + (vzi - vpred(3,i))**2 + errmax = max(errmax,erri) + + v2i = vxi*vxi + vyi*vyi + vzi*vzi + v2mean = v2mean + v2i + np = np + 1 + + vxyzu(1,i) = vxi + vxyzu(2,i) = vyi + vxyzu(3,i) = vzi + !--this is the energy equation if non-isothermal + if (maxvxyzu >= 4 .and. icooling/=9) vxyzu(4,i) = eni endif if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) + hdtsph*ddustprop(:,i) @@ -586,12 +611,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (.not.converged .and. npart > 0) then !$omp parallel do default(none)& !$omp private(i) & -!$omp shared(npart,hdtsph,icooling)& +!$omp shared(npart,hdtsph)& !$omp shared(store_itype,vxyzu,fxyzu,vpred,iphase) & !$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) & !$omp firstprivate(itype) & !$omp schedule(static) until_converged: do i=1,npart @@ -628,12 +653,10 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! if (gr) then pxyzu(:,i) = pxyzu(:,i) - hdtsph*fxyzu(:,i) + elseif (icooling /= 9) then + vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) else - if (icooling /= 9) then - vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) - else - vxyzu(1:3,i) = vxyzu(1:3,i) - hdtsph*fxyzu(1:3,i) - endif + vxyzu(1:3,i) = vxyzu(1:3,i) - hdtsph*fxyzu(1:3,i) endif if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) - hdtsph*ddustprop(:,i) if (itype==igas) then @@ -760,7 +783,7 @@ end subroutine step_extern_sph_gr subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) use dim, only:maxptmass,maxp,maxvxyzu - use io, only:iverbose,id,master,iprint,warning + 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,& @@ -776,7 +799,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:),pxyzu(:,:),dens(:),metrics(:,:,:,:),metricderivs(:,:,:,:) - integer :: i,itype,nsubsteps,naccreted,its,ierr + integer :: i,itype,nsubsteps,naccreted,its,ierr,nlive real :: timei,t_end_step,hdt,pmassi real :: dt,dtf,dtextforcenew,dtextforce_min real :: pri,spsoundi,pondensi,tempi,gammai @@ -871,7 +894,8 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me tempi = eos_vars(itemp,i) rhoi = rhoh(hi,massoftype(igas)) -! Note: grforce needs derivatives of the metric, which do not change between pmom iterations + ! Note: grforce needs derivatives of the metric, + ! which do not change between pmom iterations pmom_iterations: do while (its <= itsmax .and. .not. converged) its = its + 1 pprev = pxyz @@ -884,7 +908,8 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me if (pmom_err < ptol) converged = .true. fexti = fstar enddo pmom_iterations - if (its > itsmax ) call warning('step_extern_gr','Reached max number of pmom iterations. pmom_err ',val=pmom_err) + if (its > itsmax ) call warning('step_extern_gr',& + 'max # of pmom iterations',var='pmom_err',val=pmom_err) pitsmax = max(its,pitsmax) perrmax = max(pmom_err,perrmax) @@ -897,9 +922,11 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me its = 0 converged = .false. vxyz_star = vxyz -! Note: since particle positions change between iterations the metric and its derivatives need to be updated. -! cons2prim does not require derivatives of the metric, so those can updated once the iterations -! are complete, in order to reduce the number of computations. + ! Note: since particle positions change between iterations + ! the metric and its derivatives need to be updated. + ! cons2prim does not require derivatives of the metric, + ! so those can updated once the iterations are complete + ! in order to reduce the number of computations. xyz_iterations: do while (its <= itsmax .and. .not. converged) its = its+1 xyz_prev = xyz @@ -947,6 +974,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me ! accretedmass = 0. naccreted = 0 + nlive = 0 dtextforce_min = bignumber !$omp parallel default(none) & !$omp shared(npart,xyzh,metrics,metricderivs,vxyzu,fext,iphase,ntypes,massoftype,hdt,timei) & @@ -956,7 +984,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me !$omp private(pri,pondensi,spsoundi,tempi,dtf) & !$omp firstprivate(itype,pmassi) & !$omp reduction(min:dtextforce_min) & - !$omp reduction(+:accretedmass,naccreted) & + !$omp reduction(+:accretedmass,naccreted,nlive) & !$omp shared(idamp,damp_fac) !$omp do accreteloop: do i=1,npart @@ -990,11 +1018,16 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me naccreted = naccreted + 1 endif endif + nlive = nlive + 1 endif enddo accreteloop !$omp enddo !$omp end parallel + if (npart > 2 .and. nlive < 2) then + call fatal('step','all particles accreted',var='nlive',ival=nlive) + endif + if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a)") & 'Step: at time ',timei,', ',naccreted,' particles were accreted. Mass accreted = ',accretedmass @@ -1031,7 +1064,7 @@ end subroutine step_extern_gr !+ !---------------------------------------------------------------- subroutine step_extern_sph(dt,npart,xyzh,vxyzu) - use part, only:isdead_or_accreted,iboundary,iphase,iamtype + use part, only:isdead_or_accreted real, intent(in) :: dt integer, intent(in) :: npart real, intent(inout) :: xyzh(:,:) @@ -1039,7 +1072,7 @@ subroutine step_extern_sph(dt,npart,xyzh,vxyzu) integer :: i !$omp parallel do default(none) & - !$omp shared(npart,xyzh,vxyzu,dt,iphase) & + !$omp shared(npart,xyzh,vxyzu,dt) & !$omp private(i) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then @@ -1102,7 +1135,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) integer(kind=1), intent(in) :: nbinmax integer(kind=1), intent(inout) :: ibin_wake(:) - integer :: i,itype,nsubsteps,ichem,naccreted,nfail,nfaili,merge_n + integer :: i,itype,nsubsteps,naccreted,nfail,nfaili,merge_n,nlive integer :: merge_ij(nptmass) integer(kind=1) :: ibin_wakei real :: timei,hdt,fextx,fexty,fextz,fextxi,fextyi,fextzi,phii,pmassi @@ -1201,7 +1234,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, fonrmax = 0. !$omp parallel default(none) & !$omp shared(maxp,maxphase) & - !$omp shared(npart,xyzh,vxyzu,fext,abundance,iphase,ntypes,massoftype,fxyzu) & + !$omp shared(npart,xyzh,vxyzu,fext,abundance,iphase,ntypes,massoftype) & !$omp shared(eos_vars,dust_temp,store_dust_temperature) & !$omp shared(dt,hdt,timei,iexternalforce,extf_is_velocity_dependent,cooling_in_step,icooling) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,idamp,damp_fac) & @@ -1348,8 +1381,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, endif else ! cooling without stored dust temperature - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),dudtcool,rhoi,dt,dudti_sph=fxyzu(4,i),part_id=i) -! upstream version call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool) + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,dudti_sph=fxyzu(4,i),part_id=i) endif endif #endif @@ -1395,6 +1427,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, accretedmass = 0. nfail = 0 naccreted = 0 + nlive = 0 ibin_wakei = 0 dptmass(:,:) = 0. @@ -1407,7 +1440,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, !$omp reduction(+:dptmass) & !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & !$omp firstprivate(itype,pmassi,ibin_wakei) & - !$omp reduction(+:accretedmass,nfail,naccreted) + !$omp reduction(+:accretedmass,nfail,naccreted,nlive) !$omp do accreteloop: do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then @@ -1450,12 +1483,16 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, endif if (nfaili > 1) nfail = nfail + 1 endif + nlive = nlive + 1 endif - enddo accreteloop !$omp enddo !$omp end parallel + if (npart > 2 .and. nlive < 2) then + call fatal('step','all particles accreted',var='nlive',ival=nlive) + endif + ! ! reduction of sink particle changes across MPI ! diff --git a/src/utils/analysis_BRhoOrientation.F90 b/src/utils/analysis_BRhoOrientation.F90 index 3ba144698..73170e3e6 100644 --- a/src/utils/analysis_BRhoOrientation.F90 +++ b/src/utils/analysis_BRhoOrientation.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_clumpfind.F90 b/src/utils/analysis_clumpfind.F90 index 46bd494a2..697a4e1c1 100644 --- a/src/utils/analysis_clumpfind.F90 +++ b/src/utils/analysis_clumpfind.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_clumpfindWB23.F90 b/src/utils/analysis_clumpfindWB23.F90 index b11b2a975..da430b9ff 100644 --- a/src/utils/analysis_clumpfindWB23.F90 +++ b/src/utils/analysis_clumpfindWB23.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_common_envelope.F90 b/src/utils/analysis_common_envelope.F90 deleted file mode 100644 index 86ee7cb4f..000000000 --- a/src/utils/analysis_common_envelope.F90 +++ /dev/null @@ -1,4594 +0,0 @@ -!--------------------------------------------------------------------------! -! 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 analysis -! -! Analysis routine for common envelope simulations -! -! :References: None -! -! :Owner: Mike Lau -! -! :Runtime parameters: None -! -! :Dependencies: centreofmass, dust_formation, energies, eos, -! eos_gasradrec, eos_mesa, extern_corotate, io, ionization_mod, kernel, -! mesa_microphysics, part, physcon, prompting, ptmass, setbinary, -! sortutils, table_utils, units, vectorutils -! - - use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,poten,ihsoft,ihacc,& - rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted - use units, only:print_units,umass,utime,udist,unit_ergg,unit_density,& - unit_pressure,unit_velocity,unit_Bfield,unit_energ - use physcon, only:gg,pi,c,Rg - use io, only:fatal - use prompting, only:prompt - use centreofmass, only:get_centreofmass, reset_centreofmass - use energies, only:compute_energies,ekin,etherm,epot,etot - use ptmass, only:get_accel_sink_gas,get_accel_sink_sink - use kernel, only:kernel_softening,radkern,wkern,cnormk - use eos, only:equationofstate,ieos,init_eos,X_in,Z_in,gmw,get_spsound,done_init_eos - use eos_gasradrec,only:irecomb - use eos_mesa, only:get_eos_kappa_mesa,get_eos_pressure_temp_mesa,& - get_eos_various_mesa,get_eos_pressure_temp_gamma1_mesa - use setbinary, only:Rochelobe_estimate,L1_point - use sortutils, only:set_r2func_origin,r2func_origin,indexxfunc - use table_utils, only:logspace - implicit none - character(len=20), parameter, public :: analysistype = 'common_envelope' - integer :: analysis_to_perform - integer :: dump_number = 0 - real :: omega_corotate=0,init_radius,rho_surface,gamma - logical, dimension(5) :: switch = .false. - public :: do_analysis - public :: tconv_profile,get_interior_mass ! public = no unused fn warning - public :: planet_destruction,total_dust_mass ! make public to avoid compiler warning - private - -contains - -subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) - character(len=*), intent(in) :: dumpfile - integer, intent(in) :: num,npart,iunit - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real, intent(in) :: particlemass,time - integer :: unitnum,i,ncols - logical :: requires_eos_opts - - !case 5 variables - real :: rhopart - - !case 7 variables - character(len=17), allocatable :: columns(:) - - !case 12 variables - real :: etoti, ekini, einti, epoti, phii - - real, dimension(3) :: com_xyz, com_vxyz - real, dimension(3) :: xyz_a, vxyz_a - real, allocatable :: histogram_data(:,:) - real :: ang_vel - - real :: pres_1i, proint_1i, peint_1i, temp_1i - real :: troint_1i, teint_1i, entrop_1i, abad_1i, gamma1_1i, gam_1i - - !case 16 variables - real, allocatable :: thermodynamic_quantities(:,:) - real, allocatable :: radius_1i, dens_1i - - - !chose analysis type - if (dump_number==0) then - print "(41(a,/))", & - ' 1) Sink separation', & - ' 2) Bound and unbound quantities', & - ' 3) Energies', & - ' 4) Profile from centre of mass', & - ' 5) Roche-lobe utils', & - ' 6) Star stabilisation suite', & - ' 7) Simulation units and particle properties', & - ' 8) Output .divv', & - ' 9) EoS testing', & - '11) Profile of newly unbound particles', & - '12) Sink properties', & - '13) MESA EoS compute total entropy and other average td quantities', & - '14) MESA EoS save on file thermodynamical quantities for all particles', & - '15) Gravitational drag on sinks', & - '16) CoM of gas around primary core', & - '17) Miscellaneous', & - '18) J-E plane', & - '19) Rotation profile', & - '20) Energy profile', & - '21) Recombination statistics', & - '22) Optical depth profile', & - '23) Particle tracker', & - '24) Unbound ion fraction', & - '25) Optical depth at recombination', & - '26) Envelope binding energy', & - '27) Print dumps number matching separation', & - '28) Companion mass coordinate vs. time', & - '29) Energy histogram',& - '30) Analyse disk',& - '31) Recombination energy vs time',& - '32) Binding energy profile',& - '33) planet_rvm',& - '34) Velocity histogram',& - '35) Unbound temperature',& - '36) Planet mass distribution',& - '37) Planet profile',& - '38) Velocity profile',& - '39) Angular momentum profile',& - '40) Keplerian velocity profile',& - '41) Total dust mass' - analysis_to_perform = 1 - 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) - - ! List of analysis options that require specifying EOS options - requires_eos_opts = any((/2,3,4,5,6,8,9,11,13,14,15,20,21,22,23,24,25,26,29,30,31,32,33,35,41/) == analysis_to_perform) - if (dump_number == 0 .and. requires_eos_opts) call set_eos_options(analysis_to_perform) - - select case(analysis_to_perform) - case(1) !sink separation - call separation_vs_time(time) - case(2) !bound and unbound quantities - call bound_mass(time,npart,particlemass,xyzh,vxyzu) - case(3) !Energies and bound mass - call calculate_energies(time,npart,particlemass,xyzh,vxyzu) - case(4) !Profile from COM (can be used for stellar profile) - call create_profile(time, num, npart, particlemass, xyzh, vxyzu) - case(5) !Mass within roche lobes - call roche_lobe_values(time,npart,particlemass,xyzh,vxyzu) - case(6) !Star stabilisation suite - 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(9) !EoS testing - call eos_surfaces - case(11) !New unbound particle profiles in time - call unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) - case(19) ! Rotation profile - call rotation_profile(time,num,npart,xyzh,vxyzu) - case(20) ! Energy profile - call energy_profile(time,npart,particlemass,xyzh,vxyzu) - case(21) ! Recombination statistics - call recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) - case(22) ! Optical depth profile - call tau_profile(time,num,npart,particlemass,xyzh) - case(23) ! Particle tracker - call track_particle(time,particlemass,xyzh,vxyzu) - case(24) ! Unbound ion fractions - call unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) - case(25) ! Optical depth at recombination - call recombination_tau(time,npart,particlemass,xyzh,vxyzu) - case(26) ! Calculate binding energy outside core - call env_binding_ene(npart,particlemass,xyzh,vxyzu) - case(27) ! Print dump number corresponding to given set of sink-sink separations - call print_dump_numbers(dumpfile) - case(28) ! Companion mass coordinate (spherical mass shells) vs. time - call m_vs_t(time,npart,particlemass,xyzh) - case(29) ! Energy histogram - call energy_hist(time,npart,particlemass,xyzh,vxyzu) - case(30) ! Analyse disk around companion - call analyse_disk(num,npart,particlemass,xyzh,vxyzu) - case(31) ! Recombination energy vs. time - call erec_vs_t(time,npart,particlemass,xyzh) - case(32) ! Binding energy profile - call create_bindingEnergy_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(33) ! Planet coordinates and mass - call planet_rvm(time,particlemass,xyzh,vxyzu) - case(34) ! Velocity histogram - call velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) - case(35) ! Unbound temperatures - call unbound_temp(time,npart,particlemass,xyzh,vxyzu) - case(36) ! Planet mass distribution - call planet_mass_distribution(time,num,npart,xyzh) - case(37) ! Calculate planet profile - call planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) - case(38) ! Velocity profile - call velocity_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(39) ! Angular momentum profile - call angular_momentum_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(40) ! Keplerian velocity profile - call vkep_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(41) !Total dust mass - call total_dust_mass(time,npart,particlemass,xyzh) - case(12) !sink properties - call sink_properties(time,npart,particlemass,xyzh,vxyzu) - case(13) !MESA EoS compute total entropy and other average thermodynamical quantities - call bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) - case(14) !MESA EoS save on file thermodynamical quantities for all particles - allocate(thermodynamic_quantities(5,npart)) - do i=1,npart - - !particle radius - radius_1i = distance(xyzh(1:3,i)) * udist - - !particles density in code units - rhopart = rhoh(xyzh(4,i), particlemass) - dens_1i = rhopart * unit_density - - !gets entropy for the current particle - call get_eos_various_mesa(rhopart*unit_density,vxyzu(4,i) * unit_ergg, & - pres_1i,proint_1i,peint_1i,temp_1i,troint_1i, & - teint_1i,entrop_1i,abad_1i,gamma1_1i,gam_1i) - - !stores everything in an array - thermodynamic_quantities(1,i) = radius_1i - thermodynamic_quantities(2,i) = dens_1i - thermodynamic_quantities(3,i) = pres_1i - thermodynamic_quantities(4,i) = temp_1i - thermodynamic_quantities(5,i) = entrop_1i - - enddo - ncols = 5 - allocate(columns(ncols)) - columns = (/' radius', & - ' density', & - ' pressure', & - ' temperature', & - ' entropy'/) - call write_file('td_quantities', 'thermodynamics', columns, thermodynamic_quantities, npart, ncols, num) - - unitnum = unitnum + 1 - deallocate(thermodynamic_quantities) - - case(15) !Gravitational drag on sinks - call gravitational_drag(time,npart,particlemass,xyzh,vxyzu) - - case(16) - call get_core_gas_com(time,npart,xyzh,vxyzu) - - case(17) - ncols = 6 - allocate(columns(ncols)) - columns = (/' x', & - ' y', & - ' z', & - ' r', & - 'spec. energy', & - ' omega ratio'/) - - call orbit_com(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,com_xyz,com_vxyz) - - ang_vel = 0. - - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - xyz_a(1:3) = xyzmh_ptmass(1:3,i) - com_xyz(1:3) - vxyz_a(1:3) = vxyz_ptmass(1:3,i) - com_vxyz(1:3) - ang_vel = ang_vel + (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) - endif - enddo - - ang_vel = ang_vel / 2. - - allocate(histogram_data(6,npart)) - - do i=1,npart - xyz_a(1:3) = xyzh(1:3,i) - com_xyz(1:3) - vxyz_a(1:3) = vxyzu(1:3,i) - com_vxyz(1:3) - - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) - histogram_data(1:3,i) = xyzh(1:3,i) - histogram_data(4,i) = distance(xyz_a(1:3)) - histogram_data(5,i) = epoti + ekini - histogram_data(6,i) = (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) - histogram_data(6,i) = (histogram_data(6,i) - ang_vel) / ang_vel - enddo - - call write_file('specific_energy_particles', 'histogram', columns, histogram_data, size(histogram_data(1,:)), ncols, num) - - deallocate(histogram_data) - - case(18) - call J_E_plane(num,npart,particlemass,xyzh,vxyzu) - end select - !increase dump number counter - dump_number = dump_number + 1 - -end subroutine do_analysis - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!! Analysis routines !!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -subroutine total_dust_mass(time,npart,particlemass,xyzh) - use part, only:nucleation,idK3,idK0,idK1, idJstar - use dust_formation, only:set_abundances, mass_per_H - use physcon, only:atomic_mass_unit - real, intent(in) :: time,particlemass,xyzh(:,:) - integer, intent(in) :: npart - integer :: i,ncols,j - real, dimension(2) :: dust_mass - character(len=17), allocatable :: columns(:) - real, allocatable :: temp(:) !npart - real :: median,mass_factor,grain_size - real, parameter :: a0 = 1.28e-4 !radius of a carbon atom in micron - - call set_abundances !initialize mass_per_H - dust_mass = 0. - ncols = 2 - print *,'size(nucleation,1) = ',size(nucleation,1) - print *,'size(nucleation,2) = ',size(nucleation,2) - allocate(columns(ncols),temp(npart)) - columns = (/'Dust mass [Msun]', & - 'median size [um]'/) - j=0 - mass_factor = 12.*atomic_mass_unit*particlemass/mass_per_H - do i = 1,npart - if (.not. isdead_or_accreted(xyzh(4,i))) then - dust_mass(1) = dust_mass(1) + nucleation(idK3,i) *mass_factor - grain_size = a0*nucleation(idK1,i)/(nucleation(idK0,i)+1.0E-99) !in micron - if (grain_size > a0) then - j = j+1 - temp(j) = grain_size - endif - endif - enddo - - call sort(temp,j) - if (mod(j,2)==0) then !npart - median = (temp(j/2)+temp(j/2+1))/2.0 !(temp(npart/2)+temp(npart/2+1))/2.0 - else - median = (temp(j/2)+temp(j/2+1))/2.0 !temp(npart/2+1) - endif - - dust_mass(2) = median - - call write_time_file('total_dust_mass_vs_time', columns, time, dust_mass, ncols, dump_number) - !after execution of the analysis routine, a file named "total_dust_mass_vs_time.ev" appears - deallocate(columns,temp) - -end subroutine total_dust_mass - -! -------------------------------------------------------------------- -! integer function FindMinimum(): -! This function returns the location of the minimum in the section -! between Start and End. -! -------------------------------------------------------------------- - -integer function FindMinimum(x, Start, Fin) - implicit none - integer, intent(in) :: start, fin - real, dimension(Fin), intent(in) :: x - real :: minimum - integer :: location - integer :: i - - minimum = x(start) ! assume the first is the min - location = start ! record its position - do i = start+1, fin ! start with next elements - if (x(i) < minimum) then ! if x(i) less than the min? - minimum = x(i) ! yes, a new minimum found - location = i ! record its position - endif - enddo - findminimum = location ! return the position -end function FindMinimum - -! -------------------------------------------------------------------- -! subroutine Sort(): -! This subroutine receives an array x() and sorts it into ascending -! order. -! -------------------------------------------------------------------- - -subroutine Sort(x, longitud) - implicit none - integer, intent(in) :: longitud - real, dimension(longitud), intent(inout) :: x - integer :: i - integer :: location - - do i = 1, longitud-1 ! except for the last - location = findminimum(x, i, longitud) ! find min from this to last - call swap(x(i), x(location)) ! swap this and the minimum - enddo -end subroutine Sort - - -!---------------------------------------------------------------- -!+ -! Separation vs. time -!+ -!---------------------------------------------------------------- -subroutine separation_vs_time(time) - real, intent(in) :: time - character(len=17), allocatable :: columns(:) - real :: sink_separation(4,nptmass-1) - integer :: i,ncols - ncols = 4*(nptmass-1) - allocate(columns(ncols)) - - do i=1,(nptmass-1) - call separation_vector(xyzmh_ptmass(1:3,1),xyzmh_ptmass(1:3,i+1),sink_separation(1:4,i)) - - write(columns((i*4)-3), '(A11,I1)') ' x sep. ', i - write(columns((i*4)-2), '(A11,I1)') ' y sep. ', i - write(columns((i*4)-1), '(A11,I1)') ' z sep. ', i - write(columns((i*4)), '(A11,I1)') ' sep. ', i - enddo - - call write_time_file('separation_vs_time', columns, time, sink_separation, ncols, dump_number) - deallocate(columns) -end subroutine separation_vs_time - - -!---------------------------------------------------------------- -!+ -! Output planet position (x,y,z,r) and velocity (vx,vy,vz,|v|) -! relative to core, instantaneous mass according to different -! criteria (m1,m2,m3,m4,m5), max. density, and min. entropy -! -! For small dumps, only (x,y,z,r) and rhomax may be determined. -! All other quantities will be outputted as zero. -!+ -!---------------------------------------------------------------- -subroutine planet_rvm(time,particlemass,xyzh,vxyzu) - use eos, only:entropy - 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, allocatable :: data_cols(:),mass(:),vthreshold(:) - integer :: i,j,ncols,maxrho_ID,ientropy,Nmasks - integer, save :: nplanet - integer, allocatable, save :: planetIDs(:) - logical :: isfulldump - - if (.not. done_init_eos) call fatal("planet_rvm","EOS has not been initialised.") - - ncols = 15 - allocate(data_cols(ncols),columns(ncols)) - columns = (/' x sep', & - ' y sep', & - ' z sep', & - ' sep', & - ' vx', & - ' vy', & - ' vz', & - ' v', & - ' m1', & - ' m2', & - ' m3', & - ' m4', & - ' m5', & - ' rhomax', & - ' smin'/) - - if (dump_number == 0) call get_planetIDs(nplanet,planetIDs) - isfulldump = (vxyzu(4,1) > 0.) - - ! Find highest density and lowest entropy in planet - rhoprev = 0. - maxrho_ID = 1 - smin = huge(0.) - ientropy = 1 - ieos = 2 - gamma = 5./3. - do i = 1,nplanet - rhoi = rhoh(xyzh(4,planetIDs(i)), particlemass) - if (rhoi > rhoprev) then - maxrho_ID = planetIDs(i) - rhoprev = rhoi - endif - - if (isfulldump) then - presi = (gamma-1.)*vxyzu(4,i) - si = entropy(rhoi*unit_density,presi*unit_pressure,gmw,ientropy) - smin = min(smin,si) - endif - enddo - - planet_com = xyzh(1:3,maxrho_ID) - sep = planet_com - xyzmh_ptmass(1:3,1) - - if (isfulldump) then - planet_vel = vxyzu(1:3,maxrho_ID) - vel = planet_vel - vxyz_ptmass(1:3,1) - else - vel = 0. - smin = 0. - endif - - ! Sum planet mass according to criterion - Nmasks = 5 ! Number of velocity thresholds for calculating planet mass - allocate(mass(Nmasks),vthreshold(Nmasks)) - mass = 0. - if (isfulldump) then - Rthreshold = 0.21 ! Radius criterion to be considered part of planet - vthreshold = (/0.1,0.3,0.5,0.7,0.9/) ! Allowed fractional deviation in particle velocity from velocity of densest planet particle - do i = 1,nplanet - sepi = separation(xyzh(1:3,planetIDs(i)), planet_com) - do j = 1,Nmasks - if ( (sepi < Rthreshold) .and. (abs(1. - dot_product(vxyzu(1:3,planetIDs(i)),planet_vel)/& - dot_product(planet_vel,planet_vel)) < vthreshold(j)) ) then ! vi dot vp / vp^2 > threshold - mass(j:Nmasks) = mass(j:Nmasks) + 1. - exit - endif - enddo - enddo - mass = mass * particlemass - endif - - data_cols = (/ sep(1), sep(2), sep(3), distance(planet_com),& - vel(1), vel(2), vel(3), distance(vel),& - mass(1), mass(2), mass(3), mass(4), mass(5), rhoprev, smin /) - call write_time_file('planet_rvm', columns, time, data_cols, ncols, dump_number) - - deallocate(data_cols,columns,mass,vthreshold) - -end subroutine planet_rvm - - -!---------------------------------------------------------------- -!+ -! Output radial distribution of planetary material -!+ -!---------------------------------------------------------------- -subroutine planet_mass_distribution(time,num,npart,xyzh) - integer, intent(in) :: npart,num - real, intent(in) :: time - real, intent(inout) :: xyzh(:,:) - real, allocatable :: rad_part(:),dist_part(:),hist_var(:) - real :: mina,maxa,xyz_origin(3) - character(len=17) :: filename - character(len=100) :: data_formatter,headerline - integer :: i,iu,nbins - integer, save :: nplanet - integer, allocatable, save :: planetIDs(:) - - if (dump_number == 0) call get_planetIDs(nplanet,planetIDs) - - nbins = 1000 ! Radial bins - mina = 0. - maxa = 4.2 - - allocate(rad_part(nplanet),dist_part(nplanet),hist_var(nbins)) - filename = ' planet_m_dist.ev' - xyz_origin = xyzmh_ptmass(1:3,1) - - dist_part = 0. - rad_part = 0. - do i = 1,nplanet - rad_part(i) = separation(xyzh(1:3,planetIDs(i)),xyz_origin) - dist_part(i) = 1. - enddo - - call histogram_setup(rad_part,dist_part,hist_var,nplanet,maxa,mina,nbins,.false.,.false.) - - write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" - if (num == 0) then - open(newunit=iu, file=trim(adjustl(filename)), status='replace') - write(headerline, "(a,i5,a,f5.2,a,f5.2)") "# Planet mass distribution, nbins = ", nbins,", min a = ", mina, ", max a = ", maxa - write(iu, "(a)") headerline - close(unit=iu) - endif - open(newunit=iu, file=trim(adjustl(filename)), position='append') - write(iu,data_formatter) time,hist_var(:) - close(unit=iu) - - deallocate(rad_part,dist_part,hist_var) - -end subroutine planet_mass_distribution - - -!---------------------------------------------------------------- -!+ -! Companion mass coordinate (spherical mass shells) vs. time -!+ -!---------------------------------------------------------------- -subroutine m_vs_t(time,npart,particlemass,xyzh) - integer, intent(in) :: npart - real, intent(in) :: time,particlemass,xyzh(:,:) - character(len=17) :: colname - real :: sinksinksep,mass(1) - integer :: i,k - integer, allocatable :: iorder(:) - - allocate(iorder(npart)) - - call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) ! Order particles by distance from core - call indexxfunc(npart,r2func_origin,xyzh,iorder) - - sinksinksep = separation(xyzmh_ptmass(1:3,1), xyzmh_ptmass(1:3,2)) - do i=1,npart - k = iorder(i) - if (separation(xyzh(1:3,k), xyzmh_ptmass(1:3,1)) > sinksinksep) exit - enddo - - mass = i*particlemass + xyzmh_ptmass(4,1) - write(colname, '(A11)') ' mass coord' - call write_time_file(' m_vs_t',colname,time,mass,1,dump_number) - - deallocate(iorder) - -end subroutine m_vs_t - - -!---------------------------------------------------------------- -!+ -! Bound mass -!+ -!---------------------------------------------------------------- -subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp - use ptmass, only:get_accel_sink_gas - use ionization_mod, only:calc_thermal_energy - use vectorutils, only:cross_product3D - integer, intent(in) :: npart - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real :: etoti,ekini,epoti,phii,einti,ethi - real :: E_H2,E_HI,E_HeI,E_HeII - real, save :: Xfrac,Yfrac,Zfrac - real :: rhopart,ponrhoi,spsoundi,tempi,dum1,dum2,dum3 - real, dimension(3) :: rcrossmv - real, dimension(28) :: bound - integer :: i,bound_i,ncols - integer, parameter :: ib=1,ibt=9,ibe=17 - character(len=17), allocatable :: columns(:) - - if (.not. done_init_eos) call fatal("bound_mass","EOS has not been initialised.") - - ncols = 28 - bound = 0. - allocate(columns(ncols)) - columns = (/' b num part', & ! Total bound number of particles - ' b mass', & ! Total bound gas mass - ' b ang mom', & ! Total bound gas angular momentum wrt CoM of entire system - ' b tot en', & ! Total bound energy of gas - ' ub num part', & - ' ub mass', & - ' ub ang mom', & - ' ub tot en', & - ' bt num part', & ! As in comments above, but including thermal energy in criterion - ' bt mass', & - ' bt ang mom', & - ' bt tot en', & - 'ubt num part', & - ' ubt mass', & - ' ubt ang mom', & - ' ubt tot en', & - ' be num part', & - ' be mass', & - ' be ang mom', & - ' be tot en', & - 'ube num part', & - ' ube mass', & - ' ube ang mom', & - ' ube tot en', & - ' HeII bm', & ! Bound mass including recombination energy of HeII - ' HeII+HeI bm', & ! Bound mass including recombination energy of HeII, HeI - ' He+HI bm', & ! Bound mass including recombination energy of HeII, HeI, HI - ' He+HI+H2 bm'/) ! Bound mass including recombination energy of HeII, HeI, HI, H2 - - Zfrac = 0. - if (dump_number == 0) then - if (ieos /= 10 .and. ieos /= 20) then ! For MESA EoS, just use X_in and Z_in from eos module - Xfrac = 0.69843 - Zfrac = 0.01426 - call prompt('Enter hydrogen mass fraction to assume for recombination:',Xfrac,0.,1.) - call prompt('Enter metallicity to assume for recombination:',Zfrac,0.,1.) - else - Xfrac = X_in - Zfrac = Z_in - endif - Yfrac = 1. - Xfrac - Zfrac - endif - - ! Ionisation energies per particle (in code units) - E_H2 = 0.5*Xfrac*0.0022866 * particlemass - E_HI = Xfrac*0.0068808 * particlemass - E_HeI = 0.25*Yfrac*0.012442 * particlemass - E_HeII = 0.25*Yfrac*0.027536 * particlemass - - do i = 1,npart - if (.not. isdead_or_accreted(xyzh(4,i))) then - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) - call 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) - 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 - etoti = 0. - epoti = 0. - ekini = 0. - einti = 0. - ethi = 0. - phii = 0. - ponrhoi = 0. - rcrossmv = (/ 0., 0., 0. /) - endif - - ! Bound criterion - if ((epoti + ekini < 0.) .or. isdead_or_accreted(xyzh(4,i))) then - bound_i = ib - else - bound_i = ib + 4 ! Unbound - endif - - bound(bound_i) = bound(bound_i) + 1 - bound(bound_i + 1) = bound(bound_i + 1) + particlemass - bound(bound_i + 2) = bound(bound_i + 2) + distance(rcrossmv) - bound(bound_i + 3) = bound(bound_i + 3) + etoti - - ! Bound criterion INCLUDING thermal energy - if ((epoti + ekini + ethi < 0.) .or. isdead_or_accreted(xyzh(4,i))) then - bound_i = ibt - else - bound_i = ibt + 4 - endif - - bound(bound_i) = bound(bound_i) + 1 - bound(bound_i + 1) = bound(bound_i + 1) + particlemass - bound(bound_i + 2) = bound(bound_i + 2) + distance(rcrossmv) - bound(bound_i + 3) = bound(bound_i + 3) + etoti - - ! Bound criterion using enthalpy - if ((epoti + ekini + ethi + ponrhoi*particlemass < 0.) .or. isdead_or_accreted(xyzh(4,i))) then - bound_i = ibe - else - bound_i = ibe + 4 - endif - - bound(bound_i) = bound(bound_i) + 1 - bound(bound_i + 1) = bound(bound_i + 1) + particlemass - bound(bound_i + 2) = bound(bound_i + 2) + distance(rcrossmv) - bound(bound_i + 3) = bound(bound_i + 3) + etoti - - ! Bound criterion including HeI + HeII ionisation energy - if ((epoti + ekini + ethi + E_HeII < 0.) .or. isdead_or_accreted(xyzh(4,i))) then - bound(25) = bound(25) + particlemass - endif - - ! Bound criterion including HeI + HeII ionisation energy - if ((epoti + ekini + ethi + E_HeII + E_HeI < 0.) .or. isdead_or_accreted(xyzh(4,i))) then - bound(26) = bound(26) + particlemass - endif - - ! Bound criterion including HeI + HeII + HI ionisation energy - if ((epoti + ekini + ethi + E_HeII + E_HeI + E_HI < 0.) .or. isdead_or_accreted(xyzh(4,i))) then - bound(27) = bound(27) + particlemass - endif - - ! Bound criterion including HeI + HeII + HI + H2 ionisation energy - if ((epoti + ekini + ethi + E_HeII + E_HeI + E_HI + E_H2 < 0.) .or. isdead_or_accreted(xyzh(4,i))) then - bound(28) = bound(28) + particlemass - endif - enddo - - call write_time_file('boundunbound_vs_time', columns, time, bound, ncols, dump_number) - deallocate(columns) - -end subroutine bound_mass - - -!---------------------------------------------------------------- -!+ -! Calculate energies -!+ -!---------------------------------------------------------------- -subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) - use vectorutils, only:cross_product3D - 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 :: rhopart,ponrhoi,spsoundi,tempi,r_ij,radvel - real, dimension(3) :: rcrossmv - character(len=17), allocatable :: columns(:) - integer :: i, j, ncols - logical :: inearsink - integer, parameter :: ie_tot = 1 - integer, parameter :: ie_pot = ie_tot + 1 - integer, parameter :: ie_kin = ie_pot + 1 - integer, parameter :: ie_therm = ie_kin + 1 - integer, parameter :: ipot_sink = ie_therm + 1 - integer, parameter :: ikin_sink = ipot_sink + 1 - integer, parameter :: iorb_sink = ikin_sink + 1 - integer, parameter :: iorb_comp = iorb_sink + 1 - integer, parameter :: ipot_env = iorb_comp + 1 - integer, parameter :: ie_env = ipot_env + 1 - integer, parameter :: ikin_bound = ie_env + 1 - integer, parameter :: ikin_unbound = ikin_bound + 1 - integer, parameter :: imass_bound = ikin_unbound + 1 - integer, parameter :: imass_unbound = imass_bound + 1 - integer, parameter :: ipot_pp = imass_unbound + 1 - integer, parameter :: ipot_ps = ipot_pp + 1 - integer, parameter :: ijz_tot = ipot_ps + 1 - integer, parameter :: ijz_bound = ijz_tot + 1 - integer, parameter :: ijz_unbound = ijz_bound + 1 - integer, parameter :: ijz_orb = ijz_unbound + 1 - integer, parameter :: ie_gas = ijz_orb + 1 - integer, parameter :: fallbackmass = ie_gas + 1 - integer, parameter :: fallbackmom = fallbackmass + 1 - real, dimension(fallbackmom) :: encomp - - ncols = 23 - allocate(columns(ncols)) - columns = (/'total energy',& - ' pot energy',& - ' kin energy',& - 'therm energy',& - ' sink pot',& - ' sink kin',& - ' sink orb',& - ' comp orb',& - ' env pot',& - ' env energy',& - ' bound kin',& - ' unbound kin',& - ' bound mass',& - 'unbound mass',& - ' p-p pot',& - ' p-s pot',& - ' tot ang mom',& - ' b ang mom',& - ' ub ang mom',& - ' orb ang mom',& - ' gas energy',& - ' fallback',& - 'fallback mom'/) - - encomp(5:) = 0. - call compute_energies(time) - ekin = 0. - - do i=1,npart - encomp(ipot_pp) = encomp(ipot_pp) + poten(i) ! poten already includes factor of 1/2 to correct for double counting - encomp(ipot_env) = encomp(ipot_env) + poten(i) - - call cross_product3D(xyzh(1:3,i), particlemass * vxyzu(1:3,i), rcrossmv) - jz = rcrossmv(3) - encomp(ijz_tot) = encomp(ijz_tot) + jz - - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) - - encomp(ipot_ps) = encomp(ipot_ps) + particlemass * phii - - phii1 = 0. - call get_accel_sink_gas(1,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,fxi,fyi,fzi,phii1) - encomp(ipot_env) = encomp(ipot_env) + phii1 * particlemass - - do j=1,nptmass - if (xyzmh_ptmass(4,j) > 0.) then - r_ij = separation(xyzmh_ptmass(1:3,j),xyzh(1:3,i)) - if (r_ij < 80.) then - inearsink = .true. - endif - endif - enddo - - 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 (etoti < 0) then - encomp(ikin_bound) = encomp(ikin_bound) + ekini - encomp(imass_bound) = encomp(imass_bound) + particlemass - encomp(ijz_bound) = encomp(ijz_bound) + jz - radvel = dot_product(vxyzu(1:3,i),xyzh(1:3,i)) / distance(xyzh(1:3,i)) - - if (inearsink .eqv. .false.) then - if (radvel < 0.) then - encomp(fallbackmass) = encomp(fallbackmass) + particlemass - encomp(fallbackmom) = encomp(fallbackmom) + particlemass * radvel - endif - endif - - else - encomp(ikin_unbound) = encomp(ikin_unbound) + ekini - encomp(imass_unbound) = encomp(imass_unbound) + particlemass - encomp(ijz_unbound) = encomp(ijz_unbound) + jz - endif - enddo - - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - call cross_product3D(xyzmh_ptmass(1:3,i), xyzmh_ptmass(4,i)*vxyz_ptmass(1:3,i), rcrossmv) - jz = rcrossmv(3) - encomp(ijz_tot) = jz + encomp(ijz_tot) - encomp(ijz_orb) = jz + encomp(ijz_orb) - encomp(ikin_sink) = encomp(ikin_sink) + 0.5 * xyzmh_ptmass(4,i) * distance(vxyz_ptmass(1:3,i))**2 - if (i==2) encomp(iorb_comp) = encomp(iorb_comp) + 0.5 * xyzmh_ptmass(4,i) * distance(vxyz_ptmass(1:3,i))**2 - endif - enddo - - do i=1,nptmass-1 - if (xyzmh_ptmass(4,i) > 0.) then - do j=i+1,nptmass - if (xyzmh_ptmass(4,j) > 0.) then - r_ij = separation(xyzmh_ptmass(1:3,i),xyzmh_ptmass(1:3,j)) - encomp(ipot_sink) = encomp(ipot_sink) - xyzmh_ptmass(4,i) * xyzmh_ptmass(4,j) / r_ij - if (i==1 .and. j==2) encomp(iorb_comp) = encomp(iorb_comp) - xyzmh_ptmass(4,i) * xyzmh_ptmass(4,j) / r_ij - endif - enddo - endif - enddo - - ekin = encomp(ikin_bound) + encomp(ikin_unbound) + encomp(ikin_sink) - encomp(iorb_sink) = encomp(ipot_sink) + encomp(ikin_sink) - encomp(ie_env) = encomp(ipot_env) + etherm + encomp(ikin_bound) - epot = encomp(ipot_pp) + encomp(ipot_ps) + encomp(ipot_sink) - etot = epot + ekin + etherm - encomp(ie_gas) = encomp(ikin_bound) + encomp(ikin_unbound) + encomp(ipot_ps) - - encomp(ie_tot) = etot - encomp(ie_pot) = epot - encomp(ie_kin) = ekin - encomp(ie_therm) = etherm - - call write_time_file('energy', columns, time, encomp, ncols, dump_number) - deallocate(columns) - -end subroutine calculate_energies - - -!!!!! Create profile !!!!! -subroutine create_profile(time, num, npart, particlemass, xyzh, vxyzu) - integer, intent(in) :: npart, num - real, intent(in) :: time, particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17), allocatable :: columns(:) - real, save :: profile_vector(3) - integer :: ncols - character(len=15) :: name_in - real, allocatable :: profile(:,:) - - if (dump_number == 0) then - profile_vector=(/1.,0.,0./) - call prompt('Would you like simple profiles?', switch(1), .true.) - call prompt('Choose profile vector x-component ',profile_vector(1)) - call prompt('Choose profile vector y-component ',profile_vector(2)) - call prompt('Choose profile vector z-component ',profile_vector(3)) - endif - - if (switch(1)) then - ncols = 8 - else - ncols = 18 - endif - - if (all(profile_vector <= tiny(profile_vector))) then - write(*,*)'Using all particles!' - call stellar_profile(time,ncols,particlemass,npart,xyzh,vxyzu,profile,switch(1)) - write(name_in, "(a)") 'part_profile' - else - write(*,*)'Profile_vector is:',profile_vector - call stellar_profile(time,ncols,particlemass,npart,xyzh,vxyzu,profile,switch(1),profile_vector) - write(name_in, "(a,i1,i1,i1)") 'ray_profile_',int(profile_vector(1:3)) - endif - - allocate(columns(18)) - columns = (/' radius',& - ' mass coord',& - ' azimuth',& - ' density',& - ' velocity',& - ' rad. vel.',& - ' vxy tan.',& - ' omega',& !Simple creates up to here - ' int. energy',& - ' pressure',& - ' sound speed',& - ' temp',& - ' kappa',& - ' mfp',& - ' energy',& - ' HII frac',& - ' HeII frac',& - ' HeIII frac'/) - - call write_file(name_in, 'profile', columns, profile, size(profile(1,:)), ncols, num) - - deallocate(profile,columns) -end subroutine create_profile - - -!!!!! Roche lobe values !!!!! -subroutine roche_lobe_values(time,npart,particlemass,xyzh,vxyzu) - use vectorutils, only:cross_product3D - integer, intent(in) :: npart - real, intent(in) :: time, particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17), allocatable :: columns(:) - integer :: i, j, nFB, nR1T, ncols - integer, parameter :: iRL1 = 1 - integer, parameter :: iMRL1 = 2 - integer, parameter :: iBMRL1 = 3 - integer, parameter :: ijzRL1 = 4 - integer, parameter :: iRL2 = 5 - integer, parameter :: iMRL2 = 6 - integer, parameter :: iBMRL2 = 7 - integer, parameter :: ijzRL2 = 8 - integer, parameter :: iR1 = 9 - integer, parameter :: iR1T = 10 - integer, parameter :: iRej = 11 - integer, parameter :: iMej = 12 - integer, parameter :: iBMej = 13 - integer, parameter :: ijzej = 14 - integer, parameter :: iBjzej = 15 - integer, parameter :: iMF = 16 - integer, parameter :: ijzMF = 17 - integer, parameter :: iDR = 18 - integer, parameter :: iFB = 19 - integer, parameter :: iFBV = 20 - integer, parameter :: iFBJz = 21 - real, dimension(iFBJz) :: MRL - real :: etoti, ekini, einti, epoti, phii, jz - logical, dimension(:), allocatable, save:: transferred - real, save :: m1, m2 - real :: sep, sep1, sep2 - real :: rhovol, rhomass, rhopart, R1, rad_vel, sepCoO - real :: temp_const, ponrhoi, spsoundi, tempi - real, dimension(3) :: rcrossmv, CoO, com_xyz, com_vxyz - real, allocatable :: xyz_a(:,:) - integer :: npart_a, mean_rad_num - integer, allocatable :: iorder(:) - - allocate(iorder(npart),xyz_a(3,npart)) - - MRL = 0. - rhovol = 0. - rhomass = 0. - nFB = 0 - nR1T = 0 - temp_const = (unit_pressure / unit_density) * 1.34 / Rg - - if (dump_number == 0) then - m1 = npart * particlemass + xyzmh_ptmass(4,1) - m2 = xyzmh_ptmass(4,2) - allocate(transferred(npart)) - transferred(1:npart) = .false. - - rho_surface = rhoh(xyzh(4,1), particlemass) - do i=1,npart - rhopart = rhoh(xyzh(4,i), particlemass) - if (rhopart < rho_surface) then - rho_surface = rhopart - endif - enddo - endif - - mean_rad_num = npart / 200 - npart_a = 0 - - do i=1,npart - rhopart = rhoh(xyzh(4,i), particlemass) - if (rhopart > rho_surface) then - if (separation(xyzh(1:3,i), xyzmh_ptmass(1:3,1)) < & - separation(xyzh(1:3,i), xyzmh_ptmass(1:3,2))) then - rhomass = rhomass + particlemass - rhovol = rhovol + particlemass / rhopart - npart_a = npart_a + 1 - xyz_a(1:3,npart_a) = xyzh(1:3,i) - endif - endif - enddo - - call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) - call indexxfunc(npart_a,r2func_origin,xyz_a,iorder) - - R1 = 0 - do i=npart_a-mean_rad_num,npart_a - j = iorder(i) - R1 = R1 + separation(xyz_a(1:3,j),xyzmh_ptmass(1:3,1)) - enddo - - R1 = R1 / real(mean_rad_num) - - sep = separation(xyzmh_ptmass(1:3,1),xyzmh_ptmass(1:3,2)) - MRL(iRL1) = Rochelobe_estimate(m2,m1,sep) - MRL(iRL2) = Rochelobe_estimate(m1,m2,sep) - - !R1 = (3. * rhovol/(4. * pi))**(1./3.) - CoO(1:3) = (xyzmh_ptmass(1:3,1) + xyzmh_ptmass(1:3,2)) / 2. - MRL(iR1) = R1 - MRL(iRej) = separation(CoO(1:3),xyzmh_ptmass(1:3,1)) + R1 - - call orbit_com(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,com_xyz,com_vxyz) - - do i=1,npart - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) - - sep1 = separation(xyzmh_ptmass(1:3,1),xyzh(1:3,i)) - sep2 = separation(xyzmh_ptmass(1:3,2),xyzh(1:3,i)) - sepCoO = separation(CoO(1:3),xyzh(1:3,i)) - - call cross_product3D(xyzh(1:3,i)-com_xyz(1:3), particlemass * vxyzu(1:3,i), rcrossmv) - jz = rcrossmv(3) - - if (sep1 < MRL(iRL1)) then - MRL(iMRL1) = MRL(iMRL1) + particlemass - MRL(ijzRL1) = MRL(ijzRL1) + jz - if (etoti < 0) then - MRL(iBMRL1) = MRL(iBMRL1) + particlemass - endif - endif - - if (sep2 < MRL(iRL2)) then - MRL(iMRL2) = MRL(iMRL2) + particlemass - MRL(ijzRL2) = MRL(ijzRL2) + jz - - if (transferred(i) .eqv. .false.) then - MRL(iMF) = MRL(iMF) + particlemass - MRL(ijzMF) = MRL(ijzMF) + jz - transferred(i) = .true. - endif - - if (etoti < 0) then - MRL(iBMRL2) = MRL(iBMRL2) + particlemass - endif - endif - - if ((sep1 - xyzh(4,i) < R1) .and. (sep1 + xyzh(4,i) > R1)) then !!!!FIX THIS - call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - MRL(iR1T) = MRL(iR1T) + ponrhoi * temp_const - nR1T = nR1T + 1 - endif - - if (sepCoO > MRL(iRej)) then - rad_vel = dot_product(vxyzu(1:3,i),xyzh(1:3,i)) / distance(xyzh(1:3,i)) - - MRL(iMej) = MRL(iMej) + particlemass - MRL(ijzej) = MRL(ijzej) + jz - - if (etoti < 0) then - MRL(iBMej) = MRL(iBMej) + particlemass - MRL(iBjzej) = MRL(iBjzej) + jz - endif - - if (rad_vel < 0) then - MRL(iFB) = MRL(iFB) + particlemass - MRL(iFBV) = MRL(iFBV) + rad_vel - MRL(iFBJz) = MRL(iFBJz) + jz - nFB = nFB + 1 - endif - endif - enddo - - if (nR1T == 0) then - MRL(iR1T) = 0 - else - MRL(iR1T) = MRL(iR1T) / real(nR1T) - endif - - if (nFB == 0) then - MRL(iFBV) = 0 - else - MRL(iFBV) = MRL(iFBV) / real(nFB) - endif - - - - MRL(iMRL1) = MRL(iMRL1) + xyzmh_ptmass(4,1) - MRL(iMRL2) = MRL(iMRL2) + xyzmh_ptmass(4,2) - - MRL(iDR) = (R1 - MRL(iRL1)) / R1 - - call cross_product3D(xyzmh_ptmass(1:3,1) - com_xyz(1:3),xyzmh_ptmass(4,1) * vxyz_ptmass(1:3,1),rcrossmv) - MRL(ijzRL1) = MRL(ijzRL1) + rcrossmv(3) - - call cross_product3D(xyzmh_ptmass(1:3,2) - com_xyz(1:3),xyzmh_ptmass(4,2) * vxyz_ptmass(1:3,2),rcrossmv) - MRL(ijzRL2) = MRL(ijzRL2) + rcrossmv(3) - - m1 = rhomass + xyzmh_ptmass(4,1) - m2 = MRL(iMRL2) - - ncols = 21 - allocate(columns(ncols)) - columns = (/' RL1',& - ' Mass in RL1',& - ' B Mass RL1',& - ' jz in RL1',& - ' RL2',& - ' Mass in RL2',& - ' B Mass RL2',& - ' jz in RL2',& - ' R1',& - ' R1 temp',& - ' R_ejecta',& - 'Mass ejected',& - 'B Mass eject',& - ' jz ejected',& - ' B jz eject',& - ' Mass flow',& - 'Mass flow jz',& - ' R1-RL1/R1',& - ' Fallback',& - 'Fallback vel',& - ' Fallback Jz'/) - - call write_time_file('roche_lobes', columns, time, MRL, ncols, dump_number) - deallocate(columns,iorder) - -end subroutine roche_lobe_values - -!---------------------------------------------------------------- -!+ -! Star stabilisation -!+ -!---------------------------------------------------------------- -subroutine star_stabilisation_suite(time,npart,particlemass,xyzh,vxyzu) - use part, only:fxyzu - use eos, only:equationofstate - integer, intent(in) :: npart - real, intent(in) :: time, particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17), allocatable :: columns(:) - integer :: i,j,k,ncols,mean_rad_num,npart_a - 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 - integer, parameter :: ivoleqrad = 1 - integer, parameter :: idensrad = 2 - integer, parameter :: imassout = 3 - integer, parameter :: imassfracout = 4 - integer, parameter :: ipartrad = 5 - integer, parameter :: ipart2hrad = 6 - integer, parameter :: ipdensrad = 7 - integer, parameter :: ip2hdensrad = 8 - integer, parameter :: ivirialpart = 9 - integer, parameter :: ivirialfluid = 10 - - ncols = 10 - allocate(columns(ncols),star_stability(ncols),iorder(npart),iorder_a(npart)) - columns = (/'vol. eq. rad',& - ' density rad',& - 'mass outside',& - 'frac outside',& - ' part rad',& - ' part 2h rad',& - ' p dens rad',& - 'p2h dens rad',& - 'part. virial',& ! Residual of virial theorem for self-gravitating particles - 'fluid virial'/) ! Residual of virial theorem for fluid - - ! Get order of particles by distance from sink particle core - call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) - call indexxfunc(npart,r2func_origin,xyzh,iorder) - - ! Get density of outermost particle in initial star dump - if (dump_number == 0) then - rho_surface = rhoh(xyzh(4,iorder(npart)), particlemass) - endif - - npart_a = 0 - totvol = 0. - rhovol = 0. - virialpart = 0. - totekin = 0. - totepot = 0. - virialintegral= 0. - do i = 1,npart - rhopart = rhoh(xyzh(4,i), particlemass) - totvol = totvol + particlemass / rhopart ! Sum "volume" of all particles - virialpart = virialpart + particlemass * ( dot_product(fxyzu(1:3,i),xyzh(1:3,i)) + dot_product(vxyzu(1:3,i),vxyzu(1:3,i)) ) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) - totekin = totekin + ekini - totepot = totepot + 0.5*epoti ! Factor of 1/2 to correct for double counting - if (rhopart > rho_surface) then - ! Sum "volume" of particles within "surface" of initial star dump - rhovol = rhovol + particlemass / rhopart - npart_a = npart_a + 1 ! Count number of particles within "surface" of initial star dump - endif - ! Calculate residual of Virial theorem for fluid - if (ieos == 2) then - call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,gamma_local=gamma) - else - call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - endif - virialintegral = virialintegral + 3. * ponrhoi * particlemass - enddo - virialpart = virialpart / (abs(totepot) + 2.*abs(totekin)) ! Normalisation for the virial - virialfluid = (virialintegral + totepot) / (abs(virialintegral) + abs(totepot)) - - ! Sort particles within "surface" by radius - call indexxfunc(npart_a,r2func_origin,xyzh,iorder_a) - - mean_rad_num = npart / 200 ! 0.5 percent of particles - star_stability = 0. - ! Loop over the outermost npart/200 particles that are within the "surface" - do i = npart_a - mean_rad_num,npart_a - j = iorder(i) - k = iorder_a(i) - star_stability(ipartrad) = star_stability(ipartrad) + separation(xyzh(1:3,j),xyzmh_ptmass(1:3,1)) - star_stability(ipart2hrad) = star_stability(ipart2hrad) + separation(xyzh(1:3,j),xyzmh_ptmass(1:3,1)) + xyzh(4,j) - star_stability(ipdensrad) = star_stability(ipdensrad) + separation(xyzh(1:3,k),xyzmh_ptmass(1:3,1)) - star_stability(ip2hdensrad) = star_stability(ip2hdensrad) + separation(xyzh(1:3,k),xyzmh_ptmass(1:3,1)) + xyzh(4,j) - enddo - - star_stability(ipartrad) = star_stability(ipartrad) / real(mean_rad_num) - star_stability(ipart2hrad) = star_stability(ipart2hrad) / real(mean_rad_num) - star_stability(ipdensrad) = star_stability(ipdensrad) / real(mean_rad_num) - star_stability(ip2hdensrad) = star_stability(ip2hdensrad) / real(mean_rad_num) - star_stability(ivoleqrad) = (3. * totvol/(4. * pi))**(1./3.) - star_stability(idensrad) = (3. * rhovol/(4. * pi))**(1./3.) - star_stability(ivirialpart) = virialpart - star_stability(ivirialfluid)= virialfluid - - if (dump_number == 0) then - init_radius = star_stability(ivoleqrad) - endif - - star_stability(imassout) = 0. - total_mass = xyzmh_ptmass(4,1) - do i = 1,npart - if (separation(xyzmh_ptmass(1:3,1),xyzh(1:3,i)) > init_radius) then - star_stability(imassout) = star_stability(imassout) + particlemass - endif - total_mass = total_mass + particlemass - enddo - - star_stability(imassfracout) = star_stability(imassout) / total_mass - call write_time_file('star_stability', columns, time, star_stability, ncols, dump_number) - deallocate(columns,star_stability,iorder,iorder_a) - -end subroutine star_stabilisation_suite - - -!---------------------------------------------------------------- -!+ -! Print simulation parameters -!+ -!---------------------------------------------------------------- -subroutine print_simulation_parameters(npart,particlemass) - integer, intent(in) :: npart - real, intent(in) :: particlemass - integer :: i - - write(*,"(/,3(a,es10.3,1x),a)") ' Mass: ',umass, 'g Length: ',udist, 'cm Time: ',utime,'s' - write(*,"(3(a,es10.3,1x),a)") ' Density: ',unit_density, 'g/cm^3 Energy: ',unit_energ,'erg En/m: ',unit_ergg,'erg/g' - write(*,"(3(a,es10.3,1x),a)") ' Velocity: ',unit_velocity,'cm/s Bfield: ',unit_Bfield,'G Pressure: ',& - unit_pressure,'g/cm s^2' - write(*,"(2(a,es10.3,1x),/)") ' G: ', gg*umass*utime**2/udist**3,' c: ',c*utime/udist - - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - write(*,'(A,I2,A,ES10.3,A,ES10.3)') 'Point mass ',i,': M = ',xyzmh_ptmass(4,i),' and h_soft = ',xyzmh_ptmass(ihsoft,i) - endif - enddo - write(*,"(A,ES10.3)") 'Sink-sink separation: ', separation(xyzmh_ptmass(1:3,1), xyzmh_ptmass(1:3,2)) - - write(*,'(A,I7,A,ES10.3)') 'Gas particles : ',npart,' particles, each of mass ',particlemass - -end subroutine print_simulation_parameters - - -!---------------------------------------------------------------- -!+ -! Write quantities (up to four) to divv file -!+ -!---------------------------------------------------------------- -subroutine output_divv_files(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:calc_thermal_energy,ionisation_fraction - use dust_formation, only:psat_C,eps,set_abundances,mass_per_H, chemical_equilibrium_light, calc_nucleation!, Scrit - !use dim, only:nElements - integer, intent(in) :: npart - 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(:) - real :: ekini,einti,epoti,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(:) - 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, parameter :: Scrit = 2. ! Critical saturation ratio - logical :: verbose = .false. - - allocate(quant(4,npart)) - Nquantities = 14 - if (dump_number == 0) then - print "(14(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) - endif - - ! 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 - - !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)) - 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 - epsC = eps(3) - nucleation(idK3,i) - if (epsC < 0.) then - print *,'eps(C) =',eps(3),', K3=',nucleation(idK3,i),', epsC=',epsC,', T=',tempi,' rho=',rho_cgs - print *,'JKmuS=',nucleation(:,i) - stop '[S-dust_formation] epsC < 0!' - endif - if (tempi > 450.) then - !call chemical_equilibrium_light to obtain pC, and pC2H2 - call chemical_equilibrium_light(rho_cgs, tempi, epsC, pC, pC2, pC2H, pC2H2, nucleation(idmu,i), nucleation(idgamma,i)) - S = pC/psat_C(tempi) - if (S > Scrit) then - !call nucleation_function to obtain JstarS - call calc_nucleation(tempi, pC, 0., 0., 0., pC2H2, S, JstarS, taustar, taugr) - JstarS = JstarS/ nH_tot - endif - endif - !Check if the variables have meaningful values close to condensation temperatures - if (tempi >= 1400. .and. tempi <= 1500. .and. verbose ) then - print *,'size(nucleation,1) = ',size(nucleation,1) - print *,'size(nucleation,2) = ',size(nucleation,2) - print *,'nucleation(idK3,i) = ',nucleation(idK3,i) - 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 - 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),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 - 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 - case default - print*,"Error: Requested quantity is invalid." - stop - 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) - enddo - close(iu) - deallocate(quant) - -end subroutine output_divv_files - - - -!!!!! EoS surfaces !!!!! -subroutine eos_surfaces - integer :: i, j, ierr - real :: rho_array(1000) = (/ (10**(i/10000.), i=-180000,-30150,150) /) - real :: eni_array(1000) = (/ (10**(i/10000.), i=120000,149970,30) /) - real :: temp_array(400) = (/ (10**(i/1000.), i=3000,6990,10) /) - real :: kappa_array(1000,400) - real :: gam1_array(1000,1000) - real :: pres_array(1000,1000) - real :: dum(1000,1000) - real :: kappat, kappar - - - do i=1,size(rho_array) - do j=1,size(eni_array) - if (j < size(temp_array) + 1) then - call get_eos_kappa_mesa(rho_array(i),temp_array(j),kappa_array(i,j),kappat,kappar) - endif - call get_eos_pressure_temp_gamma1_mesa(rho_array(i),eni_array(j),pres_array(i,j),dum(i,j),gam1_array(i,j),ierr) - !call get_eos_pressure_temp_mesa(rho_array(i),eni_array(j),pres_array(i,j),temp) - !pres_array(i,j) = eni_array(j)*rho_array(i)*0.66667 / pres_array(i,j) - enddo - enddo - - open(unit=1000, file='mesa_eos_pressure.out', status='replace') - - !Write data to file - do i=1,1000 - write(1000,"(1000(3x,es18.11e2,1x))") pres_array(i,:) - enddo - - close(unit=1000) - - open(unit=1002, file='mesa_eos_gamma.out', status='replace') - - !Write data to file - do i=1,1000 - write(1002,"(1000(3x,es18.11e2,1x))") gam1_array(i,:) - enddo - - close(unit=1002) - - open(unit=1001, file='mesa_eos_kappa.out', status='replace') - - !Write data to file - do i=1,1000 - write(1001,"(400(3x,es18.11e2,1x))") kappa_array(i,:) - enddo - - close(unit=1001) - -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 - use mesa_microphysics, only:getvalue_mesa - use ionization_mod, only:calc_thermal_energy,ionisation_fraction - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - integer, parameter :: nparttotrack=10,ncols=17 - real :: r,v,rhopart,ponrhoi,Si,spsoundi,tempi,machi,xh0,xh1,xhe0,xhe1,xhe2,& - ekini,einti,epoti,ethi,etoti,dum,phii,pgas,mu - 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 /) - columns = (/ ' r',& - ' v',& - ' rho',& - ' temp',& - 'entropy',& - 'spsound',& - ' mach',& - ' ekin',& - ' epot',& - ' eth',& - ' eint',& - ' etot',& - ' xHI',& - ' xHII',& - ' xHeI',& - ' xHeII',& - ' xHeIII' /) - - call compute_energies(time) - - do i=1,nparttotrack - write (filenames(i),"(a1,i7.7)") "p", partID(i) - enddo - - do k=1,nparttotrack - i = partID(k) - 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) - 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 - 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 - 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) - endif - ! MESA ENTROPY - ! Si = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_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) - - ! Write file - datatable = (/ r,v,rhopart,eos_vars(itemp,i),Si,spsoundi,machi,ekini,epoti,ethi,einti,etoti,xh0,xh1,xhe0,xhe1,xhe2 /) - call write_time_file(trim(adjustl(filenames(k))),columns,time,datatable,ncols,dump_number) - enddo - -end subroutine track_particle - - -!---------------------------------------------------------------- -!+ -! Optical depth profile -!+ -!---------------------------------------------------------------- -subroutine tau_profile(time,num,npart,particlemass,xyzh) - use part, only:eos_vars,itemp - integer, intent(in) :: npart,num - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:) - integer :: nbins - real, allocatable :: rad_part(:),kappa_part(:),rho_part(:) - real, allocatable :: kappa_hist(:),rho_hist(:),tau_r(:),sepbins(:) - real :: maxloga,minloga,kappa,kappat,kappar - character(len=17) :: filename - character(len=40) :: data_formatter - integer :: i,unitnum - - call compute_energies(time) - nbins = 500 - - allocate(rad_part(npart),kappa_part(npart),rho_part(npart)) - rad_part = 0. - kappa_part = 0. - rho_part = 0. - minloga = 0.5 - maxloga = 4.3 - - allocate(rho_hist(nbins),kappa_hist(nbins),sepbins(nbins),tau_r(nbins)) - filename = ' grid_tau.ev' - - do i=1,npart - rho_part(i) = rhoh(xyzh(4,i), particlemass) - rad_part(i) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) - call get_eos_kappa_mesa(rho_part(i)*unit_density,eos_vars(itemp,i),kappa,kappat,kappar) - kappa_part(i) = kappa ! In cgs units? - enddo - - call histogram_setup(rad_part(1:npart),kappa_part,kappa_hist,npart,maxloga,minloga,nbins,.true.,.true.) - call histogram_setup(rad_part(1:npart),rho_part,rho_hist,npart,maxloga,minloga,nbins,.true.,.true.) - - - ! Integrate optical depth inwards - sepbins = (/ (10**(minloga + (i-1) * (maxloga-minloga)/real(nbins)), i=1,nbins) /) ! Create log-uniform bins - ! Convert to cgs units (kappa has already been outputted in cgs) - rho_hist = rho_hist * unit_density - sepbins = sepbins * udist ! udist should be Rsun in cm - - tau_r(nbins) = 0. - do i=nbins,2,-1 - tau_r(i-1) = tau_r(i) + kappa_hist(i) * rho_hist(i) * (sepbins(i+1) - sepbins(i)) - enddo - - ! Write data row - write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" - if (num == 0) then - unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(filename)), status='replace') - write(unitnum, "(a)") '# Optical depth profile' - close(unit=unitnum) - endif - unitnum=1002 - open(unit=unitnum, file=trim(adjustl(filename)), position='append') - write(unitnum,data_formatter) time,tau_r - close(unit=unitnum) - deallocate(rad_part,kappa_part,rho_part) - deallocate(rho_hist,kappa_hist,sepbins,tau_r) - -end subroutine tau_profile - -!---------------------------------------------------------------- -!+ -! Sound crossing time profile -!+ -!---------------------------------------------------------------- -subroutine tconv_profile(time,num,npart,particlemass,xyzh,vxyzu) - use part, only:itemp - use eos, only:get_spsound - use units, only:unit_velocity - integer, intent(in) :: npart,num - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - integer :: nbins - real, allocatable :: rad_part(:),cs_part(:) - real, allocatable :: cs_hist(:),tconv(:),sepbins(:) - real :: maxloga,minloga,rhoi - character(len=17) :: filename - character(len=40) :: data_formatter - integer :: i,unitnum - - call compute_energies(time) - nbins = 500 - allocate(rad_part(npart),cs_part(npart)) - rad_part = 0. - cs_part = 0. - minloga = 0.5 - maxloga = 4.3 - - allocate(cs_hist(nbins),sepbins(nbins),tconv(nbins)) - filename = ' grid_tconv.ev' - - do i=1,npart - rhoi = rhoh(xyzh(4,i), particlemass) - rad_part(i) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) - cs_part(i) = get_spsound(eos_type=ieos,xyzi=xyzh(:,i),rhoi=rhoi,vxyzui=vxyzu(:,i),gammai=gamma,mui=gmw,Xi=X_in,Zi=Z_in) - enddo - - call histogram_setup(rad_part(1:npart),cs_part,cs_hist,npart,maxloga,minloga,nbins,.true.,.true.) - - ! Integrate sound-crossing time from surface inwards - sepbins = (/ (10**(minloga + (i-1) * (maxloga-minloga)/real(nbins)), i=1,nbins) /) ! Create log-uniform bins - ! Convert to cgs units - cs_hist = cs_hist * unit_velocity - sepbins = sepbins * udist ! udist should be Rsun in cm - - tconv(nbins) = 0. - do i=nbins,2,-1 - if (cs_hist(i) < tiny(1.)) then - tconv(i-1) = tconv(i) - else - tconv(i-1) = tconv(i) + (sepbins(i+1) - sepbins(i)) / cs_hist(i) - endif - enddo - - ! Write data row - write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" - if (num == 0) then - unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(filename)), status='replace') - write(unitnum, "(a)") '# Sound crossing time profile' - close(unit=unitnum) - endif - unitnum=1002 - open(unit=unitnum, file=trim(adjustl(filename)), position='append') - write(unitnum,data_formatter) time,tconv - close(unit=unitnum) - - deallocate(rad_part,cs_part) - -end subroutine tconv_profile - - -!---------------------------------------------------------------- -!+ -! Histogram of optical depth at hydrogen recombination -!+ -!---------------------------------------------------------------- -subroutine recombination_tau(time,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy,ionisation_fraction - integer, intent(in) :: npart - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - integer :: nbins - integer, allocatable :: recombined_pid(:) - real, allocatable :: rad_part(:),kappa_part(:),rho_part(:) - real, allocatable, save:: tau_recombined(:) - 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 - real, parameter :: recomb_th=0.9 - integer :: i,j,nrecombined,bin_ind - - call compute_energies(time) - allocate(rad_part(npart),kappa_part(npart),rho_part(npart),recombined_pid(npart)) - rad_part = 0. - kappa_part = 0. - rho_part = 0. - nbins = 300 ! Number of radial bins - minloga = 0.5 - maxloga = 4.3 - allocate(rho_hist(nbins),kappa_hist(nbins),sepbins(nbins),sepbins_cm(nbins),tau_r(nbins)) - if (dump_number == 0) then - allocate(tau_recombined(npart),prev_recombined(npart)) - tau_recombined = -1. ! Store tau of newly-recombined particles. -ve data means particle never recombined] - prev_recombined = .false. ! All hydrogen is ionised at the start - endif - - j=0 - do i=1,npart - rho_part(i) = rhoh(xyzh(4,i), particlemass) - rad_part(i) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) - call equationofstate(ieos,ponrhoi,spsoundi,rho_part(i),xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call get_eos_kappa_mesa(rho_part(i)*unit_density,eos_vars(itemp,i),kappa,kappat,kappar) - kappa_part(i) = kappa ! In cgs units - call ionisation_fraction(rho_part(i)*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) ! Calculate total energy - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rho_part(i),eos_vars(itemp,i),ethi) - etoti = ekini + epoti + ethi - if ((xh0 > recomb_th) .and. (.not. prev_recombined(i)) .and. (etoti < 0.)) then ! Recombination event and particle is still bound - j=j+1 - recombined_pid(j) = i - prev_recombined(i) = .true. - else - prev_recombined(i) = .false. - endif - enddo - nrecombined = j - - call histogram_setup(rad_part(1:npart),kappa_part,kappa_hist,npart,maxloga,minloga,nbins,.true.,.true.) - call histogram_setup(rad_part(1:npart),rho_part,rho_hist,npart,maxloga,minloga,nbins,.true.,.true.) - - ! Integrate optical depth inwards - sepbins = (/ (10.**(minloga + (i-1) * (maxloga-minloga)/real(nbins)), i=1,nbins) /) ! Create log-uniform bins - - ! Convert to cgs units (kappa has already been outputted in cgs) - rho_hist = rho_hist * unit_density - sepbins_cm = sepbins * udist ! udist should be Rsun in g - - ! Integrate bins in tau(r) - tau_r(nbins) = 0. - do i=nbins,2,-1 - tau_r(i-1) = tau_r(i) + kappa_hist(i) * rho_hist(i) * (sepbins_cm(i+1) - sepbins_cm(i)) - enddo - - ! Integrate optical depth for each newly recombined particle - do j=1,nrecombined - i = recombined_pid(j) - bin_ind = 1 + nint( nbins * ( log10(rad_part(i))-minloga ) / (maxloga-minloga) ) ! Find radial bin of recombined particle - tau_recombined(i) = tau_r(bin_ind) - enddo - ! Trick write_time_file into writing my data table - if (dump_number == 320) then - do i=1,npart - call write_time_file("recombination_tau",(/' tau'/),-1.,tau_recombined(i),1,i-1) ! Set num = i-1 so that header will be written for particle 1 and particle 1 only - enddo - endif - deallocate(recombined_pid,rad_part,kappa_part,rho_part) - -end subroutine recombination_tau - - -!---------------------------------------------------------------- -!+ -! Energy histogram -!+ -!---------------------------------------------------------------- -subroutine energy_hist(time,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy - integer, intent(in) :: npart - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17), allocatable :: filename(:) - 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, allocatable :: quant(:) - logical :: ilogbins - - nhists = 3 - nbins = 500 - allocate(filename(nhists),coord(npart,nhists),hist(nbins),Emin(nhists),Emax(nhists)) - Emin = (/ -0.0446, 0., 0. /) - Emax = (/ 0.0315, 0.0105, 0.0105 /) - ilogbins = .false. - filename = (/ ' hist_kp.ev', & - ' hist_erec.ev', & - ' hist_eth.ev' /) - - allocate(quant(npart)) - quant = (/ (1., i=1,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),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 - ethi = einti - endif - coord(i,1) = (ekini + epoti)/particlemass - coord(i,2) = vxyzu(4,i) - ethi/particlemass - coord(i,3) = ethi/particlemass - enddo - - write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" - do i=1,nhists - call histogram_setup(coord(:,i),quant,hist,npart,Emax(i),Emin(i),nbins,.false.,ilogbins) - if (dump_number == 0) then - unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(filename(i))), status='replace') - close(unit=unitnum) - endif - unitnum=1001+i - open(unit=unitnum, file=trim(adjustl(filename(i))), status='old', position='append') - write(unitnum,data_formatter) time,hist - close(unit=unitnum) - enddo - deallocate(filename,coord,hist,Emin,Emax,quant) - -end subroutine energy_hist - - -!---------------------------------------------------------------- -!+ -! Energy profile -!+ -!---------------------------------------------------------------- -subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp - use eos, only:entropy - use mesa_microphysics, only:getvalue_mesa - use ionization_mod, only:calc_thermal_energy,ionisation_fraction - integer, intent(in) :: npart - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - integer :: nbins - real, allocatable :: coord(:) - real, allocatable :: hist(:),quant(:,:) - real :: ekini,einti,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 - integer :: i,k,unitnum,ierr,ientropy,nvars - integer, allocatable :: iorder(:) - integer, save :: iquantity - logical :: ilogbins - logical, save :: use_mass_coord - - if (dump_number==0) then - iquantity = 1 - use_mass_coord = .false. - print "(4(/,a))",'1. Energy',& - '2. Entropy',& - '3. Bernoulli energy',& - '4. Ion fractions' - call prompt("Select quantity to calculate",iquantity,1,4) - call prompt("Bin in mass coordinates instead of radius?",use_mass_coord) - endif - - nbins = 500 - allocate(hist(nbins)) - if (use_mass_coord) then - mincoord = 3.8405 ! Min. mass coordinate - maxcoord = 12.0 ! Max. mass coordinate - ilogbins = .false. - else - mincoord = 0.5 ! Min. log(r) - maxcoord = 4.3 ! Max. log(r) - ilogbins = .true. - endif - - call compute_energies(time) - - ! Allocate arrays for single variable outputs - if ( (iquantity==1) .or. (iquantity==2) .or. (iquantity==3) ) then - nvars = 1 - else - nvars = 5 - endif - allocate(filename(nvars),headerline(nvars),quant(npart,nvars),coord(npart)) - - coord = 0. - quant = 0. - select case (iquantity) - case(1) ! Energy - filename = ' grid_Etot.ev' - headerline = '# Energy profile ' - case(2) ! Entropy - filename = ' grid_entropy.ev' - headerline = '# Entropy profile' - select case(ieos) - case(2) - ientropy = 1 - case(12) - ientropy = 2 - case(10,20) - ientropy = 3 - case default - ientropy = -1 - end select - case(3) ! Bernoulli energy (per unit mass) - filename = 'grid_bernoulli.ev' - headerline = '# Bernoulli prof.' - case(4) ! Ion fraction profiles - filename = (/ ' grid_HI.ev', & - ' grid_HII.ev', & - ' grid_HeI.ev', & - ' grid_HeII.ev', & - ' grid_HeIII.ev' /) - headerline = (/ ' # HI', & - ' # HII', & - ' # HeI', & - ' # HeII', & - ' # HeIII' /) - end select - - allocate(iorder(npart)) - if (use_mass_coord) then - call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) ! Order particles by distance from core - call indexxfunc(npart,r2func_origin,xyzh,iorder) - else - iorder = (/(i, i=1,npart, 1)/) ! Have iorder(k) be same as k - endif - - do k=1,npart - i = iorder(k) ! Loop from innermost to outermost particle - if (use_mass_coord) then - coord(i) = real(k-1) ! Number of particles interior to particle k - else - coord(i) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) - endif - - 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)) - select case (iquantity) - case(1) ! Energy - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) - quant(i,1) = ekini + epoti + ethi - case(2) ! Entropy - if ((ieos==10) .and. (ientropy==2)) then - 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 - else - mu = gmw - endif - if ((ieos==10) .and. (ientropy==3)) then - quant(i,1) = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) - else - quant(i,1) = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,ierr=ierr) - endif - case(3) ! Bernoulli energy (per unit mass) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - 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) - quant(i,1) = xh0 - quant(i,2) = xh1 - quant(i,3) = xhe0 - quant(i,4) = xhe1 - quant(i,5) = xhe2 - end select - enddo - - if (use_mass_coord) coord = coord * particlemass + xyzmh_ptmass(4,1) - - write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" - do i=1,nvars - call histogram_setup(coord,quant(:,i),hist,npart,maxcoord,mincoord,nbins,.true.,ilogbins) - if (dump_number == 0) then - unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(filename(i))), status='replace') - write(unitnum, "(a)") trim(headerline(i)) - close(unit=unitnum) - endif - unitnum=1001+i - open(unit=unitnum, file=trim(adjustl(filename(i))), status='old', position='append') - write(unitnum,data_formatter) time,hist - close(unit=unitnum) - enddo - deallocate(iorder,coord,headerline,filename,quant,hist) - -end subroutine energy_profile - - -!---------------------------------------------------------------- -!+ -! Rotation profiles -!+ -!---------------------------------------------------------------- -subroutine rotation_profile(time,num,npart,xyzh,vxyzu) - use vectorutils, only:cross_product3D - integer, intent(in) :: npart,num - real, intent(in) :: time - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - integer :: nbins - real, allocatable :: rad_part(:) - real, allocatable :: hist_var(:),dist_part(:,:) - real :: minloga,maxloga,sep_vector(3),vel_vector(3),J_vector(3),xyz_origin(3),vxyz_origin(3),omega,vphi - character(len=17), allocatable :: grid_file(:) - character(len=40) :: data_formatter - integer :: i,unitnum,nfiles,iradius - - nbins = 500 - minloga = 0.5 - maxloga = 4.3 - iradius = 1 ! 1: Bin by cylindrical radius; 2: Bin by spherical radius; 3: Bin by cylindrical radius from CM - - nfiles = 2 - allocate(hist_var(nbins),grid_file(nfiles),dist_part(nfiles,npart),rad_part(npart)) - rad_part = 0. - dist_part = 0. - grid_file = (/ ' grid_omega.ev', & - ' grid_Jz.ev' /) - - select case (iradius) - case(1,2) ! Take donor core as origin - xyz_origin = xyzmh_ptmass(1:3,1) - vxyz_origin = vxyz_ptmass(1:3,1) - case(3) ! Take sink CM as origin - xyz_origin = (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)) - vxyz_origin = (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)) - end select - - do i=1,npart - select case (iradius) - case(1,3) ! Bin by cylindrical radius - rad_part(i) = sqrt( dot_product(xyzh(1:2,i) - xyz_origin(1:2), xyzh(1:2,i) - xyz_origin(1:2)) ) - case(2) ! Bin by spherical radius - rad_part(i) = separation(xyzh(1:3,i),xyz_origin) - end select - - call get_gas_omega(xyz_origin,vxyz_origin,xyzh(1:3,i),vxyzu(1:3,i),vphi,omega) - dist_part(1,i) = vphi - - sep_vector = xyzh(1:3,i) - xyz_origin(1:3) - vel_vector = vxyzu(1:3,i) - vxyz_origin(1:3) - call cross_product3D(vel_vector, sep_vector, J_vector) - dist_part(2,i) = dot_product(J_vector, (/0.,0.,1./)) - enddo - - do i=1,nfiles - call histogram_setup(rad_part(1:npart),dist_part(i,1:npart),hist_var,npart,maxloga,minloga,nbins,.true.,.true.) - write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" - if (num == 0) then - unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(grid_file(i))), status='replace') - write(unitnum, "(a)") '# z-component of angular velocity' - close(unit=unitnum) - endif - unitnum=1001+i - open(unit=unitnum, file=trim(adjustl(grid_file(i))), position='append') - write(unitnum,data_formatter) time,hist_var(:) - close(unit=unitnum) - enddo - deallocate(hist_var,grid_file,dist_part,rad_part) - -end subroutine rotation_profile - - -!---------------------------------------------------------------- -!+ -! Velocity distribution -!+ -!---------------------------------------------------------------- -subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy - real, intent(in) :: time,particlemass - integer, intent(in) :: npart,num - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - 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, 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),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))) - - if (ekini+epoti > 0.) then - vbound(i) = -1.e15 - vunbound(i) = vr(i) - else - vbound(i) = vr(i) - vunbound(i) = -1.e15 - endif - enddo - - ncols = npart - write(data_formatter, "(a,I6.6,a)") "(", ncols+1, "(2x,es18.11e2))" - file_name1 = "vel_bound.ev" - file_name2 = "vel_unbound.ev" - - if (dump_number == 0) then - open(newunit=iu1, file=file_name1, status='replace') - open(newunit=iu2, file=file_name2, status='replace') - else - open(newunit=iu1, file=file_name1, position='append') - open(newunit=iu2, file=file_name2, position='append') - endif - - write(iu1,data_formatter) time,vbound - write(iu2,data_formatter) time,vunbound - close(unit=iu1) - close(unit=iu2) - - deallocate(vbound,vunbound,vr) - -end subroutine velocity_histogram - - -!---------------------------------------------------------------- -!+ -! Velocity profile -!+ -!---------------------------------------------------------------- -subroutine velocity_profile(time,num,npart,particlemass,xyzh,vxyzu) - real, intent(in) :: time,particlemass - integer, intent(in) :: npart,num - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=40) :: data_formatter - character(len=40) :: file_name - integer :: i,nbins,iu,count - real :: rmin,rmax,xyz_origin(3),vxyz_origin(3),vphi,omega,& - theta1,theta2,tantheta1,tantheta2,tantheta - real, allocatable, dimension(:) :: rad_part,dist_part,hist - - nbins = 500 - rmin = 0. - rmax = 5. - - allocate(hist(nbins),dist_part(npart),rad_part(npart)) - dist_part = 0. - file_name = ' vphi_profile.ev' - - ! Select origin - xyz_origin = xyzmh_ptmass(1:3,1) - vxyz_origin = vxyz_ptmass(1:3,1) - - ! Masking in polar angle - theta1 = 75. ! Polar angle in deg - theta2 = 105. - tantheta1 = tan(theta1*3.14159/180.) - tantheta2 = tan(theta2*3.14159/180.) - - count = 0 - do i = 1,npart - rad_part(i) = sqrt( dot_product(xyzh(1:2,i) - xyz_origin(1:2), xyzh(1:2,i) - xyz_origin(1:2)) ) ! Cylindrical radius - - ! Masking in polar angle - tantheta = rad_part(i)/(xyzh(3,i) - xyzmh_ptmass(3,1)) - if ( (tantheta>0. .and. tanthetatantheta2) ) cycle - - call get_gas_omega(xyz_origin,vxyz_origin,xyzh(1:3,i),vxyzu(1:3,i),vphi,omega) - dist_part(i) = vphi - count = count + 1 - enddo - - call histogram_setup(rad_part,dist_part,hist,count,rmax,rmin,nbins,.true.,.false.) - write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" - if (num == 0) then - open(newunit=iu, file=trim(adjustl(file_name)), status='replace') - write(iu, "(a)") '# Azimuthal velocity profile' - close(unit=iu) - endif - open(newunit=iu, file=trim(adjustl(file_name)), position='append') - write(iu,data_formatter) time,hist - close(unit=iu) - deallocate(hist,dist_part,rad_part) - -end subroutine velocity_profile - - -!---------------------------------------------------------------- -!+ -! Specific z-angular momentum profile -!+ -!---------------------------------------------------------------- -subroutine angular_momentum_profile(time,num,npart,particlemass,xyzh,vxyzu) - real, intent(in) :: time,particlemass - integer, intent(in) :: npart,num - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=40) :: data_formatter - character(len=40) :: file_name - integer :: i,nbins,iu,count - real :: rmin,rmax,xyz_origin(3),vxyz_origin(3),& - theta1,theta2,tantheta1,tantheta2,tantheta - real, allocatable, dimension(:) :: rad_part,dist_part,hist - - nbins = 500 - rmin = 0. - rmax = 5. - - allocate(hist(nbins),dist_part(npart),rad_part(npart)) - dist_part = 0. - file_name = ' jz_profile.ev' - - ! Select origin - xyz_origin = xyzmh_ptmass(1:3,1) - vxyz_origin = vxyz_ptmass(1:3,1) - - ! Masking in polar angle - theta1 = 75. ! Polar angle in deg - theta2 = 105. - tantheta1 = tan(theta1*3.14159/180.) - tantheta2 = tan(theta2*3.14159/180.) - - count = 0 - do i = 1,npart - rad_part(i) = sqrt( dot_product(xyzh(1:2,i) - xyz_origin(1:2), xyzh(1:2,i) - xyz_origin(1:2)) ) ! Cylindrical radius - - ! Masking in polar angle - tantheta = rad_part(i)/(xyzh(3,i) - xyzmh_ptmass(3,1)) - if ( (tantheta>0. .and. tanthetatantheta2) ) cycle - - dist_part(i) = ( (xyzh(1,i)-xyz_origin(1))*(vxyzu(2,i)-vxyz_origin(2)) - & - (xyzh(2,i)-xyz_origin(2))*(vxyzu(1,i)-vxyz_origin(1)) ) - count = count + 1 - enddo - - call histogram_setup(rad_part,dist_part,hist,count,rmax,rmin,nbins,.true.,.false.) - write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" - if (num == 0) then - open(newunit=iu, file=trim(adjustl(file_name)), status='replace') - write(iu, "(a)") '# z-angular momentum profile' - close(unit=iu) - endif - open(newunit=iu, file=trim(adjustl(file_name)), position='append') - write(iu,data_formatter) time,hist - close(unit=iu) - -end subroutine angular_momentum_profile - - -!---------------------------------------------------------------- -!+ -! Keplerian velocity profile -!+ -!---------------------------------------------------------------- -subroutine vkep_profile(time,num,npart,particlemass,xyzh,vxyzu) - use sortutils, only:set_r2func_origin,r2func_origin,find_rank - use part, only:iorder=>ll - real, intent(in) :: time,particlemass - integer, intent(in) :: npart,num - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=40) :: data_formatter,file_name - integer :: i,nbins,iu - real :: rmin,rmax,massi,Mtot - real, allocatable :: hist(:),rad_part(:),dist_part(:) - - nbins = 500 - rmin = 0. - rmax = 5. - - allocate(hist(nbins),rad_part(npart),dist_part(npart)) - dist_part = 0. - file_name = ' vkep_profile.ev' - - call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) - call find_rank(npart,r2func_origin,xyzh(1:3,:),iorder) - - Mtot = npart*particlemass - do i = 1,npart - massi = Mtot * real(iorder(i)-1) / real(npart) + xyzmh_ptmass(4,1) - rad_part(i) = separation( xyzh(1:3,i), xyzmh_ptmass(1:3,1) ) - dist_part(i) = sqrt(massi/rad_part(i)) - enddo - - call histogram_setup(rad_part,dist_part,hist,npart,rmax,rmin,nbins,.true.,.false.) - write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" - if (num == 0) then - open(newunit=iu, file=trim(adjustl(file_name)), status='replace') - write(iu, "(a)") '# Keplerian velocity profile' - close(unit=iu) - endif - open(newunit=iu, file=trim(adjustl(file_name)), position='append') - write(iu,data_formatter) time,hist - close(unit=iu) - deallocate(hist,dist_part,rad_part) - -end subroutine vkep_profile - - -!---------------------------------------------------------------- -!+ -! Planet profile -!+ -!---------------------------------------------------------------- -subroutine planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) - character(len=*), intent(in) :: dumpfile - integer, intent(in) :: num - real, intent(in) :: particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=40) :: file_name - integer :: i,maxrho_ID,iu - integer, save :: nplanet - integer, allocatable, save :: planetIDs(:) - real :: rhoprev - real, dimension(3) :: planet_com,planet_vcom,vnorm,ri,Rvec - real, allocatable :: R(:),z(:),rho(:) - - if (dump_number ==0 ) call get_planetIDs(nplanet,planetIDs) - allocate(R(nplanet),z(nplanet),rho(nplanet)) - - ! Find highest density in planet - rhoprev = 0. - maxrho_ID = planetIDs(1) - do i = 1,nplanet - rho(i) = rhoh(xyzh(4,planetIDs(i)), particlemass) - if (rho(i) > rhoprev) then - maxrho_ID = planetIDs(i) - rhoprev = rho(i) - endif - enddo - planet_com = xyzh(1:3,maxrho_ID) - planet_vcom = vxyzu(1:3,maxrho_ID) - vnorm = planet_vcom / sqrt(dot_product(planet_vcom,planet_vcom)) - - ! Write to file - file_name = trim(dumpfile)//".planetpart" - open(newunit=iu, file=file_name, status='replace') - - ! Record R and z cylindrical coordinates w.r.t. planet_com - do i = 1,nplanet - ri = xyzh(1:3,planetIDs(i)) - planet_com ! Particle position w.r.t. planet_com - z(i) = dot_product(ri, vnorm) - Rvec = ri - z(i)*vnorm - R(i) = sqrt(dot_product(Rvec,Rvec)) - ! write(iu,"(es13.6,2x,es13.6,2x,es13.6)") R(i),z(i),rho(i) - write(iu,"(es13.6,2x,es13.6,2x,es13.6,2x,es13.6,2x,es13.6)") xyzh(1,i),xyzh(2,i),xyzh(3,i),rho(i),vxyzu(4,i) - enddo - - close(unit=iu) - deallocate(R,z,rho) - -end subroutine planet_profile - - -!---------------------------------------------------------------- -!+ -! Unbound profiles -!+ -!---------------------------------------------------------------- -subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) - use ionization_mod, only:calc_thermal_energy - integer, intent(in) :: npart,num - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - 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 :: 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 - nbins = 500 - rad_part = 0. ! (4,npart_hist)-array storing separations of particles - dist_part = 0. - 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' /) - - if (dump_number == 0) then - allocate(prev_bound(2,npart)) - allocate(prev_unbound(2,npart)) - prev_bound = .false. - prev_unbound = .false. - endif - - - 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),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 - - ! 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 - endif - 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,& - .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 - unitnum = 1000 - open(unit=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') - - write(unitnum,"()") - write(unitnum,data_formatter) time,hist_var(:) - - close(unit=unitnum) - enddo - deallocate(hist_var) - -end subroutine unbound_profiles - - -!---------------------------------------------------------------- -!+ -! Unbound ion fractions: Look at distribution of ion fraction when given particle is unbound -!+ -!---------------------------------------------------------------- -subroutine unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) - use ionization_mod, only:calc_thermal_energy,get_xion,ionisation_fraction - integer, intent(in) :: npart - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17) :: columns(5) - integer :: i - real :: etoti,ekini,einti,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(:,:) - - columns = (/' xion1', & - ' xion2', & - ' xion3', & - ' xion4', & - ' 1-xion3' /) - - if (dump_number == 0) then - allocate(prev_unbound(npart),prev_bound(npart)) - prev_bound = .false. - prev_unbound = .false. - allocate(ionfrac(npart,5)) - ionfrac = -1. ! Initialise ion states to -1 - endif - - call compute_energies(time) - do i=1,npart - rhopart = rhoh(xyzh(4,i), particlemass) - call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) - etoti = ekini + epoti + ethi - - if ((etoti > 0.) .and. (.not. prev_unbound(i))) then - if (ieos == 10) then ! MESA EoS - call ionisation_fraction(rhopart*unit_density,tempi,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) - elseif (ieos == 20) then ! Gas + radiation + recombination EoS - call get_xion(log10(rhopart*unit_density),tempi,X_in,1.-X_in-Z_in,xion) - xh0 = xion(1) ! H2 ionisation fraction - xh1 = xion(2) ! H ionisation fraction - xhe1 = xion(3) ! He ionisation to He+ fraction - xhe2 = xion(4) ! He+ ionisation to He++ fraction - xhe0 = 1.-xion(3) - else ! Not supported - print*,"Error, not sensible to use unbound_ionfrac when not using MESA EoS (ieos=10) or gas+rad+rec EoS (ieos=20)" - stop - endif - ionfrac(i,1) = xh0 - ionfrac(i,2) = xh1 - ionfrac(i,3) = xhe1 - ionfrac(i,4) = xhe2 - ionfrac(i,5) = xhe0 - prev_unbound(i) = .true. - elseif (etoti < 0.) then - prev_unbound(i) = .false. - endif - enddo - - ! Trick write_time_file into writing my data table - print*,'Dump number is ',dump_number - if (dump_number == 258) then - do i=1,npart - call write_time_file("unbound_ionfrac",columns,-1.,ionfrac(i,1:5),5,i-1) ! Set num = i-1 so that header will be written for particle 1 and particle 1 only - enddo - endif - -end subroutine unbound_ionfrac - - -!---------------------------------------------------------------- -!+ -! Unbound temperature -!+ -!---------------------------------------------------------------- -subroutine unbound_temp(time,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy,get_xion - integer, intent(in) :: npart - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17) :: columns(1) - integer :: i,final_count(7) - real :: etoti,ekini,einti,epoti,ethi,phii,dum,rhopart,& - ponrhoi,spsoundi,temp_bins(7) - logical, allocatable, save :: prev_unbound(:),prev_bound(:) - real, allocatable, save :: temp_unbound(:) - - columns = (/' temp'/) - - if (dump_number == 0) then - allocate(prev_unbound(npart),prev_bound(npart),temp_unbound(npart)) - prev_bound = .false. - prev_unbound = .false. - temp_unbound = 0. ! Initialise temperatures to 0. - endif - - do i=1,npart - rhopart = rhoh(xyzh(4,i), particlemass) - call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),eos_vars(itemp,i),vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) - etoti = ekini + epoti + ethi - - if ((etoti > 0.) .and. (.not. prev_unbound(i))) then - temp_unbound(i) = eos_vars(itemp,i) - prev_unbound(i) = .true. - elseif (etoti < 0.) then - prev_unbound(i) = .false. - endif - enddo - - print*,'dump_number=',dump_number - ! Trick write_time_file into writing my data table - if (dump_number == 167) then - temp_bins = (/ 2.e3, 5.5e3, 8.e3, 1.5e4, 2.e4, 4.e4, 1.e15 /) - final_count = 0 - do i=1,npart - if (temp_unbound(i) > 1.e-15) then - if (temp_unbound(i) < temp_bins(1)) then - final_count(1:7) = final_count(1:7) + 1 - elseif (temp_unbound(i) < temp_bins(2)) then - final_count(2:7) = final_count(2:7) + 1 - elseif (temp_unbound(i) < temp_bins(3)) then - final_count(3:7) = final_count(3:7) + 1 - elseif (temp_unbound(i) < temp_bins(4)) then - final_count(4:7) = final_count(4:7) + 1 - elseif (temp_unbound(i) < temp_bins(5)) then - final_count(5:7) = final_count(5:7) + 1 - elseif (temp_unbound(i) < temp_bins(6)) then - final_count(6:7) = final_count(6:7) + 1 - elseif (temp_unbound(i) < temp_bins(7)) then - final_count(7) = final_count(7) + 1 - endif - endif - call write_time_file("unbound_temp",columns,-1.,temp_unbound(i),1,i-1) ! Set num = i-1 so that header will be written for particle 1 and particle 1 only - enddo - - print*,final_count - endif - -end subroutine unbound_temp - - -!---------------------------------------------------------------- -!+ -! Recombination statistics -!+ -!---------------------------------------------------------------- -subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy,ionisation_fraction - integer, intent(in) :: npart,num - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real :: etoti,ekini,einti,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 :: i - real, parameter :: recomb_th=0.05 - - call compute_energies(time) - - allocate(isbound(npart),H_state(npart),He_state(npart)) - do i=1,npart - ! Calculate total energy - rhopart = rhoh(xyzh(4,i), particlemass) - call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) - etoti = ekini + epoti + ethi - - call get_eos_pressure_temp_mesa(rhopart*unit_density,vxyzu(4,i)*unit_ergg,pressure,temperature) ! This should depend on ieos - call ionisation_fraction(rhopart*unit_density,temperature,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) - - ! Is unbound? - if (etoti > 0.) then - isbound(i) = .false. - else - isbound(i) = .true. - endif - - ! H ionisation state - if (xh0 > recomb_th) then - H_state(i) = 1 - elseif (xh1 > recomb_th) then - H_state(i) = 2 - else - H_state(i) = 0 ! This should not happen - endif - - ! H ionisation state - if (xhe0 > recomb_th) then - He_state(i) = 1 - elseif (xhe1 > recomb_th) then - He_state(i) = 2 - elseif (xhe2 > recomb_th) then - He_state(i) = 3 - else - He_state(i) = 0 ! This should not happen - 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 - - if (num == 0) then ! Write header line - open(unit=1000, file="H_state.ev", status='replace') - write(1000, "(a)") '# Ion fraction statistics' - close(unit=1000) - open(unit=1001, file="He_state.ev", status='replace') - write(1001, "(a)") '# Ion fraction statistics' - close(unit=1001) - open(unit=1002, file="isbound.ev", status='replace') - write(1002, "(a)") '# Ion fraction statistics' - close(unit=1002) - endif - - open(unit=1000, file="H_state.ev", position='append') - 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=1000, file="isbound.ev", position='append') - write(1000,logical_format) time,isbound(:) - close(unit=1000) - - deallocate(isbound,H_state,He_state) - -end subroutine recombination_stats - - -!---------------------------------------------------------------- -!+ -! Sink properties -!+ -!---------------------------------------------------------------- -subroutine sink_properties(time,npart,particlemass,xyzh,vxyzu) - use vectorutils, only:cross_product3D - integer, intent(in) :: npart - real, intent(in) :: time, particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17), allocatable :: columns(:) - character(len=17) :: filename - real :: sinkcomp(35) - real :: ang_mom(3) - real :: phitot, dtsinksink, fonrmax - real :: fxi, fyi, fzi, phii - real, dimension(4,maxptmass) :: fssxyz_ptmass - real, dimension(4,maxptmass) :: fxyz_ptmass - real, dimension(3,maxptmass) :: dsdt_ptmass - real, dimension(3) :: com_xyz,com_vxyz - integer :: i,ncols,merge_n,merge_ij(nptmass) - - ncols = 31 - allocate(columns(ncols)) - columns = (/' x', & - ' y', & - ' z', & - ' r', & - ' vx', & - ' vy', & - ' vz', & - ' |v|', & - ' px', & - ' py', & - ' pz', & - ' |p|', & - ' fssx', & - ' fssy', & - ' fssz', & - ' |fss|', & - ' fsx', & - ' fsy', & - ' fsz', & - ' |fs|', & - ' ang mom x', & - ' ang mom y', & - ' ang mom z', & - ' |ang mom|', & - ' kin en', & - ' CoM x ', & - ' CoM y ', & - ' CoM z ', & - ' CoM vx', & - ' CoM vy', & - ' CoM vz' /) - - fxyz_ptmass = 0. - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) - fssxyz_ptmass = fxyz_ptmass - do i=1,npart - call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,& - fxi,fyi,fzi,phii,particlemass,fxyz_ptmass,dsdt_ptmass,fonrmax) - enddo - - ! Determine position and velocity of the CoM - call orbit_com(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,com_xyz,com_vxyz) - - do i=1,nptmass - sinkcomp = 0. - write (filename, "(A16,I0)") "sink_properties_", i - - ! position xyz - sinkcomp(1:3) = xyzmh_ptmass(1:3,i) - ! position modulus - sinkcomp(4) = distance(xyzmh_ptmass(1:3,i)) - ! velocity xyz - sinkcomp(5:7) = vxyz_ptmass(1:3,i) - ! velocity modulus - sinkcomp(8) = distance(vxyz_ptmass(1:3,i)) - ! momentum xyz - sinkcomp(9:11) = xyzmh_ptmass(4,i)*vxyz_ptmass(1:3,i) - ! momentum modulus - sinkcomp(12) = xyzmh_ptmass(4,i)*sinkcomp(8) - ! force xyz - sinkcomp(13:15) = fssxyz_ptmass(1:3,i) - ! force modulus - sinkcomp(16) = distance(fssxyz_ptmass(1:3,i)) - ! tot force xyz - sinkcomp(17:19) = fxyz_ptmass(1:3,i) - ! tot force modulus - sinkcomp(20) = distance(fxyz_ptmass(1:3,i)) - ! angular momentum xyz - call cross_product3D(xyzmh_ptmass(1:3,i), xyzmh_ptmass(4,i)*vxyz_ptmass(1:3,i), ang_mom) - sinkcomp(21:23) = ang_mom - ! angular momentum modulus - sinkcomp(24) = distance(ang_mom(1:3)) - ! kinetic energy - sinkcomp(25) = 0.5*xyzmh_ptmass(4,i)*sinkcomp(8)**2 - ! CoM position - sinkcomp(26:28) = com_xyz(1:3) - ! CoM velocity - sinkcomp(29:31) = com_vxyz(1:3) - - call write_time_file(filename, columns, time, sinkcomp, ncols, dump_number) - enddo - deallocate(columns) - -end subroutine sink_properties - - - -subroutine env_binding_ene(npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy - integer, intent(in) :: npart - real, intent(in) :: particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - integer :: i - real :: ethi,phii,rhoi,ponrhoi,spsoundi,tempi,dum1,dum2,dum3 - real :: bind_g,bind_th,bind_int,eth_tot,eint_tot - - bind_g = 0. - bind_th = 0. - bind_int = 0. - eint_tot = 0. - eth_tot = 0. - do i=1,npart - ! Gas-gas potential - bind_g = bind_g + poten(i) ! Double counting factor of 1/2 already included in poten - - ! Sink-sink potential - phii = 0. - call get_accel_sink_gas(1,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass(:,1),dum1,dum2,dum3,phii) ! Include only core particle; no companion - bind_g = bind_g + particlemass * phii - - rhoi = rhoh(xyzh(4,i), particlemass) - call equationofstate(ieos,ponrhoi,spsoundi,rhoi,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhoi,eos_vars(itemp,i),ethi) - - eth_tot = eth_tot + ethi - eint_tot = eint_tot + particlemass * vxyzu(4,i) - enddo - bind_th = bind_g + eth_tot - bind_int = bind_g + eint_tot - - print*,bind_g*unit_energ, bind_th*unit_energ, bind_int*unit_energ - -end subroutine env_binding_ene - - -subroutine bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) - integer, intent(in) :: npart - real, intent(in) :: time, particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17), allocatable :: columns(:) - integer :: i, ncols - real, dimension(8) :: entropy_array - real :: etoti, ekini, einti, epoti, phii, rhopart - 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 - integer, parameter :: ient_ub = 2 - integer, parameter :: itemp_b = 3 - integer, parameter :: itemp_ub = 4 - integer, parameter :: ipres_b = 5 - integer, parameter :: ipres_ub = 6 - integer, parameter :: idens_b = 7 - integer, parameter :: idens_ub = 8 - - !zeroes the entropy variable and others - entropy_array = 0. - - !setup - if (dump_number == 0) then - call prompt('Would you like to use thermal energy in the computation of the bound/unbound status?', switch(1),.false.) - endif - - call compute_energies(time) - - do i=1,npart - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) - - rhopart = rhoh(xyzh(4,i), particlemass) - - !gets entropy for the current particle - call get_eos_various_mesa(rhopart*unit_density,vxyzu(4,i) * unit_ergg, & - pres_1,proint_1,peint_1,temp_1,troint_1, & - teint_1,entrop_1,abad_1,gamma1_1,gam_1) - - !sums entropy and other quantities for bound particles and unbound particles - - if (.not. switch(1)) then - etoti = etoti - einti - endif - - if (etoti < 0.0) then !bound - entropy_array(ient_b) = entropy_array(ient_b) + entrop_1 - entropy_array(itemp_b) = entropy_array(itemp_b) + temp_1 - entropy_array(ipres_b) = entropy_array(ipres_b) + pres_1 - entropy_array(idens_b) = entropy_array(idens_b) + rhopart*unit_density - - else !unbound - entropy_array(ient_ub) = entropy_array(ient_ub) + entrop_1 - entropy_array(itemp_ub) = entropy_array(itemp_ub) + temp_1 - entropy_array(ipres_ub) = entropy_array(ipres_ub) + pres_1 - entropy_array(idens_ub) = entropy_array(idens_ub) + rhopart*unit_density - - endif - - enddo - - !average - entropy_array(itemp_b) = entropy_array(itemp_b) / npart - entropy_array(itemp_ub) = entropy_array(itemp_ub) / npart - entropy_array(ipres_b) = entropy_array(ipres_b) / npart - entropy_array(ipres_ub) = entropy_array(ipres_ub) / npart - entropy_array(idens_b) = entropy_array(idens_b) / npart - entropy_array(idens_ub) = entropy_array(idens_ub) / npart - - !writes on file - ncols = 8 - allocate(columns(ncols)) - columns = (/' b entr',& - ' unb entr',& - ' avg b temp',& - ' avg unb temp',& - ' avg b pres',& - ' avg unb pres',& - ' avg b dens',& - ' avg unb dens'/) - call write_time_file('entropy_vs_time', columns, time, entropy_array, ncols, dump_number) - deallocate(columns) -end subroutine bound_unbound_thermo - - -!---------------------------------------------------------------- -!+ -! Gravitational drag -!+ -!---------------------------------------------------------------- -subroutine gravitational_drag(time,npart,particlemass,xyzh,vxyzu) - use prompting, only:prompt - use vectorutils, only:cross_product3D - integer, intent(in) :: npart - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17), allocatable :: columns(:) - character(len=17) :: filename - integer :: i,j,k,ncols,sizeRcut,vol_npart,merge_ij(nptmass),merge_n - integer, allocatable :: iorder(:) - real, dimension(:), allocatable, save :: ang_mom_old,time_old - real, dimension(:,:), allocatable :: drag_force - real, dimension(4,maxptmass) :: fxyz_ptmass,fxyz_ptmass_sinksink - real, dimension(3,maxptmass) :: dsdt_ptmass - real, dimension(3) :: avg_vel,avg_vel_par,avg_vel_perp,& - com_xyz,com_vxyz,unit_vel,unit_vel_perp,& - pos_wrt_CM,vel_wrt_CM,ang_mom,com_vec,& - unit_sep,unit_sep_perp,vel_contrast_vec,Fgrav - real :: drag_perp,drag_par,drag_perp_proj,& - vel_contrast,mdot,sep,Jdot,R2,& - rho_avg,cs,racc,fonrmax,fxi,fyi,fzi,& - phii,phitot,dtsinksink,interior_mass,sinksinksep,& - volume,vol_mass,vKep,omega,maxsep,cos_psi,mass_coregas,& - com_sink_sep,Fgrav_mag - real, dimension(:), allocatable :: Rcut - real, dimension(:,:,:), allocatable :: force_cut_vec - logical, save :: iacc,icentreonCM - integer, save :: iavgopt - - ! OPTIONS - if (dump_number == 0) then - print*,'Options for averaging gas properties:' - print "(6(/,a))",'1. Average over sphere centred on the companion (not recommended)',& - '2. Average over sphere centred on opposite side of orbit',& - '3. Average over annulus',& - '4. Average over annulus but excluding sphere centred on the companion',& - '5. Average over sphere twice as far on the opposite side of the orbit',& - '6. Average over sphere half as far on the opposite side of the orbit' - iavgopt = 2 - call prompt('Select option above : ',iavgopt,1,6) - icentreonCM = .false. - select case (iavgopt) - case(2,5,6) - call prompt('Centre averaging sphere on the CM (otherwise, centre on primary core)?: ',icentreonCM) - case(3,4) - call prompt('Centre annulus on the CM (otherwise, centre on primary core)?: ',icentreonCM) - end select - - write(*,"(a,i2)") 'Using ieos = ',ieos - if ( xyzmh_ptmass(ihacc,2) > 0 ) then - write(*,"(a,f13.7,a)") 'Companion has accretion radius = ', xyzmh_ptmass(ihacc,2), '(code units)' - write(*,"(a)") 'Will analyse accretion' - iacc = .true. - else - iacc = .false. - endif - endif - - ncols = 31 - allocate(columns(ncols),iorder(npart),force_cut_vec(4,maxptmass,5)) - allocate(drag_force(ncols,nptmass)) - columns = (/' drag_perp', & ! 1 Component of net force (excluding sink-sink) perpendicular to sink separation (projection on (r2-r1) x z) - ' drag_par', & ! 2 Component of net force (excluding sink-sink) projected along sink separation, -(r2-r1) - 'drag_perp_pr', & ! 3 'drag_perp' projected along the -v direction - ' F_dot_v', & ! 4 Dot product of 'drag_perp_pr' and sink velocity (<0 means energy dissipation) - ' drag_torque', & ! 5 torque / r of sink - ' cos_psi', & ! 6 Cosine of angle between (r2-r1) x z and -v - ' Fgrav', & ! 7 Magnitude of gravitational force from core and gas around it inferred from net force minus drag - 'mass_coregas', & ! 8 Mass of core+gas inferred from net force minus drag - ' drag_BHL', & ! 9 Bondi-Hoyle-Lyttleton drag force - ' mdot_BHL', & ! 10 Bond-Hoyle-Lyttleton mass accretion rate - ' v_con', & ! 11 Magnitude of average background gas velocity minus sink velocity, positive when vsink dot vgas < 0 - ' v_con_par', & ! 12 Projection of velocity contrast on -vsink - ' v_Kep', & ! 13 Keplerian velocity of companion, sqrt(M( 0.) then - rho_avg = vol_mass / volume - avg_vel_par(1:3) = dot_product(avg_vel, unit_vel) * unit_vel - avg_vel_perp(1:3) = avg_vel(1:3) - avg_vel_par(1:3) - vel_contrast_vec = avg_vel - vxyz_ptmass(1:3,i) - vel_contrast = sign( distance(vel_contrast_vec), -dot_product(vxyz_ptmass(1:3,i), avg_vel) ) - racc = 2. * xyzmh_ptmass(4,i) / (vel_contrast**2 + cs**2) ! Accretion radius - mdot = 4.*pi * xyzmh_ptmass(4,i)**2 * rho_avg / (cs**2 + vel_contrast**2)**1.5 ! BHL mass accretion rate - endif - - - ! Sum acceleration (fxyz_ptmass) on companion due to gravity of gas particles - force_cut_vec = 0. - fxyz_ptmass = 0. - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) - - sizeRcut = 5 - if (i == 1) allocate(Rcut(sizeRcut)) - call logspace(Rcut,0.4,2.5) - !Rcut = Rcut * racc ! Bin by fraction of accretion radius - Rcut = Rcut * separation( xyzmh_ptmass(1:3,1), xyzmh_ptmass(1:3,2) ) ! Bin by fraction of sink-sink separation - - do j = 1,npart - if (.not. isdead_or_accreted(xyzh(4,j))) then - ! Get total gravitational force from gas - call get_accel_sink_gas(nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),xyzmh_ptmass,& - fxi,fyi,fzi,phii,particlemass,fxyz_ptmass,dsdt_ptmass,fonrmax) - ! Get force from gas within distance cutoff - do k = 1,sizeRcut - if ( separation(xyzh(1:3,j), xyzmh_ptmass(1:4,i)) < Rcut(k) ) then - call get_accel_sink_gas(nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),xyzmh_ptmass,& - fxi,fyi,fzi,phii,particlemass,force_cut_vec(1:4,:,k),dsdt_ptmass,fonrmax) - endif - enddo - endif - enddo - - ! Calculate angular momentum of companion wrt orbit CoM - pos_wrt_CM = xyzmh_ptmass(1:3,i) - com_xyz(1:3) - vel_wrt_CM = vxyz_ptmass(1:3,i) - com_vxyz(1:3) - call cross_product3D(pos_wrt_CM, xyzmh_ptmass(4,i) * vel_wrt_CM, ang_mom) - Jdot = (ang_mom(3) - ang_mom_old(i)) / (time - time_old(i)) ! Average change in angular momentum - R2 = distance(xyzmh_ptmass(1:3,i) - com_xyz(1:3)) - ang_mom_old(i) = ang_mom(3) ! Set ang_mom_old for next dump - time_old(i) = time - - ! Calculate mass interior to companion - call set_r2func_origin(xyzmh_ptmass(1,3-i),xyzmh_ptmass(2,3-i),xyzmh_ptmass(3,3-i)) ! Order particles by distance from donor core - call indexxfunc(npart,r2func_origin,xyzh,iorder) - sinksinksep = separation(xyzmh_ptmass(1:3,1), xyzmh_ptmass(1:3,2)) - interior_mass = xyzmh_ptmass(4,3-i) ! Include mass of donor core - select case(iavgopt) - case(5) ! Calculate mass interior to R/2 - maxsep = 2.*sinksinksep - case(6) ! Calculate mass interior to 2*R - maxsep = 0.5*sinksinksep - case default ! Calculate mass interior to R - maxsep = sinksinksep - end select - do j = 1,npart - k = iorder(j) - sep = separation(xyzmh_ptmass(1:3,3-i), xyzh(1:3,k)) - if (sep > maxsep) exit - interior_mass = interior_mass + particlemass - enddo - vKep = sqrt(interior_mass / sinksinksep) - - ! Calculate perpendicular force projected along -v - cos_psi = cos_vector_angle(-unit_sep_perp, -vxyz_ptmass(1:3,i)) ! Theta is angle between (r2-r1) x z and -v - drag_par = - dot_product(fxyz_ptmass(1:3,i),unit_sep) * xyzmh_ptmass(4,i) ! Total force projected along -(r2-r1) - drag_perp = dot_product(fxyz_ptmass(1:3,i),-unit_sep_perp) * xyzmh_ptmass(4,i) ! Total force projected along -(r2-r1) x z - drag_perp_proj = drag_perp / cos_psi ! Perpendicular force projected along -v - - ! Calculate core + gas mass based on projected gravitational force - Fgrav = fxyz_ptmass(1:3,i) * xyzmh_ptmass(4,i) - drag_perp_proj * (-unit_vel) ! Ftot,gas + Fsinksink = Fdrag + Fgrav - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass_sinksink,phitot,dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) - Fgrav = Fgrav + fxyz_ptmass_sinksink(1:3,i) * xyzmh_ptmass(4,i) - Fgrav_mag = distance(Fgrav) - mass_coregas = Fgrav_mag * sinksinksep**2 / xyzmh_ptmass(4,i) - - ! Calculate CoM inferred from core + gas mass - com_vec = (mass_coregas * xyzmh_ptmass(1:3,3-i) + xyzmh_ptmass(4,i) * xyzmh_ptmass(1:3,i)) / (mass_coregas + xyzmh_ptmass(4,i)) - com_sink_sep = separation(com_vec, xyzmh_ptmass(1:3,i)) - - drag_force(1,i) = drag_perp - drag_force(2,i) = drag_par - drag_force(3,i) = drag_perp_proj - drag_force(4,i) = drag_perp_proj * (-distance(vxyz_ptmass(1:3,i))) - drag_force(5,i) = Jdot / R2 - drag_force(6,i) = cos_psi - drag_force(7,i) = Fgrav_mag - drag_force(8,i) = mass_coregas - drag_force(9,i) = mdot * vel_contrast ! BHL drag force - drag_force(10,i) = mdot - drag_force(11,i) = vel_contrast - drag_force(12,i) = dot_product(vel_contrast_vec, -unit_vel) - drag_force(13,i) = vKep - drag_force(14,i) = interior_mass - drag_force(15,i) = omega - drag_force(16,i) = cs - drag_force(17,i) = rho_avg - drag_force(18,i) = racc - drag_force(19,i) = com_sink_sep - drag_force(20,i) = separation(com_xyz(1:3),xyzmh_ptmass(1:3,i)) - drag_force(21,i) = sinksinksep - drag_force(22,i) = - dot_product(force_cut_vec(1:3,i,1),unit_sep) * xyzmh_ptmass(4,i) - drag_force(23,i) = - dot_product(force_cut_vec(1:3,i,1),unit_sep_perp) * xyzmh_ptmass(4,i) - drag_force(24,i) = - dot_product(force_cut_vec(1:3,i,2),unit_sep) * xyzmh_ptmass(4,i) - drag_force(25,i) = - dot_product(force_cut_vec(1:3,i,2),unit_sep_perp) * xyzmh_ptmass(4,i) - drag_force(26,i) = - dot_product(force_cut_vec(1:3,i,3),unit_sep) * xyzmh_ptmass(4,i) - drag_force(27,i) = - dot_product(force_cut_vec(1:3,i,3),unit_sep_perp) * xyzmh_ptmass(4,i) - drag_force(28,i) = - dot_product(force_cut_vec(1:3,i,4),unit_sep) * xyzmh_ptmass(4,i) - drag_force(29,i) = - dot_product(force_cut_vec(1:3,i,4),unit_sep_perp) * xyzmh_ptmass(4,i) - drag_force(30,i) = - dot_product(force_cut_vec(1:3,i,5),unit_sep) * xyzmh_ptmass(4,i) - drag_force(31,i) = - dot_product(force_cut_vec(1:3,i,5),unit_sep_perp) * xyzmh_ptmass(4,i) - - ! Write to output - write (filename, "(A16,I0)") "sink_drag_", i - call write_time_file(trim(adjustl(filename)), columns, time, drag_force(:,i), ncols, dump_number) - enddo - deallocate(columns,drag_force,force_cut_vec,Rcut) - -end subroutine gravitational_drag - - -subroutine J_E_plane(num,npart,particlemass,xyzh,vxyzu) - use vectorutils, only:cross_product3D - integer, intent(in) :: npart,num - 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, allocatable :: data(:,:) - - ncols = 7 - allocate(columns(ncols),data(ncols,npart)) - columns = (/' E',& - ' Jxcom',& - ' Jycom',& - ' Jzcom',& - ' Jxcore',& - ' Jycore',& - ' Jzcore'/) - - call get_centreofmass(com_xyz,com_vxyz,npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) - - do i=1,npart - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,dum1,dum2,dum3,dum4,etoti) - 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 - call cross_product3D(xyzh(1:3,i)-com_xyz(1:3), vxyz_ptmass(1:3,i)-com_vxyz(1:3), angmom_com) - data(2:4,i) = angmom_com - enddo - - data(1,:) = data(1,:) / particlemass ! specific energy - - call write_file('JEplane','JEplane',columns,data,size(data(1,:)),ncols,num) - deallocate(columns,data) - -end subroutine J_E_plane - -!------------------------------------------------------------------- -!+ -! Planet destruction -!+ -!------------------------------------------------------------------- -subroutine planet_destruction(time,npart,particlemass,xyzh,vxyzu) - use kernel, only:wkern - integer, intent(in) :: npart - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17), allocatable :: columns(:) - character(len=18) :: filename - real, allocatable :: planetDestruction(:) - integer :: ncols,i,j - real, save :: time_old - real, allocatable, save :: particleRho(:) - character(len=50) :: planetRadiusPromptString - real, allocatable, save :: planetRadii(:) !In units of Rsun - - real, dimension(3) :: currentGasVel, currentVelContrast - real :: currentRho(1) !Is a one element array because sphInterpolation returns a 1 dimensional array. - real :: currentRhoScaled,currentVelContrastScaled,currentPlanetRhoScaled - real :: currentPlanetMassScaled,currentPlanetRadiusScaled - real, allocatable, save :: currentKhAblatedMass(:) - - ncols=5 - allocate(columns(ncols),planetDestruction(ncols)) - columns=(/" rhoGas", & - " kh_rhoCrit", & - " kh_lmax", & - " kh_mdot", & - " kh_ablatedM" /) - - !Kelvin-Helmholtz instability planet destruction as described in "On the survival of brown dwarfs - !and planets by their giant host star" (https://arxiv.org/abs/1210.0879). Description of columns: - !rhoGas: background gas density at sink. In units of g/cm^3. - !kh_rhoCrit: paper equation 5. In units of g/cm^3. - !kh_lmax: paper equation 6. In units of Jupiter radii. - !kh_mdot: paper equation 7. In units of Jupiter mass/year. - !kh_ablatedM: kh_mdot integrated over time. In units of Jupiter masses. - - currentRho = 0. - do i=1,nptmass - if (i==1) cycle !The first sink is assumed to be the core. - - if ((dump_number==0) .and. (i==2)) then !This is only done once. - allocate(planetRadii(nptmass)) - planetRadii=0.1 - do j=2,nptmass - write(planetRadiusPromptString,"(A13,I0,A32)") "Enter planet ",j-1," radius in units of solar radii" - call prompt(planetRadiusPromptString,planetRadii(i),0.0,1.0) - enddo - - allocate(particleRho(npart)) - allocate(currentKhAblatedMass(nptmass)) - - time_old=0.0 - particleRho=getParticleRho(xyzh(4,:),particlemass) - currentKhAblatedMass=0.0 - endif - - - currentRho=sphInterpolation(npart,particlemass,particleRho,xyzh,xyzmh_ptmass(1:3,i),reshape(particleRho,(/1,npart/))) - currentGasVel=sphInterpolation(npart,particlemass,particleRho,xyzh,xyzmh_ptmass(1:3,i),vxyzu(1:3,:)) - currentVelContrast=vxyz_ptmass(1:3,i)-currentGasVel - - currentPlanetRadiusScaled=planetRadii(i)/0.1 !In units of 0.1 Rsun. - currentPlanetMassScaled=xyzmh_ptmass(4,i)*104.74 !In units of 10 jupiter masses. - currentPlanetRhoScaled=(xyzmh_ptmass(4,i)/((4.0/3.0)*pi*(planetRadii(i)**3.0)))*0.44 !In units of 13.34 g/cm^3 - currentRhoScaled=currentRho(1)*59000.0 !In units of 10^-4 g/cm^3. - currentVelContrastScaled=distance(currentVelContrast)*4.37 !In units of 100 km/s. - - planetDestruction(1)=currentRho(1)*5.9 - planetDestruction(2)=3.82*(currentPlanetRhoScaled**(4.0/3.0))*(currentPlanetMassScaled**(2.0/3.0))& - *(currentVelContrastScaled**(-2.0)) - planetDestruction(3)=0.0000263*(currentVelContrastScaled**2.0)*currentRhoScaled*(currentPlanetRhoScaled**((-5.0)/3.0))& - *(currentPlanetMassScaled**((-1.0)/3.0)) - planetDestruction(4)=11.0*currentVelContrastScaled*currentRhoScaled*(currentPlanetRadiusScaled**2.0)& - *(planetDestruction(3)/(currentPlanetRadiusScaled*0.973)) - - currentKhAblatedMass(i)=currentKhAblatedMass(i)+((time-time_old)*planetDestruction(4)*0.0000505) - planetDestruction(5)=currentKhAblatedMass(i) - - - write(filename, "(A17,I0)") "sink_destruction_",i - call write_time_file(filename, columns, time, planetDestruction, ncols, dump_number) - enddo - - time_old=time - - deallocate(columns,planetDestruction) -end subroutine planet_destruction - -!----------------------------------------------------------------------------------------- -!+ -!Binding energy profile -!+ -!----------------------------------------------------------------------------------------- -subroutine create_bindingEnergy_profile(time,num,npart,particlemass,xyzh,vxyzu) - real, intent(in) :: time,particlemass - integer, intent(in) :: num,npart - real, intent(in) :: xyzh(4,npart),vxyzu(4,npart) - - character(len=17), allocatable :: columns(:) - real, allocatable :: profile(:,:) - integer :: ncols,i,j - integer, allocatable :: iorder(:) - real :: currentInteriorMass,currentParticleGPE,currentCoreParticleSeparation - real :: previousBindingEnergy,previousBindingEnergyU - - ncols=3 - allocate(columns(ncols),iorder(npart)) - allocate(profile(ncols,npart)) - columns=(/" radius",& - " bEnergy",& !Binding energy without internal energy. - " bEnergy (u)"/) !Binding energy with internal energy. - - - call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) - call indexxfunc(npart,r2func_origin,xyzh,iorder) - currentInteriorMass=xyzmh_ptmass(4,1)+(npart*particlemass) !Initally set to the entire mass of the star. - - do i=npart,1,-1 !Loops over all particles from outer to inner. - j=iorder(i) - currentInteriorMass=currentInteriorMass-particlemass - currentCoreParticleSeparation=separation(xyzmh_ptmass(1:3,1),xyzh(1:3,j)) - currentParticleGPE=(currentInteriorMass*particlemass)/currentCoreParticleSeparation - - !The binding energy at a particular radius is the sum of the gravitational potential energies - !(and internal energies in the case of the third column) of all particles beyond that radius. - if (i==npart) then - previousBindingEnergy=0.0 - previousBindingEnergyU=0.0 - else - previousBindingEnergy=profile(2,i+1) - previousBindingEnergyU=profile(3,i+1) - endif - - profile(1,i)=currentCoreParticleSeparation - profile(2,i)=previousBindingEnergy+currentParticleGPE - profile(3,i)=previousBindingEnergyU+currentParticleGPE-(vxyzu(4,j)*particlemass) - enddo - - call write_file('bEnergyProfile','bEnergyProfiles',columns,profile,npart,ncols,num) - deallocate(columns,iorder,profile) - -end subroutine create_bindingEnergy_profile - - -subroutine get_core_gas_com(time,npart,xyzh,vxyzu) - use sortutils, only:set_r2func_origin,r2func_origin,indexxfunc - integer, intent(in) :: npart - real, intent(in) :: time - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real :: sep,maxsep,core_gas_com(3),core_gas_vcom(3),xyz_gas(4,npart),vxyz_gas(3,npart) - real, allocatable :: mytable(:) - character(len=17), allocatable :: columns(:) - character(len=17) :: filename - integer, save :: ngas - integer, allocatable, save :: iorder(:) - integer :: ncols,j,k - - ncols = 12 - allocate(columns(ncols)) - allocate(mytable(ncols)) - mytable = 0. - columns = (/' gas_com_x', & - ' gas_com_y', & - ' gas_com_z', & - ' gas_com_vx', & - ' gas_com_vy', & - ' gas_com_vz', & - ' core_x', & - ' core_y', & - ' core_z', & - ' core_vx', & - ' core_vy', & - ' core_vz' /) - - - ! Record particles that are closest to primary core - if (dump_number == 0) then - allocate(iorder(npart)) - maxsep = 10. ! 10 Rsun - ngas = 0 - call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) ! Order particles by distance from donor core - call indexxfunc(npart,r2func_origin,xyzh,iorder) - - do j=1,npart - k = iorder(j) - if (j < 10) print*,k - sep = separation(xyzmh_ptmass(1:3,1), xyzh(1:3,k)) - if (sep > maxsep) exit - ngas = ngas + 1 - enddo - endif - - print*,'ngas=',ngas - - do j=1,ngas - k = iorder(j) - xyz_gas(1:4,j) = xyzh(1:4,k) - vxyz_gas(1:3,j) = vxyzu(1:3,k) - enddo - - call get_centreofmass(core_gas_com,core_gas_vcom,ngas,xyz_gas,vxyz_gas) ! Do not include sinks - - mytable(1:3) = core_gas_com(1:3) - mytable(4:6) = core_gas_vcom(1:3) - mytable(7:9) = xyzmh_ptmass(1:3,1) - mytable(10:12) = vxyz_ptmass(1:3,1) - - write (filename, "(A16,I0)") "core_gas_com" - call write_time_file(trim(adjustl(filename)),columns,time,mytable,ncols,dump_number) -end subroutine get_core_gas_com - - -!---------------------------------------------------------------- -!+ -! Print dump numbers corresponding to given sink-sink separations -!+ -!---------------------------------------------------------------- -subroutine print_dump_numbers(dumpfile) - character(len=*), intent(in) :: dumpfile - character(len=50), allocatable, save :: dumpfiles(:) - integer :: nseps - integer, save :: i - real, allocatable :: sinksinksep(:) - real :: sep - - nseps = 2 - allocate(sinksinksep(nseps)) - if (dump_number == 0) then - allocate(dumpfiles(nseps)) - i=1 - endif - sinksinksep = (/ 938., 67. /) - - sep = separation(xyzmh_ptmass(1:3,1),xyzmh_ptmass(1:3,2)) - if ( sep < sinksinksep(i) ) then - dumpfiles(i) = trim(dumpfile) - i=i+1 - endif - if (i==nseps+1) then - print "(5(a,/))",'../',dumpfiles - return - endif - -end subroutine print_dump_numbers - - -!---------------------------------------------------------------- -!+ -! Analyse disk -!+ -!---------------------------------------------------------------- -subroutine analyse_disk(num,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp - use extern_corotate, only:get_companion_force - use ionization_mod, only:calc_thermal_energy - use vectorutils, only:cross_product3D - integer, intent(in) :: num,npart - real, intent(in) :: particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - character(len=17), allocatable :: columns(:) - real, allocatable :: data(:,:) - real :: diskz,diskR2,diskR1,R,omegai,phii,rhopart,ponrhoi,spsoundi,tempi,& - epoti,ekini,ethi,Ji(3),vrel2,fxi,fyi,fzi,vphi - integer :: ncols,i - - ncols = 9 - allocate(columns(ncols),data(ncols,npart)) - data = -1. - columns = (/' R',& ! cylindrical radius w.r.t companion - ' E',& ! specific energy (kin+pot only) w.r.t. companion - ' Omega',& ! angular momentum w.r.t. companion - ' Jx',& ! specific angular momentum components - ' Jy',& - ' Jz',& - ' ekin',& - ' epot',& ! gravitational potential energy due to companion only - ' etherm'/) - - ! Set disk dimensions - diskz = 50. ! disk half-thickness - diskR1 = 5. ! disk inner radius - diskR2 = 150. ! disk outer radius - - do i=1,npart - ! Skip if particle is not within the defined disk - if (abs(xyzh(3,i) - xyzmh_ptmass(3,2)) > diskz) cycle - R = sqrt( (xyzh(1,i) - xyzmh_ptmass(1,2))**2 + (xyzh(2,i) - xyzmh_ptmass(2,2))**2 ) - if ( (R > diskR2) .or. (R < diskR1) ) cycle - - vrel2 = (vxyzu(1,i) - vxyz_ptmass(1,2))**2 + (vxyzu(2,i) - vxyz_ptmass(2,2))**2 + (vxyzu(3,i) - vxyz_ptmass(3,2))**2 - ekini = 0.5*particlemass*vrel2 - - ! Calculate gravitational potential due to companion only - phii = 0. - call get_companion_force(xyzh(1:3,i),fxi,fyi,fzi,phii) - epoti = phii*particlemass - - ! Calculate thermal 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) - - call get_gas_omega(xyzmh_ptmass(1:3,2),vxyz_ptmass(1:3,2),xyzh(1:3,i),vxyzu(1:3,i),vphi,omegai) - call cross_product3D(xyzh(1:3,i)-xyzmh_ptmass(1:3,2), vxyzu(1:3,i)-vxyz_ptmass(1:3,2), Ji) - - data(1,i) = R - data(2,i) = (ekini+epoti) / particlemass - data(3,i) = omegai - data(4:6,i) = Ji - data(7,i) = ekini - data(8,i) = epoti - data(9,i) = ethi - enddo - call write_file('companion_disk','companion_disk',columns,data,npart,ncols,num) - deallocate(columns) - -end subroutine analyse_disk - - -!---------------------------------------------------------------- -!+ -! Recombination energy vs. time -!+ -!---------------------------------------------------------------- -subroutine erec_vs_t(time,npart,particlemass,xyzh) - use ionization_mod, only:get_erec_components - integer, intent(in) :: npart - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:) - character(len=17) :: filename,columns(4) - integer :: i - real :: ereci(4),erec(4),tempi,rhoi - - columns = (/' H2', & - ' HI', & - ' HeI', & - ' HeII'/) - - erec = 0. - do i = 1,npart - rhoi = rhoh(xyzh(4,i), particlemass) - call get_erec_components( log10(rhoi*unit_density), tempi, X_in, 1.-X_in-Z_in, ereci) - erec = erec + ereci - enddo - - write (filename, "(A16,I0)") "erec_vs_t" - call write_time_file(trim(adjustl(filename)),columns,time,erec,4,dump_number) - -end subroutine erec_vs_t - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!! Routines used in analysis routines !!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!---------------------------------------------------------------- -!+ -! Calculate the angular velocity of an envelope gas particle -! relative to a reference point -!+ -!---------------------------------------------------------------- -subroutine get_gas_omega(xyz_centre,vxyz_centre,xyzi,vxyzi,vphi,omega) - use vectorutils, only:cross_product3D - real, intent(in) :: xyz_centre(3),vxyz_centre(3),xyzi(3),vxyzi(3) - real, intent(out) :: vphi,omega - real :: Rmag,R(3),phi_unitvec(3),R_unitvec(3) - - ! xyz_centre: Position vector of reference point - ! vxyz_centre: Velocity vector of reference point - ! R: Cylindrical radius vector - R(1:2) = xyzi(1:2) - xyz_centre(1:2) ! Separation in x-y plane - R(3) = 0. - Rmag = sqrt(dot_product(R,R)) - R_unitvec = R / Rmag - call cross_product3D((/0.,0.,1./), R_unitvec, phi_unitvec) ! phi = z x R - vphi = dot_product(vxyzi - vxyz_centre, phi_unitvec) - omega = vphi / Rmag -end subroutine get_gas_omega - - -!---------------------------------------------------------------- -!+ -! Calculate kinetic, gravitational potential (gas-gas and sink-gas), -! and internal energy of a gas particle. -!+ -!---------------------------------------------------------------- -subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,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 - real, intent(in) :: particlemass - real(4), intent(in) :: poten - real, dimension(4), intent(in) :: xyzh,vxyzu - real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass - real, intent(out) :: phii,epoti,ekini,einti,etoti - real :: fxi,fyi,fzi - - phii = 0.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) - etoti = epoti + ekini + einti - -end subroutine calc_gas_energies - - -subroutine adjust_corotating_velocities(npart,particlemass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,omega_c,dump_number) - use vectorutils, only:cross_product3D - real, dimension(:,:), intent(in) :: xyzmh_ptmass,xyzh - real, dimension(:,:), intent(inout) :: vxyzu,vxyz_ptmass - real, intent(inout) :: omega_c - real, intent(in) :: particlemass - integer, intent(in) :: npart, dump_number - - logical :: switch - real :: sep, mtot - real, dimension(3) :: omega_vec, omegacrossr - integer :: i - - if (dump_number == 0) then - call prompt('Was this in a corotating frame?',switch,.false.) - - if (switch) then - sep = separation(xyzmh_ptmass(1:3,1), xyzmh_ptmass(1:3,2)) - mtot = sum(xyzmh_ptmass(4,:)) + npart*particlemass - omega_c = sqrt(mtot / sep**3) - else - omega_c = -1 - endif - endif - - if (omega_c > 0.) then - omega_vec = (/ 0.,0.,omega_c /) - - do i=1,npart - call cross_product3D(omega_vec,xyzh(1:3,i),omegacrossr) - vxyzu(1:3,i) = vxyzu(1:3,i) + omegacrossr(1:3) - enddo - - do i=1,nptmass - call cross_product3D(omega_vec,xyzmh_ptmass(1:3,i),omegacrossr) - vxyz_ptmass(1:3,i) = vxyz_ptmass(1:3,i) + omegacrossr(1:3) - enddo - endif -end subroutine adjust_corotating_velocities - - -! returns a profile from the centre of mass -! profile can either use all particles or can find particles within 2h of a given ray -! if simple flag is set to true, it will only produce a limited subset -subroutine stellar_profile(time,ncols,particlemass,npart,xyzh,vxyzu,profile,simple,ray) - use eos, only:ieos,equationofstate,X_in, Z_in - use eos_mesa, only:get_eos_kappa_mesa,get_eos_pressure_temp_mesa - use physcon, only:kboltz,mass_proton_cgs - use centreofmass, only:get_centreofmass - use energies, only:compute_energies - use part, only:xyzmh_ptmass,rhoh,ihsoft,poten - use units, only:udist,unit_ergg,unit_density,unit_pressure,unit_velocity,unit_energ - use kernel, only:kernel_softening,radkern - use ptmass, only:get_accel_sink_gas - use ionization_mod, only:ionisation_fraction - - real, intent(in) :: time - integer, intent(in) :: ncols - real, intent(in) :: particlemass - integer, intent(in) :: npart - real, intent(in) :: xyzh(:,:) - real, intent(inout) :: vxyzu(:,:) - real, intent(out), allocatable :: profile(:,:) - logical, intent(in) :: simple - real, intent(in), optional :: ray(3) - integer :: i,iprofile - 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 :: xh0, xh1, xhe0, xhe1, xhe2 - real :: temp_profile(ncols,npart) - logical :: criteria - - call compute_energies(time) - - iprofile = 0 - - do i=1,npart - if (xyzh(4,i) >= 0) then - - if (present(ray)) then - proj_mag = dot_product(xyzh(1:3,i),ray(1:3)) - proj = proj_mag * ray - orth(1:3) = xyzh(1:3,i) - proj(1:3) - orth_dist = separation(orth,(/0.,0.,0./)) - orth_ratio = orth_dist / xyzh(4,i) - if (orth_ratio < radkern .and. proj_mag > 0.) then - criteria = .true. - else - criteria = .false. - endif - else - criteria = .true. - endif - - if (criteria) then - - iprofile = iprofile + 1 - - rhopart = rhoh(xyzh(4,i), particlemass) - - temp_profile(1,iprofile) = distance(xyzh(1:3,i)) * udist - temp_profile(3,iprofile) = atan2(xyzh(2,i),xyzh(1,i)) - temp_profile(4,iprofile) = rhopart * unit_density - temp_profile(5,iprofile) = distance(vxyzu(1:3,i)) * unit_velocity - temp_profile(6,iprofile) = dot_product(vxyzu(1:3,i),xyzh(1:3,i)) / distance(xyzh(1:3,i)) * unit_velocity - temp_profile(7,iprofile) = sqrt(distance(vxyzu(1:2,i))**2 - (dot_product(vxyzu(1:2,i),xyzh(1:2,i)) & - / distance(xyzh(1:2,i)))**2) * unit_velocity - temp_profile(8,iprofile) = temp_profile(7,iprofile) / (distance(xyzh(1:2,i)) * udist) - if (simple .eqv. .false.) then - call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - - if (ieos == 10) then - call get_eos_pressure_temp_mesa(rhopart*unit_density,vxyzu(4,i) * unit_ergg,pres,temp) - call get_eos_kappa_mesa(rhopart*unit_density,temp,kappa,kappat,kappar) - else - temp = (ponrhoi * (unit_pressure/unit_density) * 2.381 * mass_proton_cgs) / kboltz - kappa = 1. - endif - - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,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) - - temp_profile(9,iprofile) = vxyzu(4,i) * unit_ergg - temp_profile(10,iprofile) = ponrhoi * rhopart * unit_pressure - temp_profile(11,iprofile) = spsoundi * unit_velocity - temp_profile(12,iprofile) = temp - temp_profile(13,iprofile) = kappa - temp_profile(14,iprofile) = 1. / (kappa * rhopart * unit_density) - temp_profile(15,iprofile) = etoti * unit_energ - temp_profile(16,iprofile) = xh1 - temp_profile(17,iprofile) = xhe1 - temp_profile(18,iprofile) = xhe2 - endif - endif - endif - enddo - - allocate(profile(ncols,iprofile)) - profile(1:ncols,1:iprofile) = temp_profile(1:ncols,1:iprofile) - - call quicksort(profile, 1, iprofile, ncols, 1) - - do i=1,iprofile - if (i==1) profile(2,i) = particlemass - if (i > 1) profile(2,i) = profile(2,i-1) + particlemass - enddo - - deallocate(profile) - print*, "Profile completed" - -end subroutine stellar_profile - -!---------------------------------------------------------------- -!+ -! Calculate mass interior to companion -!+ -!---------------------------------------------------------------- -subroutine get_interior_mass(xyzh,vxyzu,donor_xyzm,companion_xyzm,particlemass,npart,iavgopt,interior_mass,com_xyz,com_vxyz) - real, intent(in) :: xyzh(:,:),vxyzu(:,:),donor_xyzm(4),companion_xyzm(4),particlemass - real, intent(out) :: interior_mass,com_xyz(3),com_vxyz(3) - integer, intent(in) :: npart,iavgopt - real :: sinksinksep,maxsep,sep,xyz_int(3,npart),vxyz_int(3,npart) - integer :: j,k,npart_int - integer, allocatable :: iorder(:) - - ! Calculate mass interior to companion - allocate(iorder(npart)) - call set_r2func_origin(donor_xyzm(1),donor_xyzm(2),donor_xyzm(3)) ! Order particles by distance from donor core - call indexxfunc(npart,r2func_origin,xyzh,iorder) - sinksinksep = separation(donor_xyzm(1:3), companion_xyzm(1:3)) - interior_mass = donor_xyzm(4) ! Include mass of donor core - select case(iavgopt) - case(5) ! Calculate mass interior to R/2 - maxsep = 2.*sinksinksep - case(6) ! Calculate mass interior to 2*R - maxsep = 0.5*sinksinksep - case default ! Calculate mass interior to R - maxsep = sinksinksep - end select - npart_int = 0 - do j = 1,npart - k = iorder(j) - sep = separation(donor_xyzm(1:3), xyzh(1:3,k)) - if (sep > maxsep) exit - npart_int = npart_int + 1 - xyz_int(1:3,npart_int) = xyzh(1:3,k) - vxyz_int(1:3,npart_int) = vxyzu(1:3,k) - enddo - interior_mass = npart_int * particlemass - - call get_centreofmass(com_xyz,com_vxyz,npart_int,xyz_int,vxyz_int,nptmass,xyzmh_ptmass,vxyz_ptmass) - deallocate(iorder) - -end subroutine get_interior_mass - -!---------------------------------------------------------------- -!+ -! Get CoM position and velocity of the two point masses plus -! gas particles radius = 2*sep from the donor, where sep is the -! distance between the donor and the CoM of just the point masses. -!+ -!---------------------------------------------------------------- -subroutine orbit_com(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,com_xyz,com_vxyz) - integer, intent(in) :: npart,nptmass - real, intent(in) :: xyzh(:,:),vxyzu(:,:),xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - real, intent(out), dimension(3) :: com_xyz,com_vxyz - real, allocatable :: xyz_a(:,:) - real, allocatable :: vxyz_a(:,:) - integer, allocatable :: iorder(:) - integer :: npart_a - real :: sep - integer :: i,j,k - - allocate(iorder(npart),xyz_a(4,npart),vxyz_a(3,npart)) - - ! Get order of particles by distance from CoM of point masses - com_xyz(1) = sum(xyzmh_ptmass(1,:)*xyzmh_ptmass(4,:))/nptmass - com_xyz(2) = sum(xyzmh_ptmass(2,:)*xyzmh_ptmass(4,:))/nptmass - com_xyz(3) = sum(xyzmh_ptmass(3,:)*xyzmh_ptmass(4,:))/nptmass - call set_r2func_origin(com_xyz(1),com_xyz(2),com_xyz(3)) - call indexxfunc(npart,r2func_origin,xyzh,iorder) - ! Displacement of donor core from the CoM of point masses - sep = separation(xyzmh_ptmass(1:3,1),com_xyz(1:3)) - - ! Calculate CoM of orbit, including only gas particles within radius = 2*sep from donor core - ! The point is that by including some gas particles around the donor core, we get a more accurate - ! position of the CoM about which the stellar cores orbit - i = 1 - k = 1 - do while (i < npart+1) - j = iorder(i) ! Loop from particles closest to farthest from CoM - if (isdead_or_accreted(xyzh(4,j))) then - i = i + 1 - else - if (separation(xyzh(1:3,j),com_xyz(1:3)) > 2.*sep) exit - xyz_a(1:4,k) = xyzh(1:4,j) - vxyz_a(1:3,k) = vxyzu(1:3,j) - i = i + 1 - k = k + 1 - endif - enddo - npart_a = k - 1 - call get_centreofmass(com_xyz,com_vxyz,npart_a,xyz_a,vxyz_a,nptmass,xyzmh_ptmass,vxyz_ptmass) - deallocate(iorder,xyz_a,vxyz_a) - -end subroutine orbit_com - -subroutine average_in_vol(xyzh,vxyzu,npart,particlemass,com_xyz,com_vxyz,isink,icentreonCM,iavgopt,vel,cs,omega,volume,vol_mass,& - vol_npart) - real, intent(in) :: xyzh(:,:),vxyzu(:,:),com_xyz(:),com_vxyz(:),particlemass - logical, intent(in) :: icentreonCM - real, intent(out) :: vel(:),cs,omega,volume,vol_mass - integer, intent(out) :: vol_npart - integer, intent(in) :: npart,isink,iavgopt - real :: orbit_centre(3),orbit_centre_vel(3),sphere_centre(3),Rarray(size(xyzh(1,:))),zarray(size(xyzh(1,:))),vxyzu_copy(4) - real :: Rsphere,sep,omega_out,Rsinksink,dR,dz,vphi - integer :: i,j,k,iorder(size(xyzh(1,:))) - - i = isink - if (icentreonCM) then ! Centre on orbit CoM - orbit_centre = com_xyz - orbit_centre_vel = com_vxyz - else ! Centre on primary core - orbit_centre = xyzmh_ptmass(1:3,3-i) - orbit_centre_vel = vxyz_ptmass(1:3,3-i) - endif - - Rsphere = 0.2 * separation(orbit_centre, xyzmh_ptmass(1:3,i)) - Rsinksink = separation(xyzmh_ptmass(1:2,i), xyzmh_ptmass(1:2,3-i)) ! [(x2-x1)^2 + (y2-y1)^2]^0.5 - dR = 0.2*Rsinksink - dz = 0.2*Rsinksink - vol_npart = 0 - vol_mass = 0. - omega = 0. - cs = 0. - - ! If averaging over a sphere, get order of particles from closest to farthest from sphere centre - dr = 0. - dz = 0. - Rsinksink = 0. - vol_npart = 0 - Rsphere = 0. - select case(iavgopt) - case(1,2,5,6) - select case (iavgopt) - case(1) ! Use companion position - sphere_centre = xyzmh_ptmass(1:3,i) - case(2) ! Use companion position on the opposite side of orbit - sphere_centre = 2.*orbit_centre - xyzmh_ptmass(1:3,i) ! Just r1 - (r2 - r1) - case(5) ! Averaging twice as far on opposite side of orbit - sphere_centre = 2.*(orbit_centre - xyzmh_ptmass(1:3,i)) ! Just r1 - 2(r2 - r1) - case(6) ! Averaging half as far on opposite side of orbit - sphere_centre = 1.5*orbit_centre - 0.5*xyzmh_ptmass(1:3,i) ! Just r1 - 0.5*(r2 - r1) - end select - call set_r2func_origin(sphere_centre(1),sphere_centre(2),sphere_centre(3)) - call indexxfunc(npart,r2func_origin,xyzh,iorder) - - ! Sum velocities, cs, and densities of all particles within averaging sphere - do j = 1,npart - k = iorder(j) ! Only use particles within the averaging sphere - if (.not. isdead_or_accreted(xyzh(4,k))) then - sep = separation(xyzh(1:3,k), sphere_centre) - if (sep > Rsphere) exit - vel(1:3) = vel(1:3) + vxyzu(1:3,k) - vxyzu_copy = vxyzu(:,k) - cs = cs + get_spsound(ieos,xyzh(1:3,k),rhoh(xyzh(4,k),particlemass),vxyzu_copy) - call get_gas_omega(orbit_centre,orbit_centre_vel,xyzh(1:3,k),vxyzu(1:3,k),vphi,omega_out) - omega = omega + omega_out - endif - enddo - vol_npart = j-1 ! Number of (unaccreted) particles in the sphere - vol_mass = vol_npart * particlemass - if ((iavgopt == 2) .or. (iavgopt == 5) .or. (iavgopt == 6)) vel = -vel ! To-do: get rid of this line - - ! Averaging in annulus - case(3,4) - Rarray = sqrt( (xyzh(1,:) - xyzmh_ptmass(1,3-i))**2 + (xyzh(2,:) - xyzmh_ptmass(2,3-i))**2) ! [(x-x1)^2 + (y-y1)^2]^0.5 - zarray = xyzh(3,:) - xyzmh_ptmass(3,3-i) - if (iavgopt == 4) Rsphere = 0.2*separation(xyzmh_ptmass(1:3,3-i),xyzmh_ptmass(1:3,i)) - do k = 1,npart - if ( (iavgopt == 4) .and. (separation(xyzh(1:3,k), xyzmh_ptmass(1:3,i)) < Rsphere) ) cycle - if ( (abs(Rarray(k) - Rsinksink) < 0.5*dR) .and.& - (abs(zarray(k) - xyzmh_ptmass(3,3-i)) < 0.5*dz) ) then - vel = vel + vxyzu(1:3,k) - vxyzu_copy = vxyzu(:,k) - cs = cs + get_spsound(ieos,xyzh(1:3,k),rhoh(xyzh(4,k),particlemass),vxyzu_copy) - call get_gas_omega(orbit_centre,orbit_centre_vel,xyzh(1:3,k),vxyzu(1:3,k),vphi,omega_out) - omega = omega + omega_out - vol_npart = vol_npart + 1 - endif - enddo - vol_mass = vol_npart * particlemass - end select - - ! Calculate averaging volume based on averaging option - select case (iavgopt) - case (1,2,5,6) ! Spheres - volume = 4./3.*pi*Rsphere**3 - case(3) ! Annulus - volume = 2.*pi * Rsinksink * dR * dz - case(4) ! Annulus with sphere subtracted - volume = 2.*pi * Rsinksink * dR * dz - volume = volume - 0.4*dR*dz*Rsinksink - case default - volume = 0. - print*,'Unknown averaging option' - return - end select - - ! Calculate volume averages - if (vol_npart > 0) then - vel(1:3) = vel(1:3) / float(vol_npart) - omega = omega / float(vol_npart) - cs = cs / float(vol_npart) - endif - -end subroutine average_in_vol - - -!---------------------------------------------------------------- -!+ -! Returns hist, the radial or mass-coordinate profile of a -! quantity. -! -! Inputs: -! coord: Array of radius or mass-coordinate of each particle -! quant: Array containing quantity for each particle to be binned -! bin_min: Lower bin edge for coord -! bin_max: Upper bin edge for coord -! nbins: Number of bins for coord -! logbins: If true, produce log-uniform bins -! normalise_by_bincount: If true, normalises histogram by bin -! count, thus averaging the quantity -!+ -!---------------------------------------------------------------- -subroutine histogram_setup(coord,quant,hist,npart,bin_max,bin_min,nbins,normalise_by_bincount,logbins) - integer, intent(in) :: npart,nbins - real, intent(in) :: coord(npart),quant(npart),bin_max, bin_min - logical, intent(in) :: normalise_by_bincount,logbins - real, intent(out) :: hist(nbins) - integer :: i,j,bincount(nbins) - real :: bins(nbins) - - if (logbins) then ! Create log-uniform bins - bins = (/ (10**(bin_min + (i-1) * (bin_max-bin_min)/real(nbins)), i=1,nbins) /) - else ! Create linear bins - bins = (/ (bin_min + (i-1) * (bin_max-bin_min)/real(nbins), i=1,nbins) /) - endif - - hist = 0. - bincount = 0 - - do j=1,npart - do i=1,nbins-1 - if (coord(j) >= bins(i) .and. coord(j) < bins(i+1)) then - bincount(i) = bincount(i) + 1 - hist(i) = hist(i) + quant(j) - exit ! Move onto next particle - endif - enddo - enddo - - if (normalise_by_bincount) then - do i=1,nbins - if (bincount(i) > 0) then - hist(i) = hist(i) / real(bincount(i)) - endif - enddo - endif - -end subroutine histogram_setup - -subroutine write_file(name_in, dir_in, cols, data_in, npart, ncols, num) - !outputs a file from a single dump - character(len=*), intent(in) :: name_in, dir_in - integer, intent(in) :: npart, ncols, num - character(len=*), dimension(ncols), intent(in) :: cols - character(len=20), dimension(ncols) :: columns - character(len=40) :: data_formatter, column_formatter - character(len(name_in)+9) :: file_name - - real, dimension(ncols,npart), intent(in) :: data_in - integer :: i, unitnum - - unitnum = 1000 + num - if (dump_number == 0) then - call system('mkdir ' // dir_in ) - endif - - write(file_name, "(2a,i5.5,a)") trim(name_in), "_", num, ".ev" - - open(unit=unitnum, file='./'//dir_in//'/'//file_name, status='replace') - - write(column_formatter, "(a,I2.2,a)") "('#',2x,", ncols, "('[',a15,']',3x))" - write(data_formatter, "(a,I2.2,a)") "(", ncols, "(2x,es19.11e3))" - - do i=1,ncols - write(columns(i), "(I2.2,a)") i, cols(i) - enddo - - !set column headings - write(unitnum, column_formatter) columns(:) - - !Write data to file - do i=1,npart - write(unitnum,data_formatter) data_in(:ncols,i) - enddo - - close(unit=unitnum) -end subroutine write_file - - -subroutine write_time_file(name_in, cols, time, data_in, ncols, num) - !outputs a file over a series of dumps - character(len=*), intent(in) :: name_in - integer, intent(in) :: ncols, num - character(len=*), dimension(ncols), intent(in) :: cols - character(len=20), dimension(ncols) :: columns - character(len=40) :: data_formatter, column_formatter - character(len(name_in)+9) :: file_name - real, intent(in) :: time - real, dimension(ncols), intent(in) :: data_in - integer :: i, unitnum - - write(column_formatter, "(a,I2.2,a)") "('#',2x,", ncols+1, "('[',a15,']',3x))" - write(data_formatter, "(a,I2.2,a)") "(", ncols+1, "(2x,es18.11e2))" - write(file_name,"(2a,i3.3,a)") name_in, '.ev' - - if (num == 0) then - unitnum = 1000 - - open(unit=unitnum, file=file_name, status='replace') - do i=1,ncols - write(columns(i), "(I2,a)") i+1, cols(i) - enddo - - !set column headings - write(unitnum, column_formatter) '1 time', columns(:) - close(unit=unitnum) - endif - - unitnum=1001+num - - open(unit=unitnum, file=file_name, position='append') - - write(unitnum,data_formatter) time, data_in(:ncols) - - close(unit=unitnum) - -end subroutine write_time_file - -real function distance(a) - ! Return norm of a vector of arbitrary dimension - real, intent(in), dimension(:) :: a - - distance = sqrt(dot_product(a,a)) -end function distance - -subroutine unit_vector(a,b) - real, intent(in), dimension(3) :: a - real, intent(out), dimension(3) :: b - - b(1:3) = a(1:3) / distance(a(1:3)) -end subroutine unit_vector - -real function cos_vector_angle(a,b) - real, intent(in), dimension(3) :: a,b - if (distance(a) == 0 .or. distance(b) == 0) then - cos_vector_angle = 1. - else - cos_vector_angle = dot_product(a,b) / (distance(a) * distance(b)) - endif -end function cos_vector_angle - -subroutine separation_vector(a,b,c) - !return difference between two vectors - real, intent(in), dimension(3) :: a,b - real, intent(out), dimension(4) :: c - - c(1) = a(1) - b(1) - c(2) = a(2) - b(2) - c(3) = a(3) - b(3) - c(4) = distance(c(1:3)) -end subroutine separation_vector - -real function separation(a,b) - !return the distance between two vectors - real, intent(in), dimension(:) :: a,b - - separation = distance(a - b) -end function separation - -!Creates an array of SPH particle densities for each value of h. -elemental real function getParticleRho(h,particlemass) - real, intent(in) :: h,particlemass - getParticleRho=rhoh(h,particlemass) -end function getParticleRho - -!Performs SPH interpolation on the SPH particle property toInterpolate at the location interpolateXyz. -!The smoothing length used is the smoothing length of the closest SPH particle to interpolateXyz. -function sphInterpolation(npart,particlemass,particleRho,particleXyzh,interpolateXyz,toInterpolate) result(interpolatedData) - use kernel, only:wkern - integer, intent(in) :: npart - real, intent(in) :: particlemass - real, intent(in) :: particleRho(npart) - real, intent(in) :: particleXyzh(4,npart) - real, intent(in) :: interpolateXyz(3) - real, intent(in) :: toInterpolate(:,:) - real :: interpolatedData(size(toInterpolate,1)) - - integer :: i,j - integer, allocatable :: iorder(:) - real :: currentR,currentQ,currentQ2 - real :: nearestSphH - real :: currentParticleRho,currentSphSummandFactor - - interpolatedData=0.0 - allocate(iorder(npart)) - call set_r2func_origin(interpolateXyz(1),interpolateXyz(2),interpolateXyz(3)) - call indexxfunc(npart,r2func_origin,particleXyzh,iorder) !Gets the order of SPH particles from the interpolation point. - nearestSphH=particleXyzh(4,iorder(1)) !The smoothing length of the nearest SPH particle to the ineterpolation point. - - do i=1,npart - j=iorder(i) - - currentR=separation(interpolateXyz,particleXyzh(1:3,j)) - currentQ=currentR/nearestSphH !currentR is scaled in units of nearestSphH - currentQ2=currentQ**2.0 - - !All SPH particles beyond 2 smoothing lengths are ignored. - if (currentQ>2) then - exit - endif - - !SPH interpolation is done below. - currentParticleRho=particleRho(j) - currentSphSummandFactor=(particlemass/currentParticleRho)*((1.0/((nearestSphH**3.0)*pi))*wkern(currentQ2,currentQ)) - interpolatedData=interpolatedData+(currentSphSummandFactor*toInterpolate(:,j)) - enddo - deallocate(iorder) - -end function sphInterpolation - -!Sorting routines -recursive subroutine quicksort(a, first, last, ncols, sortcol) - integer, intent(in) :: first, last, ncols, sortcol - real, dimension(ncols,last-first+1), intent(inout) :: a - real :: x - integer :: i, j, k - - x = a(sortcol, (first+last) / 2 ) - i = first - j = last - do - do while (a(sortcol, i) < x) - i=i+1 - enddo - - do while (x < a(sortcol, j)) - j=j-1 - enddo - - if (i >= j) exit - - do k=1,ncols - call swap(a(k,i),a(k,j)) - enddo - - i=i+1 - j=j-1 - enddo - if (first < i-1) call quicksort(a, first, i-1, ncols, sortcol) - if (j+1 < last) call quicksort(a, j+1, last, ncols, sortcol) -end subroutine quicksort - -subroutine swap(a,b) - real, intent(inout) :: a,b - real :: c - - c = a - a = b - b = c - -end subroutine swap - - -!---------------------------------------------------------------- -!+ -! Determine ID of planet particles based on distance from host star core -!+ -!---------------------------------------------------------------- -subroutine get_planetIDs(nplanet,planetIDs) - integer, allocatable, intent(out) :: planetIDs(:) - integer, intent(out) :: nplanet - integer :: i - - ! Determine planet particle IDs (the nplanet particles initially farthest from the donor star) - nplanet = 1262 - call prompt('Enter number of planet particles:',nplanet,0) - allocate(planetIDs(nplanet)) - do i = 1,nplanet - planetIDs(i) = i - enddo - -end subroutine get_planetIDs - - -!---------------------------------------------------------------- -!+ -! Set EOS options for analysis -!+ -!---------------------------------------------------------------- -subroutine set_eos_options(analysis_to_perform) - integer, intent(in) :: analysis_to_perform - integer :: ierr - - ieos = 2 - call prompt('Enter ieos:',ieos) - select case(ieos) - 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 - case(10,20) - gamma = 5./3. - X_in = 0.69843 - Z_in = 0.01426 - call prompt('Enter hydrogen mass fraction:',X_in,0.,1.) - call prompt('Enter metallicity:',Z_in,0.,1.) - irecomb = 0 - if (ieos==20) call prompt('Using gas+rad+rec EoS. Enter irecomb:',irecomb,0,2) - case default - call fatal('analysis_common_envelope',"EOS type not supported") - end select - call init_eos(ieos,ierr) - if (ierr /= 0) call fatal('analysis_common_envelope',"Failed to initialise EOS") - -end subroutine set_eos_options - - -!---------------------------------------------------------------- -!+ -! Calculates escape velocity for all SPH particles given the potential energy -! of the system at that time -!+ -!---------------------------------------------------------------- -subroutine calc_escape_velocities(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phii,epoti,v_esc) - use ptmass, only:get_accel_sink_gas - use part, only:nptmass - real, intent(in) :: particlemass - real(4), intent(in) :: poten - real, dimension(4), intent(in) :: xyzh,vxyzu - real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass - real :: phii,epoti - real :: fxi,fyi,fzi - real, intent(out) :: v_esc - - phii = 0.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 - v_esc = sqrt(2*abs(epoti/particlemass)) - -end subroutine calc_escape_velocities - -end module analysis diff --git a/src/utils/analysis_dustywind.F90 b/src/utils/analysis_dustywind.F90 deleted file mode 100644 index 2485a4fad..000000000 --- a/src/utils/analysis_dustywind.F90 +++ /dev/null @@ -1,348 +0,0 @@ -!--------------------------------------------------------------------------! -! 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.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module analysis -! -! Analysis routine for dusty wind testing -! -! :References: None -! -! :Owner: Lionel Siess -! -! :Runtime parameters: None -! -! :Dependencies: dim, dust_formation, kernel, part, units -! - - implicit none - character(len=20), parameter, public :: analysistype = 'dustywind' - - public :: do_analysis - - private - integer, parameter :: N = 1024 !32 - double precision, parameter :: theta = 0., phi = 0. - double precision, parameter :: u(3) = (/ sin(theta)*cos(phi), sin(theta)*sin(phi), cos(theta) /) - -contains - -subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) - - use part, only: nptmass,xyzmh_ptmass,vxyz_ptmass,iLum,iTeff,iReff - use part, only: dust_temp,isdead_or_accreted,nucleation - use dust_formation, only: set_abundances - - !general variables - character(len=*), intent(in) :: dumpfile - integer, intent(in) :: num,npart,iunit - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real, intent(in) :: particlemass,time - - real :: L_star,T_star,R_star,xa,ya,za - integer :: j - - call set_abundances - !property of the sink particle - j = 1 - T_star = xyzmh_ptmass(iTeff,j) - L_star = xyzmh_ptmass(iLum,j) - R_star = xyzmh_ptmass(iReff,j) !sqrt(L_star/(4.*pi*steboltz*utime**3/umass*R_star**4)) - xa = xyzmh_ptmass(1,j) - ya = xyzmh_ptmass(2,j) - za = xyzmh_ptmass(3,j) - call get_Teq_from_Lucy(npart,xyzh,xa,ya,za,R_star,T_star,dust_temp) - - -end subroutine do_analysis - -!------------------------------------------------------------------------------- -!+ -! Calculates the radiative equilibrium temperature using the Lucy approximation -! Performs ray-tracing along 1 direction (could be generalized to include other directions) -!+ -!------------------------------------------------------------------------------- -subroutine get_Teq_from_Lucy(npart,xyzh,xa,ya,za,R_star,T_star,dust_temp) - use part, only:isdead_or_accreted,nucleation,idK3 - use dim, only:do_nucleation - integer, intent(in) :: npart - real, intent(in) :: xyzh(:,:),xa,ya,za,R_star,T_star - real, intent(out) :: dust_temp(:) - real :: r(3),r0(3),d,dmin,dmax,d2_axis,OR(N),Teq(N),K3(N),rho_over_r2(2*N+1),rho(N) - integer :: i,idx_axis(npart),naxis - - !.. find particles that lie within 2 smoothing lengths of the ray axis - r0(1:3) = (/xa, ya, za/) - dmin = 1.d99 - dmax = 0 - naxis = 0 -!$omp parallel do default(none) & -!$omp shared(npart,xyzh,r0,naxis,idx_axis) & -!$omp private(i,r,d,d2_axis) & -!$omp reduction(min:dmin) & -!$omp reduction(max:dmax) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - r = xyzh(1:3,i)-r0 - !d = r(1)**2+r(2)**2+r(3)**2 - d = dot_product(r,r) - dmin = min(d,dmin) - dmax = max(d,dmax) - !distance to the axis - !d2_axis = sq_distance_to_z(r) - d2_axis = sq_distance_to_line(r,u) - if (d2_axis < 4.*xyzh(4,i)*xyzh(4,i)) then - !$omp critical (crit_naxis_add) - naxis = naxis+1 - idx_axis(naxis) = i - !$omp end critical (crit_naxis_add) - endif - endif - enddo -!$omp end parallel do - dmin = sqrt(dmin) - dmax = sqrt(dmax) - - - if (do_nucleation) then - call density_along_line(npart, xyzh, r0, naxis, idx_axis, -dmax, dmax, R_star, N, rho, & - rho_over_r2, dust_temp, Teq, nucleation(idK3,:), K3) - call calculate_Teq(N, dmax, R_star, T_star, rho, rho_over_r2, OR, Teq, K3) - else - call density_along_line(npart, xyzh, r0, naxis, idx_axis, -dmax, dmax, R_star, N, rho, & - rho_over_r2, dust_temp, Teq) - call calculate_Teq(N, dmax, R_star, T_star, rho, rho_over_r2, OR, Teq) - endif - call interpolate_on_particles(npart, N, dmax, r0, Teq, dust_temp, xyzh) - -end subroutine get_Teq_from_Lucy - -!-------------------------------------------------------------------------- -!+ -! Calculates the radiative equilibrium temperature along the ray direction -!+ -!-------------------------------------------------------------------------- -subroutine calculate_Teq(N, dmax, R_star, T_star, rho, rho_over_r2, OR, Teq, K3) - use dust_formation, only : calc_kappa_dust,calc_kappa_bowen,idust_opacity - integer, intent(in) :: N - real, intent(in) :: dmax, R_star, T_star, rho(N), rho_over_r2(2*N+1) - real, optional, intent(in) :: K3(N) - real, intent(out) :: Teq(N) - - real :: OR(N),tau_prime(N),vTeq(N),kappa(N),dTeq,pTeq(N) - real :: dr, fact, rho_on_r2(N) - real, parameter :: tol = 1.d-2, kap_gas = 2.d-4 - integer :: i,istart,iter - - - tau_prime = 0. - iter = 0 - vTeq = 0. - dTeq = 1. - dr = dmax/N - forall(i=1:N) OR(i) = i*dr - OR(N) = dmax - fact = dr/2. * R_star**2 - do i = 1,N - if (OR(i) > R_star) exit - enddo - istart = i-1 - if (istart > 0) Teq(1:istart) = T_star - Teq(istart+1:N) = T_star*(0.5*(1.-sqrt(1.-(R_star/OR(istart+1:N))**2))) - vTeq = Teq - pTeq= Teq - rho_on_r2 = 0. - kappa = 0. - - do while (dTeq > tol .and. iter < 20) - if (iter == 0) dTeq = 0. - iter = iter+1 - do i=N-1,istart+1,-1 - if (idust_opacity == 2) then - if (rho(i) > 0.) then - kappa(i) = calc_kappa_dust(K3(i),Teq(i),rho(i)) - else - kappa(i) = 0.d0 - endif - elseif (idust_opacity == 1) then - kappa(i) = calc_kappa_bowen(Teq(i)) - endif - rho_on_r2(i) = rho_over_r2(N-i)+rho_over_r2(N-i+1)+rho_over_r2(N+i+1)+rho_over_r2(N+i+2) - !if (iter >= 1) print *,'teq loop',i,K3(i),Teq(i),kappa(i),rho_on_r2(i) - tau_prime(i) = tau_prime(i+1) + fact*(kappa(i)+kap_gas) *rho_on_r2(i) - - Teq(i) = T_star*(0.5*(1.-sqrt(1.-(R_star/OR(i))**2)) + 0.75*tau_prime(i))**(1./4.) - dTeq = max(dTeq,abs(1.-Teq(i)/(1.d-5+vTeq(i)))) - vTeq(i) = Teq(i) - enddo - print *,iter,dTeq - enddo - print *,iter - open(unit=220,file='Teq.dat') - write(220,*) '# ng z vTeq Teq tau kappa rho_on_r2' - do i = 1,N - write(220,*) i,OR(i),pTeq(i),Teq(i),tau_prime(i),kappa(i),rho_on_r2(i) - enddo - close(220) - -end subroutine calculate_Teq - -!----------------------------------------------------------------------- -!+ -! compute the mean properties along the ray -!+ -!----------------------------------------------------------------------- -subroutine density_along_line(npart, xyzh, r0, npart_axis, idx_axis, rmin, rmax, r_star, N, & - rho_cgs, rho_over_r2, T, Teq, K3, K3i) - use kernel, only:cnormk,wkern - use part, only:massoftype,igas,rhoh - use units, only:unit_density - integer, intent(in) :: npart,N - real, intent(in) :: xyzh(:,:), T(:), r0(3) - real, optional, intent(in) :: K3(:) - integer, intent(in) :: npart_axis, idx_axis(npart) - real, intent(in) :: rmin, rmax, R_star - real, intent(out) :: rho_over_r2(2*N+1), Teq(N), rho_cgs(N) - real, optional, intent(out) :: K3i(N) - real :: rhoi(2*N+1), OR(2*N+1), Ti(2*N+1), Ki(2*N+1), xnorm(2*N+1) - real :: OH, d2_axis, HR, q2, q, fact0, fact, h, h2, part_mass - real :: delta_r, rmin_o, rmin_p, rmax_p, dr, r(3), xfact, rhoinv - integer :: i, np, j, j_min, j_max, Nr - -! Discretization of the line of sight in N segments - Nr = 2*N+1 - dr = (rmax-rmin)/(Nr-1) - rmin_o = rmin - dr - do i=1,Nr - OR(i) = dr*i+rmin_o - print *,i,OR(i),R_star - enddo - print *,'*******',rmax,rmin,r_star - - open(unit=220,file='allpart.dat') - write(220,*) '# ng x y z rho T K' - do i = 1, npart - write (220,*) np,xyzh(1:3,i)-r0(3),rhoh(xyzh(4,i),part_mass),T(i),K3(i) - enddo - close(220) - rhoi(:) = 0. - Teq(:) = 0. - K3i(:) = 0. - Ki(:) = 0. - Ti(:) = 0. - xnorm(:) = 0. - part_mass = massoftype(igas) - fact0 = part_mass*cnormk - open(unit=221,file='part_axis.dat') - write(221,*) '# ng x y z rho T K' - do i = 1, npart_axis - np = idx_axis(i) - r = xyzh(1:3,np)-r0(3) - !distance to z-axis - !OH = r(3) - !d2_axis = sq_distance_to_z(r) - OH = dot_product(r,u) - d2_axis = sq_distance_to_line(r,u) - h = xyzh(4,np) - h2 = h*h - delta_r = sqrt(4.*h2 - d2_axis) - ! rmin_p and rmax_p are the positions on the line of the two intersections between the line and the interaction sphere - rmin_p = OH-delta_r - rmax_p = OH+delta_r - j_min = ceiling((rmin_p-rmin_o)/dr) - j_max = floor((rmax_p-rmin_o)/dr) - j_min = max(1, j_min) - j_max = min(Nr, j_max) - ! Adds the contribution of particle np to density at all the discretized locations in the interaction sphere - fact = fact0/h**3 - rhoinv = 1./rhoh(h,part_mass) - write (221,*) np,r,rhoh(h,part_mass),T(np),K3(np) - do j=j_min, j_max - HR = OR(j) - OH - q2 = (d2_axis+HR**2)/h2 - q = sqrt(q2) - xfact = fact*wkern(q2,q) - rhoi(j) = rhoi(j) + xfact - xnorm(j) = xnorm(j)+xfact*rhoinv - Ti(j) = Ti(j) + xfact*rhoinv*T(np) - if (present(K3)) Ki(j) = Ki(j) + xfact*rhoinv*K3(np) - !print *,j,Ti(j),T(np),part_mass/(rhoh(h,part_mass)*h**3)!rhoh(h,part_mass),part_mass,q,fact,wkern(q2,q) - enddo - enddo - close (221) -! rho_over_r2 = 0 inside the star so that we do not divide by zero! - open(unit=222,file='ray.dat') - write(222,*) '# ng z rho T K xnorm rho_over_r2' - do j=1,Nr - if (xnorm(j) > 0.) then - Ti(j) = Ti(j)/xnorm(j) - if (present(K3)) Ki(j) = Ki(j) /xnorm(j) - endif - if (abs(OR(j)) < r_star) then - rho_over_r2(j) = 0. - else - rho_over_r2(j) = rhoi(j)/OR(j)**2 - endif - print *,j,rho_over_r2(j) - write (222,*) j,OR(j),rhoi(j),Ti(j),Ki(j),xnorm(j),rho_over_r2(j) - enddo - close(222) - do j=1,N - rho_cgs(N+1-j) = (rhoi(j)+rhoi(2*N-j+2))*unit_density/2. - Teq(N+1-j) = (Ti(j)+Ti(2*N-j+2))/2. - if (present(K3)) K3i(N+1-j) = (Ki(j)+Ki(2*N-j+2))/2. -! print *,'k3i',j,k3i(j) - enddo - -end subroutine density_along_line - -!----------------------------------------------------------------------- -!+ -! Interpolates a quantity computed on the discretized line of sight for all SPH particles -! (spherical symmetry assumed) -!+ -!----------------------------------------------------------------------- -subroutine interpolate_on_particles(npart, N, dmax, r0, Teq, dust_temp, xyzh) - use part, only:isdead_or_accreted - integer, intent(in) :: npart, N - real, intent(in) :: dmax, r0(3), Teq(N), xyzh(:,:) - real, intent(out) :: dust_temp(:) - - real :: r(3), d, dr, d2 - integer :: i, j - - dr = dmax / N - !should start at nwall - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - r = xyzh(1:3,i) - r0 - d2 = dot_product(r,r) - d = sqrt(d2) - j = min(int(d/dr),N-1) - dust_temp(i) = (d-dr*j)*(Teq(j+1)-Teq(j))/dr + Teq(j) - endif - enddo - open(unit=220,file='all_final.dat') - write(220,*) '# ng x y z T' - do i = 1, npart - write (220,*) i,xyzh(1:3,i)-r0(3),dust_temp(i) - enddo - close(220) -end subroutine interpolate_on_particles - -real function sq_distance_to_z(r) - real, intent(in) :: r(3) - sq_distance_to_z = r(1)*r(1)+r(2)*r(2) -end function sq_distance_to_z - -real function sq_distance_to_line(r,u) - real, intent(in) :: r(3),u(3) - real :: p,d(3) - p = dot_product(r,u) - d = r-p*u - sq_distance_to_line = dot_product(d,d) -end function sq_distance_to_line - -end module analysis diff --git a/src/utils/analysis_kdtree.F90 b/src/utils/analysis_kdtree.F90 index 9ebd7492d..ef83ee5e3 100644 --- a/src/utils/analysis_kdtree.F90 +++ b/src/utils/analysis_kdtree.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_protostar_environ.F90 b/src/utils/analysis_protostar_environ.F90 index 94c362c9c..6ac1dcd41 100644 --- a/src/utils/analysis_protostar_environ.F90 +++ b/src/utils/analysis_protostar_environ.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/analysis_write_kdtree.F90 b/src/utils/analysis_write_kdtree.F90 index 777dcbf29..a185c915d 100644 --- a/src/utils/analysis_write_kdtree.F90 +++ b/src/utils/analysis_write_kdtree.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module analysis ! diff --git a/src/utils/interpolate3D_amr.F90 b/src/utils/interpolate3D_amr.F90 index 6bc232f05..49a9eb8b7 100644 --- a/src/utils/interpolate3D_amr.F90 +++ b/src/utils/interpolate3D_amr.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module interpolations3D_amr ! diff --git a/src/utils/struct_part.F90 b/src/utils/struct_part.F90 deleted file mode 100644 index 44ffa447e..000000000 --- a/src/utils/struct_part.F90 +++ /dev/null @@ -1,269 +0,0 @@ -!--------------------------------------------------------------------------! -! 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.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module structurefn_part -! -! module for obtaining structure functions -! direct from SPH particles -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: random, timing -! - implicit none - -contains - -subroutine get_structure_fn(sf,nbins,norder,distmin,distmax,xbins,ncount,npart,xyz,vel,& - rho,dxbox,dybox,dzbox,massweighted,ierr) - !use fastmath, only:finvsqrt - use timing, only:get_timings,print_time - use random, only:ran2 - integer, intent(in) :: npart,nbins,norder - real, intent(in) :: xyz(:,:) - real, intent(in) :: vel(:,:) - real, intent(in) :: rho(:) - real(kind=8), intent(out) :: sf(2,norder,nbins) - real, intent(out) :: xbins(nbins) - integer(kind=8), intent(out) :: ncount(nbins) - real, intent(in) :: distmax,distmin - real, intent(in) :: dxbox,dybox,dzbox - logical, intent(in) :: massweighted - integer, intent(out) :: ierr - - real(kind=8) :: sfprev(2,norder,nbins) - integer, allocatable :: list(:) - integer :: i,iran,ipart,ipt,iorder,ibin,iseed,npts,isf,nptstot,its - real :: err(norder),sfmax(norder) - real :: xpt(3),velpt(3) - real :: dxbin,dvx,dvy,dvz,dx,dy,dz,rij1,rij - real(kind=4) :: t1,t2,tcpu1,tcpu2 - real :: rij2,distmin2,ddxbin,minusdistminddxbin - real :: dvdotr,dvterm,dvtrans,rhomax,errtot,temp - real(kind=8) :: dvdotrterm,dvtransterm -!$ integer :: omp_get_num_threads - logical :: converged -! -!--set up the distance bins (linear) -! - dxbin = (distmax-distmin)/float(nbins-1) - do ibin=1,nbins - xbins(ibin) = distmin + (ibin-0.5)*dxbin - enddo - distmin2 = distmin*distmin - ddxbin = 1./dxbin - minusdistminddxbin = -distmin*ddxbin - ierr = 0 -! -!--set structure functions to zero -! - sf(:,:,:) = 0. - sfprev(:,:,:) = 0. - ncount(:) = 0 - iseed = -128 - npts = min(128,npart) - nptstot = 0 - its = 0 -! -!--start with a low number of points, and we keep adding more -! points until the structure function calculation is converged -! - converged = .false. - !$omp parallel - !$omp master -!$ print*,' Using ',omp_get_num_threads(),' cpus' - !$omp end master - !$omp end parallel - - iterations: do while(nptstot <= npart .and. .not.converged) - - its = its + 1 - nptstot = nptstot + npts - print "(a,i2,2(a,i10),a)",' Iteration ',its,': adding ',npts,' sample particles (',nptstot,' in total)' - if (allocated(list)) deallocate(list) - allocate(list(npts),stat=ierr) - if (ierr /= 0) then - print*,' error: cannot allocate memory for ',npts,' sample particles ' - sf = sfprev - return - endif - print*,' iseed = ',iseed,' ncount(1:10) = ',ncount(1:10) - - ! - !--choose a random selection of npts particles - ! - if (massweighted) then - ! - !--select particles randomly according to particle id - ! (this preferentially selects particles in dense regions) - ! - do ipt=1,npts - iran = int(ran2(iseed)*npart) + 1 - list(ipt) = iran - enddo - else - ! - !--alternatively, select particles but weight selection by - ! the volume element m/rho, i.e., inversely proportional to rho - ! - rhomax = 0. - !$omp parallel do schedule(static) private(i) reduction(max:rhomax) - do i=1,npart - rhomax = max(rho(i),rhomax) - enddo - if (rhomax <= 0.) then - print*,' ERROR: max density on particles <= 0' - print*,' cannot use volume element weighting for structure fns' - return - endif - ipt = 0 - write(*,"(2x,a,i8,a)",ADVANCE='NO') 'choosing ',npts,' volume-weighted points...' - do while(ipt < npts) -!--first random number chooses the particle - iran = int(ran2(iseed)*npart) + 1 -!--then select particle if rho/rhomax (0..1) is less than -! a second random number - if (rho(iran)/rhomax < ran2(iseed)) then - ipt = ipt + 1 - list(ipt) = iran - endif - enddo - print*,' done' - endif - - call get_timings(t1,tcpu1) - !$omp parallel do schedule(runtime) default(none) & - !$omp shared(npts,xyz,vel,list,npart) & - !$omp firstprivate(distmin2,dxbox,dybox,dzbox,ddxbin,norder,minusdistminddxbin) & - !$omp private(ipt,xpt,velpt,dx,dy,dz,rij2,rij1,rij,dvdotr) & - !$omp private(i,dvx,dvy,dvz) & - !$omp private(dvterm,dvtrans,dvdotrterm,dvtransterm,ibin) & - !$omp reduction(+:ncount) & - !$omp reduction(+:sf) - do ipt=1,npts -#ifndef _OPENMP - if (mod(ipt,100)==0) then - call cpu_time(tcpu2) - print*,' ipt = ',ipt,tcpu2-tcpu1 - endif -#endif - i = list(ipt) - xpt(1) = xyz(1,i) - xpt(2) = xyz(2,i) - xpt(3) = xyz(3,i) - velpt(1) = vel(1,i) - velpt(2) = vel(2,i) - velpt(3) = vel(3,i) - - do ipart=1,npart - dx = xyz(1,ipart) - xpt(1) - dy = xyz(2,ipart) - xpt(2) - dz = xyz(3,ipart) - xpt(3) - !--mod distances with periodic boundary - if (abs(dx) > 0.5*dxbox) dx = dx - dxbox*sign(1.0,dx) - if (abs(dy) > 0.5*dybox) dy = dy - dybox*sign(1.0,dy) - if (abs(dz) > 0.5*dzbox) dz = dz - dzbox*sign(1.0,dz) - - rij2 = dx*dx + dy*dy + dz*dz -! -!--work out which distance bin this pair lies in -! exclude pairs which lie closer than the minimum -! separation bin -! - if (rij2 > distmin2) then - dvx = vel(1,ipart) - velpt(1) - dvy = vel(2,ipart) - velpt(2) - dvz = vel(3,ipart) - velpt(3) - - ! rij1 = finvsqrt(rij2) - rij1 = 1./sqrt(rij2) - - dvdotr = abs((dvx*dx + dvy*dy + dvz*dz)*rij1) - dvterm = (dvx*dvx + dvy*dvy + dvz*dvz) - dvdotr*dvdotr - if (dvterm < 0.) dvterm = 0. - dvtrans = sqrt(dvterm) - - rij = 1./rij1 - ibin = int(rij*ddxbin + minusdistminddxbin) + 1 - !if (ibin < 1 .or. ibin > nbins) stop 'ibin out of range' - - dvdotrterm = 1.0d0 - dvtransterm = 1.0d0 - do iorder=1,norder - dvdotrterm = dvdotrterm*dvdotr ! dvdotrterm = dvdotr**iorder - dvtransterm = dvtransterm*dvtrans ! dvtransterm = dvtrans**iorder - - sf(1,iorder,ibin) = sf(1,iorder,ibin) + dvdotrterm - sf(2,iorder,ibin) = sf(2,iorder,ibin) + dvtransterm - enddo - ncount(ibin) = ncount(ibin) + 1_8 - endif - enddo - enddo - !$omp end parallel do - call get_timings(t2,tcpu2) - call print_time(t2-t1,' wall time :') - call print_time(tcpu2-tcpu1,' cpu time :') - - err(:) = 0. - sfmax(:) = 0. - !$omp parallel do schedule(runtime) private(ibin) & - !$omp reduction(+:err) & - !$omp reduction(max:sfmax) - do ibin=1,nbins - if (ncount(ibin) > 0) then - do iorder=1,norder - do isf=1,2 - temp = sf(isf,iorder,ibin)/real(ncount(ibin)) - err(iorder) = err(iorder) + (temp - sfprev(isf,iorder,ibin))**2 - sfmax(iorder) = max(sfmax(iorder),temp) - sfprev(isf,iorder,ibin) = temp - enddo - enddo - else - sfprev(:,:,ibin) = 0. - endif - enddo - !$omp end parallel do - - errtot = 0. - do iorder=1,norder - if (sfmax(iorder) > 0.) then - err(iorder) = err(iorder)/sfmax(iorder)**2/real(nbins*2) - endif - errtot = errtot + err(iorder) - print*,' Error in structure function of order ',iorder,' = ',sqrt(err(iorder)) - enddo - errtot = sqrt(errtot/real(norder)) - print*,' mean square error = ',errtot - converged = maxval(sqrt(err(1:norder))) < 1.e-2 .and. errtot < 1.e-2 - npts = min(nptstot,npart-nptstot) - - ! - !--write the iterations to file (debugging only) - ! - !do i=1,nbins - ! write(10+its,*) xbins(i),(sfprev(1,iorder,i),iorder=1,norder) - !enddo - - enddo iterations - - print*,' Converged!' - - !$omp parallel do schedule(static) private(ibin) - do ibin=1,nbins - sf(:,:,ibin) = sfprev(:,:,ibin) - enddo - - if (allocated(list)) deallocate(list) - -end subroutine get_structure_fn - -end module structurefn_part diff --git a/src/utils/utils_getneighbours.F90 b/src/utils/utils_getneighbours.F90 index 6dde04c82..0e889d282 100644 --- a/src/utils/utils_getneighbours.F90 +++ b/src/utils/utils_getneighbours.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module getneighbours ! diff --git a/src/utils/utils_raytracer_all.F90 b/src/utils/utils_raytracer_all.F90 deleted file mode 100644 index fbf41e28f..000000000 --- a/src/utils/utils_raytracer_all.F90 +++ /dev/null @@ -1,1199 +0,0 @@ -!--------------------------------------------------------------------------! -! 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.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module raytracer_all -! -! raytracer_all -! -! :References: Esseldeurs M., Siess L. et al, 2023, A&A, 674, A122 -! -! :Owner: Mats Esseldeurs -! -! :Runtime parameters: None -! -! :Dependencies: healpix, kernel, linklist, part, units -! - use healpix - implicit none - public :: get_all_tau_outwards, get_all_tau_inwards, get_all_tau_adaptive - private -contains - - !*********************************************************************! - !*************************** ADAPTIVE ****************************! - !*********************************************************************! - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth of each particle, using the adaptive ray- - ! tracing scheme - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: kappa: The array containing the kappa of all SPH particles - ! IN: Rstar: The radius of the star - ! IN: minOrder: The minimal order in which the rays are sampled - ! IN: refineLevel: The amount of orders in which the rays can be - ! sampled deeper - ! IN: refineScheme: The refinement scheme used for adaptive ray selection - !+ - ! OUT: taus: The list of optical depths for each particle - !+ - ! OPT: companion: The xyz coordinates of the companion - ! OPT: Rcomp: The radius of the companion - !+ - !-------------------------------------------------------------------------- -subroutine get_all_tau_adaptive(npart, primary, xyzh, kappa, Rstar, minOrder,& - refineLevel, refineScheme, taus, companion, Rcomp) - integer, intent(in) :: npart, minOrder, refineLevel, refineScheme - real, intent(in) :: primary(3), kappa(:), xyzh(:,:), Rstar - real, optional :: Rcomp, companion(3) - real, intent(out) :: taus(:) - - integer :: i, nrays, nsides, index - real :: normCompanion, theta0, unitCompanion(3), theta, root, dist, vec(3), dir(3) - real, dimension(:,:), allocatable :: dirs - real, dimension(:,:), allocatable :: listsOfDists, listsOfTaus - integer, dimension(:), allocatable :: indices, rays_dim - real, dimension(:), allocatable :: tau, dists - - if (present(companion) .and. present(Rcomp)) then - unitCompanion = companion-primary - normCompanion = norm2(unitCompanion) - theta0 = asin(Rcomp/normCompanion) - unitCompanion = unitCompanion/normCompanion - - call get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, dirs, indices, nrays) - allocate(listsOfDists(200, nrays)) - allocate(listsOfTaus(size(listsOfDists(:,1)), nrays)) - allocate(tau(size(listsOfDists(:,1)))) - allocate(dists(size(listsOfDists(:,1)))) - allocate(rays_dim(nrays)) - - !$omp parallel do private(tau,dist,dir,dists,root,theta) - do i = 1, nrays - tau=0. - dists=0. - dir = dirs(:,i) - theta = acos(dot_product(unitCompanion, dir)) - if (theta < theta0) then - root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) - dist = normCompanion*cos(theta)-root - call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i), dist) - else - call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i)) - endif - listsOfTaus(:,i) = tau - listsOfDists(:,i) = dists - enddo - !$omp end parallel do - - nsides = 2**(minOrder+refineLevel) - taus = 0. - !$omp parallel do private(index,vec) - do i = 1, npart - vec = xyzh(1:3,i)-primary - call vec2pix_nest(nsides, vec, index) - index = indices(index + 1) - call get_tau_on_ray(norm2(vec), listsOfTaus(:,index), listsOfDists(:,index), rays_dim(index), taus(i)) - enddo - !$omp end parallel do - - else - call get_all_tau_outwards_single(npart, primary, xyzh, kappa, & - Rstar, minOrder+refineLevel, 0, taus) - endif -end subroutine get_all_tau_adaptive - - !-------------------------------------------------------------------------- - !+ - ! Return all the directions of the rays that need to be traced for the - ! adaptive ray-tracing scheme - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: companion: The xyz coordinates of the companion - ! IN: Rcomp: The radius of the companion - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: minOrder: The minimal order in which the rays are sampled - ! IN: refineLevel: The amount of orders in which the rays can be - ! sampled deeper - ! IN: refineScheme: The refinement scheme used for adaptive ray selection - !+ - ! OUT: rays: A list containing the rays that need to be traced - ! in the adaptive ray-tracing scheme - ! OUT: indices: A list containing a link between the index in the - ! deepest order and the rays in the adaptive ray-tracing scheme - ! OUT: nrays: The number of rays after the ray selection - !+ - !-------------------------------------------------------------------------- -subroutine get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, rays, indices, nrays) - integer, intent(in) :: npart, minOrder, refineLevel, refineScheme - real, intent(in) :: primary(3), companion(3), xyzh(:,:), Rcomp - real, allocatable, intent(out) :: rays(:,:) - integer, allocatable, intent(out) :: indices(:) - integer, intent(out) :: nrays - - real :: theta, dist, phi, cosphi, sinphi - real, dimension(:,:), allocatable :: circ - integer :: i, j, minNsides, minNrays, ind,n, maxOrder, max, distr(12*4**(minOrder+refineLevel)) - integer, dimension(:,:), allocatable :: distrs - - maxOrder = minOrder+refineLevel - nrays = 12*4**(maxOrder) - allocate(rays(3, nrays)) - allocate(indices(12*4**(maxOrder))) - rays = 0. - indices = 0 - - !If there is no refinement, just return the uniform ray distribution - minNsides = 2**minOrder - minNrays = 12*4**minOrder - if (refineLevel == 0) then - do i=1, minNrays - call pix2vec_nest(minNsides,i-1, rays(:,i)) - indices(i) = i - enddo - return - endif - - !Fill a list to have the number distribution in angular space - distr = 0 - !$omp parallel do private(ind) - do i = 1, npart - call vec2pix_nest(2**maxOrder, xyzh(1:3, i)-primary, ind) - distr(ind+1) = distr(ind+1)+1 - enddo - max = maxval(distr) - - !Make sure the companion is described using the highest refinement - dist = norm2(primary-companion) - theta = asin(Rcomp/dist) - phi = atan2(companion(2)-primary(2),companion(1)-primary(1)) - cosphi = cos(phi) - sinphi = sin(phi) - dist = dist*cos(theta) - n = int(theta*6*2**(minOrder+refineLevel))+4 - allocate(circ(n,3)) - do i=1, n !Define boundary of the companion - circ(i,1) = dist*cos(theta) - circ(i,2) = dist*sin(theta)*cos(twopi*i/n) - circ(i,3) = dist*sin(theta)*sin(twopi*i/n) - circ(i,:) = (/cosphi*circ(i,1) - sinphi*circ(i,2),sinphi*circ(i,1) + cosphi*circ(i,2), circ(i,3)/) - enddo - do i=1, n !Make sure the boundary is maximally refined - call vec2pix_nest(2**maxOrder,circ(i,:),ind) - distr(ind+1) = max - enddo - - !Calculate the number distribution in all the orders needed - allocate(distrs(12*4**(minOrder+refineLevel),refineLevel+1)) - distrs = 0 - distrs(:,1) = distr - do i = 1, refineLevel - do j = 1, 12*4**(maxOrder-i) - distrs(j,i+1) = distrs(4*j,i)+distrs(4*j+1,i)+distrs(4*j+2,i)+distrs(4*j+3,i) - enddo - enddo - max = maxval(distrs(:,refineLevel+1))+1 - - !Fill the rays array walking through the orders - ind=1 - - ! refine half in each order - if (refineScheme == 1) then - do i=0, refineLevel-1 - call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) - do j=1, 6*4**minOrder*2**(i) - call pix2vec_nest(2**(minOrder+i), distr(j)-1, rays(:,ind)) - indices(4**(refineLevel-i)*(distr(j)-1)+1:4**(refineLevel-i)*distr(j)) = ind - ind=ind+1 - distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max - enddo - do j = j+1, 12*4**(minOrder+i) - if (distrs(distr(j),refineLevel-i+1) == max) then - distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max - endif - enddo - enddo - - ! refine overdens regions in each order - elseif (refineScheme == 2) then - do i=0, refineLevel-1 - call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) - j=1 - do while (distrs(distr(j),refineLevel-i+1) 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 9 rays, linear interpolation - elseif (raypolation==2) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = norm2(vectemp) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,nneigh - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 4 rays, square interpolation - elseif (raypolation==3) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = dot_product(vectemp,vectemp) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = dot_product(vectemp,vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 9 rays, square interpolation - elseif (raypolation==4) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = dot_product(vectemp,vectemp) - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = dot_product(vectemp,vectemp) - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,nneigh - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 4 rays, cubed interpolation - elseif (raypolation==5) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = norm2(vectemp)**3 - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp)**3 - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,3 - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - - ! 9 rays, cubed interpolation - elseif (raypolation==6) then - vec_norm2 = norm2(vec) - !returns rayIndex, the index of the ray vector that points to the particle (direction vec) - call vec2pix_nest(nsides, vec, rayIndex) - !returns ray(3), the unit vector identifying the ray with index number rayIndex - call pix2vec_nest(nsides, rayIndex, ray) - vectemp = vec - vec_norm2*ray - distRay_sq = norm2(vectemp)**3 - call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) - if (distRay_sq > 0.) then - tau = tautemp/distRay_sq - weight = 1./distRay_sq - else - ! the particle sits exactly on the ray, no need to get the neighbours - tau = tautemp - return - endif - - !returns the number nneigh and list of vectors (n) neighbouring the ray number index - call neighbours_nest(nsides, rayIndex, neighbours, nneigh) - !for each neighbouring ray calculate its distance to the particle - do i=1,nneigh - call pix2vec_nest(nsides, neighbours(i), ray) - vectemp = vec - vec_norm2*ray - tempdist(i) = norm2(vectemp)**3 - enddo - neighbours = neighbours+1 - mask = .true. - if (nneigh <8) mask(nneigh+1:8) = .false. - !take tau contribution from the 3 closest rays - do i=1,nneigh - k = minloc(tempdist,1,mask) - mask(k) = .false. - call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & - rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) - tau = tau + tautemp/tempdist(k) - weight = weight + 1./tempdist(k) - enddo - tau = tau / weight - endif -end subroutine interpolate_tau - - - !-------------------------------------------------------------------------- - !+ - ! Interpolation of the optical depth for an arbitrary point on the ray, - ! with a given distance to the starting point of the ray. - !+ - ! IN: distance: The distance from the staring point of the ray to a - ! point on the ray - ! IN: tau_along_ray: The vector of cumulative optical depths along the ray - ! IN: dist_along_ray: The vector of distances from the primary along the ray - ! IN: len: The length of listOfTau and listOfDist - !+ - ! OUT: tau: The optical depth to the given distance along the ray - !+ - !-------------------------------------------------------------------------- -subroutine get_tau_on_ray(distance, tau_along_ray, dist_along_ray, len, tau) - real, intent(in) :: distance, tau_along_ray(:), dist_along_ray(:) - integer, intent(in) :: len - real, intent(out) :: tau - - integer :: L, R, m ! left, right and middle index for binary search - - if (distance < dist_along_ray(1)) then - tau = 0. - elseif (distance > dist_along_ray(len)) then - tau = 99. - else - L = 2 - R = len-1 - !bysection search for the index of the closest ray location to the particle - do while (L < R) - m = (L + R)/2 - if (dist_along_ray(m) > distance) then - R = m - else - L = m + 1 - endif - enddo - !interpolate linearly ray properties to get the particle's optical depth - tau = tau_along_ray(L-1)+(tau_along_ray(L)-tau_along_ray(L-1))/ & - (dist_along_ray(L)-dist_along_ray(L-1))*(distance-dist_along_ray(L-1)) - endif -end subroutine get_tau_on_ray - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth along a given ray - !+ - ! IN: primary: The location of the primary star - ! IN: ray: The unit vector of the direction in which the - ! optical depts will be calculated - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: kappa: The array containing the particles opacity - ! IN: Rstar: The radius of the primary star - !+ - ! OUT: taus: The distribution of optical depths throughout the ray - ! OUT: listOfDists: The distribution of distances throughout the ray - ! OUT: len: The length of tau_along_ray and dist_along_ray - !+ - ! OPT: maxDistance: The maximal distance the ray needs to be traced - !+ - !-------------------------------------------------------------------------- -subroutine ray_tracer(primary, ray, xyzh, kappa, Rstar, tau_along_ray, dist_along_ray, len, maxDistance) - use linklist, only:getneigh_pos,ifirstincell,listneigh - use kernel, only:radkern - use units, only:umass,udist - real, intent(in) :: primary(3), ray(3), Rstar, xyzh(:,:), kappa(:) - real, optional :: maxDistance - real, intent(out) :: dist_along_ray(:), tau_along_ray(:) - integer, intent(out) :: len - - integer, parameter :: maxcache = 0 - real, allocatable :: xyzcache(:,:) - real :: distance, h, dtaudr, previousdtaudr, nextdtaudr - integer :: nneigh, inext, i - - distance = Rstar - - h = Rstar/100. - inext=0 - do while (inext==0) - h = h*2. - call getneigh_pos(primary+Rstar*ray,0.,h,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) - call find_next(primary, ray, distance, xyzh, listneigh, inext, nneigh) - enddo - call calc_opacity(primary+Rstar*ray, xyzh, kappa, listneigh, nneigh, previousdtaudr) - - i = 1 - tau_along_ray(i) = 0. - distance = Rstar - dist_along_ray(i) = distance - do while (hasNext(inext,tau_along_ray(i),distance,maxDistance)) - i = i + 1 - call getneigh_pos(primary + distance*ray,0.,xyzh(4,inext)*radkern, & - 3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) - call calc_opacity(primary + distance*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) - dtaudr = (nextdtaudr+previousdtaudr)/2 - previousdtaudr = nextdtaudr - tau_along_ray(i) = tau_along_ray(i-1)+(distance-dist_along_ray(i-1))*dtaudr - dist_along_ray(i) = distance - call find_next(primary, ray, distance, xyzh, listneigh, inext,nneigh) - enddo - len = i - tau_along_ray = tau_along_ray*umass/(udist**2) -end subroutine ray_tracer - -logical function hasNext(inext, tau, distance, maxDistance) - integer, intent(in) :: inext - real, intent(in) :: distance, tau - real, optional :: maxDistance - real, parameter :: tau_max = 99. - if (present(maxDistance)) then - hasNext = inext /= 0 .and. distance < maxDistance .and. tau < tau_max - else - hasNext = inext /= 0 .and. tau < tau_max - endif -end function hasNext - - !*********************************************************************! - !**************************** INWARDS ****************************! - !*********************************************************************! - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth of each particle, using the inwards ray- - ! tracing scheme - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: neighbors: A list containing the indices of the neighbors of - ! each particle - ! IN: kappa: The array containing the opacity of all the SPH particles - ! IN: Rstar: The radius of the primary star - !+ - ! OUT: tau: The array of optical depths for each SPH particle - !+ - ! OPT: companion: The location of the companion - ! OPT: R: The radius of the companion - !+ - !-------------------------------------------------------------------------- -subroutine get_all_tau_inwards(npart, primary, xyzh, neighbors, kappa, Rstar, tau, companion, R) - real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) - integer, intent(in) :: npart, neighbors(:,:) - real, optional :: R, companion(3) - real, intent(out) :: tau(:) - - if (present(companion) .and. present(R)) then - call get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, R, tau) - else - call get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) - endif -end subroutine get_all_tau_inwards - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth of each particle, using the inwards ray- - ! tracing scheme concerning only a single star - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: neighbors: A list containing the indices of the neighbors of - ! each particle - ! IN: kappa: The array containing the opacity of all the SPH particles - ! IN: Rstar: The radius of the primary star - !+ - ! OUT: taus: The list of optical depths for each particle - !+ - !-------------------------------------------------------------------------- -subroutine get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) - real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) - integer, intent(in) :: npart, neighbors(:,:) - real, intent(out) :: tau(:) - - integer :: i - - !$omp parallel do - do i = 1, npart - call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) - enddo - !$omp end parallel do -end subroutine get_all_tau_inwards_single - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth of each particle, using the inwards ray- - ! tracing scheme concerning a binary system - !+ - ! IN: npart: The number of SPH particles - ! IN: primary: The xyz coordinates of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: neighbors: A list containing the indices of the neighbors of - ! each particle - ! IN: kappa: The array containing the opacity of all the SPH particles - ! IN: Rstar: The radius of the primary star - ! IN: companion: The xyz coordinates of the companion - ! IN: Rcomp: The radius of the companion - !+ - ! OUT: tau: The array of optical depths for each SPH particle - !+ - !-------------------------------------------------------------------------- -subroutine get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, Rcomp, tau) - real, intent(in) :: primary(3), companion(3), kappa(:), Rstar, xyzh(:,:), Rcomp - integer, intent(in) :: npart, neighbors(:,:) - real, intent(out) :: tau(:) - - integer :: i - real :: normCompanion, theta0, uvecCompanion(3), norm, theta, root, norm0 - - uvecCompanion = companion-primary - normCompanion = norm2(uvecCompanion) - uvecCompanion = uvecCompanion/normCompanion - theta0 = asin(Rcomp/normCompanion) - - !$omp parallel do private(norm,theta,root,norm0) - do i = 1, npart - norm = norm2(xyzh(1:3,i)-primary) - theta = acos(dot_product(uvecCompanion, xyzh(1:3,i)-primary)/norm) - if (theta < theta0) then - root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) - norm0 = normCompanion*cos(theta)-root - if (norm > norm0) then - tau(i) = 99. - else - call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) - endif - else - call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) - endif - enddo - !$omp end parallel do -end subroutine get_all_tau_inwards_companion - - !-------------------------------------------------------------------------- - !+ - ! Calculate the optical depth for a given particle, using the inwards ray- - ! tracing scheme - !+ - ! IN: point: The index of the point that needs to be calculated - ! IN: primary: The location of the primary star - ! IN: xyzh: The array containing the particles position+smooting lenght - ! IN: neighbors: A list containing the indices of the neighbors of - ! each particle - ! IN: kappa: The array containing the opacity of all the SPH particles - ! IN: Rstar: The radius of the star - !+ - ! OUT: tau: The list of optical depth of the given particle - !+ - !-------------------------------------------------------------------------- -subroutine get_tau_inwards(point, primary, xyzh, neighbors, kappa, Rstar, tau) - use linklist, only:getneigh_pos,ifirstincell,listneigh - use kernel, only:radkern - use units, only:umass,udist - real, intent(in) :: primary(3), xyzh(:,:), kappa(:), Rstar - integer, intent(in) :: point, neighbors(:,:) - real, intent(out) :: tau - - integer :: i, next, previous, nneigh - integer, parameter :: nmaxcache = 0 - real :: xyzcache(0,nmaxcache) - real :: ray(3), nextDist, previousDist, maxDist, dtaudr, previousdtaudr, nextdtaudr - - ray = primary - xyzh(1:3,point) - maxDist = norm2(ray) - ray = ray / maxDist - maxDist=max(maxDist-Rstar,0.) - next=point - call getneigh_pos(xyzh(1:3,point),0.,xyzh(4,point)*radkern, & - 3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) - call calc_opacity(xyzh(1:3,point), xyzh, kappa, listneigh, nneigh, nextdtaudr) - nextDist=0. - - tau = 0. - i=1 - do while (nextDist < maxDist .and. next /=0) - i = i + 1 - previous = next - previousDist = nextDist - call find_next(xyzh(1:3,point), ray, nextDist, xyzh, neighbors(next,:), next) - if (nextDist > maxDist) then - nextDist = maxDist - endif - call getneigh_pos(xyzh(1:3,point) + nextDist*ray,0.,xyzh(4,previous)*radkern, & - 3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) - previousdtaudr=nextdtaudr - call calc_opacity(xyzh(1:3,point) + nextDist*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) - dtaudr = (nextdtaudr+previousdtaudr)/2 - tau = tau + (nextDist-previousDist)*dtaudr - enddo - !fix units for tau (kappa is in cgs while rho & r are in code units) - tau = tau*umass/(udist**2) -end subroutine get_tau_inwards - - !*********************************************************************! - !**************************** COMMON *****************************! - !*********************************************************************! - - !-------------------------------------------------------------------------- - !+ - ! Find the next point on a ray - !+ - ! IN: inpoint: The coordinate of the initial point projected on the - ! ray for which the next point will be calculated - ! IN: ray: The unit vector of the direction in which the next - ! point will be calculated - ! IN: xyzh: The array containing the particles position+smoothing length - ! IN: neighbors: A list containing the indices of the neighbors of - ! the initial point - ! IN: inext: The index of the initial point - ! (this point will not be considered as possible next point) - !+ - ! OPT: nneighin: The amount of neighbors - !+ - ! OUT: inext: The index of the next point on the ray - !+ - !-------------------------------------------------------------------------- -subroutine find_next(inpoint, ray, dist, xyzh, neighbors, inext, nneighin) - integer, intent(in) :: neighbors(:) - real, intent(in) :: xyzh(:,:), inpoint(:), ray(:) - integer, intent(inout) :: inext - real, intent(inout) :: dist - integer, optional :: nneighin - - real :: trace_point(3), dmin, vec(3), tempdist, raydist - real :: nextdist - integer :: i, nneigh, prev - - dmin = huge(0.) - if (present(nneighin)) then - nneigh = nneighin - else - nneigh = size(neighbors) - endif - - prev=inext - inext=0 - nextDist=dist - trace_point = inpoint + dist*ray - - i = 1 - do while (i <= nneigh .and. neighbors(i) /= 0) - if (neighbors(i) /= prev) then - vec=xyzh(1:3,neighbors(i)) - trace_point - tempdist = dot_product(vec,ray) - if (tempdist>0.) then - raydist = dot_product(vec,vec) - tempdist**2 - if (raydist < dmin) then - dmin = raydist - inext = neighbors(i) - nextdist = dist+tempdist - endif - endif - endif - i = i+1 - enddo - dist=nextdist -end subroutine find_next - - !-------------------------------------------------------------------------- - !+ - ! Calculate the opacity in a given location - !+ - ! IN: r0: The location where the opacity will be calculated - ! IN: xyzh: The xyzh of all the particles - ! IN: opacities: The list of the opacities of the particles - ! IN: neighbors: A list containing the indices of the neighbors of - ! the initial point - ! IN: nneigh: The amount of neighbors - !+ - ! OUT: dtaudr: The local optical depth derivative at the given location (inpoint) - !+ - !-------------------------------------------------------------------------- -subroutine calc_opacity(r0, xyzh, opacities, neighbors, nneigh, dtaudr) - use kernel, only:cnormk,wkern - use part, only:hfact,rhoh,massoftype,igas - real, intent(in) :: r0(:), xyzh(:,:), opacities(:) - integer, intent(in) :: neighbors(:), nneigh - real, intent(out) :: dtaudr - - integer :: i - real :: q - - dtaudr=0 - do i=1,nneigh - q = norm2(r0 - xyzh(1:3,neighbors(i)))/xyzh(4,neighbors(i)) - dtaudr=dtaudr+wkern(q*q,q)*opacities(neighbors(i))*rhoh(xyzh(4,neighbors(i)), massoftype(igas)) - enddo - dtaudr = dtaudr*cnormk/hfact**3 -end subroutine calc_opacity -end module raytracer_all From 0f07e973021a55dd759751cb7082800f087d5caa Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 21:27:55 +1000 Subject: [PATCH 405/814] (prdrag) BUG FIX in update_vdependent solver; use matrix inversion directly; now passes testsuite --- src/main/extern_prdrag.f90 | 83 +++++++++++++++++++++++--------------- 1 file changed, 51 insertions(+), 32 deletions(-) diff --git a/src/main/extern_prdrag.f90 b/src/main/extern_prdrag.f90 index 3ea8ac216..c6d412feb 100644 --- a/src/main/extern_prdrag.f90 +++ b/src/main/extern_prdrag.f90 @@ -110,53 +110,72 @@ subroutine get_prdrag_vdependent_force(xyzi,vel,Mstar,fexti) end subroutine get_prdrag_vdependent_force +!----------------------------------------------------------------------- +!+ +! solve for the velocity update in the leapfrog corrector step +! i.e. v^n+1 = vhalf + 0.5*dt*f_sph + 0.5*dt*f_pr(x,v^n+1) +!+ +!----------------------------------------------------------------------- subroutine update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,Mstar) - use units, only:get_c_code - use io, only:warn - real, intent(in) :: dt,xi,yi,zi, Mstar + use units, only:get_c_code,get_G_code + use io, only:warn,fatal + use vectorutils, only:matrixinvert3D + real, intent(in) :: dt,xi,yi,zi,Mstar real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(inout) :: fexti(3) - real :: r, r2, r3, Q, betai - real :: Tx, Ty, Tz, vonex, voney, vonez - real :: denominator, vrhalf, vrone, twoQondt - real :: xi2, yi2, zi2, ccode, kd + integer :: ierr + real :: dton2,r2,dr,rx,ry,rz + real :: gcode,ccode,betai,bterm,b,vr + real :: rhat(3),vel(3),A(3),Rmat(3,3),Rinv(3,3) character(len=30), parameter :: label = 'update_prdrag_leapfrog' ccode = get_c_code() + gcode = get_G_code() - xi2 = xi*xi - yi2 = yi*yi - zi2 = zi*zi - kd = k1 - k2 + ! we are solving half a timestep forwards in time + dton2 = 0.5*dt - r2 = (xi2 + yi2 + zi2) - r = sqrt(r2) - r3 = r*r2 - vrhalf = vhalfx*xi + vhalfy*yi + vhalfz*zi + r2 = xi*xi + yi*yi + zi*zi + dr = 1./sqrt(r2) + rx = xi*dr + ry = yi*dr + rz = zi*dr + rhat = (/rx,ry,rz/) + + ! solve for v^1 using matrix inversion of [Rmat][v1] = [A] + A(1) = vhalfx + dton2*fxi + A(2) = vhalfy + dton2*fyi + A(3) = vhalfz + dton2*fzi - betai = beta - Q = Mstar*betai*dt/(2.*ccode*r*r) - twoQondt = 2.*Q/dt - denominator = -r2*( k2*kd*Q*Q + (kd-k2)*Q - 1 ) + betai = beta + bterm = betai*gcode*Mstar/(ccode*r2) + b = dton2*bterm + + ! This is the matrix from the equation for v1: [Rmat][v1] = [A] + Rmat = reshape((/1. + b*(k2 + k1*rx*rx), b*k1*ry*rx, b*k1*rz*rx, & + b*k1*rx*ry, 1. + b*(k2 + k1*ry*ry), b*k1*rz*ry, & + b*k1*rx*rz, b*k1*ry*rz, 1. + b*(k2 + k1*rz*rz)/),(/3,3/)) + +! Get the inverse matrix + call matrixinvert3D(Rmat,Rinv,ierr) + if (ierr /= 0) then + call fatal('extern_prdrag','Error: determinant = 0 in matrix inversion') + endif - Tx = vhalfx + 0.5*dt*fxi - Ty = vhalfy + 0.5*dt*fyi - Tz = vhalfz + 0.5*dt*fzi +! Compute v1 via matrix multiplication. + vel(:) = matmul(A,Rinv) - vonex = (-(Q*k1*xi)*(Ty*yi+Tz*zi)+Q*kd*Tx*r2-Tx*(r2+Q*k1*xi2))/denominator - voney = (-(Q*k1*yi)*(Tx*xi+Tz*zi)+Q*kd*Ty*r2-Ty*(r2+Q*k1*yi2))/denominator - vonez = (-(Q*k1*zi)*(Tx*xi+Ty*yi)+Q*kd*Tz*r2-Tz*(r2+Q*k1*zi2))/denominator + vr = dot_product(vel,rhat) - vrone = (vonex*xi + voney*yi + vonez*zi)/r ! vr = rhat dot v + ! velocity dependent part of the P-R drag force (e.g. equation 142 of Klacka 1992) + fexti(:) = -bterm*(vr*rhat*k1 + vel*k2) - fexti(1) = twoQondt * (vonex*k2 + k1*vrone*xi/r) - fexti(2) = twoQondt * (voney*k2 + k1*vrone*yi/r) - fexti(3) = twoQondt * (vonez*k2 + k1*vrone*zi/r) + !v1check(:) = A(:) + dton2*fexti(:) ! this should match expression for v1 - fxi = fxi + fexti(1) - fyi = fyi + fexti(2) - fzi = fzi + fexti(3) + fxi = fxi + fexti(1) + fyi = fyi + fexti(2) + fzi = fzi + fexti(3) end subroutine update_prdrag_leapfrog From 4fd490a5fa545ef755af3b36cee944a0da1c58f8 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 21:29:46 +1000 Subject: [PATCH 406/814] (rwdump) unfill_header and fill_header routines moved into readwrite_dump_common.f90 --- src/main/readwrite_dumps_common.f90 | 446 ++++++++++++++++++++++++++ src/main/readwrite_dumps_fortran.f90 | 449 +-------------------------- 2 files changed, 447 insertions(+), 448 deletions(-) diff --git a/src/main/readwrite_dumps_common.f90 b/src/main/readwrite_dumps_common.f90 index 5cf289f29..058dc0b97 100644 --- a/src/main/readwrite_dumps_common.f90 +++ b/src/main/readwrite_dumps_common.f90 @@ -110,6 +110,452 @@ subroutine get_options_from_fileid(fileid,tagged,phantomdump,smalldump,& end subroutine get_options_from_fileid +!-------------------------------------------------------------------- +!+ +! utility to extract header variables to phantom +!+ +!------------------------------------------------------------------- +subroutine unfill_header(hdr,phantomdump,got_tags,nparttot, & + nblocks,npart,npartoftype, & + tfile,hfactfile,alphafile,iprint,id,nprocs,ierr) + use dim, only:maxdustlarge,use_dust + use io, only:master ! check this + use eos, only:isink + use part, only:maxtypes,igas,idust,ndustsmall,ndustlarge,ndusttypes,& + npartoftypetot + use units, only:udist,umass,utime,set_units_extra,set_units + use dump_utils, only:extract,dump_h + use fileutils, only:make_tags_unique + type(dump_h), intent(in) :: hdr + logical, intent(in) :: phantomdump,got_tags + integer(kind=8), intent(out) :: nparttot + integer, intent(out) :: nblocks,npart,npartoftype(maxtypes) + real, intent(out) :: tfile,hfactfile,alphafile + integer, intent(in) :: iprint,id,nprocs + integer, intent(out) :: ierr + integer :: nparttoti,npartoftypetoti(maxtypes),ntypesinfile,nptinfile + integer :: ierr1,ierrs(3),i,counter + integer(kind=8) :: ntypesinfile8 + character(len=10) :: dust_label(maxdustlarge) + + ierr = 0 + nparttot = 0 + npartoftypetot(:) = 0 + npart = 0 + npartoftype(:) = 0 + isink = 0 + call extract('ntypes',ntypesinfile,hdr,ierr1) + if (ierr1 /= 0 .or. ntypesinfile < 1) then + if (phantomdump .and. got_tags) then + ierr = 4 + return + else + ntypesinfile = 5 + endif + endif + + ! extract quantities from integer header + call extract('nparttot',nparttoti,hdr,ierr1) + if (ierr1 /= 0) then + ierr = 5 + return + endif + if (ntypesinfile > maxtypes) then + write(*,*) 'WARNING: number of particle types in file exceeds array limits' + write(*,*) 'READING ONLY FIRST ',maxtypes,' OF ',ntypesinfile,' particle types' + ntypesinfile = maxtypes + endif + call extract('npartoftype',npartoftypetoti(1:ntypesinfile),hdr,ierr1) + if (ierr1 /= 0) then + npartoftype(1) = nparttoti ! assume only gas particles + endif + call extract('nblocks',nblocks,hdr,ierr1,default=1) + if (ierr1 /= 0) write(*,*) 'number of MPI blocks not read: assuming 1' + + nparttot = int(nparttoti,kind=8) + npartoftypetot = int(npartoftypetoti,kind=8) + if (nblocks==1) then + npartoftype(1:ntypesinfile) = int(npartoftypetot(1:ntypesinfile)) + if (npartoftype(idust) > 0) write(*,*) 'n(gas) = ',npartoftype(igas) + counter = 0 + do i=1,maxdustlarge + if (npartoftype(idust+i-1) > 0) then + counter = counter + 1 + endif + enddo + dust_label = 'dust' + call make_tags_unique(counter,dust_label) + do i=1,counter + write(*,*) 'n('//trim(dust_label(i))//') = ',npartoftype(idust+i-1) + enddo + endif + call extract('isink',isink,hdr,ierr1) + +!--non-MPI dumps + if (nprocs==1) then + if (nparttoti > huge(npart)) then + write (*,*) 'ERROR in readdump: number of particles exceeds 32 bit limit, must use int(kind=8)''s ',nparttoti + ierr = 4 + return + endif + endif + if (nblocks==1) then + npart = int(nparttoti) + nparttot = npart + if (id==master) write (iprint,*) 'npart = ',npart + endif + if (got_tags) then + call extract('ntypes',ntypesinfile8,hdr,ierr1) + ntypesinfile = int(ntypesinfile8) + endif + if (ntypesinfile > maxtypes) then + write(*,*) 'WARNING: number of particle types in file exceeds array limits' + write(*,*) 'READING ONLY FIRST ',maxtypes,' OF ',ntypesinfile,' particle types' + ntypesinfile = maxtypes + endif + call extract('nparttot',nparttot,hdr,ierr1) + if (nblocks > 1) then + call extract('npartoftype',npartoftype(1:ntypesinfile),hdr,ierr1) + endif + if (id==master) write(*,*) 'npart(total) = ',nparttot +! +!--number of dust species +! + if (use_dust) then + call extract('ndustsmall',ndustsmall,hdr,ierrs(1)) + call extract('ndustlarge',ndustlarge,hdr,ierrs(2)) + if (any(ierrs(1:2) /= 0)) then + call extract('ndustfluids',ndustsmall,hdr,ierrs(1)) ! for backwards compatibility + if (ierrs(1) /= 0) write(*,*) 'ERROR reading number of small/large grain types from file header' + endif + ndusttypes = ndustsmall + ndustlarge + endif +! +!--units +! + call extract('udist',udist,hdr,ierrs(1)) + call extract('umass',umass,hdr,ierrs(2)) + call extract('utime',utime,hdr,ierrs(3)) + if (all(ierrs(1:3)==0)) then + call set_units_extra() + else + write(iprint,*) 'ERROR reading units from dump file, assuming default' + call set_units() ! use default units + endif + ! get nptmass from header, needed to figure out if gwinspiral info is sensible + call extract('nptmass',nptinfile,hdr,ierrs(1)) +!--default real + call unfill_rheader(hdr,phantomdump,ntypesinfile,nptinfile,& + tfile,hfactfile,alphafile,iprint,ierr) + if (ierr /= 0) return + + if (id==master) write(iprint,*) 'time = ',tfile + +end subroutine unfill_header + +!-------------------------------------------------------------------- +!+ +! subroutine to fill the real header with various things +!+ +!------------------------------------------------------------------- +subroutine fill_header(sphNGdump,t,nparttot,npartoftypetot,nblocks,nptmass,hdr,ierr) + use eos, only:write_headeropts_eos,polyk2 + 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 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, & + 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 + + logical, intent(in) :: sphNGdump + real, intent(in) :: t + integer(kind=8), intent(in) :: nparttot,npartoftypetot(:) + integer, intent(in) :: nblocks,nptmass + type(dump_h), intent(inout) :: hdr + integer, intent(out) :: ierr + integer :: number + + ierr = 0 + ! default int + call add_to_iheader(int(nparttot),'nparttot',hdr,ierr) + call add_to_iheader(maxtypes,'ntypes',hdr,ierr) + call add_to_iheader(int(npartoftypetot(1:maxtypes)),'npartoftype',hdr,ierr) + call add_to_iheader(nblocks,'nblocks',hdr,ierr) + call add_to_iheader(nptmass,'nptmass',hdr,ierr) + call add_to_iheader(ndustlarge,'ndustlarge',hdr,ierr) + call add_to_iheader(ndustsmall,'ndustsmall',hdr,ierr) + call add_to_iheader(idust,'idust',hdr,ierr) + call add_to_iheader(idtmax_n_next,'idtmax_n',hdr,ierr) + call add_to_iheader(idtmax_frac_next,'idtmax_frac',hdr,ierr) + call add_to_iheader(idumpfile,'idumpfile',hdr,ierr) + call add_to_iheader(phantom_version_major,'majorv',hdr,ierr) + call add_to_iheader(phantom_version_minor,'minorv',hdr,ierr) + call add_to_iheader(phantom_version_micro,'microv',hdr,ierr) + + ! int*8 + call add_to_header(nparttot,'nparttot',hdr,ierr) + call add_to_header(int(maxtypes,kind=8),'ntypes',hdr,ierr) + call add_to_header(npartoftypetot(1:maxtypes),'npartoftype',hdr,ierr) + + ! int*4 + call add_to_header(iexternalforce,'iexternalforce',hdr,ierr) + call add_to_header(ieos,'ieos',hdr,ierr) + call write_headeropts_eos(ieos,hdr,ierr) + + ! default real variables + call add_to_rheader(t,'time',hdr,ierr) + call add_to_rheader(dtmax_user,'dtmax',hdr,ierr) + call add_to_rheader(rhozero,'rhozero',hdr,ierr) + if (sphNGdump) then ! number = 23 + call add_to_rheader(0.,'escaptot',hdr,ierr) + call add_to_rheader(0.,'tkin',hdr,ierr) + call add_to_rheader(0.,'tgrav',hdr,ierr) + call add_to_rheader(0.,'tterm',hdr,ierr) + call add_to_rheader(0.,'anglostx',hdr,ierr) + call add_to_rheader(0.,'anglosty',hdr,ierr) + call add_to_rheader(0.,'anglostz',hdr,ierr) + call add_to_rheader(0.,'specang',hdr,ierr) + call add_to_rheader(0.,'ptmassin',hdr,ierr) + call add_to_rheader(0.,'tmag',hdr,ierr) + call add_to_rheader(Bextx,'Bextx',hdr,ierr) + call add_to_rheader(Bexty,'Bexty',hdr,ierr) + call add_to_rheader(Bextz,'Bextz',hdr,ierr) + call add_to_rheader(0.,'hzero',hdr,ierr) + call add_to_rheader(1.5*polyk2,'uzero_n2',hdr,ierr) + call add_to_rheader(0.,'hmass',hdr,ierr) + call add_to_rheader(0.,'gapfac',hdr,ierr) + call add_to_rheader(0.,'pmassinitial',hdr,ierr) + else ! number = 49 + call add_to_rheader(hfact,'hfact',hdr,ierr) + call add_to_rheader(tolh,'tolh',hdr,ierr) + call add_to_rheader(C_cour,'C_cour',hdr,ierr) + call add_to_rheader(C_force,'C_force',hdr,ierr) + call add_to_rheader(alpha,'alpha',hdr,ierr) + call add_to_rheader(alphau,'alphau',hdr,ierr) + call add_to_rheader(alphaB,'alphaB',hdr,ierr) + call add_to_rheader(massoftype,'massoftype',hdr,ierr) ! array + if (do_nucleation) call write_headeropts_dust_formation(hdr,ierr) + call add_to_rheader(Bextx,'Bextx',hdr,ierr) + call add_to_rheader(Bexty,'Bexty',hdr,ierr) + call add_to_rheader(Bextz,'Bextz',hdr,ierr) + call add_to_rheader(0.,'dum',hdr,ierr) + if (iexternalforce /= 0) call write_headeropts_extern(iexternalforce,hdr,t,ierr) + if (periodic) then + call add_to_rheader(xmin,'xmin',hdr,ierr) + call add_to_rheader(xmax,'xmax',hdr,ierr) + call add_to_rheader(ymin,'ymin',hdr,ierr) + call add_to_rheader(ymax,'ymax',hdr,ierr) + call add_to_rheader(zmin,'zmin',hdr,ierr) + call add_to_rheader(zmax,'zmax',hdr,ierr) + endif + if (dynamic_bdy) then + call add_to_rheader(dxyz,'dxyz',hdr,ierr) + call add_to_iheader(irho_bkg_ini,'irho_bkg_ini',hdr,ierr) + call add_to_rheader(rho_bkg_ini,'rho_bkg_ini',hdr,ierr) + endif + call add_to_rheader(get_conserv,'get_conserv',hdr,ierr) + call add_to_rheader(etot_in,'etot_in',hdr,ierr) + call add_to_rheader(angtot_in,'angtot_in',hdr,ierr) + call add_to_rheader(totmom_in,'totmom_in',hdr,ierr) + call add_to_rheader(mdust_in(1:ndusttypes),'mdust_in',hdr,ierr) + if (use_dust) then + call add_to_rheader(grainsize(1:ndusttypes),'grainsize',hdr,ierr) + call add_to_rheader(graindens(1:ndusttypes),'graindens',hdr,ierr) + endif + endif + + ! real*8 + call add_to_header(udist,'udist',hdr,ierr) + call add_to_header(umass,'umass',hdr,ierr) + call add_to_header(utime,'utime',hdr,ierr) + call add_to_header(unit_Bfield,'umagfd',hdr,ierr) + + if (ierr /= 0) write(*,*) ' ERROR: arrays too small writing rheader' + + number = num_in_header(hdr%realtags) + if (number >= maxphead) then + write(*,*) 'error: header arrays too small for number of items in header: will be truncated' + endif + +end subroutine fill_header + +!-------------------------------------------------------------------- +!+ +! subroutine to set runtime parameters having read the real header +!+ +!------------------------------------------------------------------- +subroutine unfill_rheader(hdr,phantomdump,ntypesinfile,nptmass,& + tfile,hfactfile,alphafile,iprint,ierr) + use io, only:id,master + use dim, only:maxvxyzu,nElements,use_dust,use_dustgrowth,use_krome,do_nucleation,idumpfile + use eos, only:extract_eos_from_hdr, read_headeropts_eos + 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 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 + use boundary_dyn, only:dynamic_bdy,dxyz,irho_bkg_ini,rho_bkg_ini,rho_bkg_ini1 + use dump_utils, only:extract,dump_h + use dust, only:grainsizecgs,graindenscgs + use units, only:unit_density,udist + use timestep, only:idtmax_n,idtmax_frac + use dust_formation, only:read_headeropts_dust_formation + type(dump_h), intent(in) :: hdr + logical, intent(in) :: phantomdump + integer, intent(in) :: iprint,ntypesinfile,nptmass + real, intent(out) :: tfile,hfactfile,alphafile + integer, intent(out) :: ierr + + integer, parameter :: lu = 173 + integer :: ierrs(10),iextern_in_file + real :: xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,dtmaxi + real :: alphaufile,alphaBfile,C_courfile,C_forcefile,tolhfile + logical :: iexist + + ierr = 0 + call extract('time',tfile,hdr,ierr) + if (ierr/=0) call extract('gt',tfile,hdr,ierr) ! this is sphNG's label for time + call extract('dtmax',dtmaxi,hdr,ierr) + call extract('rhozero',rhozero,hdr,ierr) + Bextx = 0. + Bexty = 0. + Bextz = 0. + if (phantomdump) then + call extract('hfact',hfactfile,hdr,ierr) + call extract('tolh',tolhfile,hdr,ierr) + call extract('C_cour',C_courfile,hdr,ierr) + call extract('C_force',C_forcefile,hdr,ierr) + call extract('alpha',alphafile,hdr,ierr) + if (maxvxyzu >= 4) then + call extract('alphau',alphaufile,hdr,ierr) + else + alphaufile = 0. + endif + if (mhd) then + call extract('alphaB',alphaBfile,hdr,ierr) + endif + + if (extract_eos_from_hdr) call extract('ieos',ieos,hdr,ierr) + + call extract('massoftype',massoftype(1:ntypesinfile),hdr,ierr) + if (ierr /= 0) then + write(*,*) '*** ERROR reading massoftype from dump header ***' + ierr = 4 + endif + if (do_nucleation) then + call read_headeropts_dust_formation(hdr,ierr) + if (ierr /= 0) ierr = 6 + endif + + call extract('iexternalforce',iextern_in_file,hdr,ierrs(1)) + if (extract_iextern_from_hdr) iexternalforce = iextern_in_file + if (iexternalforce /= 0) then + call read_headeropts_extern(iexternalforce,hdr,nptmass,ierrs(1)) + if (ierrs(1) /= 0) ierr = 5 + elseif (iextern_in_file /= 0) then + call read_headeropts_extern(iextern_in_file,hdr,nptmass,ierrs(1)) + if (ierrs(1) /= 0) ierr = 5 + endif + + call extract('idtmax_n',idtmax_n,hdr,ierr,default=1) + call extract('idtmax_frac',idtmax_frac,hdr,ierr) + call extract('idumpfile',idumpfile,hdr,ierr) + else + massoftype(1) = 0. + hfactfile = 0. + endif + + call read_headeropts_eos(ieos,hdr,ierr) + + if (periodic) then + call extract('xmin',xmini,hdr,ierrs(1)) + call extract('xmax',xmaxi,hdr,ierrs(2)) + call extract('ymin',ymini,hdr,ierrs(3)) + call extract('ymax',ymaxi,hdr,ierrs(4)) + call extract('zmin',zmini,hdr,ierrs(5)) + call extract('zmax',zmaxi,hdr,ierrs(6)) + if (any(ierrs(1:6) /= 0)) then + write(*,"(2(/,a))") ' ERROR: dump does not contain boundary positions', & + ' but we are using periodic boundaries' + inquire(file='bound.tmp',exist=iexist) + if (iexist) then + open(unit=lu,file='bound.tmp') + read(lu,*) xmini,xmaxi,ymini,ymaxi,zmini,zmaxi + close(lu) + call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) + write(*,"(a,6(es10.3,1x))") ' READ from bound.tmp ',xmin,xmax,ymin,ymax,zmin,zmax + else + write(*,"(3(/,a),/,/,a)") ' To silence this error and restart from an older dump file ', & + ' create an ascii file called "bound.tmp" in the current directory', & + ' with xmin,xmax,ymin,ymax,zmin & zmax in it, e.g.: ', & + ' 0. 1. 0. 1. 0. 1.' + ierr = 5 ! spit fatal error + endif + else + call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) + endif + endif + + if (dynamic_bdy) then + call extract('irho_bkg_ini',irho_bkg_ini,hdr,ierrs(1)) + call extract('rho_bkg_ini',rho_bkg_ini,hdr,ierrs(1)) + call extract('dxyz',dxyz,hdr,ierrs(2)) + if (rho_bkg_ini > 0.) then + rho_bkg_ini1 = 1.0/rho_bkg_ini + else + rho_bkg_ini1 = 0. + endif + endif + + if (mhd) then + call extract('Bextx',Bextx,hdr,ierrs(1)) + call extract('Bexty',Bexty,hdr,ierrs(2)) + call extract('Bextz',Bextz,hdr,ierrs(3)) + if (id==master) then + if (any(ierrs(1:3) /= 0)) then + write(*,*) 'ERROR reading external field (setting to zero)' + else + write(*,*) 'External field found, Bext = ',Bextx,Bexty,Bextz + endif + endif + endif + + ! values to track that conserved values remain conserved + call extract('get_conserv',get_conserv,hdr,ierrs(1)) + 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)) + if (any(ierrs(1:4) /= 0)) then + write(*,*) 'ERROR reading values to verify conservation laws. Resetting initial values.' + get_conserv = 1.0 + endif + + + !--pull grain size and density arrays if they are in the header + !-- i.e. if dustgrowth is not ON + if (use_dust .and. .not.use_dustgrowth) then + call extract('grainsize',grainsize(1:ndusttypes),hdr,ierrs(1)) + call extract('graindens',graindens(1:ndusttypes),hdr,ierrs(2)) + if (any(ierrs(1:2) /= 0)) then + write(*,*) 'ERROR reading grain size/density from file header' + grainsize(1) = real(grainsizecgs/udist) + graindens(1) = real(graindenscgs/unit_density) + endif + endif + +end subroutine unfill_rheader + !--------------------------------------------------------------- !+ ! make sure required arrays have been read from Phantom file diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index e0ceb38e1..ac1554bbf 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -25,7 +25,7 @@ module readwrite_dumps_fortran ! use dump_utils, only:lenid,ndatatypes,i_int,i_int1,i_int2,i_int4,i_int8,& i_real,i_real4,i_real8,int1,int2,int1o,int2o,dump_h,lentag - use readwrite_dumps_common, only:check_arrays,fileident,get_options_from_fileid + use readwrite_dumps_common, only:check_arrays,fileident,get_options_from_fileid,fill_header,unfill_header implicit none public :: write_smalldump_fortran,write_fulldump_fortran,read_smalldump_fortran,read_dump_fortran @@ -1206,453 +1206,6 @@ subroutine check_block_header(narraylengths,nblocks,ilen,nums,nparttot,nhydrothi end subroutine check_block_header -!-------------------------------------------------------------------- -!+ -! utility to extract header variables to phantom -!+ -!------------------------------------------------------------------- -subroutine unfill_header(hdr,phantomdump,got_tags,nparttot, & - nblocks,npart,npartoftype, & - tfile,hfactfile,alphafile,iprint,id,nprocs,ierr) - use dim, only:maxdustlarge,use_dust - use io, only:master ! check this - use eos, only:isink - use part, only:maxtypes,igas,idust,ndustsmall,ndustlarge,ndusttypes,& - npartoftypetot - use units, only:udist,umass,utime,set_units_extra,set_units - use dump_utils, only:extract,dump_h - use fileutils, only:make_tags_unique - type(dump_h), intent(in) :: hdr - logical, intent(in) :: phantomdump,got_tags - integer(kind=8), intent(out) :: nparttot - integer, intent(out) :: nblocks,npart,npartoftype(maxtypes) - real, intent(out) :: tfile,hfactfile,alphafile - integer, intent(in) :: iprint,id,nprocs - integer, intent(out) :: ierr - integer :: nparttoti,npartoftypetoti(maxtypes),ntypesinfile,nptinfile - integer :: ierr1,ierrs(3),i,counter - integer(kind=8) :: ntypesinfile8 - character(len=10) :: dust_label(maxdustlarge) - - ierr = 0 - nparttot = 0 - npartoftypetot(:) = 0 - npart = 0 - npartoftype(:) = 0 - isink = 0 - call extract('ntypes',ntypesinfile,hdr,ierr1) - if (ierr1 /= 0 .or. ntypesinfile < 1) then - if (phantomdump .and. got_tags) then - ierr = 4 - return - else - ntypesinfile = 5 - endif - endif - - ! extract quantities from integer header - call extract('nparttot',nparttoti,hdr,ierr1) - if (ierr1 /= 0) then - ierr = 5 - return - endif - if (ntypesinfile > maxtypes) then - write(*,*) 'WARNING: number of particle types in file exceeds array limits' - write(*,*) 'READING ONLY FIRST ',maxtypes,' OF ',ntypesinfile,' particle types' - ntypesinfile = maxtypes - endif - call extract('npartoftype',npartoftypetoti(1:ntypesinfile),hdr,ierr1) - if (ierr1 /= 0) then - npartoftype(1) = nparttoti ! assume only gas particles - endif - call extract('nblocks',nblocks,hdr,ierr1,default=1) - if (ierr1 /= 0) write(*,*) 'number of MPI blocks not read: assuming 1' - - nparttot = int(nparttoti,kind=8) - npartoftypetot = int(npartoftypetoti,kind=8) - if (nblocks==1) then - npartoftype(1:ntypesinfile) = int(npartoftypetot(1:ntypesinfile)) - if (npartoftype(idust) > 0) write(*,*) 'n(gas) = ',npartoftype(igas) - counter = 0 - do i=1,maxdustlarge - if (npartoftype(idust+i-1) > 0) then - counter = counter + 1 - endif - enddo - dust_label = 'dust' - call make_tags_unique(counter,dust_label) - do i=1,counter - write(*,*) 'n('//trim(dust_label(i))//') = ',npartoftype(idust+i-1) - enddo - endif - call extract('isink',isink,hdr,ierr1) - -!--non-MPI dumps - if (nprocs==1) then - if (nparttoti > huge(npart)) then - write (*,*) 'ERROR in readdump: number of particles exceeds 32 bit limit, must use int(kind=8)''s ',nparttoti - ierr = 4 - return - endif - endif - if (nblocks==1) then - npart = int(nparttoti) - nparttot = npart - if (id==master) write (iprint,*) 'npart = ',npart - endif - if (got_tags) then - call extract('ntypes',ntypesinfile8,hdr,ierr1) - ntypesinfile = int(ntypesinfile8) - endif - if (ntypesinfile > maxtypes) then - write(*,*) 'WARNING: number of particle types in file exceeds array limits' - write(*,*) 'READING ONLY FIRST ',maxtypes,' OF ',ntypesinfile,' particle types' - ntypesinfile = maxtypes - endif - call extract('nparttot',nparttot,hdr,ierr1) - if (nblocks > 1) then - call extract('npartoftype',npartoftype(1:ntypesinfile),hdr,ierr1) - endif - if (id==master) write(*,*) 'npart(total) = ',nparttot -! -!--number of dust species -! - if (use_dust) then - call extract('ndustsmall',ndustsmall,hdr,ierrs(1)) - call extract('ndustlarge',ndustlarge,hdr,ierrs(2)) - if (any(ierrs(1:2) /= 0)) then - call extract('ndustfluids',ndustsmall,hdr,ierrs(1)) ! for backwards compatibility - if (ierrs(1) /= 0) write(*,*) 'ERROR reading number of small/large grain types from file header' - endif - ndusttypes = ndustsmall + ndustlarge - endif -! -!--units -! - call extract('udist',udist,hdr,ierrs(1)) - call extract('umass',umass,hdr,ierrs(2)) - call extract('utime',utime,hdr,ierrs(3)) - if (all(ierrs(1:3)==0)) then - call set_units_extra() - else - write(iprint,*) 'ERROR reading units from dump file, assuming default' - call set_units() ! use default units - endif - ! get nptmass from header, needed to figure out if gwinspiral info is sensible - call extract('nptmass',nptinfile,hdr,ierrs(1)) -!--default real - call unfill_rheader(hdr,phantomdump,ntypesinfile,nptinfile,& - tfile,hfactfile,alphafile,iprint,ierr) - if (ierr /= 0) return - - if (id==master) write(iprint,*) 'time = ',tfile - -end subroutine unfill_header - -!-------------------------------------------------------------------- -!+ -! subroutine to fill the real header with various things -!+ -!------------------------------------------------------------------- -subroutine fill_header(sphNGdump,t,nparttot,npartoftypetot,nblocks,nptmass,hdr,ierr) - use eos, only:write_headeropts_eos,polyk2 - 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 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 - use dim, only:use_dust,maxtypes,use_dustgrowth,do_nucleation, & - 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 - - logical, intent(in) :: sphNGdump - real, intent(in) :: t - integer(kind=8), intent(in) :: nparttot,npartoftypetot(:) - integer, intent(in) :: nblocks,nptmass - type(dump_h), intent(inout) :: hdr - integer, intent(out) :: ierr - integer :: number - - ierr = 0 - ! default int - call add_to_iheader(int(nparttot),'nparttot',hdr,ierr) - call add_to_iheader(maxtypes,'ntypes',hdr,ierr) - call add_to_iheader(int(npartoftypetot(1:maxtypes)),'npartoftype',hdr,ierr) - call add_to_iheader(nblocks,'nblocks',hdr,ierr) - call add_to_iheader(nptmass,'nptmass',hdr,ierr) - call add_to_iheader(ndustlarge,'ndustlarge',hdr,ierr) - call add_to_iheader(ndustsmall,'ndustsmall',hdr,ierr) - call add_to_iheader(idust,'idust',hdr,ierr) - call add_to_iheader(idtmax_n_next,'idtmax_n',hdr,ierr) - call add_to_iheader(idtmax_frac_next,'idtmax_frac',hdr,ierr) - call add_to_iheader(idumpfile,'idumpfile',hdr,ierr) - call add_to_iheader(phantom_version_major,'majorv',hdr,ierr) - call add_to_iheader(phantom_version_minor,'minorv',hdr,ierr) - call add_to_iheader(phantom_version_micro,'microv',hdr,ierr) - - ! int*8 - call add_to_header(nparttot,'nparttot',hdr,ierr) - call add_to_header(int(maxtypes,kind=8),'ntypes',hdr,ierr) - call add_to_header(npartoftypetot(1:maxtypes),'npartoftype',hdr,ierr) - - ! int*4 - call add_to_header(iexternalforce,'iexternalforce',hdr,ierr) - call add_to_header(ieos,'ieos',hdr,ierr) - call write_headeropts_eos(ieos,hdr,ierr) - - ! default real variables - call add_to_rheader(t,'time',hdr,ierr) - call add_to_rheader(dtmax_user,'dtmax',hdr,ierr) - call add_to_rheader(rhozero,'rhozero',hdr,ierr) - if (sphNGdump) then ! number = 23 - call add_to_rheader(0.,'escaptot',hdr,ierr) - call add_to_rheader(0.,'tkin',hdr,ierr) - call add_to_rheader(0.,'tgrav',hdr,ierr) - call add_to_rheader(0.,'tterm',hdr,ierr) - call add_to_rheader(0.,'anglostx',hdr,ierr) - call add_to_rheader(0.,'anglosty',hdr,ierr) - call add_to_rheader(0.,'anglostz',hdr,ierr) - call add_to_rheader(0.,'specang',hdr,ierr) - call add_to_rheader(0.,'ptmassin',hdr,ierr) - call add_to_rheader(0.,'tmag',hdr,ierr) - call add_to_rheader(Bextx,'Bextx',hdr,ierr) - call add_to_rheader(Bexty,'Bexty',hdr,ierr) - call add_to_rheader(Bextz,'Bextz',hdr,ierr) - call add_to_rheader(0.,'hzero',hdr,ierr) - call add_to_rheader(1.5*polyk2,'uzero_n2',hdr,ierr) - call add_to_rheader(0.,'hmass',hdr,ierr) - call add_to_rheader(0.,'gapfac',hdr,ierr) - call add_to_rheader(0.,'pmassinitial',hdr,ierr) - else ! number = 49 - call add_to_rheader(hfact,'hfact',hdr,ierr) - call add_to_rheader(tolh,'tolh',hdr,ierr) - call add_to_rheader(C_cour,'C_cour',hdr,ierr) - call add_to_rheader(C_force,'C_force',hdr,ierr) - call add_to_rheader(alpha,'alpha',hdr,ierr) - call add_to_rheader(alphau,'alphau',hdr,ierr) - call add_to_rheader(alphaB,'alphaB',hdr,ierr) - call add_to_rheader(massoftype,'massoftype',hdr,ierr) ! array - if (do_nucleation) call write_headeropts_dust_formation(hdr,ierr) - call add_to_rheader(Bextx,'Bextx',hdr,ierr) - call add_to_rheader(Bexty,'Bexty',hdr,ierr) - call add_to_rheader(Bextz,'Bextz',hdr,ierr) - call add_to_rheader(0.,'dum',hdr,ierr) - if (iexternalforce /= 0) call write_headeropts_extern(iexternalforce,hdr,t,ierr) - if (periodic) then - call add_to_rheader(xmin,'xmin',hdr,ierr) - call add_to_rheader(xmax,'xmax',hdr,ierr) - call add_to_rheader(ymin,'ymin',hdr,ierr) - call add_to_rheader(ymax,'ymax',hdr,ierr) - call add_to_rheader(zmin,'zmin',hdr,ierr) - call add_to_rheader(zmax,'zmax',hdr,ierr) - endif - if (dynamic_bdy) then - call add_to_rheader(dxyz,'dxyz',hdr,ierr) - call add_to_iheader(irho_bkg_ini,'irho_bkg_ini',hdr,ierr) - call add_to_rheader(rho_bkg_ini,'rho_bkg_ini',hdr,ierr) - endif - call add_to_rheader(get_conserv,'get_conserv',hdr,ierr) - call add_to_rheader(etot_in,'etot_in',hdr,ierr) - call add_to_rheader(angtot_in,'angtot_in',hdr,ierr) - call add_to_rheader(totmom_in,'totmom_in',hdr,ierr) - call add_to_rheader(mdust_in(1:ndusttypes),'mdust_in',hdr,ierr) - if (use_dust) then - call add_to_rheader(grainsize(1:ndusttypes),'grainsize',hdr,ierr) - call add_to_rheader(graindens(1:ndusttypes),'graindens',hdr,ierr) - endif - endif - - ! real*8 - call add_to_header(udist,'udist',hdr,ierr) - call add_to_header(umass,'umass',hdr,ierr) - call add_to_header(utime,'utime',hdr,ierr) - call add_to_header(unit_Bfield,'umagfd',hdr,ierr) - - if (ierr /= 0) write(*,*) ' ERROR: arrays too small writing rheader' - - number = num_in_header(hdr%realtags) - if (number >= maxphead) then - write(*,*) 'error: header arrays too small for number of items in header: will be truncated' - endif - -end subroutine fill_header - -!-------------------------------------------------------------------- -!+ -! subroutine to set runtime parameters having read the real header -!+ -!------------------------------------------------------------------- -subroutine unfill_rheader(hdr,phantomdump,ntypesinfile,nptmass,& - tfile,hfactfile,alphafile,iprint,ierr) - use io, only:id,master - use dim, only:maxvxyzu,nElements,use_dust,use_dustgrowth,use_krome,do_nucleation,idumpfile - use eos, only:extract_eos_from_hdr, read_headeropts_eos - 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 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 - use boundary_dyn, only:dynamic_bdy,dxyz,irho_bkg_ini,rho_bkg_ini,rho_bkg_ini1 - use dump_utils, only:extract - use dust, only:grainsizecgs,graindenscgs - use units, only:unit_density,udist - use timestep, only:idtmax_n,idtmax_frac - use dust_formation, only:read_headeropts_dust_formation - type(dump_h), intent(in) :: hdr - logical, intent(in) :: phantomdump - integer, intent(in) :: iprint,ntypesinfile,nptmass - real, intent(out) :: tfile,hfactfile,alphafile - integer, intent(out) :: ierr - - integer, parameter :: lu = 173 - integer :: ierrs(10),iextern_in_file - real :: xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,dtmaxi - real :: alphaufile,alphaBfile,C_courfile,C_forcefile,tolhfile - logical :: iexist - - ierr = 0 - call extract('time',tfile,hdr,ierr) - if (ierr/=0) call extract('gt',tfile,hdr,ierr) ! this is sphNG's label for time - call extract('dtmax',dtmaxi,hdr,ierr) - call extract('rhozero',rhozero,hdr,ierr) - Bextx = 0. - Bexty = 0. - Bextz = 0. - if (phantomdump) then - call extract('hfact',hfactfile,hdr,ierr) - call extract('tolh',tolhfile,hdr,ierr) - call extract('C_cour',C_courfile,hdr,ierr) - call extract('C_force',C_forcefile,hdr,ierr) - call extract('alpha',alphafile,hdr,ierr) - if (maxvxyzu >= 4) then - call extract('alphau',alphaufile,hdr,ierr) - else - alphaufile = 0. - endif - if (mhd) then - call extract('alphaB',alphaBfile,hdr,ierr) - endif - - if (extract_eos_from_hdr) call extract('ieos',ieos,hdr,ierr) - - call extract('massoftype',massoftype(1:ntypesinfile),hdr,ierr) - if (ierr /= 0) then - write(*,*) '*** ERROR reading massoftype from dump header ***' - ierr = 4 - endif - if (do_nucleation) then - call read_headeropts_dust_formation(hdr,ierr) - if (ierr /= 0) ierr = 6 - endif - - call extract('iexternalforce',iextern_in_file,hdr,ierrs(1)) - if (extract_iextern_from_hdr) iexternalforce = iextern_in_file - if (iexternalforce /= 0) then - call read_headeropts_extern(iexternalforce,hdr,nptmass,ierrs(1)) - if (ierrs(1) /= 0) ierr = 5 - elseif (iextern_in_file /= 0) then - call read_headeropts_extern(iextern_in_file,hdr,nptmass,ierrs(1)) - if (ierrs(1) /= 0) ierr = 5 - endif - - call extract('idtmax_n',idtmax_n,hdr,ierr,default=1) - call extract('idtmax_frac',idtmax_frac,hdr,ierr) - call extract('idumpfile',idumpfile,hdr,ierr) - else - massoftype(1) = 0. - hfactfile = 0. - endif - - call read_headeropts_eos(ieos,hdr,ierr) - - if (periodic) then - call extract('xmin',xmini,hdr,ierrs(1)) - call extract('xmax',xmaxi,hdr,ierrs(2)) - call extract('ymin',ymini,hdr,ierrs(3)) - call extract('ymax',ymaxi,hdr,ierrs(4)) - call extract('zmin',zmini,hdr,ierrs(5)) - call extract('zmax',zmaxi,hdr,ierrs(6)) - if (any(ierrs(1:6) /= 0)) then - write(*,"(2(/,a))") ' ERROR: dump does not contain boundary positions', & - ' but we are using periodic boundaries' - inquire(file='bound.tmp',exist=iexist) - if (iexist) then - open(unit=lu,file='bound.tmp') - read(lu,*) xmini,xmaxi,ymini,ymaxi,zmini,zmaxi - close(lu) - call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) - write(*,"(a,6(es10.3,1x))") ' READ from bound.tmp ',xmin,xmax,ymin,ymax,zmin,zmax - else - write(*,"(3(/,a),/,/,a)") ' To silence this error and restart from an older dump file ', & - ' create an ascii file called "bound.tmp" in the current directory', & - ' with xmin,xmax,ymin,ymax,zmin & zmax in it, e.g.: ', & - ' 0. 1. 0. 1. 0. 1.' - ierr = 5 ! spit fatal error - endif - else - call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) - endif - endif - - if (dynamic_bdy) then - call extract('irho_bkg_ini',irho_bkg_ini,hdr,ierrs(1)) - call extract('rho_bkg_ini',rho_bkg_ini,hdr,ierrs(1)) - call extract('dxyz',dxyz,hdr,ierrs(2)) - if (rho_bkg_ini > 0.) then - rho_bkg_ini1 = 1.0/rho_bkg_ini - else - rho_bkg_ini1 = 0. - endif - endif - - if (mhd) then - call extract('Bextx',Bextx,hdr,ierrs(1)) - call extract('Bexty',Bexty,hdr,ierrs(2)) - call extract('Bextz',Bextz,hdr,ierrs(3)) - if (id==master) then - if (any(ierrs(1:3) /= 0)) then - write(*,*) 'ERROR reading external field (setting to zero)' - else - write(*,*) 'External field found, Bext = ',Bextx,Bexty,Bextz - endif - endif - endif - - ! values to track that conserved values remain conserved - call extract('get_conserv',get_conserv,hdr,ierrs(1)) - 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)) - if (any(ierrs(1:4) /= 0)) then - write(*,*) 'ERROR reading values to verify conservation laws. Resetting initial values.' - get_conserv = 1.0 - endif - - - !--pull grain size and density arrays if they are in the header - !-- i.e. if dustgrowth is not ON - if (use_dust .and. .not.use_dustgrowth) then - call extract('grainsize',grainsize(1:ndusttypes),hdr,ierrs(1)) - call extract('graindens',graindens(1:ndusttypes),hdr,ierrs(2)) - if (any(ierrs(1:2) /= 0)) then - write(*,*) 'ERROR reading grain size/density from file header' - grainsize(1) = real(grainsizecgs/udist) - graindens(1) = real(graindenscgs/unit_density) - endif - endif - -end subroutine unfill_rheader - - !----------------------------------------------------------------- !+ ! if tags not read, give expected order of variables in header From b373d4d9a10bdafaf6c5807f34c33923f8d226cf Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 11 Apr 2024 12:31:27 +0100 Subject: [PATCH 407/814] restoring upstream changes part 4 --- src/setup/setup_bondi.F90 | 295 ----------- src/setup/setup_photoevap.f90 | 97 ---- src/setup/setup_sphere.f90 | 848 ------------------------------ src/setup/setup_wind.F90 | 828 ----------------------------- src/tests/directsum.f90 | 2 +- src/tests/phantomtest.f90 | 2 +- src/tests/test_cooling.f90 | 2 +- src/tests/test_corotate.f90 | 2 +- src/tests/test_damping.f90 | 2 +- src/tests/test_derivs.F90 | 2 +- src/tests/test_dust.f90 | 2 +- src/tests/test_eos.f90 | 2 +- src/tests/test_eos_stratified.f90 | 2 +- src/tests/test_externf.f90 | 2 +- src/tests/test_externf_gr.f90 | 2 +- src/tests/test_fastmath.F90 | 162 ------ src/tests/test_geometry.f90 | 2 +- src/tests/test_gnewton.f90 | 2 +- src/tests/test_gr.F90 | 557 -------------------- src/tests/test_gravity.F90 | 642 ---------------------- src/tests/test_growth.F90 | 406 -------------- src/tests/test_hierarchical.f90 | 2 +- src/tests/test_indtstep.F90 | 2 +- src/tests/test_kdtree.F90 | 2 +- src/tests/test_kernel.f90 | 2 +- src/tests/test_link.F90 | 2 +- src/tests/test_luminosity.F90 | 2 +- src/tests/test_mpi.F90 | 100 ---- src/tests/test_nonidealmhd.F90 | 2 +- src/tests/test_part.f90 | 2 +- src/tests/test_poly.f90 | 2 +- src/tests/test_ptmass.f90 | 2 +- src/tests/test_radiation.f90 | 5 +- src/tests/test_rwdump.F90 | 2 +- src/tests/test_sedov.F90 | 4 +- src/tests/test_setdisc.f90 | 2 +- src/tests/test_smol.F90 | 2 +- src/tests/test_step.F90 | 2 +- src/tests/utils_testsuite.f90 | 2 +- 39 files changed, 33 insertions(+), 3967 deletions(-) delete mode 100644 src/setup/setup_bondi.F90 delete mode 100644 src/setup/setup_photoevap.f90 delete mode 100644 src/setup/setup_sphere.f90 delete mode 100644 src/setup/setup_wind.F90 delete mode 100644 src/tests/test_fastmath.F90 delete mode 100644 src/tests/test_gr.F90 delete mode 100644 src/tests/test_gravity.F90 delete mode 100644 src/tests/test_growth.F90 delete mode 100644 src/tests/test_mpi.F90 diff --git a/src/setup/setup_bondi.F90 b/src/setup/setup_bondi.F90 deleted file mode 100644 index 10b56c781..000000000 --- a/src/setup/setup_bondi.F90 +++ /dev/null @@ -1,295 +0,0 @@ -!--------------------------------------------------------------------------! -! 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.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module setup -! -! Setup for Bondi flow problem, for both relativistic and non-relativistic solution -! -! :References: Liptai & Price (2019), MNRAS 485, 819-842 -! -! :Owner: David Liptai -! -! :Runtime parameters: -! - isol : *(1 = geodesic flow | 2 = sonic point flow)* -! - iswind : *wind option (logical)* -! - np : *desired number of particles (stretch-mapping will only give this approx.)* -! - rmax : *outer edge* -! - rmin : *inner edge* -! -! :Dependencies: bondiexact, centreofmass, dim, externalforces, -! infile_utils, io, kernel, metric_tools, options, part, physcon, -! prompting, setup_params, spherical, stretchmap, timestep, units -! - use physcon, only:pi - use externalforces, only:accradius1,accradius1_hard - use dim, only:gr,maxvxyzu - use metric_tools, only:imet_schwarzschild,imetric - use externalforces, only:mass1 - use setup_params, only:rhozero,npart_total - use io, only:master,fatal - use spherical, only:set_sphere - use options, only:ieos,iexternalforce,nfulldump - use timestep, only:tmax,dtmax - use centreofmass, only:reset_centreofmass - use units, only:set_units,get_G_code - use physcon, only:pc,solarm,gg - use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,ihacc,igas,set_particle_type,iboundary - use stretchmap, only:get_mass_r,rho_func - use kernel, only:radkern - use prompting, only:prompt - use bondiexact, only:get_bondi_solution,rcrit,isol,iswind - implicit none - - public :: setpart - - private - - real :: gamma_eos,rmax,rmin - integer :: np - - logical, parameter :: set_boundary_particles = .false. - -contains - -!---------------------------------------------------------------- -!+ -! setup for bondi accretion -!+ -!---------------------------------------------------------------- -subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) - integer, intent(in) :: id - integer, intent(inout) :: npart - integer, intent(out) :: npartoftype(:) - real, intent(out) :: xyzh(:,:) - real, intent(out) :: massoftype(:) - real, intent(out) :: vxyzu(:,:) - real, intent(out) :: polyk,gamma,hfact - real, intent(inout) :: time - character(len=20), intent(in) :: fileprefix - integer, parameter :: ntab=10000 - real :: rhotab(ntab) - real :: vol,psep,tff,rhor,vr,ur - real :: r,pos(3),cs2,totmass,approx_m,approx_h - integer :: i,ierr,nx,nbound - character(len=100) :: filename - logical :: iexist - procedure(rho_func), pointer :: density_func -! -!-- Set code units -! - call set_units(G=1.d0,c=1.d0) - print*,' G in code units = ',get_G_code() - -! -!--Set general parameters -! - time = 0. - iexternalforce = 1 - - rmin = 7. - rmax = 8. - np = 10000 - - if (gr) then - if (imetric/=imet_schwarzschild) call fatal('setup_bondi',& - 'You are not using the Schwarzschild metric.') - endif - -! -!-- Read things from setup file -! - filename=trim(fileprefix)//'.setup' - print "(/,1x,63('-'),1(/,1x,a),/,1x,63('-'),/)", 'Bondi Flow.' - inquire(file=filename,exist=iexist) - if (iexist) then - call read_setupfile(filename,ierr) - if (ierr /= 0) then - if (id==master) call write_setupfile(filename) - call fatal('setup','failed to read in all the data from .setup. Aborting') - endif - elseif (id==master) then - print "(a,/)",trim(filename)//' not found: using interactive setup' - if (gr) then - call prompt(' Enter solution type isol (1 = geodesic | 2 = sonic point flow) ',isol,1,2) - call prompt(' Do you want a wind (y/n)? ',iswind) - endif - call prompt(' Enter inner edge: ',rmin,0.) - call prompt(' Enter outer edge: ',rmax,rmin) - call prompt(' Enter the desired number of particles: ',np,0) - call write_setupfile(filename) - print*,' Edit '//trim(filename)//' and rerun phantomsetup' - stop - endif - - if (gr) then - ieos = 2 - gamma = 5./3. - polyk = 1. - else - gamma = 1. - ieos = 1 - cs2 = mass1/(2.*rcrit) - polyk = cs2 - endif - - gamma_eos = gamma ! Note, since non rel bondi is isothermal, solution doesn't depend on gamma - accradius1 = 0. - accradius1_hard = 0. - - if (gr) then - rmin = rmin*mass1 - rmax = rmax*mass1 - endif - - vol = 4./3.*pi*(rmax**3 - rmin**3) - nx = int(np**(1./3.)) - psep = vol**(1./3.)/real(nx) - - call get_rhotab(rhotab,rmin,rmax,mass1,gamma) - - density_func => rhofunc - totmass = get_mass_r(density_func,rmax,rmin) - approx_m = totmass/np - approx_h = hfact*(approx_m/rhofunc(rmin))**(1./3.) - rhozero = totmass/vol - - tff = sqrt(3.*pi/(32.*rhozero)) - tmax = 10.*tff - dtmax = tmax/150. - - print*,'' - print*,' Setup for gas: ' - print*,' min,max radius = ',rmin,rmax - print*,' volume = ',vol ,' particle separation = ',psep - print*,' vol/psep**3 = ',vol/psep**3,' totmass = ',totmass - print*,' free fall time = ',tff ,' tmax = ',tmax - print*,'' - -!--- Add stretched sphere - npart = 0 - npart_total = 0 - call set_sphere('closepacked',id,master,rmin,rmax,psep,hfact,npart,& - xyzh,rhotab=rhotab,nptot=npart_total) - massoftype(:) = totmass/npart - print "(a,i0,/)",' npart = ',npart - - nbound = 0 - do i=1,npart - - pos = xyzh(1:3,i) - r = sqrt(dot_product(pos,pos)) - call get_bondi_solution(rhor,vr,ur,r,mass1,gamma) - vxyzu(1:3,i) = vr*pos/r - if (maxvxyzu >= 4) vxyzu(4,i) = ur - - if (set_boundary_particles) then - if (r + radkern*xyzh(4,i)>rmax .or. r - radkern*xyzh(4,i) 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 diff --git a/src/setup/setup_wind.F90 b/src/setup/setup_wind.F90 deleted file mode 100644 index 012d95aea..000000000 --- a/src/setup/setup_wind.F90 +++ /dev/null @@ -1,828 +0,0 @@ -!--------------------------------------------------------------------------! -! 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 setup -! -! initial conditions for binary wind accretion / AGB star wind injection -! -! :References: -! Siess et al. 2022, A&A, 667, 75 -! -! :Owner: Lionel Siess -! -! :Runtime parameters: -! - Reff2a : *tight binary primary effective radius (au)* -! - Reff2b : *tight binary secondary effective radius (au)* -! - T_wind : *wind temperature (K)* -! - Teff2a : *tight binary primary effective temperature (K)* -! - Teff2b : *tight binary secondary effective temperature (K)* -! - binary2_a : *tight binary semi-major axis* -! - binary2_e : *tight binary eccentricity* -! - eccentricity : *eccentricity of the binary system* -! - icompanion_star : *set to 1 for a binary system, 2 for a triple system* -! - inclination : *inclination of the tight binary system w.r.t. outer binary (deg)* -! - lum2a : *tight binary primary luminosity (Lsun)* -! - lum2b : *tight binary secondary luminosity (Lsun)* -! - mass_of_particles : *particle mass (Msun, overwritten if iwind_resolution <>0)* -! - primary_Reff : *primary star effective radius (au)* -! - primary_Teff : *primary star effective temperature (K)* -! - primary_lum : *primary star luminosity (Lsun)* -! - primary_mass : *primary star mass (Msun)* -! - primary_racc : *primary star accretion radius (au)* -! - q2 : *tight binary mass ratio* -! - racc2a : *tight binary primary accretion radius* -! - racc2b : *tight binary secondary accretion radius* -! - secondary_Reff : *secondary star effective radius (au)* -! - secondary_Teff : *secondary star effective temperature)* -! - secondary_lum : *secondary star luminosity (Lsun)* -! - secondary_mass : *secondary star mass (Msun)* -! - secondary_racc : *secondary star accretion radius (au)* -! - semi_major_axis : *semi-major axis of the binary system (au)* -! - subst : *star to substitute* -! - temp_exponent : *temperature profile T(r) = T_wind*(r/Reff)^(-temp_exponent)* -! - wind_gamma : *adiabatic index (initial if Krome chemistry used)* -! -! :Dependencies: dim, eos, infile_utils, inject, io, part, physcon, -! prompting, setbinary, sethierarchical, spherical, timestep, units -! - use dim, only:isothermal - implicit none - public :: setpart - - private - real, public :: wind_gamma - real, public :: T_wind - real :: temp_exponent - integer :: icompanion_star,iwind - real :: semi_major_axis,semi_major_axis_au,eccentricity - real :: default_particle_mass - real :: primary_lum_lsun,primary_mass_msun,primary_Reff_au,primary_racc_au - real :: secondary_lum_lsun,secondary_mass_msun,secondary_Reff_au,secondary_racc_au - real :: lum2a_lsun,lum2b_lsun,Teff2a,Teff2b,Reff2a_au,Reff2b_au - real :: binary2_a_au,racc2a_au,racc2b_au,binary2_i,q2 - real :: primary_Reff,primary_Teff,primary_lum,primary_mass,primary_racc - real :: secondary_Reff,secondary_Teff,secondary_lum,secondary_mass,secondary_racc - real :: Reff2a,Reff2b - real :: racc2a,racc2b - real :: lum2a,lum2b - real :: binary2_a - real :: binary2_e - integer :: subst - -contains -!---------------------------------------------------------------- -!+ -! default parameter choices -!+ -!---------------------------------------------------------------- -subroutine set_default_parameters_wind() - - wind_gamma = 5./3. - if (isothermal) then - T_wind = 30000. - temp_exponent = 0.5 - ! primary_racc_au = 0.465 - ! primary_mass_msun = 1.5 - ! primary_lum_lsun = 0. - ! primary_Reff_au = 0.465240177008 !100 Rsun - else - T_wind = 3000. - !primary_racc_au = 1. - !primary_mass_msun = 1.5 - !primary_lum_lsun = 20000. - !primary_Reff_au = 0. - endif - icompanion_star = 0 - semi_major_axis = 4.0 - eccentricity = 0. - primary_Teff = 3000. - secondary_Teff = 0. - semi_major_axis_au = 4.0 - default_particle_mass = 1.e-11 - primary_lum_lsun = 5315. - primary_mass_msun = 1.5 - primary_Reff_au = 1. - primary_racc_au = 1. - secondary_lum_lsun = 0. - secondary_mass_msun = 1.0 - secondary_Reff_au = 0. - secondary_racc_au = 0.1 - lum2a_lsun = 0. - lum2b_lsun = 0. - Teff2a = 0. - Teff2b = 0. - Reff2a_au = 0. - Reff2b_au = 0. - binary2_a_au = 0.3 - racc2a_au = 0.1 - racc2b_au = 0.1 - binary2_i = 0. - -end subroutine set_default_parameters_wind - -!---------------------------------------------------------------- -!+ -! setup for uniform particle distributions -!+ -!---------------------------------------------------------------- -subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) - use part, only: xyzmh_ptmass, vxyz_ptmass, nptmass, igas, iTeff, iLum, iReff - use physcon, only: au, solarm, mass_proton_cgs, kboltz, solarl - use units, only: umass,set_units,unit_velocity,utime,unit_energ,udist - use inject, only: init_inject,set_default_options_inject - use setbinary, only: set_binary - use sethierarchical, only: set_multiple - use io, only: master - use eos, only: gmw,ieos,isink,qfacdisc - use spherical, only: set_sphere - use timestep, only: tmax!,dtmax - 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 - real, intent(inout) :: time - character(len=*), intent(in) :: fileprefix - character(len=len(fileprefix)+6) :: filename - integer :: ierr,k - logical :: iexist - - call set_units(dist=au,mass=solarm,G=1.) - call set_default_parameters_wind() - filename = trim(fileprefix)//'.in' - inquire(file=filename,exist=iexist) - if (.not. iexist) call set_default_options_inject - -!--general parameters -! - time = 0. - filename = trim(fileprefix)//'.setup' - inquire(file=filename,exist=iexist) - if (iexist) call read_setupfile(filename,ierr) - if (.not. iexist .or. ierr /= 0) then - if (id==master) then - call setup_interactive() - call write_setupfile(filename) - endif - endif - -! -!--space available for injected gas particles -! - npart = 0 - npartoftype(:) = 0 - xyzh(:,:) = 0. - vxyzu(:,:) = 0. - xyzmh_ptmass(:,:) = 0. - vxyz_ptmass(:,:) = 0. - - if (icompanion_star == 1) then - call set_binary(primary_mass, & - secondary_mass, & - semi_major_axis, & - eccentricity, & - primary_racc, & - secondary_racc, & - xyzmh_ptmass, vxyz_ptmass, nptmass, ierr) - xyzmh_ptmass(iTeff,1) = primary_Teff - xyzmh_ptmass(iReff,1) = primary_Reff - xyzmh_ptmass(iLum,1) = primary_lum - xyzmh_ptmass(iTeff,2) = secondary_Teff - xyzmh_ptmass(iReff,2) = secondary_Reff - xyzmh_ptmass(iLum,2) = secondary_lum - elseif (icompanion_star == 2) then - !-- hierarchical triple - nptmass = 0 - print "(/,a)",'----------- Hierarchical triple -----------' - print "(a,g10.3,a)",' First hierarchical level primary mass: ', primary_mass_msun - print "(a,g10.3,a)",' First hierarchical level secondary mass: ', secondary_mass_msun - print "(a,g10.3)", ' Wide binary mass ratio: ', secondary_mass/primary_mass - print "(a,g10.3)", ' Tight binary mass ratio: ', q2 - print "(a,g10.3)", ' Star to be substituted: ', abs(subst) -! print "(a,g10.3,a)",' Accretion Radius 1: ', primary_racc!, trim(dist_unit) -! print "(a,g10.3,a)",' Accretion Radius 2a: ', racc2a!, trim(dist_unit) -! print "(a,g10.3,a)",' Accretion Radius 2b: ', racc2b!, trim(dist_unit) - - if (subst>0) then - print "(a,g10.3,a)",' Tight binary orientation referred to: substituted star orbital plane' - else - print "(a,g10.3,a)",' Tight binary orientation referred to: sky' - endif - - - call set_multiple(primary_mass,secondary_mass,semimajoraxis=semi_major_axis,eccentricity=eccentricity, & - accretion_radius1=primary_racc,accretion_radius2=secondary_racc, & - xyzmh_ptmass=xyzmh_ptmass,vxyz_ptmass=vxyz_ptmass,nptmass=nptmass,ierr=ierr) - - if (subst == 12) then - call set_multiple(secondary_mass/(q2+1),secondary_mass*q2/(q2+1),semimajoraxis=binary2_a,eccentricity=binary2_e, & - accretion_radius1=racc2a,accretion_radius2=racc2b, & - xyzmh_ptmass=xyzmh_ptmass,vxyz_ptmass=vxyz_ptmass,nptmass=nptmass,& - posang_ascnode=0.,arg_peri=0.,incl=binary2_i,subst=subst,ierr=ierr) - - xyzmh_ptmass(iTeff,1) = primary_Teff - xyzmh_ptmass(iReff,1) = primary_Reff - xyzmh_ptmass(iLum,1) = primary_lum - xyzmh_ptmass(iTeff,2) = Teff2a - xyzmh_ptmass(iReff,2) = Reff2a - xyzmh_ptmass(iLum,2) = lum2a - xyzmh_ptmass(iTeff,3) = Teff2b - xyzmh_ptmass(iReff,3) = Reff2b - xyzmh_ptmass(iLum,3) = lum2b - - elseif (subst == 11) then - call set_multiple(primary_mass*q2/(q2+1),primary_mass/(q2+1),semimajoraxis=binary2_a,eccentricity=binary2_e, & - accretion_radius1=racc2b,accretion_radius2=primary_racc, & - xyzmh_ptmass=xyzmh_ptmass,vxyz_ptmass=vxyz_ptmass,nptmass=nptmass,& - posang_ascnode=0.,arg_peri=0.,incl=binary2_i,subst=subst,ierr=ierr) - - xyzmh_ptmass(iTeff,1) = primary_Teff - xyzmh_ptmass(iReff,1) = primary_Reff - xyzmh_ptmass(iLum,1) = primary_lum - xyzmh_ptmass(iTeff,2) = secondary_Teff - xyzmh_ptmass(iReff,2) = secondary_Reff - xyzmh_ptmass(iLum,2) = secondary_lum - xyzmh_ptmass(iTeff,3) = Teff2b - xyzmh_ptmass(iReff,3) = Reff2b - xyzmh_ptmass(iLum,3) = lum2b - endif - - print *,'Sink particles summary' - print *,' # mass racc lum Reff' - do k=1,nptmass - print '(i4,2(2x,f9.5),2(2x,es10.3))',k,xyzmh_ptmass(4:5,k),xyzmh_ptmass(iLum,k)/(solarl*utime/unit_energ),& - xyzmh_ptmass(iReff,k)*udist/au - enddo - print *,'' - - else - nptmass = 1 - xyzmh_ptmass(4,1) = primary_mass - xyzmh_ptmass(5,1) = primary_racc - xyzmh_ptmass(iTeff,1) = primary_Teff - xyzmh_ptmass(iReff,1) = primary_Reff - xyzmh_ptmass(iLum,1) = primary_lum - endif - - ! - ! for binary wind simulations the particle mass is IRRELEVANT - ! since it will be over-written on the first call to init_inject - ! - massoftype(igas) = default_particle_mass * (solarm / umass) - - if (isothermal) then - gamma = 1. - if (iwind == 3) then - ieos = 6 - qfacdisc = 0.5*temp_exponent - isink = 1 - T_wind = primary_Teff - else - isink = 1 - ieos = 1 - endif - else - T_wind = 0. - gamma = wind_gamma - endif - polyk = kboltz*T_wind/(mass_proton_cgs * gmw * unit_velocity**2) - - ! - ! avoid failures in the setup by ensuring that tmax and dtmax are large enough - ! - tmax = max(tmax,100.) - !dtmax = max(tmax/10.,dtmax) - -end subroutine setpart - -!---------------------------------------------------------------- -!+ -! determine which problem to set up interactively -!+ -!---------------------------------------------------------------- -subroutine setup_interactive() - use prompting, only:prompt - use physcon, only:au,solarm - use units, only:umass,udist - use io, only:fatal - integer :: ichoice - - if (isothermal) then - iwind = 2 - else - iwind = 1 - call prompt('Type of wind: 1=adia, 2=isoT, 3=T(r)',iwind,1,3) - if (iwind == 2 .or. iwind == 3) then - call fatal('setup','If you choose options 2 or 3, the code must be compiled with SETUP=isowind') - endif - if (iwind == 3) T_wind = primary_Teff - endif - - icompanion_star = 0 - call prompt('Add binary?',icompanion_star,0,2) - - !Hierarchical triple system - if (icompanion_star == 2) then - !select the tight binary - ichoice = 1 - print "(a)",'Star to be substituted by a tight binary' - print "(a)",' 1: primary (2+1)' ,' 2: companion (1+2)' - call prompt('Select star to be substituted',ichoice,1,2) - subst = ichoice+10 - - !select orbital parameters for outer binary - semi_major_axis_au = 15. - eccentricity = 0. - ichoice = 1 - print "(a)",'Orbital parameters first hierarchical level binary' - print "(a)",' 1: semi-axis = 15 au, eccentricity = 0',' 0: custom' - call prompt('select semi-major axis and ecccentricity',ichoice,0,1) - if (ichoice == 0) then - call prompt('enter semi-major axis in au',semi_major_axis_au,0.,100.) - call prompt('enter eccentricity',eccentricity,0.) - endif - semi_major_axis = semi_major_axis_au * au / udist - ichoice = 1 - - !replace companion by tight binary system : 1+2 - if (subst == 12) then - print "(a)",'Primary star parameters (the single wind launching central star)' - print "(a)",' 2: Mass = 1.2 Msun, accretion radius = 0.2568 au',& - ' 1: Mass = 1.5 Msun, accretion radius = 1.2568 au', & - ' 0: custom' - call prompt('select mass and radius of primary',ichoice,0,2) - select case(ichoice) - case(2) - primary_mass_msun = 1.2 - primary_racc_au = 0.2568 - case(1) - primary_mass_msun = 1.5 - primary_racc_au = 1.2568 - case default - primary_mass_msun = 1.5 - primary_racc_au = 1. - call prompt('enter primary mass',primary_mass_msun,0.,100.) - call prompt('enter accretion radius in au ',primary_racc_au,0.) - end select - primary_mass = primary_mass_msun * (solarm / umass) - primary_racc = primary_racc_au * (au / udist) - - ichoice = 1 - print "(a)",'Total mass of tight binary system (1+2)' - print "(a)",' 1: Total mass tight binary = 1.0 Msun',' 0: custom' - secondary_mass_msun = 1. - call prompt('select mass',ichoice,0,1) - select case(ichoice) - case(0) - call prompt('enter total mass tigh binary',secondary_mass_msun,0.,100.) - end select - secondary_mass = secondary_mass_msun * (solarm / umass) - - ichoice = 1 - print "(a)",'Mass ratio and accretion radii of stars in tight orbit:' - print "(a)",' 1: mass ratio m2b/m2a = 1, accretion radius a = 0.01 au, accretion radius b = 0.01 au',' 0: custom' - call prompt('select mass ratio and accretion radii of tight binary',ichoice,0,1) - select case(ichoice) - case(1) - q2 = 1. - racc2a_au = 0.1 - racc2b_au = 0.1 - case default - q2 = 1. - racc2a_au = 0.1 - racc2b_au = 0.1 - call prompt('enter tight binary mass ratio',q2,0.) - call prompt('enter accretion radius a in au ',racc2a_au,0.) - call prompt('enter accretion radius b in au ',racc2b_au,0.) - end select - racc2a = racc2a_au * (au / udist) - racc2b = racc2b_au * (au / udist) - secondary_racc = racc2a !needs to be /=0 otherwise NaNs in set_multiple - - !replace primary by tight binary system : 2+1 - elseif (subst == 11) then - print "(a)",'Stellar parameters of the remote single star (2+1)' - print "(a)",' 1: Mass = 1.0 Msun, accretion radius = 0.1 au',' 0: custom' - call prompt('select mass and radius of remote single star',ichoice,0,1) - select case(ichoice) - case(1) - secondary_mass_msun = 1. - secondary_racc_au = 0.1 - case default - secondary_mass_msun = 1. - secondary_racc_au = 0.1 - call prompt('enter mass of remote single star',secondary_mass_msun,0.,100.) - call prompt('enter accretion radius in au ',secondary_racc_au,0.) - end select - secondary_mass = secondary_mass_msun * (solarm / umass) - secondary_racc = secondary_racc_au * (au / udist) - - ichoice = 1 - print "(a)",'wind-launching star accretion radius in tigh orbit (called primary)' - print "(a)",' 2: accretion radius primary = 0.2568 au',& - ' 1: accretion radius primary = 1.2568 au', & - ' 0: custom' - call prompt('select accretion radius of wind launching star',ichoice,0,2) - select case(ichoice) - case(2) - primary_racc_au = 0.2568 - case(1) - primary_racc_au = 1.2568 - case default - primary_racc_au = 1. - call prompt('enter accretion radius in au ',primary_racc_au,0.) - end select - primary_racc = primary_racc_au * (au / udist) - - ichoice = 1 - print "(a)",'Total mass of the tight binary system (2+1):' - print "(a)",' 2: Total mass tight binary = 1.2 Msun',& - ' 1: Total mass tight binary = 1.5 Msun', & - ' 0: custom' - call prompt('select total mass tight binary',ichoice,0,2) - select case(ichoice) - case(2) - primary_mass_msun = 1.2 - case(1) - primary_mass_msun = 1.5 - case default - primary_mass_msun = 1.5 - call prompt('enter primary mass',primary_mass_msun,0.,100.) - end select - primary_mass = primary_mass_msun * (solarm / umass) - - ichoice = 1 - print "(a)",'Mass ratio and accretion radius of secondary in tight orbit:' - print "(a)",' 1: mass ratio m1b/m1a = 0.3, accretion radius b = 0.01 au',' 0: custom' - call prompt('select mass ratio and accretion radius of tight binary',ichoice,0,1) - select case(ichoice) - case(1) - q2 = 0.3 - racc2b_au = 0.1 - case default - q2 = 0.3 - racc2b_au = 0.1 - call prompt('enter tight binary mass ratio',q2,0.) - call prompt('enter accretion radius b in au ',racc2b_au,0.) - end select - racc2b = racc2b_au * (au / udist) - endif - - ichoice = 1 - print "(a)",'Orbital parameters of tight system:' - print "(a)",' 1: semi-axis = 4 au, eccentricity = 0',' 0: custom' - call prompt('select tight binary semi-major axis and eccentricity',ichoice,0,1) - select case(ichoice) - case(1) - binary2_a_au = 4. - binary2_e = 0. - case default - binary2_a_au = 4. - binary2_e = 0. - call prompt('enter semi-major axis in au',binary2_a_au,0.,semi_major_axis_au) - call prompt('enter eccentricity',binary2_e,0.) - end select - binary2_a = binary2_a_au * au / udist - - ichoice = 1 - print "(a)",'inclination of orbit tight binary w.r.t. outer binary:' - print "(a)",' 1: inclination = 0 deg',' 0: custom' - call prompt('select inclination',ichoice,0,1) - select case(ichoice) - case(1) - binary2_i = 0. - case default - binary2_i = 0. - call prompt('enter inclination',binary2_i,0.,90.) - end select - - !binary or single star case - else - if (icompanion_star == 1) then - print "(a)",'Primary star parameters' - else - print "(a)",'Stellar parameters' - endif - ichoice = 2 - print "(a)",' 3: Mass = 1.2 Msun, accretion radius = 1. au (trans-sonic)',& - ' 2: Mass = 1.2 Msun, accretion radius = 0.2568 au',& - ' 1: Mass = 1.0 Msun, accretion radius = 1.2568 au', & - ' 0: custom' - call prompt('select mass and radius of primary',ichoice,0,3) - select case(ichoice) - case(3) - primary_lum_lsun = 2.d4 - primary_Teff = 5.d4 - primary_mass_msun = 1.2 - primary_racc_au = 1. - wind_gamma = 1.4 - case(2) - primary_mass_msun = 1.2 - primary_racc_au = 0.2568 - case(1) - primary_mass_msun = 1. - primary_racc_au = 1.2568 - case default - primary_mass_msun = 1. - primary_racc_au = 1. - call prompt('enter primary mass',primary_mass_msun,0.,100.) - call prompt('enter accretion radius in au ',primary_racc_au,0.) - end select - primary_mass = primary_mass_msun * (solarm / umass) - primary_racc = primary_racc_au * (au / udist) - - if (icompanion_star == 1) then - ichoice = 1 - print "(a)",'Secondary star parameters' - print "(a)",' 1: Mass = 1.0 Msun, accretion radius = 0.1 au',' 0: custom' - call prompt('select mass and radius of secondary',ichoice,0,1) - select case(ichoice) - case(1) - secondary_mass_msun = 1. - secondary_racc_au = 0.1 - case default - secondary_mass_msun = 1. - secondary_racc_au = 0.1 - call prompt('enter secondary mass',secondary_mass_msun,0.,100.) - call prompt('enter accretion radius in au ',secondary_racc_au,0.) - end select - secondary_mass = secondary_mass_msun * (solarm / umass) - secondary_racc = secondary_racc_au * (au / udist) - - ichoice = 1 - print "(a)",'Orbital parameters' - print "(a)",' 1: semi-axis = 3.7 au, eccentricity = 0',' 0: custom' - call prompt('select semi-major axis and ecccentricity',ichoice,0,1) - select case(ichoice) - case(1) - semi_major_axis_au = 3.7 - eccentricity = 0. - case default - semi_major_axis_au = 1. - eccentricity = 0. - call prompt('enter semi-major axis in au',semi_major_axis_au,0.,100.) - call prompt('enter eccentricity',eccentricity,0.) - end select - semi_major_axis = semi_major_axis_au * au / udist - endif - endif - -end subroutine setup_interactive - -!---------------------------------------------------------------- -!+ -! get luminosity and effective radius in code units -! from various combinations of L, Teff and Reff in physical inuts -!+ -!---------------------------------------------------------------- -subroutine get_lum_and_Reff(lum_lsun,reff_au,Teff,lum,Reff) - use physcon, only:au,steboltz,solarl,pi - use units, only:udist,unit_luminosity - real, intent(inout) :: lum_lsun,reff_au,Teff - real, intent(out) :: lum,Reff - - if (Teff <= tiny(0.) .and. lum_lsun > 0. .and. Reff_au > 0.) then - primary_Teff = (lum_lsun*solarl/(4.*pi*steboltz*(Reff_au*au)**2))**0.25 - elseif (Reff_au <= 0. .and. lum_lsun > 0. .and. Teff > 0.) then - Reff_au = sqrt(lum_lsun*solarl/(4.*pi*steboltz*Teff**4))/au - elseif (Reff_au > 0. .and. lum_lsun <= 0. .and. Teff > 0.) then - lum_lsun = 4.*pi*steboltz*Teff**4*(primary_Reff_au*au)**2/solarl - endif - - lum = lum_lsun*(solarl/unit_luminosity) - Reff = Reff_au*(au/udist) - -end subroutine get_lum_and_Reff - -!---------------------------------------------------------------- -!+ -! write parameters to setup file -!+ -!---------------------------------------------------------------- -subroutine write_setupfile(filename) - use infile_utils, only:write_inopt - character(len=*), intent(in) :: filename - integer, parameter :: iunit = 20 - - print "(a)",' writing setup options file '//trim(filename) - open(unit=iunit,file=filename,status='replace',form='formatted') - write(iunit,"(a)") '# input file for wind setup routine' - - call get_lum_and_Reff(primary_lum_lsun,primary_Reff_au,primary_Teff,primary_lum,primary_Reff) - - if (icompanion_star == 2) then - call get_lum_and_Reff(secondary_lum_lsun,secondary_Reff_au,secondary_Teff,secondary_lum,secondary_Reff) - - call write_inopt(icompanion_star,'icompanion_star','set to 1 for a binary system, 2 for a triple system',iunit) - !-- hierarchical triple - write(iunit,"(/,a)") '# options for hierarchical triple' - call write_inopt(subst,'subst','star to substitute',iunit) - write(iunit,"(/,a)") '# input of primary (wind launching star)' - if (subst == 12) then - call write_inopt(primary_mass_msun,'primary_mass','primary star mass (Msun)',iunit) - call write_inopt(primary_racc_au,'primary_racc','primary star accretion radius (au)',iunit) - call write_inopt(primary_lum_lsun,'primary_lum','primary star luminosity (Lsun)',iunit) - call write_inopt(primary_Teff,'primary_Teff','primary star effective temperature (K)',iunit) - call write_inopt(primary_Reff_au,'primary_Reff','primary star effective radius (au)',iunit) - call write_inopt(semi_major_axis_au,'semi_major_axis','semi-major axis of the binary system (au)',iunit) - call write_inopt(eccentricity,'eccentricity','eccentricity of the binary system',iunit) - write(iunit,"(/,a)") '# input secondary to be replaced by tight binary' - call write_inopt(secondary_mass_msun,'secondary_mass','total mass of secondary tight binary (Msun)',iunit) - call write_inopt(q2,'q2','tight binary mass ratio',iunit) - !-- tight orbital parameters - call write_inopt(binary2_a,'binary2_a','tight binary semi-major axis',iunit) - call write_inopt(binary2_e,'binary2_e','tight binary eccentricity',iunit) - !-- accretion radii, luminosity, radii - call write_inopt(racc2a_au,'racc2a','tight binary primary accretion radius',iunit) - call write_inopt(racc2b_au,'racc2b','tight binary secondary accretion radius',iunit) - call write_inopt(lum2a_lsun,'lum2a','tight binary primary luminosity (Lsun)',iunit) - call write_inopt(lum2b_lsun,'lum2b','tight binary secondary luminosity (Lsun)',iunit) - call write_inopt(Teff2a,'Teff2a','tight binary primary effective temperature (K)',iunit) - call write_inopt(Teff2b,'Teff2b','tight binary secondary effective temperature (K)',iunit) - call write_inopt(Reff2a_au,'Reff2a','tight binary primary effective radius (au)',iunit) - call write_inopt(Reff2b_au,'Reff2b','tight binary secondary effective radius (au)',iunit) - elseif (subst == 11) then - call write_inopt(primary_racc_au,'primary_racc','primary star accretion radius (au)',iunit) - call write_inopt(primary_lum_lsun,'primary_lum','primary star luminosity (Lsun)',iunit) - call write_inopt(primary_Teff,'primary_Teff','primary star effective temperature (K)',iunit) - call write_inopt(primary_Reff_au,'primary_Reff','primary star effective radius (au)',iunit) - write(iunit,"(/,a)") '# input tight binary to create close companion' - call write_inopt(primary_mass_msun,'primary_mass','primary star mass (Msun)',iunit) - call write_inopt(q2,'q2','tight binary mass ratio',iunit) - !-- tight orbital parameters - call write_inopt(binary2_a,'binary2_a','tight binary semi-major axis',iunit) - call write_inopt(binary2_e,'binary2_e','tight binary eccentricity',iunit) - !-- accretion radii - call write_inopt(racc2b_au,'racc2b','tight binary secondary accretion radius',iunit) - call write_inopt(lum2b_lsun,'lum2b','tight binary secondary luminosity (Lsun)',iunit) - call write_inopt(Teff2b,'Teff2b','tight binary secondary effective temperature (K)',iunit) - call write_inopt(Reff2b_au,'Reff2b','tight binary secondary effective radius (au)',iunit) - write(iunit,"(/,a)") '# input of secondary, outer binary' - call write_inopt(secondary_mass_msun,'secondary_mass','secondary star mass (Msun)',iunit) - call write_inopt(secondary_racc_au,'secondary_racc','secondary star accretion radius (au)',iunit) - call write_inopt(secondary_lum_lsun,'secondary_lum','secondary star luminosity (Lsun)',iunit) - call write_inopt(secondary_Teff,'secondary_Teff','secondary star effective temperature)',iunit) - call write_inopt(secondary_Reff_au,'secondary_Reff','secondary star effective radius (au)',iunit) - call write_inopt(semi_major_axis_au,'semi_major_axis','semi-major axis of the binary system (au)',iunit) - call write_inopt(eccentricity,'eccentricity','eccentricity of the binary system',iunit) - endif - call write_inopt(binary2_i,'inclination','inclination of the tight binary system w.r.t. outer binary (deg)',iunit) - !binary or single star - else - call write_inopt(primary_mass_msun,'primary_mass','primary star mass (Msun)',iunit) - call write_inopt(primary_racc_au,'primary_racc','primary star accretion radius (au)',iunit) - call write_inopt(primary_lum_lsun,'primary_lum','primary star luminosity (Lsun)',iunit) - call write_inopt(primary_Teff,'primary_Teff','primary star effective temperature (K)',iunit) - call write_inopt(primary_Reff_au,'primary_Reff','primary star effective radius (au)',iunit) - call write_inopt(icompanion_star,'icompanion_star','set to 1 for a binary system, 2 for a triple system',iunit) - if (icompanion_star == 1) then - call get_lum_and_Reff(secondary_lum_lsun,secondary_Reff_au,secondary_Teff,secondary_lum,secondary_Reff) - - call write_inopt(secondary_mass_msun,'secondary_mass','secondary star mass (Msun)',iunit) - call write_inopt(secondary_racc_au,'secondary_racc','secondary star accretion radius (au)',iunit) - call write_inopt(secondary_lum_lsun,'secondary_lum','secondary star luminosity (Lsun)',iunit) - call write_inopt(secondary_Teff,'secondary_Teff','secondary star effective temperature)',iunit) - call write_inopt(secondary_Reff_au,'secondary_Reff','secondary star effective radius (au)',iunit) - call write_inopt(semi_major_axis_au,'semi_major_axis','semi-major axis of the binary system (au)',iunit) - call write_inopt(eccentricity,'eccentricity','eccentricity of the binary system',iunit) - endif - endif - - call write_inopt(default_particle_mass,'mass_of_particles','particle mass (Msun, overwritten if iwind_resolution <>0)',iunit) - - if (isothermal) then - wind_gamma = 1. - if (iwind == 3) then - call write_inopt(primary_Teff,'T_wind','wind temperature at injection radius (K)',iunit) - call write_inopt(temp_exponent,'temp_exponent','temperature profile T(r) = T_wind*(r/Reff)^(-temp_exponent)',iunit) - else - call write_inopt(T_wind,'T_wind','wind temperature (K)',iunit) - endif - else - call write_inopt(wind_gamma,'wind_gamma','adiabatic index (initial if Krome chemistry used)',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 physcon, only:au,steboltz,solarl,solarm,pi - use units, only:udist,umass,utime,unit_energ - character(len=*), intent(in) :: filename - integer, intent(out) :: ierr - integer, parameter :: iunit = 21 - type(inopts), allocatable :: db(:) - integer :: nerr,ichange - - nerr = 0 - ichange = 0 - print "(a)",' reading setup options from '//trim(filename) - call open_db_from_file(db,filename,iunit,ierr) - call read_inopt(primary_mass_msun,'primary_mass',db,min=0.,max=1000.,errcount=nerr) - primary_mass = primary_mass_msun * (solarm / umass) - call read_inopt(primary_lum_lsun,'primary_lum',db,min=0.,max=1e7,errcount=nerr) - primary_lum = primary_lum_lsun * (solarl * utime / unit_energ) - call read_inopt(primary_Teff,'primary_Teff',db,min=0.,errcount=nerr) - call read_inopt(primary_Reff_au,'primary_Reff',db,min=0.,errcount=nerr) - primary_Reff = primary_Reff_au * au / udist - call read_inopt(primary_racc_au,'primary_racc',db,min=0.,errcount=nerr) - primary_racc = primary_racc_au * au / udist - if (primary_racc < tiny(0.)) then - print *,'ERROR: primary accretion radius not defined' - nerr = nerr+1 - endif - - call read_inopt(icompanion_star,'icompanion_star',db,min=0,errcount=nerr) - if (icompanion_star == 1) then - call read_inopt(secondary_mass_msun,'secondary_mass',db,min=0.,max=1000.,errcount=nerr) - secondary_mass = secondary_mass_msun * (solarm / umass) - call read_inopt(secondary_lum_lsun,'secondary_lum',db,min=0.,max=1e7,errcount=nerr) - secondary_lum = secondary_lum_lsun * (solarl * utime / unit_energ) - call read_inopt(secondary_Teff,'secondary_Teff',db,min=0.,errcount=nerr) - call read_inopt(secondary_Reff_au,'secondary_Reff',db,min=0.,errcount=nerr) - secondary_Reff = secondary_Reff_au * au / udist - call read_inopt(secondary_racc_au,'secondary_racc',db,min=0.,errcount=nerr) - secondary_racc = secondary_racc_au * au / udist - if (secondary_racc < tiny(0.)) then - print *,'ERROR: secondary accretion radius not defined' - nerr = nerr+1 - endif - call read_inopt(semi_major_axis_au,'semi_major_axis',db,min=0.,errcount=nerr) - semi_major_axis = semi_major_axis_au * au / udist - call read_inopt(eccentricity,'eccentricity',db,min=0.,errcount=nerr) - elseif (icompanion_star == 2) then - !-- hierarchical triple - call read_inopt(subst,'subst',db,errcount=nerr) - !replace primary by tight binary system : 2+1 - if (subst == 11) then - call read_inopt(secondary_lum_lsun,'secondary_lum',db,min=0.,max=1000.,errcount=nerr) - secondary_lum = secondary_lum_lsun * (solarl * utime / unit_energ) - call read_inopt(secondary_Teff,'secondary_Teff',db,min=0.,max=1000.,errcount=nerr) - call read_inopt(secondary_Reff_au,'secondary_Reff',db,min=0.,max=1000.,errcount=nerr) - secondary_Reff = secondary_Reff_au * au / udist - call read_inopt(secondary_racc_au,'secondary_racc',db,min=0.,max=1000.,errcount=nerr) - secondary_racc = secondary_racc_au * au / udist - elseif (subst == 12) then - call read_inopt(lum2a_lsun,'lum2a',db,errcount=nerr) - lum2a = lum2a_lsun * (solarl * utime / unit_energ) - !secondary_lum_lsun = lum2a_lsun - call read_inopt(Teff2a,'Teff2a',db,errcount=nerr) - call read_inopt(Reff2a_au,'Reff2a',db,errcount=nerr) - Reff2a = Reff2a_au * au / udist - !secondary_Reff = Reff2a - call read_inopt(racc2a_au,'racc2a',db,errcount=nerr) - racc2a = racc2a_au * au / udist - endif - call read_inopt(secondary_mass_msun,'secondary_mass',db,min=0.,max=1000.,errcount=nerr) - secondary_mass = secondary_mass_msun * (solarm / umass) - call read_inopt(semi_major_axis_au,'semi_major_axis',db,min=0.,errcount=nerr) - semi_major_axis = semi_major_axis_au * au / udist - call read_inopt(eccentricity,'eccentricity',db,min=0.,errcount=nerr) - !-- masses - call read_inopt(q2,'q2',db,min=0.,max=1.,errcount=nerr) - !-- tight parameters - call read_inopt(binary2_a_au,'binary2_a',db,errcount=nerr) - binary2_a = binary2_a_au * au / udist - call read_inopt(binary2_e,'binary2_e',db,errcount=nerr) - !-- accretion radii,... - call read_inopt(racc2b_au,'racc2b',db,errcount=nerr) - racc2b = racc2b_au * au / udist - if (racc2b < tiny(0.)) then - print *,'WARNING: secondary accretion radius not defined' - !nerr = nerr+1 - endif - call read_inopt(lum2b_lsun,'lum2b',db,errcount=nerr) - lum2b = lum2b_lsun * (solarl * utime / unit_energ) - call read_inopt(Teff2b,'Teff2b',db,errcount=nerr) - call read_inopt(Reff2b_au,'Reff2b',db,errcount=nerr) - Reff2b = Reff2b_au * au / udist - call read_inopt(binary2_i,'inclination',db,errcount=nerr) - endif - - call read_inopt(default_particle_mass,'mass_of_particles',db,min=0.,errcount=nerr) - - if (isothermal) then - wind_gamma = 1. - call read_inopt(T_wind,'T_wind',db,min=0.,errcount=nerr) - if (iwind == 3) call read_inopt(temp_exponent,'temp_exponent',db,min=0.,max=5.,errcount=nerr) - else - call read_inopt(wind_gamma,'wind_gamma',db,min=1.,max=4.,errcount=nerr) - endif - call close_db(db) - ierr = nerr - call write_setupfile(filename) - -end subroutine read_setupfile - -end module setup diff --git a/src/tests/directsum.f90 b/src/tests/directsum.f90 index e79acc2cc..c99024b0c 100644 --- a/src/tests/directsum.f90 +++ b/src/tests/directsum.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module directsum ! diff --git a/src/tests/phantomtest.f90 b/src/tests/phantomtest.f90 index 2233c4967..dd310aa6f 100644 --- a/src/tests/phantomtest.f90 +++ b/src/tests/phantomtest.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantomtest ! diff --git a/src/tests/test_cooling.f90 b/src/tests/test_cooling.f90 index bf4d502bd..41db26289 100644 --- a/src/tests/test_cooling.f90 +++ b/src/tests/test_cooling.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testcooling ! diff --git a/src/tests/test_corotate.f90 b/src/tests/test_corotate.f90 index f42abe572..95d1d1b00 100644 --- a/src/tests/test_corotate.f90 +++ b/src/tests/test_corotate.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testcorotate ! diff --git a/src/tests/test_damping.f90 b/src/tests/test_damping.f90 index 14c2b9ac5..ca00a1b95 100644 --- a/src/tests/test_damping.f90 +++ b/src/tests/test_damping.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testdamping ! diff --git a/src/tests/test_derivs.F90 b/src/tests/test_derivs.F90 index 1f59eb848..4423158f5 100644 --- a/src/tests/test_derivs.F90 +++ b/src/tests/test_derivs.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testderivs ! diff --git a/src/tests/test_dust.f90 b/src/tests/test_dust.f90 index e89dfacd3..371059769 100644 --- a/src/tests/test_dust.f90 +++ b/src/tests/test_dust.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testdust ! diff --git a/src/tests/test_eos.f90 b/src/tests/test_eos.f90 index 6a6014b56..23a1372a7 100644 --- a/src/tests/test_eos.f90 +++ b/src/tests/test_eos.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testeos ! diff --git a/src/tests/test_eos_stratified.f90 b/src/tests/test_eos_stratified.f90 index a61ea477a..f8aaf1936 100644 --- a/src/tests/test_eos_stratified.f90 +++ b/src/tests/test_eos_stratified.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testeos_stratified ! diff --git a/src/tests/test_externf.f90 b/src/tests/test_externf.f90 index d2465227a..f6bb79410 100644 --- a/src/tests/test_externf.f90 +++ b/src/tests/test_externf.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testexternf ! diff --git a/src/tests/test_externf_gr.f90 b/src/tests/test_externf_gr.f90 index f1bf27461..ca7529063 100644 --- a/src/tests/test_externf_gr.f90 +++ b/src/tests/test_externf_gr.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testexternf ! diff --git a/src/tests/test_fastmath.F90 b/src/tests/test_fastmath.F90 deleted file mode 100644 index 76d7a2b0a..000000000 --- a/src/tests/test_fastmath.F90 +++ /dev/null @@ -1,162 +0,0 @@ -!--------------------------------------------------------------------------! -! 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.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module testmath -! -! This module performs unit tests of the fast sqrt routines -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: fastmath, io, mpiutils, random -! - implicit none - public :: test_math - - private - -contains - -subroutine test_math(ntests,npass,usefsqrt,usefinvsqrt) - use io, only:id,master - use fastmath, only:checksqrt,testsqrt,finvsqrt - use random, only:ran2 - use mpiutils, only:barrier_mpi - integer, intent(inout) :: ntests,npass - logical, intent(out) :: usefsqrt,usefinvsqrt - integer, parameter :: n = 1000000 - integer, parameter :: stderr = 0 - integer :: ierr,iseed,nerr,i - real, allocatable :: x(:),f(:),y(:) - real :: t1,t2,errmax,tnative - - if (id==master) write(*,"(a,/)") '--> TESTING FAST SQRT ROUTINES' - - usefsqrt = .true. - usefinvsqrt = .true. -! -!--check for errors first -! - call testsqrt(ierr,output=.false.) - if (ierr /= 0) then - ! report errors on any threads - write(*, "(a)") ' *** ERROR with fast sqrt on this architecture ***' - usefsqrt = .false. - usefinvsqrt = .false. - write(*,"(/,a,/)") '<-- FAST SQRT TEST FAILED' - return - endif - - allocate(x(n),f(n),y(n),stat=ierr) - if (ierr /= 0) return - - iseed = -5234 - do i=1,n - x(i) = ran2(iseed)*1.e8 - enddo - - ntests = ntests + 1 - nerr = 0 - do i=1,n - call checksqrt(x(i),5.e-7*x(i),ierr,.false.) - nerr = max(ierr,nerr) - enddo - if (nerr > 0) then - usefsqrt = .false. - usefinvsqrt = .false. - else - npass = npass + 1 - endif - -! -!--check timings for inverse sqrt -! - call cpu_time(t1) - do i=1,n - f(i) = 1./sqrt(x(i)) - enddo - call cpu_time(t2) - tnative = t2-t1 - if (id==master) write(*,"(a,es10.3,a)") ' native 1/sqrt done in ',tnative,' cpu-s' - y = f - - call barrier_mpi - - call cpu_time(t1) - do i=1,n - f(i) = finvsqrt(x(i)) - enddo - call cpu_time(t2) - - ! run tests on all threads, but only report detailed results on master thread - if (id==master) write(*,"(a,es10.3,a)") ' fast 1/sqrt done in ',t2-t1,' cpu-s' - - if ((t2-t1) > tnative) then - if (id==master) write(*,"(a,f4.1)") ' so finvsqrt(x) is SLOWER than 1/sqrt(x) by factor of ',& - (t2-t1)/tnative - usefinvsqrt = .false. - else - if (id==master) write(*,"(a,f4.1)") ' so finvsqrt(x) is FASTER than 1/sqrt(x) by factor of ', & - tnative/(t2-t1) - endif - - errmax = 0. - do i=1,n - errmax = max(errmax,abs(y(i) - f(i))/y(i)) - enddo - if (id==master) write(*,"(1x,a,es10.3)") 'max relative error is ',errmax - if (errmax > 1.e-7) usefinvsqrt = .false. - - if (id==master) write(*,*) - call barrier_mpi -! -!--check timings for sqrt -! - call cpu_time(t1) - do i=1,n - f(i) = sqrt(x(i)) - enddo - call cpu_time(t2) - tnative = t2-t1 - if (id==master) write(*,"(a,es10.3,a)") ' native sqrt done in ',tnative,' cpu-s' - y = f - call barrier_mpi - - call cpu_time(t1) - do i=1,n - f(i) = x(i)*finvsqrt(x(i)) - enddo - call cpu_time(t2) - if (id==master) write(*,"(a,es10.3,a)") ' x*finvsqrt(x) done in ',t2-t1,' cpu-s' - - if ((t2-t1) > tnative) then - if (id==master) write(*,"(a,f4.1)") ' so x*finvsqrt(x) is SLOWER than sqrt(x) by factor of ',& - (t2-t1)/tnative - usefsqrt = .false. - else - if (id==master) write(*,"(a,f4.1)") ' so x*finvsqrt(x) is FASTER than sqrt(x) by factor of ',tnative/(t2-t1) - endif - - errmax = 0. - do i=1,n - errmax = max(errmax,abs(y(i) - f(i))/(y(i) + epsilon(y))) - enddo - if (id==master) write(*,"(1x,a,es10.3)") 'max relative error is ',errmax - if (errmax > 1.e-7) usefinvsqrt = .false. - - if (allocated(x)) deallocate(x) - if (allocated(f)) deallocate(f) - if (allocated(y)) deallocate(y) - - if (id==master) write(*,"(/,a,/)") '<-- FAST SQRT TEST COMPLETE' - call barrier_mpi - -end subroutine test_math - -end module testmath diff --git a/src/tests/test_geometry.f90 b/src/tests/test_geometry.f90 index 91e66acbf..b32735f05 100644 --- a/src/tests/test_geometry.f90 +++ b/src/tests/test_geometry.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testgeometry ! diff --git a/src/tests/test_gnewton.f90 b/src/tests/test_gnewton.f90 index 19fd7b6ab..3dff7afa3 100644 --- a/src/tests/test_gnewton.f90 +++ b/src/tests/test_gnewton.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testgnewton ! diff --git a/src/tests/test_gr.F90 b/src/tests/test_gr.F90 deleted file mode 100644 index 5327c7042..000000000 --- a/src/tests/test_gr.F90 +++ /dev/null @@ -1,557 +0,0 @@ -!--------------------------------------------------------------------------! -! 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.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module testgr -! -! Unit tests of General Relativity -! -! :References: Liptai & Price (2019), MNRAS -! -! :Owner: David Liptai -! -! :Runtime parameters: None -! -! :Dependencies: cons2prim, cons2primsolver, eos, extern_gr, inverse4x4, -! io, metric, metric_tools, part, physcon, step_lf_global, testutils, -! units, utils_gr, vectorutils -! - use testutils, only:checkval,checkvalbuf,checkvalbuf_end,update_test_scores - implicit none - - public :: test_gr - - private - -contains -!----------------------------------------------------------------------- -!+ -! Unit tests for General Relativity -!+ -!----------------------------------------------------------------------- -subroutine test_gr(ntests,npass) - use io, only:id,master - use units, only:set_units - use physcon, only:solarm - integer, intent(inout) :: ntests,npass - - call set_units(mass=1.d6*solarm,G=1.d0,c=1.d0) - if (id==master) write(*,"(/,a,/)") '--> TESTING GENERAL RELATIVITY' - call test_combinations_all(ntests,npass) - call test_precession(ntests,npass) - call test_inccirc(ntests,npass) - if (id==master) write(*,"(/,a)") '<-- GR TESTS COMPLETE' - -end subroutine test_gr - -!----------------------------------------------------------------------- -!+ -! Test of orbital precession in the Kerr metric -!+ -!----------------------------------------------------------------------- -subroutine test_precession(ntests,npass) - use metric_tools, only:imetric,imet_kerr,imet_schwarzschild - use metric, only:a - integer, intent(inout) :: ntests,npass - integer :: nerr(6),norbits,nstepsperorbit - real :: dt,period,x0,vy0,tmax,angtol,postol - real :: angmom(3),angmom0(3),xyz(3),vxyz(3) - - write(*,'(/,a)') '--> testing step_extern_gr (precession)' - if (imetric /= imet_kerr .and. imetric /= imet_schwarzschild) then - write(*,'(/,a)') ' Skipping test! Metric is not Kerr (or Schwarzschild).' - return - endif - - a = 0. - x0 = 90. - vy0 = 0.0521157 - xyz = (/x0,0. ,0./) - vxyz = (/0.,vy0,0./) - period = 2390. ! approximate - norbits = 4 - tmax = norbits*period - nstepsperorbit = 1000 - dt = 0.239 !period/nstepsperorbit - - call integrate_geodesic(tmax,dt,xyz,vxyz,angmom0,angmom) - - angtol = 1.08e-15 - postol = 1.4e-5 - call checkval(angmom(1),angmom0(1),angtol,nerr(1),'error in angmomx') - call checkval(angmom(2),angmom0(2),angtol,nerr(2),'error in angmomy') - call checkval(angmom(3),angmom0(3),angtol,nerr(3),'error in angmomz') - call checkval(xyz(1), 77.606726748045929,postol,nerr(4),'error in final x position') - call checkval(xyz(2),-45.576259888019351,postol,nerr(5),'error in final y position') - call checkval(xyz(3),0.0 ,postol,nerr(6),'error in final z position') - - call update_test_scores(ntests,nerr,npass) - -end subroutine test_precession - -!----------------------------------------------------------------------- -!+ -! Test of inclined circular orbit in the Kerr metric -!+ -!----------------------------------------------------------------------- -subroutine test_inccirc(ntests,npass) - use physcon, only:pi - use metric_tools, only:imetric,imet_kerr - use metric, only:a - integer, intent(inout) :: ntests,npass - integer :: nerr(6),norbits,nstepsperorbit - real :: dt,period,tmax - real :: angmom(3),angmom0(3),xyz(3),vxyz(3) - real :: m,omega,phi,q,r,rdot,rho2,theta,thetadot,vx,vy,vz,x1,y1,z1 - real :: R2,rfinal - - write(*,'(/,a)') '--> testing step_extern_gr (inclined circular orbit)' - - if (imetric /= imet_kerr) then - write(*,'(/,a)') ' Skipping test! Metric is not Kerr.' - return - endif - - a = 1. - r = 10. - theta = 45.*pi/180. ! convert to radians - phi = 0. - m = 1. - q = sqrt(r**2 - a**2*cos(theta)**2) - rho2 = r**2 + a**2*cos(theta)**2 - omega = q*sqrt(m)/(sin(theta)*(rho2*sqrt(r)+a*q*sqrt(m)*sin(theta))) !shakura 1987 - rdot = 0. - thetadot = 0. - - ! Cartesian coordinates - x1 = sqrt(r**2+a**2)*sin(theta)*cos(phi) - y1 = sqrt(r**2+a**2)*sin(theta)*sin(phi) - z1 = r*cos(theta) - vx = r/sqrt(r**2+a**2)*sin(theta)*cos(phi)*rdot + sqrt(r**2+a**2)*(cos(theta)*cos(phi)*thetadot-sin(theta)*sin(phi)*omega) - vy = r/sqrt(r**2+a**2)*sin(theta)*sin(phi)*rdot + sqrt(r**2+a**2)*(cos(theta)*sin(phi)*thetadot+sin(theta)*cos(phi)*omega) - vz = cos(theta)*rdot-r*sin(theta)*thetadot - - xyz = (/x1,y1,z1/) - vxyz = (/vx,vy,vz/) - - period = 2390. ! approximate - norbits = 4 - tmax = norbits*period - nstepsperorbit = 1000 - dt = 0.239 !period/nstepsperorbit - - call integrate_geodesic(tmax,dt,xyz,vxyz,angmom0,angmom) - - R2 = dot_product(xyz,xyz) - rfinal = sqrt(0.5*(R2-a**2) + 0.5*sqrt((R2-a**2)**2 + 4.*a**2*xyz(3)**2)) - - nerr = 0 - call checkval(angmom(1),angmom0(1),6.e-10,nerr(1),'error in angmomx') - call checkval(angmom(2),angmom0(2),6.e-10,nerr(2),'error in angmomy') - call checkval(angmom(3),angmom0(3),6.e-10,nerr(3),'error in angmomz') - call checkval(rfinal ,r ,5.08e-6,nerr(4),'error in final r position') - - call update_test_scores(ntests,nerr,npass) - -end subroutine test_inccirc - -!----------------------------------------------------------------------- -!+ -! test the geodesic integrator using test particle integration -! and the step_extern_gr routine -!+ -!----------------------------------------------------------------------- -subroutine integrate_geodesic(tmax,dt,xyz,vxyz,angmom0,angmom) - use io, only:iverbose - use part, only:igas,npartoftype,massoftype,set_particle_type,get_ntypes,ien_type - use step_lf_global, only:step_extern_gr - use eos, only:ieos - use cons2prim, only:prim2consall - use metric_tools, only:init_metric,unpack_metric - use extern_gr, only:get_grforce_all - real, intent(in) :: tmax,dt - real, intent(inout) :: xyz(3), vxyz(3) - real, intent(out) :: angmom0(3),angmom(3) - integer :: nsteps,ntypes,npart - real :: time,dtextforce,massi,blah - real :: xyzh(4,1),vxyzu(4,1),fext(3,1),pxyzu(4,1),dens(1),metrics(0:3,0:3,2,1),metricderivs(0:3,0:3,3,1) - - npart = 1 - - xyzh = 0. - vxyzu = 0. - pxyzu = 0. - fext = 0. - metrics = 0. - metricderivs = 0. - - xyzh(1:3,1) = xyz(:) - vxyzu(1:3,1) = vxyz(:) - xyzh(4,:) = 1. - vxyzu(4,:) = 0. - massi = 1.e-10 - call set_particle_type(1,igas) - - npartoftype(igas) = npart - massoftype(igas) = massi - ntypes = get_ntypes(npartoftype) - - ! - ! initialise runtime parameters - ! - ieos = 11 - iverbose = 1 - time = 0 - blah = dt - ien_type = 1 - - call init_metric(npart,xyzh,metrics,metricderivs) - call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) - call get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtextforce) - call calculate_angmom(xyzh(1:3,1),metrics(:,:,:,1),massi,vxyzu(1:3,1),angmom0) - - nsteps = 0 - do while (time <= tmax) - nsteps = nsteps + 1 - time = time + dt - dtextforce = blah - call step_extern_gr(npart,ntypes,dt,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) - enddo - - call calculate_angmom(xyzh(1:3,1),metrics(:,:,:,1),massi,vxyzu(1:3,1),angmom) - - xyz(:) = xyzh(1:3,1) - vxyz(:) = vxyzu(1:3,1) - -end subroutine integrate_geodesic - -!----------------------------------------------------------------------- -!+ -! compute the angular momentum for the orbit -!+ -!----------------------------------------------------------------------- -subroutine calculate_angmom(xyzi,metrici,massi,vxyzi,angmomi) - use metric_tools, only:unpack_metric - use vectorutils, only:cross_product3D - use utils_gr, only:dot_product_gr - real, intent(in) :: xyzi(3),metrici(:,:,:),massi,vxyzi(3) - real, intent(out) :: angmomi(3) - real :: alpha_gr,beta_gr_UP(3),bigvi(3),fourvel_space(3),lorentzi,v2i,gammaijdown(3,3) - - call unpack_metric(metrici,betaUP=beta_gr_UP,alpha=alpha_gr,gammaijdown=gammaijdown) - bigvi = (vxyzi+beta_gr_UP)/alpha_gr - v2i = dot_product_gr(bigvi,bigvi,gammaijdown) - lorentzi = 1./sqrt(1.-v2i) - fourvel_space = (lorentzi/alpha_gr)*vxyzi - call cross_product3D(xyzi,fourvel_space,angmomi) ! position cross with four-velocity - angmomi=angmomi*massi - -end subroutine calculate_angmom - -!----------------------------------------------------------------------- -!+ -! Test various combinations of position, velocity and fluid quantities -!+ -!----------------------------------------------------------------------- -subroutine test_combinations_all(ntests,npass) - use eos, only:ieos - integer, intent(inout) :: ntests,npass - integer, parameter :: eos_to_test(2) = (/2,12/) - integer :: i - - do i = 1,size(eos_to_test) - ieos = eos_to_test(i) - call test_combinations(ntests,npass) - enddo - -end subroutine test_combinations_all - -!----------------------------------------------------------------------- -!+ -! Test various combinations of position, velocity and fluid quantities -!+ -!----------------------------------------------------------------------- -subroutine test_combinations(ntests,npass) - use physcon, only:pi - use eos, only:gamma,equationofstate,ieos - use utils_gr, only:dot_product_gr - use metric_tools, only:get_metric,get_metric_derivs,imetric,imet_kerr - use metric, only:metric_type - integer, intent(inout) :: ntests,npass - real :: radii(5),theta(5),phi(5),vx(5),vy(5),vz(5) - real :: utherm(7),density(7),errmax,errmaxg,errmaxc,errmaxd - real :: position(3),v(3),v4(0:3),sqrtg,gcov(0:3,0:3),gcon(0:3,0:3) - real :: ri,thetai,phii,vxi,vyi,vzi,x,y,z,p,t,dens,u,pondens,spsound - real :: dgdx1(0:3,0:3),dgdx2(0:3,0:3),dgdx3(0:3,0:3) - integer :: i,j,k,l,m,n,ii,jj - integer :: ncheck_metric,nfail_metric,ncheck_cons2prim,nfail_cons2prim - integer :: ncheckg,nfailg,ncheckd,nfaild - real, parameter :: tol = 2.e-15 - real, parameter :: tolc = 1.e-12 - real, parameter :: told = 4.e-7 - - write(*,'(/,a)') '--> testing metric and cons2prim with combinations of variables' - write(*,'(a)') ' metric type = '//trim(metric_type) - write(*,'(a,I4,/)') ' eos = ', ieos - - ntests = ntests + 4 - ncheck_metric = 0 - nfail_metric = 0 - ncheckg = 0 - nfailg = 0 - ncheck_cons2prim = 0 - nfail_cons2prim = 0 - ncheckd = 0 - nfaild = 0 - errmax = 0. - errmaxg = 0. - errmaxc = 0. - errmaxd = 0. - - ! ieos=12 - gamma = 5./3. - - radii = (/2.1,2.5,3.0,5.0,10.0/) - theta = (/0.,pi/4.,pi/2.,3.*pi/4.,pi/) - phi = (/0.,pi/4.,pi/2.,pi,3.*pi/2./) - - vx = (/0.,0.25,0.5,0.75,1./) - vy = vx - vz = vx - - utherm = (/1.e-3,1.,10.,100.,1000.,1.e5,1.e7/) - density = (/1.e-10,1.e-5,1.e-3,1.,10.,100.,1000./) - - t = -1. ! initial temperature guess to avoid complier warning - - do i=1,size(radii) - ri = radii(i) - do j=1,size(theta) - thetai = theta(j) - do k=1,size(phi) - phii = phi(k) - x = ri*sin(thetai)*cos(phii) - y = ri*sin(thetai)*sin(phii) - z = ri*cos(thetai) - position = (/x,y,z/) - - call get_metric(position,gcov,gcon,sqrtg) - call test_metric_i(gcov,gcon,sqrtg,ncheck_metric,nfail_metric,errmax,ncheckg,nfailg,errmaxg,tol) - - ! Check below is because Kerr metric derivatives currently badly behaved at the poles - ! Would be nice to remove this... - if ((imetric /= imet_kerr) .or. (x**2 + y**2 > 1.e-12)) then - call get_metric_derivs(position,dgdx1,dgdx2,dgdx3) - call test_metric_derivs_i(position,dgdx1,dgdx2,dgdx3,ncheckd,nfaild,errmaxd,told) - endif - - do l=1,size(vx) - vxi=vx(l) - do m=1,size(vy) - vyi=vy(m) - do n=1,size(vz) - vzi=vz(n) - - v = (/vxi,vyi,vzi/) - v4(0) = 1. - v4(1:3) = v(:) - - ! Only allow valid combinations of position and velocity to be tested. - ! i.e. Not faster than the speed of light locally (U0 real, not imaginary). - if (dot_product_gr(v4,v4,gcov) < 0.) then - do ii=1,size(utherm) - u = utherm(ii) - do jj=1,size(density) - dens = density(jj) - call equationofstate(ieos,pondens,spsound,dens,x,y,z,t,u) - p = pondens*dens - call test_cons2prim_i(position,v,dens,u,p,ncheck_cons2prim,nfail_cons2prim,errmaxc,tolc) - enddo - enddo - endif - - enddo - enddo - enddo - enddo - enddo - enddo - - call checkvalbuf_end('inv * metric = identity',ncheck_metric,nfail_metric,errmax,tol) - call checkvalbuf_end('sqrt g = -det(g)',ncheckg,nfailg,errmaxg,tol) - call checkvalbuf_end('d/dx^i g_munu',ncheckd,nfaild,errmaxd,told) - call checkvalbuf_end('conservative to primitive',ncheck_cons2prim,nfail_cons2prim,errmaxc,tolc) - if (nfail_metric==0) npass = npass + 1 - if (nfailg==0) npass = npass + 1 - if (nfaild==0) npass = npass + 1 - if (nfail_cons2prim==0) npass = npass + 1 - -end subroutine test_combinations - -!---------------------------------------------------------------- -!+ -! Test of the metric -!+ -!---------------------------------------------------------------- -subroutine test_metric_i(gcov,gcon,sqrtg,ncheck,nfail,errmax,ncheckg,nfailg,errmaxg,tol) - use inverse4x4, only:inv4x4 - integer, intent(inout) :: ncheck,nfail,ncheckg,nfailg - real, intent(in) :: gcov(0:3,0:3),gcon(0:3,0:3),sqrtg,tol - real, intent(inout) :: errmax,errmaxg - real, dimension(0:3,0:3) :: gg - real :: sum,det - integer :: i,j - - ! Product of metric and its inverse - gg = 0. - gg = matmul(gcov,gcon) - sum = 0 - do j=0,3 - do i=0,3 - sum = sum + gg(i,j) - enddo - enddo - - ! Check to see that the product is 4 (trace of identity) - call checkvalbuf(sum,4.,tol,'[F]: gddgUU ',nfail,ncheck,errmax) - - !if (nfail /= 0) then - ! print*,' metric ' - ! print "(4(es10.3,1x))",gcov - ! print*,' inverse ' - ! print "(4(es10.3,1x))",gcon - ! print*,' gg ' - ! print "(4(es10.3,1x))",gg - ! print*, 'gdown*gup /= Identity' - !endif - - ! Check that the determinant of the metric matches the one returned - call inv4x4(gcov,gg,det) - call checkvalbuf(-det,sqrtg,tol,'sqrt(g) ',nfailg,ncheckg,errmaxg) - -end subroutine test_metric_i - -!---------------------------------------------------------------- -!+ -! Check that analytic metric derivs give similar answer to -! numerical differences of the metric -!+ -!---------------------------------------------------------------- -subroutine test_metric_derivs_i(x,dgdx1,dgdx2,dgdx3,ncheck,nfail,errmax,tol) - use metric_tools, only:numerical_metric_derivs - real, intent(in) :: x(1:3),dgdx1(0:3,0:3),dgdx2(0:3,0:3),dgdx3(0:3,0:3),tol - integer, intent(inout) :: ncheck,nfail - real, intent(inout) :: errmax - real :: dgdx_1(0:3,0:3),dgdx_2(0:3,0:3),dgdx_3(0:3,0:3) - integer :: j,i - - call numerical_metric_derivs(x,dgdx_1,dgdx_2,dgdx_3) - do j=0,3 - do i=0,3 - call checkvalbuf(dgdx1(i,j),dgdx_1(i,j),tol,'dgcov/dx',nfail,ncheck,errmax) - call checkvalbuf(dgdx2(i,j),dgdx_2(i,j),tol,'dgcov/dy',nfail,ncheck,errmax) - call checkvalbuf(dgdx3(i,j),dgdx_3(i,j),tol,'dgcov/dz',nfail,ncheck,errmax) - enddo - enddo - -end subroutine test_metric_derivs_i - -!---------------------------------------------------------------- -!+ -! Test of the conservative to primitive variable solver -!+ -!---------------------------------------------------------------- -subroutine test_cons2prim_i(x,v,dens,u,p,ncheck,nfail,errmax,tol) - use cons2primsolver, only:conservative2primitive,primitive2conservative - 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 - - real, intent(in) :: x(1:3),v(1:3),dens,p,tol - real, intent(inout) :: u - integer, intent(inout) :: ncheck,nfail - real, intent(inout) :: errmax - real :: metrici(0:3,0:3,2) - real :: rho2,pmom2(1:3),en2,temp - real :: p2,u2,t2,dens2,gamma2,v2(1:3) - real :: pondens2,spsound2 - real :: v_out(1:3),dens_out,u_out,p_out,gamma_out - real :: toli - integer :: ierr,i,j,nfailprev,ien_type - real, parameter :: tolg = 1.e-7, tolp = 1.5e-6 - - ! perturb the state - dens2 = 2.*dens - u2 = 2.*u - t2 = -1. - - call equationofstate(ieos,pondens2,spsound2,dens2,x(1),x(2),x(3),t2,u2) - P2 = pondens2 * dens2 - v2 = v - - over_energy_variables: do i = 1,3 - ! Used for initial guess in conservative2primitive - v_out = v - dens_out = dens - u_out = u - p_out = p - gamma_out = 1. + p/(dens*u) - errmax = 0. - nfailprev = nfail - temp = 1.e7 ! arbitrary initial guess - gamma2 = 1. + P2/(dens2*u2) - - call pack_metric(x,metrici) - if (ieos == 12 .and. i /= 3) then - ! entropy_K and etotal cannot use with gasplusrad eos - cycle - elseif (i == 1) then - ien_type = ien_entropy - toli = 1.5e-11 - elseif (i == 2) then - ien_type = ien_etotal - toli = 1.5e-9 - else - ien_type = ien_entropy_s - toli = 1.5e-11 - endif - - call primitive2conservative(x,metrici,v,dens2,u2,P2,rho2,pmom2,en2,ien_type) - call conservative2primitive(x,metrici,v_out,dens_out,u_out,p_out,temp,gamma_out,rho2,pmom2,en2,ierr,ien_type) - - call checkvalbuf(ierr,0,0,'[F]: ierr (convergence)',nfail,ncheck) - do j=1,3 - call checkvalbuf(v_out(j),v2(j),toli,'[F]: v_out',nfail,ncheck,errmax) - enddo - call checkvalbuf(dens_out,dens2,toli,'[F]: dens_out',nfail,ncheck,errmax) - call checkvalbuf(u_out,u2,toli,'[F]: u_out',nfail,ncheck,errmax) - call checkvalbuf(p_out,p2,tolp,'[F]: p_out',nfail,ncheck,errmax) - call checkvalbuf(gamma_out,gamma2,tolg,'[F]: gamma_out',nfail,ncheck,errmax) - - if (nfail > nfailprev .and. nfail < 10) then - print*,'-- cons2prim test failed with' - print*,' ien_type =',ien_type - print*,' ieos =',ieos - print*,' - IN:' - print*,' x =',x - print*,' v =',v2 - print*,' dens =',dens2 - print*,' u =',u2 - print*,' p =',p2 - print*,' gamma=',gamma2 - print*,' - OUT:' - print*,' v =',v_out - print*,' dens =',dens_out - print*,' u =',u_out - print*,' p =',p_out - print*,' gamma=',gamma_out - print*,'' - endif - enddo over_energy_variables - -end subroutine test_cons2prim_i - -end module testgr diff --git a/src/tests/test_gravity.F90 b/src/tests/test_gravity.F90 deleted file mode 100644 index 196d998b5..000000000 --- a/src/tests/test_gravity.F90 +++ /dev/null @@ -1,642 +0,0 @@ -!--------------------------------------------------------------------------! -! 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.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module testgravity -! -! Unit tests of self-gravity -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: deriv, dim, directsum, energies, eos, io, kdtree, -! linklist, mpibalance, mpiutils, options, part, physcon, ptmass, -! sort_particles, spherical, testutils, timing -! - use io, only:id,master - implicit none - public :: test_gravity - - private - -contains -!----------------------------------------------------------------------- -!+ -! Unit tests for Newtonian gravity (i.e. Poisson solver) -!+ -!----------------------------------------------------------------------- -subroutine test_gravity(ntests,npass,string) - use dim, only:gravity - integer, intent(inout) :: ntests,npass - character(len=*), intent(in) :: string - logical :: testdirectsum,testpolytrope,testtaylorseries,testall - - testdirectsum = .false. - testtaylorseries = .false. - testpolytrope = .false. - testall = .false. - select case(string) - case('taylorseries') - testtaylorseries = .true. - case('directsum') - testdirectsum = .true. - case('polytrope') - testpolytrope = .true. - case default - testall = .true. - end select - - if (gravity) then - if (id==master) write(*,"(/,a,/)") '--> TESTING SELF-GRAVITY' - ! - !--unit test of Taylor series expansions in the treecode - ! - if (testtaylorseries .or. testall) call test_taylorseries(ntests,npass) - ! - !--unit tests of treecode gravity by direct summation - ! - if (testdirectsum .or. testall) call test_directsum(ntests,npass) - - if (id==master) write(*,"(/,a)") '<-- SELF-GRAVITY TESTS COMPLETE' - else - if (id==master) write(*,"(/,a)") '--> SKIPPING SELF-GRAVITY TESTS (need -DGRAVITY)' - endif - -end subroutine test_gravity - -!----------------------------------------------------------------------- -!+ -! Unit tests of the Taylor series expansion about local and distant nodes -!+ -!----------------------------------------------------------------------- -subroutine test_taylorseries(ntests,npass) - use kdtree, only:compute_fnode,expand_fgrav_in_taylor_series - use testutils, only:checkval,update_test_scores - integer, intent(inout) :: ntests,npass - integer :: nfailed(18),i,npnode - real :: xposi(3),xposj(3),x0(3),dx(3),fexact(3),f0(3) - real :: xposjd(3,3),dfdx_approx(3,3),d2f(3,3),dpot(3) - real :: fnode(20),quads(6) - real :: dr,dr2,phi,phiexact,pmassi,tol,totmass - - if (id==master) write(*,"(/,a)") '--> testing taylor series expansion about current node' - totmass = 5. - xposi = (/0.05,-0.04,-0.05/) ! position to evaluate the force at - xposj = (/1., 1., 1./) ! position of distant node - x0 = 0. ! position of nearest node centre - - call get_dx_dr(xposi,xposj,dx,dr) - fexact = -totmass*dr**3*dx ! exact force between i and j - phiexact = -totmass*dr ! exact potential between i and j - - call get_dx_dr(x0,xposj,dx,dr) - fnode = 0. - quads = 0. - call compute_fnode(dx(1),dx(2),dx(3),dr,totmass,quads,fnode) - - dx = xposi - x0 ! perform expansion about x0 - call expand_fgrav_in_taylor_series(fnode,dx(1),dx(2),dx(3),f0(1),f0(2),f0(3),phi) - !print*,' exact force = ',fexact,' phi = ',phiexact - !print*,' force at origin = ',fnode(1:3), ' phi = ',fnode(20) - !print*,'force w. taylor series = ',f0, ' phi = ',phi - nfailed(:) = 0 - call checkval(f0(1),fexact(1),3.e-4,nfailed(1),'fx taylor series about f0') - call checkval(f0(2),fexact(2),1.1e-4,nfailed(2),'fy taylor series about f0') - call checkval(f0(3),fexact(3),9.e-5,nfailed(3),'fz taylor series about f0') - call checkval(phi,phiexact,8.e-4,nfailed(4),'phi taylor series about f0') - call update_test_scores(ntests,nfailed,npass) - - if (id==master) write(*,"(/,a)") '--> testing taylor series expansion about distant node' - totmass = 5. - npnode = 3 - xposjd(:,1) = (/1.03, 0.98, 1.01/) ! position of distant particle 1 - xposjd(:,2) = (/0.95, 1.01, 1.03/) ! position of distant particle 2 - xposjd(:,3) = (/0.99, 0.95, 0.95/) ! position of distant particle 3 - xposj = 0. - pmassi = totmass/real(npnode) - do i=1,npnode - xposj = xposj + pmassi*xposjd(:,i) ! centre of mass of distant node - enddo - xposj = xposj/totmass - !print*,' centre of mass of distant node = ',xposj - !--compute quadrupole moments - quads = 0. - do i=1,npnode - dx(:) = xposjd(:,i) - xposj - dr2 = dot_product(dx,dx) - quads(1) = quads(1) + pmassi*(3.*dx(1)*dx(1) - dr2) - quads(2) = quads(2) + pmassi*(3.*dx(1)*dx(2)) - quads(3) = quads(3) + pmassi*(3.*dx(1)*dx(3)) - quads(4) = quads(4) + pmassi*(3.*dx(2)*dx(2) - dr2) - quads(5) = quads(5) + pmassi*(3.*dx(2)*dx(3)) - quads(6) = quads(6) + pmassi*(3.*dx(3)*dx(3) - dr2) - enddo - - x0 = 0. ! position of nearest node centre - xposi = x0 ! position to evaluate the force at - fexact = 0. - phiexact = 0. - do i=1,npnode - dx = xposi - xposjd(:,i) - dr = 1./sqrt(dot_product(dx,dx)) - fexact = fexact - dr**3*dx ! exact force between i and j - phiexact = phiexact - dr ! exact force between i and j - enddo - fexact = fexact*pmassi - phiexact = phiexact*pmassi - - call get_dx_dr(x0,xposj,dx,dr) - fnode = 0. - call compute_fnode(dx(1),dx(2),dx(3),dr,totmass,quads,fnode) - - dx = xposi - x0 ! perform expansion about x0 - call expand_fgrav_in_taylor_series(fnode,dx(1),dx(2),dx(3),f0(1),f0(2),f0(3),phi) - !print*,' exact force = ',fexact,' phi = ',phiexact - !print*,' force at origin = ',fnode(1:3), ' phi = ',fnode(20) - !print*,'force w. taylor series = ',f0, ' phi = ',phi - nfailed(:) = 0 - call checkval(f0(1),fexact(1),8.7e-5,nfailed(1),'fx taylor series about f0') - call checkval(f0(2),fexact(2),1.5e-6,nfailed(2),'fy taylor series about f0') - call checkval(f0(3),fexact(3),1.6e-5,nfailed(3),'fz taylor series about f0') - call checkval(phi,phiexact,5.9e-6,nfailed(4),'phi taylor series about f0') - call update_test_scores(ntests,nfailed,npass) - - if (id==master) write(*,"(/,a)") '--> checking results of compute_fnode routine' - ! - ! check that components of fnode are derivatives of each other - ! - tol = 1.e-6 - call get_finite_diff(3,x0,xposj,totmass,quads,fnode,dfdx_approx,dpot,d2f,tol) - nfailed(:) = 0 - call checkval(fnode(1),dpot(1),tol,nfailed(1),'fx=-dphi/dx') - call checkval(fnode(2),dpot(2),tol,nfailed(2),'fy=-dphi/dy') - call checkval(fnode(3),dpot(3),tol,nfailed(3),'fz=-dphi/dz') - call checkval(fnode(4),dfdx_approx(1,1),tol,nfailed(4),'dfx/dx') - call checkval(fnode(5),dfdx_approx(1,2),tol,nfailed(5),'dfx/dy') - call checkval(fnode(6),dfdx_approx(1,3),tol,nfailed(6),'dfx/dz') - call checkval(fnode(7),dfdx_approx(2,2),tol,nfailed(7),'dfy/dy') - call checkval(fnode(8),dfdx_approx(2,3),tol,nfailed(8),'dfx/dz') - call checkval(fnode(9),dfdx_approx(3,3),tol,nfailed(9),'dfz/dz') - call checkval(fnode(10),d2f(1,1),1.e-3,nfailed(10),'d^2fx/dx^2') - call checkval(fnode(13),d2f(1,2),1.1e-3,nfailed(11),'d^2fx/dy^2') - call checkval(fnode(15),d2f(1,3),1.e-3,nfailed(12),'d^2fx/dz^2') - call checkval(fnode(11),d2f(2,1),1.e-3,nfailed(13),'d^2fy/dx^2') - call checkval(fnode(16),d2f(2,2),1.e-3,nfailed(14),'d^2fy/dy^2') - call checkval(fnode(18),d2f(2,3),1.e-3,nfailed(15),'d^2fy/dz^2') - call checkval(fnode(12),d2f(3,1),1.e-3,nfailed(16),'d^2fz/dx^2') - call checkval(fnode(17),d2f(3,2),1.2e-3,nfailed(17),'d^2fz/dy^2') - call checkval(fnode(19),d2f(3,3),1.e-3,nfailed(18),'d^2fz/dz^2') - call update_test_scores(ntests,nfailed,npass) - - if (id==master) write(*,"(/,a)") '--> testing taylor series expansion about both current and distant nodes' - x0 = 0. ! position of nearest node centre - xposi = (/0.05,0.05,-0.05/) ! position to evaluate the force at - fexact = 0. - phiexact = 0. - do i=1,npnode - dx = xposi - xposjd(:,i) - dr = 1./sqrt(dot_product(dx,dx)) - fexact = fexact - dr**3*dx ! exact force between i and j - phiexact = phiexact - dr ! exact force between i and j - enddo - fexact = fexact*pmassi - phiexact = phiexact*pmassi - - dx = x0 - xposj - dr = 1./sqrt(dot_product(dx,dx)) ! compute approx force between node and j - fnode = 0. - call compute_fnode(dx(1),dx(2),dx(3),dr,totmass,quads,fnode) - - dx = xposi - x0 ! perform expansion about x0 - call expand_fgrav_in_taylor_series(fnode,dx(1),dx(2),dx(3),f0(1),f0(2),f0(3),phi) - !print*,' exact force = ',fexact,' phi = ',phiexact - !print*,' force at origin = ',fnode(1:3), ' phi = ',fnode(20) - !print*,'force w. taylor series = ',f0, ' phi = ',phi - nfailed(:) = 0 - call checkval(f0(1),fexact(1),4.3e-5,nfailed(1),'fx taylor series about f0') - call checkval(f0(2),fexact(2),1.4e-4,nfailed(2),'fy taylor series about f0') - call checkval(f0(3),fexact(3),3.2e-4,nfailed(3),'fz taylor series about f0') - call checkval(phi,phiexact,9.7e-4,nfailed(4),'phi taylor series about f0') - call update_test_scores(ntests,nfailed,npass) - -end subroutine test_taylorseries - -!----------------------------------------------------------------------- -!+ -! Unit tests of the tree code gravity, checking it agrees with -! gravity computed via direct summation -!+ -!----------------------------------------------------------------------- -subroutine test_directsum(ntests,npass) - use io, only:id,master - use dim, only:maxp,maxptmass,mpi - 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 - use eos, only:polyk,gamma - use options, only:ieos,alpha,alphau,alphaB,tolh - use spherical, only:set_sphere - use deriv, only:get_derivs_global - use physcon, only:pi - use timing, only:getused,printused - use directsum, only:directsum_grav - use energies, only:compute_energies,epot - use kdtree, only:tree_accuracy - use testutils, only:checkval,checkvalbuf_end,update_test_scores - use ptmass, only:get_accel_sink_sink,get_accel_sink_gas,h_soft_sinksink - use mpiutils, only:reduceall_mpi,bcast_mpi - use linklist, only:set_linklist - use sort_particles, only:sort_part_id - use mpibalance, only:balancedomains - - integer, intent(inout) :: ntests,npass - integer :: nfailed(18) - integer :: maxvxyzu,nx,np,i,k,merge_n,merge_ij(maxptmass),nfgrav - real :: psep,totvol,totmass,rhozero,tol,pmassi - real :: time,rmin,rmax,phitot,dtsinksink,fonrmax,phii,epot_gas_sink - real(kind=4) :: t1,t2 - real :: epoti,tree_acc_prev - real, allocatable :: fgrav(:,:),fxyz_ptmass_gas(:,:) - - maxvxyzu = size(vxyzu(:,1)) - tree_acc_prev = tree_accuracy - do k = 1,6 - if (labeltype(k)/='bound') then - if (id==master) write(*,"(/,3a)") '--> testing gravity force in densityforce for ',labeltype(k),' particles' -! -!--general parameters -! - time = 0. - hfact = 1.2 - gamma = 5./3. - rmin = 0. - rmax = 1. - ieos = 2 - tree_accuracy = 0.5 -! -!--setup particles -! - call init_part() - np = 1000 - totvol = 4./3.*pi*rmax**3 - nx = int(np**(1./3.)) - psep = totvol**(1./3.)/real(nx) - psep = 0.18 - npart = 0 - ! only set up particles on master, otherwise we will end up with n duplicates - if (id==master) then - call set_sphere('cubic',id,master,rmin,rmax,psep,hfact,npart,xyzh) - endif - np = npart -! -!--set particle properties -! - totmass = 1. - rhozero = totmass/totvol - npartoftype(:) = 0 - npartoftype(k) = int(reduceall_mpi('+',npart),kind=kind(npartoftype)) - massoftype(:) = 0.0 - massoftype(k) = totmass/npartoftype(k) - if (maxphase==maxp) then - do i=1,npart - iphase(i) = isetphase(k,iactive=.true.) - enddo - endif -! -!--set thermal terms and velocity to zero, so only force is gravity -! - polyk = 0. - vxyzu(:,:) = 0. -! -!--make sure AV is off -! - alpha = 0. - alphau = 0. - alphaB = 0. - tolh = 1.e-5 - - fxyzu = 0.0 -! -!--call derivs to get everything initialised -! - call get_derivs_global() -! -!--reset force to zero -! - fxyzu = 0.0 -! -!--move particles to master and sort for direct summation -! - if (mpi) then - ibelong(:) = 0 - call balancedomains(npart) - endif - call sort_part_id -! -!--allocate array for storing direct sum gravitational force -! - allocate(fgrav(maxvxyzu,npart)) - fgrav = 0.0 -! -!--compute gravitational forces by direct summation -! - if (id == master) then - call directsum_grav(xyzh,gradh,fgrav,phitot,npart) - endif -! -!--send phitot to all tasks -! - call bcast_mpi(phitot) -! -!--calculate derivatives -! - call getused(t1) - call get_derivs_global() - call getused(t2) - if (id==master) call printused(t1) -! -!--move particles to master and sort for test comparison -! - if (mpi) then - ibelong(:) = 0 - call balancedomains(npart) - endif - call sort_part_id -! -!--compare the results -! - call checkval(npart,fxyzu(1,:),fgrav(1,:),5.e-3,nfailed(1),'fgrav(x)') - call checkval(npart,fxyzu(2,:),fgrav(2,:),6.e-3,nfailed(2),'fgrav(y)') - call checkval(npart,fxyzu(3,:),fgrav(3,:),9.4e-3,nfailed(3),'fgrav(z)') - deallocate(fgrav) - epoti = 0. - do i=1,npart - epoti = epoti + poten(i) - enddo - epoti = reduceall_mpi('+',epoti) - call checkval(epoti,phitot,5.2e-4,nfailed(4),'potential') - call checkval(epoti,-3./5.*totmass**2/rmax,3.6e-2,nfailed(5),'potential=-3/5 GMM/R') - ! check that potential energy computed via compute_energies is also correct - call compute_energies(0.) - call checkval(epot,phitot,5.2e-4,nfailed(6),'epot in compute_energies') - call update_test_scores(ntests,nfailed(1:6),npass) - endif - enddo - - -!--test that the same results can be obtained from a cloud of sink particles -! with softening lengths equal to the original SPH particle smoothing lengths -! - if (maxptmass >= npart) then - if (id==master) write(*,"(/,3a)") '--> testing gravity in uniform cloud of softened sink particles' -! -!--move particles to master for sink creation -! - if (mpi) then - ibelong(:) = 0 - call balancedomains(npart) - endif -! -!--sort particles so that they can be compared at the end -! - call sort_part_id - - pmassi = totmass/reduceall_mpi('+',npart) - call copy_gas_particles_to_sinks(npart,nptmass,xyzh,xyzmh_ptmass,pmassi) - h_soft_sinksink = hfact*psep -! -!--compute direct sum for comparison, but with fixed h and hence gradh terms switched off -! - do i=1,npart - xyzh(4,i) = h_soft_sinksink - gradh(1,i) = 1. - gradh(2,i) = 0. - vxyzu(:,i) = 0. - enddo - allocate(fgrav(maxvxyzu,npart)) - fgrav = 0.0 - call directsum_grav(xyzh,gradh,fgrav,phitot,npart) - call bcast_mpi(phitot) -! -!--compute gravity on the sink particles -! - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epoti,& - dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) - call bcast_mpi(epoti) -! -!--compare the results -! - tol = 1.e-14 - call checkval(npart,fxyz_ptmass(1,:),fgrav(1,:),tol,nfailed(1),'fgrav(x)') - call checkval(npart,fxyz_ptmass(2,:),fgrav(2,:),tol,nfailed(2),'fgrav(y)') - call checkval(npart,fxyz_ptmass(3,:),fgrav(3,:),tol,nfailed(3),'fgrav(z)') - call checkval(epoti,phitot,8e-3,nfailed(4),'potential') - call checkval(epoti,-3./5.*totmass**2/rmax,4.1e-2,nfailed(5),'potential=-3/5 GMM/R') - call update_test_scores(ntests,nfailed(1:5),npass) - - -! -!--now perform the same test, but with HALF the cloud made of sink particles -! and HALF the cloud made of gas particles. Do not re-evaluate smoothing lengths -! so that the results should be identical to the previous test -! - if (id==master) write(*,"(/,3a)") & - '--> testing softened gravity in uniform sphere with half sinks and half gas' - -!--sort the particles by ID so that the first half will have the same order -! even after half the particles have been converted into sinks. This sort is -! not really necessary because the order shouldn't have changed since the -! last test because derivs hasn't been called since. - call sort_part_id - call copy_half_gas_particles_to_sinks(npart,nptmass,xyzh,xyzmh_ptmass,pmassi) - - print*,' Using ',npart,' SPH particles and ',nptmass,' point masses' - call get_derivs_global() - - epoti = 0.0 - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epoti,& - dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) -! -!--prevent double counting of sink contribution to potential due to MPI -! - if (id /= master) epoti = 0.0 -! -!--allocate an array for the gas contribution to sink acceleration -! - allocate(fxyz_ptmass_gas(size(fxyz_ptmass,dim=1),nptmass)) - fxyz_ptmass_gas = 0.0 - - epot_gas_sink = 0.0 - do i=1,npart - call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - xyzmh_ptmass,fxyzu(1,i),fxyzu(2,i),fxyzu(3,i),& - phii,pmassi,fxyz_ptmass_gas,dsdt_ptmass,fonrmax,dtsinksink) - epot_gas_sink = epot_gas_sink + pmassi*phii - epoti = epoti + poten(i) - enddo -! -!--the gas contribution to sink acceleration has to be added afterwards to -! prevent double counting the sink contribution when calling reduceall_mpi -! - fxyz_ptmass_gas = reduceall_mpi('+',fxyz_ptmass_gas) - fxyz_ptmass(:,1:nptmass) = fxyz_ptmass(:,1:nptmass) + fxyz_ptmass_gas(:,1:nptmass) - deallocate(fxyz_ptmass_gas) -! -!--sum up potentials across MPI tasks -! - epoti = reduceall_mpi('+',epoti) - epot_gas_sink = reduceall_mpi('+',epot_gas_sink) - -! -!--move particles to master for comparison -! - if (mpi) then - ibelong(:) = 0 - call balancedomains(npart) - endif - call sort_part_id - - call checkval(npart,fxyzu(1,:),fgrav(1,:),5.e-2,nfailed(1),'fgrav(x)') - call checkval(npart,fxyzu(2,:),fgrav(2,:),6.e-2,nfailed(2),'fgrav(y)') - call checkval(npart,fxyzu(3,:),fgrav(3,:),9.4e-2,nfailed(3),'fgrav(z)') - -! -!--fgrav doesn't exist on worker tasks, so it needs to be sent from master -! - call bcast_mpi(npart) - if (id == master) nfgrav = size(fgrav,dim=2) - call bcast_mpi(nfgrav) - if (id /= master) then - deallocate(fgrav) - allocate(fgrav(maxvxyzu,nfgrav)) - endif - call bcast_mpi(fgrav) - - call checkval(nptmass,fxyz_ptmass(1,:),fgrav(1,npart+1:2*npart),2.3e-2,nfailed(4),'fgrav(xsink)') - call checkval(nptmass,fxyz_ptmass(2,:),fgrav(2,npart+1:2*npart),2.9e-2,nfailed(5),'fgrav(ysink)') - call checkval(nptmass,fxyz_ptmass(3,:),fgrav(3,npart+1:2*npart),3.7e-2,nfailed(6),'fgrav(zsink)') - - call checkval(epoti+epot_gas_sink,phitot,8e-3,nfailed(7),'potential') - call checkval(epoti+epot_gas_sink,-3./5.*totmass**2/rmax,4.1e-2,nfailed(8),'potential=-3/5 GMM/R') - call update_test_scores(ntests,nfailed(1:8),npass) - deallocate(fgrav) - endif -! -!--clean up doggie-doos -! - npartoftype(:) = 0 - massoftype(:) = 0. - tree_accuracy = tree_acc_prev - fxyzu = 0. - vxyzu = 0. - -end subroutine test_directsum - -subroutine copy_gas_particles_to_sinks(npart,nptmass,xyzh,xyzmh_ptmass,massi) - integer, intent(in) :: npart - integer, intent(out) :: nptmass - real, intent(in) :: xyzh(:,:),massi - real, intent(out) :: xyzmh_ptmass(:,:) - integer :: i - - nptmass = npart - do i=1,npart - ! make a sink particle with the position of each SPH particle - xyzmh_ptmass(1:3,i) = xyzh(1:3,i) - xyzmh_ptmass(4,i) = massi ! same mass as SPH particles - xyzmh_ptmass(5:,i) = 0. - enddo - -end subroutine copy_gas_particles_to_sinks - -subroutine copy_half_gas_particles_to_sinks(npart,nptmass,xyzh,xyzmh_ptmass,massi) - use io, only: id,master,fatal - use mpiutils, only: bcast_mpi - integer, intent(inout) :: npart - integer, intent(out) :: nptmass - real, intent(in) :: xyzh(:,:),massi - real, intent(out) :: xyzmh_ptmass(:,:) - integer :: i, nparthalf - - nptmass = 0 - nparthalf = npart/2 - - call bcast_mpi(nparthalf) - - if (id==master) then - ! Assuming all gas particles are already on master, - ! create sinks here and send them to other tasks - - ! remove half the particles by changing npart - npart = nparthalf - - do i=npart+1,2*npart - nptmass = nptmass + 1 - call bcast_mpi(nptmass) - ! make a sink particle with the position of each SPH particle - xyzmh_ptmass(1:3,nptmass) = xyzh(1:3,i) - xyzmh_ptmass(4,nptmass) = massi ! same mass as SPH particles - xyzmh_ptmass(5:,nptmass) = 0. - call bcast_mpi(xyzmh_ptmass(1:5,nptmass)) - enddo - else - ! Assuming there are no gas particles here, - ! get sinks from master - - if (npart /= 0) call fatal("copy_half_gas_particles_to_sinks","there are particles on a non-master task") - - ! Get nparthalf from master, but don't change npart from zero - do i=nparthalf+1,2*nparthalf - call bcast_mpi(nptmass) - call bcast_mpi(xyzmh_ptmass(1:5,nptmass)) - enddo - endif - -end subroutine copy_half_gas_particles_to_sinks - -subroutine get_dx_dr(x1,x2,dx,dr) - real, intent(in) :: x1(3),x2(3) - real, intent(out) :: dx(3),dr - - dx = x1 - x2 - dr = 1./sqrt(dot_product(dx,dx)) - -end subroutine get_dx_dr - -subroutine get_finite_diff(ndim,x0,xposj,totmass,quads,fnode,dfdx,dpot,d2f,eps) - use kdtree, only:compute_fnode - integer, intent(in) :: ndim - real, intent(in) :: x0(ndim),xposj(ndim),totmass,quads(6),fnode(20),eps - real, intent(out) :: dfdx(ndim,ndim),dpot(ndim),d2f(ndim,ndim) - integer :: i,j - real :: dx(ndim),x0_plus(ndim),x0_minus(ndim) - real :: dr,fnode_plus(20),fnode_minus(20) - - do j=1,ndim - x0_plus = x0 - x0_plus(j) = x0(j) + eps - x0_minus = x0 - x0_minus(j) = x0(j) - eps - do i=1,ndim - call get_dx_dr(x0_plus,xposj,dx,dr) - fnode_plus = 0. - call compute_fnode(dx(1),dx(2),dx(3),dr,totmass,quads,fnode_plus) - - call get_dx_dr(x0_minus,xposj,dx,dr) - fnode_minus = 0. - call compute_fnode(dx(1),dx(2),dx(3),dr,totmass,quads,fnode_minus) - - dfdx(i,j) = (fnode_plus(i) - fnode_minus(i))/(2.*eps) - d2f(i,j) = (fnode_plus(i) - 2.*fnode(i) + fnode_minus(i))/(eps*eps) - enddo - dpot(j) = -(fnode_plus(20) - fnode_minus(20))/(2.*eps) - enddo - -end subroutine get_finite_diff - -end module testgravity diff --git a/src/tests/test_growth.F90 b/src/tests/test_growth.F90 deleted file mode 100644 index a0d4c6e24..000000000 --- a/src/tests/test_growth.F90 +++ /dev/null @@ -1,406 +0,0 @@ -!--------------------------------------------------------------------------! -! 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.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module testgrowth -! -! Unit tests of the growth module -! -! :References: -! -! :Owner: Arnaud Vericel -! -! :Runtime parameters: None -! -! :Dependencies: boundary, checksetup, deriv, dim, dust, energies, eos, -! growth, io, kernel, mpidomain, mpiutils, options, part, physcon, -! step_lf_global, testdust, testutils, timestep, unifdis, units, -! viscosity -! - use testutils, only:checkval,update_test_scores - use io, only:id,master -#ifdef DUST -#ifdef DUSTGROWTH - use testdust, only:test_dustybox -#endif -#endif - implicit none - public :: test_growth - - private - -contains -!----------------------------------------------------------------------- -!+ -! Unit tests for dust growth using Stepinksi & Valageas method -!+ -!----------------------------------------------------------------------- -subroutine test_growth(ntests,npass) -#ifdef DUST -#ifdef DUSTGROWTH - use growth, only:init_growth,ifrag,isnow - use physcon, only:solarm,au - use units, only:set_units - use mpiutils, only:barrier_mpi -#endif -#endif - integer, intent(inout) :: ntests,npass - -#ifdef DUST -#ifdef DUSTGROWTH - integer :: nfailed(5),ierr !don't forget the dimension of nfailed - logical, dimension(2) :: logic = (/.false., .true./) - integer :: i,j - - if (id==master) write(*,"(/,a)") '--> TESTING DUSTGROWTH MODULE' - - call set_units(mass=solarm,dist=au,G=1.d0) - - if (id==master) write(*,"(/,a)") '--> testing growth initialisation' - - nfailed = 0 - do ifrag=0,2 - do isnow=0,2 - call init_growth(ierr) - call checkval(ierr,0,0,nfailed(ifrag+isnow+1),'growth initialisation') - enddo - enddo - call update_test_scores(ntests,nfailed,npass) - - ! - ! The return of the dustybox test - ! - call test_dustybox(ntests,npass) - call barrier_mpi() - - ! - ! testing farmingbox with several config. - ! - do i=1,2 - do j=1,2 - call test_farmingbox(ntests,npass,frag=logic(i),onefluid=logic(j)) - call barrier_mpi() - enddo - enddo - - if (id==master) write(*,"(/,a)") '<-- DUSTGROWTH TEST COMPLETE' -#else - if (id==master) write(*,"(/,a)") '--> SKIPPING DUSTGROWTH TEST (REQUIRES -DDUST -DDUSTGROWTH)' -#endif -#endif - -end subroutine test_growth - -#ifdef DUST -#ifdef DUSTGROWTH - -!------------------- -!------------------- -!------------------- - -subroutine test_farmingbox(ntests,npass,frag,onefluid) - use boundary, only:set_boundary,xmin,xmax,ymin,ymax,zmin,zmax,dxbound,dybound,dzbound - use kernel, only:hfact_default - use part, only:init_part,igas,idust,npart,xyzh,vxyzu,npartoftype,massoftype,set_particle_type,& - fxyzu,fext,Bevol,dBevol,dustprop,ddustprop,& - dustfrac,dustevol,ddustevol,iphase,maxtypes,& - VrelVf,dustgasprop,Omega_k,alphaind,iamtype,& - ndustlarge,ndustsmall,rhoh,deltav,this_is_a_test,periodic, & - npartoftypetot,update_npartoftypetot - use step_lf_global, only:step,init_step - use deriv, only:get_derivs_global - use energies, only:compute_energies - use testutils, only:checkvalbuf,checkvalbuf_end - use eos, only:ieos,polyk,gamma,get_spsound - use dust, only:idrag,init_drag - use growth, only:ifrag,init_growth,isnow,vfrag,gsizemincgs,get_size - use options, only:alpha,alphamax,use_dustfrac - use unifdis, only:set_unifdis - use dim, only:periodic,mhd,use_dust,maxp,maxalpha - use timestep, only:dtmax - use io, only:iverbose - use mpiutils, only:reduceall_mpi - use physcon, only:au,solarm,Ro,pi,fourpi - use viscosity, only:shearparam - use units, only:set_units,udist,unit_density!,unit_velocity - use mpidomain, only:i_belong - use checksetup, only:check_setup - - integer, intent(inout) :: ntests,npass - logical, intent(in) :: frag,onefluid - - integer :: nx,nerror,nwarn - integer :: itype,npart_previous,i,j,nsteps,modu,noutputs - integer :: ncheck(4),nerr(4) - real :: errmax(4) - integer :: ierr,iam - - logical :: do_output = .false. - real :: deltax,dz,hfact,totmass,rhozero - real :: Stcomp(20000),Stini(20000) - real :: cscomp(20000),tau(20000) - real :: s(20000),time,timelim(20000) - real :: sinit,dens,t,tmax,dt,dtext,dtnew,guillaume,dtgratio,rhog,rhod - - real, parameter :: tolst = 5.e-4 - real, parameter :: tolcs = 5.e-4 - real, parameter :: tols = 5.e-4 - real, parameter :: tolrho = 5.e-4 - - character(len=15) :: stringfrag - character(len=15) :: stringmethod - - ! initialise particle arrays to zero - call init_part() - - if (frag) then - sinit = 1./udist - gsizemincgs = 1.e-3 - dtgratio = 0.5 - stringfrag = "fragmentation" - else - sinit = 3.e-2/udist - dtgratio = 1. - stringfrag = "growth" - endif - - if (onefluid) then - use_dustfrac = .true. - stringmethod = "one fluid" - ndustsmall = 1 - ndustlarge = 0 - dtgratio = 1.e-1 - else - use_dustfrac = .false. - stringmethod = "two fluid" - ndustsmall = 0 - ndustlarge = 1 - endif - dens = 1./unit_density - - write(*,*)'--> testing FARMINGBOX using: ',trim(stringfrag),' and ',trim(stringmethod), ' dust method' - write(*,*)'------------------------------------------------------------------------' - - ! - ! initialise - ! - this_is_a_test = .true. - - ! - ! setup for dustybox problem - ! - nx = 32 - deltax = 1./nx - dz = 2.*sqrt(6.)/nx - call set_boundary(-0.5,0.5,-0.25,0.25,-dz,dz) - hfact = hfact_default - rhozero = 1.e-11/unit_density - totmass = rhozero*dxbound*dybound*dzbound - if (onefluid) then - rhog = rhozero * (1-dtgratio) - rhod = dtgratio * rhozero - else - rhog = rhozero - rhod = dtgratio * rhozero - endif - npart = 0 - fxyzu = 0. - dustprop = 0. - ddustprop = 0. - ddustevol = 0. - dBevol = 0. - if (maxalpha==maxp) alphaind(:,:) = 0. - - !- setting gas particles - itype = igas - npart_previous = npart - call set_unifdis('closepacked',id,master,xmin,xmax,ymin,ymax,zmin,zmax,& - deltax,hfact,npart,xyzh,periodic,verbose=.false.,mask=i_belong) - do i=npart_previous+1,npart - vxyzu(:,i) = 0. - fext(:,i) = 0. - if (mhd) Bevol(:,i) = 0. - if (use_dust) then - dustevol(:,i) = 0. - dustfrac(:,i) = 0. - deltav(:,:,i) = 0. - dustgasprop(:,i) = 0. - VrelVf(i) = 0. - if (use_dustfrac) then - dustfrac(1,i) = dtgratio - dustprop(1,i) = fourpi/3.*dens*sinit**3 - dustprop(2,i) = dens - else - dustprop(:,i) = 0. - dustfrac(:,i) = 0. - endif - endif - call set_particle_type(i,itype) - enddo - npartoftype(itype) = npart - npart_previous - call update_npartoftypetot - massoftype(itype) = totmass/npartoftypetot(itype) - - !- setting dust particles if not one fluid - if (.not. use_dustfrac) then - itype = idust - npart_previous = npart - call set_unifdis('closepacked',id,master,xmin,xmax,ymin,ymax,zmin,zmax,& - deltax,hfact,npart,xyzh,periodic,verbose=.false.,mask=i_belong) - do i=npart_previous+1,npart - vxyzu(:,i) = 0. - fext(:,i) = 0. - if (mhd) Bevol(:,i) = 0. - if (use_dust) then - dustevol(:,i) = 0. - dustfrac(:,i) = 0. - dustprop(1,i) = fourpi/3.*dens*sinit**3 - dustprop(2,i) = dens - dustgasprop(:,i) = 0. - VrelVf(i) = 0. - endif - call set_particle_type(i,itype) - enddo - npartoftype(itype) = npart - npart_previous - npartoftypetot(itype) = reduceall_mpi('+',npartoftype(itype)) - massoftype(itype) = dtgratio*totmass/npartoftypetot(itype) - endif - - ! - ! check that particle setup is sensible - ! - call check_setup(nerror,nwarn) - - ! - ! runtime parameters - ! - - ieos = 1 - idrag = 1 - if (frag) then - ifrag = 1 - shearparam = 2.5e-2 - else - ifrag = 0 - shearparam = 1.e-2 - endif - isnow = 0 - vfrag = 1.e-11 - gsizemincgs = 1.e-2 - polyk = 1.e-3 - gamma = 1. - alpha = 0. - alphamax = 0. - iverbose = 0 - - !- timestepping - dt = 1.e-3 - tmax = 0.2 - nsteps = int(tmax/dt) - noutputs = 150 - if (noutputs > nsteps) noutputs = nsteps - modu = int(nsteps/noutputs) - dtmax = nsteps*dt - - timelim(:) = 1.e3 - ncheck(:) = 0 - nerr(:) = 0 - errmax(:) = 0. - - t = 0. - - call init_drag(ierr) - call init_growth(ierr) - - call get_derivs_global() - - call init_step(npart,t,dtmax) - - do j=1,npart - iam = iamtype(iphase(j)) - if (iam == idust .or. (use_dustfrac .and. iam == igas)) then - cscomp(j) = get_spsound(ieos,xyzh(:,j),rhog,vxyzu(:,j)) - Stini(j) = sqrt(pi*gamma/8)*dens*sinit/((rhog+rhod)*cscomp(j)) * Omega_k(j) - Stcomp(j) = Stini(j) - tau(j) = 1/(sqrt(2**1.5*Ro*shearparam)*Omega_k(j))*(rhog+rhod)/rhod/sqrt(pi*gamma/8.) - s(j) = sinit - timelim(j) = 2*sqrt(Stini(j))*(1.+Stini(j)/3.)*tau(j) - endif - enddo - if (frag) write(*,"(a,f5.1,a)") "Analytical solution no longer valid after t = ", minval(timelim), " (size < 0)" - - ! - ! run farmingbox problem - ! - do i=1,nsteps - dtext = dt - call step(npart,npart,t,dt,dtext,dtnew) - t = t + dt - if (do_output .and. mod(i,modu)==0) then - call write_file_err(i,t,xyzh,dustprop(1,:)*udist,s*udist,dustgasprop(3,:),Stcomp,npart,"farmingbox_") - endif - do j=1,npart - iam = iamtype(iphase(j)) - if (iam == idust .or. (iam == igas .and. use_dustfrac)) then - if (frag) then - time = - t/tau(j) + 2.*sqrt(Stini(j))*(1.+Stini(j)/3.) - else - time = 2.*sqrt(Stini(j))*(1.+Stini(j)/3.) + t/tau(j) - endif - guillaume = (8.+9.*time*time+3.*time*sqrt(16.+9.*time*time))**(1./3.) - Stcomp(j) = guillaume/2. + 2./guillaume - 2 - s(j) = Stcomp(j)/(sqrt(pi*gamma/8)*dens/((rhog+rhod)*cscomp(j))*Omega_k(j)) - if (onefluid) then - call checkvalbuf(dustgasprop(3,j)/Stcomp(j),1.,tolst,'St',nerr(1),ncheck(1),errmax(1)) - call checkvalbuf(get_size(dustprop(1,j),dustprop(2,j))/s(j),1.,tols,'size',nerr(2),ncheck(2),errmax(2)) - else - call checkvalbuf(dustgasprop(3,j)/Stcomp(j),1.,tolst,'St',nerr(1),ncheck(1),errmax(1)) - call checkvalbuf(get_size(dustprop(1,j),dustprop(2,j))/s(j),1.,tols,'size',nerr(2),ncheck(2),errmax(2)) - call checkvalbuf(dustgasprop(1,j)/cscomp(j),1.,tolcs,'csound',nerr(3),ncheck(3),errmax(3)) - call checkvalbuf(dustgasprop(2,j)/rhozero,1.,tolrho,'rhogas',nerr(4),ncheck(4),errmax(4)) - endif - endif - enddo - enddo - if (onefluid) then - call checkvalbuf_end('Stokes number evaluation matches exact solution',ncheck(1),nerr(1),errmax(1),tolst) - call checkvalbuf_end('size evaluation matches exact solution',ncheck(2),nerr(2),errmax(2),tols) - else - call checkvalbuf_end('Stokes number interpolation matches exact solution',ncheck(1),nerr(1),errmax(1),tolst) - call checkvalbuf_end('size evaluation matches exact solution',ncheck(2),nerr(2),errmax(2),tols) - call checkvalbuf_end('sound speed interpolation matches exact number',ncheck(3),nerr(3),errmax(3),tolcs) - call checkvalbuf_end('rhogas interpolation matches exact number',ncheck(4),nerr(4),errmax(4),tolrho) - endif - - call update_test_scores(ntests,nerr,npass) - -end subroutine test_farmingbox - -subroutine write_file_err(step,t,xyzh,size,size_exact,St,St_exact,npart,prefix) - use part, only:iamdust,iphase,iamgas - real, intent(in) :: t - real, intent(in) :: xyzh(:,:) - real, intent(in) :: St(:),St_exact(:),size(:),size_exact(:) - character(len=*), intent(in) :: prefix - integer, intent(in) :: npart,step - character(len=30) :: filename,str - integer :: i,lu - - write(str,"(i000.4)") step - filename = prefix//'dust_'//trim(adjustl(str))//'.txt' - open(newunit=lu,file=filename,status='replace') - write(lu,*) t - do i=1,npart - if (iamdust(iphase(i))) write(lu,*) xyzh(1,i),xyzh(2,i),xyzh(3,i),size(i),size_exact(i),& - St(i),St_exact(i) - enddo - close(lu) - -end subroutine write_file_err - -#endif -#endif - -end module testgrowth diff --git a/src/tests/test_hierarchical.f90 b/src/tests/test_hierarchical.f90 index 8cd40fced..9d5f6899a 100644 --- a/src/tests/test_hierarchical.f90 +++ b/src/tests/test_hierarchical.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testsethier ! diff --git a/src/tests/test_indtstep.F90 b/src/tests/test_indtstep.F90 index ecd84373c..30d101661 100644 --- a/src/tests/test_indtstep.F90 +++ b/src/tests/test_indtstep.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testindtstep ! diff --git a/src/tests/test_kdtree.F90 b/src/tests/test_kdtree.F90 index 6971b69b5..4d5cfa0ab 100644 --- a/src/tests/test_kdtree.F90 +++ b/src/tests/test_kdtree.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testkdtree ! diff --git a/src/tests/test_kernel.f90 b/src/tests/test_kernel.f90 index 285dbef0e..6169a18f7 100644 --- a/src/tests/test_kernel.f90 +++ b/src/tests/test_kernel.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testkernel ! diff --git a/src/tests/test_link.F90 b/src/tests/test_link.F90 index d8852dde5..95c8a961a 100644 --- a/src/tests/test_link.F90 +++ b/src/tests/test_link.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testlink ! diff --git a/src/tests/test_luminosity.F90 b/src/tests/test_luminosity.F90 index 89941749c..dab7dc68f 100644 --- a/src/tests/test_luminosity.F90 +++ b/src/tests/test_luminosity.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testlum ! diff --git a/src/tests/test_mpi.F90 b/src/tests/test_mpi.F90 deleted file mode 100644 index f4b685f29..000000000 --- a/src/tests/test_mpi.F90 +++ /dev/null @@ -1,100 +0,0 @@ -!--------------------------------------------------------------------------! -! 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.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module testmpi -! -! MPI unit tests -! -! :References: None -! -! :Owner: David Liptai -! -! :Runtime parameters: None -! -! :Dependencies: io, mpiforce, mpimemory, physcon, testutils, units -! - use testutils, only:checkval,checkvalbuf,checkvalbuf_end,update_test_scores - implicit none - - public :: test_mpi - - private - -contains - -subroutine test_mpi(ntests,npass) - use io, only:id,master - use units, only:set_units - use physcon, only:solarm - integer, intent(inout) :: ntests,npass - - call set_units(mass=1.d6*solarm,G=1.d0,c=1.d0) - if (id==master) write(*,"(/,a,/)") '--> TESTING MPI' - call test_increase_mpi_memory(ntests,npass) - if (id==master) write(*,"(/,a)") '<-- MPI TESTS COMPLETE' - -end subroutine test_mpi - -subroutine test_increase_mpi_memory(ntests,npass) - use mpimemory, only:allocate_mpi_memory,increase_mpi_memory,& - deallocate_mpi_memory,stacksize,force_stack_1,& - push_onto_stack - use mpiforce, only:cellforce - integer, intent(inout) :: ntests,npass - integer, parameter :: new_stacksize=100 - type(cellforce) :: cell - integer :: nerr(3), ncheck(3), i, stacksize_orig - real :: maxerr(3) - - nerr = 0 - ncheck = 0 - maxerr = 0. - - ! Save original stacksize, assuming they're the same for dens and force - stacksize_orig = stacksize - - ! Deallocate existing stack - call deallocate_mpi_memory - - ! Allocate the stacks again at a smaller size. - call allocate_mpi_memory(stacksize_in=new_stacksize) - - ! Write some data to each cell - do i=1,new_stacksize - cell%xpos = [1.,2.,3.] * i - call push_onto_stack(force_stack_1, cell) - enddo - - ! Ensure size of force_stack_1 is what we expect it to be - call checkval(force_stack_1%n,new_stacksize,0,nerr(1),'stacksize after pushing cells') - call update_test_scores(ntests,nerr,npass) - - ! Trigger a stacksize increase - if this doesn't segfault, that's a good sign - call increase_mpi_memory - - ! Ensure stack size hasn't changed - call checkval(force_stack_1%n,new_stacksize,0,nerr(1),'stacksize after mem increase') - call update_test_scores(ntests,nerr,npass) - - ! Check cell data is the same as what was written into cells above - do i=1,new_stacksize - call checkvalbuf(force_stack_1%cells(i)%xpos(1),1.*i,1.e-15,'error in xpos(1) after mem increase',nerr(1),ncheck(1),maxerr(1)) - call checkvalbuf(force_stack_1%cells(i)%xpos(2),2.*i,1.e-15,'error in xpos(2) after mem increase',nerr(2),ncheck(2),maxerr(2)) - call checkvalbuf(force_stack_1%cells(i)%xpos(3),3.*i,1.e-15,'error in xpos(3) after mem increase',nerr(3),ncheck(3),maxerr(3)) - enddo - - call checkvalbuf_end('error in xpos(1) after mem increase asfgd',ncheck(1),nerr(1),maxerr(1),1.e-15) - call checkvalbuf_end('error in xpos(2) after mem increase asfgd',ncheck(2),nerr(2),maxerr(2),1.e-15) - call checkvalbuf_end('error in xpos(3) after mem increase asfgd',ncheck(3),nerr(3),maxerr(3),1.e-15) - call update_test_scores(ntests,nerr,npass) - - ! Reallocate previous stack - call deallocate_mpi_memory - call allocate_mpi_memory(stacksize_in=stacksize_orig) - -end subroutine test_increase_mpi_memory - -end module testmpi diff --git a/src/tests/test_nonidealmhd.F90 b/src/tests/test_nonidealmhd.F90 index 9a49c3518..e03bab93d 100644 --- a/src/tests/test_nonidealmhd.F90 +++ b/src/tests/test_nonidealmhd.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testnimhd ! diff --git a/src/tests/test_part.f90 b/src/tests/test_part.f90 index 62add8a8c..aa4086b6f 100644 --- a/src/tests/test_part.f90 +++ b/src/tests/test_part.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testpart ! diff --git a/src/tests/test_poly.f90 b/src/tests/test_poly.f90 index 7053c571d..a5bb1b56c 100644 --- a/src/tests/test_poly.f90 +++ b/src/tests/test_poly.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testpoly ! diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 04b35b897..2096c3d5d 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testptmass ! diff --git a/src/tests/test_radiation.f90 b/src/tests/test_radiation.f90 index 8d1778ebd..36c299cfd 100644 --- a/src/tests/test_radiation.f90 +++ b/src/tests/test_radiation.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testradiation ! @@ -411,6 +411,7 @@ subroutine test_radiation_diffusion(ntests,npass) ! reset various things call init_part() limit_radiation_flux = .true. + drad = 0. end subroutine test_radiation_diffusion @@ -451,7 +452,7 @@ subroutine setup_radiation_diffusion_problem_sinusoid(kappa_code,c_code,xi0,rho0 rho0 = 2.5e-24 massoftype(igas) = rho0*dxbound*dybound*dzbound/nptot pmassi = massoftype(igas) - if (maxphase==maxp) iphase(:) = isetphase(igas,iactive=.true.) + if (maxphase==maxp) iphase(1:npart) = isetphase(igas,iactive=.true.) npartoftype(:) = 0 npartoftype(igas) = npart nactive = npart diff --git a/src/tests/test_rwdump.F90 b/src/tests/test_rwdump.F90 index 49dfedfcd..febdb7eb0 100644 --- a/src/tests/test_rwdump.F90 +++ b/src/tests/test_rwdump.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testrwdump ! diff --git a/src/tests/test_sedov.F90 b/src/tests/test_sedov.F90 index 687fb4732..d12efb34a 100644 --- a/src/tests/test_sedov.F90 +++ b/src/tests/test_sedov.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testsedov ! @@ -167,7 +167,7 @@ subroutine test_sedov(ntests,npass) angtot_in = angtot totmom_in = totmom mdust_in = mdust - call evol('test.in',logfile,evfile,dumpfile) + call evol('test.in',logfile,evfile,dumpfile,1) call write_evfile(time,dt) etotend = etot momtotend = totmom diff --git a/src/tests/test_setdisc.f90 b/src/tests/test_setdisc.f90 index 392fb0d70..2f7bf026f 100644 --- a/src/tests/test_setdisc.f90 +++ b/src/tests/test_setdisc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testsetdisc ! diff --git a/src/tests/test_smol.F90 b/src/tests/test_smol.F90 index 014c51969..7b26c1b65 100644 --- a/src/tests/test_smol.F90 +++ b/src/tests/test_smol.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testsmol ! diff --git a/src/tests/test_step.F90 b/src/tests/test_step.F90 index eceb5ceb2..9bd8f7ad8 100644 --- a/src/tests/test_step.F90 +++ b/src/tests/test_step.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module teststep ! diff --git a/src/tests/utils_testsuite.f90 b/src/tests/utils_testsuite.f90 index 0c8efdf46..8f05a7d0c 100644 --- a/src/tests/utils_testsuite.f90 +++ b/src/tests/utils_testsuite.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module testutils ! From cf8d4753c6baf39ed46bc0b97476bd66dba3add0 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 21:36:35 +1000 Subject: [PATCH 408/814] [header-bot] updated file headers --- src/main/deriv.F90 | 8 ++++---- src/main/extern_gr.f90 | 2 +- src/main/extern_prdrag.f90 | 5 +++-- src/main/readwrite_dumps_common.f90 | 7 ++++--- src/main/readwrite_dumps_fortran.f90 | 7 +++---- src/setup/setup_binary.f90 | 4 ++-- 6 files changed, 17 insertions(+), 16 deletions(-) diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index fd6b06ceb..91ef885a6 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -14,10 +14,10 @@ module deriv ! ! :Runtime parameters: None ! -! :Dependencies: cons2prim, densityforce, derivutils, dim, dust_formation, -! externalforces, forces, forcing, growth, io, linklist, metric_tools, -! options, part, porosity, ptmass, ptmass_radiation, radiation_implicit, -! timestep, timestep_ind, timing +! :Dependencies: cons2prim, densityforce, derivutils, dim, externalforces, +! forces, forcing, growth, io, linklist, metric_tools, options, part, +! porosity, ptmass, ptmass_radiation, radiation_implicit, timestep, +! timestep_ind, timing ! implicit none diff --git a/src/main/extern_gr.f90 b/src/main/extern_gr.f90 index 3d3aacdb2..7043299e2 100644 --- a/src/main/extern_gr.f90 +++ b/src/main/extern_gr.f90 @@ -13,7 +13,7 @@ module extern_gr ! Liptai & Price (2019), MNRAS 485, 819 ! Magnall, Price, Lasky & Macpherson (2023), Phys. Rev D. 108, 103534 ! -! :Owner: Spencer Magnall +! :Owner: David Liptai ! ! :Runtime parameters: None ! diff --git a/src/main/extern_prdrag.f90 b/src/main/extern_prdrag.f90 index c6d412feb..b0e26407f 100644 --- a/src/main/extern_prdrag.f90 +++ b/src/main/extern_prdrag.f90 @@ -27,9 +27,10 @@ module extern_prdrag ! ! :Owner: Daniel Price ! -! :Runtime parameters: None +! :Runtime parameters: +! - beta : *beta parameter* ! -! :Dependencies: eos, infile_utils, io, units +! :Dependencies: eos, infile_utils, io, units, vectorutils ! use eos, only:qfacdisc diff --git a/src/main/readwrite_dumps_common.f90 b/src/main/readwrite_dumps_common.f90 index 058dc0b97..11df1d566 100644 --- a/src/main/readwrite_dumps_common.f90 +++ b/src/main/readwrite_dumps_common.f90 @@ -10,12 +10,13 @@ module readwrite_dumps_common ! ! :References: None ! -! :Owner: Daniel Mentiplay +! :Owner: Daniel Price ! ! :Runtime parameters: None ! -! :Dependencies: dim, dump_utils, dust_formation, eos, gitinfo, io, -! options, part, sphNGutils +! :Dependencies: boundary, boundary_dyn, checkconserved, dim, dump_utils, +! dust, dust_formation, eos, externalforces, fileutils, gitinfo, io, +! options, part, setup_params, sphNGutils, timestep, units ! use dump_utils, only:lenid implicit none diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index ac1554bbf..433b06909 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -18,10 +18,9 @@ module readwrite_dumps_fortran ! ! :Runtime parameters: None ! -! :Dependencies: boundary, boundary_dyn, checkconserved, dim, dump_utils, -! dust, dust_formation, eos, externalforces, fileutils, io, lumin_nsdisc, -! memory, metric_tools, mpi, mpiutils, options, part, -! readwrite_dumps_common, setup_params, sphNGutils, timestep, units +! :Dependencies: boundary_dyn, dim, dump_utils, eos, io, memory, +! metric_tools, mpiutils, options, part, readwrite_dumps_common, +! sphNGutils, timestep ! use dump_utils, only:lenid,ndatatypes,i_int,i_int1,i_int2,i_int4,i_int8,& i_real,i_real4,i_real8,int1,int2,int1o,int2o,dump_h,lentag diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 311183cc6..cdf4f7c8d 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -23,8 +23,8 @@ module setup ! - w : *argument of periapsis (deg)* ! ! :Dependencies: centreofmass, dim, eos, externalforces, infile_utils, io, -! mpidomain, options, part, physcon, relaxstar, setbinary, setstar, -! setunits, setup_params, units +! kernel, mpidomain, options, part, physcon, relaxstar, setbinary, +! setstar, setunits, setup_params, units ! use setstar, only:star_t use dim, only:gr From 2a6814679a545a3b246500fcca4e74a2cf248234 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 21:36:50 +1000 Subject: [PATCH 409/814] [space-bot] whitespace at end of lines removed --- src/main/porosity.f90 | 2 +- src/main/tmunu2grid.f90 | 2 +- src/tests/test_dust.f90 | 2 +- src/utils/einsteintk_wrapper.f90 | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 547584f34..7b5071b17 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -6,7 +6,7 @@ !--------------------------------------------------------------------------! module porosity ! -! Contains routine for porosity evolution (growth, bouncing, +! Contains routine for porosity evolution (growth, bouncing, ! fragmentation, compaction, disruption) ! ! :References: diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index db90dda00..f95a91427 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -59,7 +59,7 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) weights = weight itype = 1 - + ! For now we can set this to the origin, but it might need to be ! set to the grid origin of the CCTK_grid since we have boundary points ! TODO This should also be the proper phantom values and not a magic number diff --git a/src/tests/test_dust.f90 b/src/tests/test_dust.f90 index 371059769..c025207f5 100644 --- a/src/tests/test_dust.f90 +++ b/src/tests/test_dust.f90 @@ -103,7 +103,7 @@ subroutine test_dust(ntests,npass) ! call test_drag(ntests,npass) call barrier_mpi() - + ! ! DUSTYBOX test with explicit/implicit scheme ! diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 312374352..28580cd41 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -56,7 +56,7 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) nophantompart = npart call get_metricderivs_all(dtout,dt_et) ! commented out to try and fix prim2cons - + call get_phantom_dt(dtout) end subroutine init_et2phantom From 77eeeef8b907ce3b3e8d94362c39b1ad3adb96bb Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 11 Apr 2024 21:37:26 +1000 Subject: [PATCH 410/814] [indent-bot] standardised indentation --- src/main/tmunu2grid.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index f95a91427..754f63a6d 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -280,4 +280,4 @@ subroutine check_conserved_p(pgrid,cfac) end subroutine check_conserved_p -end module tmunu2grid \ No newline at end of file +end module tmunu2grid From b7498f7f225463639fca50c2d8075e86ddaf024a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 11 Apr 2024 21:50:26 +1000 Subject: [PATCH 411/814] clean up of the parallel closes in step_lf --- src/main/step_extern.F90 | 29 ++++++++++++----------------- 1 file changed, 12 insertions(+), 17 deletions(-) diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index d2ee2a819..4f629667c 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -1127,22 +1127,16 @@ subroutine step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,ti !$omp parallel default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,abundance,iphase,ntypes,massoftype) & - !$omp shared(eos_vars,dust_temp,store_dust_temperature) & - !$omp shared(dt,hdt,timei,iexternalforce,extf_is_velocity_dependent,cooling_in_step,icooling) & + !$omp shared(eos_vars,dust_temp) & + !$omp shared(dt,hdt,timei,iexternalforce,extf_is_velocity_dependent) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,idamp,damp_fac) & - !$omp shared(nptmass,nsubsteps,C_force,divcurlv,dphotflag,dphot0) & + !$omp shared(nptmass,divcurlv,dphotflag,dphot0) & !$omp shared(abundc,abundo,abundsi,abunde) & - !$omp shared(nucleation,do_nucleation,update_muGamma,h2chemistry,unit_density) & - !$omp private(dphot,abundi,gmwvar,ph,ph_tot) & - !$omp private(ui,rhoi, mui, gammai) & - !$omp private(i,dudtcool,fxi,fyi,fzi,phii) & - !$omp private(fextx,fexty,fextz,fextxi,fextyi,fextzi,poti,fextv,accreted) & + !$omp shared(nucleation) & + !$omp private(i,phii) & + !$omp private(fextx,fexty,fextz) & !$omp private(fonrmaxi,dtphi2i,dtf) & - !$omp private(vxhalfi,vyhalfi,vzhalfi) & !$omp firstprivate(pmassi,itype) & -#ifdef KROME - !$omp shared(T_gas_cool) & -#endif !$omp reduction(min:dtextforcenew,dtphi2) & !$omp reduction(max:fonrmax) & !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) @@ -1192,14 +1186,15 @@ subroutine step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,ti call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), xyzh(1:3,i), damp_fac) endif - if (maxvxyzu >= 4 .and. itype==igas) then - call cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & - divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,idK2,idmu,idkappa, & - idgamma,imu,igamma,nabn,dphotflag,nabundances) - endif fext(1,i) = fextx fext(2,i) = fexty fext(3,i) = fextz + + if (maxvxyzu >= 4 .and. itype==igas) then + call cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,idK2,idmu,idkappa, & + idgamma,imu,igamma,nabn,dphotflag,nabundances) + endif endif enddo predictor !$omp enddo From 3be9f366c21cb58cad4121d7292939001815a9e2 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 11 Apr 2024 15:16:08 +0100 Subject: [PATCH 412/814] restoring upstream changes part5. Passes test suite! --- build/Makefile | 3 +- src/main/cons2prim.f90 | 3 +- src/main/cooling.F90 | 26 +- src/main/cooling_stamatellos.f90 | 2 +- src/main/eos.F90 | 4 +- src/main/eos_stamatellos.f90 | 3 +- src/main/force.F90 | 185 +++------ src/main/readwrite_infile.F90 | 11 +- src/main/step_leapfrog.F90 | 7 +- src/tests/test_gravity.f90 | 642 +++++++++++++++++++++++++++++++ src/tests/test_growth.f90 | 394 +++++++++++++++++++ 11 files changed, 1113 insertions(+), 167 deletions(-) create mode 100644 src/tests/test_gravity.f90 create mode 100644 src/tests/test_growth.f90 diff --git a/build/Makefile b/build/Makefile index 32282cb91..0ca66f007 100644 --- a/build/Makefile +++ b/build/Makefile @@ -498,6 +498,7 @@ SRCCHEM= fs_data.f90 mol_data.f90 utils_spline.f90 \ cooling_koyamainutsuka.f90 \ cooling_ism.f90 \ cooling_molecular.f90 \ + cooling_stamatellos.f90\ cooling_functions.f90 \ cooling_solver.f90 \ h2chem.f90 cooling.f90 @@ -505,7 +506,7 @@ SRCCHEM= fs_data.f90 mol_data.f90 utils_spline.f90 \ # equations of state # 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.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 diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 151dc9337..9c1130f8e 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -177,8 +177,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& iohm,ihall,nden_nimhd,eta_nimhd,iambi,get_partinfo,iphase,this_is_a_test,& ndustsmall,itemp,ikappa,idmu,idgamma,icv 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 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 diff --git a/src/main/cooling.F90 b/src/main/cooling.F90 index 582838213..aa2dda90b 100644 --- a/src/main/cooling.F90 +++ b/src/main/cooling.F90 @@ -84,20 +84,16 @@ subroutine init_cooling(id,master,iprint,ierr) if (id==master) write(iprint,*) 'initialising ISM cooling functions...' abund_default(iHI) = 1. call init_cooling_ism() - else - select case(icooling) - case(9) - if (ieos /= 21 .and. ieos /=2) call fatal('cooling','icooling=9 requires ieos=21',& - 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) - if (do_radiation) then - call fatal('cooling','Do radiation was switched on!') - endif + if (icooling==8) cooling_in_step = .false. + case(9) + if (ieos /= 21 .and. ieos /=2) call fatal('cooling','icooling=9 requires ieos=21',& + 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) @@ -110,8 +106,6 @@ subroutine init_cooling(id,master,iprint,ierr) case(7) ! Gammie PL cooling_in_step = .false. - case(8) - cooling_in_step = .false. case default call init_cooling_solver(ierr) end select diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index 75b0b2412..52705cc45 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module cooling_stamatellos ! diff --git a/src/main/eos.F90 b/src/main/eos.F90 index e90d18aeb..55ae32e93 100644 --- a/src/main/eos.F90 +++ b/src/main/eos.F90 @@ -461,7 +461,7 @@ end subroutine equationofstate subroutine init_eos(eos_type,ierr) use units, only:unit_velocity use physcon, only:Rg - use io, only:error,warning + use io, only:error,warning,fatal use eos_mesa, only:init_eos_mesa use eos_helmholtz, only:eos_helmholtz_init use eos_piecewise, only:init_eos_piecewise @@ -547,7 +547,7 @@ subroutine init_eos(eos_type,ierr) endif case(21) 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 fatal('init_eos','Failed to read EOS file') call init_S07cool end select diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index a5586f7be..060633d6a 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos_stamatellos ! @@ -20,6 +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(:) character(len=25), public :: eos_file= 'myeos.dat' !default name of tabulated EOS file logical,parameter,public :: doFLD = .True. integer,public :: iunitst=19 diff --git a/src/main/force.F90 b/src/main/force.F90 index 2caa4f23f..3d7b3fc33 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -39,7 +39,7 @@ module forces ! ! :Runtime parameters: None ! -! :Dependencies: boundary, cooling, dim, dust, eos, eos_shen, eos_stamatellos,fastmath, +! :Dependencies: boundary, cooling, dim, dust, eos, eos_shen, fastmath, ! growth, io, io_summary, kdtree, kernel, linklist, metric_tools, ! mpiderivs, mpiforce, mpimemory, mpiutils, nicil, omputils, options, ! part, physcon, ptmass, ptmass_heating, radiation_utils, timestep, @@ -53,8 +53,6 @@ module forces use part, only:iradxi,ifluxx,ifluxy,ifluxz,ikappa,ien_type,ien_entropy,ien_etotal,ien_entropy_s implicit none - character(len=80), parameter, public :: & ! module version - modid="$Id$" integer, parameter :: maxcellcache = 1000 @@ -898,14 +896,14 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g #ifdef FINVSQRT use fastmath, only:finvsqrt #endif - use kernel, only:grkern,cnormk,radkern2,wkern + 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 nicil, only:nimhd_get_jcbcb,nimhd_get_dBdt - use eos, only:ieos,eos_is_non_ideal,gamma - use eos_stamatellos, only:gradP_cool,Gpot_cool,duFLD,doFLD,getopac_opdep,get_k_fld + use eos, only:ieos,eos_is_non_ideal + use eos_stamatellos, only:gradP_cool,Gpot_cool #ifdef GRAVITY use kernel, only:kernel_softening use ptmass, only:ptmass_not_obscured @@ -913,18 +911,21 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g #ifdef PERIODIC use boundary, only:dxbound,dybound,dzbound #endif - use dim, only:use_dust,use_dustgrowth,ind_timesteps>>>>>>> upstream/master + use dim, only:use_dust,use_dustgrowth,ind_timesteps + use dust, only:get_ts,idrag,icut_backreaction,ilimitdustflux,irecon,drag_implicit + use kernel, only:wkern_drag,cnormk_drag,wkern,cnormk + use part, only:ndustsmall,grainsize,graindens,ndustsmall,grainsize,graindens,filfac + use options, only:use_porosity,icooling + use growth, only:get_size use kernel, only:wkern,cnormk #ifdef IND_TIMESTEPS use part, only:ibin_old,iamboundary use timestep_ind,only:get_dt #endif use timestep, only:bignumber - use options, only:overcleanfac,use_dustfrac,ireconav,icooling,limit_radiation_flux + use options, only:overcleanfac,use_dustfrac,ireconav,limit_radiation_flux use units, only:get_c_code -#ifdef GR use metric_tools,only:imet_minkowski,imetric -#endif use utils_gr, only:get_bigv use radiation_utils, only:get_rad_R integer, intent(in) :: i @@ -987,16 +988,11 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g #ifdef KROME real :: gammaj #endif -#ifdef DUST integer :: iregime,idusttype,l real :: dragterm,dragheating,wdrag,dv2,tsijtmp real :: grkernav,tsj(maxdusttypes),dustfracterms(maxdusttypes),term real :: projvstar,projf_drag,epstsj,sdrag1,sdrag2!,rhogas1i - !real :: Dav(maxdusttypes),vsigeps,depsdissterm(maxdusttypes) -#ifdef DUSTGROWTH real :: winter -#endif -#endif real :: dBevolx,dBevoly,dBevolz,divBsymmterm,divBdiffterm real :: rho21i,rho21j,Bxi,Byi,Bzi,psii,pmjrho21grkerni,pmjrho21grkernj real :: auterm,avBterm,mrhoi5,vsigB @@ -1027,8 +1023,8 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g real :: bigv2j,alphagrj,enthi,enthj real :: dlorentzv,lorentzj,lorentzi_star,lorentzj_star,projbigvi,projbigvj real :: bigvj(1:3),velj(3),metricj(0:3,0:3,2),projbigvstari,projbigvstarj - real :: radPj,fgravxi,fgravyi,fgravzi,wkernj,wkerni,gradpx,gradpy,gradpz - real :: gradP_cooli,gradP_coolj,kfldi,kfldj,Ti,Tj,diffterm,gmwi + real :: radPj,fgravxi,fgravyi,fgravzi + real :: gradpx,gradpy,gradpz,gradP_cooli,gradP_coolj ! unpack xi = xpartveci(ixi) @@ -1133,8 +1129,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g Bzi = 0.0 psii = 0.0 endif - if (use_dustfrac) then -#ifdef DUST + if (use_dust .and. use_dustfrac) then dustfraci(:) = xpartveci(idustfraci:idustfraciend) dustfracisum = sum(dustfraci(:)) if (ilimitdustflux) then @@ -1143,17 +1138,8 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g tsi(:) = xpartveci(itstop:itstopend) endif epstsi = sum(dustfraci(:)*tsi(:)) -!------------------------------------------------ -!--sqrt(rho*epsilon) method -! sqrtrhodustfraci(:) = sqrt(rhoi*dustfraci(:)) -!------------------------------------------------ !--sqrt(epsilon/1-epsilon) method (Ballabio et al. 2018) sqrtrhodustfraci(:) = sqrt(dustfraci(:)/(1.-dustfraci(:))) -!------------------------------------------------ -!--asin(sqrt(epsilon)) method -! sqrtrhodustfraci(:) = asin(sqrt(dustfraci(:))) -!------------------------------------------------ -#endif else dustfraci(:) = 0. dustfracisum = 0. @@ -1201,17 +1187,11 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g if (icooling == 9) then gradP_cool(i) = 0d0 Gpot_cool(i) = 0d0 - duFLD(i) = 0d0 gradpx = 0d0 gradpy = 0d0 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 - + loop_over_neighbours2: do n = 1,nneigh j = abs(listneigh(n)) @@ -1336,11 +1316,9 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g ibin_wake(j) = max(ibinnow_m1,ibin_wake(j)) ibin_neighi = max(ibin_neighi,ibin_old(j)) endif -#ifdef DUST - if (drag_implicit) then + if (use_dust .and. drag_implicit) then dti = min(dti,get_dt(dt,ibin_old(j))) endif -#endif #endif endif pmassj = massoftype(iamtypej) @@ -1370,7 +1348,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g if (iamgasj .and. maxvxyzu >= 4) then enj = vxyzu(4,j) - if (eos_is_non_ideal(ieos)) then ! Is this condition required, or should this be always true? + if (eos_is_non_ideal(ieos)) then ! only do this if eos requires temperature in physical units tempj = eos_vars(itemp,j) denij = 0.5*(eni/tempi + enj/tempj)*(tempi - tempj) ! dU = c_V * dT else @@ -1378,6 +1356,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g endif else denij = 0. + enj = 0. endif if (gr) then @@ -1455,16 +1434,8 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g dustfracj(:) = dustfrac(:,j) dustfracjsum = sum(dustfracj(:)) rhogasj = rhoj*(1. - dustfracjsum) -!------------------------------------------------ -!--sqrt(rho*epsilon) method -! sqrtrhodustfracj(:) = sqrt(rhoj*dustfracj(:)) -!------------------------------------------------ -!--sqrt(epsilon/1-epsilon) method (Ballabio et al. 2018) + !--sqrt(epsilon/1-epsilon) method (Ballabio et al. 2018) sqrtrhodustfracj(:) = sqrt(dustfracj(:)/(1.-dustfracj(:))) -!------------------------------------------------ -!--asin(sqrt(epsilon)) method -! sqrtrhodustfracj(:) = asin(sqrt(dustfracj(:))) -!------------------------------------------------ else dustfracj(:) = 0. dustfracjsum = 0. @@ -1474,7 +1445,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g if (maxalpha==maxp) alphaj = alphaind(1,j) - if (gr) densj = dens(j) prj = eos_vars(igasP,j) spsoundj = eos_vars(ics,j) radPj = 0. @@ -1511,7 +1481,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g !rhoj = 0. rho1j = 0. rho21j = 0. - densj = 0. mrhoj5 = 0. autermj = 0. @@ -1543,6 +1512,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g qrho2i = 0. qrho2j = 0. if (gr) then + densj = dens(j) enthi = 1.+eni+pri/densi enthj = 1.+enj+prj/densj endif @@ -1617,27 +1587,26 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g gradP_cooli = pmassj*pri*rho1i*rho1i*grkerni gradP_coolj = 0d0 if (usej) then - gradp_coolj = pmassj*prj*rho1j*rho1j*grkernj + gradp_coolj = pmassj*prj*rho1j*rho1j*grkernj endif endif + !--artificial thermal conductivity (need j term) if (maxvxyzu >= 4) then -#ifdef GR - denij = alphagri*eni/lorentzi - alphagrj*enj/lorentzj - if (imetric==imet_minkowski) then ! Eq 60 in LP19 - rhoav1 = 2./(enthi*densi + enthj*densj) - vsigu = min(1.,sqrt(abs(pri-prj)*rhoav1)) - else - vsigu = abs(vij) ! Eq 61 in LP19 - endif -#else - if (gravity) then + if (gr) then + denij = alphagri*eni/lorentzi - alphagrj*enj/lorentzj + if (imetric==imet_minkowski) then ! Eq 60 in LP19 + rhoav1 = 2./(enthi*densi + enthj*densj) + vsigu = min(1.,sqrt(abs(pri-prj)*rhoav1)) + else + vsigu = abs(vij) ! Eq 61 in LP19 + endif + elseif (gravity) then vsigu = abs(projv) else rhoav1 = 2./(rhoi + rhoj) vsigu = sqrt(abs(pri - prj)*rhoav1) endif -#endif dendissterm = vsigu*denij*(auterm*grkerni + autermj*grkernj) endif @@ -1727,12 +1696,10 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g projsy = projsyi + projsyj projsz = projszi + projszj - fsum(ifxi) = fsum(ifxi) - runix*(gradp + fgrav) - projsx fsum(ifyi) = fsum(ifyi) - runiy*(gradp + fgrav) - projsy fsum(ifzi) = fsum(ifzi) - runiz*(gradp + fgrav) - projsz fsum(ipot) = fsum(ipot) + pmassj*phii ! no need to symmetrise (see PM07) - if (icooling == 9) then Gpot_cool(i) = Gpot_cool(i) + pmassj*phii gradpx = gradpx + runix*(gradP_cooli + gradP_coolj) @@ -1748,31 +1715,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g fsum(idudtdissi) = fsum(idudtdissi) + dudtdissi + dudtresist !--energy dissipation due to conductivity fsum(idendtdissi) = fsum(idendtdissi) + dendissterm - if (icooling == 9) 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 - elseif (rhoj == 0.) then - diffterm = 0d0 - else - diffterm = 4d0*pmassj/rhoi/rhoj - diffterm = diffterm * kfldi * kfldj / (kfldi+kfldj) - diffterm = diffterm * (Ti - Tj) / rij2 - diffterm = diffterm*cnormk*grkerni*(runix*dx + runiy*dy + runiz*dz) - 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 - 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 !--add contribution to particle i's force @@ -1812,7 +1754,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g radDi = c_code*radlambdai/radkappai/rhoi - ! TWO FIRST DERIVATES ! + ! TWO FIRST DERIVATIVES ! radDFWi = pmassj*radDi*grkerni*rho21i*& (radFi(1)*runix + radFi(2)*runiy + radFi(3)*runiz) @@ -1823,8 +1765,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g ! (rhoi*radeni-rhoj*radenj)*grkerni*rij1 endif -#ifdef DUST - if (use_dustfrac) then + if (use_dust .and. use_dustfrac) then tsj = 0. do l=1,ndustsmall ! get stopping time - for one fluid dust we do not know deltav, but it is small by definition @@ -1854,20 +1795,18 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g do l=1,ndustsmall if (dustfraci(l) > 0. .or. dustfracj(l) > 0.) then - ! define averages of diffusion coefficient and kernels - !Dav(l) = dustfraci(l)*tsi(l) + dustfracj(l)*tsj(l) + ! define average of kernels grkernav = 0.5*(grkerni + grkernj) -!------------------------------------------------ -!--sqrt(epsilon/1-epsilon) method (Ballabio et al. 2018) + !--sqrt(epsilon/1-epsilon) method (Ballabio et al. 2018) dustfracterms(l) = pmassj*sqrtrhodustfracj(l)*rho1j & *((tsi(l)-epstsi)*(1.-dustfraci(l))/(1.-dustfracisum) & +(tsj(l)-epstsj)*(1.-dustfracj(l))/(1.-dustfracjsum)) & *(pri - prj)*grkernav*rij1 fsum(iddustevoli+(l-1)) = fsum(iddustevoli+(l-1)) - dustfracterms(l) -!------------------------------------------------ -!--sqrt(rho*epsilon) method and sqrt(epsilon/1-epsilon) method (Ballabio et al. 2018) + + !--sqrt(rho*epsilon) method and sqrt(epsilon/1-epsilon) method (Ballabio et al. 2018) if (maxvxyzu >= 4) fsum(idudtdusti+(l-1)) = fsum(idudtdusti+(l-1)) - sqrtrhodustfraci(l)*dustfracterms(l)*denij endif ! Equation 270 in Phantom paper @@ -1879,7 +1818,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g endif enddo endif -#endif else !ifgas ! @@ -1889,11 +1827,11 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g fsum(ifyi) = fsum(ifyi) - fgrav*runiy fsum(ifzi) = fsum(ifzi) - fgrav*runiz fsum(ipot) = fsum(ipot) + pmassj*phii ! no need to symmetrise (see PM07) -#ifdef DUST + ! ! gas-dust: compute drag terms ! - if (idrag>0) then + if (use_dust .and. idrag>0) then if (iamgasi .and. iamdustj .and. icut_backreaction==0) then projvstar = projv if (irecon >= 0) call reconstruct_dv(projv,dx,dy,dz,runix,runiy,runiz,dvdxi,dvdxj,projvstar,irecon) @@ -1964,10 +1902,10 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g if (q2i < q2j) then winter = wkern(q2i,qi)*hi21*hi1*cnormk else + winter = wkern(q2j,qj)*hj21*hj1*cnormk endif !--following quantities are weighted by mass rather than mass/density fsum(idensgasi) = fsum(idensgasi) + pmassj*winter - winter = wkern(q2j,qj)*hj21*hj1*cnormk fsum(idvix) = fsum(idvix) + pmassj*dvx*winter fsum(idviy) = fsum(idviy) + pmassj*dvy*winter fsum(idviz) = fsum(idviz) + pmassj*dvz*winter @@ -2000,7 +1938,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g fsum(ifdragzi) = fsum(ifdragzi) - dragterm*runiz endif endif -#endif endif ifgas !--self gravity contribution to total energy equation @@ -2037,7 +1974,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g !-- add contribution of 'distant neighbour' (outside r_kernel) gas particle to potential if (iamtypej == igas .and. icooling == 9) Gpot_cool(i) = Gpot_cool(i) + pmassj*phii - + !--self gravity contribution to total energy equation if (gr .and. gravity .and. ien_type == ien_etotal) then fgravxi = fgravxi - dx*fgravj @@ -2048,15 +1985,13 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g endif is_sph_neighbour enddo loop_over_neighbours2 - - if (icooling == 9) gradP_cool(i) = sqrt(gradpx*gradpx + gradpy*gradpy + gradpz*gradpz) - + if (icooling == 9) gradP_cool(i) = sqrt(gradpx*gradpx + gradpy*gradpy + gradpz*gradpz) + if (gr .and. gravity .and. ien_type == ien_etotal) then fsum(idudtdissi) = fsum(idudtdissi) + vxi*fgravxi + vyi*fgravyi + vzi*fgravzi endif - return end subroutine compute_forces !---------------------------------------------------------------- @@ -2165,7 +2100,6 @@ subroutine get_stress(pri,spsoundi,rhoi,rho1i,xi,yi,zi, & endif endif - return end subroutine get_stress !---------------------------------------------------------------- @@ -2187,9 +2121,9 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, use growth, only:get_size use part, only:ibin_old use timestep_ind, only:get_dt - use nicil, only:nimhd_get_jcbcb + use nicil, only:nimhd_get_jcbcb use radiation_utils, only:get_rad_R - use eos, only:utherm + use eos_stamatellos, only:Gpot_cool type(cellforce), intent(inout) :: cell integer(kind=1), intent(in) :: iphase(:) real, intent(in) :: xyzh(:,:) @@ -2268,10 +2202,9 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, if (iamgasi) then if (ndivcurlv >= 1) divcurlvi(:) = real(divcurlv(:,i),kind=kind(divcurlvi)) if (maxvxyzu >= 4) then - !eni = utherm(vxyzu(:,i),rhoi,gamma) - eni = vxyzu(4,i) + eni = vxyzu(4,i) else - eni = 0.0 + eni = 0.0 endif ! @@ -2615,9 +2548,6 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv rad,drad,radprop,dtrad) use io, only:fatal,warning -#ifdef FINVSQRT - use fastmath, only:finvsqrt -#endif use dim, only:mhd,mhd_nonideal,lightcurve,use_dust,maxdvdx,use_dustgrowth,gr,use_krome,& store_dust_temperature,do_nucleation,update_muGamma,h2chemistry use eos, only:ieos,iopacity_type @@ -2652,14 +2582,8 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv use physcon, only:fourpi use options, only:use_porosity use part, only:Omega_k -#endif use io, only:warning use physcon, only:c,kboltz -#ifdef GR - use part, only:pxyzu -#endif - use eos_stamatellos, only:Gpot_cool - integer, intent(in) :: icall type(cellforce), intent(inout) :: cell real, intent(inout) :: fxyzu(:,:) @@ -2695,7 +2619,8 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv integer, intent(inout) :: ndustres real, intent(inout) :: dustresfacmean,dustresfacmax real, intent(in) :: rad(:,:),radprop(:,:) - real, intent(out) :: drad(:,:),dtrad + real, intent(out) :: drad(:,:) + real, intent(inout) :: dtrad real :: c_code,dtradi,radlambdai,radkappai real :: xpartveci(maxxpartveciforce),fsum(maxfsum) real :: rhoi,rho1i,rhogasi,hi,hi1,pmassi,tempi,gammai @@ -2857,7 +2782,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv !--add self-contribution call kernel_softening(0.,0.,potensoft0,dum) epoti = 0.5*pmassi*(fsum(ipot) + pmassi*potensoft0*hi1) - if (icooling == 9 .and. iamgasi) Gpot_cool(i) = Gpot_cool(i) + pmassi*potensoft0*hi1 + if (icooling==9 .and. iamgasi) Gpot_cool(i) = Gpot_cool(i) + pmassi*potensoft0*hi1 ! !--add contribution from distant nodes, expand these in Taylor series about node centre ! use xcen directly, -1 is placeholder @@ -2867,7 +2792,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv fsum(ifxi) = fsum(ifxi) + fxi fsum(ifyi) = fsum(ifyi) + fyi fsum(ifzi) = fsum(ifzi) + fzi - if (icooling == 9 .and. iamgasi) Gpot_cool(i) = Gpot_cool(i) + poti ! add contribution from distant nodes + if (icooling==9 .and. iamgasi) Gpot_cool(i) = Gpot_cool(i) + poti ! add contribution from distant nodes if (gr .and. ien_type == ien_etotal) then fsum(idudtdissi) = fsum(idudtdissi) + vxi*fxi + vyi*fyi + vzi*fzi endif @@ -3137,8 +3062,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv endif else ! not gas -#ifdef DUSTGROWTH - if (iamdusti) then + if (use_dustgrowth .and. iamdusti) then !- return interpolations to their respective arrays dustgasprop(2,i) = fsum(idensgasi) !- rhogas !- interpolations are mass weigthed, divide result by rhog,i @@ -3159,7 +3083,6 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv endif dustgasprop(3,i) = tstopint * Omega_k(i) !- Stokes number endif -#endif if (maxvxyzu > 4) fxyzu(4,i) = 0. ! timestep based on Courant condition for non-gas particles @@ -3175,11 +3098,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv ! timestep based on force condition if (abs(f2i) > epsilon(f2i)) then -#ifdef FINVSQRT - dtf = C_force*sqrt(hi*finvsqrt(f2i)) -#else dtf = C_force*sqrt(hi/sqrt(f2i)) -#endif endif ! one fluid dust timestep diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 08820a848..a1705b37c 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module readwrite_infile ! @@ -343,10 +343,6 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) use options, only:use_porosity use porosity, only:read_options_porosity use metric, only:read_options_metric -#endif -#ifdef PHOTO - use photoevap, only:read_options_photoevap -#endif #ifdef INJECT_PARTICLES use inject, only:read_options_inject #endif @@ -711,8 +707,6 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (beta < 0.) call fatal(label,'beta < 0') if (beta > 4.) call warn(label,'very high beta viscosity set') #ifndef MCFOST - if (maxvxyzu >= 4 .and. (ieos /= 2 .and. ieos /= 4 .and. ieos /= 10 .and. ieos /=11 .and. & - ieos /=12 .and. ieos /= 15 .and. ieos /= 16 .and. ieos /= 20 .and. ieos/=21)) & 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 /= 20 .and. ieos/=21)) & call fatal(label,'only ieos=2 makes sense if storing thermal energy') @@ -721,7 +715,8 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (shearparam < 0.) call fatal(label,'stupid value for shear parameter (< 0)') if (irealvisc==2 .and. shearparam > 1) call error(label,'alpha > 1 for shakura-sunyaev viscosity') if (iverbose > 99 .or. iverbose < -9) call fatal(label,'invalid verboseness setting (two digits only)') - if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos ==21)) call fatal(label,'cooling requires adiabatic eos (ieos=2)') + if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos ==21)) & + call fatal(label,'cooling requires adiabatic eos (ieos=2)') if (icooling > 0 .and. (ipdv_heating <= 0 .or. ishock_heating <= 0)) & call fatal(label,'cooling requires shock and work contributions') if (((isink_radiation == 1 .or. isink_radiation == 3 ) .and. idust_opacity == 0 ) & diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 9f878498e..2de7b5a88 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -612,7 +612,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp parallel do default(none)& !$omp private(i) & !$omp shared(npart,hdtsph)& -!$omp shared(store_itype,vxyzu,fxyzu,vpred,iphase) & +!$omp shared(store_itype,vxyzu,fxyzu,vpred,iphase,icooling) & !$omp shared(Bevol,dBevol,Bpred,pxyzu,ppred) & !$omp shared(dustprop,ddustprop,dustproppred,use_dustfrac,dustevol,dustpred,ddustevol) & !$omp shared(filfac,filfacpred,use_porosity) & @@ -1234,7 +1234,7 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, fonrmax = 0. !$omp parallel default(none) & !$omp shared(maxp,maxphase) & - !$omp shared(npart,xyzh,vxyzu,fext,abundance,iphase,ntypes,massoftype) & + !$omp shared(npart,xyzh,vxyzu,fext,abundance,iphase,ntypes,massoftype,fxyzu) & !$omp shared(eos_vars,dust_temp,store_dust_temperature) & !$omp shared(dt,hdt,timei,iexternalforce,extf_is_velocity_dependent,cooling_in_step,icooling) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,idamp,damp_fac) & @@ -1381,7 +1381,8 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, endif 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,dudti_sph=fxyzu(4,i),part_id=i) + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,& + divcurlv(1,i),dudtcool,dudti_sph=fxyzu(4,i),part_id=i) endif endif #endif diff --git a/src/tests/test_gravity.f90 b/src/tests/test_gravity.f90 new file mode 100644 index 000000000..db00c260a --- /dev/null +++ b/src/tests/test_gravity.f90 @@ -0,0 +1,642 @@ +!--------------------------------------------------------------------------! +! 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 testgravity +! +! Unit tests of self-gravity +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: deriv, dim, directsum, energies, eos, io, kdtree, +! linklist, mpibalance, mpiutils, options, part, physcon, ptmass, +! sort_particles, spherical, testutils, timing +! + use io, only:id,master + implicit none + public :: test_gravity + + private + +contains +!----------------------------------------------------------------------- +!+ +! Unit tests for Newtonian gravity (i.e. Poisson solver) +!+ +!----------------------------------------------------------------------- +subroutine test_gravity(ntests,npass,string) + use dim, only:gravity + integer, intent(inout) :: ntests,npass + character(len=*), intent(in) :: string + logical :: testdirectsum,testpolytrope,testtaylorseries,testall + + testdirectsum = .false. + testtaylorseries = .false. + testpolytrope = .false. + testall = .false. + select case(string) + case('taylorseries') + testtaylorseries = .true. + case('directsum') + testdirectsum = .true. + case('polytrope') + testpolytrope = .true. + case default + testall = .true. + end select + + if (gravity) then + if (id==master) write(*,"(/,a,/)") '--> TESTING SELF-GRAVITY' + ! + !--unit test of Taylor series expansions in the treecode + ! + if (testtaylorseries .or. testall) call test_taylorseries(ntests,npass) + ! + !--unit tests of treecode gravity by direct summation + ! + if (testdirectsum .or. testall) call test_directsum(ntests,npass) + + if (id==master) write(*,"(/,a)") '<-- SELF-GRAVITY TESTS COMPLETE' + else + if (id==master) write(*,"(/,a)") '--> SKIPPING SELF-GRAVITY TESTS (need -DGRAVITY)' + endif + +end subroutine test_gravity + +!----------------------------------------------------------------------- +!+ +! Unit tests of the Taylor series expansion about local and distant nodes +!+ +!----------------------------------------------------------------------- +subroutine test_taylorseries(ntests,npass) + use kdtree, only:compute_fnode,expand_fgrav_in_taylor_series + use testutils, only:checkval,update_test_scores + integer, intent(inout) :: ntests,npass + integer :: nfailed(18),i,npnode + real :: xposi(3),xposj(3),x0(3),dx(3),fexact(3),f0(3) + real :: xposjd(3,3),dfdx_approx(3,3),d2f(3,3),dpot(3) + real :: fnode(20),quads(6) + real :: dr,dr2,phi,phiexact,pmassi,tol,totmass + + if (id==master) write(*,"(/,a)") '--> testing taylor series expansion about current node' + totmass = 5. + xposi = (/0.05,-0.04,-0.05/) ! position to evaluate the force at + xposj = (/1., 1., 1./) ! position of distant node + x0 = 0. ! position of nearest node centre + + call get_dx_dr(xposi,xposj,dx,dr) + fexact = -totmass*dr**3*dx ! exact force between i and j + phiexact = -totmass*dr ! exact potential between i and j + + call get_dx_dr(x0,xposj,dx,dr) + fnode = 0. + quads = 0. + call compute_fnode(dx(1),dx(2),dx(3),dr,totmass,quads,fnode) + + dx = xposi - x0 ! perform expansion about x0 + call expand_fgrav_in_taylor_series(fnode,dx(1),dx(2),dx(3),f0(1),f0(2),f0(3),phi) + !print*,' exact force = ',fexact,' phi = ',phiexact + !print*,' force at origin = ',fnode(1:3), ' phi = ',fnode(20) + !print*,'force w. taylor series = ',f0, ' phi = ',phi + nfailed(:) = 0 + call checkval(f0(1),fexact(1),3.e-4,nfailed(1),'fx taylor series about f0') + call checkval(f0(2),fexact(2),1.1e-4,nfailed(2),'fy taylor series about f0') + call checkval(f0(3),fexact(3),9.e-5,nfailed(3),'fz taylor series about f0') + call checkval(phi,phiexact,8.e-4,nfailed(4),'phi taylor series about f0') + call update_test_scores(ntests,nfailed,npass) + + if (id==master) write(*,"(/,a)") '--> testing taylor series expansion about distant node' + totmass = 5. + npnode = 3 + xposjd(:,1) = (/1.03, 0.98, 1.01/) ! position of distant particle 1 + xposjd(:,2) = (/0.95, 1.01, 1.03/) ! position of distant particle 2 + xposjd(:,3) = (/0.99, 0.95, 0.95/) ! position of distant particle 3 + xposj = 0. + pmassi = totmass/real(npnode) + do i=1,npnode + xposj = xposj + pmassi*xposjd(:,i) ! centre of mass of distant node + enddo + xposj = xposj/totmass + !print*,' centre of mass of distant node = ',xposj + !--compute quadrupole moments + quads = 0. + do i=1,npnode + dx(:) = xposjd(:,i) - xposj + dr2 = dot_product(dx,dx) + quads(1) = quads(1) + pmassi*(3.*dx(1)*dx(1) - dr2) + quads(2) = quads(2) + pmassi*(3.*dx(1)*dx(2)) + quads(3) = quads(3) + pmassi*(3.*dx(1)*dx(3)) + quads(4) = quads(4) + pmassi*(3.*dx(2)*dx(2) - dr2) + quads(5) = quads(5) + pmassi*(3.*dx(2)*dx(3)) + quads(6) = quads(6) + pmassi*(3.*dx(3)*dx(3) - dr2) + enddo + + x0 = 0. ! position of nearest node centre + xposi = x0 ! position to evaluate the force at + fexact = 0. + phiexact = 0. + do i=1,npnode + dx = xposi - xposjd(:,i) + dr = 1./sqrt(dot_product(dx,dx)) + fexact = fexact - dr**3*dx ! exact force between i and j + phiexact = phiexact - dr ! exact force between i and j + enddo + fexact = fexact*pmassi + phiexact = phiexact*pmassi + + call get_dx_dr(x0,xposj,dx,dr) + fnode = 0. + call compute_fnode(dx(1),dx(2),dx(3),dr,totmass,quads,fnode) + + dx = xposi - x0 ! perform expansion about x0 + call expand_fgrav_in_taylor_series(fnode,dx(1),dx(2),dx(3),f0(1),f0(2),f0(3),phi) + !print*,' exact force = ',fexact,' phi = ',phiexact + !print*,' force at origin = ',fnode(1:3), ' phi = ',fnode(20) + !print*,'force w. taylor series = ',f0, ' phi = ',phi + nfailed(:) = 0 + call checkval(f0(1),fexact(1),8.7e-5,nfailed(1),'fx taylor series about f0') + call checkval(f0(2),fexact(2),1.5e-6,nfailed(2),'fy taylor series about f0') + call checkval(f0(3),fexact(3),1.6e-5,nfailed(3),'fz taylor series about f0') + call checkval(phi,phiexact,5.9e-6,nfailed(4),'phi taylor series about f0') + call update_test_scores(ntests,nfailed,npass) + + if (id==master) write(*,"(/,a)") '--> checking results of compute_fnode routine' + ! + ! check that components of fnode are derivatives of each other + ! + tol = 1.e-6 + call get_finite_diff(3,x0,xposj,totmass,quads,fnode,dfdx_approx,dpot,d2f,tol) + nfailed(:) = 0 + call checkval(fnode(1),dpot(1),tol,nfailed(1),'fx=-dphi/dx') + call checkval(fnode(2),dpot(2),tol,nfailed(2),'fy=-dphi/dy') + call checkval(fnode(3),dpot(3),tol,nfailed(3),'fz=-dphi/dz') + call checkval(fnode(4),dfdx_approx(1,1),tol,nfailed(4),'dfx/dx') + call checkval(fnode(5),dfdx_approx(1,2),tol,nfailed(5),'dfx/dy') + call checkval(fnode(6),dfdx_approx(1,3),tol,nfailed(6),'dfx/dz') + call checkval(fnode(7),dfdx_approx(2,2),tol,nfailed(7),'dfy/dy') + call checkval(fnode(8),dfdx_approx(2,3),tol,nfailed(8),'dfx/dz') + call checkval(fnode(9),dfdx_approx(3,3),tol,nfailed(9),'dfz/dz') + call checkval(fnode(10),d2f(1,1),1.e-3,nfailed(10),'d^2fx/dx^2') + call checkval(fnode(13),d2f(1,2),1.1e-3,nfailed(11),'d^2fx/dy^2') + call checkval(fnode(15),d2f(1,3),1.e-3,nfailed(12),'d^2fx/dz^2') + call checkval(fnode(11),d2f(2,1),1.e-3,nfailed(13),'d^2fy/dx^2') + call checkval(fnode(16),d2f(2,2),1.e-3,nfailed(14),'d^2fy/dy^2') + call checkval(fnode(18),d2f(2,3),1.e-3,nfailed(15),'d^2fy/dz^2') + call checkval(fnode(12),d2f(3,1),1.e-3,nfailed(16),'d^2fz/dx^2') + call checkval(fnode(17),d2f(3,2),1.2e-3,nfailed(17),'d^2fz/dy^2') + call checkval(fnode(19),d2f(3,3),1.e-3,nfailed(18),'d^2fz/dz^2') + call update_test_scores(ntests,nfailed,npass) + + if (id==master) write(*,"(/,a)") '--> testing taylor series expansion about both current and distant nodes' + x0 = 0. ! position of nearest node centre + xposi = (/0.05,0.05,-0.05/) ! position to evaluate the force at + fexact = 0. + phiexact = 0. + do i=1,npnode + dx = xposi - xposjd(:,i) + dr = 1./sqrt(dot_product(dx,dx)) + fexact = fexact - dr**3*dx ! exact force between i and j + phiexact = phiexact - dr ! exact force between i and j + enddo + fexact = fexact*pmassi + phiexact = phiexact*pmassi + + dx = x0 - xposj + dr = 1./sqrt(dot_product(dx,dx)) ! compute approx force between node and j + fnode = 0. + call compute_fnode(dx(1),dx(2),dx(3),dr,totmass,quads,fnode) + + dx = xposi - x0 ! perform expansion about x0 + call expand_fgrav_in_taylor_series(fnode,dx(1),dx(2),dx(3),f0(1),f0(2),f0(3),phi) + !print*,' exact force = ',fexact,' phi = ',phiexact + !print*,' force at origin = ',fnode(1:3), ' phi = ',fnode(20) + !print*,'force w. taylor series = ',f0, ' phi = ',phi + nfailed(:) = 0 + call checkval(f0(1),fexact(1),4.3e-5,nfailed(1),'fx taylor series about f0') + call checkval(f0(2),fexact(2),1.4e-4,nfailed(2),'fy taylor series about f0') + call checkval(f0(3),fexact(3),3.2e-4,nfailed(3),'fz taylor series about f0') + call checkval(phi,phiexact,9.7e-4,nfailed(4),'phi taylor series about f0') + call update_test_scores(ntests,nfailed,npass) + +end subroutine test_taylorseries + +!----------------------------------------------------------------------- +!+ +! Unit tests of the tree code gravity, checking it agrees with +! gravity computed via direct summation +!+ +!----------------------------------------------------------------------- +subroutine test_directsum(ntests,npass) + use io, only:id,master + use dim, only:maxp,maxptmass,mpi + 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 + use eos, only:polyk,gamma + use options, only:ieos,alpha,alphau,alphaB,tolh + use spherical, only:set_sphere + use deriv, only:get_derivs_global + use physcon, only:pi + use timing, only:getused,printused + use directsum, only:directsum_grav + use energies, only:compute_energies,epot + use kdtree, only:tree_accuracy + use testutils, only:checkval,checkvalbuf_end,update_test_scores + use ptmass, only:get_accel_sink_sink,get_accel_sink_gas,h_soft_sinksink + use mpiutils, only:reduceall_mpi,bcast_mpi + use linklist, only:set_linklist + use sort_particles, only:sort_part_id + use mpibalance, only:balancedomains + + integer, intent(inout) :: ntests,npass + integer :: nfailed(18) + integer :: maxvxyzu,nx,np,i,k,merge_n,merge_ij(maxptmass),nfgrav + real :: psep,totvol,totmass,rhozero,tol,pmassi + real :: time,rmin,rmax,phitot,dtsinksink,fonrmax,phii,epot_gas_sink + real(kind=4) :: t1,t2 + real :: epoti,tree_acc_prev + real, allocatable :: fgrav(:,:),fxyz_ptmass_gas(:,:) + + maxvxyzu = size(vxyzu(:,1)) + tree_acc_prev = tree_accuracy + do k = 1,6 + if (labeltype(k)/='bound') then + if (id==master) write(*,"(/,3a)") '--> testing gravity force in densityforce for ',labeltype(k),' particles' +! +!--general parameters +! + time = 0. + hfact = 1.2 + gamma = 5./3. + rmin = 0. + rmax = 1. + ieos = 2 + tree_accuracy = 0.5 +! +!--setup particles +! + call init_part() + np = 1000 + totvol = 4./3.*pi*rmax**3 + nx = int(np**(1./3.)) + psep = totvol**(1./3.)/real(nx) + psep = 0.18 + npart = 0 + ! only set up particles on master, otherwise we will end up with n duplicates + if (id==master) then + call set_sphere('cubic',id,master,rmin,rmax,psep,hfact,npart,xyzh) + endif + np = npart +! +!--set particle properties +! + totmass = 1. + rhozero = totmass/totvol + npartoftype(:) = 0 + npartoftype(k) = int(reduceall_mpi('+',npart),kind=kind(npartoftype)) + massoftype(:) = 0.0 + massoftype(k) = totmass/npartoftype(k) + if (maxphase==maxp) then + do i=1,npart + iphase(i) = isetphase(k,iactive=.true.) + enddo + endif +! +!--set thermal terms and velocity to zero, so only force is gravity +! + polyk = 0. + vxyzu(:,:) = 0. +! +!--make sure AV is off +! + alpha = 0. + alphau = 0. + alphaB = 0. + tolh = 1.e-5 + + fxyzu = 0.0 +! +!--call derivs to get everything initialised +! + call get_derivs_global() +! +!--reset force to zero +! + fxyzu = 0.0 +! +!--move particles to master and sort for direct summation +! + if (mpi) then + ibelong(:) = 0 + call balancedomains(npart) + endif + call sort_part_id +! +!--allocate array for storing direct sum gravitational force +! + allocate(fgrav(maxvxyzu,npart)) + fgrav = 0.0 +! +!--compute gravitational forces by direct summation +! + if (id == master) then + call directsum_grav(xyzh,gradh,fgrav,phitot,npart) + endif +! +!--send phitot to all tasks +! + call bcast_mpi(phitot) +! +!--calculate derivatives +! + call getused(t1) + call get_derivs_global() + call getused(t2) + if (id==master) call printused(t1) +! +!--move particles to master and sort for test comparison +! + if (mpi) then + ibelong(:) = 0 + call balancedomains(npart) + endif + call sort_part_id +! +!--compare the results +! + call checkval(npart,fxyzu(1,:),fgrav(1,:),5.e-3,nfailed(1),'fgrav(x)') + call checkval(npart,fxyzu(2,:),fgrav(2,:),6.e-3,nfailed(2),'fgrav(y)') + call checkval(npart,fxyzu(3,:),fgrav(3,:),9.4e-3,nfailed(3),'fgrav(z)') + deallocate(fgrav) + epoti = 0. + do i=1,npart + epoti = epoti + poten(i) + enddo + epoti = reduceall_mpi('+',epoti) + call checkval(epoti,phitot,5.2e-4,nfailed(4),'potential') + call checkval(epoti,-3./5.*totmass**2/rmax,3.6e-2,nfailed(5),'potential=-3/5 GMM/R') + ! check that potential energy computed via compute_energies is also correct + call compute_energies(0.) + call checkval(epot,phitot,5.2e-4,nfailed(6),'epot in compute_energies') + call update_test_scores(ntests,nfailed(1:6),npass) + endif + enddo + + +!--test that the same results can be obtained from a cloud of sink particles +! with softening lengths equal to the original SPH particle smoothing lengths +! + if (maxptmass >= npart) then + if (id==master) write(*,"(/,3a)") '--> testing gravity in uniform cloud of softened sink particles' +! +!--move particles to master for sink creation +! + if (mpi) then + ibelong(:) = 0 + call balancedomains(npart) + endif +! +!--sort particles so that they can be compared at the end +! + call sort_part_id + + pmassi = totmass/reduceall_mpi('+',npart) + call copy_gas_particles_to_sinks(npart,nptmass,xyzh,xyzmh_ptmass,pmassi) + h_soft_sinksink = hfact*psep +! +!--compute direct sum for comparison, but with fixed h and hence gradh terms switched off +! + do i=1,npart + xyzh(4,i) = h_soft_sinksink + gradh(1,i) = 1. + gradh(2,i) = 0. + vxyzu(:,i) = 0. + enddo + allocate(fgrav(maxvxyzu,npart)) + fgrav = 0.0 + call directsum_grav(xyzh,gradh,fgrav,phitot,npart) + call bcast_mpi(phitot) +! +!--compute gravity on the sink particles +! + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epoti,& + dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) + call bcast_mpi(epoti) +! +!--compare the results +! + tol = 1.e-14 + call checkval(npart,fxyz_ptmass(1,:),fgrav(1,:),tol,nfailed(1),'fgrav(x)') + call checkval(npart,fxyz_ptmass(2,:),fgrav(2,:),tol,nfailed(2),'fgrav(y)') + call checkval(npart,fxyz_ptmass(3,:),fgrav(3,:),tol,nfailed(3),'fgrav(z)') + call checkval(epoti,phitot,8e-3,nfailed(4),'potential') + call checkval(epoti,-3./5.*totmass**2/rmax,4.1e-2,nfailed(5),'potential=-3/5 GMM/R') + call update_test_scores(ntests,nfailed(1:5),npass) + + +! +!--now perform the same test, but with HALF the cloud made of sink particles +! and HALF the cloud made of gas particles. Do not re-evaluate smoothing lengths +! so that the results should be identical to the previous test +! + if (id==master) write(*,"(/,3a)") & + '--> testing softened gravity in uniform sphere with half sinks and half gas' + +!--sort the particles by ID so that the first half will have the same order +! even after half the particles have been converted into sinks. This sort is +! not really necessary because the order shouldn't have changed since the +! last test because derivs hasn't been called since. + call sort_part_id + call copy_half_gas_particles_to_sinks(npart,nptmass,xyzh,xyzmh_ptmass,pmassi) + + print*,' Using ',npart,' SPH particles and ',nptmass,' point masses' + call get_derivs_global() + + epoti = 0.0 + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epoti,& + dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) +! +!--prevent double counting of sink contribution to potential due to MPI +! + if (id /= master) epoti = 0.0 +! +!--allocate an array for the gas contribution to sink acceleration +! + allocate(fxyz_ptmass_gas(size(fxyz_ptmass,dim=1),nptmass)) + fxyz_ptmass_gas = 0.0 + + epot_gas_sink = 0.0 + do i=1,npart + call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& + xyzmh_ptmass,fxyzu(1,i),fxyzu(2,i),fxyzu(3,i),& + phii,pmassi,fxyz_ptmass_gas,dsdt_ptmass,fonrmax,dtsinksink) + epot_gas_sink = epot_gas_sink + pmassi*phii + epoti = epoti + poten(i) + enddo +! +!--the gas contribution to sink acceleration has to be added afterwards to +! prevent double counting the sink contribution when calling reduceall_mpi +! + fxyz_ptmass_gas = reduceall_mpi('+',fxyz_ptmass_gas) + fxyz_ptmass(:,1:nptmass) = fxyz_ptmass(:,1:nptmass) + fxyz_ptmass_gas(:,1:nptmass) + deallocate(fxyz_ptmass_gas) +! +!--sum up potentials across MPI tasks +! + epoti = reduceall_mpi('+',epoti) + epot_gas_sink = reduceall_mpi('+',epot_gas_sink) + +! +!--move particles to master for comparison +! + if (mpi) then + ibelong(:) = 0 + call balancedomains(npart) + endif + call sort_part_id + + call checkval(npart,fxyzu(1,:),fgrav(1,:),5.e-2,nfailed(1),'fgrav(x)') + call checkval(npart,fxyzu(2,:),fgrav(2,:),6.e-2,nfailed(2),'fgrav(y)') + call checkval(npart,fxyzu(3,:),fgrav(3,:),9.4e-2,nfailed(3),'fgrav(z)') + +! +!--fgrav doesn't exist on worker tasks, so it needs to be sent from master +! + call bcast_mpi(npart) + if (id == master) nfgrav = size(fgrav,dim=2) + call bcast_mpi(nfgrav) + if (id /= master) then + deallocate(fgrav) + allocate(fgrav(maxvxyzu,nfgrav)) + endif + call bcast_mpi(fgrav) + + call checkval(nptmass,fxyz_ptmass(1,:),fgrav(1,npart+1:2*npart),2.3e-2,nfailed(4),'fgrav(xsink)') + call checkval(nptmass,fxyz_ptmass(2,:),fgrav(2,npart+1:2*npart),2.9e-2,nfailed(5),'fgrav(ysink)') + call checkval(nptmass,fxyz_ptmass(3,:),fgrav(3,npart+1:2*npart),3.7e-2,nfailed(6),'fgrav(zsink)') + + call checkval(epoti+epot_gas_sink,phitot,8e-3,nfailed(7),'potential') + call checkval(epoti+epot_gas_sink,-3./5.*totmass**2/rmax,4.1e-2,nfailed(8),'potential=-3/5 GMM/R') + call update_test_scores(ntests,nfailed(1:8),npass) + deallocate(fgrav) + endif +! +!--clean up doggie-doos +! + npartoftype(:) = 0 + massoftype(:) = 0. + tree_accuracy = tree_acc_prev + fxyzu = 0. + vxyzu = 0. + +end subroutine test_directsum + +subroutine copy_gas_particles_to_sinks(npart,nptmass,xyzh,xyzmh_ptmass,massi) + integer, intent(in) :: npart + integer, intent(out) :: nptmass + real, intent(in) :: xyzh(:,:),massi + real, intent(out) :: xyzmh_ptmass(:,:) + integer :: i + + nptmass = npart + do i=1,npart + ! make a sink particle with the position of each SPH particle + xyzmh_ptmass(1:3,i) = xyzh(1:3,i) + xyzmh_ptmass(4,i) = massi ! same mass as SPH particles + xyzmh_ptmass(5:,i) = 0. + enddo + +end subroutine copy_gas_particles_to_sinks + +subroutine copy_half_gas_particles_to_sinks(npart,nptmass,xyzh,xyzmh_ptmass,massi) + use io, only: id,master,fatal + use mpiutils, only: bcast_mpi + integer, intent(inout) :: npart + integer, intent(out) :: nptmass + real, intent(in) :: xyzh(:,:),massi + real, intent(out) :: xyzmh_ptmass(:,:) + integer :: i, nparthalf + + nptmass = 0 + nparthalf = npart/2 + + call bcast_mpi(nparthalf) + + if (id==master) then + ! Assuming all gas particles are already on master, + ! create sinks here and send them to other tasks + + ! remove half the particles by changing npart + npart = nparthalf + + do i=npart+1,2*npart + nptmass = nptmass + 1 + call bcast_mpi(nptmass) + ! make a sink particle with the position of each SPH particle + xyzmh_ptmass(1:3,nptmass) = xyzh(1:3,i) + xyzmh_ptmass(4,nptmass) = massi ! same mass as SPH particles + xyzmh_ptmass(5:,nptmass) = 0. + call bcast_mpi(xyzmh_ptmass(1:5,nptmass)) + enddo + else + ! Assuming there are no gas particles here, + ! get sinks from master + + if (npart /= 0) call fatal("copy_half_gas_particles_to_sinks","there are particles on a non-master task") + + ! Get nparthalf from master, but don't change npart from zero + do i=nparthalf+1,2*nparthalf + call bcast_mpi(nptmass) + call bcast_mpi(xyzmh_ptmass(1:5,nptmass)) + enddo + endif + +end subroutine copy_half_gas_particles_to_sinks + +subroutine get_dx_dr(x1,x2,dx,dr) + real, intent(in) :: x1(3),x2(3) + real, intent(out) :: dx(3),dr + + dx = x1 - x2 + dr = 1./sqrt(dot_product(dx,dx)) + +end subroutine get_dx_dr + +subroutine get_finite_diff(ndim,x0,xposj,totmass,quads,fnode,dfdx,dpot,d2f,eps) + use kdtree, only:compute_fnode + integer, intent(in) :: ndim + real, intent(in) :: x0(ndim),xposj(ndim),totmass,quads(6),fnode(20),eps + real, intent(out) :: dfdx(ndim,ndim),dpot(ndim),d2f(ndim,ndim) + integer :: i,j + real :: dx(ndim),x0_plus(ndim),x0_minus(ndim) + real :: dr,fnode_plus(20),fnode_minus(20) + + do j=1,ndim + x0_plus = x0 + x0_plus(j) = x0(j) + eps + x0_minus = x0 + x0_minus(j) = x0(j) - eps + do i=1,ndim + call get_dx_dr(x0_plus,xposj,dx,dr) + fnode_plus = 0. + call compute_fnode(dx(1),dx(2),dx(3),dr,totmass,quads,fnode_plus) + + call get_dx_dr(x0_minus,xposj,dx,dr) + fnode_minus = 0. + call compute_fnode(dx(1),dx(2),dx(3),dr,totmass,quads,fnode_minus) + + dfdx(i,j) = (fnode_plus(i) - fnode_minus(i))/(2.*eps) + d2f(i,j) = (fnode_plus(i) - 2.*fnode(i) + fnode_minus(i))/(eps*eps) + enddo + dpot(j) = -(fnode_plus(20) - fnode_minus(20))/(2.*eps) + enddo + +end subroutine get_finite_diff + +end module testgravity diff --git a/src/tests/test_growth.f90 b/src/tests/test_growth.f90 new file mode 100644 index 000000000..01190a85b --- /dev/null +++ b/src/tests/test_growth.f90 @@ -0,0 +1,394 @@ +!--------------------------------------------------------------------------! +! 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 testgrowth +! +! Unit tests of the growth module +! +! :References: +! +! :Owner: Arnaud Vericel +! +! :Runtime parameters: None +! +! :Dependencies: boundary, checksetup, deriv, dim, dust, energies, eos, +! growth, io, kernel, mpidomain, mpiutils, options, part, physcon, +! step_lf_global, testdust, testutils, timestep, unifdis, units, +! viscosity +! + use testutils, only:checkval,update_test_scores + use io, only:id,master + use testdust, only:test_dustybox + implicit none + public :: test_growth + + private + +contains +!----------------------------------------------------------------------- +!+ +! Unit tests for dust growth using Stepinksi & Valageas method +!+ +!----------------------------------------------------------------------- +subroutine test_growth(ntests,npass) + use dim, only:use_dust,use_dustgrowth + use growth, only:init_growth,ifrag,isnow + use physcon, only:solarm,au + use units, only:set_units + use mpiutils, only:barrier_mpi + integer, intent(inout) :: ntests,npass + integer :: nfailed(5),ierr !don't forget the dimension of nfailed + logical, dimension(2) :: logic = (/.false., .true./) + integer :: i,j + + if (use_dust .and. use_dustgrowth) then + if (id==master) write(*,"(/,a)") '--> TESTING DUSTGROWTH MODULE' + else + if (id==master) write(*,"(/,a)") '--> SKIPPING DUSTGROWTH TEST (REQUIRES -DDUST -DDUSTGROWTH)' + return + endif + + call set_units(mass=solarm,dist=au,G=1.d0) + + if (id==master) write(*,"(/,a)") '--> testing growth initialisation' + + nfailed = 0 + do ifrag=0,2 + do isnow=0,2 + call init_growth(ierr) + call checkval(ierr,0,0,nfailed(ifrag+isnow+1),'growth initialisation') + enddo + enddo + call update_test_scores(ntests,nfailed,npass) + + ! + ! The return of the dustybox test + ! + call test_dustybox(ntests,npass) + call barrier_mpi() + + ! + ! testing farmingbox with several config. + ! + do i=1,2 + do j=1,2 + call test_farmingbox(ntests,npass,frag=logic(i),onefluid=logic(j)) + call barrier_mpi() + enddo + enddo + + if (id==master) write(*,"(/,a)") '<-- DUSTGROWTH TEST COMPLETE' + +end subroutine test_growth + +!------------------- +!------------------- +!------------------- + +subroutine test_farmingbox(ntests,npass,frag,onefluid) + use boundary, only:set_boundary,xmin,xmax,ymin,ymax,zmin,zmax,dxbound,dybound,dzbound + use kernel, only:hfact_default + use part, only:init_part,igas,idust,npart,xyzh,vxyzu,npartoftype,& + massoftype,set_particle_type,& + fxyzu,fext,Bevol,dBevol,dustprop,ddustprop,& + dustfrac,dustevol,ddustevol,iphase,maxtypes,& + VrelVf,dustgasprop,Omega_k,alphaind,iamtype,& + ndustlarge,ndustsmall,rhoh,deltav,this_is_a_test,periodic, & + npartoftypetot,update_npartoftypetot + use step_lf_global, only:step,init_step + use deriv, only:get_derivs_global + use energies, only:compute_energies + use testutils, only:checkvalbuf,checkvalbuf_end + use eos, only:ieos,polyk,gamma,get_spsound + use dust, only:idrag,init_drag + use growth, only:ifrag,init_growth,isnow,vfrag,gsizemincgs,get_size + use options, only:alpha,alphamax,use_dustfrac + use unifdis, only:set_unifdis + use dim, only:periodic,mhd,use_dust,maxp,maxalpha + use timestep, only:dtmax + use io, only:iverbose + use mpiutils, only:reduceall_mpi + use physcon, only:au,solarm,Ro,pi,fourpi + use viscosity, only:shearparam + use units, only:set_units,udist,unit_density!,unit_velocity + use mpidomain, only:i_belong + use checksetup, only:check_setup + + integer, intent(inout) :: ntests,npass + logical, intent(in) :: frag,onefluid + + integer :: nx,nerror,nwarn + integer :: itype,npart_previous,i,j,nsteps,modu,noutputs + integer :: ncheck(4),nerr(4) + real :: errmax(4) + integer :: ierr,iam + integer, parameter :: ngrid = 20000 + + logical :: do_output = .false. + real :: deltax,dz,hfact,totmass,rhozero + real :: Stcomp(ngrid),Stini(ngrid) + real :: cscomp(ngrid),tau(ngrid) + real :: s(ngrid),time,timelim(ngrid) + real :: sinit,dens,t,tmax,dt,dtext,dtnew,guillaume,dtgratio,rhog,rhod + + real, parameter :: tolst = 5.e-4 + real, parameter :: tolcs = 5.e-4 + real, parameter :: tols = 5.e-4 + real, parameter :: tolrho = 5.e-4 + + character(len=15) :: stringfrag + character(len=15) :: stringmethod + + ! initialise particle arrays to zero + call init_part() + + if (frag) then + sinit = 1./udist + gsizemincgs = 1.e-3 + dtgratio = 0.5 + stringfrag = "fragmentation" + else + sinit = 3.e-2/udist + dtgratio = 1. + stringfrag = "growth" + endif + + if (onefluid) then + use_dustfrac = .true. + stringmethod = "one fluid" + ndustsmall = 1 + ndustlarge = 0 + dtgratio = 1.e-1 + else + use_dustfrac = .false. + stringmethod = "two fluid" + ndustsmall = 0 + ndustlarge = 1 + endif + dens = 1./unit_density + + write(*,"(/,a)") '--> testing FARMINGBOX using: '//trim(stringfrag)//& + ' and '//trim(stringmethod)//' dust method' + ! + ! initialise + ! + this_is_a_test = .true. + + ! + ! setup for dustybox problem + ! + nx = 16 + deltax = 1./nx + dz = 2.*sqrt(6.)/nx + call set_boundary(-0.5,0.5,-0.25,0.25,-dz,dz) + hfact = hfact_default + rhozero = 1.e-11/unit_density + totmass = rhozero*dxbound*dybound*dzbound + if (onefluid) then + rhog = rhozero * (1-dtgratio) + rhod = dtgratio * rhozero + else + rhog = rhozero + rhod = dtgratio * rhozero + endif + npart = 0 + fxyzu = 0. + dustprop = 0. + ddustprop = 0. + ddustevol = 0. + dBevol = 0. + if (maxalpha==maxp) alphaind(:,:) = 0. + + !- setting gas particles + itype = igas + npart_previous = npart + call set_unifdis('closepacked',id,master,xmin,xmax,ymin,ymax,zmin,zmax,& + deltax,hfact,npart,xyzh,periodic,verbose=.false.,mask=i_belong) + do i=npart_previous+1,npart + vxyzu(:,i) = 0. + fext(:,i) = 0. + if (mhd) Bevol(:,i) = 0. + if (use_dust) then + dustevol(:,i) = 0. + dustfrac(:,i) = 0. + deltav(:,:,i) = 0. + dustgasprop(:,i) = 0. + VrelVf(i) = 0. + if (use_dustfrac) then + dustfrac(1,i) = dtgratio + dustprop(1,i) = fourpi/3.*dens*sinit**3 + dustprop(2,i) = dens + else + dustprop(:,i) = 0. + dustfrac(:,i) = 0. + endif + endif + call set_particle_type(i,itype) + enddo + npartoftype(itype) = npart - npart_previous + call update_npartoftypetot + massoftype(itype) = totmass/npartoftypetot(itype) + + !- setting dust particles if not one fluid + if (.not. use_dustfrac) then + itype = idust + npart_previous = npart + call set_unifdis('closepacked',id,master,xmin,xmax,ymin,ymax,zmin,zmax,& + deltax,hfact,npart,xyzh,periodic,verbose=.false.,mask=i_belong) + do i=npart_previous+1,npart + vxyzu(:,i) = 0. + fext(:,i) = 0. + if (mhd) Bevol(:,i) = 0. + if (use_dust) then + dustevol(:,i) = 0. + dustfrac(:,i) = 0. + dustprop(1,i) = fourpi/3.*dens*sinit**3 + dustprop(2,i) = dens + dustgasprop(:,i) = 0. + VrelVf(i) = 0. + endif + call set_particle_type(i,itype) + enddo + npartoftype(itype) = npart - npart_previous + npartoftypetot(itype) = reduceall_mpi('+',npartoftype(itype)) + massoftype(itype) = dtgratio*totmass/npartoftypetot(itype) + endif + + ! + ! check that particle setup is sensible + ! + call check_setup(nerror,nwarn) + + ! + ! runtime parameters + ! + + ieos = 1 + idrag = 1 + if (frag) then + ifrag = 1 + shearparam = 2.5e-2 + else + ifrag = 0 + shearparam = 1.e-2 + endif + isnow = 0 + vfrag = 1.e-11 + gsizemincgs = 1.e-2 + polyk = 1.e-3 + gamma = 1. + alpha = 0. + alphamax = 0. + iverbose = 0 + + !- timestepping + dt = 1.e-3 + tmax = 0.2 + nsteps = int(tmax/dt) + noutputs = 150 + if (noutputs > nsteps) noutputs = nsteps + modu = int(nsteps/noutputs) + dtmax = nsteps*dt + + timelim(:) = 1.e3 + ncheck(:) = 0 + nerr(:) = 0 + errmax(:) = 0. + + t = 0. + + call init_drag(ierr) + call init_growth(ierr) + + call get_derivs_global() + + call init_step(npart,t,dtmax) + + do j=1,npart + iam = iamtype(iphase(j)) + if (iam == idust .or. (use_dustfrac .and. iam == igas)) then + cscomp(j) = get_spsound(ieos,xyzh(:,j),rhog,vxyzu(:,j)) + Stini(j) = sqrt(pi*gamma/8)*dens*sinit/((rhog+rhod)*cscomp(j)) * Omega_k(j) + Stcomp(j) = Stini(j) + tau(j) = 1/(sqrt(2**1.5*Ro*shearparam)*Omega_k(j))*(rhog+rhod)/rhod/sqrt(pi*gamma/8.) + s(j) = sinit + timelim(j) = 2*sqrt(Stini(j))*(1.+Stini(j)/3.)*tau(j) + endif + enddo + if (frag) write(*,"(a,f5.1,a)") "Analytical solution no longer valid after t = ", minval(timelim), " (size < 0)" + + ! + ! run farmingbox problem + ! + do i=1,nsteps + dtext = dt + call step(npart,npart,t,dt,dtext,dtnew) + t = t + dt + if (do_output .and. mod(i,modu)==0) then + call write_file_err(i,t,xyzh,dustprop(1,:)*udist,s*udist,& + dustgasprop(3,:),Stcomp,npart,"farmingbox_") + endif + do j=1,npart + iam = iamtype(iphase(j)) + if (iam == idust .or. (iam == igas .and. use_dustfrac)) then + if (frag) then + time = - t/tau(j) + 2.*sqrt(Stini(j))*(1.+Stini(j)/3.) + else + time = 2.*sqrt(Stini(j))*(1.+Stini(j)/3.) + t/tau(j) + endif + guillaume = (8.+9.*time*time+3.*time*sqrt(16.+9.*time*time))**(1./3.) + Stcomp(j) = guillaume/2. + 2./guillaume - 2 + s(j) = Stcomp(j)/(sqrt(pi*gamma/8)*dens/((rhog+rhod)*cscomp(j))*Omega_k(j)) + if (onefluid) then + call checkvalbuf(dustgasprop(3,j)/Stcomp(j),1.,tolst,'St',nerr(1),ncheck(1),errmax(1)) + call checkvalbuf(get_size(dustprop(1,j),dustprop(2,j))/s(j),1.,tols,'size',nerr(2),ncheck(2),errmax(2)) + else + call checkvalbuf(dustgasprop(3,j)/Stcomp(j),1.,tolst,'St',nerr(1),ncheck(1),errmax(1)) + call checkvalbuf(get_size(dustprop(1,j),dustprop(2,j))/s(j),1.,tols,'size',nerr(2),ncheck(2),errmax(2)) + call checkvalbuf(dustgasprop(1,j)/cscomp(j),1.,tolcs,'csound',nerr(3),ncheck(3),errmax(3)) + call checkvalbuf(dustgasprop(2,j)/rhozero,1.,tolrho,'rhogas',nerr(4),ncheck(4),errmax(4)) + endif + endif + enddo + enddo + if (onefluid) then + call checkvalbuf_end('Stokes number evaluation matches exact solution',ncheck(1),nerr(1),errmax(1),tolst) + call checkvalbuf_end('size evaluation matches exact solution',ncheck(2),nerr(2),errmax(2),tols) + else + call checkvalbuf_end('Stokes number interpolation matches exact solution',ncheck(1),nerr(1),errmax(1),tolst) + call checkvalbuf_end('size evaluation matches exact solution',ncheck(2),nerr(2),errmax(2),tols) + call checkvalbuf_end('sound speed interpolation matches exact number',ncheck(3),nerr(3),errmax(3),tolcs) + call checkvalbuf_end('rhogas interpolation matches exact number',ncheck(4),nerr(4),errmax(4),tolrho) + endif + + call update_test_scores(ntests,nerr,npass) + +end subroutine test_farmingbox + +subroutine write_file_err(step,t,xyzh,gsize,gsize_exact,St,St_exact,npart,prefix) + use part, only:iamdust,iphase,iamgas + real, intent(in) :: t + real, intent(in) :: xyzh(:,:) + real, intent(in) :: St(:),St_exact(:) + real(kind=8), intent(in) :: gsize(:),gsize_exact(:) + character(len=*), intent(in) :: prefix + integer, intent(in) :: npart,step + character(len=30) :: filename,str + integer :: i,lu + + write(str,"(i000.4)") step + filename = prefix//'dust_'//trim(adjustl(str))//'.txt' + open(newunit=lu,file=filename,status='replace') + write(lu,*) t + do i=1,npart + if (iamdust(iphase(i))) write(lu,*) xyzh(1,i),xyzh(2,i),xyzh(3,i),gsize(i),gsize_exact(i),& + St(i),St_exact(i) + enddo + close(lu) + +end subroutine write_file_err + +end module testgrowth From cbfd9951baf53e08a1b3494c2e5d509e4ec978bc Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 12 Apr 2024 12:59:15 +1000 Subject: [PATCH 413/814] main refactory of step extern... (still need to merge extrap force and force ) --- src/main/part.F90 | 4 + src/main/ptmass.F90 | 142 ++++++----- src/main/step_extern.F90 | 496 +++++++++++++++++++++++++++------------ 3 files changed, 420 insertions(+), 222 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index 8fd586af6..362587bc2 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -204,10 +204,12 @@ module part integer, parameter :: i_mlast = 17 ! accreted mass of last time integer, parameter :: imassenc = 18 ! mass enclosed in sink softening radius integer, parameter :: iJ2 = 19 ! 2nd gravity moment due to oblateness + integer, parameter :: ndptmass = 13 ! number of properties to conserve after a accretion phase or merge real, allocatable :: xyzmh_ptmass(:,:) real, allocatable :: vxyz_ptmass(:,:) real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:),fsink_old(:,:) real, allocatable :: dsdt_ptmass(:,:),dsdt_ptmass_sinksink(:,:) + real, allocatable :: dptmass(:,:) integer :: nptmass = 0 ! zero by default real :: epot_sinksink character(len=*), parameter :: xyzmh_ptmass_label(nsinkproperties) = & @@ -432,6 +434,7 @@ subroutine allocate_part call allocate_array('fxyz_ptmass', fxyz_ptmass, 4, maxptmass) call allocate_array('fxyz_ptmass_sinksink', fxyz_ptmass_sinksink, 4, maxptmass) call allocate_array('fsink_old', fsink_old, 4, maxptmass) + call allocate_array('dptmass', dptmass, ndptmass,maxptmass) call allocate_array('dsdt_ptmass', dsdt_ptmass, 3, maxptmass) call allocate_array('dsdt_ptmass_sinksink', dsdt_ptmass_sinksink, 3, maxptmass) call allocate_array('poten', poten, maxgrav) @@ -519,6 +522,7 @@ subroutine deallocate_part if (allocated(fxyz_ptmass)) deallocate(fxyz_ptmass) if (allocated(fxyz_ptmass_sinksink)) deallocate(fxyz_ptmass_sinksink) if (allocated(fsink_old)) deallocate(fsink_old) + if (allocated(dptmass)) deallocate(dptmass) if (allocated(dsdt_ptmass)) deallocate(dsdt_ptmass) if (allocated(dsdt_ptmass_sinksink)) deallocate(dsdt_ptmass_sinksink) if (allocated(poten)) deallocate(poten) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index eab603fea..55ae74c89 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -93,7 +93,6 @@ module ptmass character(len=50), private :: pt_prefix = 'Sink' character(len=50), private :: pt_suffix = '00.sink' ! will be overwritten to .ev for write_one_ptfile = .false. - integer, public, parameter :: ndptmass = 13 integer, public, parameter :: & idxmsi = 1, & idymsi = 2, & @@ -757,106 +756,97 @@ end subroutine ptmass_boundary_crossing ! (called from inside a parallel section) !+ !---------------------------------------------------------------- -subroutine ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) +subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass) integer, intent(in) :: nptmass - real, intent(in) :: dt + real, intent(in) :: ckdt real, intent(inout) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: vxyz_ptmass(3,nptmass) - real, intent(in) :: fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real :: vxhalfi,vyhalfi,vzhalfi + real, intent(in) :: dsdt_ptmass(3,nptmass) integer :: i !$omp parallel do schedule(static) default(none) & - !$omp shared(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) & - !$omp private(i,vxhalfi,vyhalfi,vzhalfi) + !$omp shared(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass) & + !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then - vxhalfi = vxyz_ptmass(1,i) + 0.5*dt*fxyz_ptmass(1,i) - vyhalfi = vxyz_ptmass(2,i) + 0.5*dt*fxyz_ptmass(2,i) - vzhalfi = vxyz_ptmass(3,i) + 0.5*dt*fxyz_ptmass(3,i) - xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dt*vxhalfi - xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dt*vyhalfi - xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dt*vzhalfi - vxyz_ptmass(1,i) = vxhalfi - vxyz_ptmass(2,i) = vyhalfi - vxyz_ptmass(3,i) = vzhalfi - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + 0.5*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + 0.5*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + 0.5*dt*dsdt_ptmass(3,i) + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ckdt*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ckdt*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ckdt*vxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + ckdt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + ckdt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + ckdt*dsdt_ptmass(3,i) endif enddo !$omp end parallel do -end subroutine ptmass_predictor +end subroutine ptmass_drift !---------------------------------------------------------------- !+ -! corrector step for the point masses -! (called from inside a parallel section) +! kick step for the point masses !+ !---------------------------------------------------------------- -subroutine ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,iexternalforce) - use externalforces, only:update_vdependent_extforce_leapfrog,is_velocity_dependent +subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass) integer, intent(in) :: nptmass - real, intent(in) :: dt + real, intent(in) :: dkdt real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) real, intent(in) :: fxyz_ptmass(4,nptmass) real, intent(in) :: dsdt_ptmass(3,nptmass) + integer :: i + + + !$omp parallel do schedule(static) default(none) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,nptmass) & + !$omp private(i) + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dkdt*fxyz_ptmass(1,i) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dkdt*fxyz_ptmass(2,i) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dkdt*fxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) + endif + enddo + !$omp end parallel do + + +end subroutine ptmass_kick + +!---------------------------------------------------------------- +!+ +! force correction due to vdep force. +!+ +!---------------------------------------------------------------- +subroutine ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) + integer, intent(in) :: nptmass + real, intent(in) :: dkdt + real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(in) :: fxyz_ptmass(4,nptmass) integer, intent(in) :: iexternalforce - real :: vxhalfi,vyhalfi,vzhalfi real :: fxi,fyi,fzi,fextv(3) integer :: i - ! - ! handle special case of velocity-dependent external forces - ! in the leapfrog integrator - ! - if (is_velocity_dependent(iexternalforce)) then - !$omp parallel do schedule(static) default(none) & - !$omp shared(vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,dt,nptmass,iexternalforce) & - !$omp private(vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi,fextv) & - !$omp private(i) - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - vxhalfi = vxyz_ptmass(1,i) - vyhalfi = vxyz_ptmass(2,i) - vzhalfi = vxyz_ptmass(3,i) - fxi = fxyz_ptmass(1,i) - fyi = fxyz_ptmass(2,i) - fzi = fxyz_ptmass(3,i) - call update_vdependent_extforce_leapfrog(iexternalforce,& - vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi,fextv,dt,& - xyzmh_ptmass(1,i),xyzmh_ptmass(2,i),xyzmh_ptmass(3,i)) - fxi = fxi + fextv(1) - fyi = fyi + fextv(2) - fzi = fzi + fextv(3) - vxyz_ptmass(1,i) = vxhalfi + 0.5*dt*fxi - vxyz_ptmass(2,i) = vyhalfi + 0.5*dt*fyi - vxyz_ptmass(3,i) = vzhalfi + 0.5*dt*fzi - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + 0.5*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + 0.5*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + 0.5*dt*dsdt_ptmass(3,i) - endif - enddo - !$omp end parallel do - else - !$omp parallel do schedule(static) default(none) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,nptmass) & - !$omp private(i) - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + 0.5*dt*fxyz_ptmass(1,i) - vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + 0.5*dt*fxyz_ptmass(2,i) - vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + 0.5*dt*fxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + 0.5*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + 0.5*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + 0.5*dt*dsdt_ptmass(3,i) - endif - enddo - !$omp end parallel do - endif - -end subroutine ptmass_corrector + !$omp parallel do schedule(static) default(none) & + !$omp shared(vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dkdt,nptmass,iexternalforce) & + !$omp private(fxi,fyi,fzi,fextv) & + !$omp private(i) + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + fxi = fxyz_ptmass(1,i) + fyi = fxyz_ptmass(2,i) + fzi = fxyz_ptmass(3,i) + call update_vdependent_extforce_leapfrog(iexternalforce,& + vxyz_ptmass(1,i),vxyz_ptmass(2,i),vxyz_ptmass(3,i), & + fxi,fyi,fzi,fextv,dkdt,xyzmh_ptmass(1,i),xyzmh_ptmass(2,i), & + xyzmh_ptmass(3,i)) + fxyz_ptmass(1,i) = fxi + fextv(1) + fxyz_ptmass(2,i) = fyi + fextv(2) + fxyz_ptmass(3,i) = fzi + fextv(3) + endif + enddo + !$omp end parallel do +end subroutine ptmass_vdependent_correction !---------------------------------------------------------------- !+ diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 4f629667c..68b2e5364 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -512,12 +512,12 @@ end subroutine step_extern_FSI !+ !---------------------------------------------------------------- -subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) +subroutine drift(ck,dt,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) use part, only:isdead_or_accreted,ispinx,ispiny,ispinz use io , only:id,master use mpiutils, only:bcast_mpi real, intent(in) :: dt,ck - integer, intent(in) :: npart,nptmass + integer, intent(in) :: npart,nptmass,ntypes real, intent(inout) :: xyzh(:,:),vxyzu(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) real :: ckdt @@ -542,24 +542,11 @@ subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsd ! Drift sink particles if(nptmass>0) then if(id==master) then - !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ckdt) & - !$omp private(i) - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ckdt*vxyz_ptmass(1,i) - xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ckdt*vxyz_ptmass(2,i) - xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ckdt*vxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + ckdt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + ckdt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + ckdt*dsdt_ptmass(3,i) - endif - enddo - !$omp end parallel do + call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass) endif call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) endif -end subroutine drift_4th +end subroutine drift !---------------------------------------------------------------- @@ -568,57 +555,172 @@ end subroutine drift_4th !+ !---------------------------------------------------------------- -subroutine kick_4th(dk,dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - use part, only: isdead_or_accreted,ispinx,ispiny,ispinz - use io , only:id,master - use mpiutils, only:bcast_mpi - real, intent(in) :: dt,dk - integer, intent(in) :: npart,nptmass - real, intent(in) :: xyzh(:,:) - real, intent(inout) :: vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - integer :: i - real :: dkdt +subroutine kick(dk,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei) + use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz + use ptmass, only:f_acc,ptmass_accrete + use externalforces, only:accrete_particles + use options, only:iexternalforce + use io , only:id,master,fatal + use mpiutils, only:bcast_mpi + use dim, only:ind_timesteps + use timestep_sts, only:sts_it_n + real, intent(in) :: dt,dk + integer, intent(in) :: npart,nptmass,ntypes + real, intent(in) :: xyzh(:,:) + real, intent(inout) :: vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + real, optional, intent(in) :: dptmass(:,:) + real, optional, intent(in) :: timei + integer(kind=1), optional, intent(inout) :: ibin_wake(:) + integer(kind=1), optional, intent(in) :: nbinmax + logical :: is_accretion,accreted + integer :: i,itype,ibin_wakei,nfaili + integer :: naccreted,nfail,nlive + real :: dkdt,pmassi,fxi,fyi,fzi,accretedmass + + if (present(dptmass) .and. present(timei) .and. present(ibin_wake) .and. present(nbinmax)) then + is_accretion = .true. + else + is_accretion = .false. + endif dkdt = dk*dt - ! Kick gas particles - - !$omp parallel do default(none) & - !$omp shared(npart,fext,xyzh,vxyzu,dkdt) & - !$omp private(i) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - vxyzu(1,i) = vxyzu(1,i) + dkdt*fext(1,i) - vxyzu(2,i) = vxyzu(2,i) + dkdt*fext(2,i) - vxyzu(3,i) = vxyzu(3,i) + dkdt*fext(3,i) - endif - enddo - !$omp end parallel do - ! Kick sink particles if (nptmass>0) then if(id==master) then - !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,dsdt_ptmass,dkdt) & - !$omp private(i) - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dkdt*fxyz_ptmass(1,i) - vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dkdt*fxyz_ptmass(2,i) - vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dkdt*fxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) + call ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass) + endif + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + call bcast_mpi(xyzmh_ptmass(ispinx,1:nptmass)) + call bcast_mpi(xyzmh_ptmass(ispiny,1:nptmass)) + call bcast_mpi(xyzmh_ptmass(ispinz,1:nptmass)) + endif + + + ! Kick gas particles + + if (.not.is_accretion) then + !$omp parallel do default(none) & + !$omp shared(maxp,maxphase) & + !$omp shared(iphase,ntypes) & + !$omp shared(npart,fext,xyzh,vxyzu,dkdt) & + !$omp firstprivate(itype) & + !$omp private(i) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + if (ntypes > 1 .and. maxphase==maxp) then + itype = iamtype(iphase(i)) + if (iamboundary(itype)) cycle endif - enddo - !$omp end parallel do + vxyzu(1,i) = vxyzu(1,i) + dkdt*fext(1,i) + vxyzu(2,i) = vxyzu(2,i) + dkdt*fext(2,i) + vxyzu(3,i) = vxyzu(3,i) + dkdt*fext(3,i) + endif + enddo + !$omp end parallel do + else + accretedmass = 0. + nfail = 0 + naccreted = 0 + nlive = 0 + ibin_wakei = 0 + dptmass(:,1:nptmass) = 0. + !$omp parallel default(none) & + !$omp shared(maxp,maxphase) & + !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & + !$omp shared(iexternalforce) & + !$omp shared(nbinmax,ibin_wake) & + !$omp reduction(+:dptmass) & + !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & + !$omp firstprivate(itype,pmassi,ibin_wakei) & + !$omp reduction(+:accretedmass,nfail,naccreted,nlive) + !$omp do + accreteloop: do i=1,npart + 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 + endif + ! + ! correct v to the full step using only the external force + ! + vxyzu(1,i) = vxyzu(1,i) + dkdt*fext(1,i) + vxyzu(2,i) = vxyzu(2,i) + dkdt*fext(2,i) + vxyzu(3,i) = vxyzu(3,i) + dkdt*fext(3,i) + + if (iexternalforce > 0) then + call accrete_particles(iexternalforce,xyzh(1,i),xyzh(2,i), & + xyzh(3,i),xyzh(4,i),pmassi,timei,accreted) + if (accreted) accretedmass = accretedmass + pmassi + endif + ! + ! accretion onto sink particles + ! need position, velocities and accelerations of both gas and sinks to be synchronised, + ! otherwise will not conserve momentum + ! Note: requiring sts_it_n since this is supertimestep with the most active particles + ! + if (nptmass > 0 .and. sts_it_n) then + fxi = fext(1,i) + fyi = fext(2,i) + fzi = fext(3,i) + if (ind_timesteps) ibin_wakei = ibin_wake(i) + + call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& + vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxi,fyi,fzi,& + itype,pmassi,xyzmh_ptmass,vxyz_ptmass,& + accreted,dptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) + if (accreted) then + naccreted = naccreted + 1 + cycle accreteloop + else + if (ind_timesteps) ibin_wake(i) = ibin_wakei + endif + if (nfaili > 1) nfail = nfail + 1 + endif + nlive = nlive + 1 + endif + enddo accreteloop + !$omp enddo + !$omp end parallel + + if (npart > 2 .and. nlive < 2) then + call fatal('step','all particles accreted',var='nlive',ival=nlive) + endif + +! +! reduction of sink particle changes across MPI +! + if (nptmass > 0) then + call reduce_in_place_mpi('+',dptmass(:,1:nptmass)) + + naccreted = int(reduceall_mpi('+',naccreted)) + nfail = int(reduceall_mpi('+',nfail)) + + if (id==master) call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) + + call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + call bcast_mpi(fxyz_ptmass(:,1:nptmass)) + endif + + if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a,i4,a)") & + 'Step: at time ',timei,', ',naccreted,' particles were accreted amongst ',nptmass,' sink(s).' + + if (nptmass > 0) then + call summary_accrete_fail(nfail) + call summary_accrete(nptmass) + ! only write to .ev during substeps if no gas particles present + if (npart==0) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & + fxyz_ptmass,fxyz_ptmass_sinksink) endif - call bcast_mpi(vxyz_ptmass(:,1:nptmass)) endif -end subroutine kick_4th + +end subroutine kick !---------------------------------------------------------------- !+ @@ -626,25 +728,35 @@ end subroutine kick_4th !+ !---------------------------------------------------------------- -subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - use options, only:iexternalforce - use dim, only:maxptmass - use io, only:iverbose,master,id,iprint,warning,fatal - use part, only:epot_sinksink,fxyz_ptmass_sinksink,dsdt_ptmass_sinksink - use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks - use timestep, only:bignumber,C_force - use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi - integer, intent(in) :: nptmass,npart,nsubsteps - real, intent(inout) :: xyzh(:,:),fext(:,:) +subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck,dk) + use io, only:iverbose,master,id,iprint,warning,fatal + use dim, only:maxp,maxvxyzu,itau_alloc + use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks + 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 + 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 + use damping, only:apply_damp,idamp + use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation + integer, intent(in) :: nptmass,npart,nsubsteps,ntypes + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) real, intent(inout) :: dtextforce - real, intent(in) :: timei,pmassi + real, intent(in) :: timei,ck,dk,dt integer :: merge_ij(nptmass) integer :: merge_n - integer :: i + integer :: i,itype real :: dtf,dtextforcenew,dtsinkgas,dtphi2,fonrmax - real :: fextx,fexty,fextz + real :: fextx,fexty,fextz,pmassi real :: fonrmaxi,phii,dtphi2i + real :: dkdt,ckdt + + dkdt = dk*dt + ckdt = ck*dt dtextforcenew = bignumber dtsinkgas = bignumber @@ -671,33 +783,78 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe call bcast_mpi(dtf) dtextforcenew = min(dtextforcenew,C_force*dtf) endif - if (iverbose >= 3 ) write(iprint,*) "dt_sink_sink",dtextforcenew + + !$omp parallel default(none) & - !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext) & - !$omp private(fextx,fexty,fextz) & - !$omp private(fonrmaxi,dtphi2i,phii,pmassi,dtf) & + !$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,ckdt,timei,iexternalforce,extf_is_velocity_dependent) & + !$omp shared(divcurlv,dphotflag,dphot0,nucleation) & + !$omp shared(abundc,abundo,abundsi,abunde) & + !$omp private(fextx,fexty,fextz,itype) & + !$omp private(i,fonrmaxi,dtphi2i,phii,dtf) & + !$omp firstprivate(pmassi,itype) & !$omp reduction(min:dtextforcenew,dtphi2) & !$omp reduction(max:fonrmax) & !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) !$omp do do i=1,npart + if (ntypes > 1 .and. maxphase==maxp) then + itype = iamtype(iphase(i)) + pmassi = massoftype(itype) + endif fextx = 0. fexty = 0. fextz = 0. - call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,& + if (nptmass>0) then + call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,& fextx,fexty,fextz,phii,pmassi,fxyz_ptmass,dsdt_ptmass,fonrmaxi,dtphi2i) - fonrmax = max(fonrmax,fonrmaxi) - dtphi2 = min(dtphi2,dtphi2i) + fonrmax = max(fonrmax,fonrmaxi) + dtphi2 = min(dtphi2,dtphi2i) + endif + + ! + ! compute and add external forces + ! + if (iexternalforce > 0) then + call external_force_update_gas(xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i), & + vxyzu(1,i),vxyzu(1,i),vxyzu(1,i),timei,i, & + dtextforcenew,dtf,dkdt,fextx,fexty,fextz, & + extf_is_velocity_dependent,iexternalforce) + endif + + if (idamp > 0) then + call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), xyzh(1:3,i), damp_fac) + endif + fext(1,i) = fextx fext(2,i) = fexty fext(3,i) = fextz + + if (maxvxyzu >= 4 .and. itype==igas) then + call cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & + divcurlv,abundc,abunde,abundo,abundsi,ckdt,dphot0,idK2,idmu,idkappa, & + idgamma,imu,igamma,nabn,dphotflag,nabundances) + endif enddo !$omp enddo !$omp end parallel + if (nptmass > 0 .and. isink_radiation > 0) then + if (itau_alloc == 1) then + call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) + else + call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext) + endif + endif + if (nptmass > 0) then call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + if(id==master) then + call ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) + endif endif if(nptmass>0) then @@ -706,68 +863,13 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe endif if (iverbose >= 3 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas dtextforcenew = min(dtextforcenew,dtsinkgas) - dtextforce = dtextforcenew endif dtextforcenew = reduceall_mpi('min',dtextforcenew) + dtextforce = dtextforcenew -end subroutine get_force_4th - - !---------------------------------------------------------------- - !+ - ! grad routine for the 4th order scheme (FSI) - !+ - !---------------------------------------------------------------- - - -subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old) - use dim, only:maxptmass - use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink - use mpiutils, only:reduce_in_place_mpi - use io, only:id,master - integer, intent(in) :: nptmass,npart - real, intent(inout) :: xyzh(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) - real, intent(in) :: fsink_old(4,nptmass) - real, intent(inout) :: dt - real, intent(in) :: pmassi - real :: fextx,fexty,fextz - integer :: i - - - if (nptmass>0) then - if(id==master) then - call get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old) - else - fxyz_ptmass(:,:) = 0. - endif - endif - - !$omp parallel default(none) & - !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,dt,pmassi,fsink_old) & - !$omp private(fextx,fexty,fextz) & - !$omp reduction(+:fxyz_ptmass) - !$omp do - do i=1,npart - fextx = fext(1,i) - fexty = fext(2,i) - fextz = fext(3,i) - call get_gradf_sink_gas(nptmass,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - xyzmh_ptmass,fextx,fexty,fextz,pmassi,fxyz_ptmass,fsink_old) - fext(1,i) = fext(1,i)+ fextx - fext(2,i) = fext(2,i)+ fexty - fext(3,i) = fext(3,i)+ fextz - enddo - !$omp enddo - !$omp end parallel - - if (nptmass > 0) then - call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - !call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) - endif - -end subroutine get_gradf_4th +end subroutine get_force !---------------------------------------------------------------- !+ @@ -841,6 +943,7 @@ subroutine get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce, !$omp enddo !$omp end parallel + if (nptmass > 0) then call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) @@ -942,11 +1045,11 @@ end subroutine cooling_abundances_update -subroutine external_force_update(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew,dtf,dt, & +subroutine external_force_update_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew,dtf,dkdt, & fextx,fexty,fextz,extf_is_velocity_dependent,iexternalforce) use timestep, only:C_force use externalforces, only: externalforce,update_vdependent_extforce_leapfrog - real, intent(in) :: xi,yi,zi,hi,vxi,vyi,vzi,timei,dt + real, intent(in) :: xi,yi,zi,hi,vxi,vyi,vzi,timei,dkdt real, intent(inout) :: dtextforcenew,dtf,fextx,fexty,fextz integer, intent(in) :: iexternalforce,i logical, intent(in) :: extf_is_velocity_dependent @@ -969,14 +1072,14 @@ subroutine external_force_update(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew,d fextyi = fexty fextzi = fextz call update_vdependent_extforce_leapfrog(iexternalforce,vxi,vyi,vzi, & - fextxi,fextyi,fextzi,fextv,dt,xi,yi,zi) + fextxi,fextyi,fextzi,fextv,dkdt,xi,yi,zi) fextx = fextx + fextv(1) fexty = fexty + fextv(2) fextz = fextz + fextv(3) endif -end subroutine external_force_update +end subroutine external_force_update_gas @@ -1011,15 +1114,10 @@ subroutine step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,ti use timestep, only:bignumber,C_force use timestep_sts, only:sts_it_n use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi - use damping, only:calc_damp,apply_damp,idamp + use damping, only:calc_damp,apply_damp use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation - use cooling, only:energ_cooling,cooling_in_step - use dust_formation, only:evolve_dust,calc_muGamma - use units, only:unit_density -#ifdef KROME - use part, only: T_gas_cool - use krome_interface, only: update_krome -#endif + + integer, intent(in) :: npart,ntypes,nptmass real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce @@ -1367,4 +1465,110 @@ subroutine step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,ti end subroutine step_extern_lf +subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & + nbinmax,ibin_wake) + use io, only:iverbose,id,master,iprint + use options, only:iexternalforce + use part, only:abundance,eos_vars,divcurlv,fxyz_ptmass_sinksink, & + dsdt_ptmass_sinksink,dust_temp,tau,nucleation + use cooling_ism, only:dphot0,dphotflag,abundsi,abundo,abunde,abundc,nabn + use io_summary, only:summary_variable,iosumextr,iosumextt + use damping, only:calc_damp + integer, intent(in) :: npart,ntypes,nptmass + real, intent(in) :: dtsph,time + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + real, intent(inout) :: dptmass(:,:) + integer(kind=1), intent(in) :: nbinmax + integer(kind=1), intent(inout) :: ibin_wake(:) + ! + ! determine whether or not to use substepping + ! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + timei = time + extf_is_velocity_dependent = is_velocity_dependent(iexternalforce) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + + substeps: do while (timei <= t_end_step .and. .not.done) + timei = timei + dt + if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + nsubsteps = nsubsteps + 1 + + if (.not.last_step .and. iverbose > 1 .and. id==master) then + write(iprint,"(a,f14.6)") '> external/ptmass forces only : t=',timei + endif + ! + ! update time-dependent external forces + ! + call calc_damp(time, damp_fac) + call update_externalforce(iexternalforce,timei,dmdt) + + ! + ! Main integration scheme + ! + call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call drift(ck(1),dt,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + + call get_force(nptmass,npart,nsubsteps,ntypestimei,dtextforce,xyzh,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2)) + + if (int_precision == 2) then + ! the last kick phase of the scheme will perform the accretion loop after velocity update + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei) + elseif (int_precision == 4) then + ! FSFI extrapolation method (Omelyan 2006) + fsink_old = fxyz_ptmass + call get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2)) + + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call drift(ck(2),dt,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + + call get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2)) + ! 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) + endif + + + dtextforce_min = min(dtextforce_min,dtextforce) + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + enddo substeps + + if (nsubsteps > 1) then + if (iverbose>=1 .and. id==master) then + write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + +end subroutine step_extern_pattern + + end module step_extern From a6e079d1c62c6413016932e89e348da7ac5aada2 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 12 Apr 2024 16:53:47 +1000 Subject: [PATCH 414/814] refactory finished. still few compilation warnings to clear up. --- src/main/evolve.F90 | 4 +- src/main/ptmass.F90 | 16 +- src/main/step_extern.F90 | 858 ++++++++----------------------------- src/main/step_leapfrog.F90 | 16 +- 4 files changed, 207 insertions(+), 687 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 68cface6f..5aadfdeee 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -88,7 +88,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) use io, only:ianalysis #endif use part, only:npart,nptmass,xyzh,vxyzu,fxyzu,fext,divcurlv,massoftype, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gravity,iboundary, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,gravity,iboundary, & fxyz_ptmass_sinksink,ntot,poten,ndustsmall,accrete_particles_outside_sphere use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot @@ -270,7 +270,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! creation of new sink particles ! call ptmass_create(nptmass,npart,ipart_rhomax,xyzh,vxyzu,fxyzu,fext,divcurlv,& - poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,time) + poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) endif ! ! Strang splitting: implicit update for half step diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 55ae74c89..07af536cb 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -48,7 +48,7 @@ module ptmass public :: get_accel_sink_gas, get_accel_sink_sink public :: get_gradf_sink_gas, get_gradf_sink_sink public :: merge_sinks - public :: ptmass_predictor, ptmass_corrector + public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured public :: ptmass_accrete, ptmass_create public :: write_options_ptmass, read_options_ptmass @@ -69,6 +69,7 @@ module ptmass real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius real, public :: f_crit_override = 0.0 ! 1000. logical, public :: use_fourthorder = .false. + integer, public :: n_force_order = 1 ! Note for above: if f_crit_override > 0, then will unconditionally make a sink when rho > f_crit_override*rho_crit_cgs ! This is a dangerous parameter since failure to form a sink might be indicative of another problem. ! This is a hard-coded parameter due to this danger, but will appear in the .in file if set > 0. @@ -796,7 +797,7 @@ subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_pt !$omp parallel do schedule(static) default(none) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,nptmass) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dkdt,nptmass) & !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then @@ -819,10 +820,11 @@ end subroutine ptmass_kick !+ !---------------------------------------------------------------- subroutine ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) + use externalforces, only:update_vdependent_extforce_leapfrog integer, intent(in) :: nptmass real, intent(in) :: dkdt real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(in) :: fxyz_ptmass(4,nptmass) + real, intent(inout) :: fxyz_ptmass(4,nptmass) integer, intent(in) :: iexternalforce real :: fxi,fyi,fzi,fextv(3) integer :: i @@ -1161,9 +1163,9 @@ end subroutine update_ptmass !+ !------------------------------------------------------------------------- subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& - massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,time) + massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) use part, only:ihacc,ihsoft,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & - ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP,igamma + ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP,igamma,ndptmass use dim, only:maxp,maxneigh,maxvxyzu,maxptmass,ind_timesteps use kdtree, only:getneigh use kernel, only:kernel_softening,radkern @@ -1188,14 +1190,13 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote real, intent(in) :: vxyzu(:,:),fxyzu(:,:),fext(:,:),massoftype(:) real(4), intent(in) :: divcurlv(:,:),poten(:) real, intent(inout) :: xyzmh_ptmass(:,:) - real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:),dptmass(ndptmass,nptmass+1) real, intent(in) :: time integer(kind=1) :: iphasei,ibin_wakei,ibin_itest integer :: nneigh integer, parameter :: maxcache = 12000 integer, parameter :: nneigh_thresh = 1024 ! approximate epot if neigh>neigh_thresh; (-ve for off) real, save :: xyzcache(maxcache,3) - real :: dptmass(ndptmass,nptmass+1) real :: xi,yi,zi,hi,hi1,hi21,xj,yj,zj,hj1,hj21,xk,yk,zk,hk1 real :: rij2,rik2,rjk2,dx,dy,dz real :: vxi,vyi,vzi,dv2,dvx,dvy,dvz,rhomax @@ -2172,6 +2173,7 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) ngot = ngot + 1 case('use_fourthorder') read(valstring,*,iostat=ierr) use_fourthorder + if (use_fourthorder) n_force_order = 3 case default imatch = .false. end select diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 68b2e5364..3b7681f19 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -34,11 +34,10 @@ module step_extern ! implicit none - public :: step_extern_lf public :: step_extern_gr public :: step_extern_sph public :: step_extern_sph_gr - public :: step_extern_FSI + public :: step_extern_pattern real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) real,parameter :: ck(2) = (/0.5,0.5/) @@ -420,30 +419,38 @@ subroutine step_extern_sph(dt,npart,xyzh,vxyzu) end subroutine step_extern_sph - !---------------------------------------------------------------- +!---------------------------------------------------------------- !+ - ! This is the equivalent of the routine below with no cooling - ! and external forces except ptmass. (4th order scheme) + ! Substepping of external and sink particle forces. + ! Also updates position of all particles even if no external + ! forces applied. This is the internal loop of the RESPA + ! algorithm over the "fast" forces. !+ !---------------------------------------------------------------- -subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fsink_old,dsdt_ptmass) - use part, only: isdead_or_accreted,igas,massoftype - use io, only:iverbose,id,master,iprint,warning,fatal +subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & + fsink_old,nbinmax,ibin_wake) + use io, only:iverbose,id,master,iprint,fatal + use options, only:iexternalforce + use part, only:fxyz_ptmass_sinksink use io_summary, only:summary_variable,iosumextr,iosumextt - real, intent(in) :: dtsph,time - integer, intent(in) :: npart,nptmass - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass),fsink_old(4,nptmass) - real :: dt,t_end_step,dtextforce_min - real :: pmassi,timei - logical :: done,last_step - integer :: nsubsteps - - ! - ! determine whether or not to use substepping - ! + use externalforces, only:is_velocity_dependent + use ptmass, only:use_fourthorder + integer, intent(in) :: npart,ntypes,nptmass + real, intent(in) :: dtsph,time + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + real, intent(inout) :: dptmass(:,:),fsink_old(:,:) + integer(kind=1), intent(in) :: nbinmax + integer(kind=1), intent(inout) :: ibin_wake(:) + logical :: extf_vdep_flag,done,last_step + integer :: force_count,nsubsteps + real :: timei,time_par,dt,t_end_step + real :: dtextforce_min +! +! determine whether or not to use substepping +! if (dtextforce < dtsph) then dt = dtextforce last_step = .false. @@ -451,34 +458,53 @@ subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext, dt = dtsph last_step = .true. endif - timei = time - pmassi = massoftype(igas) + time_par = time + extf_vdep_flag = is_velocity_dependent(iexternalforce) t_end_step = timei + dtsph nsubsteps = 0 dtextforce_min = huge(dt) done = .false. substeps: do while (timei <= t_end_step .and. .not.done) + force_count = 0 timei = timei + dt if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) - nsubsteps = nsubsteps + 1 - call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - call kick_4th (dk(1),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift_4th(ck(1),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) ! Direct calculation of the force and force gradient - fsink_old=fxyz_ptmass - call get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,fsink_old) ! extrapolation method Omelyan - !call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old) - call kick_4th (dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,& - xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - call kick_4th (dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt + nsubsteps = nsubsteps + 1 + + if (.not.last_step .and. iverbose > 1 .and. id==master) then + write(iprint,"(a,f14.6)") '> external/ptmass forces only : t=',timei + endif +! +! Main integration scheme +! + call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) + + if (.not.use_fourthorder) then !! standard leapfrog scheme +! the last kick phase of the scheme will perform the accretion loop after velocity update + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + else !! FSI 4th order scheme +! FSFI extrapolation method (Omelyan 2006) + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,fsink_old) + + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) +! the last kick phase of the scheme will perform the accretion loop after velocity update + call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + endif + dtextforce_min = min(dtextforce_min,dtextforce) @@ -496,14 +522,13 @@ subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext, if (nsubsteps > 1) then if (iverbose>=1 .and. id==master) then write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph +' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph endif call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) endif - -end subroutine step_extern_FSI +end subroutine step_extern_pattern !---------------------------------------------------------------- @@ -512,12 +537,14 @@ end subroutine step_extern_FSI !+ !---------------------------------------------------------------- -subroutine drift(ck,dt,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) +subroutine drift(ck,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) use part, only:isdead_or_accreted,ispinx,ispiny,ispinz + use ptmass, only:ptmass_drift use io , only:id,master use mpiutils, only:bcast_mpi real, intent(in) :: dt,ck integer, intent(in) :: npart,nptmass,ntypes + real, intent(inout) :: time_par real, intent(inout) :: xyzh(:,:),vxyzu(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) real :: ckdt @@ -546,6 +573,9 @@ subroutine drift(ck,dt,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass, endif call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) endif + + time_par = time_par + ckdt !! update time for external potential in force routine + end subroutine drift @@ -555,28 +585,31 @@ end subroutine drift !+ !---------------------------------------------------------------- -subroutine kick(dk,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei) - use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz - use ptmass, only:f_acc,ptmass_accrete +subroutine kick(dk,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & + fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas + 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 - use mpiutils, only:bcast_mpi - use dim, only:ind_timesteps + 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 timestep_sts, only:sts_it_n real, intent(in) :: dt,dk integer, intent(in) :: npart,nptmass,ntypes - real, intent(in) :: xyzh(:,:) + real, intent(inout) :: xyzh(:,:) real, intent(inout) :: vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, optional, intent(in) :: dptmass(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + real, optional, intent(inout) :: dptmass(:,:),fxyz_ptmass_sinksink(:,:) real, optional, intent(in) :: timei integer(kind=1), optional, intent(inout) :: ibin_wake(:) integer(kind=1), optional, intent(in) :: nbinmax - logical :: is_accretion,accreted - integer :: i,itype,ibin_wakei,nfaili - integer :: naccreted,nfail,nlive - real :: dkdt,pmassi,fxi,fyi,fzi,accretedmass + integer(kind=1) :: ibin_wakei + logical :: is_accretion,accreted + integer :: i,itype,nfaili + integer :: naccreted,nfail,nlive + real :: dkdt,pmassi,fxi,fyi,fzi,accretedmass if (present(dptmass) .and. present(timei) .and. present(ibin_wake) .and. present(nbinmax)) then is_accretion = .true. @@ -584,6 +617,9 @@ subroutine kick(dk,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,f is_accretion = .false. endif + itype = iphase(igas) + pmassi = massoftype(igas) + dkdt = dk*dt ! Kick sink particles @@ -728,52 +764,92 @@ end subroutine kick !+ !---------------------------------------------------------------- -subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck,dk) +subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, & + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck,dk, & + force_count,extf_vdep_flag,fsink_old) use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc - use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks + 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 + 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 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 - use damping, only:apply_damp,idamp + use damping, only:apply_damp,idamp,calc_damp + use externalforces, only:update_externalforce use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation integer, intent(in) :: nptmass,npart,nsubsteps,ntypes + integer, intent(inout) :: force_count real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) real, intent(inout) :: dtextforce real, intent(in) :: timei,ck,dk,dt + logical, intent(in) :: extf_vdep_flag + real, optional, intent(inout) :: fsink_old(4,nptmass) integer :: merge_ij(nptmass) integer :: merge_n integer :: i,itype + real, save :: dmdt = 0. real :: dtf,dtextforcenew,dtsinkgas,dtphi2,fonrmax - real :: fextx,fexty,fextz,pmassi + real :: fextx,fexty,fextz,xi,yi,zi,pmassi,damp_fac real :: fonrmaxi,phii,dtphi2i - real :: dkdt,ckdt + real :: dkdt,ckdt,extrapfac + logical :: extrap,last - dkdt = dk*dt - ckdt = ck*dt + if(present(fsink_old)) then + fsink_old = fxyz_ptmass + extrap = .true. + else + extrap = .false. + endif + force_count = force_count + 1 + extrapfac = (1./24.)*dt**2 + dkdt = dk*dt + ckdt = ck*dt + itype = igas + pmassi = massoftype(igas) dtextforcenew = bignumber dtsinkgas = bignumber dtphi2 = bignumber - fonrmax = 0 + fonrmax = 0 + last = (force_count == n_force_order) + +! +! update time-dependent external forces +! + call calc_damp(timei, damp_fac) + + call update_externalforce(iexternalforce,timei,dmdt) + if (nptmass>0) then if (id==master) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + if (extrap) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n, & + dsdt_ptmass,extrapfac,fsink_old) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n, & + dsdt_ptmass,extrapfac,fsink_old) + endif + else + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + endif endif else fxyz_ptmass(:,:) = 0. @@ -789,10 +865,10 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$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,ckdt,timei,iexternalforce,extf_is_velocity_dependent) & - !$omp shared(divcurlv,dphotflag,dphot0,nucleation) & - !$omp shared(abundc,abundo,abundsi,abunde) & - !$omp private(fextx,fexty,fextz,itype) & + !$omp shared(dkdt,ckdt,timei,iexternalforce,extf_vdep_flag,last) & + !$omp shared(divcurlv,dphotflag,dphot0,nucleation,extrap) & + !$omp shared(abundc,abundo,abundsi,abunde,extrapfac,fsink_old) & + !$omp private(fextx,fexty,fextz,xi,yi,zi) & !$omp private(i,fonrmaxi,dtphi2i,phii,dtf) & !$omp firstprivate(pmassi,itype) & !$omp reduction(min:dtextforcenew,dtphi2) & @@ -807,32 +883,47 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, fextx = 0. fexty = 0. fextz = 0. + if(extrap) then + xi = xyzh(1,i) + extrapfac*fext(1,i) + yi = xyzh(2,i) + extrapfac*fext(2,i) + zi = xyzh(3,i) + extrapfac*fext(3,i) + else + xi = xyzh(1,i) + yi = xyzh(2,i) + zi = xyzh(3,i) + endif if (nptmass>0) then - call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),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) + 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) + fonrmax = max(fonrmax,fonrmaxi) + dtphi2 = min(dtphi2,dtphi2i) + endif endif ! ! compute and add external forces ! if (iexternalforce > 0) then - call external_force_update_gas(xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i), & - vxyzu(1,i),vxyzu(1,i),vxyzu(1,i),timei,i, & + call external_force_update_gas(xi,yi,zi,xyzh(4,i),vxyzu(1,i), & + vxyzu(1,i),vxyzu(1,i),timei,i, & dtextforcenew,dtf,dkdt,fextx,fexty,fextz, & - extf_is_velocity_dependent,iexternalforce) + extf_vdep_flag,iexternalforce) endif if (idamp > 0) then - call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), xyzh(1:3,i), damp_fac) + call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), (/xi,yi,zi/), damp_fac) endif fext(1,i) = fextx fext(2,i) = fexty fext(3,i) = fextz - if (maxvxyzu >= 4 .and. itype==igas) then + 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,ckdt,dphot0,idK2,idmu,idkappa, & idgamma,imu,igamma,nabn,dphotflag,nabundances) @@ -841,7 +932,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$omp enddo !$omp end parallel - if (nptmass > 0 .and. isink_radiation > 0) then + if (nptmass > 0 .and. isink_radiation > 0 .and. .not.extrap) then if (itau_alloc == 1) then call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) else @@ -852,105 +943,25 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (nptmass > 0) then call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) - if(id==master) then + if(id==master .and. extf_vdep_flag) then call ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) endif endif - if(nptmass>0) then - if (fonrmax > 0.) then - dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) - endif - if (iverbose >= 3 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas - dtextforcenew = min(dtextforcenew,dtsinkgas) - endif - - dtextforcenew = reduceall_mpi('min',dtextforcenew) - dtextforce = dtextforcenew - - -end subroutine get_force - - !---------------------------------------------------------------- - !+ - ! grad routine for the 4th order scheme (FSI), extrapolation method - !+ - !---------------------------------------------------------------- - - -subroutine get_gradf_extrap_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh, & - fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,fsink_old) - use options, only:iexternalforce - use dim, only:maxptmass - use part, only:epot_sinksink - use io, only:master,id - use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks - use timestep, only:bignumber - use mpiutils, only:reduce_in_place_mpi - integer, intent(in) :: nptmass,npart,nsubsteps - real, intent(inout) :: xyzh(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real, intent(in) :: fsink_old(4,nptmass) - real, intent(inout) :: dtextforce - real, intent(in) :: timei,pmassi,dt - integer :: merge_ij(nptmass) - integer :: merge_n - integer :: i - real :: dtf - real :: fextx,fexty,fextz,xi,yi,zi - real :: fonrmaxi,phii,dtphi2i,extrapfac - - extrapfac = (1/24.)*dt**2 - - if (nptmass>0) then - if (id==master) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n, & - dsdt_ptmass,extrapfac,fsink_old) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n, & - dsdt_ptmass,extrapfac,fsink_old) + if (last) then + if(nptmass>0) then + if (fonrmax > 0.) then + dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) endif - else - fxyz_ptmass(:,:) = 0. - dsdt_ptmass(:,:) = 0. + if (iverbose >= 3 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas + dtextforcenew = min(dtextforcenew,dtsinkgas) endif - endif - - !$omp parallel default(none) & - !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,extrapfac,fsink_old) & - !$omp private(fextx,fexty,fextz,xi,yi,zi) & - !$omp private(fonrmaxi,dtphi2i,phii,pmassi,dtf) & - !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) - !$omp do - do i=1,npart - fextx = 0. - fexty = 0. - fextz = 0. - xi = xyzh(1,i) + extrapfac*fext(1,i) - yi = xyzh(2,i) + extrapfac*fext(2,i) - zi = xyzh(3,i) + extrapfac*fext(3,i) - 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) - fext(1,i) = fextx - fext(2,i) = fexty - fext(3,i) = fextz - enddo - !$omp enddo - !$omp end parallel - - - if (nptmass > 0) then - call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + dtextforcenew = reduceall_mpi('min',dtextforcenew) + dtextforce = dtextforcenew endif -end subroutine get_gradf_extrap_4th - +end subroutine get_force ! NOTE: The chemistry and cooling here is implicitly calculated. That is, ! dt is *passed in* to the chemistry & cooling routines so that the @@ -1082,493 +1093,4 @@ subroutine external_force_update_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcen end subroutine external_force_update_gas - - !---------------------------------------------------------------- - !+ - ! Substepping of external and sink particle forces. - ! Also updates position of all particles even if no external - ! forces applied. This is the internal loop of the RESPA - ! algorithm over the "fast" forces. - !+ - !---------------------------------------------------------------- -subroutine step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time,nptmass, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) - use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome,itau_alloc,& - do_nucleation,update_muGamma,h2chemistry,ind_timesteps - use io, only:iverbose,id,master,iprint,warning,fatal - use externalforces, only:externalforce,accrete_particles,update_externalforce, & - update_vdependent_extforce_leapfrog,is_velocity_dependent - use ptmass, only:ptmass_predictor,ptmass_corrector,ptmass_accrete, & - get_accel_sink_gas,get_accel_sink_sink,merge_sinks,f_acc,pt_write_sinkev, & - idxmsi,idymsi,idzmsi,idmsi,idspinxsi,idspinysi,idspinzsi, & - idvxmsi,idvymsi,idvzmsi,idfxmsi,idfymsi,idfzmsi, & - ndptmass,update_ptmass - use options, only:iexternalforce,icooling - use part, only:maxphase,abundance,nabundances,epot_sinksink,eos_vars,& - isdead_or_accreted,iamboundary,igas,iphase,iamtype,massoftype,rhoh,divcurlv, & - fxyz_ptmass_sinksink,dsdt_ptmass_sinksink,dust_temp,tau,& - nucleation,idK2,idmu,idkappa,idgamma,imu,igamma - use chem, only:update_abundances,get_dphot - use cooling_ism, only:dphot0,energ_cooling_ism,dphotflag,abundsi,abundo,abunde,abundc,nabn - use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete,summary_accrete_fail - use timestep, only:bignumber,C_force - use timestep_sts, only:sts_it_n - use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi - use damping, only:calc_damp,apply_damp - use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation - - - integer, intent(in) :: npart,ntypes,nptmass - real, intent(in) :: dtsph,time - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:),fxyzu(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - integer(kind=1), intent(in) :: nbinmax - integer(kind=1), intent(inout) :: ibin_wake(:) - integer :: i,itype,nsubsteps,naccreted,nfail,nfaili,merge_n,nlive - integer :: merge_ij(nptmass) - integer(kind=1) :: ibin_wakei - real :: timei,hdt,fextx,fexty,fextz,fextxi,fextyi,fextzi,phii,pmassi - real :: dtphi2,dtphi2i,vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi - real :: dudtcool,fextv(3),poti,ui,rhoi,mui,gammai,ph,ph_tot - real :: dt,dtextforcenew,dtsinkgas,fonrmax,fonrmaxi - real :: dtf,accretedmass,t_end_step,dtextforce_min - real, allocatable :: dptmass(:,:) ! dptmass(ndptmass,nptmass) - real :: damp_fac,dphot - real, save :: dmdt = 0. - real :: abundi(nabn),gmwvar - logical :: accreted,extf_is_velocity_dependent - logical :: last_step,done - - - ! - ! determine whether or not to use substepping - ! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - - timei = time - extf_is_velocity_dependent = is_velocity_dependent(iexternalforce) - accretedmass = 0. - itype = igas - pmassi = massoftype(igas) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - ! allocate memory for dptmass array (avoids ifort bug) - allocate(dptmass(ndptmass,nptmass)) - - substeps: do while (timei <= t_end_step .and. .not.done) - hdt = 0.5*dt - timei = timei + dt - if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) - nsubsteps = nsubsteps + 1 - dtextforcenew = bignumber - dtsinkgas = bignumber - dtphi2 = bignumber - - call calc_damp(time, damp_fac) - - if (.not.last_step .and. iverbose > 1 .and. id==master) then - write(iprint,"(a,f14.6)") '> external/ptmass forces only : t=',timei - endif - ! - ! update time-dependent external forces - ! - call update_externalforce(iexternalforce,timei,dmdt) - - !--------------------------- - ! predictor during substeps - !--------------------------- - ! - ! point mass predictor step - ! - if (nptmass > 0) then - if (id==master) then - call ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - ! - ! get sink-sink forces (and a new sink-sink timestep. Note: fxyz_ptmass is zeroed in this subroutine) - ! pass sink-sink forces to variable fxyz_ptmass_sinksink for later writing. - ! - if (iexternalforce==14) call update_externalforce(iexternalforce,timei,dmdt) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - endif - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf - else - fxyz_ptmass(:,:) = 0. - dsdt_ptmass(:,:) = 0. - endif - call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) - call bcast_mpi(vxyz_ptmass(:,1:nptmass)) - call bcast_mpi(epot_sinksink) - call bcast_mpi(dtf) - dtextforcenew = min(dtextforcenew,C_force*dtf) - endif - - ! - ! predictor step for sink-gas and external forces, also recompute sink-gas and external forces - ! - fonrmax = 0. - !$omp parallel default(none) & - !$omp shared(maxp,maxphase) & - !$omp shared(npart,xyzh,vxyzu,fext,abundance,iphase,ntypes,massoftype) & - !$omp shared(eos_vars,dust_temp) & - !$omp shared(dt,hdt,timei,iexternalforce,extf_is_velocity_dependent) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,idamp,damp_fac) & - !$omp shared(nptmass,divcurlv,dphotflag,dphot0) & - !$omp shared(abundc,abundo,abundsi,abunde) & - !$omp shared(nucleation) & - !$omp private(i,phii) & - !$omp private(fextx,fexty,fextz) & - !$omp private(fonrmaxi,dtphi2i,dtf) & - !$omp firstprivate(pmassi,itype) & - !$omp reduction(min:dtextforcenew,dtphi2) & - !$omp reduction(max:fonrmax) & - !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) - !$omp do - predictor: do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - if (ntypes > 1 .and. maxphase==maxp) then - itype = iamtype(iphase(i)) - pmassi = massoftype(itype) - endif - ! - ! predict v to the half step - ! - vxyzu(1:3,i) = vxyzu(1:3,i) + hdt*fext(1:3,i) - ! - ! main position update - ! - xyzh(1,i) = xyzh(1,i) + dt*vxyzu(1,i) - xyzh(2,i) = xyzh(2,i) + dt*vxyzu(2,i) - xyzh(3,i) = xyzh(3,i) + dt*vxyzu(3,i) - ! - ! Skip remainder of update if boundary particle; note that fext==0 for these particles - if (iamboundary(itype)) cycle predictor - ! - ! compute and add sink-gas force - ! - fextx = 0. - fexty = 0. - fextz = 0. - if (nptmass > 0) then - call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),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 - ! - ! compute and add external forces - ! - if (iexternalforce > 0) then - call external_force_update(xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i), & - vxyzu(1,i),vxyzu(1,i),vxyzu(1,i),timei,i, & - dtextforcenew,dtf,dt,fextx,fexty,fextz, & - extf_is_velocity_dependent,iexternalforce) - endif - - if (idamp > 0) then - call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), xyzh(1:3,i), damp_fac) - endif - - fext(1,i) = fextx - fext(2,i) = fexty - fext(3,i) = fextz - - if (maxvxyzu >= 4 .and. itype==igas) then - call cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & - divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,idK2,idmu,idkappa, & - idgamma,imu,igamma,nabn,dphotflag,nabundances) - endif - endif - enddo predictor - !$omp enddo - !$omp end parallel - - if (nptmass > 0 .and. isink_radiation > 0) then - if (itau_alloc == 1) then - call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) - else - call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext) - endif - endif - - ! - ! reduction of sink-gas forces from each MPI thread - ! - if (nptmass > 0) then - call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) - endif - !--------------------------- - ! corrector during substeps - !--------------------------- - ! - ! corrector step on sinks (changes velocities only, does not change position) - ! - if (nptmass > 0) then - if (id==master) then - call ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,iexternalforce) - endif - call bcast_mpi(vxyz_ptmass(:,1:nptmass)) - endif - - ! - ! corrector step on gas particles (also accrete particles at end of step) - ! - accretedmass = 0. - nfail = 0 - naccreted = 0 - nlive = 0 - ibin_wakei = 0 - dptmass(:,:) = 0. - - !$omp parallel default(none) & - !$omp shared(maxp,maxphase) & - !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype,hdt,timei,nptmass,sts_it_n) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & - !$omp shared(iexternalforce) & - !$omp shared(nbinmax,ibin_wake) & - !$omp reduction(+:dptmass) & - !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & - !$omp firstprivate(itype,pmassi,ibin_wakei) & - !$omp reduction(+:accretedmass,nfail,naccreted,nlive) - !$omp do - accreteloop: do i=1,npart - 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 - endif - ! - ! correct v to the full step using only the external force - ! - vxyzu(1:3,i) = vxyzu(1:3,i) + hdt*fext(1:3,i) - - if (iexternalforce > 0) then - call accrete_particles(iexternalforce,xyzh(1,i),xyzh(2,i), & - xyzh(3,i),xyzh(4,i),pmassi,timei,accreted) - if (accreted) accretedmass = accretedmass + pmassi - endif - ! - ! accretion onto sink particles - ! need position, velocities and accelerations of both gas and sinks to be synchronised, - ! otherwise will not conserve momentum - ! Note: requiring sts_it_n since this is supertimestep with the most active particles - ! - if (nptmass > 0 .and. sts_it_n) then - fxi = fext(1,i) - fyi = fext(2,i) - fzi = fext(3,i) - if (ind_timesteps) ibin_wakei = ibin_wake(i) - - call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxi,fyi,fzi,& - itype,pmassi,xyzmh_ptmass,vxyz_ptmass,& - accreted,dptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) - if (accreted) then - naccreted = naccreted + 1 - cycle accreteloop - else - if (ind_timesteps) ibin_wake(i) = ibin_wakei - endif - if (nfaili > 1) nfail = nfail + 1 - endif - nlive = nlive + 1 - endif - enddo accreteloop - !$omp enddo - !$omp end parallel - - if (npart > 2 .and. nlive < 2) then - call fatal('step','all particles accreted',var='nlive',ival=nlive) - endif - - ! - ! reduction of sink particle changes across MPI - ! - if (nptmass > 0) then - call reduce_in_place_mpi('+',dptmass(:,1:nptmass)) - - naccreted = int(reduceall_mpi('+',naccreted)) - nfail = int(reduceall_mpi('+',nfail)) - - if (id==master) call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) - - call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) - call bcast_mpi(vxyz_ptmass(:,1:nptmass)) - call bcast_mpi(fxyz_ptmass(:,1:nptmass)) - endif - - if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a,i4,a)") & - 'Step: at time ',timei,', ',naccreted,' particles were accreted amongst ',nptmass,' sink(s).' - - if (nptmass > 0) then - call summary_accrete_fail(nfail) - call summary_accrete(nptmass) - ! only write to .ev during substeps if no gas particles present - if (npart==0) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & - fxyz_ptmass,fxyz_ptmass_sinksink) - endif - ! - ! check if timestep criterion was violated during substeps - ! - if (nptmass > 0) then - if (fonrmax > 0.) then - dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) - endif - if (iverbose >= 2) write(iprint,*) nsubsteps,'dt(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas - dtextforcenew = min(dtextforcenew,dtsinkgas) - endif - - dtextforcenew = reduceall_mpi('min',dtextforcenew) - - dtextforce_min = min(dtextforce_min,dtextforcenew) - dtextforce = dtextforcenew - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - enddo substeps - - deallocate(dptmass) - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - -end subroutine step_extern_lf - - -subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & - nbinmax,ibin_wake) - use io, only:iverbose,id,master,iprint - use options, only:iexternalforce - use part, only:abundance,eos_vars,divcurlv,fxyz_ptmass_sinksink, & - dsdt_ptmass_sinksink,dust_temp,tau,nucleation - use cooling_ism, only:dphot0,dphotflag,abundsi,abundo,abunde,abundc,nabn - use io_summary, only:summary_variable,iosumextr,iosumextt - use damping, only:calc_damp - integer, intent(in) :: npart,ntypes,nptmass - real, intent(in) :: dtsph,time - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, intent(inout) :: dptmass(:,:) - integer(kind=1), intent(in) :: nbinmax - integer(kind=1), intent(inout) :: ibin_wake(:) - ! - ! determine whether or not to use substepping - ! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - timei = time - extf_is_velocity_dependent = is_velocity_dependent(iexternalforce) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - - substeps: do while (timei <= t_end_step .and. .not.done) - timei = timei + dt - if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) - nsubsteps = nsubsteps + 1 - - if (.not.last_step .and. iverbose > 1 .and. id==master) then - write(iprint,"(a,f14.6)") '> external/ptmass forces only : t=',timei - endif - ! - ! update time-dependent external forces - ! - call calc_damp(time, damp_fac) - call update_externalforce(iexternalforce,timei,dmdt) - - ! - ! Main integration scheme - ! - call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - - call drift(ck(1),dt,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - - call get_force(nptmass,npart,nsubsteps,ntypestimei,dtextforce,xyzh,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2)) - - if (int_precision == 2) then - ! the last kick phase of the scheme will perform the accretion loop after velocity update - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei) - elseif (int_precision == 4) then - ! FSFI extrapolation method (Omelyan 2006) - fsink_old = fxyz_ptmass - call get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2)) - - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - - call drift(ck(2),dt,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) - - call get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2)) - ! 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) - endif - - - dtextforce_min = min(dtextforce_min,dtextforce) - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - enddo substeps - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - -end subroutine step_extern_pattern - - end module step_extern diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index f643d4c5e..a03680e54 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -104,7 +104,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use deriv, only:derivs use timestep, only:dterr,bignumber,tolv use mpiutils, only:reduceall_mpi - use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fsink_old,ibin_wake + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & + dsdt_ptmass,fsink_old,ibin_wake,dptmass use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax @@ -124,9 +125,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate - use step_extern, only:step_extern_FSI,step_extern_lf,step_extern_gr, & + use step_extern, only:step_extern_pattern,step_extern_gr, & step_extern_sph_gr,step_extern_sph - use ptmass, only: use_fourthorder integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -248,13 +248,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif else if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then - if (use_fourthorder) then - call step_extern_FSI(dtextforce,dtsph,t,npart,nptmass,xyzh,vxyzu,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fsink_old,dsdt_ptmass) - else - call step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) - endif + call step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& + dptmass,fsink_old,nbinmax,ibin_wake) else call step_extern_sph(dtsph,npart,xyzh,vxyzu) endif From 5b8fd93cc5ef9d9706304da66b985bbcd6566a30 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 12 Apr 2024 15:34:53 +0200 Subject: [PATCH 415/814] increase require tolerances for ieos=12,20 tests and add option to enforce relative tolerance in checkvalbuf_real --- src/main/eos.f90 | 4 +-- src/main/eos_gasradrec.f90 | 4 +-- src/main/eos_idealplusrad.f90 | 12 ++++---- src/tests/test_eos.f90 | 54 +++++++++++++++++------------------ src/tests/utils_testsuite.f90 | 9 ++++-- 5 files changed, 43 insertions(+), 40 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 45776d30a..be0410681 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -106,7 +106,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam use io, only:fatal,error,warning use part, only:xyzmh_ptmass, nptmass use units, only:unit_density,unit_pressure,unit_ergg,unit_velocity - use physcon, only:kb_on_mh,radconst + use physcon, only:Rg,radconst use eos_mesa, only:get_eos_pressure_temp_gamma1_mesa,get_eos_1overmu_mesa use eos_helmholtz, only:eos_helmholtz_pres_sound use eos_shen, only:eos_shen_NL3 @@ -414,7 +414,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam if (tempi > 0.) then temperaturei = tempi else - temperaturei = min(0.67 * cgseni * mui / kb_on_mh, (cgseni*cgsrhoi/radconst)**0.25) + temperaturei = min(0.67 * cgseni * mui / Rg, (cgseni*cgsrhoi/radconst)**0.25) endif call equationofstate_gasradrec(cgsrhoi,cgseni*cgsrhoi,temperaturei,imui,X_i,1.-X_i-Z_i,cgspresi,cgsspsoundi,gammai) ponrhoi = real(cgspresi / (unit_pressure * rhoi)) diff --git a/src/main/eos_gasradrec.f90 b/src/main/eos_gasradrec.f90 index d8e949aba..831a9302e 100644 --- a/src/main/eos_gasradrec.f90 +++ b/src/main/eos_gasradrec.f90 @@ -23,6 +23,7 @@ module eos_gasradrec public :: equationofstate_gasradrec,calc_uT_from_rhoP_gasradrec,read_options_eos_gasradrec,& write_options_eos_gasradrec,eos_info_gasradrec,init_eos_gasradrec private + real, parameter :: eoserr=1.e-15,W4err=1.e-2 contains !----------------------------------------------------------------------- @@ -39,7 +40,6 @@ subroutine equationofstate_gasradrec(d,eint,T,imu,X,Y,p,cf,gamma_eff) real, intent(in) :: X,Y real, intent(out) :: p,cf,gamma_eff real :: corr,erec,derecdT,dimurecdT,Tdot,logd,dt,Tguess - real, parameter :: W4err=1.e-2,eoserr=1.e-13 integer, parameter :: nmax = 500 integer n @@ -69,6 +69,7 @@ subroutine equationofstate_gasradrec(d,eint,T,imu,X,Y,p,cf,gamma_eff) print*,'d=',d,'eint=',eint/d,'Tguess=',Tguess,'mu=',1./imu,'T=',T,'erec=',erec call fatal('eos_gasradrec','Failed to converge on temperature in equationofstate_gasradrec') endif + call get_erec_imurec(logd,T,X,Y,erec,imu) p = ( Rg*imu*d + radconst*T**3/3. )*T gamma_eff = 1.+p/(eint-d*erec) cf = sqrt(gamma_eff*p/d) @@ -92,7 +93,6 @@ subroutine calc_uT_from_rhoP_gasradrec(rhoi,presi,X,Y,T,eni,mui,ierr) integer, intent(out) :: ierr integer :: n real :: logrhoi,imu,dimurecdT,dT,Tdot,corr - real, parameter :: W4err=1.e-2,eoserr=1.e-13 if (T <= 0.) T = min((3.*presi/radconst)**0.25, presi/(rhoi*Rg)) ! initial guess for temperature ierr = 0 diff --git a/src/main/eos_idealplusrad.f90 b/src/main/eos_idealplusrad.f90 index b48c73974..e2a6c10aa 100644 --- a/src/main/eos_idealplusrad.f90 +++ b/src/main/eos_idealplusrad.f90 @@ -20,7 +20,7 @@ module eos_idealplusrad ! use physcon, only:Rg,radconst implicit none - real, parameter :: tolerance = 1e-15 + real, parameter :: tolerance = 1.e-15 public :: get_idealplusrad_temp,get_idealplusrad_pres,get_idealplusrad_spsoundi,& get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp,& @@ -64,19 +64,17 @@ end subroutine get_idealplusrad_temp subroutine get_idealplusrad_pres(rhoi,tempi,mu,presi) - real, intent(in) :: rhoi,mu - real, intent(in) :: tempi + real, intent(in) :: rhoi,tempi,mu real, intent(out) :: presi - presi = Rg*rhoi*tempi/mu + 1./3.*radconst*tempi**4 ! Eq 13.2 (Kippenhahn et al.) + presi = (Rg*rhoi/mu + radconst*tempi**3/3.)*tempi ! Eq 13.2 (Kippenhahn et al.) end subroutine get_idealplusrad_pres subroutine get_idealplusrad_spsoundi(rhoi,presi,eni,spsoundi,gammai) real, intent(in) :: rhoi,presi,eni - real, intent(out) :: spsoundi - real, intent(out) :: gammai + real, intent(out) :: spsoundi,gammai gammai = 1. + presi/(eni*rhoi) spsoundi = sqrt(gammai*presi/rhoi) @@ -127,7 +125,7 @@ subroutine get_idealplusrad_enfromtemp(densi,tempi,mu,eni) real, intent(in) :: densi,tempi,mu real, intent(out) :: eni - eni = 3./2.*Rg*tempi/mu + radconst*tempi**4/densi + eni = 1.5*Rg*tempi/mu + radconst*tempi**4/densi end subroutine get_idealplusrad_enfromtemp diff --git a/src/tests/test_eos.f90 b/src/tests/test_eos.f90 index 23a1372a7..e984131f8 100644 --- a/src/tests/test_eos.f90 +++ b/src/tests/test_eos.f90 @@ -23,6 +23,7 @@ module testeos public :: test_helmholtz ! to avoid compiler warning for unused routine private + logical :: use_rel_tol = .true. contains !---------------------------------------------------------- @@ -116,7 +117,7 @@ subroutine test_idealplusrad(ntests, npass) use eos_idealplusrad, only:get_idealplusrad_enfromtemp,get_idealplusrad_pres use testutils, only:checkval,checkvalbuf_start,checkvalbuf,checkvalbuf_end,update_test_scores use units, only:unit_density,unit_pressure,unit_ergg - use physcon, only:kb_on_mh + use physcon, only:Rg integer, intent(inout) :: ntests,npass integer :: npts,ieos,ierr,i,j,nfail(2),ncheck(2) real :: rhocodei,gamma,presi,dum,csound,eni,temp,ponrhoi,mu,tol,errmax(2),pres2,code_eni @@ -129,7 +130,7 @@ subroutine test_idealplusrad(ntests, npass) call get_rhoT_grid(npts,rhogrid,Tgrid) dum = 0. - tol = 1.e-12 + tol = 1.e-15 nfail = 0; ncheck = 0; errmax = 0. call init_eos(ieos,ierr) do i=1,npts @@ -140,13 +141,13 @@ subroutine test_idealplusrad(ntests, npass) ! Recalculate T, P, from rho, u code_eni = eni/unit_ergg - temp = eni*mu/kb_on_mh + temp = eni*mu/Rg ! guess rhocodei = rhogrid(i)/unit_density call equationofstate(ieos,ponrhoi,csound,rhocodei,dum,dum,dum,temp,code_eni,mu_local=mu,gamma_local=gamma) pres2 = ponrhoi * rhocodei * unit_pressure - call checkvalbuf(temp,Tgrid(j),tol,'Check recovery of T from rho, u',nfail(1),ncheck(1),errmax(1)) - call checkvalbuf(pres2,presi,tol,'Check recovery of P from rho, u',nfail(2),ncheck(2),errmax(2)) + call checkvalbuf(temp,Tgrid(j),tol,'Check recovery of T from rho, u',nfail(1),ncheck(1),errmax(1),use_rel_tol) + call checkvalbuf(pres2,presi,tol,'Check recovery of P from rho, u',nfail(2),ncheck(2),errmax(2),use_rel_tol) enddo enddo call checkvalbuf_end('Check recovery of T from rho, u',ncheck(1),nfail(1),errmax(1),tol) @@ -170,9 +171,9 @@ subroutine test_hormone(ntests, npass) use testutils, only:checkval,checkvalbuf_start,checkvalbuf,checkvalbuf_end,update_test_scores use units, only:unit_density,unit_pressure,unit_ergg integer, intent(inout) :: ntests,npass - integer :: npts,ieos,ierr,i,j,nfail(4),ncheck(4) - real :: imurec,mu,eni_code,presi,pres2,dum,csound,eni,tempi - real :: ponrhoi,X,Z,tol,errmax(4),gasrad_eni,eni2,rhocodei,gamma + integer :: npts,ieos,ierr,i,j,nfail(6),ncheck(6) + real :: imurec,mu,eni_code,presi,pres2,dum,csound,eni,tempi,gamma_eff + real :: ponrhoi,X,Z,tol,errmax(6),gasrad_eni,eni2,rhocodei,gamma,mu2 real, allocatable :: rhogrid(:),Tgrid(:) if (id==master) write(*,"(/,a)") '--> testing HORMONE equation of states' @@ -185,45 +186,44 @@ subroutine test_hormone(ntests, npass) ! Testing dum = 0. - tol = 1.e-12 + tol = 1.e-14 tempi = -1. nfail = 0; ncheck = 0; errmax = 0. call init_eos(ieos,ierr) - tempi = 1. - eni_code = 764437650.64783347/unit_ergg - rhocodei = 3.2276168501594796E-015/unit_density - call equationofstate(ieos,ponrhoi,csound,rhocodei,0.,0.,0.,tempi,eni_code,mu_local=mu,Xlocal=X,Zlocal=Z,gamma_local=gamma) do i=1,npts do j=1,npts gamma = 5./3. - ! Get mu from rho, T + ! Get mu, u, P from rho, T call get_imurec(log10(rhogrid(i)),Tgrid(j),X,1.-X-Z,imurec) mu = 1./imurec - - ! Get u, P from rho, T, mu call get_idealplusrad_enfromtemp(rhogrid(i),Tgrid(j),mu,gasrad_eni) eni = gasrad_eni + get_erec(log10(rhogrid(i)),Tgrid(j),X,1.-X-Z) call get_idealplusrad_pres(rhogrid(i),Tgrid(j),mu,presi) - ! Recalculate P, T from rho, u, mu + ! Recalculate P, T from rho, u tempi = 1. eni_code = eni/unit_ergg rhocodei = rhogrid(i)/unit_density - call equationofstate(ieos,ponrhoi,csound,rhocodei,0.,0.,0.,tempi,eni_code,mu_local=mu,Xlocal=X,Zlocal=Z,gamma_local=gamma) + call equationofstate(ieos,ponrhoi,csound,rhocodei,0.,0.,0.,tempi,eni_code,& + mu_local=mu2,Xlocal=X,Zlocal=Z,gamma_local=gamma_eff) ! mu and gamma_eff are outputs pres2 = ponrhoi * rhocodei * unit_pressure - call checkvalbuf(tempi,Tgrid(j),tol,'Check recovery of T from rho, u',nfail(1),ncheck(1),errmax(1)) - call checkvalbuf(pres2,presi,tol,'Check recovery of P from rho, u',nfail(2),ncheck(2),errmax(2)) + call checkvalbuf(mu2,mu,tol,'Check recovery of mu from rho, u',nfail(1),ncheck(1),errmax(1),use_rel_tol) + call checkvalbuf(tempi,Tgrid(j),tol,'Check recovery of T from rho, u',nfail(2),ncheck(2),errmax(2),use_rel_tol) + call checkvalbuf(pres2,presi,tol,'Check recovery of P from rho, u',nfail(3),ncheck(3),errmax(3),use_rel_tol) ! Recalculate u, T, mu from rho, P - call calc_uT_from_rhoP_gasradrec(rhogrid(i),presi,X,1.-X-Z,tempi,eni2,mu,ierr) - call checkvalbuf(tempi,Tgrid(j),tol,'Check recovery of T from rho, P',nfail(3),ncheck(3),errmax(3)) - call checkvalbuf(eni2,eni,tol,'Check recovery of u from rho, P',nfail(4),ncheck(4),errmax(4)) + call calc_uT_from_rhoP_gasradrec(rhogrid(i),presi,X,1.-X-Z,tempi,eni2,mu2,ierr) + call checkvalbuf(mu2,mu,tol,'Check recovery of mu from rho, P',nfail(4),ncheck(4),errmax(4),use_rel_tol) + call checkvalbuf(tempi,Tgrid(j),tol,'Check recovery of T from rho, P',nfail(5),ncheck(5),errmax(5),use_rel_tol) + call checkvalbuf(eni2,eni,tol,'Check recovery of u from rho, P',nfail(6),ncheck(6),errmax(6),use_rel_tol) enddo enddo - call checkvalbuf_end('Check recovery of T from rho, u',ncheck(1),nfail(1),errmax(1),tol) - call checkvalbuf_end('Check recovery of P from rho, u',ncheck(2),nfail(2),errmax(2),tol) - call checkvalbuf_end('Check recovery of T from rho, P',ncheck(3),nfail(3),errmax(3),tol) - call checkvalbuf_end('Check recovery of u from rho, P',ncheck(4),nfail(4),errmax(4),tol) + call checkvalbuf_end('Check recovery of mu from rho, u',ncheck(1),nfail(1),errmax(1),tol) + call checkvalbuf_end('Check recovery of T from rho, u',ncheck(2),nfail(2),errmax(2),tol) + call checkvalbuf_end('Check recovery of P from rho, u',ncheck(3),nfail(3),errmax(3),tol) + call checkvalbuf_end('Check recovery of mu from rho, P',ncheck(4),nfail(4),errmax(4),tol) + call checkvalbuf_end('Check recovery of T from rho, P',ncheck(5),nfail(5),errmax(5),tol) + call checkvalbuf_end('Check recovery of u from rho, P',ncheck(6),nfail(6),errmax(6),tol) call update_test_scores(ntests,nfail,npass) end subroutine test_hormone diff --git a/src/tests/utils_testsuite.f90 b/src/tests/utils_testsuite.f90 index 8f05a7d0c..512d25766 100644 --- a/src/tests/utils_testsuite.f90 +++ b/src/tests/utils_testsuite.f90 @@ -629,16 +629,21 @@ end subroutine checkvalbuf_int ! (buffered: reports on errors only and ndiff is a running total) !+ !---------------------------------------------------------------- -subroutine checkvalbuf_real(xi,val,tol,label,ndiff,ncheck,errmax) +subroutine checkvalbuf_real(xi,val,tol,label,ndiff,ncheck,errmax,use_rel_tol) real, intent(in) :: xi real, intent(in) :: val,tol character(len=*), intent(in) :: label integer, intent(inout) :: ndiff,ncheck real, intent(inout) :: errmax + logical, intent(in), optional :: use_rel_tol real :: erri + logical :: rel_tol + + rel_tol = .false. + if (present(use_rel_tol)) rel_tol = use_rel_tol erri = abs(xi-val) - if (abs(val) > smallval .and. erri > tol) erri = erri/abs(val) + if (rel_tol .or. (abs(val) > smallval .and. erri > tol)) erri = erri/abs(val) ncheck = ncheck + 1 if (erri > tol .or. erri /= erri) then From 77b54ddffdea0d285e20e64e439cc815d2fd4857 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 15 Apr 2024 10:37:46 +1000 Subject: [PATCH 416/814] fix update vdep extf for all int order + ck and dk init + clean up --- src/main/extern_corotate.f90 | 24 ++- src/main/extern_gnewton.f90 | 19 ++- src/main/extern_lensethirring.f90 | 25 ++- src/main/extern_prdrag.f90 | 28 ++-- src/main/externalforces.f90 | 26 ++-- src/main/externalforces_gr.f90 | 6 +- src/main/ptmass.F90 | 246 +++--------------------------- src/main/step_extern.F90 | 28 ++-- src/tests/test_externf.f90 | 17 ++- src/tests/test_gnewton.f90 | 6 +- src/tests/test_gr.f90 | 2 +- 11 files changed, 109 insertions(+), 318 deletions(-) diff --git a/src/main/extern_corotate.f90 b/src/main/extern_corotate.f90 index 72eedd4e5..e8d9bfff8 100644 --- a/src/main/extern_corotate.f90 +++ b/src/main/extern_corotate.f90 @@ -39,7 +39,7 @@ module extern_corotate real, public :: primarycore_xpos = 1., primarycore_mass = 1. integer, public :: icompanion_grav = 0 - public :: update_coriolis_leapfrog + public :: update_coriolis public :: get_coriolis_force,get_centrifugal_force,get_companion_force public :: write_options_corotate, read_options_corotate private @@ -132,17 +132,16 @@ end subroutine get_coriolis_force ! returning the forces plus the Coriolis force. !+ !--------------------------------------------------------------- -subroutine update_coriolis_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& - vcrossomega,dt) +subroutine update_coriolis(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& + vcrossomega,dkdt) use vectorutils, only:cross_product3D,matrixinvert3D use io, only:fatal - real, intent(in) :: dt + real, intent(in) :: dkdt real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(out) :: vcrossomega(3) integer :: ierr - real :: dton2 real :: A(3),v1(3),Omegap(3) real :: Rmat(3,3),Rinv(3,3) @@ -161,15 +160,14 @@ subroutine update_coriolis_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& ! ! and fxi,fyi,fzi are the components of f1_sph !-------------------------------------------------- - dton2 = 0.5*dt - A(1) = vhalfx + dton2*fxi - A(2) = vhalfy + dton2*fyi - A(3) = vhalfz + dton2*fzi + A(1) = vhalfx + dkdt*fxi + A(2) = vhalfy + dkdt*fyi + A(3) = vhalfz + dkdt*fzi ! This is the matrix from the equation for v1: [Rmat][v1] = [A] - Rmat = reshape((/1., -dton2*Omegap(3), dton2*Omegap(2), & - dton2*Omegap(3), 1., -dton2*Omegap(1), & - -dton2*Omegap(2), dton2*Omegap(1), 1. /),(/3,3/)) + Rmat = reshape((/1., -dkdt*Omegap(3), dkdt*Omegap(2), & + dkdt*Omegap(3), 1., -dkdt*Omegap(1), & + -dkdt*Omegap(2), dkdt*Omegap(1), 1. /),(/3,3/)) ! Get the inverse matrix call matrixinvert3D(Rmat,Rinv,ierr) @@ -188,7 +186,7 @@ subroutine update_coriolis_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& fyi = fyi + vcrossomega(2) fzi = fzi + vcrossomega(3) -end subroutine update_coriolis_leapfrog +end subroutine update_coriolis !----------------------------------------------------------------------- !+ diff --git a/src/main/extern_gnewton.f90 b/src/main/extern_gnewton.f90 index 75a8563e9..8d60fe62e 100644 --- a/src/main/extern_gnewton.f90 +++ b/src/main/extern_gnewton.f90 @@ -21,7 +21,7 @@ module extern_gnewton ! implicit none public :: get_gnewton_spatial_force, get_gnewton_vdependent_force - public :: update_gnewton_leapfrog + public :: update_gnewton public :: get_gnewton_energy private @@ -99,18 +99,18 @@ subroutine get_gnewton_vdependent_force(xyzi,veli,mass,fexti) end subroutine get_gnewton_vdependent_force -subroutine update_gnewton_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,mass) +subroutine update_gnewton(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,mass) use io, only:fatal - real, intent(in) :: dt,xi,yi,zi, mass + real, intent(in) :: dkdt,xi,yi,zi, mass real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(inout) :: fexti(3) real :: fextv(3) - real :: v1x, v1y, v1z, v1xold, v1yold, v1zold, vhalf2, erri, dton2 + real :: v1x, v1y, v1z, v1xold, v1yold, v1zold, vhalf2, erri logical :: converged integer :: its, itsmax integer, parameter :: maxitsext = 50 ! maximum number of iterations on external force - character(len=30), parameter :: label = 'update_gnewton_leapfrog' + character(len=30), parameter :: label = 'update_gnewton' real, parameter :: tolv = 1.e-2 real, parameter :: tolv2 = tolv*tolv real,dimension(3) :: pos,vel @@ -118,7 +118,6 @@ subroutine update_gnewton_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi, itsmax = maxitsext its = 0 converged = .false. - dton2 = 0.5*dt v1x = vhalfx v1y = vhalfy @@ -142,9 +141,9 @@ subroutine update_gnewton_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi, v1y = vel(2) v1z = vel(3) - v1x = vhalfx + dton2*(fxi + fextv(1)) - v1y = vhalfy + dton2*(fyi + fextv(2)) - v1z = vhalfz + dton2*(fzi + fextv(3)) + v1x = vhalfx + dkdt*(fxi + fextv(1)) + v1y = vhalfy + dkdt*(fyi + fextv(2)) + v1z = vhalfz + dkdt*(fzi + fextv(3)) erri = (v1x - v1xold)**2 + (v1y - v1yold)**2 + (v1z - v1zold)**2 erri = erri / vhalf2 @@ -162,7 +161,7 @@ subroutine update_gnewton_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi, fyi = fyi + fexti(2) fzi = fzi + fexti(3) -end subroutine update_gnewton_leapfrog +end subroutine update_gnewton !----------------------------------------------------------------------- diff --git a/src/main/extern_lensethirring.f90 b/src/main/extern_lensethirring.f90 index cfc6b9b03..e1f318e46 100644 --- a/src/main/extern_lensethirring.f90 +++ b/src/main/extern_lensethirring.f90 @@ -31,7 +31,7 @@ module extern_lensethirring real, public :: blackhole_spin_angle = 0. real, public :: cos_spinangle = 1., sin_spinangle = 0. - public :: update_ltforce_leapfrog + public :: update_ltforce public :: get_lense_thirring_force,check_lense_thirring_settings public :: write_options_ltforce, read_options_ltforce private @@ -111,25 +111,22 @@ end subroutine get_lense_thirring_force ! returning the forces plust the Lense-Thirring force. !+ !--------------------------------------------------------------- -subroutine update_ltforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& - vcrossomega,dt,xi,yi,zi,bh_mass) +subroutine update_ltforce(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& + vcrossomega,dkdt,xi,yi,zi,bh_mass) use vectorutils, only : cross_product3D,matrixinvert3D use io, only : fatal,warning - real, intent(in) :: dt,xi,yi,zi,bh_mass + real, intent(in) :: dkdt,xi,yi,zi,bh_mass real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(out) :: vcrossomega(3) integer :: ierr - real :: dton2,dton2sq !,f2,flt2 real :: A(3),v1(3),Omegap(3) !,v1check real :: Rmat(3,3),Rinv(3,3) ! Half the timestep and compute its square - dton2 = 0.5*dt - dton2sq = dton2**2 ! Equation we are solving is: v1 = v0 + 0.5dt*(f0 + f1_sph + v1 cross Omega) ! vhalf = v0 + 0.5*dt*f0 @@ -142,14 +139,14 @@ subroutine update_ltforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& !---------------------------------------------------------------------- ! Third attempt with matrix inversion. !---------------------------------------------------------------------- - A(1) = vhalfx + dton2*fxi - A(2) = vhalfy + dton2*fyi - A(3) = vhalfz + dton2*fzi + A(1) = vhalfx + dkdt*fxi + A(2) = vhalfy + dkdt*fyi + A(3) = vhalfz + dkdt*fzi ! This is the matrix from the equation for v1: [Rmat][v1] = [A] - Rmat = reshape((/1., -dton2*Omegap(3), dton2*Omegap(2), & - dton2*Omegap(3), 1., -dton2*Omegap(1), & - -dton2*Omegap(2), dton2*Omegap(1), 1. /),(/3,3/)) + Rmat = reshape((/1., -dkdt*Omegap(3), dkdt*Omegap(2), & + dkdt*Omegap(3), 1., -dkdt*Omegap(1), & + -dkdt*Omegap(2), dkdt*Omegap(1), 1. /),(/3,3/)) ! Get the inverse matrix call matrixinvert3D(Rmat,Rinv,ierr) @@ -189,7 +186,7 @@ subroutine update_ltforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& ! call warning('extern_lensethirring',' lense-thirring force > 10% of total force') ! endif -end subroutine update_ltforce_leapfrog +end subroutine update_ltforce !--------------------------------------------------------------- !+ diff --git a/src/main/extern_prdrag.f90 b/src/main/extern_prdrag.f90 index 78456bd68..a8db0f9ff 100644 --- a/src/main/extern_prdrag.f90 +++ b/src/main/extern_prdrag.f90 @@ -19,7 +19,7 @@ module extern_prdrag ! ! subroutine get_prdrag_spatial_force-- use beta_module, only:beta ! subroutine get_prdrag_vdependent_force-- use beta_module, only:beta -! subroutine update_prdrag_leapfrog-- use beta_module, only:beta +! subroutine update_prdrag-- use beta_module, only:beta ! subroutine write_options_prdrag-- use beta_module, only:write_options_beta ! subroutine read_options_prdrag-- use beta_module, only:read_options_beta ! @@ -43,7 +43,7 @@ module extern_prdrag real, private :: k1 = 1. ! redshift public :: get_prdrag_spatial_force, get_prdrag_vdependent_force - public :: update_prdrag_leapfrog + public :: update_prdrag public :: read_options_prdrag, write_options_prdrag private @@ -111,19 +111,19 @@ subroutine get_prdrag_vdependent_force(xyzi,vel,Mstar,fexti) end subroutine get_prdrag_vdependent_force -subroutine update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,Mstar) +subroutine update_prdrag(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,Mstar) use lumin_nsdisc, only:beta use units, only:get_c_code use io, only:warn - real, intent(in) :: dt,xi,yi,zi, Mstar + real, intent(in) :: dkdt,xi,yi,zi, Mstar real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(inout) :: fexti(3) real :: r, r2, r3, Q, betai real :: Tx, Ty, Tz, vonex, voney, vonez - real :: denominator, vrhalf, vrone, twoQondt + real :: denominator, vrhalf, vrone, Qondkdt real :: xi2, yi2, zi2, ccode, kd - character(len=30), parameter :: label = 'update_prdrag_leapfrog' + character(len=30), parameter :: label = 'update_prdrag' ccode = get_c_code() @@ -139,12 +139,12 @@ subroutine update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,y betai = beta( xi, yi, zi ) Q = Mstar*betai*dt/(2.*ccode*r*r) - twoQondt = 2.*Q/dt + Qondkdt = Q/dkdt denominator = -r2*( k2*kd*Q*Q + (kd-k2)*Q - 1 ) - Tx = vhalfx + 0.5*dt*fxi - Ty = vhalfy + 0.5*dt*fyi - Tz = vhalfz + 0.5*dt*fzi + Tx = vhalfx + dkdt*fxi + Ty = vhalfy + dkdt*fyi + Tz = vhalfz + dkdt*fzi vonex = (-(Q*k1*xi)*(Ty*yi+Tz*zi)+Q*kd*Tx*r2-Tx*(r2+Q*k1*xi2))/denominator voney = (-(Q*k1*yi)*(Tx*xi+Tz*zi)+Q*kd*Ty*r2-Ty*(r2+Q*k1*yi2))/denominator @@ -152,15 +152,15 @@ subroutine update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,y vrone = (vonex*xi + voney*yi + vonez*zi)/r ! vr = rhat dot v - fexti(1) = twoQondt * (vonex*k2 + k1*vrone*xi/r) - fexti(2) = twoQondt * (voney*k2 + k1*vrone*yi/r) - fexti(3) = twoQondt * (vonez*k2 + k1*vrone*zi/r) + fexti(1) = Qondkdt * (vonex*k2 + k1*vrone*xi/r) + fexti(2) = Qondkdt * (voney*k2 + k1*vrone*yi/r) + fexti(3) = Qondkdt * (vonez*k2 + k1*vrone*zi/r) fxi = fxi + fexti(1) fyi = fyi + fexti(2) fzi = fzi + fexti(3) -end subroutine update_prdrag_leapfrog +end subroutine update_prdrag !----------------------------------------------------------------------- !+ diff --git a/src/main/externalforces.f90 b/src/main/externalforces.f90 index 51f3ecd3c..d6ece456f 100644 --- a/src/main/externalforces.f90 +++ b/src/main/externalforces.f90 @@ -33,7 +33,7 @@ module externalforces public :: accradius1,omega_corotate,accretedmass1,accretedmass2 public :: write_options_externalforces,read_options_externalforces public :: initialise_externalforces,is_velocity_dependent - public :: update_vdependent_extforce_leapfrog + public :: update_vdependent_extforce public :: update_externalforce public :: write_headeropts_extern,read_headeropts_extern @@ -493,14 +493,14 @@ end subroutine externalforce_vdependent ! necessary for using v-dependent forces in leapfrog !+ !----------------------------------------------------------------------- -subroutine update_vdependent_extforce_leapfrog(iexternalforce, & - vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,densi,ui) - use extern_corotate, only:update_coriolis_leapfrog - use extern_prdrag, only:update_prdrag_leapfrog - use extern_lensethirring, only:update_ltforce_leapfrog - use extern_gnewton, only:update_gnewton_leapfrog +subroutine update_vdependent_extforce(iexternalforce, & + vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,densi,ui) + use extern_corotate, only:update_coriolis + use extern_prdrag, only:update_prdrag + use extern_lensethirring, only:update_ltforce + use extern_gnewton, only:update_gnewton integer, intent(in) :: iexternalforce - real, intent(in) :: dt,xi,yi,zi + real, intent(in) :: dkdt,xi,yi,zi real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(out) :: fexti(3) @@ -508,16 +508,16 @@ subroutine update_vdependent_extforce_leapfrog(iexternalforce, & select case(iexternalforce) case(iext_corotate,iext_corot_binary) - call update_coriolis_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt) + call update_coriolis(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt) case(iext_prdrag) - call update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,mass1) + call update_prdrag(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,mass1) case(iext_lensethirring,iext_einsteinprec) - call update_ltforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,mass1) + call update_ltforce(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,mass1) case(iext_gnewton) - call update_gnewton_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,mass1) + call update_gnewton(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,mass1) end select -end subroutine update_vdependent_extforce_leapfrog +end subroutine update_vdependent_extforce !----------------------------------------------------------------------- !+ diff --git a/src/main/externalforces_gr.f90 b/src/main/externalforces_gr.f90 index 562660310..4219f96ae 100644 --- a/src/main/externalforces_gr.f90 +++ b/src/main/externalforces_gr.f90 @@ -27,7 +27,7 @@ module externalforces public :: accrete_particles,was_accreted public :: write_options_externalforces,read_options_externalforces public :: initialise_externalforces,is_velocity_dependent - public :: update_vdependent_extforce_leapfrog + public :: update_vdependent_extforce public :: update_externalforce public :: write_headeropts_extern,read_headeropts_extern @@ -124,7 +124,7 @@ end subroutine externalforce_vdependent ! necessary for using v-dependent forces in leapfrog !+ !----------------------------------------------------------------------- -subroutine update_vdependent_extforce_leapfrog(iexternalforce, & +subroutine update_vdependent_extforce(iexternalforce, & vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,densi,ui) integer, intent(in) :: iexternalforce real, intent(in) :: dt,xi,yi,zi @@ -136,7 +136,7 @@ subroutine update_vdependent_extforce_leapfrog(iexternalforce, & ! ! This doesn't doesn't actually get used in gr... ! -end subroutine update_vdependent_extforce_leapfrog +end subroutine update_vdependent_extforce !----------------------------------------------------------------------- !+ diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 07af536cb..a29fbfabe 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -68,8 +68,16 @@ module ptmass real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius real, public :: f_crit_override = 0.0 ! 1000. + + logical, public :: use_fourthorder = .false. integer, public :: n_force_order = 1 + real, public, parameter :: dk2(3) = (/0.5,0.5,0.0/) + real, public, parameter :: ck2(2) = (/1.,0.0/) + real, public, parameter :: dk4(3) = (/1./6.,2./3.,1./6./) + real, public, parameter :: ck4(2) = (/0.5,0.5/) + + ! Note for above: if f_crit_override > 0, then will unconditionally make a sink when rho > f_crit_override*rho_crit_cgs ! This is a dangerous parameter since failure to form a sink might be indicative of another problem. ! This is a hard-coded parameter due to this danger, but will appear in the .in file if set > 0. @@ -510,228 +518,6 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin end subroutine get_accel_sink_sink -!---------------------------------------------------------------- -!+ -! get gradient correction of the force for FSI integrator (sink-gas) -!+ -!---------------------------------------------------------------- -subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & - pmassi,fxyz_ptmass,fsink_old) - use kernel, only:kernel_softening,kernel_grad_soft,radkern - integer, intent(in) :: nptmass - real, intent(in) :: xi,yi,zi,hi,dt - real, intent(inout) :: fxi,fyi,fzi - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(in) :: pmassi - real, intent(inout) :: fxyz_ptmass(4,nptmass) - real, intent(in) :: fsink_old(4,nptmass) - real :: gtmpxi,gtmpyi,gtmpzi - real :: dx,dy,dz,rr2,ddr,dr3,g11,g12,g21,g22,pmassj - real :: dfx,dfy,dfz,drdotdf - real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft,gpref - integer :: j - - gtmpxi = 0. ! use temporary summation variable - gtmpyi = 0. ! (better for round-off, plus we need this bit of - gtmpzi = 0. - - do j=1,nptmass - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - dfx = fxi - fsink_old(1,j) - dfy = fyi - fsink_old(2,j) - dfz = fzi - fsink_old(3,j) - pmassj = xyzmh_ptmass(4,j) - hsoft = xyzmh_ptmass(ihsoft,j) - if (hsoft > 0.0) hsoft = max(hsoft,hi) - if (pmassj < 0.0) cycle - - rr2 = dx*dx + dy*dy + dz*dz + epsilon(rr2) - drdotdf = dx*dfx + dy*dfy + dz*dfz + epsilon(drdotdf) - ddr = 1./sqrt(rr2) - if (rr2 < (radkern*hsoft)**2) then - ! - ! if the sink particle is given a softening length, soften the - ! force and potential if r < radkern*hsoft - ! - hsoft1 = 1.0/hsoft - hsoft21= hsoft1**2 - q2i = rr2*hsoft21 - qi = sqrt(q2i) - call kernel_softening(q2i,qi,psoft,fsoft) - - gpref = ((dt**2)/24.)*hsoft21 - - ! first grad term of gas due to point mass particle - g11 = pmassj*fsoft*ddr - - ! first grad term of sink from gas - g21 = pmassi*fsoft*ddr - - call kernel_grad_soft(q2i,qi,gsoft) - - dr3 = ddr*ddr*ddr - - ! Second grad term of gas due to point mass particle - g12 = pmassj*gsoft*dr3*drdotdf - - ! Second grad term of sink from gas - g22 = pmassi*gsoft*dr3*drdotdf - - gtmpxi = gtmpxi - gpref*(dfx*g11+dx*g12) - gtmpyi = gtmpyi - gpref*(dfy*g11+dy*g12) - gtmpzi = gtmpzi - gpref*(dfz*g11+dz*g12) - - - else - ! no softening on the sink-gas interaction - dr3 = ddr*ddr*ddr - - gpref = ((dt**2)/24.) - - ! first grad term of gas due to point mass particle - g11 = pmassj*dr3 - - ! first grad term of sink from gas - g21 = pmassi*dr3 - - ! first grad term of gas due to point mass particle - g12 = -3.*pmassj*dr3*ddr*ddr*drdotdf - - ! first grad term of sink from gas - g22 = -3.*pmassi*dr3*ddr*ddr*drdotdf - - - gtmpxi = gtmpxi - gpref*(dfx*g11+dx*g12) - gtmpyi = gtmpyi - gpref*(dfy*g11+dy*g12) - gtmpzi = gtmpzi - gpref*(dfz*g11+dz*g12) - endif - - ! backreaction of gas onto sink - fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + gpref*(dfx*g21 + dx*g22) - fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + gpref*(dfy*g21 + dy*g22) - fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + gpref*(dfz*g21 + dz*g22) - enddo - ! - ! add temporary sums to existing force on gas particle - ! - fxi = fxi + gtmpxi - fyi = fyi + gtmpyi - fzi = fzi + gtmpzi - -end subroutine get_gradf_sink_gas - -!---------------------------------------------------------------- -!+ -! get gradient correction of the force for FSI integrator (sink-gas) -!+ -!---------------------------------------------------------------- -subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old) - use kernel, only:kernel_softening,kernel_grad_soft,radkern - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(inout) :: fxyz_ptmass(4,nptmass) - real, intent(in) :: fsink_old(4,nptmass) - real, intent(in) :: dt - real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,gxi,gyi,gzi - real :: ddr,dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,dr3,g1,g2 - real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft - real :: gpref - integer :: i,j - - if (nptmass <= 1) return - if (h_soft_sinksink > 0.) then - hsoft1 = 1.0/h_soft_sinksink - hsoft21= hsoft1**2 - else - hsoft1 = 0. ! to avoid compiler warnings - hsoft21 = 0. - endif - ! - !--compute N^2 gradf on point mass particles due to each other - ! - !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,fsink_old) & - !$omp shared(h_soft_sinksink,hsoft21,dt) & - !$omp private(i,xi,yi,zi,pmassi,pmassj) & - !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & - !$omp private(fxi,fyi,fzi,gxi,gyi,gzi,gpref) & - !$omp private(q2i,qi,psoft,fsoft,gsoft) - do i=1,nptmass - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) - pmassi = xyzmh_ptmass(4,i) - if (pmassi < 0.) cycle - fxi = fsink_old(1,i) - fyi = fsink_old(2,i) - fzi = fsink_old(3,i) - gxi = 0. - gyi = 0. - gzi = 0. - do j=1,nptmass - if (i==j) cycle - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - dfx = fxi - fsink_old(1,j) - dfy = fyi - fsink_old(2,j) - dfz = fzi - fsink_old(3,j) - pmassj = xyzmh_ptmass(4,j) - if (pmassj < 0.) cycle - - rr2 = dx*dx + dy*dy + dz*dz + epsilon(rr2) - drdotdf = dx*dfx + dy*dfy + dz*dfz - ddr = 1./sqrt(rr2) - - gpref = pmassj*((dt**2)/24.) - - if (rr2 < (radkern*h_soft_sinksink)**2) then - ! - ! if the sink particle is given a softening length, soften the - ! force and potential if r < radkern*h_soft_sinksink - ! - q2i = rr2*hsoft21 - qi = sqrt(q2i) - call kernel_softening(q2i,qi,psoft,fsoft) ! Note: psoft < 0 - - - ! gradf part 1 of sink1 from sink2 - g1 = fsoft*hsoft21*ddr - - call kernel_grad_soft(q2i,qi,gsoft) - - dr3 = ddr*ddr*ddr - - ! gradf part 2 of sink1 from sink2 - g2 = gsoft*hsoft21*dr3*drdotdf - gxi = gxi - gpref*(dfx*g1 + dx*g2) - gyi = gyi - gpref*(dfy*g1 + dy*g2) - gzi = gzi - gpref*(dfz*g1 + dz*g2) - - else - ! no softening on the sink-sink interaction - dr3 = ddr*ddr*ddr - - ! gradf part 1 of sink1 from sink2 - g1 = dr3 - ! gradf part 2 of sink1 from sink2 - g2 = -3.*dr3*ddr*ddr*drdotdf - gxi = gxi - gpref*(dfx*g1 + dx*g2) - gyi = gyi - gpref*(dfy*g1 + dy*g2) - gzi = gzi - gpref*(dfz*g1 + dz*g2) - endif - enddo - ! - !--store sink-sink forces (only) - ! - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + gxi - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + gyi - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + gzi - enddo -!$omp end parallel do -end subroutine get_gradf_sink_sink !---------------------------------------------------------------- !+ ! Update position of sink particles if they cross the periodic boundary @@ -820,7 +606,7 @@ end subroutine ptmass_kick !+ !---------------------------------------------------------------- subroutine ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) - use externalforces, only:update_vdependent_extforce_leapfrog + use externalforces, only:update_vdependent_extforce integer, intent(in) :: nptmass real, intent(in) :: dkdt real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) @@ -838,7 +624,7 @@ subroutine ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyz fxi = fxyz_ptmass(1,i) fyi = fxyz_ptmass(2,i) fzi = fxyz_ptmass(3,i) - call update_vdependent_extforce_leapfrog(iexternalforce,& + call update_vdependent_extforce(iexternalforce,& vxyz_ptmass(1,i),vxyz_ptmass(2,i),vxyz_ptmass(3,i), & fxi,fyi,fzi,fextv,dkdt,xyzmh_ptmass(1,i),xyzmh_ptmass(2,i), & xyzmh_ptmass(3,i)) @@ -2107,6 +1893,7 @@ end subroutine write_options_ptmass !----------------------------------------------------------------------- subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) use io, only:warning,fatal + use step_extern,only:ck,dk character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr @@ -2173,7 +1960,16 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) ngot = ngot + 1 case('use_fourthorder') read(valstring,*,iostat=ierr) use_fourthorder - if (use_fourthorder) n_force_order = 3 + if (use_fourthorder) then + n_force_order = 3 + ck = ck4 + dk = dk4 + else + ck = ck2 + dk = dk2 + endif + + case default imatch = .false. end select diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 3b7681f19..10e9aa26c 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -39,8 +39,8 @@ module step_extern public :: step_extern_sph_gr public :: step_extern_pattern - real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) - real,parameter :: ck(2) = (/0.5,0.5/) + real, public :: dk(3) + real, public :: ck(2) private @@ -537,12 +537,12 @@ end subroutine step_extern_pattern !+ !---------------------------------------------------------------- -subroutine drift(ck,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) +subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) use part, only:isdead_or_accreted,ispinx,ispiny,ispinz use ptmass, only:ptmass_drift use io , only:id,master use mpiutils, only:bcast_mpi - real, intent(in) :: dt,ck + real, intent(in) :: dt,cki integer, intent(in) :: npart,nptmass,ntypes real, intent(inout) :: time_par real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -550,7 +550,7 @@ subroutine drift(ck,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxy real :: ckdt integer :: i - ckdt = ck*dt + ckdt = cki*dt ! Drift gas particles @@ -585,7 +585,7 @@ end subroutine drift !+ !---------------------------------------------------------------- -subroutine kick(dk,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & +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) use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas use ptmass, only:f_acc,ptmass_accrete,pt_write_sinkev,update_ptmass,ptmass_kick @@ -596,7 +596,7 @@ subroutine kick(dk,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi use dim, only:ind_timesteps,maxp,maxphase use timestep_sts, only:sts_it_n - real, intent(in) :: dt,dk + real, intent(in) :: dt,dki integer, intent(in) :: npart,nptmass,ntypes real, intent(inout) :: xyzh(:,:) real, intent(inout) :: vxyzu(:,:),fext(:,:) @@ -620,7 +620,7 @@ subroutine kick(dk,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, itype = iphase(igas) pmassi = massoftype(igas) - dkdt = dk*dt + dkdt = dki*dt ! Kick sink particles if (nptmass>0) then @@ -765,7 +765,7 @@ end subroutine kick !---------------------------------------------------------------- subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, & - fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck,dk, & + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,cki,dki, & force_count,extf_vdep_flag,fsink_old) use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc @@ -787,7 +787,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) real, intent(inout) :: dtextforce - real, intent(in) :: timei,ck,dk,dt + real, intent(in) :: timei,cki,dki,dt logical, intent(in) :: extf_vdep_flag real, optional, intent(inout) :: fsink_old(4,nptmass) integer :: merge_ij(nptmass) @@ -809,8 +809,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, force_count = force_count + 1 extrapfac = (1./24.)*dt**2 - dkdt = dk*dt - ckdt = ck*dt + dkdt = dki*dt + ckdt = cki*dt itype = igas pmassi = massoftype(igas) dtextforcenew = bignumber @@ -1059,7 +1059,7 @@ end subroutine cooling_abundances_update subroutine external_force_update_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew,dtf,dkdt, & fextx,fexty,fextz,extf_is_velocity_dependent,iexternalforce) use timestep, only:C_force - use externalforces, only: externalforce,update_vdependent_extforce_leapfrog + use externalforces, only: externalforce,update_vdependent_extforce real, intent(in) :: xi,yi,zi,hi,vxi,vyi,vzi,timei,dkdt real, intent(inout) :: dtextforcenew,dtf,fextx,fexty,fextz integer, intent(in) :: iexternalforce,i @@ -1082,7 +1082,7 @@ subroutine external_force_update_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcen fextxi = fextx fextyi = fexty fextzi = fextz - call update_vdependent_extforce_leapfrog(iexternalforce,vxi,vyi,vzi, & + call update_vdependent_extforce(iexternalforce,vxi,vyi,vzi, & fextxi,fextyi,fextzi,fextv,dkdt,xi,yi,zi) fextx = fextx + fextv(1) fexty = fexty + fextv(2) diff --git a/src/tests/test_externf.f90 b/src/tests/test_externf.f90 index f6bb79410..13433ddb4 100644 --- a/src/tests/test_externf.f90 +++ b/src/tests/test_externf.f90 @@ -35,7 +35,7 @@ subroutine test_externf(ntests,npass) use externalforces, only:externalforcetype,externalforce,accrete_particles, & was_accreted,iexternalforce_max,initialise_externalforces,& accradius1,update_externalforce,is_velocity_dependent,& - externalforce_vdependent,update_vdependent_extforce_leapfrog,& + externalforce_vdependent,update_vdependent_extforce,& iext_lensethirring,iext_prdrag,iext_einsteinprec,iext_spiral,& iext_densprofile,iext_staticsine,iext_gwinspiral use extern_corotate, only:omega_corotate @@ -52,7 +52,7 @@ subroutine test_externf(ntests,npass) real :: psep,fxi,fyi,fzi,dtf,time,pmassi,dhi real :: fextxi,fextyi,fextzi,dumx,dumy,dumz,pot1,pot2 real :: xerrmax,yerrmax,zerrmax,ferrmaxx,ferrmaxy,ferrmaxz - real :: xi(4),v1(3),fext_iteration(3),fexti(3),vhalfx,vhalfy,vhalfz,dt + real :: xi(4),v1(3),fext_iteration(3),fexti(3),vhalfx,vhalfy,vhalfz,dt,hdt real :: xmini(3),xmaxi(3),poti real, parameter :: tolf = 1.5e-3 real, parameter :: tolfold = 1.e-10 @@ -199,24 +199,25 @@ subroutine test_externf(ntests,npass) fxi = -0.0789 ! non-zero, but small so that v-dependent fyi = 0.036 ! part is dominant component of the force fzi = -0.01462 + hdt = 0.5*dt ! ! get an explicit evaluation of the external force ! and solve v^1 = v^1/2 + dt/2*[f1(x^1) + f1(x^1,v^1)] ! by iterating 20 times ! - v1 = (/vhalfx + 0.5*dt*fxi,vhalfy + 0.5*dt*fyi,vhalfz + 0.5*dt*fzi/) + v1 = (/vhalfx + hdt*fxi,vhalfy + hdt*fyi,vhalfz + hdt*fzi/) do i=1,30 call externalforce_vdependent(iextf,xi(1:3),v1,fext_iteration,poti) - v1(1) = vhalfx + 0.5*dt*(fxi + fext_iteration(1)) - v1(2) = vhalfy + 0.5*dt*(fyi + fext_iteration(2)) - v1(3) = vhalfz + 0.5*dt*(fzi + fext_iteration(3)) + v1(1) = vhalfx + hdt*(fxi + fext_iteration(1)) + v1(2) = vhalfy + hdt*(fyi + fext_iteration(2)) + v1(3) = vhalfz + hdt*(fzi + fext_iteration(3)) !print*,'fext_iteration = ',fext_iteration enddo ! ! call update_leapfrog routine to get analytic solution ! - call update_vdependent_extforce_leapfrog(iextf,vhalfx,vhalfy,vhalfz,& - fxi,fyi,fzi,fexti,dt,xi(1),xi(2),xi(3)) + call update_vdependent_extforce(iextf,vhalfx,vhalfy,vhalfz,& + fxi,fyi,fzi,fexti,hdt,xi(1),xi(2),xi(3)) ! ! check that these agree with each other ! diff --git a/src/tests/test_gnewton.f90 b/src/tests/test_gnewton.f90 index 3dff7afa3..ebc352296 100644 --- a/src/tests/test_gnewton.f90 +++ b/src/tests/test_gnewton.f90 @@ -157,7 +157,7 @@ end subroutine test_gnewton !+ !----------------------------------------------------------------------- subroutine step_lf(t,dt,dtnew) - use externalforces, only:externalforce,update_vdependent_extforce_leapfrog,externalforce_vdependent + use externalforces, only:externalforce,update_vdependent_extforce,externalforce_vdependent use timestep, only:C_force use part, only:xyzh,vxyzu use options, only:iexternalforce @@ -191,9 +191,9 @@ subroutine step_lf(t,dt,dtnew) fy = fexty fz = fextz - call update_vdependent_extforce_leapfrog(iexternalforce,& + call update_vdependent_extforce(iexternalforce,& vxhalf,vyhalf,vzhalf, & - fx,fy,fz,fextv,dt,xyzh(1,1),xyzh(2,1),xyzh(3,1)) + fx,fy,fz,fextv,hdt,xyzh(1,1),xyzh(2,1),xyzh(3,1)) vxyzu(1,1) = vxhalf + hdt*fx vxyzu(2,1) = vyhalf + hdt*fy diff --git a/src/tests/test_gr.f90 b/src/tests/test_gr.f90 index e32beae2d..1e424118b 100644 --- a/src/tests/test_gr.f90 +++ b/src/tests/test_gr.f90 @@ -166,7 +166,7 @@ end subroutine test_inccirc subroutine integrate_geodesic(tmax,dt,xyz,vxyz,angmom0,angmom) use io, only:iverbose use part, only:igas,npartoftype,massoftype,set_particle_type,get_ntypes,ien_type - use step_lf_global, only:step_extern_gr + use step_extern, only:step_extern_gr use eos, only:ieos use cons2prim, only:prim2consall use metric_tools, only:init_metric,unpack_metric From 72c6093d1335deb97782a092c772941711b4014e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 15 Apr 2024 11:56:49 +1000 Subject: [PATCH 417/814] fix group_info to handle correctly only external forces --- src/main/part.F90 | 3 +- src/main/ptmass.F90 | 55 ++++--- src/main/sdar_group.f90 | 328 +++++++++++++++++++++++--------------- src/main/step_extern.F90 | 4 +- src/main/utils_kepler.f90 | 4 +- 5 files changed, 235 insertions(+), 159 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index 2f124e91d..f9c026ddd 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -297,6 +297,7 @@ module part integer(kind=1), allocatable :: nmatrix(:,:) integer, parameter :: igarg = 1 ! idx of the particle member of a group integer, parameter :: igcum = 2 ! cumulative sum of the indices to find the starting and ending point of a group + integer, parameter :: igid = 3 ! id of the group, correspond to the root of the group in the dfs/union find construction ! needed for group identification and sorting integer :: n_group = 0 integer :: n_ingroup = 0 @@ -493,7 +494,7 @@ subroutine allocate_part call allocate_array('abundance', abundance, nabundances, maxp_h2) endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) - call allocate_array('group_info', group_info, 2, maxptmass) + call allocate_array('group_info', group_info, 3, maxptmass) call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) call allocate_array("gtgrad", gtgrad, 3, maxptmass) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 259ae0a23..33853473f 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -299,7 +299,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec - use part, only:igarg,igcum + use part, only:igarg,igid integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(out) :: fxyz_ptmass(4,nptmass) @@ -307,7 +307,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin integer, intent(in) :: iexternalforce real, intent(in) :: ti integer, intent(out) :: merge_ij(:),merge_n - integer, optional, intent(in) :: group_info(:,:) + integer, optional, intent(in) :: group_info(3,nptmass) real, intent(out) :: dsdt_ptmass(3,nptmass) real, optional, intent(in) :: extrapfac real, optional, intent(in) :: fsink_old(4,nptmass) @@ -318,8 +318,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real :: fterm,pterm,potensoft0,dsx,dsy,dsz real :: J2i,rsinki,shati(3) real :: J2j,rsinkj,shatj(3) - integer :: k,l,i,j,start_id,end_id - logical :: extrap,wsub + integer :: k,l,i,j,gidi,gidj + logical :: extrap,subsys dtsinksink = huge(dtsinksink) fxyz_ptmass(:,:) = 0. @@ -335,11 +335,11 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin extrap = .false. endif - if(present(group_info)) then - wsub = .true. - extrap = .false. + if (present(group_info)) then + subsys = .true. + else + subsys = .false. endif - ! !--get self-contribution to the potential if sink-sink softening is used ! @@ -356,11 +356,11 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !--compute N^2 forces on point mass particles due to each other ! !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info,subsys) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & !$omp shared(extrapfac,extrap,fsink_old) & !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & - !$omp private(start_id,end_id) & + !$omp private(gidi,gidj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & !$omp private(fextx,fexty,fextz,phiext) & @@ -369,10 +369,9 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) do k=1,nptmass - if (wsub) then - start_id = group_info(igcum,k) + 1 - end_id = group_info(igcum,k) + if (subsys) then i = group_info(igarg,k) + gidi = group_info(igid,k) else i = k endif @@ -398,9 +397,10 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dsy = 0. dsz = 0. do l=1,nptmass - if (present(group_info)) then + if (subsys) then j = group_info(igarg,l) - if (j>=start_id .or. j<=end_id) cycle + gidj = group_info(igid,l) + if (gidi==gidj) cycle else j = l endif @@ -660,7 +660,7 @@ end subroutine get_gradf_sink_gas !---------------------------------------------------------------- subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) use kernel, only:kernel_softening,kernel_grad_soft,radkern - use part, only:igarg,igcum + use part, only:igarg,igid integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: fxyz_ptmass(4,nptmass) @@ -671,7 +671,14 @@ subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,gro real :: ddr,dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,dr3,g1,g2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft real :: gpref - integer :: i,j,k,l,start_id,end_id + integer :: i,j,k,l,gidi,gidj + logical :: subsys + + if (present(group_info)) then + subsys = .true. + else + subsys=.false. + endif if (nptmass <= 1) return if (h_soft_sinksink > 0.) then @@ -686,17 +693,16 @@ subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,gro ! !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) & - !$omp shared(h_soft_sinksink,hsoft21,dt) & + !$omp shared(h_soft_sinksink,hsoft21,dt,subsys) & !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & - !$omp private(start_id,end_id) & + !$omp private(gidi,gidj) & !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & !$omp private(fxi,fyi,fzi,gxi,gyi,gzi,gpref) & !$omp private(q2i,qi,psoft,fsoft,gsoft) do k=1,nptmass - if (present(group_info)) then - start_id = group_info(igcum,k) + 1 - end_id = group_info(igcum,k) + if (subsys) then i = group_info(igarg,k) + gidi = group_info(igid,k) else i = k endif @@ -712,9 +718,10 @@ subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,gro gyi = 0. gzi = 0. do l=1,nptmass - if (present(group_info)) then + if (subsys) then j = group_info(igarg,l) - if (j>=start_id .or. j<=end_id) cycle + gidj = group_info(igid,l) + if (gidi==gidj) cycle else j = l endif diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 049b8130f..beba710bd 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -12,7 +12,7 @@ module sdar_group public :: group_identify public :: evolve_groups ! parameters for group identification - real, parameter :: eta_pert = 0.02 + real, parameter :: eta_pert = 0.0002 real, parameter :: time_error = 1e-10 real, parameter :: max_step = 100000 real, parameter, public :: r_neigh = 0.001 @@ -50,25 +50,26 @@ end subroutine group_identify subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) - use part, only : igarg,igcum + use part, only : igarg,igcum,igid integer, intent(in) :: nptmass integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) - integer, intent(inout) :: group_info(2,nptmass) + integer, intent(inout) :: group_info(3,nptmass) integer, intent(inout) :: n_group,n_ingroup,n_sing integer :: i,ncg logical :: visited(nptmass) visited = .false. - group_info(igcum,1) = 1 + group_info(igcum,1) = 0 do i=1,nptmass if(.not.visited(i)) then n_ingroup = n_ingroup + 1 call dfs(i,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) if (ncg>1)then n_group = n_group + 1 - group_info(igcum,n_group+1) = ncg + group_info(igcum,n_group) + group_info(igcum,n_group+1) = (ncg) + group_info(igcum,n_group) else n_ingroup = n_ingroup - 1 group_info(igarg,nptmass-n_sing) = i + group_info(igid,nptmass-n_sing) = i n_sing = n_sing + 1 endif endif @@ -76,11 +77,11 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) end subroutine form_group subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) - use part, only : igarg + use part, only : igarg,igid integer, intent(in) :: nptmass,iroot integer, intent(out) :: ncg integer(kind=1), intent(in) :: nmatrix(nptmass,nptmass) - integer, intent(inout) :: group_info(2,nptmass) + integer, intent(inout) :: group_info(3,nptmass) integer, intent(inout) :: n_ingroup logical, intent(inout) :: visited(nptmass) integer :: stack(nptmass) @@ -89,6 +90,7 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) ncg = 1 inode = iroot group_info(igarg,n_ingroup) = inode + group_info(igid,n_ingroup) = iroot stack_top = stack_top + 1 stack(stack_top) = inode visited(inode) = .true. @@ -103,6 +105,7 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) stack(stack_top) = j visited(j) = .true. group_info(igarg,n_ingroup) = j + group_info(igid,n_ingroup) = iroot endif enddo enddo @@ -181,31 +184,42 @@ end subroutine matrix_construction ! !--------------------------------------------- -subroutine evolve_groups(n_group,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) +subroutine evolve_groups(n_group,nptmass,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) use part, only: igarg,igcum + use io, only: id,master + use mpiutils,only:bcast_mpi real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) - integer, intent(inout) :: n_group + integer, intent(in) :: n_group,nptmass real, intent(in) :: tnext integer :: i,start_id,end_id,gsize - !$omp parallel do default(none)& - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& - !$omp shared(tnext,group_info,gtgrad)& - !$omp private(i,start_id,end_id,gsize) - do i=1,n_group - start_id = group_info(igcum,i) + 1 - end_id = group_info(igcum,i+1) - gsize = end_id - start_id - call integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - enddo - !$omp end parallel do + if (n_group>0) then + if(id==master) then + !$omp parallel do default(none)& + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& + !$omp shared(tnext,group_info,gtgrad)& + !$omp private(i,start_id,end_id,gsize) + do i=1,n_group + start_id = group_info(igcum,i) + 1 + end_id = group_info(igcum,i+1) + gsize = end_id - start_id + call integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) + enddo + !$omp end parallel do + endif + endif + + call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) end subroutine evolve_groups -subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) +subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) + use part, only: igarg real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: group_info(:,:) integer, intent(in) :: start_id,end_id,gsize real, intent(in) :: tnext real, allocatable :: bdata(:) @@ -216,16 +230,16 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas real :: dt,ds_init,dt_end,step_modif,t_old,W_old real :: W,tcoord logical :: t_end_flag,backup_flag,ismultiple - integer :: i + integer :: i,prim,sec tcoord = tnext ismultiple = gsize > 2 - call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,W,start_id,end_id,ismultiple,ds_init) + call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,start_id,end_id,ismultiple,ds_init) - allocate(bdata(gsize*9)) + allocate(bdata(gsize*6)) step_count_int = 0 step_count_tsyn = 0 @@ -238,20 +252,22 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas do while (.true.) if (backup_flag) then - call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,bdata) + call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,bdata) else - call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,tcoord,t_old,W,W_old,bdata) + call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) endif t_old = tcoord W_old = W if (gsize>1) then do i=1,ck_size - call drift_TTL (tcoord,W,ds(switch)*ck(i),xyzmh_ptmass,vxyz_ptmass,start_id,end_id) + call drift_TTL (tcoord,W,ds(switch)*ck(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) time_table(i) = tcoord - call kick_TTL (ds(switch)*dk(i),W,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,start_id,end_id) + call kick_TTL (ds(switch)*dk(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,start_id,end_id) enddo else - call oneStep_bin(tcoord,W,ds(switch),xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,start_id,end_id) + prim = group_info(igarg,start_id) + sec = group_info(igarg,end_id) + call oneStep_bin(tcoord,W,ds(switch),xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,prim,sec) endif dt = tcoord - t_old @@ -357,46 +373,46 @@ end subroutine new_ds_sync_sup -subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,bdata) - real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) - real, intent(out)::bdata(:) +subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,bdata) + use part, only: igarg + real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + integer,intent(in) :: group_info(:,:) + real, intent(out) ::bdata(:) integer,intent(in) :: start_id,end_id - integer :: i,j + integer :: i,j,k j=0 - do i=start_id,end_id - bdata(j*9+1) = xyzmh_ptmass(1,i) - bdata(j*9+2) = xyzmh_ptmass(2,i) - bdata(j*9+3) = xyzmh_ptmass(3,i) - bdata(j*9+4) = vxyz_ptmass(1,i) - bdata(j*9+5) = vxyz_ptmass(2,i) - bdata(j*9+6) = vxyz_ptmass(3,i) - bdata(j*9+7) = fxyz_ptmass(1,i) - bdata(j*9+8) = fxyz_ptmass(2,i) - bdata(j*9+9) = fxyz_ptmass(3,i) + do k=start_id,end_id + i = group_info(igarg,k) + bdata(j*6+1) = xyzmh_ptmass(1,i) + bdata(j*6+2) = xyzmh_ptmass(2,i) + bdata(j*6+3) = xyzmh_ptmass(3,i) + bdata(j*6+4) = vxyz_ptmass(1,i) + bdata(j*6+5) = vxyz_ptmass(2,i) + bdata(j*6+6) = vxyz_ptmass(3,i) j = j + 1 enddo end subroutine backup_data -subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,tcoord,t_old,W,W_old,bdata) +subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) + use part, only: igarg real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + integer,intent(in) :: group_info(:,:) real, intent(out) :: tcoord,W real, intent(in) :: t_old,W_old real, intent(in) :: bdata(:) integer, intent(in) :: start_id,end_id - integer :: i,j + integer :: k,i,j j = 0 - do i=start_id,end_id - xyzmh_ptmass(1,i) = bdata(j*9+1) - xyzmh_ptmass(2,i) = bdata(j*9+2) - xyzmh_ptmass(3,i) = bdata(j*9+3) - vxyz_ptmass(1,i) = bdata(j*9+4) - vxyz_ptmass(2,i) = bdata(j*9+5) - vxyz_ptmass(3,i) = bdata(j*9+6) - fxyz_ptmass(1,i) = bdata(j*9+7) - fxyz_ptmass(2,i) = bdata(j*9+8) - fxyz_ptmass(3,i) = bdata(j*9+9) + do k=start_id,end_id + i = group_info(igarg,k) + xyzmh_ptmass(1,i) = bdata(j*6+1) + xyzmh_ptmass(2,i) = bdata(j*6+2) + xyzmh_ptmass(3,i) = bdata(j*6+3) + vxyz_ptmass(1,i) = bdata(j*6+4) + vxyz_ptmass(2,i) = bdata(j*6+5) + vxyz_ptmass(3,i) = bdata(j*6+6) j = j + 1 enddo tcoord = t_old @@ -405,19 +421,22 @@ subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,tc end subroutine restore_state -subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,s_id,e_id) +subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,s_id,e_id) + use part, only: igarg real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer,intent(in) :: group_info(:,:) real, intent(inout) :: tcoord real, intent(in) :: h,W integer,intent(in) :: s_id,e_id - integer :: i + integer :: k,i real :: dtd dtd = h/W tcoord = tcoord + dtd - do i=s_id,e_id + do k=s_id,e_id + i = group_info(igarg,k) xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd*vxyz_ptmass(2,i) xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd*vxyz_ptmass(3,i) @@ -425,26 +444,30 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,s_id,e_id) end subroutine drift_TTL -subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,s_id,e_id) +subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,s_id,e_id) + use part, only: igarg real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) + integer,intent(in) :: group_info(:,:) real, intent(in) :: h real, intent(inout) :: W integer,intent(in) :: s_id,e_id real :: om,dw,dtk - integer :: i + integer :: i,k - call get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) + call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id) dtk = h/om - do i=s_id,e_id + do k=s_id,e_id + i=group_info(igarg,k) vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + (0.5*dtk)*fxyz_ptmass(1,i) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + (0.5*dtk)*fxyz_ptmass(2,i) vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + (0.5*dtk)*fxyz_ptmass(3,i) enddo dw = 0. - do i=s_id,e_id + do k=s_id,e_id + i=group_info(igarg,k) dw = dw + vxyz_ptmass(1,i)*gtgrad(1,i) + & vxyz_ptmass(2,i)*gtgrad(2,i) + & vxyz_ptmass(3,i)*gtgrad(3,i) @@ -452,7 +475,8 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,s_id,e_id) W = W + dw*dtk - do i=s_id,e_id + do k=s_id,e_id + i=group_info(igarg,k) vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + (0.5*dtk)*fxyz_ptmass(1,i) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + (0.5*dtk)*fxyz_ptmass(2,i) vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + (0.5*dtk)*fxyz_ptmass(3,i) @@ -461,77 +485,80 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,s_id,e_id) end subroutine kick_TTL -subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,s_id,e_id) +subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,i,j) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:),time_table(:) real, intent(in) :: ds real, intent(inout) :: tcoord,W - integer, intent(in) :: s_id,e_id - integer :: i + integer, intent(in) :: i,j + integer :: k real :: dtd,dtk,dvel1(3),dvel2(3),dw,om - do i = 1,ck_size - dtd = ds*ck(i)/W + do k = 1,ck_size + dtd = ds*ck(k)/W tcoord = tcoord + dtd - time_table(i) = tcoord - - xyzmh_ptmass(1,s_id) = xyzmh_ptmass(1,s_id) + dtd*vxyz_ptmass(1,s_id) - xyzmh_ptmass(2,s_id) = xyzmh_ptmass(2,s_id) + dtd*vxyz_ptmass(2,s_id) - xyzmh_ptmass(3,s_id) = xyzmh_ptmass(3,s_id) + dtd*vxyz_ptmass(3,s_id) - xyzmh_ptmass(1,e_id) = xyzmh_ptmass(1,e_id) + dtd*vxyz_ptmass(1,e_id) - xyzmh_ptmass(2,e_id) = xyzmh_ptmass(2,e_id) + dtd*vxyz_ptmass(2,e_id) - xyzmh_ptmass(3,e_id) = xyzmh_ptmass(3,e_id) + dtd*vxyz_ptmass(3,e_id) - - call get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) - - dtk = ds*dk(i)/om - - dvel1(1) = 0.5*dtk*fxyz_ptmass(1,s_id) - dvel1(2) = 0.5*dtk*fxyz_ptmass(2,s_id) - dvel1(3) = 0.5*dtk*fxyz_ptmass(3,s_id) - dvel2(1) = 0.5*dtk*fxyz_ptmass(1,e_id) - dvel2(2) = 0.5*dtk*fxyz_ptmass(2,e_id) - dvel2(3) = 0.5*dtk*fxyz_ptmass(3,e_id) - - vxyz_ptmass(1,s_id) = vxyz_ptmass(1,s_id) + dvel1(1) - vxyz_ptmass(2,s_id) = vxyz_ptmass(2,s_id) + dvel1(2) - vxyz_ptmass(3,s_id) = vxyz_ptmass(3,s_id) + dvel1(3) - vxyz_ptmass(1,e_id) = vxyz_ptmass(1,e_id) + dvel2(1) - vxyz_ptmass(2,e_id) = vxyz_ptmass(2,e_id) + dvel2(2) - vxyz_ptmass(3,e_id) = vxyz_ptmass(3,e_id) + dvel2(3) - - dw = gtgrad(1,s_id)*vxyz_ptmass(1,s_id)+& - gtgrad(2,s_id)*vxyz_ptmass(2,s_id)+& - gtgrad(3,s_id)*vxyz_ptmass(3,s_id)+& - gtgrad(1,e_id)*vxyz_ptmass(1,e_id)+& - gtgrad(2,e_id)*vxyz_ptmass(2,e_id)+& - gtgrad(3,e_id)*vxyz_ptmass(3,e_id) + time_table(k) = tcoord + + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd*vxyz_ptmass(3,i) + xyzmh_ptmass(1,j) = xyzmh_ptmass(1,j) + dtd*vxyz_ptmass(1,j) + xyzmh_ptmass(2,j) = xyzmh_ptmass(2,j) + dtd*vxyz_ptmass(2,j) + xyzmh_ptmass(3,j) = xyzmh_ptmass(3,j) + dtd*vxyz_ptmass(3,j) + + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) + + dtk = ds*dk(k)/om + + dvel1(1) = 0.5*dtk*fxyz_ptmass(1,i) + dvel1(2) = 0.5*dtk*fxyz_ptmass(2,i) + dvel1(3) = 0.5*dtk*fxyz_ptmass(3,i) + dvel2(1) = 0.5*dtk*fxyz_ptmass(1,j) + dvel2(2) = 0.5*dtk*fxyz_ptmass(2,j) + dvel2(3) = 0.5*dtk*fxyz_ptmass(3,j) + + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dvel1(1) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dvel1(2) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dvel1(3) + vxyz_ptmass(1,j) = vxyz_ptmass(1,j) + dvel2(1) + vxyz_ptmass(2,j) = vxyz_ptmass(2,j) + dvel2(2) + vxyz_ptmass(3,j) = vxyz_ptmass(3,j) + dvel2(3) + + dw = gtgrad(1,i)*vxyz_ptmass(1,i)+& + gtgrad(2,i)*vxyz_ptmass(2,i)+& + gtgrad(3,i)*vxyz_ptmass(3,i)+& + gtgrad(1,j)*vxyz_ptmass(1,j)+& + gtgrad(2,j)*vxyz_ptmass(2,j)+& + gtgrad(3,j)*vxyz_ptmass(3,j) W = W + dw*dtk - vxyz_ptmass(1,s_id) = vxyz_ptmass(1,s_id) + dvel1(1) - vxyz_ptmass(2,s_id) = vxyz_ptmass(2,s_id) + dvel1(2) - vxyz_ptmass(3,s_id) = vxyz_ptmass(3,s_id) + dvel1(3) - vxyz_ptmass(1,e_id) = vxyz_ptmass(1,e_id) + dvel2(1) - vxyz_ptmass(2,e_id) = vxyz_ptmass(2,e_id) + dvel2(2) - vxyz_ptmass(3,e_id) = vxyz_ptmass(3,e_id) + dvel2(3) + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dvel1(1) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dvel1(2) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dvel1(3) + vxyz_ptmass(1,j) = vxyz_ptmass(1,j) + dvel2(1) + vxyz_ptmass(2,j) = vxyz_ptmass(2,j) + dvel2(2) + vxyz_ptmass(3,j) = vxyz_ptmass(3,j) + dvel2(3) enddo end subroutine oneStep_bin -subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) +subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id) + use part, only: igarg real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) + integer,intent(in) :: group_info(:,:) real, intent(out) :: om integer, intent(in) :: s_id,e_id real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,r real :: gravf,gtki - integer :: i,j + integer :: i,j,k,l om = 0. - do i=s_id,e_id + do k=s_id,e_id + i = group_info(igarg,k) fxyz_ptmass(1,i) = 0. fxyz_ptmass(2,i) = 0. fxyz_ptmass(3,i) = 0. @@ -543,15 +570,16 @@ subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) mi = xyzmh_ptmass(4,i) - do j=s_id,e_id - if (i==j) cycle + do l=s_id,e_id + if (k==l) cycle + j = group_info(igarg,l) dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) - r2 = dx**2+dy**2+dz**3 - r = sqrt(r) + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) mj = xyzmh_ptmass(4,j) - gravf = xyzmh_ptmass(4,j)*(1./r2*r) + gravf = mj*(1./r2*r) gtki = gtki + mj*(1./r) fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + dx*gravf fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + dy*gravf @@ -567,10 +595,48 @@ subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) end subroutine get_force_TTL -subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismultiple,ds_init) +subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: i,j + real, intent(out) :: om + real :: dx,dy,dz,r2,r,mi,mj + real :: gravf,gtk + + mi = xyzmh_ptmass(4,i) + mj = xyzmh_ptmass(4,j) + dx = xyzmh_ptmass(1,i)-xyzmh_ptmass(1,j) + dy = xyzmh_ptmass(2,i)-xyzmh_ptmass(2,j) + dz = xyzmh_ptmass(3,i)-xyzmh_ptmass(3,j) + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) + gravf = mj*(1./r2*r) + gtk = mj*(1./r) + + fxyz_ptmass(1,i) = dx*gravf + fxyz_ptmass(2,i) = dy*gravf + fxyz_ptmass(3,i) = dz*gravf + fxyz_ptmass(1,j) = -dx*gravf + fxyz_ptmass(2,j) = -dy*gravf + fxyz_ptmass(3,j) = -dz*gravf + + gtgrad(1,i) = dx*gravf*mi + gtgrad(2,i) = dy*gravf*mi + gtgrad(3,i) = dz*gravf*mi + gtgrad(1,j) = -dx*gravf*mi + gtgrad(2,j) = -dy*gravf*mi + gtgrad(3,j) = -dz*gravf*mi + + om = gtk*mi + +end subroutine get_force_TTL_bin + +subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e_id,ismultiple,ds_init) use utils_kepler, only :extract_a_dot,extract_a,Espec + use part, only:igarg real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:) + integer,intent(in) :: group_info(:,:) real, intent(out) :: om,ds_init logical, intent(in) :: ismultiple integer, intent(in) :: s_id,e_id @@ -578,18 +644,14 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismulti real :: vxi,vyi,vzi,v2,vi,dvx,dvy,dvz,v,rdotv,axi,ayi,azi,acc,gravfi real :: gravf,gtki real :: Edot,E,semi,semidot - integer :: i,j + integer :: k,l,i,j Edot = 0. E = 0. om = 0. - do i=s_id,e_id - fxyz_ptmass(1,i) = 0. - fxyz_ptmass(2,i) = 0. - fxyz_ptmass(3,i) = 0. - enddo - do i=s_id,e_id + do k=s_id,e_id + i = group_info(igarg,k) gtki = 0. gravfi = 0. xi = xyzmh_ptmass(1,i) @@ -599,16 +661,20 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismulti vxi = vxyz_ptmass(1,i) vyi = vxyz_ptmass(2,i) vzi = vxyz_ptmass(3,i) - do j=s_id,e_id - if (i==j) cycle + fxyz_ptmass(1,i) = 0. + fxyz_ptmass(2,i) = 0. + fxyz_ptmass(3,i) = 0. + do l=s_id,e_id + if (k==l) cycle + j = group_info(igarg,l) dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) dvx = vxi - vxyz_ptmass(1,j) dvy = vyi - vxyz_ptmass(2,j) dvz = vzi - vxyz_ptmass(3,j) - r2 = dx**2+dy**2+dz**3 - r = sqrt(r) + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) mj = xyzmh_ptmass(4,j) gravf = xyzmh_ptmass(4,j)*(1./r2*r) gtki = gtki + mj*(1./r) @@ -632,7 +698,7 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismulti if (ismultiple) then vi = sqrt(vxi**2 + vyi**2 + vzi**2) Edot = Edot + mi*(vi*acc - gravfi) - E = E + 0.5*mi*vi**2 - om + E = E + 0.5*mi*vi**2 - gtki else mu = mi*mj call extract_a_dot(r2,r,mu,v2,v,acc,semidot) @@ -643,9 +709,9 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismulti om = om*0.5 if (ismultiple) then - ds_init = eta_pert * (Edot/E) + ds_init = eta_pert * (E/Edot) else - ds_init = eta_pert * (semidot/semi) + ds_init = eta_pert * (semi/semidot) endif end subroutine initial_int diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 310773a05..ae6124eba 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -550,7 +550,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass) real, intent(inout) :: fsink_old(4,nptmass),dsdt_ptmass(3,nptmass),gtgrad(3,nptmass) - integer, intent(inout) :: group_info(2,nptmass) + integer, intent(inout) :: group_info(3,nptmass) integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) integer, intent(inout) :: n_ingroup,n_group,n_sing real :: dt,t_end_step,dtextforce_min @@ -614,6 +614,8 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex endif enddo substeps + print*,fxyz_ptmass(2,1:nptmass) + if (nsubsteps > 1) then if (iverbose>=1 .and. id==master) then write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & diff --git a/src/main/utils_kepler.f90 b/src/main/utils_kepler.f90 index 661f3edf1..e7eb8d5a4 100644 --- a/src/main/utils_kepler.f90 +++ b/src/main/utils_kepler.f90 @@ -20,10 +20,10 @@ end subroutine extract_a subroutine extract_a_dot(r2,r,mu,v2,v,acc,adot) real, intent(in) :: r2,r,mu,v2,v,acc - real, intent(inout) :: adot + real, intent(out) :: adot real :: mu2 mu2 = mu**2 - adot = 2.*(mu2*v+r2*v*acc)/(2.*mu-r*v2)**2 + adot = 2.*(mu2*v+r2*v*acc)/((2.*mu-r*v2)**2) end subroutine extract_a_dot subroutine extract_e(x,y,z,vx,vy,vz,mu,r,eij) From 0ab8f31b7813696e607c99823bb62457d0348005 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 15 Apr 2024 12:10:32 +1000 Subject: [PATCH 418/814] fix main routine subsystem --- src/main/step_extern.F90 | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index ae6124eba..178a0ec98 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -544,6 +544,8 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex use io, only:iverbose,id,master,iprint,warning,fatal use io_summary, only:summary_variable,iosumextr,iosumextt use sdar_group, only:group_identify,evolve_groups + use options, only:iexternalforce + use externalforces, only:is_velocity_dependent real, intent(in) :: dtsph,time integer, intent(in) :: npart,nptmass real, intent(inout) :: dtextforce @@ -553,10 +555,10 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex integer, intent(inout) :: group_info(3,nptmass) integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) integer, intent(inout) :: n_ingroup,n_group,n_sing - real :: dt,t_end_step,dtextforce_min - real :: pmassi,timei - logical :: done,last_step - integer :: nsubsteps + logical :: extf_vdep_flag,done,last_step + integer :: force_count,nsubsteps + real :: timei,time_par,dt,t_end_step + real :: dtextforce_min ! ! determine whether or not to use substepping @@ -570,6 +572,8 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex endif timei = time + time_par = time + extf_vdep_flag = is_velocity_dependent(iexternalforce) pmassi = massoftype(igas) t_end_step = timei + dtsph nsubsteps = 0 @@ -579,6 +583,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex substeps: do while (timei <= t_end_step .and. .not.done) timei = timei + dt if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + force_count = 0 nsubsteps = nsubsteps + 1 ! ! Group all the ptmass in the system in multiple small group for regularization @@ -589,15 +594,15 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - call get_force(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) ! Direct calculation of the force and force gradient + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) fsink_old = fxyz_ptmass - call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) + call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) call kick(dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) - call get_force(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) call kick(dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt @@ -871,12 +876,13 @@ end subroutine kick !---------------------------------------------------------------- -subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) +subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) use dim, only:maxptmass use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink,use_regnbody use mpiutils, only:reduce_in_place_mpi use io, only:id,master integer, intent(in) :: nptmass,npart + integer, intent(inout) :: force_count real, intent(inout) :: xyzh(:,:),fext(3,npart) real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) real, intent(in) :: fsink_old(4,nptmass) @@ -886,6 +892,7 @@ subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptm real :: fextx,fexty,fextz integer :: i + force_count = force_count + 1 if (nptmass>0) then if(id==master) then From 2182243c5217b806499387c8f76976739fa5808f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 15 Apr 2024 12:12:06 +1000 Subject: [PATCH 419/814] fix name prdrag --- src/main/extern_prdrag.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/extern_prdrag.f90 b/src/main/extern_prdrag.f90 index aa40fd6be..dc15a0daa 100644 --- a/src/main/extern_prdrag.f90 +++ b/src/main/extern_prdrag.f90 @@ -117,7 +117,7 @@ end subroutine get_prdrag_vdependent_force ! i.e. v^n+1 = vhalf + 0.5*dt*f_sph + 0.5*dt*f_pr(x,v^n+1) !+ !----------------------------------------------------------------------- -subroutine update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,Mstar) +subroutine update_prdrag(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,Mstar) use units, only:get_c_code,get_G_code use io, only:warn,fatal use vectorutils, only:matrixinvert3D @@ -129,7 +129,7 @@ subroutine update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi real :: dton2,r2,dr,rx,ry,rz real :: gcode,ccode,betai,bterm,b,vr real :: rhat(3),vel(3),A(3),Rmat(3,3),Rinv(3,3) - character(len=30), parameter :: label = 'update_prdrag_leapfrog' + character(len=30), parameter :: label = 'update_prdrag' ccode = get_c_code() gcode = get_G_code() @@ -176,7 +176,7 @@ subroutine update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi fyi = fyi + fexti(2) fzi = fzi + fexti(3) -end subroutine update_prdrag_leapfrog +end subroutine update_prdrag !----------------------------------------------------------------------- !+ From 7b783f497c0fda2b75c62657ef93205405a2410e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 15 Apr 2024 12:49:25 +1000 Subject: [PATCH 420/814] fix option ck and dk --- src/main/ptmass.F90 | 5 +++-- src/main/step_extern.F90 | 5 +---- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 3ee18b4b5..15723105f 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -46,7 +46,6 @@ module ptmass public :: init_ptmass, finish_ptmass public :: pt_write_sinkev, pt_close_sinkev public :: get_accel_sink_gas, get_accel_sink_sink - public :: get_gradf_sink_gas, get_gradf_sink_sink public :: merge_sinks public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured @@ -77,6 +76,9 @@ module ptmass real, public, parameter :: dk4(3) = (/1./6.,2./3.,1./6./) real, public, parameter :: ck4(2) = (/0.5,0.5/) + real, public :: dk(3) + real, public :: ck(2) + ! Note for above: if f_crit_override > 0, then will unconditionally make a sink when rho > f_crit_override*rho_crit_cgs ! This is a dangerous parameter since failure to form a sink might be indicative of another problem. @@ -1894,7 +1896,6 @@ end subroutine write_options_ptmass !----------------------------------------------------------------------- subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) use io, only:warning,fatal - use step_extern,only:ck,dk character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 10e9aa26c..7f8790c10 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -39,9 +39,6 @@ module step_extern public :: step_extern_sph_gr public :: step_extern_pattern - real, public :: dk(3) - real, public :: ck(2) - private contains @@ -435,7 +432,7 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v use part, only:fxyz_ptmass_sinksink use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent - use ptmass, only:use_fourthorder + use ptmass, only:use_fourthorder,ck,dk integer, intent(in) :: npart,ntypes,nptmass real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce From 6036c9f778b5453bc001fa4b69d8f2e6dc6c30eb Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 15 Apr 2024 13:33:26 +1000 Subject: [PATCH 421/814] (docs) add info on MCFOST runtime options [skip ci] --- docs/external-utilities/mcfost.rst | 80 ++++++++++++++++++++++++++++-- 1 file changed, 75 insertions(+), 5 deletions(-) diff --git a/docs/external-utilities/mcfost.rst b/docs/external-utilities/mcfost.rst index 4b6cbf11e..b153f85e1 100644 --- a/docs/external-utilities/mcfost.rst +++ b/docs/external-utilities/mcfost.rst @@ -121,10 +121,12 @@ You first need to compile libmcfost: cd mcfost/src make all -then simply set MCFOST=yes when compiling PHANTOM. +then simply set MCFOST=yes when compiling PHANTOM. + + +Compiling and running Phantom+MCFOST on Ozstar +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Using Phantom+MCFOST on Ozstar -------------------------------- There is a copy of mcfost and libmcfost.a compiled in /fred/oz015/cpinte/mcfost To compile phantom with mcfost on ozstar using this pre-compiled version, you will need:: @@ -142,8 +144,8 @@ To run the code with MCFOST you will need:: You will also need a disc.para file -Using Phantom+MCFOST on Mac OS with mcfost installed using homebrew --------------------------------------------------------------------------- +Compiling and running Phantom+MCFOST on Mac OS with mcfost installed using homebrew +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A simple way to install mcfost from source on Mac OS is to use the homebrew package:: brew tap danieljprice/all @@ -174,3 +176,71 @@ To run the code with MCFOST you will need to create a directory where MCFOST uti You will also need a disc.para file + +Runtime options for phantom+MCFOST +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +First, when using MCFOST, you should NOT let the temperature evolve between MCFOST calls, hence +the following options should be switched off when MCFOST is activated:: + + ipdv_heating = 0 ! heating from PdV work (0=off, 1=on) + ishock_heating = 0 ! shock heating (0=off, 1=on) + +This is because we assume radiative equilibrium at all times, so the temperature is set by the +balance between heating and cooling, and this is computed by MCFOST, not phantom. The temperature +is updated every dtmax. + +After compiling phantom+MCFOST as above, you should also find several new options appearing in the .in file:: + + use_mcfost = T ! use the mcfost library + +use this option to switch the call to MCFOST on or off. Beware that the code is compiled with energy +STORED, so running with use_mcfost = F will revert to an ADIABATIC equation of state, but where u=const +on particles if ipdv_heating and ishoc_heating are off (this is not the same as the locally isothermal +equation of state used in normal simulations of discs). + +:: + + use_mcfost_stars = F ! Fix the stellar parameters to mcfost values or update using sink mass + +either use the stellar spectra in the MCFOST .para file, or look up spectra based on Siess+2000 isochrones +based on the mass of each sink particle. You should manually set the stellar parameters in the .para file +if you are trying to model a known source (e.g. HD 142527). + +:: + + mcfost_computes_Lacc = F ! Should mcfost compute the accretion luminosity + +Accretion luminosity adds an additional radiation source based assuming mass accreted by each sink particle +is converted into radiation on the stellar surface. This is emitted as a blackbody with temperature set by dividing +the accretion luminosity by 4*pi*R^2, where R is the stellar radius (set in the .para file). + +:: + + mcfost_uses_PdV = T ! Should mcfost use the PdV work and shock heating? + +The only source of photons in MCFOST by default is from stars (ie. sink particles). If you want to include heating +from shocks and PdV work, you should set this to T. This will add the pdV work and shock heating as source terms +in the Monte Carlo radiative transfer. Recall that when using MCFOST we are assuming radiative equilibrium at +all times, so the temperature is set by the balance between heating and cooling. See Figure A1 in +`Borchert et al. 2022b `__ for an example of the effect +of PdV work and shock heating on the temperature structure of a disc. Typically it is small. + +:: + + mcfost_keep_part = 0.999 ! Fraction of particles to keep for MCFOST + +MCFOST throws away very distant particles by default when constructing the Voronoi mesh. Set this to 1.0 to keep all particles. + +:: + + ISM = 0 ! ISM heating : 0 -> no ISM radiation field, 1 -> ProDiMo, 2 -> Bate & Keto + +include additional source of UV from the background interstellar medium, so there is some low temperature even if +no sink particles are present in the simulation + +:: + + mcfost_dust_subl = F ! Should mcfost do dust sublimation (experimental!) + +attempts to remove dust in regions where the temperature exceeds the sublimation temperature (1500K). This is experimental. From b08de27c9aa07b254e88ed38a67dcdf42b7d5268 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 15 Apr 2024 15:18:16 +1000 Subject: [PATCH 422/814] fix compilation errors and warnings --- src/main/extern_prdrag.f90 | 2 +- src/main/options.f90 | 7 ++++--- src/main/step_extern.F90 | 5 +++-- src/tests/test_ptmass.f90 | 11 ++++++----- 4 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/main/extern_prdrag.f90 b/src/main/extern_prdrag.f90 index dc15a0daa..da3f311ff 100644 --- a/src/main/extern_prdrag.f90 +++ b/src/main/extern_prdrag.f90 @@ -126,7 +126,7 @@ subroutine update_prdrag(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,Ms real, intent(inout) :: fxi,fyi,fzi real, intent(inout) :: fexti(3) integer :: ierr - real :: dton2,r2,dr,rx,ry,rz + real :: r2,dr,rx,ry,rz real :: gcode,ccode,betai,bterm,b,vr real :: rhat(3),vel(3),A(3),Rmat(3,3),Rinv(3,3) character(len=30), parameter :: label = 'update_prdrag' diff --git a/src/main/options.f90 b/src/main/options.f90 index 36bc7e5eb..115e1e91e 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -29,7 +29,8 @@ module options real, public :: avdecayconst integer, public :: nfulldump,nmaxdumps,iexternalforce real, public :: tolh,damp,rkill - real(kind=4), public :: twallmax + integer, parameter :: sp = 4 ! single precision + real(kind=sp), public :: twallmax ! artificial viscosity, thermal conductivity, resistivity @@ -51,7 +52,7 @@ module options logical, public :: use_mcfost, use_Voronoi_limits_file, use_mcfost_stellar_parameters, mcfost_computes_Lacc logical, public :: mcfost_uses_PdV, mcfost_dust_subl integer, public :: ISM - real(kind=4), public :: mcfost_keep_part + real(kind=sp), public :: mcfost_keep_part character(len=80), public :: Voronoi_limits_file ! radiation @@ -150,7 +151,7 @@ subroutine set_default_options mcfost_computes_Lacc = .false. mcfost_dust_subl = .false. mcfost_uses_PdV = .true. - mcfost_keep_part = real(0.999,kind=4) + mcfost_keep_part = 0.999_sp ISM = 0 ! radiation diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 7f8790c10..23c63829f 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -907,7 +907,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! if (iexternalforce > 0) then call external_force_update_gas(xi,yi,zi,xyzh(4,i),vxyzu(1,i), & - vxyzu(1,i),vxyzu(1,i),timei,i, & + vxyzu(2,i),vxyzu(3,i),timei,i, & dtextforcenew,dtf,dkdt,fextx,fexty,fextz, & extf_vdep_flag,iexternalforce) endif @@ -978,6 +978,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl #ifdef KROME use part, only: T_gas_cool use krome_interface, only: update_krome + real :: ui #endif real, intent(inout) :: vxyzu(:,:),xyzh(:,:) real, intent(inout) :: eos_vars(:,:),abundance(:,:) @@ -988,7 +989,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl integer, intent(in) :: idK2,idmu,idkappa,idgamma,imu,igamma integer, intent(in) :: i,nabn,dphotflag,nabundances - real :: dudtcool,rhoi,ui,dphot + real :: dudtcool,rhoi,dphot real :: abundi(nabn) dudtcool = 0. diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 2096c3d5d..a5eded415 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -471,8 +471,8 @@ subroutine test_accretion(ntests,npass) use io, only:id,master use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,massoftype, & npart,npartoftype,xyzh,vxyzu,fxyzu,igas,ihacc,& - isdead_or_accreted,set_particle_type - use ptmass, only:ndptmass,ptmass_accrete,update_ptmass + isdead_or_accreted,set_particle_type,ndptmass + use ptmass, only:ptmass_accrete,update_ptmass use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi use testutils, only:checkval,update_test_scores @@ -592,8 +592,9 @@ subroutine test_createsink(ntests,npass) 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, & - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass - use ptmass, only:ndptmass,ptmass_accrete,update_ptmass,icreate_sinks,& + nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,ndptmass, & + dptmass + use ptmass, only:ptmass_accrete,update_ptmass,icreate_sinks,& ptmass_create,finish_ptmass,ipart_rhomax,h_acc,rho_crit,rho_crit_cgs use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceloc_mpi,reduceall_mpi @@ -712,7 +713,7 @@ subroutine test_createsink(ntests,npass) call reduceloc_mpi('max',ipart_rhomax_global,id_rhomax) endif call ptmass_create(nptmass,npart,itestp,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& - massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,0.) + massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,0.) ! ! check that creation succeeded ! From 169958e3a690179f11a8d704402c2f7ad6c0fd68 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 15 Apr 2024 16:18:53 +1000 Subject: [PATCH 423/814] fix bug gw strain and non moving ptmass --- src/main/ptmass.F90 | 10 ---------- src/main/step_extern.F90 | 22 ++++++++++++++++++---- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 15723105f..5e781f507 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1962,16 +1962,6 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) ngot = ngot + 1 case('use_fourthorder') read(valstring,*,iostat=ierr) use_fourthorder - if (use_fourthorder) then - n_force_order = 3 - ck = ck4 - dk = dk4 - else - ck = ck2 - dk = dk2 - endif - - case default imatch = .false. end select diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 23c63829f..b3e019eea 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -432,7 +432,7 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v use part, only:fxyz_ptmass_sinksink use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent - use ptmass, only:use_fourthorder,ck,dk + use ptmass, only:use_fourthorder,ck,dk,ck2,ck4,dk2,dk4,n_force_order integer, intent(in) :: npart,ntypes,nptmass real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce @@ -455,6 +455,18 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v dt = dtsph last_step = .true. endif + + if(use_fourthorder) then + n_force_order = 3 + ck = ck4 + dk = dk2 + else + n_force_order = 1 + ck = ck2 + dk = dk2 + endif + + timei = time time_par = time extf_vdep_flag = is_velocity_dependent(iexternalforce) @@ -827,6 +839,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (nptmass>0) then if (id==master) then if (extrap) then + if (iexternalforce==14) call update_externalforce(iexternalforce,timei,dmdt) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n, & dsdt_ptmass,extrapfac,fsink_old) @@ -837,6 +850,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dsdt_ptmass,extrapfac,fsink_old) endif else + if (iexternalforce==14) call update_externalforce(iexternalforce,timei,dmdt) 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 @@ -906,7 +920,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! compute and add external forces ! if (iexternalforce > 0) then - call external_force_update_gas(xi,yi,zi,xyzh(4,i),vxyzu(1,i), & + 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) @@ -1054,7 +1068,7 @@ end subroutine cooling_abundances_update -subroutine external_force_update_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew,dtf,dkdt, & +subroutine get_external_force_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew,dtf,dkdt, & fextx,fexty,fextz,extf_is_velocity_dependent,iexternalforce) use timestep, only:C_force use externalforces, only: externalforce,update_vdependent_extforce @@ -1088,7 +1102,7 @@ subroutine external_force_update_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcen endif -end subroutine external_force_update_gas +end subroutine get_external_force_gas end module step_extern From 50a43a0348d8499995c0725c9e41e7eb0fa1a336 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 15 Apr 2024 16:39:38 +1000 Subject: [PATCH 424/814] fix spin update not supposed to be in drift --- src/main/ptmass.F90 | 8 +--- src/main/step_extern.F90 | 92 ++++++++++++++++++++-------------------- 2 files changed, 49 insertions(+), 51 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 5e781f507..00bff775c 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -545,25 +545,21 @@ end subroutine ptmass_boundary_crossing ! (called from inside a parallel section) !+ !---------------------------------------------------------------- -subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass) +subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) integer, intent(in) :: nptmass real, intent(in) :: ckdt real, intent(inout) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: vxyz_ptmass(3,nptmass) - real, intent(in) :: dsdt_ptmass(3,nptmass) integer :: i !$omp parallel do schedule(static) default(none) & - !$omp shared(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass) & + !$omp shared(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) & !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ckdt*vxyz_ptmass(1,i) xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ckdt*vxyz_ptmass(2,i) xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ckdt*vxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + ckdt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + ckdt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + ckdt*dsdt_ptmass(3,i) endif enddo !$omp end parallel do diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index b3e019eea..95670505c 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -489,7 +489,7 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v ! call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + 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,ck(1),dk(2),force_count,extf_vdep_flag) @@ -505,7 +505,7 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) + 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,ck(1),dk(2),force_count,extf_vdep_flag) @@ -546,7 +546,7 @@ end subroutine step_extern_pattern !+ !---------------------------------------------------------------- -subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) +subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) use part, only:isdead_or_accreted,ispinx,ispiny,ispinz use ptmass, only:ptmass_drift use io , only:id,master @@ -555,7 +555,7 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx integer, intent(in) :: npart,nptmass,ntypes real, intent(inout) :: time_par real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real :: ckdt integer :: i @@ -576,9 +576,9 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx !$omp end parallel do ! Drift sink particles - if(nptmass>0) then - if(id==master) then - call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass) + if (nptmass>0) then + if (id==master) then + call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) endif call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) endif @@ -887,57 +887,59 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) !$omp do do i=1,npart - if (ntypes > 1 .and. maxphase==maxp) then - itype = iamtype(iphase(i)) - pmassi = massoftype(itype) - endif - fextx = 0. - fexty = 0. - fextz = 0. - if(extrap) then - xi = xyzh(1,i) + extrapfac*fext(1,i) - yi = xyzh(2,i) + extrapfac*fext(2,i) - zi = xyzh(3,i) + extrapfac*fext(3,i) - else - xi = xyzh(1,i) - yi = xyzh(2,i) - zi = xyzh(3,i) - endif - if (nptmass>0) then - if(extrap) then - call get_accel_sink_gas(nptmass,xi,yi,zi,xyzh(4,i),xyzmh_ptmass,& + if (.not.isdead_or_accreted(xyzh(4,i))) then + if (ntypes > 1 .and. maxphase==maxp) then + itype = iamtype(iphase(i)) + pmassi = massoftype(itype) + endif + fextx = 0. + fexty = 0. + fextz = 0. + if (extrap) then + xi = xyzh(1,i) + extrapfac*fext(1,i) + yi = xyzh(2,i) + extrapfac*fext(2,i) + zi = xyzh(3,i) + extrapfac*fext(3,i) + else + xi = xyzh(1,i) + yi = xyzh(2,i) + zi = xyzh(3,i) + endif + if (nptmass>0) then + 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,& + 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) + fonrmax = max(fonrmax,fonrmaxi) + dtphi2 = min(dtphi2,dtphi2i) + endif endif - endif - ! - ! compute and add external forces - ! - if (iexternalforce > 0) then - call get_external_force_gas(xi,yi,zi,xyzh(4,i),vxyzu(1,i), & + ! + ! compute and add external forces + ! + 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) - endif + endif - if (idamp > 0) then - call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), (/xi,yi,zi/), damp_fac) - endif + if (idamp > 0) then + call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), (/xi,yi,zi/), damp_fac) + endif - fext(1,i) = fextx - fext(2,i) = fexty - fext(3,i) = fextz + fext(1,i) = fextx + fext(2,i) = fexty + fext(3,i) = fextz - if (maxvxyzu >= 4 .and. itype==igas .and. last) then - call cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & + 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,ckdt,dphot0,idK2,idmu,idkappa, & idgamma,imu,igamma,nabn,dphotflag,nabundances) + endif endif enddo !$omp enddo From feee68cbfb2169e67027c595c5f2d6597a5b041e Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 15 Apr 2024 17:28:56 +1000 Subject: [PATCH 425/814] (docs) update vscode findent info [skip ci] --- docs/developer-guide/vscode.rst | 10 ++++++---- docs/images/vscode-findent-flags.png | Bin 44635 -> 96394 bytes docs/images/vscode-findent.png | Bin 43037 -> 0 bytes docs/images/vscode-format-on-save.png | Bin 0 -> 41262 bytes 4 files changed, 6 insertions(+), 4 deletions(-) delete mode 100644 docs/images/vscode-findent.png create mode 100644 docs/images/vscode-format-on-save.png diff --git a/docs/developer-guide/vscode.rst b/docs/developer-guide/vscode.rst index 2e32d871a..1922b1068 100644 --- a/docs/developer-guide/vscode.rst +++ b/docs/developer-guide/vscode.rst @@ -2,14 +2,16 @@ Coding Phantom in VSCode or Cursor AI ===================================== In VSCode or Cursor there are several helpful settings when editing Phantom source files. After installing a modern Fortran extension, to enforce the indentation conventions in Phantom you should use `findent `_ as in the indentation engine: +and pass it the same options as used in `the bots script `_: -.. image:: ../images/vscode-findent.png +.. image:: ../images/vscode-findent-flags.png :width: 800 - :alt: findent option in VSCode + :alt: findent flags in VSCode -and pass it the same options as used in `the bots script `_: +and yes, you do have to type each flag in a separate box. Then it is useful to select the "format on save" option in Settings->Text Editor->Formatting: -.. image:: ../images/vscode-findent-flags.png +.. image:: ../images/vscode-format-on-save.png :width: 800 :alt: findent flags in VSCode +Thanks to Yann Bernard for getting this working! \ No newline at end of file diff --git a/docs/images/vscode-findent-flags.png b/docs/images/vscode-findent-flags.png index 39595e0c32f67c6ac9de3859b932566b47b35ede..19dc44f180418c3c41c6364b31c853d04f63ba4c 100644 GIT binary patch literal 96394 zcmX_o2RxPi`~OWU*(+oxA;cjen~=RTvdP|iQwrH3WUr9y>`q8RR+5lSCo3!2`+w>A z{{GMFyq>4mc}~ZD-=ELty58#&p{{z55RV2AK@dU(c^ORv!GS+wbKzpce=x1e`3S;< zD9A`@`(&(4dYe+*OG6#~7P_O5_~PCjYZffBJC{(Y=c6wP)NKd{)bX@X?Rf2e@n3KD zuU{7P_s%@0`qIXYQbU^Q`BSp)J2Cus!n4*+PHb+KB;j;WpR*rXXXL*vHgsPM`}b1N z8@vI#S|lXLUz!9bgozk^nFL3Q1m~Dtoud8iig(4u)3y7OU*jlM22sc(CfpFF#nuL% z{9xo9f_uPC9p?K(<=?xw2VP&pClUDn|6UAq)QIH2FOvEihf9F`_b$`oJ)8^3e{Yj) zUBia&`0w)vq^+OKH`<)qj<1qMC@CuP)2x1emSy(x=qTjMEh|DoLf@vW@W~qI4-1>R zrF!&aWPJSmJ}o-l|NCh<3SteGk|usjL(iT)8yovQiEhc*bF#BL_&djW9=mk|bFad< z?0xtFIeFr6slKy7x`>E~kLXF{lcxi zeaY#9w8Fw;<6{rjbIqo0+9QXQl0~ifuJl>CySoqWy5jxs`hSWxAWS!J8Wm`k45d{x zkKNPw-r$Xohqt+je-zZB>b*IIjnH-O2Z+aY-qrZNysgJYS@6vXMcwQuh9mXq(G}GYnUuQG`@4TI`E3wp20@A z8)cc}zht+}>}^CD8H z)krIBsjBrtulA;DU1(zuVIqt0IM_;f{d%!Iig9`U?4Kt0b0`9f(QyHvyv>FFG-a!j zp>HFC%~m*4)M5LvzEabA{gWn?|K0pz#pIKzOVm=&N2?c7Qc^_dc1&k$YzJ@CtbTej z`0d-RTh*3)S5$84l*~;u@>P#g1PHRqrKAYT7HbdiJEEc=a3xn+4=nxUr-|vaT3xic zh&*R$G;L)LWtL$f8(k$z?D9F-iVz_vy%A|=Z(m&A{H3Y1v~+KdC-^cf=ZhEo{QM~U zVZ%nlsmaNL!FGToT1Fj&{dc0<%%~z{+S_kYM1I{| z=#i7#G7Qx$c9?p9K0rKpcP;bk)$YALpC_#-e*T%weFUM2sjIA%FVG~%S#tT2o<{R~ zd08(xCMv4GFVmdw3XhR+f6Rz=Um7g~gRxOyjFOrr$9-AZL6;06uN4wmjojSsj~|)K z1fp4diNf>C$_nc0(hf}>9FD#h4;~!&`G^L|$WVklsNtu+CIgh77ktyhWRb>#fCJ7tNI&0rnMg}L+9C;-9C^9zoWai24iWe=y z#IN1xib?M6F7#i>_hMTw$(0NJiJa;tj$rY z$K~jF^MAz(_n_532Mdwi7ZDzVD;ylW)zibXA7G3~Y7EqT{>+{~FyrzgKi_jAUPD8J z=lvfyJw2a$_wM=b!}iqFARioYHe1c`58EEJZR>p*z4YCa`^}t@5TpR(DTN{rD=IDjn^WE2($f zb==6PjHJ!(dVhWtdiYae7jf6kBk%6R2Uf%;Pf;p2Ntf@7wyQ=l2uo{*NdOd(rl z+~jp~6zWvJ{57{CEbKy5l=Z6uOVRybb@TJAQSH6k(j|mY9XL5fCI<&6Cnf?UnjikJ z2*mH?Xg#vCD=#W6w6?S?8Tx&4B2LhDi|_3(xAr8?%gpiYK0jXEkk!!Oy>{(@Slp+m zq=X##Iz7GH%^94Xl$5XjRF7-^{rek1EvG-KuKDk-VI%wk0-~o!N=r+riCG>tHkEmK z@6qVZt))cd(YtrFrzh*DxdS#B4EY)>@+>;~L8Du(HpeX*!gJ>W4X?JL1f9OW-~7Tj z=_H7l4!x=6<$d?%OYHRNNxe?VdBhYI?J#wuEiIj=S^Une;O(o2h0>&HnVJ6kZg;|F z_4P-^vnvYb<{R8?Yt2$qM;YRFKRiB$WjE8Wdv`F_a(WmnBik+`E1Rx-dvek!G;~l} zS{gyFU#}*?aYY-MSFvz&H&<6*6BfQ8_5Am5d!g9=j630ZNAL}k_0EEAsF)Z+o|dEf zhzNzjLKO+G6^PI9o2iueTTb zk(kR&37q6l^iP(jtAd{^sEzKw`r9%*@83YNH{<46dkf?(5@Zr(EO zJ^Qh7XGegJ4MD`S>+|z7X^+n#{4_U1m>x@-?yNMn8oSJ0y_zfNEU>e?J3p_gATR%> zwDcukfh0!~{OH*9d;&yXSvf(mfMSj+s-07(^a7H@{?kJkL9SfUhh;KE>)hAoH!6y1 zM{)7;4lHce)lBq$`Ev6{>gecbd`8AkFZ9KW7coD7`icfINpey|&h_YG0gBi=7DpuQ z?EFy3;_`B6e(=ACmcy8Iksd)2Xqg0G6BDzT?;T}RV^C63BF4vec4{6S86g)9W5P{U zj%0eKQ!-g;hAA`0k<|#xZ8vw-ei6$gpVCt>LVQu;Hb4I-LKn8~-d^J>b5B1%;aGBl zwy*p#X4E}Xwn+>GZM*~pwofe|4=z#D(Y-Ei4BGpHg&I|qjhY0{r=cj6c&l3%=_p{1?REWRr(4GRj(>gK+=ACRTT zl_lsb&4 zyJmb93*i?OJU=okMe@iDN9E#$3kU7y3QQzS3Yx5mqYgT2u%luzi5?d_BcK3VT3KC* z3H$pu%D5st4|{X|CN4fc`tCJ)qQimw@WaDHEJPr^w!VJBYv6pieaBqSWg{bc3)Psz z0CA@m)02~y{4_s*{sf#=^FW1(L@4-V;*(#7YSHxif7Q$KWyQs{3B`Odu}K6;?D{c2 zo|u-FmXVRC%~4@gV&~}Sg*I|)bbvyIF!?o2ne!TOu}0!i$8!A2bvkiWLJ25msIxTbW4La;BT6T_pY{(E!3!KmMmdts;~NhyV!=cdt{ z!FEDoVgdf|Dy2nbW$jkgmqMBI2lO;tBP{hPWZm62^Yii=sM{O_c6WCR3Jd$7e)Llr zzV{I)!Tmlm(wE(03jNus9$i$FUbqw%=2tOtEna@rYaIGyqaWX`YR`9iMT5R6ng2t` zK|Tynpb#P7zk4C)3wU{j)2#gb(VdQu&LcLqjkbJ!c*Mlh?>xsxtBV{34nxl4L+KxL zs9PQ>**cglFOLlg$@}*0`eS5hdRow;W2L5MOQD_&ABR1vy>uw7?$9W8eI#In7jhjU(obYVk`&JLkR#tP3kB?i_k5|8S+Y2}u zD$#Y)Qk(uDdHUi;sQqwhqC5-KEMMRA1qD%e?8UN6|}>G>Qqrs;QJ-RH;VG6m40DW)zzCf-MbPB>}n4N)x7xyhNq|3 z?*2zUf^RaYBBp#-oF`s$-$eSPVg%wvG;twWzMH3Fl2CW=f^8@o{C=bBL*j$0r+pjwFu6 zE+NsQ?N?KiXz#G6PhS;TJ4`f$rtct#jh!99-rgoJy8qFvlJJQ3pBLQ=|NOyyVph}K z{N*7ZHUdXao!!CF@s4+Sw1{MZCfcyPurTcL`l(9rK)9ao&ej38QKEXJ;JI|PGf`d)&-p!m|Cnmh#XjmQ=_HK4Ix2{en zyT1oj(`N-pSvdG)<%49)UKww{a24gjX`mtG|Cc zI6399ch9+bdU~2t&wIQp)#;g;nVIWJ*;yIAtUTw9HsVMcv#LHXh!nEpb-LD%8|mv0 zOip?(qrBDB1Vfk@;>NA2i3kaeTY@|nzVtVWy*!VdE6HTztI zOpGS<4#|6|$CYP0w(6x8p#F&InI4zf%dTnqi)}9P@{1cjA=lQ|&&6V-bN_e|p6EQ4 zzA8n+ox(|i8<64$TSeh76b0|niy=AV@$#>PGh@-bSf_bsOdzh|o*42dhY{su5g9Qj zm%jl;YRznf_*?Xq>R)dApZ>Odi^T|?tW-;6-nK6vvfJOo5SJS^9wDl4v^k2@cv2hw zV%2}=+jSs0TYJ`Rm-#b7j_5T9480=tv9|7vp}oxzw=nevTF+SpCnQ{5SrK*px#(?= z*)?yEyl+=)W$t_Lp1-4G%!q#+eakvv9G!B*Yb3bkCM{mucGq=Zt3NH(s{-yi*`U#O zlPfImwLD7)N|~J^^yyRamvw+w9e-3Ra3n=@7TL~!im-^&Mk?Lr(tiD-$RBXoTAZE9 zc%6`-4|Ml9C|G~AI9)KE!3qB=Zb*=WDWDkQ7l+^1YU@Kmby%^xFyhs1%^FR3R> z_1&fKCXq#K4GC4u)om5%RUprz#-;NPTABwj~{gnTU4DvFDZt*fcQIrnI3 zu&6(~oZPXwacSGN5cvv~=kVqylD%+EcRw6?w| zD4XT4#600+w9`%st!AakSY_dG|59{<>+t&qy@gV*RdxRYVU`#Nhp@OfmTVQE3MkvAcF!f5v`dESg}Hk_e|8gcP*I7& z3zcS$hodt)YnG&#l$t8Wmj}qG3q_!iP+YtOthJ-#U|=A=icOY8rU-5;rh3$&tgNp! zhVPeKqhdh^ib9H{N{@~_zxqKLf+Q)%VDu`#T2Cz==5*ONRl%t6dnF>Zc z9PGx%eX@vG<>kYsCal4KA|*3S9&VEYKI>nqS<|!oj|Z zFkQdCy&w@>R$YzJZ8?~$?iWukuAUw?g@nS?`T4@PZwKv1%17+lPy_|+Z|ds&I%A3Hi7rZ!XceiN z)HxJr7Jqb&HhU?_gedt61&Gl@|NosAK%|mYY}dv zcOOvEGR&jz_q+Zn8_Wc4*pD9#E(v)oewb=P=jB@jZKh90wv!=`47r2nQx^!rh8P34 zrto>*v!sOQut(-CzPWEt$!!?0_*FMM_#{G)YqY_2Fi%!VK0$_rg#?#?Xy& z1{m^c+HHGY0txr|?-_U86%s~9M$UK=_02O_ispEoBkTpZuSq9zJWwoc4z|eB3a5h(iK)XPWXvOE(vp&5%wF~{T*EbF zB6;=dRhbcb7Fc#m$89}!iZa7SVOUo|qGq3sqo&EUm}k!>;BjSSh!V8DH|A;kYF;ID z{krGjPImM04kH?k#=$;mh$Y9lvXU>)qQh~YUuDyWCDQ!PoyHqCikahoENuSu5q&Hv zcA~n$f9I^`fgHw^_XcRp58n>ZdH*0p#<*Fwj9+k z#{`@DZZ#Jt1s)68jW!fZ7lu1jhWRq?Q{V!IHl3Ia8Rmhp+U1gx3X#k++)PNDrOt65 zL0YESlDa8*f(RzkR6h(=+71ra)DVQXNs&B+-skLpg^HVN^1Uyo_YFFta2aOOsCG5c zs`Ik(P5!&;FHD%@ee z>DiATdg3N1r@Hba^!VE#~rZv(6L0k1A3B+LU_($9RSXUpYQ9tZ}@p& zXh>hjYixZNm=^nu8+QZ*f&i$mx16f}xdxFA*05U~K8#V`A4q+M{Z3F>AO;vSvb6-6BOhyU}Y#JEg1s?%U78DJjKX8`-6LiWR z0Jd6Qb~b$HVdmn3ASk{(6A-oJS-{B<4Q_Vu@mciZ#K#DMV&Jv2Vv9V#Uos3BBUL#o zBSX``z{pVaZm~8mf%~Qv25JyXmq9}%zo@ABieP9S^{&BVjQ2sf@SQvRKyL8D9uS2e zSND4{;eI?%4Jhz){1a%;3JN#yDY+7Q=71{$jBa+#XWg4SL;WINpO&}lYWS5{Ox6kR zYMjuEh;RCc0+CfxRwl!f6%!K!(Q*6m7*yYb%1W0^Zk=4*f#q;8Kmx^E+RXu^su^-y ztEx_cey`ZlNq_57jRy;6Bcb;+xI9!#uX;7C}>B7;5va|%9 zumYrnf`WpiWNuQt(BtF4!`*e>^gh6>F9phku3qJp2=4yzzEJX!xXX-Eld*HP{<@L? z4G#EDgn-!=uU=D_vWP3gZ6?6Mmdkhb@p+w-gUD*2CwIoDPddQ)I#XFr_OpZK5`NX# zw!>l(2mSgSfA?@_m8ki<&Bul<+WPUpeYgD|?!KZ~{Sv3I-u%Yfefw`SQ^b<<^76Vh zel+JDU-hbe04k;p|Cnj{(ag*TAmZqE!mf1v-QDw9(lT;#ULG}Z%Su{WnB|Joeu)!I z%WLi5x+cfr_0uPJb#*)Gg_|8lyJwUl^P=V2{`^rlo}vh0GU6U-4n#K=8bf1Rt(TbD zJP+N`;@qRQaN?ltp()oPz{YXneiaoJ^;K2k;^G=bQA5k&AT~}846sr}Qt}uplDtwZ zxPZ`!`Ry$ZvYi2eJ`XyP!i^40&qanLX#tIQK-32Y<4#Tb~ z-gFfs{`0*G+9Di@hPfh`ZJ31PDbdNMn(4z#!@%NFjNef3iZ=a8Jzl^UIro7`EsLt&xe_i)Z3 z6(gJQHOn0x7uGC;PAJyGBO@b?(9J+$`O^Rfrxn7v05^gBOza0!Ptr7Tdp2Hzhf5=_Yp}a zCs5xL3YUh5hb12+D_V|}-=F*SOQGP~)>d?tkvK@QBR9^f+SCUG31Q$1GwYc8LX3kw zK{RN{@vIXwD|d=K0#V#)u~_|SbXhJu2JZfLLQDvc28B^WWexZS%B+~peH-VdhvN?@ z0)$Ituytvm)%GV{DD$sT>)9^;* zA654NYz2*X1J}!`GCkvZsXcQ?+Z86XB9_DE`F?}e z(s4sv&_+)6wvHN>F^0`0q~1cX{=yyO#}fdI34ot+w7-pAHOn z4Af7ir>D=BR@oyr6n zTe=U66p6RKk6^=jW$0Iye50TsLYV{rF!?S9moMmRbl#%iT9mTJ3u6gUr=01bq4p#Y zp)QmtDl1FFC3~%qKUrr7CRak(i7KtCnw|8XwsUey6ZSml58A<}pl6gbrxw^KCf()i zKAxDI>=U#5QEjb@Do|k|0|f3rML`S_MjFLgH76bVsxIh0PZuv=W7$&&ls7pE@T4HvGWc7growCLc~1c%w(bEG*DWO;2Z}rS_9nyN(im) zBdQd*$w)cRnq!ESmX_9o2Vv^$hBY=-Bg;E}P2g0_ZtQXOTu2OA!*?RQLeQqnnh*9% zPdXVDmBbDLq84F(Vj}##LBcT7`~hk%Wkp3*6%|1mLd=?4@U<{A8X6jNa}ViUo3^kR z@Ofu9d_Yujm?8}`Ea?I;W`*;XlfqZBnrRFmCR+RCoC+?$CpP;9QWg$XSzH~c}0c)YHjv(g}@p12e&lm z-uKj7MR|GVAkE|9NB#Z#mlS6<*|M~(jA%_!q5UQ*M?b)I$xA5q11UZad^QTmORXNioCX1Fpi{oZ#IyhI0q<)$GmFGeKLzqrir-PO@ePx+98V(nmnwpF&?!iH- zHEY>xw+DE2#$G|h7iFkdX4NhJe)cXEPnQ3Bled$1q(T*!|DTzlMnfG``3faxc3ILbp$6t2g`iu=*3 zT1VFeZ9)jHR0x9XCb;2AeGT+Lv#bseCufRCEU&F$KWcZSYeR*Z{r+vYyRx5PkiFp5 zb@ke{Yk-a#Z*yu;%*h2M&aY)l1lN_9Cl{W>k&-X?wzl?VYKj3t{CmnMPulw@vdQ~F zCu=_XTWxZBPz%rtLlkuyy|njBjPc6A`czYO^T~y_uhe0)LRiS+%F5o+rdq>jc71v{ zsyyJ^&a~n~Yb@kmES;T0sWo*P3&4c2(NTsBqwei5%i9^ko*!-aE4iZb*z5DlMwZ3E zWmsIa0ply)fDIe77NE9rO&1u5*XmfK|8B}ce|FjHhMM5hEbr;#!7{@DN@QmH08p4- z^0vPhq*x_9Iji=kjAIh9|u`!yw_hFbgp<;lVb5KW8rgK<1jz~#pvPUxG zetc{CP5))9#VvYWkN<8tGZ$f3%_2M;L z>4b+eGOs3`Zl(7bUaEic<0a*ZZ$p3P))&WS9{PJEGF+7R?sYQZ@(Bq&tk&Q$!vpyTC4j{C}an^yZ=rfueCI4fo2#T8>=cDf1neJTTec^%6&}= zl=pa=m<}6$B7&{BGCbKTgP5bJ9-x>AlitnxYgkl&k1a3ZULa$S3=IqWJQoR$K*dPU z?P$x?s>x1NbSLIKHdf2DL?Ocq76lwBF$V9-=lxVN_d4ZSer9DcM77hspZ6ZMJOfd* zt;meitkB8vO)=8TmopO+!NgU~7Pl2hS5!**v09gwW>+ynOP-&8+uqA^ZVqkon=~Zn z-b5IoTB%{<1z8P<$x zHm}|Kvy3Qi2RS~6*Zw^5wTt! zBlJQar$E+VeM$f~q?zqP+aj&=dt+_>o40SPaHkv|fB*Amrq=%cxpT+FXj{0ZFf zqIw&Dy>w=5G!qm1T~Wu8QdG1uX>c)HS>0S3RMO_y{`3TbXK$^lm}s+awloajlKspSy~2r6zL%uYj~kCpEI``8~KZDv%NvvsszZKw)X zR+>a`?pZeD*-na*#m-C&?5#L1QKoP6dJ|ap`o(YUow84Mao3H#Z@la zq+OWlC&q%r<*k0vqMHT7D2sTMF zsq5?W3P_t$gFcMihKkH{fl?U&UANA$|JS_gtU%*K{b6(7L>AwJEd@lvI(vvJ(3zQZ>tbJ&`;C7ow|84L3?*04sAy@{G1-1Yd;xzI4Jo2fNO?0!@ z{edHO{YwZjuydsCfYu6zF{rO>SFc_|m?)K!ZyEp|J0l;k=^;+JDR~Zw{99jF_iKR) z?jtG1WXrD!c?5Xj+O>Rw3s2h2;vypEVxuDln)ZHj+SS(8*3Q8~^QC(1toVk8f`@gA zUT>b;^d-f)s*t5z_`0;z#-S9_QaoH42T(`A1-g58a}W$9sEE zA-M%$$-(YTi_7eL9a;g%k!55|td3^~pB{U6^i`-REC1TuS1qzIH8nL?#e()iU}PJ4cCoSaCB;|`h>yP)Ns8dMS_rkEHSb??Yj^M!WsZ} zuuWk11}%Nt-<|UJ?|u<-nNug9{a|N2*rU-9A{Q9$u^+wcwGTFbMpZlw4J9Vn$`o>q zX8L@`eZKwEqJZPr16|$2PKjm>*aYAbsupeTww#ttpAy~*13Cx0Er&7pVkWi+MovXe z4vtx}V!_h-db_KrnAly`M8VrhN-RHT%s|E6SRzAY5Bm$PNY%5weRdrzawJ@7_fowYIiGM(Mdc%LEpP%fdzuP?2e! zkFu1Cc&Q1->%>Y1+rz@|d3bxrI6|87gX@G{Ef~7WE3&9f3E{|9kr&PW&LJs)_;m3YNkr@^oKOh>XxvFV^dE5wu;v_R!L5tKZZ4 z?=0pp#y}WnFQEC|yRnZSi^2RnJoK*}tAylMvSssu-Fos(H8;Qm%t_ty3E>zSv)S+P zF$B`Xq&V?CbD+DIP z9)&1r&s)U;#RAPZe8eWrY_y_ibt+fHyb5&n*k}T1e(gyOhF<_VfQbeE=|orx@(A3& z*w_l)4Z(C3%Bbu7+BXur8jVov#>&yLEM2p+tuuSgWo2{3!9I7HNCGVW{O<%w&9q(w zWr3gnJH!-0I1uvNasfgmm*3=D?dtNUUvTVF$aBT(2vYl?+HZTz^iE_Rze<#hi3EF& zEo%dc2)Khnf~9_XADQSBW@BP39?&Z@Gcy(f3+&;s^-`F34TBl8t$K-#rN|r)f?8dj zz;w9?P0R%;5&#GSDz7UlQtU;go*PE=FSrZ0Fyv@a2##a9xYIUY&Q-@nD#uq_2M74e zMu-E){r+z;%Kl46*}VZ?Q36Spj5`oNX#|U|x!GyOE%~wJBlPX5@88w$dtTRzH4|$4 z3i>1YvWF0zQ$4<{MkY6rtcKI6Z-M3=FW0MyT{y_=H}Cia#4fbCv`kNb;|qE=Jum>m z?+eAG2W4{%6gbnG#oA{)8@1A#I%t^b))?SW*sNH9jp%VDA2z$A1U00%DC2Ij;9|=T zI8R(7_+J4>km&=~EpI_#VK7gVbl0&kj#zszJm5Xm0@A ztK_824%du+DrMm}R@7FerXSXKiwZ2cOqvyowL3c5;13+);#Yl?y}hY=-a>qDZjP!^ zxIgP=8!DQ~h1-<6$DFsmz8-kF^VHGSROLz_fT1jdWjuiu z&}<4pJLFMTmQ%%udv^I~Hd<06s7wIje5srfF){x8b1lb3!3QG-TJ(B|9)+wz!uyt@ zGsXk2AZmt>o0it`2RndH2yI(3SvZc4{lz* zJjb2lZk`E{{yGcGuer-`M|QuzFR>`R8KS8lr_Z>BLVcAG7AB*mtq(lJ2hOqW*94j| z7e|^f>gxy?AbeLk@B94vJPRi;Rk_)BGZEV2n>X*^0>r%6j^4iqjRhQsgX18GpiNDI zL)BzEm=fk&^&5ZZl#Glrck8kKbsed%Cg^Z-7&IvS{re42MnBOkFc;M(gzJlo zH=qIgE*0oPiVE^v`pNBQbu2?X@aJ%rAx6TSpGN#(@m%tG2(~_dPLf7s*lY-q&&bF^ zx1s6xqYci}YuQH+@0yuufRK#n5wyj~VH(}78%vK};iA3QPu!NiSqf*a6&GcVzMZ>4 zA?uRif}R9?CgJ-R2l-%Cz4l{c;8wqbnxdlb->xG4UG^BgVaMu0X&Ba|z8S9gzz$mu1zW3lk$G3tW$R8f| z-ZF6V_WHNVk!{b0$|0=F?hXn{Lp! z1u5z>ft9~=e20sYvMYAB!Fx3 zGXcgfE=PP~P23o(8w-xRW&n`2cYp zrvXOUke|N_BK_sdDGkKJbg{X)R}sC$E`A{)l-Gsx|HY1QATafhlDe?5M}o8*W+uwe zPrnAv>wI5&i+MXuBwmK7Z)w3CYflKMEHSi#x$HYXqsBX(Dx%K(_J(xfC!IYH-Kz9f zJcP@1dR|3{;fBB+(RGS3>;`5ZiYzV3FuO95y!1%JI!ge9oiy$K{Oq72NGyg$A%Vr0 zc)3xGSueT37TmGJfM)c5#h=!h`O0{f2n;dX-Pu`l>W+oY{o|7=&V0$QyR#a^$Xb>p z)805#fRzAe-0zAcs36O9xs9a55h)?_r?|Dt3ecU z8A7oTLWWe9*Ifp_w8G4@lxXk|!pA|M84U5h?%pK9-P+kPrIsUks?2(iZEy7wo$Pef8fnzeDoz1AIC|X)tV!9uK zYd7QNKRJ3`a)oZ*HtXZ@wmOILCF6rw`jqc`l?GT+-j;o7o-mJq!Lv=f19`ck>>v+k z&yMzXwaf<-qoc<6J?9=D_s73@@!n|?1Kp8{WQKJ^!b2!F!?dL7}HV``hrauoG39 z^Ha>;>e{irwCw1OG5MGmW>VA7w?Ec0q?utMOP9Le*Zk4CoOz9Pq^VXwLWT44<{O$Y z!>siURxyPH;u#)U2M0qdE25r|2&@nAEj`zdN-0zfUt!-JXw~rd^~@eTwwdc75qf9p z2V1<8$5ZpMf*cbWX=)-3CGAx3@&GH{}$hJrdSN%t*eAvV*9!0A)BBp!;u6r zS%^CdD8-oBlne#*ds1FjF?i>p51|gI!54RwB?JV-nVCPDR~^j~x70tlNj(3`o0S3& z%=MuqbIAQ(IEO%*|A$473agfp(Ik-HHpkh!uXOAg{2lf|v_c_!RSHT7e z?@}P2KfQnHk~%cIN?RA_AN6722kxD?Pc&nMe2XVNUR^r`)F^IZ%1^WA zVgcEVL>60qFG2qA$FhT@GTge)+RecU@=^;rOk~21VeNg$=O?;mdNmefSKDDq4H`RN zY6gn}tX0(&94U?@#gZXDfmjgA&T7etTSFKe&jg&v*cKsC28ehG(Rro!c^yWT@}??V zjQfhPM}~!Qkm59MdZN!ku2=gFL6}B%zhEJuXpGz~Vd0OLnQ>tZ1|sT}51AR_sL06d z_)1%?PM3a~M+>{xZ;KF%MZT@#!6#7ogR5YbXIJ^a?!mW=c?s;!p%V)3+mF78#_ z2~*U>+FN-R&0KXGRJ7_*D4T+2!M7g{Iz@x7;abWEYQq_MK1MR1hYqF^Q-swi2$L@L z4zJs5nz%VEz6nir6bp;n8H)B-;+_=~5WKB@)oyRHID(Om_nlqZ1$k`RuW@m7C<=X) zm~s9KL+3>a@7i=TJjO-x7-bR2^qGARz^y?`8S_IvA<>Ckn;yP)cuXt?r>6&I6T| z0Z0Q;1-PJFq2qS<1B9fLICa}UeKM#1g4&ufJuNp9f!t6smp;H>xBk~1rgZEQ{p`>I79k?nf-OAqz7)BO>bEe0X8=*m8!wPT1LVQ+hP0l@9 znLM0}p{jZK1F$ShQV1$8~ zQCxEH@mctelM^NgQ#hvrHtD01b4Zy z0r9j3?(i^tc(s`zkcg-q&f~3 ztRJK@z~~`%x|j-J+;3YL@{W1zDz`vELwl{#(XCuWKF|F%Ir^y!a}iZl&97}Be>+lc z1X-NnB@g5gNG*cX0Yxn>yMitIJRwY=J%35PmC{dD$@Rx?5=PEo6i-~hCt-1A-=y zB|*8GMq98e2{d90!Lhj@g(#TfhU~F@-*=2>x#PVS0)vkbo5qoXslx5$ z5hA)D3vPF?kbcokLoctX4NUmvUp%nxBJ&_t3R|$axbaJ1Ad5n|el^?_M_i``bzxIe z-@>7nzTCz@?uF{*k3&w0L+23GOCtm!kVQhi*84>=Ka0ytts0pfuD$N^f~6Aa+dB#- zqG<%k*c5aiGOxgl`$3(8X{I;HDcRE2FTjzE^a?Z8e({I+O-G^>VgzO9m5UpKVOOcP z=#OPW+B&GDzwTcA7ZHq%Q}fvwU4YqXIwEwtd3@JHm|%e9Z~a+5%E+ipogK!Y-5Qy% zU+-J;XfWh%nO@&$IERIYkl?Cwr}QjuV}Iy=__neVm85tcsnp}*PKnBU4MJPJgKs3- z7kp&Jf;2Ek)!74%w@>9Xv~zI@@$pUGKD?tc2w7=%3b}io4xnV2z3fTp=@bCXAg;6T zxJY#{dVKYlQ`^G)JQS7pFbkNf%$=gdt=pS%$Dmldd81?5syd<*6CN5mz)#MYZCX8A zsuKm7Lj^uAuIR$0m(-c9C`FAE2wtnCXRWNSW3nzhlgWd?Ik}p{hL0$C;%<#cNxCPh z`2#PN<%$MxBq_o=y-*y2Ko7C(z8Hhx?&<51ZS@U2m zT^jBWc>3Y7Ij`<(ITF*_2ViDQuLGqUZ9d-rH~qTk*7!ov(soIcj!pdNk5OdaL%vj< z5*XVf#IeaAkk@#jLt7WHuSnMk2?ETvpR*W;*`!lZCx*ehXL!yHh6N#o*=X2$-GdZI zLz_Rde*v=dvCDjsdE@mh&r?#I`DwT)tJT>Rm6U?Ppz&YGl$d-!N=-xaW+*Hsa|vd% z!HiuixvHR zUlf)|%&nzr!ifXSedBtkCp~lDmbZmsVeJZf*`hmJo>6$pi^R0ZABl#B$uzjLI&w7hv}1#;f&4xbKRB{vJl^f$_Xry znjoL6M>SOw*U7yom<|U^lQfQn7mKl8SX7iuHxw5OKUznyC*+Q76&dNeol&q~-UF&D z9~Vd+jq<4~cKrgdfC_2W-q`q!p&Hl3yx8DXOpoj(W@%eUMV~R(#9|7hlU+r+fm~&WRMm0 zs>L<93Ole5oqc_{a!8jNCwSl1@Az=gn_B zAD=yl7m#1Ma+xXx#eJ5dTW{Lcv0eHG;dJl`0-@M#90o$ytLjXKIeqZ|q4^UK5xpub z6g$}~1pf~%bZvBVyU#R)3GAtN9!t_DCKc`GIwz;_J3@T4M^aIL+}AUw&~o2iNBgal z$v&H^YV9DZv+bxFiOp1bOUst-@D{z_+?Uv&&cOENU5aTmA+^IG`n5FnCC}V2{@*Zm zwREdKFxZg#Aqf+T3AMfs(bRYDJ&oR0p90r?`~5xqo|0tq2)X9@OgA^d?+5^%3ZYTI zrjxI^$1vPVL@e0!=cAHvCQvY#yKT4T2ExEBJEEIluMbi$E4_EaaudW1394T#G-PNh%q)yD2 z?r#0s->INKG);XSFiZV>FT_$qUmwyo#cONa=)i~by?1c065NHD>GkVu00m(dBxtWK z7^3DN=}c5%Hcw7YK7PD{PsN=j;OOV>uI0KhJ0lWw} zJluEt_WiT@^d%RelZD`*y9q42{DQBGi>uJ+@rRKw#REGa+D{@4CWv`eLw?&g7(csj zkNHW~J5Qb7S7*_=&>2US-Zy{Se)yiOEc7d2T`IojgJnCI?Ekr1%xP)_Xnbl>8=@!+;ySEO%Ou3xC$XTd8;{Sv9+Bs6au zy%=mg-kmEXu{5kPX89F?^FGSxnl3hit%h3uJ9sT1$WGDf;iFgQ13o%vqMIIDSl`6W zRc~^b`?&Roq@aiV&jGe(#D~B;%SJ^BqIFEyxfMqQ7bz}9=xdqR+I9JlbC5{iaJ{-Q zAY3b*VLI%8{6gmQt$Q|M_e3vm2bLtivcFGOrr3S$PeCvq^K&g^-Kp zU#=>PphzmKru&mMHR$;8p73ogt|3~tnbbE!8|&#>sYX8Xfoi<_K5_UP#*a(7%kabW zG$S+2AssJhnMz*6Z*wUkMpXHm|A2;;f0OmMC$=N$BUk#D)<*5qXs#<5_bTvF5nRd1 z2?Y6LOvhm=$up?@*|#^R9d~0Z8X{)>^g%GJj(!L+3RD8K!q#@lcXP=Kdn3|<_7fyY zP)%b|=w#zI%gV$&ylWxy1~mXC7D0veg&f~q$EF;~2ns4VRr9ohX^HSd*xS!;-MY22$aZ1H z3o3lv4^DE%VjM_I#3>Dn_$|N0c>2Xls z9USgLM>0L_JJ(PFuV|o>OmOx10^~A^UL1Z^r$`IfiWixcgAQd2ZHziscLy1wmE*Yl zRMg$b;6K(XB@2to%F1$BY`vaT2mHQ0J$0h!ar&bc*3Ys zDxf|(Ihm{R1O8bYEy&pZl81Af z-JJ#I_e^xH3_^8|7c?~mH}2+oZ%*~ck0@IEMC%P(psfo`sGmXv7`{*i`ugl&! zb?n%eQKz8Ww;`WUh~K!Tt{y-$HaU4c^Gv3CPD5=i#Z+S2s6xEBrLFC5UiQno*d?1| z#B;j>%e$UU<2}JUgDvpJ;-q$&UT@e9m!)l-bRpFLbM3cJ;Xm_Uo96FxR8i=9fBazTiNWOT)fbII^Rw>DzU2Zr{Ovl|daYbn zf@QksgSZCOdt?sgvPg_BHLI1Xv-Q$bkB7xPMupk zae-iW1$zPmfm4*tEiJX((+>UvBF@6-3K*FScj)8oPa$=NSkO&9?Hr!NdAINU{pL|7 zM(X<}Y!bdMaLK~>L=m{<)`fIzYMGe?>iMytRG;Z}i*LC5Qa^o~J2EoTp~T4K!@-FR z1I_3YF3*%W{YC6cyW17N4Z~|ai4BDz{oQ2$)}1Bt9+XwIL}*#Kxh*006^PT}-2Z!J z3$J+GGNpo!@Gc_f$&)7qek+TqF&(EN0yhMInuvEyy+xtc@w`i6(nt1&FjMVzU5cPd z=CqvdVH~`#1A>okyg6*J{&mgL#?Rpsoppl~4oY6CBBdN58glG_0V%P2*cU}fzD8N) zaDAKY4??slN}8v_&K?*%%F91#9Bv)o!y7ZVw&K`sb{y3az#EEj0yj~yV2}eV%+Kn! zOTml1-#F5++}gHejcsQ5wJ5ohdqawk3MzcJR-d{H0sypk${F9r_w2f@jD?U_d0N_u zZ7x}AnVpl7^#=fT(SC30)%_nCR@uqPqQb(*_;T2Ue~4ly3J3JaSF+5)!H*|do&OZE zn%7>Y(k$f3OljZPc>OzPGWyw84x^Frk3NMB-a8bF-iZCGo}%^jJ7xzBYX0Q|hte!3 zUrn9wc|TZ~A2a8_U-_bB>|@ifehmqGZ(N`_!WHyxHkM)!9f2*-GX9SXtJN{CH@3Bd zi{#G^lM&5_n~nv3jYvH4=!(>;qM(8o4Sy9ssVon@0%d?#IVQ4oCIUsBVvAfpSR2kv z!eY!*k2wiVu~s(r=*Bf0!b~Y$yM)AeFQ4)ZKf@llF_VAPJ0QHFG?Q7sQSCjyYVWs- zar1o*ujop%USErltsR(~>5B~xirx^bdAxOhcdHP06otj(Yqf#fv#me$AEgjI)8j{z zcm8b}4a%0%j`I$=j?dV{CT4GsMn8?r+)n1}zU;4eQg2BkTJJH-R`ha zRP>Tyaz$3R-bM9$6sdl~oPdV>*4Or9gKRL{T2NL|_|u6d%>FpvL}rI=xnAj_W`^p} z(kj>8w_%UdFjs&s?YD6FMT(I$rzdiG@@g6O)%Z6{= zN#X2=;u;3ebpYFf*dZzvIMjZ~pT^@we~z&SZSH2Kudl z%CFzQYwGGcPd?^2)KNSOpYRud|BSA$SWvYK)H{CobxV|Yg$6?>{tgi z_mVUHYW1(7;kT2E_Xg*euW*YLv+v`m{z`e`-K*T`=E&1@-ekMjozh-pCYQ%N8=05g z8g9&8;#N8DW}`rsIP*s~*L-i9bEegyu?fbIh_)NYZVMJ_AE|0pEb_Ic-cE33B$Zfs z_L~Z(nr${kR)xa3%b)zN6_N~q#r;W@>G1<^?4wU!oH6?xdo=Qn>*OEH`sfBQFEU%# zf6{HHwpv!yg^(}I&%e=8WVuSiz|hv|IhrUKCXL0Sw6yg;t`v97Q9eIDBa@-p+M-&v zI;D+y2t`uj=9&a(K{;BEZ(mH(yIvV|62{UUV*$Rb>t$~KmNU>{}^8=TNz@EiV~{pFTcg; zC94q)1-OQnmzSmGfXF3;sGQR4)yyNhf_*2GaM52+;#-p?} z>BnXtdp;crgd4I@R}kLN%G{$Q&#N*P$$h6iaTSl!JG3oR&5C?WQvG1T_bi*D_*LG( z;CTOsH!@YZGgQqAsXRre7#n%&osZhf3fRr`m1Fr|XYyM!-wbQh*hh~KTS&_my7Ro2yTQavh+I07>wDS3HCn{^lKI-rum%7Fs1^Cd^)hAH& z)ctaO_FC*xe#;Efgu(ef@@h|7Nz4s80^>i8MC7*%E6L z_oXMN;U&M#Tyd!T4y)fPf{yc_tBX0kFG}wZ>Sq^TseGtVd3LKEb=O-FdICR}u!x8q z6ZGmZeSfrvG&)N&|7jx~Mh297bX_^Q6`FZMF&vXiE$@*iI2Ud&#hsa%Df<9oLeza) z*;9&zZ?m&oN1a}@j!A_^W1;8IrpoQ?v!M!e{P*wfGE|iVv&&xM^?7IE7cAUMZYUUZ z?AWm#>J*D%U{>m#sfxs-%YM+QBfcEloF6^?{yj9=pF%?FDptD_F@*DFUFxB&vCmL- zDT|NA;vu~`sd+Sp&-cmrcAy(pE2(`7TqZqU?s`}=0Nc1$c69tz?(^rXtyv^Q*0yur z&Fhreze~!-=BX0r2YcMSv-LN-Y<*X2(i8Pg&#u=F?n+W}DtpEjn(A%xA^PdlxW|uC zZ=*W?sC%>0U#enb!HTbJ-n&Gnsk3u^G(Em}$EHy(IlJJwj>gs`=&g7{9qMP zyXV(Y3L@uzUj2>Y3v7^4GIgFfCRU z*=%+^=XoU$549Ijb-6W!vxrDF$(3~U|F(~Lnc=-`l-@92;nb<1Oj*Uhmo{z8OAmmU4Ic=GN)rj`K{(4;w#6%);Rt9bdreC$igvKq$V-eBR+4kRxZ# zthZNeBw}PWV(y4pTJtE+NwL#{g60BJ_e!q=wn4O3R)(5t^S^?EUo-voX&$K-Z&Fjw z18)J785oF<>JNb7u;tcFxM;i#STuWBBz&A&U)+EqjDeZ?G@yl;Opr)HUn`7j+C&_1 zTkLIbkGX&UQGER7`t%&v-Ji!U(U-pOGw_v{pBRXcI7CMW5p)b(%_wqp6yxMKpl5Aq zQDqi(>KkbaXlfez_3M%T#&31NhP=cjpzvm+5j?Ah<=U3Y)@~m7q)DFo#KzTXzK!gh zoTV4)jfpw3SNXKxx{Vq~h(*T6{<1rV!2q<}SFY?6`aJOd_MaKMX8h)iCUaWiwrwf^ zAKo;HweBrmgd&xcm2ixs<}ebUe?Ujb_HJ3n-h4jqwUbhOv*6 z>&0%lh2`bt*uNf*gt5lU&F#rfC0b%YK*08ZQ|#*rr3GJJ>_$|W`G~)-aFcL?8)fpQa8p5rHwb{hj*xitju)B9zSXh3P%!M-Qkma;b zF0Jm_KG5j9k%%c5T1)H?>gu?Xk_@k3j{+k>@#Hhk7ca&{g(iM6zNa}zmk}8f!XBUg zW>ot2GqmafDI0_{H!LY5E*Ne%_19$O;W<6FOI2twaBMIq>#4)g+v zrcI=36ylrOOhZGz(G5w~b8PW{N2#?EBg1gn;fZGJIs8J!^eS^o@3D+ll+Jhx78Zy0 zZ5Fdg=sk&wI(<{C|8!#(H1!7bXCXcYrYQ0ew|HW$te|vo#^I_nahDBmGPezw3LV-b zrTjVW#g}B!xrd?O8iky$?N3pYQy#b^u`=e>?zfM;q~(ZVtan{+Xqm z;k7n<91dapLra7Pytll22i1g>vBO}_r;O~EFS9Z-6fZ-ta^(j7AB<&qH{B<$nLj42 z%XN5#;toRs{Fz@K#hI+^b5-urx5q+h-aPR4TCo%Q+`IlmlLTnZ5yFB@MN(kq#*Y3Vl(9%vxm!DwJ=R{{8!tI@Nv(a$Ms}O5Ev#w0WY( z8-lL`;I=$-3qA@!!-=;2dSZ44fO;lK_!@e7 z8F_gfCPK%&gz}<7lqa@qtrt?&7LKC{jSUS~t~M%h{?hj;@y1E8g-qhuv9qFG9}+f3 zn~z^j5I#SZRW(q$;e9eFi7PIWCsa!~h<6*I>(ju|c+{R&466>xRWYCC7XQ>8N!Na0 zyhp3>QJG-kg%}M^4W-yu);8QyO){DE5}Fr&$J9oH3>Go z>M}NhibwFq3OgB$ev>KLQYom=-lm2LH9$SNy&rNa;wj(EU%n)$usOiW3b+C8tz0T; z?13I09zQzy($dm;l_}qaFHy-!u6}ry13U3FF%hb2Odrp$6KO!7p-D z^su~CGf%|3KS2pyN@Rgw|7-Bhd+S}j*0SyPPL75dyS16PD=F`|9&=@n36Aamp3$E% zE6sAN$hA{3N}uYDMj(wc*M}=+M_1RLNhrBqC)kxWXWKAvemb4cV_8VK<0WednVpaU zh-y7dqsJvyAiRWOa0PA3TZnA#WksDxMA?Bs7vQ@eCYgW2-jJ_&qvQ4D>6b1G-DYQN zY&vFid83SY9&q@sk8e75TBMjcW@+%?6Y*<`{#}uVTQNK*lzaBP(RpdF{?1;MgF`i^ z{X~>paFt=cCRC%vB71H29t|=C1UiQy=|s#47)@k3@;WCmlf;xFy%~jU?ot+g(5RCK z1dqxYGSb%G-rjpdRN4BdfkGFx$yNig4@^}513#q>U(<-K8+E!D@6GYBZqIgXG=DnG zo+l=KHQ*mx@CcE#EQ%l%gw)jb3WIYi$5c2JRCMaDQC*w?6w3VZ*x1;wDeC>ZQl(QC z;96X(q+o|%M9m5!=MwIRyKW0`aDYK3lAvfKeY#K!M%s7Ys}%lU%?lvAuL=30xLas< ztSra3(fM7szfCW}ZZrn|TIYIA|kOAI_Q z1woz9j~<~X*L(Ng5DpHGmg%K!GAed%qUB(Tjqg#;aKfAE)FMuLo@eo@6w?`3UHZTvcoUJk}MIqjXTt?V=uc&@$EyY(z7tJGeueYtz!1n8w3Ys079j{V;D#z z^K<8Fy}$V%2g}^MRrY7S{=QsrN-+{Sb53U>$^CJ5(HGd@V*WPl~&(lR7y!w~qQ)rY0 z>&v(g{(gUHzd*=;zO|F!MYjJ|bGCkGsUrtb;b#SKfFTAZ*nfJNLD%RWFkwPaK!M)>2#Bs-i?oPK)=| zyg(qX%aVC)dRm=3io9}s#9W5LUOyE_%%Bo)J;Pojr*qObUtekUQRO}()E!?x$Ur}` zw7L!%;h=-wY7E{l-FWqV$+WAN%~}r7GoD@>4ItF6VRtAYC6o~}|tA2uPnWj#uEcfpzMp`^%kU|!1{9# zU9asl4LtLV!U=|G<_FqTO9p=b-lgZWvcsX|2}fP7Z~PXr&CHyQnI9F;_RZUFE?!A# zDt4WovVSN94DJZ(afj+m>4fpB`Dj+U8Iq3W58=!a+LL+)f!9;<<2% z)d^Q7jtGBA7GfNUfwJ>Vd&BJ7?3p<<>9^d$#h&V>xsz2unS z0VTHE+4)RV)B&^vq2Xs^q7ql?%Oq;OP835vgyr@ z@kL4;d!LGFN5{kfR?T%67l6)E*Y?7Flw^csFW!3UYs7 z{q~XPn${25uaZF$+n%L)wOKHz``Oj5>81X2FPlfx<>NfSk+6ZF83XFlwR^*I$1k`Q zkAj{hNKY)T$mgj?J?Opo{diZH_(hrs(LAr&pQbwA=0S!yATQ+_01(!%*f^i6T)lA8 ztxPXWdJgN#k_rLr3wDxkk&?pgR80NUtK#Ju=y^Erf`(!#dnYoU2I(LSltF+(^~UQx zw~CXeg&_@iKYw5;B*M!Izb{Q;O4VGj~+P!kSXWGI@AfR!f)MXm2EoVp#))- z@)F)P6rc@Xz9`7b-UAwKZiS9lkm=m3oL6>3*y}fqFLW&=SqSsx^cA-Ibho!NB2~q< z2Um*72M-P&IM8stdq{B;0K9GxOij&?e*0WUGuaRnAZW;a)Ct$By;5fA0oaiIu@?U4M>;r4_=X{*8kE5gQ zfB&+#@oK$y2%xqj#n-$6QtNs=JG(RI?e9woioIQ3Fm$m~RtL;mP>+RjJ5r_8V$kkfQ**ZD|YF-yYBA z=27M|p}R2hJYoE#J7kjid3pG7Q8Np}kS652kqjLVEUl5IamYr|VMLKq{mtjk{A(bV zFgQmn38+>(uuey3&B-hN-juW*IQTeZ(LdZ)&*YF_7Qpp!{uOuJ>x& zP0Y>h20l`keCgdy$FKq1*HuYLRkvabH#bg+3aC%6tEsI`+WH!5F0QRO#MBo$3_k2K z_6$_I)?^(bsjRQR6yfV-P)Mb&rba>jez2YuzUN{lteL*5>rZx6_)cFB>q54II(=uq z9n7JOltEx7jBg_dC-^LkEf{b5sa?PB19>triSx`E3_ao0;}WVf1$^T~&Kf^}xn<0IbCR4j)}JI&vpVhMx|%Rod$$DPaN`ntC$!&v`+?j;~6#{PX|_WM-ZKd%*nh zi_FZyWRoDna2Bz*=$vm8LufF�HxbiSWjxPQZqGdjMG#f3_OklY=b-vsg{)cD`R+ zyyESM>%Dkl44a#B#=OT3NgC9f^qpJ(Q>vvU0^@j2(aG64Tip;j z#BOG4^CPsM{_BjCRhTuLK701;ks}XJd_Bm@io5zwe~Rq{%1b+TN4bfz1RF!3q<`ip zH_lIlqjbp6yWCHHo*+_TKyL<-6Hooq^D22}4IX!sN$fy_-=8H(ArJcTadBsy$L666 zlUGn^AK!zkUgghb3U-!=ngi{u+U}3jEK0k>X$0crNvP4i6%za|Kb3=xAEogf{md1` zoum|K82g=x@qp>j!R^!c1|7DkcRxwXuo@?SXkuVJm}n5yJ3cx-?me8a$?Qp6EJJ6O zf2fK-*x1SX8^mSDtM~yn&QR48?~+{AE8!kuVya2>@n}H8Px0|TIsvC9ti+ml>ODl& z&)%{o@%IS?KO2i5}1oF(_tmmAGXRK@>6og+4yB~!I zCJG7*9iBFKlZzRh0@yiXgfR6RDl&I=t^H!*3!sV<%v%lOur@npr(;V%iM^x#+t@bdOp zGD}lf2>zI#muISBqN)iS-g%6|$lBU58_Zq!Y)F;fN_Af!A)@AVyzwz*u|0oZi0Chy z^GEOw13EnQJ%28qX#vv3E73d7RD}7KyLg_nm z%JIp`smV!citDP6hKCOR`t@tQS)xow*#SEXQ;0tIh6u(U^fuNM1xm>ifnA`6Qi|kvtVN56-7nl zgqT}f(+fF+y11L&gr6R32GZ#vV5)Vovc+Hr_Q|BL_S5Gt5oM&MQA+~najSj&d#>?# z;owUKM!vTYyyukvX$HF$%9B8vpnhDAI$wK#y#5iB4M`l@u9DqD4ch!SzK90iZxx=^3z;VYZhU+SH+5#zP#-y`P?gjNJp zgy2*705V-{vn!%zomAu`UuYNkvod#}zdx+g9hzu8}Ab+xs5^b@^x zbk=b5z~uG}WmU)I5#zCIuaquQ{(VjNLMhT3x^5zUtEdQZLXS_-k2wkN^fxzuK5SM^ zq~O~B2`Z2`Z?tSCavIE->FL=nf3sws8Xv!T^X7L{nBY8heG*iF*3o`n9!4LyhM}JT zNe3tk%&VxWsMrGEl$L_B+d29Adln7~Vo)Fo8yxy1MKQYY2NqwjCvx-G#unHQUh%|@ zw{J!>RoNnc4{*r~^EzU46c_t+GLq5U+lN+uw|{vVo2i`NY*>NH zu(G!9D6)-cAJ5g`!PN{YJd(-imVf_ttn7wXF1|raSGO8;X42P;-TQme113fN(soS4 zyZRvmu}^<>VApN(%DI)d?eTrl_36hi3((B;cE8r!5o8EiNX>wISx>HUf-Pl@J!O^6 zn{v`}t!sF$@`&%>N93nn^8EV^{#6{n(s%wda&1UoMZ32A`-Z@B_@T-+5MBmA#Xb-s z>1wBiD4*pvWBQMiE>(R(gz}vvu><+Ja4SKETn(?X%5nU~kGBm`N4@TxR2&XVYau6e zk@61Zx1iWK7}{-9R6pn+tO4Y$J^4kl#Keaum)^$?z~2fuI@OmDXN@3*#o8){uYx z{P|!isj|(DPRgpTF{)~#*`Pg*tLq!c#VSflnzAW4M0(_&S#Bunf_97>-*2u!v#^yaK zlmXD|Bqcjf5e^Dsdh^OUS%~EChWHzTL8MX)V|VYhSsCD8dcA^4zq?pyDu)0~)~6qZ zjX{C*Tgf(IHmE3ch^mys5fp_*#*eIBS&(~ElrzvM_+j8;d%?426 z`E-WAVSL}(W`+#DF6zox;4_DYx|Zl*aQOG2_mMfUZX#k)me-eo0?bn%zG}cyV;?Cii75h0r!mRZ zz3wBS&}<@pEolQ4E~m-hqQ#W|T@Iw)oYscoK8kwX@rB zY!u-A>W{4h{~;-dq(kT)^q9eq{8;mZTE=d9kkBY5y%x5Rzm&5HkllS~@Ge+O9%ncgr zk4;Vec(b6Af8Na8oQ6HnP(w`(KF#r}swzzglBAneRUfT@kb|T{bSuad!942xd3TSp zTQvjt@q=4mzrJ$qS%N=Cb7E%zJNSi^Rk9C&soPke)=%N&K781yEsHeF zMf)kBLxe<%{yl#n&3k)FcKIBkJCdM$rYNRkv;j8ikPNH$1ez`kRGh~ONN+%toRw83 zk|>bhxqEjgKtuJ;qvyS`!pA+kZF~>n>mb^#tIIfbDi=8q0AH9}SbXGXVmA?xax3cr zbrGM4(dHYHGV$u!9%(OMPJIX&@TtgoZtema*U6KkqoY4PwnHhZLlr#Gd{sznb1hU; z^E|2*+nkDx^jzvDuM_$i-YDjNZ6W$2yTKtE!Ei?SZ`dj>F>>d)6K=a1B`tk!~ z{bY+b1qIJ=uB@IB7dPyFvj=U_aHBfYc?aZpdi{-8%D^uFQ>X1_LaET+&}xA=>)|iV zFaRK6vDj(!_h|EOP#N04D$y}ARyYj07HA<7sIDnR=JQZ2PCSI2k-TB>>YQC-delhA z_5oUs{Is;Zq9UQ=$8-KOc+oiAS>}1;`t?D8&C}r>eERg7#<_ux+?1s?FF&=AJzHS=Ym&8bwE)psodeai(3j3m4!3ne&?r{9r8;NIrv(^ig%aK6rD=N~TJtIvamnZgAy#jPi z2!*l~g|mwbe7KIdx}sIbmeBgF)x}Cx7_hO={PE*)skZ`dUvIvB+gsGRzBb2)#qNVT z6W@(F*6llX&=BEdse2%!=QVo(KgNY=0z=t6?OpGRde`?7YE2v>Widd&KEr=ETqmW< z8G_4Jo}QiM-k!&rQ!HkdTnBBaQ9)oBO1$wYEkHDu~T~;Lbk}o4DhS-yUV1MZRB-64?SF zdx9NN1VUC!djgdZ=i*k(1)9;ZV+Xeo_)DzMcEWP)FHzcUlc9QdfIgx|g>yeF!C4c^ zT3>4KU=xj;ozT_m>CIO-lpk=&$V^t=&dyfg;^M-{wQ`-Bnz|6RqlCJ;`uPM!=x19k zwY8@kR>%nD*Db9wdwn+(ST|<$G36^?D)Yq$bu+Pd8lfgDW3A&DjD<6IhBKW%_x&b$ zUy@w~Ia0|YI4&dHS1e$7|AB^sp;GV}RoOEMF;p#1cESvH+Yp`F33YLIcPU;vBHHy5 z0#c5(cnrmYrnJvWdjBK-Q>3H&UZI?B4u%xRDBT}d(I}LcUr{$r-t1# zTW#&k_Ho=}^~=}nZxh)`Yelh(eTO4QSac2%Z2TCvR;|l7Q(oTAFCRpM)Di?$V6S-T z($>l-1iAQM>Va1PS}~5jCw2df{H(4ozD<4$*H?ae|M(8;*L}xqiXIx$Pj$NTec3~p zxv8qHy*?CgOR{-G>f$pSs*fv8mR?zS@^g$XS5f{XJw8iV`iN5nn@~(pqU4wl9lEZf z(r{ALV;-0Kixlt_R99C!y8eIW#uyg`ot)kG?I8)7+_o(T# zMi#aQDmge<;u6#@1XzjXlt%2L=OB$)8Zr$^`#AQ=ybr-=-1_E6O zjrH9Jcfg$m82}^~ov%+~826TS7t_|6`?vrRGMzgH?04UOk1h|5%^xrEz^_9MtVaSN zio`654Q>|C=(_dI&v6fO0|J4&xcvM5?Vu1QP9P4JXMZBHEH~a$^eJ+LppLZ?iW4v6 zJbLt|ot*(9h*=^K=Lbeoh81mNOWqVAG14m%!kdNZF#NpNh~E{=BuUo^Hs#RkUpnadqbn- zU+PPk%3VE*AkG(W*PzY9EqrWkCDdhlgL@eXW2XUhI1~h<;{^)f)T2#dg+h8{@hO5) zE)d2*552{GCe73xc0EUj-^5E*J)YAiZ3^sV@7UvhZp z0Xo)Q$>iJ&IYO5$ygt^}z%nk3q?~}9f{qUXvqO!*9mf^{zjrcv5r-CIO^83CI^7;% z2+shfOmG;2L*VP#dDM3H+OiYzhpDNir0Fdz zd%MZEq?~H8WEQvo*&(^u+uI9MLxEPe|F+Q2Lmj9AvvP9Ew2vcZhu|kNEWV4tdDm+^ zTL_uviII_ofPg~AX;*()052%tc|2W5&j-7otK#2_QO;y#b!BDg1k%*!L1utq_V@^* zt@G+v86{jxP}D$*qM2)i?1e{bYg`oUP$#UeVx^dZ4qK>x1);kDR+{Cn!0^Kt2+syU z{JU;H&^}+hQ=Xb~DhpX+kYU=*$VvO?>nAE_FfcI@DbO0DyzB5V4d~mNnl`HGI-v>0qRVcuh_rqG9V78lcQxxfQ`Nw%>;vcs=OEsE z9M4EgM4M=2F+Dn(#K~Q}iLM(A?m>!3j+NEk3go#sdX$l|FM6cVlKL0BipqbDu@z)^ z$x@+VANdQl!UjIn-XVR^5ag&nc=T$Vz!?z{b)IN`$^nU*>bp;b;s+FzUZsZFD#JiK2|fXxwhPF#cV;MZIfCLfUVFVwK6p z^Z@D-VU?klBrCqT#6vo#Y+2DHF9%Jf?EfzpP>%WzoB{X zsr}#f&2I;@`1gM!HMHd-h@SZSHA8djf4=hzructq$R7rnYBB}$vEeT=P*&M71&6p2 zmXA#}3;aj$Dh1AbX_b_e-57lS85zOgC)TdJ5J~O%f4BU{$fT}8gqxuXh(w*uZUR9R zigV}EZmMA8|NVc08;1ij21(DwZu;Ubfqzfx|8)rPzb}KGzFnd4^!p$*KrBL~yg z*byR;96d&6=H~AfNt|QhLezgB)o;gpZ`JKi*!E-7)A)qzJ2dWvInabJ85Hy8qZ_*qu@O%?Mi-xdGumrXRpyRxSQ~atM)3ZZby*WrXV}IU>6@5?*{XGkp3R%OlU%(WI)4&#bNNMtTDGiAEVo zNrtc_QI_6Or$^Dzs@D^!Sx%iek^bBqcCek~wNq2!s8&&lyEd)SImd)X_5FK!topW)JxG=<)CwToD@8=;YC=fM0Zddse;#_ePPbn^l@o4? zs~XX9r&7!@RLsi41y}KEBhZS{@NE*4un{3~@SjFStph_d2O2G96*k=M*_{AYUu>o% z0<0|pU*Gxj5bFLLW?&N6=V7n~_|unK$!eJ}kn3Sf1RE3v_N=~J0~5#Z^`+j7 z%uMe;qh~}}HZdeg=oUB1{|?U^k)C*`b5D^_wwk_{mcvY+c(z&*05<{bzcSL*pl{9z z4vv57#QXyyuZk*H+PN?3Th|9wb)@P%>w& zAp>&e1}=FtzgNAD+ZWwz1Xlk29gM|xoFl~E>Adotm4(Gf^P|b#`}Koeds!l4o<6mg ziT`&v-f=9uY$tT(dok7Q3A*3e0R<8Z6BEQpjA!58fAD~TmUiLS!>d5W^p2YSn*rM8 zbn6HB!MSL;K=QS_7{V9S@q29_a>lUu(#qD%{b?T}>9FCoa`L84ZUN-z?(x7EuRb3~d=Pm;`6)5X2Se&m>D!W$j2B~Th0XI0@%PsE==v=7 z_W0zMlt6rn=W)Z#Y_o4iFThq^yNuP#EpJpZLs*Nt;g452XhArVkJGFyxiepIlSVBA zh5w$k-;R&o`w39Hl5$ONw)yz_vJ#)aecLtYfX@GKqeR6lY+i(d#>R#j)1j7(eIWkZ z6dehaebDu0A%A1Tr>y5fb3y0i;mf~~O$IqNX{{0!lbGK*39dk83a01GqQ$-ac5H#< zTMSVmRfnFe2?uqGh}hr;Gu^yjw1HnoMn=kt|4u`3b}+{_nLn90+a+}_{74{uP)TYw zW?_&yC011_pe+^id<}_%rQnbBrykPTZPq<&r#_Sa8~n5AEM231*KL^6S@cFdz*V+WYq)`*{XoLiMmaXqBoyFCifsF9)60z^pyf_*foT zrRekdM1*-Bc4I(I`m*UQf_UlQ_xx=|jvx&G{d!l-_CMeK|Ct#7@6F=>!#(fs z3f{bN$cz7X^<%MoTW9m`02tX7xcus^J_4Tg?Lu2G7`_Sjq;;_-SCo|GP-uooA3M1& zVw7A$qJ$L3UdZ|%#l)b+3jA7N(R_(`k0R;q+qbAKV?Rs(ePqAj9-LDn3qc@pTg7;a zvSh2dPIo#QUlpBA0A&6FN0DvsYxlXDuJ;i5(&@Qje1;1%gpMbpT>`(xojzJpvJG7) zO6`X~O#U6#sdNHc?O*R*UZc--H9dAn6olCMG8OkrYl#>nj@) zp2N&6)y}+Yr%!i!PXB0q;o5Svh0qj#ikY$N%9C@s#>dM;BzogLA9iu{Dy;rwjOp_W z3p+(GZ~M`Son}loQ%~L7b9!$5lv_5%t(|>@#T7B1HS;fT9e;e`9Tpotsl$t65h1!@ zvYtIFH!}%8OUrVw#2QuA zE0nDSLY(|T3Vbw>&z1ijvVsG#)G?TmRj1Xjo{{*^$>&MgJMe{k@j!+wpqUS zrPI`K!O`HRywc_hMEI3bny?D}@L?HlBL;>s0)b;M zs^iThCC>M=UqklQ$X%gB(LXelhTHLGy2SdSD7n+|3c|YD($W~-|Mu`+SSW;73E9^w z4h{l|eEjs3%*>P8MdkY_mdWs777Js}7}VhfRvT&ZM9o{e?J1?uBfR^A@_{%4q1|@RG{nGs67&2 zXCmk8n}~m3i9Z@8r^~AjPRETz?;p+03ikj+T|hIA{ngj&kWFJI$$ziq`}f(!PTP$u z64WFi3yw`~(Vf+6WU;j57ts+FA;u?C7ARwT7`4!3A=4AUd)TcXOTI_EgQ>uI!iChk zG!%gZLV)3eN(0mp7!&2R$45th8FUCS7e&tX9NfS*uzw1G=tm$m24hIAJ*YN6cn7DoU9Ric@0yfh_J95xgAcz z2x!Fa7hCs*KLqsB94AjENFKH*yhiYQwa>-m8S0&NOtZ-eh&>sLlsW5IqVrQtRTW7O zgLB)!$mOK$!kFXlNl@ZFC9{p~FcCDTA2X?XIXN$1s&ZeC5L@I3u7V02cjtZk_5u9P zs}8H4IOdlrDMzGJ*w-lH8xA2C>bv#&`g*0oea>gf8C1b#g@u|N4={s)c@aj*Q>U6p z`$^zG58Wnm@$kUu2?LSVr^kzg?DD5xooJ8G$XW+8Br@>i+r|rWBH-LR44@b#zaO}wKn4rgxM31LGRSZS-Ob7Wt)~OEuW=64?4rx)gPKkG0fc$e>fx)PRQkXF|wL(41+n~2)*aLo1`r5=*W@6-ghRT>;HZA<=R~liyZrR z-L5nU+DvIaMDTm|jN_*bh88L+Tf>9DJXv{feU=QM+Gg{^>1{KWJ31K{8Ic-TKS)W3 zd`K`j+{zFJjyLV{qk^JwJ0`TyhpBe`r4>AUxG#oRw?Knu=gyFdKdrXtN(&7tiSLVH zN$JiuRFuC5C=fb>(>D}pr>Y4As$dlj4N2=o(21a>!w-Uj{$P-`L-^2^f1g2$U*i2f zqGWJJcZs}r`Ft#WI$l-sL@!~&&!=mRPVFSpj%CpJ+R#0(AjV-NCCq5MZDcU?8?74&Vtm3}l34NBu=K|X>WHkJE z9?YtzqUK`1{zu_|=%27yOdDw%U0wok8fC+jqv@^(}Ni+EPrHvitnhm(}&$^ zqIct;SxCNbyF32|9mZ>nln>Jt69nmxO*^|{^->ii1DooPPG?;2%gY!Z$z9je6TeMF zE{(aBRY_@g0O^7%_UqO)0{2n29`A1M2*)b~z&pQ}r{w5rRSUe*7fvW4|o zPh8dE+r#!MXY+fTJ(Gm}&t>e;%muY11GQ4`LIozuf`he{%)8zV$=9jM-xmfw*1sN4 zoOlu)J=J#c+M_y?2eKSF?ILH=d)BM+8-1=Gj$@x(!lrMko3(fG-Lx=V#NVwE#LgQ7 zZ5UmihBf6SUEZShaWVotEZ_5Y&&}=bvWaOjN8Z`KP5*Mtq;GaDLr?oyjb+z1q{TQ+ zb&ZBGvLXi%ACMi?J^(A&ri4sPbm0$8`C}=!uiJ1DL|Le-Wc6}t5DKEBd^pmk;}zE# z=jitF?h;2Cs5Es)38c@)JMT1tj!62`*|$H;^2-<6;(`10($ZpxZ!pY1Pl|_jUHLs& zu{Ici{!DFR!M2~1X$L9X<57(Mr~3MoCUd#ePXn{^^7pQ!3hWKp|FZ9A^=^2rVIII` zo+h~ENEpVKTh6^pB@zl zB+P1AZg(UPD`b-YzVI+EPHaFp7KzK8EuDHhP)CUU89A7%@vW;%Ht_kI-rCQfkq6Qq zb2=_d^_^1;@KqVlQuJw#}rBgN+ zi+uZL-6kjB=&z5_3DJFlsQR__QCe5Sp0_JXWPTUe?w8hjKO;Or_Fa1V4gvnhLe<~J_l3@YuGw(f+r zibc#LwqdBad#bK(C*d7FXyx9CfWMrL&sGbqAN=w9rj@!nQv0N7oV>iOG45q&50O7M zzHmvh@cQ)wdO4nLS(FT6R0J6Kwi56t5fVL3y}fj_NzybpNZLF@A3y#AKn&Q zHG5s>NNrJo5@$ze=jlQd0|UQWS#M9fbFizk@87lJRmr?G#rW&bEo!QsCVT>{&&u#b z1G1W=M9*uI+kxv%RsSyX!^yazAlS#r!2!{IT_eNe@m1!6dn>HcPDs z_YBRUM0uk^Pr03RgI$Qg(YV>UakkLJ+S;l8Wkgyu?x`rpZdiusNfcYP%LE=L&?XNf z97AQBf2D!0?oD0Y$%3IQwQ&Fl)1n2>wh5hW3+9848vmq=6d0s+Tx|o(I7VeYwc`uYQq|8@ zX}4ENVza2AaI~pPglT!&XQ@}^%9@XF@ef!JmzUij$xX%?p@G+=pm1O|3b5A8SK@CE zxS^g@R(^nfhne}jlezD;CZ-adDJNlMOryj~PDX09im|b`m6fAj&&2YwByUV-Z*ON? zo7{)ZZKOnvf&wStMPg1&xU7zhyi!a@t|U2O|Ni|*(%3ued*(5iw`W~lT_a_mp~u^G zdkf*t9VIMEN+7|*K@m`{@3*Tpd7!~_h?yA`VfY=TPV3hj8$I9%*4D}vbvF0*YF~G5 zwJtx{2rcvQ-~mXmAISbfz*<^b5G0!1QNoD+?0>IGAVAEW(XzejS(RZ$ouFQs$Kd+X zruf3Mrcoy{0t)j(lxE7x$}+*>@@ZMRrB5pj!o$K~h=AO(RyG@*)K?{aP0fp+&-=4s zTN@Xr37^=&EV7x8RCQFI)|Dx%;hB@J%eIKiMg+I$MzwSwmB ziVBS5oc#78f%2$fsA&3E+_Ocfg#BKA#7i$ZgJ&h?GqN74g8>BS;ZKQWc_o|f!dx#!5M z%htipr~LBrTD{h#Pw_~iH@K-u9~H3#)>F2+Ha1dztXSe;mB8i}P^xV9LPSWbx3AA_ zYoi;WD(8tzjB%~4#sv~|ax|Ik_<$>{IwsrNc4}X&2ks5yf`;xLLsl9-L`dfR2oI;! z&eBPp?YUprVRbx41%cctKa53^@*y5i*E%C8NUYRMn!a!OwtB~j$eA~pMXt@5wUyK7 z9YShMXhRfmQ0xtqcXM-Vczjm)_Aeam@PP2^y%*!-Lrx_YB_$=R5EWpG-zHqJ@&)u6 zd3*aB$}FP8(9!5wO2de4_q+mfDE+G_MZb4;uD70_DSR(Xm|?ed)3v=Lhf)sXh}5ji;;ju zUVLt${m-H~&1hv|2??Tmh%=_xZNXHHv%yU0pQm)fpPtW;A2s$CJJ&`Z+f70cO4t~Q z^FgQNIVKVJk57GleJwScM;lMVR5XU}+qk#|caKsa^rA^gM@R@fx>ApxJQ;E-Ui_De z^MOo`gn%a!d0CQo|8kv7$hYaHV2}5O-07aC8u0MQpHyW8GzhM$uY%jg;5?)*0Gjky9?VSZ#EztrsH988O+Edr7%cRNnPPY8f=P#Hi7<5Ga<> zJeSd9ErsIgnCkna0&KmU5^}mg6_t!f58^bQ#f)DuWCO-GMIZe6{6i>X+>i)NM z@^iv(I9CYH{jvW6 zcDUI)0CEIb3*mpw$t*vAt^g(vls{BX8R(Gah#xaE^A?i&<=CUwHp?;S%2x8nesz=T z$E4b1-Z0W|^E8zdeTj%K=xELuYP93PE>iQjo}MnGaoBNc$sa=F>cK1>MAbUu-cL(2 zMOC2+2b4C9%*>CKUjPLV(keBnd4=$l=H@%88qaiI351)8BynYV9W4VviqRfR(&u>`a0hOzdePPYz4Q z*O=h#xRetKD>I-q46%38EU{?N(k8x5jvAObq4$KAISL8wFc)>(h@|j?Zd(|Q)zvW& zIlND1wJOTQ)RdMC`P%B4c-nv_sPB_{kes~!dH64DNa}C*2qia+v`$Ee)%;ml`)SvS@`};sZo)i=q@-;$i?Xqi z5O8Yh=_NWyEdoTS{i1|f$!E1X?ijl;viZ2^aWG{9dV$&Qa99meKJZ~A#u|Yqf$HT^ z^`MCG_lnKsB+*0Y?ZLI+gFZEqZ02^E~HDZ z|Ji%|xN~(2%43?F)uWZAq@}%`cf^*JZN$fS%?@=8zODE-sVYi$N8+f@_WBRgS}Ig} zBg^0CmCmbR@-rzd$Vd2mEwtO_Uk!i1g{>{1r_Jt`evK@h!CP^>*Z5+;8t{#sXPIV| z55u40A8onuLiarGJRrCMGPTfpY;4ZVV6ugGzcAlCJxsv_CYWE9<^1JhYZIBfCtUt@ zb&ad?du=Nvqum`x5V@a=i_5r+ZB|x3NI^iNc6R;3J1d9h(7R=`zFbk-hgADAtB%7I zfmVgRGXKW?(dgDXv6!;?X8<{epXTv0E2RyJL7SR@OY7IdPW0+=G#AyG%_r*@$YJUB zC)FXaKJcIneGZ?)plXGTtU_H#_;*qQ8gd7#cRMh_9S=bgFE4MZR$fujYSx)2XFWK} z{#A$@=B|ui*|5fP@xNSv*6Km$7bPW$U%t3=#-JFq*s?v%fG?_Pl#~Dj3O6VZ0hzr4 z*UB13pl78E`OFnMzqVmXfj>`ltruvs(!dx;tXVY^GAwZ!OgZYRqa#eHoW4W67Rbxp z@Ij@kUO}CDx{!(0zFW)f0p`{lZC-=1|&rM8X-%y_%G zT~n;N$r+Q7lq3VYDP-O8^2qlWN%9&S+_=tnOJAP{RXlST8-W0k$$_W{eNLQ5vAspH z$oLHx)ed*(-@4*B_hdG*6kX$jQGC2wz`v}ltVtwb5?o4tWMu3Ll$X0ohSnjGB$SB|l+DfWsHrg#?pYkH ze%sji#B^sVU{vS zBrMcI*VM{bjXqEJdIh$ zt00I64j(?Op0ed>VKKY>>4iM;N!a_}lMvoAR_Z$E*%g3zK)TZP&wh;~PVQ37LqF>3 z1dPXpPOT1KRFlpC9OLd@-lP7*f*nN~LdTECDzN(=sja^)_9sB--Y{EXFHx?+_9L*< zR6xzJ+<<|W7W<;JlM}E^yZ0Q3|Ij|V2e-Mk^?t&=>cM*_TWtsg?+TRO0Vw?xDBOr~ zXQ^XIOr3*@n(WQ-s-<ja z2oSKwGAhs~uASXR08Msq{fix##*2l2J3q8_bac0-?)AYJHNyFcIZEWv zTCj&aki>oyAPC8u5F@9TG=C~@{m2F8C~AU{0He5g@r`nn4HFb0f;(!*4vaJ{U7RV> z=f|7-H6|yHAE(`_#p#06m_P{FMjI_WzpO5rq!j}!KM3_^bU+~qV#(?i+dZ!n)iR6( zXg=gv+1L<^OC25er11ZmTSc)60;D0r>&qMVpLcQ{qQJOwPIf1Ow7Aw)>MynQ>iUw$ zgMcfQ-)a5`ACBl!!N+(veZp;FbiZSOyN3tJ3NLAUt4Ut=m7liw`VJzG$t17I+*z?E zHpxaAGC*v>EB~BKT>h)!i>X(pZ$np&tm~Znm8+OhE?hWFc$SkBtMLXqD$w>D>%Wf5 zyUHN%fHOuht(APIeIj*bPFi~b5*Snde)I0L5n0>xhK@6>RfGQcXhOYNV5!3A^ScPZ zjj(poo;XcTN<+49*AC3xl9pcFz){85^nULkqQ%}LB$qPV@nL0f6SU{ty>zoLv(min zelq)-j*rRsP*8QbZSMeH8o0@_be_h?e>M{;=o!Z@4!LZ=4G|&~@MFgT0ubPvHa2QR z;^a_Z;BgdnGTzTIC=Tsm9|E+sZ?TaN%@qxJE?gQOHl?K{ zh6YJaGMb;f|+-xL^8NA{fw_KGH-nyp&-mo_ijhB zvZ7aWA~Pi{GLn{}COTU0B>}+K3>6Uo`>Tx-N*;QOUH)_Ub0}R92!9kG4^bHmX&u>D z?B<^}j4Zl`T)f$Y#wCqR>*GUGhOlpt$e!cW{*gOimVd3FhpRwh{(~gW_$#@Fz~LtE zl%l*{S6lnGM{gUxTS$Hk`0fI5qX>i#i-VJMzjWfrNL=~Wn*RN+HpoVfh)50HDP=!a z;8g7N>Rz`E=kh1Kv+%KZl$4ar&xbLD1#*R>GiYrj1=lW(<~93d4KA0p`Qtev7g%XV zM@HcCLja^uf_!}Dejz040h>llX@pWW#MH1X|80)9m$kQVnVl7&-7!gI!#{sUP$LY# zd-whlLp^VNY%H=$p^bhJA3wgb8@M*!76{f@wpV4e{V(0 z^pv|$RJjW_)Qj0}UvA~{!}nWp`S;J0v$ylz<$zu$H*ra z+<16$4O2XSsdMr3V`azs`ohePi=HwN)|w>sTle_;*wAAc{zZi$tj0(HeQU@SQLGus z%hU8X_NyNJX0hn!$Ie6zx9h;mkRz6|csPs&;xVi|Yd@qQ@D1HddnqWgzFQaDpQL|< znr&hUF;6UQVLGAl+j7J|B^^->!ZupxyVVj5qqUu~M-KX&pfe zIK?0bUH!}oa!j`vF0-bz=-;>@de`oxe-#%muWlB5#z`XYXOf4&Q-N>x!rlceGj~c+ zM2~N|%SK&Jt`#J)MEkc{^eSs*y@yE&6Cw7*;W>k1r;PV5#;)Wj|3xIrgZkfyJ;gi5 zcpuz+P__5qr!~oyHMA=|*iBA+qgKK}lBKo&au72Ywng_fQkxE@IXcVB3kAxP5LR5v zuDp4aB5~V~=G#=z?GjzWy}m8#lZD{hf8@+S`VLfOFF{DGi<*Evp+>+aQE>~E#*R#Y zeOf2NjRd-SdhlABnhf#c12wsQz(X&(F`#urJqd||LkSZew3k&5;Yw)X~UTUy>1M$XAKP;pWfc)7Z{{e`4{T zx@Bo%f+BTXQ2iEDCAi^Q#xAL=lM+0oZ=hSxzlxD@^+Hi;X_&$%uq)B;a$ZeN!o3xj zt{Uek_EUpPSV%|Qimhn5a}G|s9P}gsAry*lneq-3jagHW!xIGgZ=@#Rnb4p zMgLx}!u`n7ztquDPRet8rV?dYk+Y!dUxhOxz_@FPubD37MMZ_Z>(v{e>8!R)nW)d4 zIYayOt8RA3*g`?!6uQm~w>vZmq0bLrd|@cFnl!NSP>u5#IZ9K%nh71`GmtNnC*1q+ z;W2`sQUIMQX6a~gJ(6WbA`}&iwCl*%eV4_EcciW#5`R4Uc9Z|s4>Vb55j?zude@?) z_w6g(FIp|6nEB~Hg#?^0++q!V&K2sNvnCe$+<>oT*s;YT#)}&H@&R)nJFNBu$(Nut z_v_fg6ZI2=T@uGWtI-81F>8~0aqsX_&ed(+3j&*v94k#{wJYXZ+ zSQth-*Lh_pF{YsEL(PuM{FtBEo&5mFwia>Gzq-l`5@J{N@9E?PqObLZk$}TNXM4@8 z?_(+3-g0u$*pQt^!#;Z4MRtbteBJ1$PbP%QH`iGLZykW7q7BIqeRe4sQlPKv?vlBZ z5`2HoKv18Tm)GkmKu^(kq3a2ZtRhKvXnk~W`*3h7bI~IVmUyCGeb|+>eMMejyQ~<)@loa<11daXk-JIn ziZ4RMdX$+tLxbql3_0=Cdt)v$I5^u^)(BN1t8;1FTz?V-@ADFI*YlN7B7FS2gKR#> zFIhL>VI6_G`>>IjV_hR9^;EL@ZWtBug9>$zEnHFyM+MK!Kt*AG{-)u|UpXLwy~A?? z36!W{=G4YbQ&;D3bEE^R8ks+rD2Wmc!o_>wrkbydlK6S*(}sK|^?jg}w$ooOs9G8r zX~i|;v%&u*7$e?nhwr@(E8yzB`4}!)+wXD8f%l4ChKT zscc%SrSPlX>GBYs{=0huYE0m~5=x+>+=b+wKD*LVOAW-@5pN*Y0lB}&b{Z{=)*=7| zLxRtIeX~bjoCjrs+DSgXYj2J6E*y{}1-p{*ggO9^>(fYr66?{#E-wv>G z3}MrAMfUx^V9Xmv=DB%tv5B@%--)h&1j1I-&J*3FNK?oFEx`+86(eOv?{rCYA3f27 zPo!W?zMbWcMLi$B!RYQ=N+h7?9lBD_(*5_DV5h3{e?dTWU~^I-m@g?dyIh=TLCegisIjqw3=9l{35~L>VnWaDt*uX;Opuh2 zcn9{1)YqZm@d?Dq699tewKTqT4kjE+*X}0s z{Db_44Ey(=M{W%B-P^aZtX<}gg{lRt78${aarxUh>e`y)-z;1z21JE~-q{b>vG`MseMHck!xh#tHZ?IJeS0#X!)hnNqM#K9&BE^2 zK>lDMqo*h?E8{(RGEn^%FavI>6EOL;XPhGUgZLSP7H$aOW}4}ttT89yzb!2tM&)L} zVF9ETft@NZXXcK5)oQWny}h-W^69Pn|9{S?*{Q=xX%1z1jl}v4JBWE#un?Z8WgzF& zQS3=ysmv|{Fhe9HeI0R1)d(II3pM!_)Nf?|s z=pg+g5V~wI6;XxY-mEj;$$I?wDIqO@pc>b%VROCVF})N_ew&Lp`$Crk#$AK!XP#+k zlleJKm+78;z`;HVJZu>|r-`AHxmx3JgdO(Y5|?QCRJeh@0lpQaL^mQxa&hs?9CWq= zTm9jC;tlxFycH6rim-a&gz(RX>$_QOOob8xpk?nVnu{)WR;4A|M@Fg;XuxM*8)=J7 zeqIKk5AGlPF)h)BAVdStgqe_=iAh^mm-1B-F21Ld9(St7$6q##pec^X`70?gM2iNg zal+U~dJna&bz=*tq6LD%dHgt#5CTnh$5(UbturZ-|9fP~fB&7YnSPbq8cSNw+z-SfLhNuF;(--7Lqn`ZV#k;C%W*m?XW@UNNQya^~gWb0B| zYU-P3&s;lRok0@PIncD#|B&|o(fiwAk@@Bgy%M9rPsb5~^QW61dd2oO^HX~7%?3Z! zK(dOd4Vh8G?kIqPj0W*om`u}Jaa%u%jXk$|Rh#P(>=YD%5=hOIdOc9K22}=AQqywH z!IZ)eA_wW|4<3x;y;0s~A_%PNFyS66bVjz;)*n6B9vaHL=%nsXZaMIOXI<_HWG;CA zckS9$QX=8uQA#2UutHByBCg>a4Tw2;bE9Y5{?uE4SJuI|0>VFdN>45G^hx>)o}PXh zT<`QwfrPQJx8Fh3Ys|ZXQC!rwfvB!#&;jhFh^Xk0SbuvvK1WoeLJmPNTK+>yub7lH z1v>+*-39N3^>ZGBevGUg-a!c7LBbGrdqS%lI+sP)vgzq*q}kvUA08UIW%Cz>-t-h_ zcz7h)*pS=ZI^uN7u%ge&=D{asiy&%c%yqQmvby8>C_`GkAlzk|E*+*pMJntJ~yEX<;!GJJf# z8bFV*qa!KhC<{wzatrnU|MZ-EX7O~wy^F^LmA`l{ZwVzxF-KJo67Cr>GKhrP+uH6a zeKWb_?<;#x;nPc*HK4}|~q$(rS zKak03(C;L0#nO8F-~z{IMLUm76hz`3qsMQ<6|GE=g~4l~W&0k@vsMcNq!82LP2hjf zKCq3LKY)`s>Kzf8Bzsj$=zN+c0O}iD1lS)txfm2hR3H+fkEy^hSOC*tiwI1a%z)%z=M@$W8R2B^H6MyTGM*= zWMReQ=g-Bd&n_Y;qe_4m!UiXNNvNGOJIF}$>(`m1@o$w+XPeq*r< zs5b*ie2h#Ev;wH?13bEjL;|4=9WSGjyrxceM4JWs9%Fh%M<%#_4o9dzQVVOtYW8p4 z!`XQO%#Nk7o{0(iT9L~1OLc*nQ2F}W#Gu`NuVXPP=z{n{@qfbv4*C0}K)F>_;S}-< z4V`b#ytL-&%^bA?+Hh~+bA7j;Rs{eh;g{BV1xge>#MR%e_6gNYveY8fC9{Mips?)_ zrIMp#h|>P7_5x;cr{LgwYv_YyG;G4;Z&jcPQ=3v6GVKYnNWo5O;{4lVql?519VO5C zdiCTtOAV7y_WD&FdLD>cPiP9#TEBh&j^`JG#+jKTjN@?^(m{Wjm=2>xx@ceq;#qLb zIoa83uO!GEi+`$T4l6AbcVYY;9UUs+eIrf~CEOkG@^Eo+wF<-@ z4pGck4&n$KP7{>=`O?>qe;bYhVMP>!Oo1Cwgu8MAAIP&-1tCVt(mq3d{q~+7QUVtj z*N~H2;i~K1yP2&P*f??YE@JgM#h?nn8eh;`%pA^Qf7Cbuzks44Djp!JU~s&`LFZgt z2BTzGmn?4)T)fJQv41tSwSkf&PoVhD^uMr!E$FMjOvDpYPwLA`fEW+NHJKbF6QK9b ziOs`O0Udaknb7j0%cZHDtGsTLS+|9}^wBW8<2i9hUYmW} zKjK6}0M-H+xVDy9CihEe!Kknoj5EU1#c!#fOm2ph6A8o|cKfKOU=)Iq@!h)x1r;n8 z=H|NazCtB+s`)f-DzzPony4{O)j%HfjvTxW%#^#}oIx6-AT=NhUn$w2Hz){xtf0N4 z&wo%m1=YU2eJ3>V32KH~LY-p^iV82s8c)^;{9(wRo|qs4Au!*?B}%AfM*uyb+|@qp z*gioiUpe>|SIcp_39xfBpF`4s7j11QN-?K&O`r>1Bq>6HeQcyjB(s!8ZT2*`OciN{qcGc65kOBka!ua@z+rV&QEsm zbgq2J$+>A_f@yB^*KQf)Ys%w`)!^dhdkWF_$ddc*5)nw;Qc}?Dg)o(!gzp_4;5^`5 zo?G+Vd$76BlUqGSx&RpyP~?2NoTvfA33>((N8ACLhJEr4k{lwqd3g~AdwNtGipvN3 zByu#!2uRgn9#5Ac@nhwn+fyxoz>56tU)0CQNZp+^vbM9fgzi0HexV5eAimBPu4qZ^qZ3Y&mRAR=r^VnK8%hyzjrlJQ4JzkrgtAw!+2 zF4l>k}?PN0sSgn)S?#k&M;#g`QoYk(IZ2dcNPwRL$gs5i5D zYzb~F{NxW~wD;Yw#}O3RfCBqUlRV_X+|UxrePMbO*mAXR4d-1J7 zzgS~}PxX)w9g1V*<>`W|-{j;7CYUQP5HHP@9oXY=5(Pp)HFe!%&;CcC2oFWkztkLTux|e$8eGE6AG2E~|iy9j$_*jGTRTq7h0M>vrt$!pH0^##GpQ zGw&*9zToFXA>r?ahK4djdlwhpn0m~Kz^r*0l3K<@&zvD85VhhEOnvzxn81sQy^aq2 zADRj6G?uR(nMaX1@G5i|`Bw=is7a?F+ysuzUYpJ#(%9H!0FYJ%_v_7|W6AF}xaJ0k zfApCIEMiz~;B;oCfh8I(LBfg9IAGZfI`9;;WZ~6D{GlqNA_F^rV+8&tuI~0Qdgime zIY}f#+(xtXF}KwsF)4|ghX<}94K9OsW`_vBzQ#5LP(}`4zI+Ap0$@VJt4sQlcuVl_>3$Rx zyP`K5TQ}~yqlXWNhkrLWH%IVVOuf$a>ne2sV{k6eZKmXHS>nDyoJbm1s4-d-T{nNc zZWt+Xo!baM0JS69J=S*}7>q%&_I)jVDj?K22pFbh=yL!Vju>dCjvSF1Kv% z)@}lU+z)C~Us=Xwp$cZcICR$?qU0nHK= z$yBTFfEZJxEUQ_*_yDQ@gI*)N;%jS2UOAQGIp1n4RSq-(aviQv7)b88ydQ|=b1W{y z$4V3Ox%95j&u+II^;8Xz6fbppj_O7lcZJ_iB=>8qZ+-FkEBkK)GR2Dwoh%<>cb*d? zJYzj(qT=XzbGULY?0Tn+D-TDlG6TaG9T6%WVafrOG5BC<_l{{A=XXvh^zJJV?k#Roh4cdaZn_UM2E_eyIbK5fz8ROC%b8lPWvIXg`3dU!O; zPnE3nTvJ7gYV*U919KCHcUJh+x%Qr+p}&=t#!ePzy)L=C@ic{jjIggP2Yskt)h`HY zaMTP@NjenLgmAzH*6ywKzQ^J}zNbIiP!95j<{cS?pCSm-ILyL=km`tFjhOluaL>R{ zl9^TZ;rzm0eCWsN@;aw-UcEw!;_Fu>?pL^j5EPKb{(Z6zOCd7*4rL)w z3`Z>0!0~8hOzQ@3jPhVjceAkAb?!A{asuV65YfPyW+>Ctyc=Q8sWg$S!MaCKq(@5z z>5Hf+F!<3?CHfjQ&X~?AMa@TI7SCJ90a=pz1~-}a+WeTCn|u0{&!i^gxdjvgtTc>= z4(Vo}kxxZ0FnksGQm@)WQUy6a&e|sPBsHb9Rz@n3+s-s(n%tMs7us@gbrT0?TW6ay=R}_JU=Cm8Qgi@1r-cdX4l@4X#IU)Z2)_p1;3j zKS^A}f9#3*tQ~+&cT*dZ^rSj#UziG?AyfR zf4O-V7`uQ~BFTJgFR3pf&)FtV?S>=f<AAzY=T_ZX!m-%aCs*uR6MHJTFRU|JCC&a{5K%WY;6akvQUAxya|1QH;d*y~#(+o8+zwdhKopbO^ zO4gGC5*q^M(EJ?!1j7|R~Hw-X!BnLaqG_)SJ;Q2mzdHs6cz(> zp?c=_Vy299X&=DHxw#O`vIHZMBx;s^pN&;b0wJ!U_pPzEO1%L)8}@#Ttf+z#^Vw?b ze9AlW`*-g3QfVPARmNj(Qcou*vk@V5EV30g^2-F8kKW)+8LHoY{ThlE1E3p-??2D$ zLsAKxw#eYA4tH<E{#LT&X4mP0&Y++m2==y_Sy4EqK@G{yo^$W6g*EVH?| z|5Fbl&Cf#z2FD!^>8re02WD18MMbx^Rw`h_ggg7vgo^|L1U|ak@=8k=mO5{!A}@Eb z^%Umh&k5nZ({^@t|Hji+GSh!TT_*FdHA}GGr=}A)Du7?TdJPdkXR~g)4;kZ9SXo8+9Ovu=2NG$k)<0_MTRKLyL zpXEb&_@Y204Rvg`Mj4V2HvZnNKx-I+6WoSEZsCR+EGz*9`1EXPaKREZ!bqJ$6#MY- zen1KU2vt=VkiG^E+scX?|7A#SYL$T7{O>$Km;q!%szD%=X1epkf{z_MdUOE_$bbR% zih+UF)ZUNl!*FOqyu{ANwud0gscq;neY;{{WiV(4(mm4vFN|N=x^E1Kk$F)vTMrc2 z&#wK>FD@>=;q8oug@P2%cQFo|dWCjguw5+Qxvmg^85#BNL_V2XV&DK#C?rEmp{Qqz zPDD5&=hk;1)*XEI;4f8*K&R^aa09y7*t}0oHRPhtNN)nrJsA5~_egJxKV-zk0VgPauQd{YXa^Z&t*z1F;c5jE??91zdG$fu^(hd|fn&Q!tDqx= zJ?C1!5O8c5A7JVk9867W+z}{$?W22+E^_J_E$r+bDZc>RhY1eHQ~)XP)d;0_t2D@J zpm{=cB>tblAoI|NVjS{->H*It5n^p_(U>(^9aG$rU2SN7>!Q#Ut$)xH*WW`faPa!rYSfBC!aZb(& z7u&OE&#I`@*F&c4%9I2yEVyulm9_8?DFH~SbMUqoZoSruTV80BOU^kZ$M z^(=VO@Jw4iRm18D8R6H`&Ryqo>@FEuI;wd-3eYIA(px-{u}b*;qAu)R+N-2RdFHdy z7u3=pJmDK?T_}0nyhlD$Eu4-oDW=lARf7!P<=GRE7lA-}%NwC|daX(dv_QWX|t59w~?IkM7 zhmfrNZW|yBybSA~LrkSp?pj#LvPVmAt!i5pn7gN;y24>l`+9>CNDD0|D+ z<~BCEkyQtvhbrjov134$DdQTJAbtLG=ZN1k0xKp3^Za5sc|3&xHZvPMBXZfQcu;W} zU>E}-gG~?teCb-K^i<~Xyo$HO;LRTt-4Ipcir5hm)!NHw_{sd{$mg1xsBp^dxv1^9 zt{}tr78Ag>Bu(}4o7;-?mbs-Pr~&(5u^}kb(Xp0{R*PFLPm$$*#Q6K1&sGaR7(hhy z%%zjU<_*bfB`AFYAvX33L{^u5WgjFaibzNxw+OxPI2JEGm7*d%XgC02_Y8_9U0fEM z4&WCMlaPQs#ph2Ktx4%7wqpGcHi}M87hKPTvyOM?pD48Vi7G-4X=k9kCLELlTgxJj zck+NdVl&#-UWj5OeIUh{ukf0L?=yj|CH-^N3`^Jz_Bh3aX z7Gwl_&DE$7?jgZ+W_v5;`SXYQw=UgvG1wb_T1aT)#`ehJ| z|9xGS$Q3b8Y zKsZT^q|qwl=hF93oQ#wI;=p8cEtZ7vwnu7rxy9D@pT4_B1|0=l8(z(e{W=-Srzdp_ z%r39=JK8g<5qA5r%|7&qiCceYQ2xHbt6ueQ+`4k==lHIBwm*N{6|cOqx@^r6(epCy zWTLe5*Y)9exw?z@qRp%~x8!br})C+lXC*p$3=fhPw ze&6R(IPIL~W^hNfv}Wu?%hu>1VnjSllq-*xByQsLjr(-PqdtI6f#b{u? zAX^JxgOTx7mD~FFp3S!%yTY$*JIy#gc{emrDpvlziQzki&(=262PujKqhIY))sp$C zU1nru;N&S5*JP46JJH>$EwqoEEwf>zwBm+q9lw^PWnPEXMb#vD@FSV(Z(Ufl>z+4P z2q-Tuo9VK6TcbG`{o7t&b0#LCzOMe!(=(62ttqyVik_ZEq!I9w`@MYi%5|yZ z)P;1UQ|6<*Kv`4A(y}$zdx=F;Q`4!q4AyuDF}waUZ}_In548XWGW5Ew3g%9Je12pv zQMhUUZeWIb>qo(d4@mg17VepxeC6k7N}l@ueF*$;94deN*4Kd0)5=Fj|HCuygH*t! z$&QAq%~6~t-rMWj_j1@sTqR^l36(El1K)KHk{+anq14&jS=HJ)OfM%v#%C~D@{Cv{ zM(f0kiy7|bi%~SMP}Cyr^;j>*xcoA)YZ{OwnYCfE^!2we*M0joYfp1YA;6IDN|C`| z{5Vz7KXdd&wYA&d>)F25hl)ZsP$*&YEOViJs*(IzAmQNpiw)jX(Hv!9;Ebt9*#F#W z)dCPJ#u8|d5mwBkw@5> z&DTd0#>O{>KkgmS0%Z%7?hL)Cl$ZLQQ~u}>@y;FLMf99|B z5MSIe4h}WGZKo^qU%yhAQ|J<wNS(dz=wJS%n!kAMra%K(Qzz{(f zLRtM5Fib!|>5&hJw?_VzqS9oy&GI?Adjz@U($;6%4H;&PT%polIaF-F=XNz-N4fox z!d|a^mC0}E6sS>;#1`xz^r9L_v3`A$o?mVaQ=TB|Ogwz>0XQ6EEk zjIEwv$Td&T^rEctbbg*Q^0}AkFTekAyPH;Cdb`u`c7!o5a9Q#*!op;CJ>dcsPHJ-h z$aehr^k`G*neot2yFUGmLWEVX87DU7peB=xUgS(d{CS_Hr6uxKh=f#xwzpR9(xS|r z>*PsAzBp_v#{%M2EUI7VBFYloEBI&cmYrlWQ56y6wN`pvTN_r=_1ivFgnM~=kc*{+ ze!QD@-w|c7H7dFtLW6+&YR8{O!N~3Ai&N#IM>(G>0fJ;;#(sNb&0dhO(LX7!Lg>S~ z`5swU*LZn0Xl4C*7<;Bgf~tW+*O&;N)>wA`Smnrkv7KJ=Sb*RH105ab>#KR@L!aT= zJHm!w{kjUZDgT4yApgLFNP9|YLH0o7KSiZWm*U_J z(Az^$q4Tcr`R0-8@Puj?@(B|@ZU|6@)X)(*Bgce8{gmb-vMw%-2h$vSrk2RAKn>v? z`kYy7!DV~v;}KD57KRMN0;}oyk!%c{_I)Lq8V*m2^S2zFio<0d zmm{yXWBGCT2b=Oka=0d${=K5*@ z7Y_1SPrvmZc6v^XaG;|lYwhV_viUPH0T#kWL=uVA@r1>dfm=?R4rfGE=!7rEaE#m; z=!=VZUiZrn(V3_SDln;;oOL)8IZWP4%~!D~3&j>IaEA>KpTZ^g&4c^i56lEjOA=hI z{yV^s$cxO3@$6$Fi5Z`&J0>P#_zc8UX~-f?8za9{N~g4pcwhS*)175o*C*{OyV^8_ zFfwnSd)-sQVnmXvQKNE(+EY++WNWW`jY)mzfo$-GunnTQeAD{|9RE^o-1)C(2QjB( z@Zq8%pPZWFeOxYk51csUxjq`(TU*|_olt3=Ieh)CX3meFrDs3=+T8ay`TA*34iznW z+rr+jUoZGY@G=BtWZ4_UZhwie1~k^5*h4{BM>I`&8G5H~?xo!$<8h4^#Cg9r=U+d!d!x=eK!(^hG7Ln1(4z9d51KqiA^JS!zK=ekZMz?QJhn z?R&u)mZSTI8I@9NwRb1f#{_L`qEQ1VO}mRjl=5Qb#UDWjloSHI0fr!eJ|Y6C_f&qY zu2S9tqDMF%zTgT4rBP++O^(R3CY__JdYPmIsgtY-ICc3YX8k3+TlgXbG4KD|c~@8d@^$w2o98WN>#)Ue-aN?AZ}jE3RRM6m!h(cN?}6&w-z2Upz{REV5U9HQ z@RxlLIdonwEJ*&lZmvx++6(e5+tN|0>Z?fv_h|?T;E< ziGrq&b+h+MA4hduhGoJZ2n_=?E?nqw@GIsAXomDz-%3=VxqHm02Luyc3ySza2A}vI z8r`|lW18QMiOQGYxauISs3~#%GYSxi%Dd=j@hADH5Z;fy1c@LAv@PK?;ikWkm~r@U zc|V^Xv23*L{K~mHbK?K%V*G=yjt=ykoM=p=lfFT-f4}5v@wec?ch{JfimTQifWB$crP|dmcUan@Lt8cPzdu zn1j&`htP^Dno|s65T`S%KEZLki+CKLx3bc6EkfoCnlShE3z-;IK8+I#?-fO-`;w9jTw}F+1UX^y}C$fX|+A|uxnqMx&jX=rknV~J}Zh36b^iDIm`zPXm;O8nfu2#ysY6kY_;X}v^Lyft_*0$J)?Kxx)OkfNEE#vpY zuDeH_$z7}h&B_>N!o$L91s=iRilaNI;&)wiHKGDw3)TOy@iwm&w88v>;2uTjVO=JKlKGw&6o?nS8q-Hz0epgF$RFqen*9BH2xzz?QY68wq>ZM& z$5o%62hfPUc6ks~YrrtF_exjio~K6%!w4FFW^g%OC~ zeG-n367FSEau5jNk@Yc|!8Pch`uFNpZg`G|yE{q|ZkGhB#Jp>MdiKEn{inVDy+&s} zfK;fTqLqI;P?DYSh9(ZySG5#r=PEx%#PA>+hBM|`&g0$FbLf}u?PO7>La1K-6e_5xzxzOU%f?&KF+%Q`D`qke*x)s60jaYPK)gtZ}>N}Xo9=&0S zeE9G=e!7<(lW{k^JBH_=c0Zp%tPBaF8o}ZY4WE^;UVw(BWeEJNRx|1puU@{4KVyyI zb_pdEZ?5KnJb+v$=;^$1{I8fkNAHW&W!RO0em$Ki}8 zPs+Nw!~$sYle%ic#{76bv4mXv{@yREuc2*lGRAOe~U2s<|rvOvGqz z;jcRi zO$8Kk^b3vAMklj55k(^p%*)M98`E0Z+Gx~Xibz;*evh|Sn3<$Z~7awx$+jY*~{?fH;d9}l6 zM$660(#?_w$bR3LSm*KDZ0ZMfyrnp{ykp1mb8}Zlo2K~U!uE(k-^@{uw1I!_rjCxO zC@CX`ZHgy1`}qx%$*p?!_ZBt)DEV#`ap6E)m&L1>TrBfDCjR~{an97sjgrSbUs6yo zf!^W65kG81PM>STON9&yM@QPzeLIOYppc2GKb3M^noP%|4*Xp6sw;8NRO965<_1Ig zzSp*gAQ(XNO=1v1WFacNG;YNXG(Pc57E0-W$a4Dw*0|yx8IIO>LR@<|S8L z{ck3!-Wh7(nYUfu-!d~RF=*B=wAC31 zdGO;>SeMQ6gNsw>mElu8%6{0v{j2qi_C+nW!ILjYA94r=NIk8b?%@k~aDneZsN24r zP21~t$C}Phn0d=+nodsqy({{D*|M5LimGAwSTo`-?I*Oql11cfo=V9CxPK(y5BY8ps%GbVoNJZBT2+#hxv1fx-9bGTgv z1E|H=3pu(|{>|I0RbNApMi*VEjA=r`^ovbc4U7n5YN@fs&IfIJ7TGUqBe1Sw-y2V|erdTjX`=X5Xx%aS(&NG5?DMBV}a14tH$ll%p6Ewa>J_`b(`q)&Sne zTlP|WQ>q8wUj0**9mEpSG6otps`jjafWrVa&JGNdxmTh_j|{$Z#F&2f-^NPPK#TdH z)5(;kPrIK;NAb@V{4LAB>KZJsO!MM)WdrX)Dp*te3x9em1Q@)zaA0U<9embZ9c5f} zdEHDI^M5{`PdGcn70R@61m;d)3Rip%;D&4-bU4M(K;D96gm3|6Bo8*0hoPiUH8ae0 zeR=@?6sV>8`XYv16%@!Khtt!KZ!g{OVVoW(Aio{D)f)G!w%<%|flzt%^nC^rz)5*m|2T>7KB%m8L+TOS1HfGeYzCo{)h~96t!eX_{Y5fL!j;00 zyeHKQ7cwmWeM?2)xu}h6vyGiNa;!{!q|xe)*4$m0?Rg$6x1y{E4B(%mtp8do zWn)W45J;k-{b~)rH(CI)$*VCTql4CM&DQ(^Tr;PEU?ZUtqCRWunO|b4jULc{_xn&{ z1|r<-eiosENXGOFZ*HeE(jv@nrQ3(s4kO5#mJGn&m!Iqxl$G_~8quoIffQ!kdZJ0F zJk~1Q*WP}1HD#|rh6eo^0RdLHSq%6hhmXBw{w1mSkR!iu-fOIT2cdGm8Rc;T8yg$< zWh5KgTD+9;6qD&f^XfTy`2!TkqeOqwc^?tAJIwfYWpPpX3{vlxmXu<$s!S$OWTrqK z7?gclh|}%k)1jeHNFIkd?NlHxNonsqIMU0zfqk((!ofr1GxTV)Qdl$NnO z)Lw@hbXcf=Y!GWka&l6+LJtifei5zY<>gz*@jrc14s$bLPgOtG```0`(D5>O7*%=? z_{>2p5LV+PRxV_W#`4gbArJ_!eL9gh-7Hy=!DUr<@fdXS^b|)UeRp3mse+JZfThUZ zk_tKL=J`jdc5e)j69gW&3SXr8TsN~HIqbjWzUY$5whOD!Niq90CEkV;gWCOF)bJ|i zP|N^D2FxlCckEckI08%Dpjf%X;6ns;Fx3Xi4?4GeG%C=epooM;6SF6h>yeMpJKB`{ zrRF#?XVB0%nXQi)4S?tPB$|?ZzWp%oFJ9RHkb_1Z8zJ}<`1Y$E8;9pGk0eWb2^GD= zm~y-R;Vr}`-XCO+Dt-A9EM>m%MOdz-L`C5e(xxv!%X|K<7D?|70l5c&g=UuAw^1Q; znxA^_-Wvs05qdcz4qehI12%SNT^+V7?;T~M$D-u9#+{gfR_ulO42WMs*|D-wvosfW z+uSfXdlQ{;6oC}Aj)lFKbzG*}()SK%S|Xtn|I9u*tMaP7o@?-4)kxKusD!o7!4hIL{{9cS7N56b!gV_~O*kE;#sNzgi?Btc;TH)VB$C znA6T68-z7j_8yWovA|FS4q@1@vnxCq`wEKq5QW62Poet%uOA+QCh*f3vpl8kAzRb8 z-^|9*t`1}e8GS&2AU082&i`K*!6gpQ_d6KB+7-ehO6lAfYsfR-njZ-Rra1Y1LR>uN8n3RE z)hiuvemrXnDch@mOMTwFc>~S};R`snQ+&!7;OQ|h>^=2(3*3G!(juu&NAIboalRe! z4bFZ}^~Uk3DM$qJw>Me_h-BiR16*2s`X8hi@5xrKxJpUh@!XiYu|40I5Cb11DjB(B zDcFQC18k5;hsaUOPfz{oQ=5d_pNa>pJe~(dRySdF-5+jKAM8w6>L39`P zC{FF_2WgO*u}7~0K8MTZ82R&zjFOKZH}Ti31P3dB?AN&Jir_4EbT_=~okok(IYVgy z0oc{!53S*5Sb01GoCSn3?x58eY=$iaFP^)<)GyJqRgYknVTh~8b#--($sTzwVPQ(P&)+2=JH`s7iz92Ldfw!}Us-_H zRFDLJ5L`T7@`#WSVgu@ZHM;}>wmoeBmZ#tS`twZk?yL2G|JaW$!6MLmXNZt*Y5zeVAxV z-?{fO_=xigg;#51c5$UL203p$5LWX zs2~rITT|+uF{uX6^++8D63eGS^2pZ1X1gf zvwL#Pn$Cdd;a6<-Z)LLwy^()+LRck1#yb_R@(9=3)wLJmFk&J?P$ylS)7tCeiex#% z+fdDR(2rCNO!_PmJdWT5zD4x)_fJbvG1elVEElnApYl2IR^aMK^~CcP1CyT8V?m59 zTG}zNRbyvk+jNaxSVcgibnJZRz@#|S_H=a-TO;u%09_`ZVzKpRUfP;_sI0tr>F;3# zibkAGyKW)8|9DvG^_FXT*%~a}oAURsT`r-UwQ6)1fpWk%0k3>*;c7o_02jb$v!=q{ z-d^wdTK$ef$CH`g@Z9ILjv$7pu&_vUWZ5f0mIbukhvdYkPYagw_z-i{oDm6CV4=sn z5=wiK7^tg&>%oP+QFGYtjU;ovEQ@BYiLRoet-AUYoUk`u+vn-&Nqqw2Q5=;<3{Hzq zgZC%(OFRtwJ~rDA@PQe*ZQC?r)8IhF7nzG@S4?{YBTeH!&Ilx+Objm?qJ(hVI5{~{ z&vO6w?VP82XJIPgqOTpD8W^wzWGId2n!6>{FI_^c&@|!T#q|KQR~z~Z?1EPdKRsC?=mH-4Lw5B7PXA#Wph|?gtw=X{KSJ3Egm@af+W3=?A3n6dFuVf$eHE2@YwyJwQ-4a%%nh#f z__dO*@L<3QkFrR2@4ij?GPqGef{pU8B?T}X>AqXmXD82=(_!WQCr=cN){`V-$a6tK z`%^&qp>d9z)Px%XM~)w#elsAlH%Nhg>$%g9kiU+HIrpU^vU20NCMF zJE@_O)-=d4pMgE%=%GV>?QfdgXGZqTXZVEr8!`xeJK&pY7Cry5hhZ*zbpaS#!-q|j z#d0I9jzNh)BGbuZ+gt8%UR|<0`@Zk*lM93IZgh;5HoV=>7kT)hQioN8&roWvChr@a z9vd+X`Mg#p6FS@0RokYk_d69~D%JGf#2zH+4l8y=yVKWb%AZ`=8{CVw!97F}2$j4l zqNi<=Wmz7au0T{!=L)>wYx`O)zAeUYle~+-%X40TbLZxK%Yrs+sFs=Q9;<8N4BxD< zO8I16c+sDXlMqT)cs4EL*)vJIUj{6sceWmbU;1F~1G)48&#AJogAKp>&!RbrRY*o_ z3{j?ZLN<_?6JpWkp75PShRR(buSW} z0Qc(^PW81T%exM8B>2zLoW#!axLZ?EQNaFpX8sDYm~`LR*<$o(ltay0n4dojvjtoX z>T$U7926AXS$!E?QSe~KFcS@CmbyoZ=4Ul)ec2}%MOAH!#(B}H6^bovz<~kM+;rk)6pTL%(JyMw6pt&Rt~-tcr<9qZl3CZ zV4?lnx$|Qk%TA*2MxS-84*hkCw^;CG<~B&fq>(D@iHG!2|MI&b=gy~-Ut29>TMeiT z!%%~o_L10yqxcl?%JikHSRY$Pp>h z_!R~|x-B@x4+Q|07bJ7z>8%&_hAom5^A43Jaw5N^4(z-zD^OBZhvzvtQHc^HTQ{}? zT_gPAo<5~y3~zu3`yiVfn}DAoA`lt|1ez95u1-LtSWEHxm2Y}=o*Vql2)O$@dy70v zpmCuA%tmPqcer*pHLcHIqU@97b3vKZgmV5&k)Oy(D(kKa3;PMacv6z~!Gj=?s$t8y zE_e)N(F>g6d-m+nD{|VvTJfCeo9Qe3cL4E^xy?Vtx`Kd+`)zG4s-gY>VqEXh_6>ZI z6su@?`Fucy;17p~heJ~S3gB7YUd)7b<0b%BgFoES(IFVc%dltiz;^$pwzgd7u>q9w zj3O3bpMLuI@zBwuhq=Y7`u@VI?P&`m=IYrxZ=N@ridwoMcB|!ECtSiIbxshv)``Oz z7i&LoR)rD*$AGPX;l;qf7$_)Ere1z+k)oAZUmu63WWH;uzYFFW{^RG$a(;OQb4ZxpVy~-PUYx!6eG_#FJF3cSd7_kc^)6que!@07v`2AWm`depuOw7I(r`+T-{6mF{>%{~Yjs`!K2*Y4S{a(={@hF=Byy z7VeF_^mu~7BDvyKnvEZm)G3BmRxw;Kikbjc$rSA0hKBCd<@@X;(2dvtwYuKI$L^b@ z^X5TVn1bq8;0Ui?zh?0b3x_o#+nmQb|8f<0v}QB|d2Go#*Va}~OziCJ#FF`N+DDo5 z3Y*-W60hYUbjZZSm6esvyTZWSN12B?PfJG!5G3-ehJimrLq=I%(?h$HbH15A&(k_$ zA+q@K;Tf>?C7DHec=qwE?Lruk?9<*%AUj;U1|fY@cj}KH=KX;f$3e*npV<)j&mjvO zv$NqL^G&nD`>vNVXeXnyT5wBNNJay+`)&nTPSq1|&TP?h_ZfVw&ST32OAENOn%Ro) zH<>ISeGjQ6?B_lH%r359CqrfsS~x|-G$D)wiQ$2_{r&L>3k2r^jjCm;wAEqh?iGVb zx9z*B(WlQX&Z1h`Exprj0yLX%zu%!)0(p@6LQXq#4qHk=dN z$4bY$Y3e?Ry!a{?c)b%ISK!DpU)b=wzn+m2-F}{%hI$FD!hSo4(}qlel>wwMrK`X_ z>rJjOfUAo3FDjYAuSu9q@d68pI(ub&+%($jtJnx1ysu%!&8DhQ^~8WZu#!`e%u6rS z6~-Y?(!X+b;N{iB0G4?o50l6oieH35JCkCb9d97S%b_UKEt0mhvML#C1dYRaYz5KB z&c;4#$KEari-Uw6)h4+>I?r;3BikYIe8JV)9boLA%wMdfeNje|D)3fUrz1bj%}vhF zuO6O;KTB_Q2!^VX-`AD%-(rb9>#wx?uggitH#$H-;p!CU>?JX0C#+JW^U441ct!~? zO@m1;H1Mo+0cii+rhXe@8s+yCGUIKjySmMq!Bs?1u=HweRS`H3&upF6E0txxcd53_P4W&i*pJH+?^Lce!SV>4x8fp9vc$1VSbw!(^&@x zVM;Xt3%II^3aiegA*7~mpG;k8fjR1+-EkB_Xvpo4=eI!^5Pd}3i-9?7Z@;1q(~jUV z3|c~}VF`>fba~km6-l<}Q}t)n%>NK8m%^Y-E&_v}yxebnPsiHsDlB}TO|x*|#1oFg z9Qt%fuO%+?&ImQ|YUi4Gg16aWb;T_}?mh63Q@3yDn?`@Ej{}BeetisMA2#3M{Sxre zMNliOHf8vZ96{PJWo4ay(vr0;?$nfKdx@@yrIzQVOEak|N2{v2FabjMgt@b{>1>Ys zyoVmmNsO6eM2gjQJTgj3J`Fm6MU9I|Rewf4c@hSx6&B9px)uMzb>lCg)_-i~YpAKN z?x6lv!{o0fuP5eH`Z-39aB6IAcl&i(8nFfE_B=^Z5oSoD^o=3jZ>y)k3=g<-2Nr>)f)g1rm)!NuLVP$x`&Qw?6)c7-}l{Z*Ys*V+$Z~ku*Y1=z=@s* zL#}<-&&7(p#$NX7)xB4*Xrfbrn*)0GFK1@@;ylj3ma|BZyoegnX2Ai_Ze{VGI&qEg zbi>6NOYohL%|=W_e*p0jC@DUBR=zdw1*w~MZ~7kaH2srHIyKcM`=)*a{QLgLskoB` zzS+#@yuH009XI5*TyS=t7bshm4XR(dSscy+R5lP&>pV54|NOpG5x+B0NJY8B- z?f1g;;j?KcvqcdsgEo-W0lW_czhqwG+Ig30`za{p6q0vu*h zpzZmuA?Y^rPj4P-4DJztc3E_wUc10~EX#AzK!cb6US39N5F`GGUj{N_L z`@CUG{Vy_W!oovCV_S*n>^#m{x!gK%}?JQu&ID`lPy@ocMdXrE96Js}r-D181+n?kKkv5MCF8gnUy&n+6R^aKM2o-N9Ed zyE%Rz(5LK{!*q5cF-=WP0DCykDz8=^T`84ifdbP)Btt3Xi@75{iqhqYkkV2RKj4dn z_6jvy^8Phwuj(nS3Q~ukaPvs&=X$9n2j9+qEEkIeA z9_oW0h5s-$rHqSOcKfy{Mh_)uHbO)F;B>#XYM)SUCO&@Qbu5ZQ zz?3Nv$#MJFHR|3AQ#GvnVa2DHjXa>uJ2W8U&TsSSeN;wDX&J^-jzWV(A+T3eJh^|L zbW;{I135NZ7!}JQG5X2Pq^Ghh80vzOfFV4JDwa)zbJTp1h`P)=&%IGJT6r4`W$RjW zb#*12mclviLRA?hbnSW`E%+mlbEa|+jrT0UW>uPl17wkV3L}&Yb$NepitaHG_4n^% zno{dEUt3(os2aIV#hx}yYhFADu`R=d$#s$*c3?*@|5ZLwCV->|X|#NJy`-e~K)&jt zkD)(J$*lMI{rM&$FyNh1A1{SMODSD_8vXIe;`;6w;tmb(G54cz{-?2$^epT~V_N6Y z0pp%9YVw^V?taB+99b(&rqMI=ZyEdy8ASeuQnuLcyFyV7?5F6;gvmH4<95z+Gdbk^g9?C1)NPg%v0zHephs=%<57u zJ{5moU)X(~#+0#aU~*=98mp}=2>pFowom#P%XuLTSSiWm+;p90mX>G=TSC01!k<5n z#ULLe#QWRnwX_#{rb%WT+WLb$D*Q+mr*}1DG9#3lOK5g?Bddjth+m76R16= z(fA*qjDuAC5z|vsZzn%lD;y_Me!;yR$wG1%78bcp3kFu=In9z|W43#cItZL-Tsxtm zw$6q@XDl}9gS*~zN97tELwKiV^mQ~8L6najB*N$ahYNtRKVAK~R$fGHpT|K?rjR># zXwI5O)b3VF2}>O;D_ZL#@e50Cs-7V{zf>C~#0BIQ8nu_3`27sAA(?bbJ_1qnW?lOpQ9Weq4u!a^WX~`umHnUQNM=tmk11v}3;= z2&}Hqc%T=7sv(@~9Htmx0Zz}(1}Vi7?j->vTY`-Ewbqfc2xN%a{yy*JJR7;SeRbU5 z8PoJD$%nopy=HNytrYptDJf=h@Zv&?@<{akW`fjQ1Q2+D$x<4aO$LNXlk zvKt54V1d+Om64Hg-MrAurO@?Tb~^gw)NRUF$(RAqSUYn4PBj`A{VUJ zjt>B3KRl|#62NxmOd$S@{jnDA6xdg)vrRdyqPXKzoWvvp z+kej4^z{$_{yX6qPAS;aju#Ve71*ambKC`YFoS}I*koOzCZlg%jJ9fwtKPFEf!kx8chL&jSF;@4sbSrYqZ!WqmmSEz<78D zx6{zjNQe9jU&!@W7@c;5??$oS*!>x}2E_4w8JL7sp)ctKHKg8%85%DPiIih=9euOs z$%V^aDx1a%nJ;I$pkz7u$vRI9IoX$Vb&o$;o*yU`HMVr z!L^&>6Qo1M5?M=&b}5YGCW&+BT?~E0!ooICmC3BWY3{Q-M7ISg&|y!idqGbY(?Kc% zdhJJ#nD*|Sui?U=)64h1EDM5y8T=@57L(x|wp}p`5F(E|&U>6NGP(fioR=b-JMv?9L7N-_Ae2|L8J|P`(4gZL0du{0`z8~pyl?!*ge$lUcVkGz*2QD)-ePhSn8gJ7#iY5*W=$r)`czsAr`LyZl=eA-2=29X8mdYsr(kkog{{ZGh*O0tLCTyV_k!1+bfo@D$%VZjOLdLGh2cjiyFWjTc8NzbfE=qXK3EuB8-E3cjh2qid+5`EhAjZ9 z6`~LHocf&zhZNuYI(+*1qph%shpdMr2MzaVM*<8$9`gLE+*8`nV}m&gB6-+-v7EB? zia!~ff6uuBZP{Alj8x2{M+hX2fBEu@^?X%X_*rf`1%-X^qyVqwg=$7~W#vI?s+Ds8 z$=Q)sQiQkVEtqpx(2vZGa?L=0ni>`mu5sAUF0237w2LE!zi4j@v$`!g!?m%@sG~t3U z*Yn(h3`rOv;`!<_&%;b{&>@slO)8uK3u6{OKA7K)wm~YEe?6}-Hn#oq=NAzX5!S0& zW#NaVz1{~NwL->dC4X$HS!Asvx*8bRI>L65w!pSm>+J0_ab)+rwZpAl~xC2uXq9*P2G225mW%q`SlT+jo;YI5Rh{a{nbn^Ij7!z$DD5Sc{ zA}$`0YK9T_aM@Pq< zcR3Jy4Kffh(R-=4I6gl9oJ@yw!Riym%R<*aaVoxi`qai@?a+DmT?EH2vgE?bGz^Cf46Rp%m z<-%*wLgYH~Ecqw+W3*pecUAF5$MUlt!l#z>6r|hE#>Sf@9&RzXvfaPWeOJPPzosINdymbVs(RUW2Y?4-Riulse7QiXSYmZ`znEn zA9CX_=UR=nyCPZ$`)yfioJx#dtkAXi(;Pt5J*3AVUIiPDx#I)nH0BoxGNl59j+qzS zXnAN(GWfCkBCZ2PJd~^}_ch=zlB4NM+V|E&ghYgSF?DH*+1J+jcWtX{=7dORJ3`cJ z>9fNwx&&Jf{kO3%VHz5C2*5*uB#TSfix>P9^UY)Os^G4JOLQiq*(^^SHc9lUsG<%Y ztUURVH0VGJhC=n_^mH?151P^4tsvrQyFoIy5QhJV4=c)V*bzf)1=2KdaG=;QadUIq zc!Gqe_42vKTUJlBN_I|!XlWs4v8-9uRaFu52y#hiC_F3>E*~AeZ>-~%EN=wlRZP`+T9z&a(PkAC$AC@O zU$r#vMGy`MgBPEXqEo?~=Q^0;3tKO)G;~y2yvsga$6T~PUV@7_KOdi$P4a1uLdRhf z3|VZnWXcC7|Fq4{-xmUB=m-+jZ2JKPYiM4$7^1q`U2`?}vUL~V)zrcb0x1cn!;B-++h=b>9s)Mfa>{mGC)@A72_XRe^fl-`}=};k+CX=?daZ>!CssR*{Gc{_-Wsz2QpERFMw6Y+%d;jnRr)KpFjZ|6C|^O1r$57nEPY2gGnhj#zn*lF ze514OUm@tnV88js**z2Bg_W}TQd1?KP20M8bER#&>0A3bo0U72a56&m4MwjE8eNhcpC<*t++^06lBx%x94^4NV) zNd2+{Y2hosC&+53PocJ&a+5O2-OCCwP-{~Yg1_PQW!MuG>egg%4`ep&SEe<$Hf+s! zhVN^^x&%`Vq?e90Aw#}aCcKx$#b;6?MUbabQdA_t%j*F;9E{tM02zk5njnTGoKUJXJ+bud!J^uaJ}9l)okkiN?mB# z{?lRKi=4q^i9L25tP?AwiIAV>=MTU&TA#N%PALr8G95j9*v#4*M%IO1%Rf+&V-Ub6>I`QV2pQlR zfq3JoK{d>nUzJn(*LRP6fH#J|xqu5!Xb|0pI8pb}wiDT+zo%8pv`2`I9Ew_*m%so< zpHKuAkun_SjMb^gQ5W|2o^mMzG zv$uCbqf2$qoSnFugM+f1+!Khc_l@yy-Tdf}Zrs^ZW@ZyMo$L&1|94Qd+Kyb@IsSg@ zQ5Y56ZY3gP6tV8`0V=M0B8W%^llnq%yAaIDRDCF5XmIclx0ut<3W5B#X-x{&2-=A8 zFCd{+cdO$G{4fPpNX9M<9Ax$nY}cmUPC~KMZ0>rmWvz!+GpWnOiPes9uzi2;n-epd zsZM%RUPW@}%5Of(Hx$aihW{h_$p2S_lo8q@bT7}eGEoFlpJ4G_^3p$b%AG=MR8`*e zkOu_}a+igV9oy~&T?!=m92{Rw--5!2Qqp6II!_B@wq-9F`)99Ti=c)}9i(*!t%dR> zc~^mNolDQ{NCXbGTZx{4m;~J@@}-lLdwWAxX^Hp?R6(F+m|eYE*|oYd+MOtwaFl|F zxw%yVZ9{4^@J~uQRkV2H*sNzLVXmmCXlQu#fcxxThDt}i?W=WlGtD#2qt8a4Juj4_ z9h%}Kbr|qd;h3B2tWb;{eh~Ak#LL>l`X?io?asEcjw%s`nC(07Z0B(x?Hnq$(*I+= zI9j(_{(U&_oiJm~qk&m7xboKtu}jBZ>wf^!Qn5*{S>5Owa74J_{^|Qc0(vCYU(;?d ze(*D7+I}uW1rbeP43E9dtue`k#&3;ucPj2QNlx<-=;NEIseDP$VobO&_(A%W-*&rK zET&#jNvY9192HWkO7;esL;pT5g2LV+OmBb9F21&2eg4+tC>ail$ai*VeYxpnZW`{u zCH0Y_%v6j=Wme~h<|nVwLMD}|r(0;#lZ0-HNyh6{PEJpj+`j?PyJBnQT{q6J#rrgH zDL;A?5dp19iHaJX{6+PVGs+aZQ-~bNR0OZnfS}+Et2Tm^_jrZhzYmxEBlPwj9!Uzx*faz0+<^|q%lq-m zm$&rT*FGDA2LdWEbydCak`leZ;KxsMiU^lT%*^7Bt1&(o;{V+B-DNi`&o5qBqUxpu z5G@1hO=PA%iw7j3&;;#-JGt?N<8U>7plhAgrW>{=RMo-Q>+Y5{N)nNhqBMkXC4-R{ zC7|MW-iw9B#ZR&6#~7x1_phy)l8`Dl;(2H1NF;X0gMUI^aup%Y7&pU|60aUdR z0S6Hy^B;d++is_&EYB{DE5$Uw(Q5y`DqDImyJZnRZ(nL}P>uUk8<3!{8Cq^cggELrfzz?@6nR#P-(`C@T$YTd6*C4t9FVYL`LR!jI)4U&_$>BA0$^`V$ z6b2GpVSoQ-fD2W%Oo_U_{vNFZobM?AsQc1AGb&kCZU?6^ZVp!;-Jqui8v+)R_6M+) z4inZf9N6g7^EuIHdRjlGVyF1~`aZkm->1%j84(ti;Jp%wrM8v+!M*4ys>NGt$mOMb zx>V!Y-o;f$IUv-Qq?568HD^pGx>J2-3J$ewd(Cv*?rC1$2G%Dn!_srzy3kL+3ADv$ zqk%G*i|}=7SE`3O;*&FKK9`P(DgU?0KbjDOLuLOY`#Nv;E^r zDL-#x|41oi-xvd7?!;Z4*)zAwlc`opX7!lHG%5d;py0zQyY>yC{lC+|Zt4GWBWM3R zEG!85?@8tP-&x}5e+iQ|2mU)jT>LMe^8fWE`Kv~hE??e-oaMN){#|3Ih^~^OkaPN+ zI2ZP7fBqZW-Yb}u;Krh!>e5{s4-p7U20^-1FW}2nA(vU(_hc6#yXBhjzKxqUiCDUU z($O*Hz*N0;Ynp<5C6i=9mr>5=+c0H^Dk(E__y3GQttxQ@fOD6`jezwD7t(tG4hp*> z@8AE>XNLec{W9rgQNx_?0D&M#K&>O1xrW^n2nAWVvn2A(8{P<8>+5r;1)U?~iSYy& zoSe#!9wg|??de3SqJ>CIrBSb#ZAUUPg$E|#gnm5)e%evW3aTG0L>jveWL5V4g*A1f zDU7T0y|4Y}1~66$uOq@$-+8R_xb4qhXeVIj~ZJ_@-kNl#mCJW6501lzslzt@Lf%H0G9GRLC7UL4v@zaN#S~-||XKh|*f= zMCgtevI6Jl4u@iH>pc>}puV-V`1i_@Z#nhXwU$xKuAQP*=H?tV1o=<~h3w06s$VrG z{SfgDhYREce)vF4Xh;w?3m_*h{IT}N>4S0H&&pZ=npMVv^(I09#?;|&wKt}|HQzeF zx)+l^AdU*q98#?dtR#m$(aKcKIK~_@kgETmnyX+>&^4-e1O8^h`@%TtO+c&1%vkBn z88x1Z7t-r2L|A=sU+$0)){Q)c&k%sXs7(};F74MIU)$R;XDumMw=ucY8!Godc=s37 znp!ds2O`V#^yvbJK_g&wcrN)O-MeL7RaAD9zrHdPN!}m|nQSdyZ-FX*>!qv(CS*Y+R^dGg%;3o5Mgr?j&0ihDQQhS(UOy;US%_F77F zzhnHAW5uR{p@|y)w{RJl+E_k}lLd7yiZa~sBa!}?vm(7c-nXjD+>%r-9?S$v1M?4BfACj933O!Z3~s`mQaqU2M=~0NRW+$ zp?Z3=t#pF5vGK2>5at_2EU?_>*co*19t;u~6JykAwrxW+Z1KyNNyWu+%;(pppEif9 z>~}xD4rN|bS_W1)9b*POb&H%VcQC`v)NT1ZI$KOOuy$SNOM-)6Gv7$##6@~@bP0b%Vr5+ihtIeh+NUXS5$gV)TJgdH=lC{@L~ z7St?=PH^bmLbH(_^ZPGPYPQ@~N@IL$)6@P`V-Y=BetuE@Y=%Z6)_3y0#$iXdV!l@u z79##m6DJ29PKtM&H?8?_XL+c3A*ORHp$kSmM__)zW^0-#$996)IR8vxmv=8cdSW@Y zgLkqs4cv!?`q!5A>Kt?ZI)wR9w3bR&>ExMZyg>bMealW|a1V)oF{0ieV4d9B)}~EM z#_y(+m&cCn{9${vu$i5gm#V#eFQDDp+F6kI{Wy_SDp9bW@{S0ypJ%z(*}RDb<9Gjl zOUT@g9lO{I($EzU7J+V!7WxAZ!t%y8iEX8K#T}Tz^gc{%z`025RLg7-M&>kSP~kaLyy71plAa zH|g5tK4!VyU&y}yIiih#i2IU?$4hIBmzomvo@EqCb_!6=&2BwPHPz(|^sre&A26=c zxrX~nS7|nuTZlx}_k(WS+^oBA>^J4bZ9*t|4)+^~mRXuSH~XgzFv;dykW(of30rGb zYyv5&koX>_A{fS2NvzSI+S?4GY$*R4`{4g!J@$WVd4wX1f(UzP4^?lue&w{PDbtig{S z*BiG2dPo?APdP3XOs8TNmJlj+Frq(fNQW-P*(OMnaYHbmH;k z$KwefS@4^0ts+GUmIVgr9$5U)_(?cwwa*1*68Ij*};QznxjxULPk>`o#FI z4)dozyVGIt9Mjd^56=p5@0Ip~ittc@vf*int2>0(olj>|I#Ww}4>t9PjTm_cEO%hO ze2t$$A=&n4MGgGgnYN2cN;3Vc8E=gFpz@PrqfIzqB0Piy8g%vjFzEt6nr=&{m%AEB zZT0)!!Ba(!?azpX_v*4UZZJcI$E*RvYm3(P2wnmm)~$Hu<3nc7@coR8;2zP!i@R1| z+FEdLwL}$Tj@A)8q2}fbUs7si=6@xBK6&t9AO8#fV&4Uf8B(`S*!pYvN`?O#Sv98jxUUW=0sW248{s6@#Dd zn+r%@Iq-uwxVNWg3r#sfW>~sQX9^koZu=kR4iIFRa@c%=q?Gb;Y!-r|Fpg}-Om&`e zek9f&3fSj(r_8|D|1j8SroM?2+;mF5_w}+DQ>%alYH1ao=f>we!f3rzZl1^HD;!-g z5brJxZ6yF$92W;1k0&%-6N$-c1KS%&vaz5pBM%ub$V0cKr~^7=>w{iXeeC<0Uw>)+ zkq4z1u((SxlBk4XKvvYjR~TDwaxPlZrn#K6zYG<6Edr!u69j5yTIYHec0c|8q`?mgh zjmWi(l$5*MV`_}0$KUzjIxR#ZlRkvfg81O-IIUR7UTeTVP!}cPKC@>+jEUWUhX%8> zj$-w$fbt&VZ8l$&w0j0SVQiX~<__*G-Wh%1ahEqJjS&CHAI0m-9aI0>eKr^a^96hx zFXfKoz0yKtQ~CYs-puE`GIqc4O^@9hfKi7x`oMPk<0p856f`$;iCV98S52_{^3$9- zeOjmJ^}X7@jZ_o?F+MZwV*7RjSwv~FbxW!e$IFqCLl-Y{4gP)pTv0Hp-GnhKqX@-6 zc2Rm>%_mLUivNC0_`PKp*I6%=Q*5Es)dC3(&PZ5 z?+xB7WQ*s8FaIJCNrILPH@0&!%e;O)P?Ottm95IG?G1~~1=&<`Y`zRMRIC+7IUhfY z(C>-FhZ0#UPpZKBKPNT)Tq_gMomIXBiO2%Q=Z&^Me;131iI;Qx5!~F1J^;n_7^Sk# z)SexWJw7QwbCP)IAryO0(OErHr^SEnwPp9c^jtH~L?vBmch5w@`kS(-cglCb*<4%p zR5DU>*^|Fz=^l;rmxu!yKlJ|nx$uM~tc=iL&~ckFT}3_#?AnsJ^TbCRPbFxUcpUVs z+^|&%yN}V8W_V5_{sPlvMCoZ+draP z$W+eH8J?of^UoHKlSGta4rv)KHd`XHO3PSO23$mQ)?+h1zZ4t0giVl(`16N03Ls%I zG0+c?o;@thKY806elNJVz;A!FOEZV zE6aXqJR1ezYZt|ZT9d-klJySuh(<10L2 zkV?SR6G+jW+CKW-DyZ95?(G!<>#54b9#;-B?zuQ|RlSlO<)1;A03}3?8p0kPW98$+3LczxyD9tV{{0)h5G8YE z@4tt%tbo8hTc~ekXbgi61K(VP62XmK+I=P#UYS)@88Atf)CrA`Z)|CiF#BT691=qM zVje!X#Gl_57Zw&k0^MN9`LFjHqTO9`EOj&C1V23-l@MR=%g-FbMHfK4WolXgTfHDs zL?|+V1+}%c!Q?xsY7A1prKKa7ym0ta385@IAJZx^o$Bs2?SzdtTB&6D2JkB8x zTXL+VD-(sqKY_ixwy)k>PCyZAV_;w(F@HrlvAv3(3hl`6#N1;E~40IZoVgL&m=R86n!ovJO!osrG zLmo2ELo|U{d$AO!p*+jB2;})bTH4?8GMqdL+jV;^IkrwN*8z9fZ>yg z{qM^k&_$FP`1xlZ@LpnFmN zP6`T`Is^uu0m&M98Mti)Nk;lcN%X8(_qTRXvsU!|<)^9XvkT+Uj-S_VOv=Kwj zRizQCsa{PR$&jYO&%=&WV=+|+Br8pF8%y^G(SS=Ll*oAanadEA5bvH@MRskJR|G=JY zG&DHh;?BZL&$i?{|ysC-`ChCZf&r zuyNX!32J>fqSYAd#vn6$eYNdIAKK>>45nkMZI-0|;SerVQb0Tz8mF+C8Ju1EA&a?&TdiD*4EY5 zuJ4`Lx%1Uw4e3Ym@s~Bl@{)`WNQFPDG4|_xj8`t|z@aRuGcnhD4oMeb9N2UQckD~% zJE8hDv-%v2vdbPm;11a0>DB_JS!_&9Le%jSyb*Z3TmLxWsnL@d+{^0Q3o9}XMZeDA zhJk#oBhm>wSigRE0SUCK>e;Sc;YLPZEiI3LNn?_WYz#2op=SpMGddc>w`cL>F2)SK zVhZ+_1++idnU_*g%&{``9w$6#G<~A~3I?jUEp|UE6kT06pf5Gatr>KHqZ53eJjct5 zTH;;*NU9fg^iR8iH0ZrNyjn2&H?n0P^XrA>638GCe6%CqMd^OiV3K}N)6sr2WlkY> zb{M*8T#OqT8v0OMYmL~WVSRn(Jkf7?bX)r17fVXg^IksSz;QNh5}Aj9#bJKyOI}BQ znwgpR)bvNnnLYZhSErPsiHT4YAot8wvU7*D%fPRiURc%vDEnLMUEDioJ$v&rEK|hn z`(q&#{_lKsX!@!>RN#78t`FJa`6AfEAaRmGL zc#pEI#B{7o4^9`t^OrvG;(3bN8+3|NvqvRmk40lta9HD3!sg1)P?>WQDI?2G2`d*g z#U5rgeft*B>vG~mV!42k@IIttUb}WmQ&SWCWdt;2d9StdgwgK>nN-Focnz$3WnGi5#(Y;gNG&|0Z%|gueVv0iw3zOKOIvtu#xba z)RB4SQ}*FwG=gPAn5AG%52_h#b)_7KrnnM3;0(}$IGd{~Xe_ao;hev}86L*^z@5B@+dMd z`5BbMYq-N}Rwre=5li>1+5C#pS5akx)y`EF>(!W%&SIgX**EkuuC-+C@0vQ8n36IN z03H-(KJ6JKRA+ZFm(_T? z!D<*sO@3D=%uq3zLw@vN7$9)8dY^~qb=r0vta-OMRtn`WE(jh8H%ah@1x>2+wPkJO ziD2o2uPO!|N+v(WpdUx84%nTRte1^0@5f31?O&P^->n9&ui2MhOG{*5xN@Q^TN%mC zoT8^r#5C~c`aU}OBU-P7;bNxOyOT1a?CbdxcECOkAK-l(7kW8#H%vMLBuZN%V79mnc8~<7Q+u zolLI!t@c%;A!Lnk`f*_LTHT|#_;^L{-GhUJd`G)lKHJ=;ENi8sT;?!>2eH5uUoPMG zF=sL4El+wL=2d>-wOkGgF360aRvapD*iG4I-yM0c&eQx|M=|poe^ebh`Owhph&!RD zIlvbtjXOIzp$7!rl9`z~3z314P+N%LV#@eXD1_Ji0u+~cbPi}V!U!Y%uP~U1#7wyr zR~n_d#~~;X&tJEJ_wU`b@6i&H6JflI9?n>BXxc5t@{u&=32=8rS>j_Kj8R99rcs{O zJ%#c}fit_er06h@Iu$*?6nIvY?nlX*N&xr>Q#H-TVicq?DqT|-ViEGid6qW}=ZRXSI)I=Uq0oB#xbj$aMQNo6R@JGw({q1RdvY8sk1nD($@)Hz}k5-juzu z!on{sEXK23aAFBP4_PglQvdo!+N{KfP}Z=IA22ccS27)h=|vhA&Lo0RI_ z(Xp}QGvMlgSfS1X+78YmQ{kcM!tTj3{b3Z7%a+uYo*k=got-lkyBJ+1SDMbPJ}oGyFcw^zZ#W9VTzqHQKFS^H z{)QPV;hpDCzJmmr#nw`prE&J!h|JG}4zQC785&aSDzT;fT)TgjJ(mH25X3@Exgc-t z#RTtla>-0Ldf9v}?;xFm`;cne*|o0E_ZHyJiL?vy zNLyS@Z05X84|2@vfQ1x8+;r)7JOttM9}gcbcQT_~ zK*2hcK@8qg=!<4soQfu0N`ABkmG^v>L4U%`wBX&L);+z37Ff~r!|h^!kyWI6UoA+@*OUjqykBwY1Y5JV5THJr&R_VvuoDmJqRSjY9TkUw+(;b%gxj zB<|9#)f%ptko^)n={a4d8mlo%5$-%e!ScG}sR0qsQg1<+i;MK~R5*65boH63rUuS~ zDfgV!*WT&uI}!__gyI2)6s^*zdd`IefbB?SQqa+P+xDkqV$_22bA*-+;WyUJ1$*W* z-dw{8J@O5R|Isx4Z%y+*eE+ka|EdxMcAHn4hCwHp0g^lCQ6dm%$aGf@zUPM!om&GZ zazgHX&(=wYO;X}Duo4jr zU#!>l+2-oV=s&4ldrTGII?XqBjvyM3C)|{MXO6u1Dv)}RlXit(;l48GVV-ErQ7|MQ zon0Io%KHjp{;?EZ=#exBZ)x}AiOFWPB+!q7?=C-yX z`+;j~qf5|DU`UG3GQ8${VkR=Rsn@PoX7DpHfzNm<##C}}42RJ<%@L`z?7D=kwuFbNl2 z)j$5&AgB$oy>%3=slo~4J_1hY@wiFjV_l`$6rveE-=rjv@ED;Tc=?hOvleL46VD@# zF|g93!%2(@_Yh+tY(jhxjxhK|DOaibn6I@5iRaxUnUfpA+I$hqVzbfbCh0x@NVJ;R zmfP_IKP@x{07?oEWjq_%jfeUBqM%?9WqNF5SlnSxpk2G@#Dup#J@J{y3O~k zB9@Sth#oRwWol1OPBi$W3+!ua6LXNxN1TMj(_xaXe_gDsyu7>;$%z#d3e_9QrLs*e zPtvXlMk$9q!PG~3+2PEYGrQzf0W_5^{|N+1R;10wq@Q}D5BzqvGjStb{Y+#QQpbs` zMI9@jBx0cI;|`D`))@c2m~rWvu`#Sa-PD(HUZOjmp7%H>J+JKK1jVl$v3TlBf)3xT z_i~H1#cM;L!bX)J;o1Lr9mZKjPJapz3!dj%nYk6wLHu<_0-_>%DQA|vR^mb_$w zy#+RFv(d8q!uaVo1$%`X_wctPKsS*xwL~AXckQj-$ljYzeZvoq*LOxY@f7SieDT$bR5FN(n4aI_YY}@uyb6pT;)^iIe%HbickbHtI z6hKY&0q=#p7CnFty>@SKhXVpqL+;%JPY<*DOV@!vo+8ba`Rv|aeWzRiE`ZztCG? zSGH+v<1l{2Q@ta95t1ozK$L&-5wPmjSyPYM1@tcvWYh{!a!J&xdqxu!= z0WLi_$)FShf|GGU{<&_^+2p%N`S@Iyr%RjC;9&&RcfXX|Y2JwE+8Pn}A3GLFK|S}z zrU&7YAK61BIe~`!cmj+cDBmG9J6LhUIPSXnGfZEkex*J!R=nDG6HVL9>}+I2gesle zpS)7-O!}e@>8nbg9vphZ7kPblbpN$aUqANsAlv?|ii-A|zhzLHB}kOi!-59vD^N@@ zkg0Dt${(Y$W`CuzFGxS=sJMM9_+iO1Qzu*hGD!%mAt*qq1AKiH16S=eX%ue057a(hC;{#|pszl8aOigW^{nPwsR(Tjk&fHK*!Wuwo^QSbRuhzwxXk*-d^ zckjc{&^(N-rl&PfjW$sV=+A>q$6zg66Lyv7qA{uvtxO=l?Js&7QM2OEMzQ@x1s0J| z;H&nA0+KKP*DYe2Z+x$mU_eg1!?A%9{sVL$uaw}mpy=%l%L2H116zLbM0#-~WblU$ z-;QcqXc2lR26qNlGBF)I7Y0*tz>D8mXIvyH%*R}y1F4lL|7R8PC{gTe?dpQuP?RRiq(1LdkbZo4kQgQQ+qB9MxapFX+v(} z^mNNAGh+rA187CTk=cc$h_kW0B%;@JhCYigM8VFZ5Lpf&rzI>p8iz#Q4~{pI9w3QY z<-50J{c(_BXP-f!UTA3O=PIPvq1?Crv&JhR+*s_uMu!iqAwCYBHLEXBC}89}sZWeK z0wW?)og&gw)6&mW21GFU#njVhG?S0E_>hvg?Y=IK4S)J{mH&}guo_+8M1jw3>4XrD z^+fQL2Y#sW)36ga%ESChNSJ`3nTY;1+eA!@5L@0bu!TzJ1q@C z-)|%(xwx#C7yNhae8m=Oiioos;|p|svx|s_p#)NF_usX9x2~2}#KU6(N3&TT5im>x zmMVNqcbnyEdYadR*jSIaw0{r$yJJ;zTM1WTs5*=&1B6n$kK}Nn1;VO>XWx5-cEv$r z;EaLAY?t@I522I`gPHnOMgo|PZ1ma7n6a52hQx{I!H)LHm|*ec9|=74flmH1FK0ji zoVwhGGexc3?v|8v!dAaed$S2f6ByE9veXcpPML(Hw+v%m3mkU$7Q}kqYZ-R`6mn6ob~m)yHYxyE1p{V?Qf)TaSQ{go@2u83&LR8V?|$Crx$o<~1`xY}801F-F|ZZC zj&}nBx9@ys+u@6{7!F}0-M_JD0~Cz%6kLb^7*q!ynn+%|)-4OL7tVk;hhluM+Py{G z13pD)24G#&GO9>KzXdK5L7}YI9+q2s_r?%Y(B6NIqlZevz3$PkEZr00X77HEj|;KY zLc5LO*L4y1&21zT50Jn+11H1xN2MxpK>W6aw7ZV{CO0Vd&C0pao}bH zcY^T~RC7)KAcwEaH$KnGx?Lpoo6Oj=y+4poO6mYcE|`a&O+VKOQi}{A!a7UXrna@4 z?5&+7eZG#3RsVWrlE-DWxyY8NsZ&Huo6Ykj>4{)#abZ5oNUa1DJsFuE`~6r>x>+&C z^X#=#u*{CCx5|$mrFGcUFi5d+S6vWALTz9*xCXPweQ2s7>(UW`>l%CL#avXuLrs^f zD67zN1DD`Yb#-&oW>U)KKmrz8<)UsYVdfXQXKgFp)G$1+!4yt1My(BXu(-IbgzsN% zVP?|F!Jea{qB6VWh0X*(^LNf$<$EyFpeG{5Qm%4;*Gstb6YtK3FU?=S?Qq1Y_Xrhj zDD~pXch9MzLI+;XQ!D*inY}4F;|wQMH`z-4v|z_n zo&dF>^1d(WZ+V@C5?pv4?qxncW|;Qankgtyl-X=n=ap_mlFBGaKEpTa=@JrIk zW8VkxO+x=Ra!{ZqPdsVa0pfo!2Xk%c{$kfC(zghH$DKW?2(Y@VLtgC1{&6!=kS$=_ z9>yc}J>M_iT9_FQ{Jw9~NIzRi*Km!80PA>2tC^IpbHI?@_Ht`=WDkUcQhZ8y)u*CbMD*tLPfU|7EG_Tm6qwft z&<0*KE(gNd^F$aHpvchLMXhA@i>%DpEh@+9Fk3DB$-~3XkBuE^Z)uBH1pUs={UAwmG9Txk^HKgCpxDM93fZp|Ww z5d5{hot5Y%vUujnJ>UnY)2gglPZPJ0|7>dN-&Yi$Wby`#@1#cfkOemmuh_r)*FN^0 zEn3)u)P#L9`XGED(0Rf!*lT_1_3=eoz`hp*B4ODoS?+!x1G|Vbk)3ugJMF5DH8BK1 zz;qZbXGi`u#E=p}DIab)^gVANKRx~D;^KSk^;~y}w>gO9)p=KsytjPG#m(Jd&6pt2 zL!F|1@q zIB7MGiC@X70V+S-KM`f@AtfuDl9BNnPHn6=O5`}eO5_cnYMY2HFCCLrAgw9FB!zQ# z7U8B$BJ?}h^Xea;s5H$Z!2wRaULw1iH_N_#=TQS8 z$ef<$5f4n3;Y3sY;DN;5hl*TP!k_Jn;9Jlf@{q^C;HFBX~0)}Z*Q0FI1(@kzJWk02Xf^;j?H&lkRXUd6-_Zyo6fkl-Laop`(B<*z|*Wr4!3 zpJ+v~RLal5xD%1zS5Xk!pGwifQO0d}jo}pRv-&Y#RpT9N+Yr~*ZVr`Qwp3H2dBDiC zcjWKin=60S0c2u?0L=+8h3=%+0_3m66i^b-?ccoj4yw0TAmGWTC=%-%8Zb!#3+5N# zn;DOZ@&9$57d9TZ+^ZE;f5Essw86SDuE>vv0u4c(`pSKpt>;OC^wsz86~pUfWb9sb z{}qivX!9UGDnPTwx#245AUUCx{|wO`GPv-mz$Y|cUldZX&72wzdIW=j3gr?f(Vb^} z5^HW}YVhehh}4zdw<+k}%mc6}*b%4pAuMbsQ0Fj}6N$OJLKe)tk!P;QCwq1PM#h^~ zgkr4DQat7}*1VXryrt#rWM1olBTL9uVBPe=17=yh_HNSqNd6lFBm$a!p895Pr$0t^ z|J4q{VG?}_PRaW<<`Qw3HF-t|=HLUH4!mWI>Tp*z zGA$e(AL6b=i;T5x`-$m0=~B*|xmRP}I(7q2`rO=Ob$q_FzzUOpSLCj7yY*0AbwlU9^~mh6QHTY1gk`#}$I4$)lPmd+7v< zHIV+((=Fq!y}>Z%eb68vnpv$yQbTwlVYT+81o}ac#V`uGA)Np#XVPvF7n_5?6F1Xj zfbxg+wVVbkL9W`nKPkCo$F=XPK6-jKMnQ_}t3K_7Uku*)k)2A^DwC`P>s+9A^h;SRbyYR7NxkW`77yX4W zDoN%hM0;5;WE|n#e@jlw=&d8dIE!8q_#X_S+0j({_S>aIQ?|3``}d4i-pI#~4;(l! zJT&Cc{n~2c`z4qRu&5gWMXCRV9snj1;9DYfd3~u-@9f!nuwziO`792ULgJ9|@2p<+ z^NtItggo$iys5B#Ay(ST)Lq74nW>*c~(|_f}VCLYysJ8pg zG#s1t@P_p(X0>%csi?XzRYN&q*SFpoBUZRc7;DZYExwV5Zdt8h`fQ*Kz8FMZJC&Z! zl-mvfTj|=hqoi3(ldbsB&`?~%2RV*@$KZ#S1WtH>G=Hf_`27=Wi;Tne|B~Q{uFh*I|ea>%fx<8oVEurz_Ij@f*xx*NNEWgZilD{Nk@{i4ja6b>3|CO6j4b@2}$vxwY^PEj#EFDR#&<5 z^_`Yo)L|%7^!A^M+VMz9IHh0p0POzU005&_z=lUv_NE~l3Bsx6%uP7zV$^uo))VV2 zw~mdtlnj_{2cCN!bgYFHB(vd++KD@^k`}Zws+pt*v?49d;UPhbY1f}^fs0)N$EuVZ zh_`Q<@zZlq+`6h+yrcc1QXsX|Jx8`o{(E(nkACjSqAKpSFEh5u*B=QzNK9$!Wa8QT zrsg4jprTrsnNn%MBvIq{oHV3&q0tC$#pv9p-#GW!o7BxJl<+3E$CVs~0k~#@M*2>_ zzXhSDGIHarznIcahbxC12XuUR@V4tlA1{(Tbk*F#q8e8{x<%yL>w%JzvmiIi-+t`l z#_lq>OOWCgK}nnP6y;e*Hq@pr1r!trpwI)-sq@@)%ae1Fj~+?L*cIaupX5rZ_k(#E zTdfGqhA1Jp#=O_`fVzjDy1sr#5+Yh5PS#cyp>dXElYDSh{CbuAGo5wyAXp?u{r0Iw3sgEdx=E+$3r3cATaQdB-@u`a}`jjwT%9Be1i=UdM*xnA*`cl zx`#Ycl9IT;00zK2#X>0iG6JulWsCxBEP*fD>45%+aUiD18*QRQd%=0@ia{$=_S$TY#>{-vH z>jv`lvJD|*ky{8?(wTX%l6gp^Nbn#*t^b__) zD?`IxV)s%}wlnVAmjL(Vf}}Or6~;6U+gNLGs7@nylb90D7YfmqQTBtCB45vOuwZnv zP>E)wr#ngZAZgblmvFbKzu!+c?yb*S004WqpADC^U%7e}XCqJ?62kB79InQTVv6e0 zC7b%kp^%oM;@MaXHGyRmHm=L!*WuAMIdJA~6X`f-<|LlhZWfPGD~CoBWJXYTV5*A^ z_Yl*W(Aw~r7$v%?4PGb?N1C}&3&FBo;DVy2W)ZX_Dk`ACSr&uF|b(xV&H{rvOawh)J6b0koj@+w~s=t&F(ds0!k~` zHWb?g$jK^BGiqu+LF%G9ZLNy4vzR>pfdg}Od`X~&zJ|h@hMv^K5f)QQLg3r4VBO))_xK@ZuU7Pj=O(cyCL`nQ}nc+`*6ZBe0Ctkgn>_J zH~jU<%yGAI;)7Hvm!~i;he^uq+o^a~G5;y2RQ0)$g4sO4`V-S1EdX)i(1OS)XWSfH z>*SqNdU~~w5AV-5ER^Owy^k?1ga4DQI7v2LUQSDLKL9XD8T-aKX`es z@M*+@3ki28Ha5t1bh27!*R;Rg*xi!*TpC#?u<*wL)2!f)B4oVxIM^q_^dME)cTP7m zY7#9hT9=mmiQ0gr$;m{;#17HFS$em+M<^bV>KKY}ZT>SFSnM`IlD29@3qQ-t`;VuN z#Ht7nrehb(EIJGYprmug>zwhgz;zKl0@N1yDA4wCk}*?I>IuZWdXRgt(sA+k^d)Nd zKd&>WJzI>wx@EP5IK~q)_6kL@h9HcL7+AfNc$Y?D8~Lq#5qkOe=4b&P z)`!DrzI}{p>m7?h*k2t)*q%HRQ$V^R^J^Rqlux-{>I^QeL>wb+phfr9{<-$%iXvRrjmV}xj zy^Qo_lQ$(|x5jU>ksI!`JmYsGEy00Usdm^d@zm$K_U!Y?cN@f1e15-I-bLPY|5nJw zKcq`v5XA2(8Q%MA@_x-v-&~$8$GTP$l{idx+;>XRa_+sj$hA-A;r5%)sc5eg-wMaA z4xUS8Fg{rKu<{+v$4Whx&0j&g`73tWa$F#nk@(#3woG$~itGvHqq~($^Cl1W8oHOn z3x0aHlMF96l6VX6U_pX*`%sK(FgXi{0$D&1`-hp1hk|cB+Sj=SjOdam%w<*F8QB=F zJM=t@*!Hu#=N3WbCP)8jKQrlF&fe+Yu-jQuv`gR=ub=E5;?3m8r(CIL-E-Nk81*A} z+`RH`Se}Ras4hok@Kv*7sxz~98~wGIV(n;FhQ1Q0=-PJqsj3nxU)aYDg#N{rPyEY(G_ZQFGgf?xIRUDo=SxsDf7lyM$CLq}ze2@iC11j@$oAiRxk`Vw9n2AT)#Zfl+Ooa(`q<2n zPk3!&EkC7NVM@BVca($_PlFPs*@N`Kl}g(!7OEJvqcb?og$9ENgox*+H7@eaj^*1l zT*S_?%RE%4p3@5?(1_|sDBm@b?4`=|VCLMmJ4W@^dPa$B;6R_I7@bx1SFf*j{tH*5 zO_>O$bK=oC{>FQ}+CEC&5k8(E_{l$V%g=cKy|b5MCbNgq)G=Urp6omiYSMBwaqoHK`sLg0X`QWw4QCH^4cQ)B- zYlO*St&Gy;%;DK8K6SOEZM1Gxe%o!g8oqFR!MfEuFL&2Fk%v@rm5FcbNsnZTNQMg~ zEPNs#fBE=X9CRx5L@v^3#E!}QAty-0t#w#vevT1aSe)Wsng44RJ=GH75T=pox%4Xu zW|b3NbNP+KWm8lZnA#$<4b6N}H;6z$(#HP$VP+o5yzJpLs5r9ipcp+ZtDrG|JApu1 zT}jZftPB%MwtYxNMvyk@54rTrVY__pebt@5ahy-d2(d5JCcCL0(9eeY$xm|+)~S+l z(!CLkzQ&`pe8{(kWp5tQ@?efG>#SS^IpM!%`ZT}Ps(s}5$Oy@MiM4W-Thv;2;(c{n z{$?NqDK38&8>_Fk0a`~JsL-N=^xGHlD?@P`Fawojvp4=Oo}iHw7l*Kr!70_m)k9Hy zaSc*56!IyPfxLv`;udyqmk>D)VxU6MBk;*)mabe8n&??F<9BgxJi9a2&Pd`Xu9w>7 zVJ0V`(t?6aB@B<7c&XgSZ3IWF{?!|sKHmzsh3=D=Yw@mv^-QSpV z*qGmjtY)_f`_f)l2*gw?Rw|T$W7G~Rr8Vc|2od_H-Y^8|Wb5V{&e3zibjM`e#cxD* z&XIN?ziJ;LlkW7y(_Q9TD#9j@@;`+od$L`JyU7P;Y8>C4mm z+3IZXm$4ITD_H{;p2x5+w5HJ*-K-2Ht(fEX_ZSGpMzYtsT<+c5FXgm&hwe2QfiwN3 z)Az@RkBrV;hA{{tvz}*{8C~>T>T(7bQ9kUqqojGh?GME#=W2w5TSlYvjv(%;JrilS zNsXS>&lGX?#i(KBfx)@Z4u?BXT5=gqX6gLSOfuHHP?-Gc)t@d(4k;-Efk*?vJ3(pz z^f0gCisF-EbFJ8@&AkFP%auZ2mXH!7g?9E|Q|^Y@2$3o_Qh*WS#as2ie$QP-3JqAK z%C&yu?BujeS2#7QrzEU3>sxP>70gW*2$;7$jF8}^-x5n^A;4^@H^230rkuyu*3(;+ z{m4F^XAFtX2QYjuGI?nrcP?@=cU8Fmjtb4WbW>fqdSPLjJSv?hr^*Aq8OEHaD4Gt! z0^}5z%HSu-!UcC9VxrzbGkf3+a{$;95nB9e>K8y0BUD1hXQ-_`HQLf=*F7Hvs;8Y?V(`(guMTQ3H~a?&sb3X#>l0a$di5g8isQ zgv|0ttTMa7B|W|H*yrCyXF(5HnRi3H&!>8u6YGoNuq?fs$A1qqkd6L3NKeZKSmX`2 zGbEPudCi!RK}6@!IgQz_w4-TX)twbGjw23ThjQNzId=4UFZ@;EdFk})Id+B_cP|2z zb+Ej&1D868Qb8ax+jwme8KshJwAD~_gAL}b{D94znU{~xttI2Ikx*_yL0P)xRzUOa zlP%yReE(4tG`{tKfYv8d9zw{23A;bORn+Umk#G)m>dciC{(WE1_xnrzG@|1k2&bl) z{IJ@*;GWz|YrX5OuF{t|QF5UO8+x*ZZFhG*@k`}APsVz-|0{>M zY5Hrf_AH%?k$6jtaf1^UrSi7V)tiOnAm$lxgz#SoJ?w{IC!whAuqt7b^%?=vZ0q1a zfo+B>9QkG+?Q|41gx_SN-AD)0lKrXXF((C|Z7p(eOj1dRGb zW8OY}Y6)Wo5|M8o)^JVD6Qp~cd-kpU1KN;$pS9BkQneEcy!Ok(pP%)-x_p)^kM&XA zPk_sI5}DcAN3}84vlLzW9J6cdo$HpC@2?b6-l=-|ayo?dn3c6P1R3k=vauN%nvK5W z#SOgY+dh8G)8ZH8=U0nQeEb+>?zs4PBO{|n9hpzxdOem;Nq+jK{^)G~9XjkE#HjkQ z-@n<|*wg^Mm(GtuRly_l4bUg1j#Y!F`C5Vrggp%;F2K|a-K_2tk7A!2!EoAt`+fq3 zIY%NteQgnY{(SdW@oV||<(F!M$FJFucRu4_yxmKY&D|%(l$nyTU!QWwDva!;mt)ZN zEgali+P-icn&D*jmpD!^s@rRKsza}lCRol;^ua%1lmuIdG|>Rfe^4`h7r zr7s;K6R%0=SK(v3x`m)0LDAUAx&0+4TVPtYW1Z{V?A2{U(N}#x98@4xlz&B(xC!Fw zn6ocV)wXLSCFZvN#y}s)7lvEC&CNq|#%`$^GVHlIvd;aLKF@TPVWP-NgSl+QwQkSC zLhxn&!1P!}{Q~%wU%nigi9$x+(o8EdZ=ohtQaaEmQ&5ia$(uK`02SEUr;+vuJ8KJz zwZs#pe_TDy%$o6kwr{@=UcnI@uV%td#j6Vy8++u@;!H2eKM@65y;9I9yKm1Ve1-6Q zDW5h%XT3CRg5>~*Cp^D@96JyTg2&RZK*|$TBfNHz{#G$jn!36=0D;s>0Px8C($jge zb!`d_XP3nZ%xr8wor?YamEc9+n0N^f*rPhjEWMN3#%u?)aIwLK zqkZ;86Wv8C9@~ADPY0Y_cUS(ASXf@(W-8p;-ku;eqb|vI#V**z&Fx8sK*LacGbLtz z>rfMvo&bwegEhMj!V-} z>`M%qXeO&>>31UF%Wg+uR{vs$GKf+_xwbAJ;z}17LLgc7cI%RFX+DiFoNP z%|z`z)6mYCD7yS!njwgQoj$bIf&j<=v}Ph9*gHQ8srRKKzRJqon=0Or!B|+-V5BUc zV%zz0*Y@3lXPD0LFc4H^+>#zP4ui#_Krk)nWC;3Z`xy?mu<=a?AL_%0LsEX|;Ioqw z6G2iy5J`tp5gb#*)e%SP&vnE0BW^^7<`E9dsAk)jhKKPi7#G*IyZ#+Z#KH6m%}b@yKa zeaPvRmFw$ANsEx4Jo+W2A95~>jqas#g?)sr3mF(4BXgH?%jW3}vq8(&h$g5>ZeR4A zpW9osqAsIBMu^7Q=F*FW?<+H5+$IN%K_kscdS8mx zMfsZ5`{2}rT4;yAf_wlgK{comW zHm)b_SdW2$0imhAT`b2C8HmEnsri@b1%7g336F{5OieyFY2>CF9 zC_b`TUTSQPU@St{E4@#s{bBo<_A_w^E0QmlWM$P4?uD*KlttZsfk@yR|hHPmtoSU6EkJG=BPowB27&euGhdNMJ}@qOD@CZGTQkN^V z2)X*+TyZUhliu^zPUm4=6r;FMi1ro-TE(m*5~OcTSJQ1sn+>Aulaj)zB=`=_(bLn| zTab~~)g@!*O$r9_giQ|~_kFabjl=3^&ziin+!EISq#Ua*HUpnf!ONF5KkQH%gMgUS z*xu5T5Ou69J>AZ|BeG+{L`ZXaF4tFCdn)_l##g9S8jkS+s}mKaxl7{f$SdNYyp@X&{TKWwJ8La z+g*<7zwYxxP$=rWzP>oi=gCROt5@q`b{?xgST8(V#ChokG?e-Jt7x=w^R1mFs)aWL zN<-m5&$tT!VeKH?cT2pM&ZT0jv#+^l7N#OD{u93S1bUjSZsR>9l`uSRpSQ9En7tcl z!s^Fera%qm*_f!g=vDQ?U{}y~*3eq;S=UB0S9nSkC%*5^-#y$^6MLQG4@0oex=ax zUMhqg9}WkcKCf1^zQ2=vr$WuP*X!dRH{3tneid1<^Z87MXx<93+Py23_K)wHM(r)E z-QJK4drFR5X3-!s;ZJwF5d+9}{daV<{Cl&b zlmT6wwjhpQWw3JvJC1=%dkUPd{>Bz8z zsI|G1%NMaK)V|$uoZ>{L0oSi|yIcOJMRek)>CUC39N$MIZHiILK|BPE{FA(0P2cTZ zCH5vT$KLbwtm^j6q&S83*0lDE?-2otAdY;}_WX$QneWVOe_U?~Rx0+xx5kYPukQT2lxw6TOpyy-BLj{d z=6ls5glW#>;%f&FMZ%!y!LR!LUek3p0Re1?2S1`bQGCq4XSI^zEW)Q(5U*H@bgT8H zJveItzf=n&olYVSo6x<0fD#DvLs+*~3V+5 z8%qdcS>gSnp{LglKQ3r@4=@B#-Ex%ln*S36H>$wu0h^@WHlys2)L!&@p9UK&q`lx>LowH z$5n8n2vZ^XsW@A2iK^cM16t(n!u9D(PL4)g0}IX8$TJsCooXI2*tM&`U*7EedG5e! z$ROq}T-Xi`DEx^l^cm3j+GnA=s!b(Y`XE^R50LL$+YJEw|`bhSmc5x_#xeQdxR9;aq- zI*kfDNoQv#fu7o*cj}Pbzda+v4*3nEaLDWi*zjve!*j_B7Yo{)l;^yfvT`Xj(9FoU zg_}Ec@)vYI=VX^*lBD}s>VOgwhnHc4)9^eRF%FV!FovDPuv@j|Gg5aFJ+AaNOcd9d z=L6w@oy&hU=6Lwieub&bhHJ{g+ZMT|J{1#s70ZP>0w)054A#=sntub67QRfn22v9} z#aHfI<-z>XRQPdZBq%=YgrUzde7o--Ki-YX;{5sZwev^a>@Vo*zOE6STwl2e^8it? z5MUyrF)sxK1l;~~j5~IaQNu@@WQ_*4QO0FMAmE;;v%-0wmb zJMZ1ruU~swS}Y`N&hmUkgYmb!Zyy_5p5eBQ`JzVBW3+a{sko=uIZMK>Bws&1G7_=Z<*U=q2q=4$I=S@L#Me8%dLSKI zG{sZ|k78g5ikUyxQTP>Px4n8LuB`)m2?7CTN(2Ict0IdcQk#aOBPp)rn%u#A(k>(Q zX#2m!9=({>3|JI}pFpGs)+cz4W4W5~vTJkrD8qpcMOr;jeCOe9D9mi<;PB+>8+}2{ zCIK^utMeJ&SLDLyymD*~DZ*Is51%R!&6qPvOULfeeGgUSO1tqv*6PS%3_sG-`EiTH zyR@C0sFNDcXSLE)qbf%!qWt9Cn2QIT`gSx@#8C^cM%Byk1arWpFS1CD{gEKi)HKPu1_CphpJuBXi-k7CLS^jB%rIw z_(2V}yB@u7%jnnl=GT8vc`GQar7GRW%mWJ^3JsK?!Kc#*{Vvk)2J+54K_Yjl*Af>2 zO=(Mp`o_9O^}xsBr2TJ}+MQaz8F}E;K-3g;yH)l{rWen}X27E>CN2(0{WG2C?lQ7w zgDF}~=J_8jr}0E&<>n^j@+{I6>$Pev(_7!Vaf+nIJ>MJMRK zN=ImIwL#vII7>mI=lIREW<_nC3$4gCI9_}T8VqcTY0Wwp3j5*n;!|;iyL$3xcq1lm z`z7-xAao))F3&zAjS#f7qTTED&1)O4->x!saM0Ay7zZ4O7^KXK3YhI9Pw2#AKm1VZ z;cJMryO*6WWRr?g&1pFSsct2QaQiv%? zjP4J{lww=9D8Y{f{zqyCpyn176hH-~-7t^`o7@9!HErLFSlC?;e7Ytv25xa56s{A} z3F|R7iCf^)-qPM49%dH(p5t=tI{Z!bvORw0*Cz4{2uyjD0ZzJ7m{C@iU0i%nn~#37 z{hLwZ@uGXFPZJY!pxV6J9aKBm+M4O?JQIAnB`bH`+ra_Pp-9ZhYQmwc_AT|va{o7m4hf`{`g4Tn+p z9(6HjFm&QGo{iNgU}s|AzmVF8(au@u?=0)4QAsH#WMl*Y+&9R6+*|;~5cr~8VUsZP zQEngoN1Ou6v zYy&heF8=LFrj23tohsAG-8tf$MXh|hk~m94#Juu;Cc^$+T24g}TOtLb>W_+w z2A3{x9yS<^{XR`#U=9Gi81>28DH{ys9zEJCogjO%BDu7*Wn#g`n&mSI2w0zMujM=O z5f2oMt;hZf(+s-8@@XOanE$`}F5NV=_u@>>E^2>}jGdjF&{(0n-`uQVB!JMtob2r4 zmgdb)fYYTh`u9P(BKhpL$B(}>jkOSA27gXZ@3?T2TjrgAZ+^ts=?E#`g!B=oTzp^B jg4%!cl`?4mZx^wClIwE0wxjSrqME9bhGLGq>Fxgks+~x#%XL@cY1!D{^#DC>^yt2XTERd z+*A7#Zmq38Ug#`ftL6DLZRR#fp5C#DOMTG_fKKX>X=K}%)yJRUMq9`RILZs+q zZ)Ry@3IZY-mXrdes&atp_x5=Pj}G}DXe~}2gqpY>1Z-MJRTx#0iirXOqqeR&fF?W~ znhLI&DtF@$c32A;u2HNzz*`9OovSYGqT)|D-rm#Bt2G|`@w6vj^V8?6iP4rfE@#kO z2&evE@R~4wvP#KhB;BC|SUG}22%xmNps0f2bch-s%tAs#K}5~wyGGiULDF^XH5CRQ z@9y5zRNcL(u|TL$Hche&q%c8BM82##cqF^Wx1p#f5y6l=FOwC^UxiA^ zXB)A4{Gj|05X^`V!kg9?R|qE9D13ZvWA_0yl=ov`?H|N{#MKVlPy~^3lx(egQ5}jPY-%EI0NS2|E{DnW|h03vA@>`gy9EJs%%@8+UzW%tCB-;n76D zgGm|mn<&J+u1e|S(wZwdSuDcCdCYj{nE2B&dWN(ptM|fRad!4xcHra@vt*K7n~!Xn z)E1bfGTcOD8h)RKe)vd@is>A}75~%O^kB-V&2J)kXaYraVBDdRk-{aU=pe4Aj-R$g zmn0%~ZvyMx{b=?PLp7huV~S_6&BGe4kZNxGr*WHCFBE6?udMRfcrj;397kw$cUa~R z!xO0HK_f2@IG|2#tUSt{9B>bu=64|@pHl~6U~>$+!GwvxykcQE{Sd+Y89+WhV|+{q zu1OBpkPa#hpyftuvGwBC?r*5gUtV5X24(bcD;5alaQk{nCfYZ#-U$J6%wZiN zb}HzN55ju#F=NVn8x{j}@>3E`f{DWNWC9XA5tvvmEUO-Xa&7NCL%_xqJcMumYY#7u>?1dSm)popXTZca!* zm@>C+(zFDs6%Ij=bkcesEi&MH&4&u`jBaN`$kCv{O)7VkOjw3M=M7$W8XZ`TzR(S` zds;7y&Ubfx6Prxvf^mwhiTpos2Lx*s4ND+YVWk7K0zU{Q<(4T$m9VQ)9zvE8-hkbp zM2V?Pxzw{Q;p2aa7I&T+nY5nNo;2ML+&8=SxJI}J@kD>Y5b3cnre(6jW~V?*2>%%U zeJIhuifM=mi?NAOB-KrmHaUcCpw$4p_F|Fs_`@;gv7QZDBmQzAet-0)11CZz`8YUM z$kxU;hlggqW|3x=X1x{UQ}FDdg}&vjmkSto6d&+T2>lp=sIviqff%$z=s^e$VQha1 zO(`mpW6FAzDzp&jEm6~a>Zw3%F)-CSl-|U z*d5q0*bZ0*44Cl2aM^)@aISFj@FDbSnodO$sx+$FL{4ez#2-oWR5#R7)GA3QiG7JI zNljD>H2UfU>OG~YCHJN0s+X!(s^g{b%1WvtA0mDf*%h7^>*XSr8mY;t{VcOA3oZ*) zYg3h&Q=NT3XEdu`l2o3hd{mrgLBYyS7pN}EBi$zV#42Hq=#1z)zRMNm?77#jv7mgX zzE_S_!cn@e{8lKma6Tisuvj&ff1!w0X_?m|=-jf)KL(f1P_Nps($K8+PD`TU)Ut00 za|vasyxzLL+A`)~{}5vTi|g%v=8Q+4%*@Ta+{|j}XDv6;n6kZ6%Gu>oH}NwZ-KgL!DuEV(2#|7+NC;se@O|igSt0l#1>&CKS5Zz;xRIwg zXpuOBU|Xw$S%YVCvT{ap>}mC>@EK(p-{hQS@ni{8l}6h~lhf2PR#}JASw?5Z?$X_~ zyD{Z4!6KX@j*@GN>WU_vs!d}s27k;+o2c2&naeerX_;$tXd*36+6ddQFV-)%XIisz z7@pp?WI1;&asM=1JZDN^1?BOxQvxy3)k zBd=QgAfJ)Ro!QCR#wnADmnESSsS~gBLFW;>EYe{RbC6skvOMNUYayYEa5Z!F+e&on z%ck8)_Nm?(KktMKf$!R@M<4+t!TXpGF+K{d=J9)X*)MvJdhe^Ps)yD>)_Bjf&WdH7 z&2X=fuZm(SWBT`+Cq5_RS+kX|V(s8+11k?WQ(R6Z}j> z!N}?G*?>?xbj)<2Rw7U*KpiRzi2_OjGUc5BVl8xBQ2kiw9@N-6)0ei(=d2F5=3hDWdZdoe`H|AHrJ+Z87O0PQNHcN=24N zcn}`pX}@14XJFQ?H=5cRNRME_ z%+bnk4yxPMM5Ul+FXcaAp^Q`+!;vwg)F6v-`na;Xvd3$`Ccg%~9;iR+oBk_KIg>f_ zFs_xQ%MCWFsI;X?!qZ~Y^R#LvlC2ah3Erf5!?&aK6R$PAW)HO(KWId0sw(R> zTRe7V-oIrMs^@7qYPfD6?p00TYmVvYHb816w0||O++1pJ5IF*y$JbHN$?1GeL1@Ga z=V)KWZmXqJptRRr+u#6QXWgdRmbrXlZ?P|X#(b$fU#=QM%(%08)#|2cR<_XARKE9s za~nxIJMN@;u`{y%F<(Wpm+!q?vn;x7XMeZkQ={3!S?umG^o&2obHD@lsdKf#WMKz& zDE`N4|LV8Zmm=b#%FmIvHp^EnvWlO|SBl$9h1-mr2cA0GJ35})@7UB2RWa3l9`){D zvda9*cC8W)<8f`|K8+>3Fg@}38ayj%lz-ILeA@Bb7kuma61aDyb9i{za1?>N0r|0S zIImx1HPjoaiCv3Booy-|HpY+i8|j3P?Bm7l)J6gR5cUwRFY{~ZFU}ixA(q+pZyxnx zlhfr2ig`=SyVpO-IkY<>70l;2Dqs2fzoio=Sp?>->Fd`um7oih_=zj%CZCSHna4Ov6?e=ZjPONK5%c z>&VT#-NI>Owg+GF=MK+_wet?g3yP=RIqkeAPdkbA&Y6_O1>aCN^Lx9&RgJrEXHo0= zcOX}}8+p@x@e)fhWxi~04W;WXZ?k@9-3>!=F=t3lP&scDFDF-uYiK_b;)^{MjzUgC z6{7EBTm-c5ZT4I4AMPWb*OPp!-7Rk~iv`->n%QwVxUZ!zt$y7kbKu$|w!3;QGhy=I z?(6QhUEIARWaWSVJbb_SKz%zibFq`-m?P7b>TCIg`+UBHrR6+AyG zdk`MZ;TwGtImeouXfZ1x@r3xWFplBlFDy_SGVA^Q?j!yEDOzMdKZDeFWn>>vzKa;W z9C&0TLd*t7+sI+&J9{e{^sO>r2A4RWxKW7P!`ZU&B0mAZu92yxl$o3y$OqsU8Uzd! z6$BhO0tJ3SLM=fc{yGK$p#a`NK)~ZeK%jtkRNzlB7wkW0A%t_m|8oqK2Y!T9M5LsE zcNJqNQ&T%<3wxKxPZ0os2IIF>)pXI6ljSzHx1~2Uu{ScMcei!;T?B;Jof|l`HFYs0 za<{dybLMvEBl+tJZs7R$#|$Jye_i5Y%}1gsr${7X?_^5EPR~fsNWu?GL`1~vWMamx zEGqu*;=q4=Bo;0%4%`e3Zf*2fdCxyi{ZaIH8@LsmEP>k@ z{_aG6CSHdB>$87f&&%+;hyUpDe+}nfp915_56jE&-?_mLd(uLO0|FulA|)!M>JECG z^-dG>Bi2v~aw2k#pkgiDa|PQxW?P%aK=-M7e|Ik;yy|gx72EvjDLsTLG71^Q!Tl=( z*3i$pcMzgtFB5$%pHDmX2A|FJ?y|Y|)|6P7m>vS5U}8c3=k?4BG3%S1=Tt~02=+g( zTp~f1kcl392|-<5UAZWQS9`a0kDmWt(uE2tzw1-f_TBn{*`L|;2R@(Y?*5bt1w~6& zg&YDZ5$Jzj{_s+QEF#h2fj_=LAmVe!k;`Dt#p$-YuZ`PfTD{&)lxkGxRaKovU`?E@ zcTsu{`Qfozz(4#*lCfX+6e&?ENDc`ZB=ogVt2D%3Ed)PF1VgP0Bl8B4w1ynm|yb@t|SI2(3(baSij&gGL#N=0R{Klv&! zV!geHFzE#I`H_tSfz{Q8}Qg|RI79bYiny4s&vyh9anONL^9ZI zPEJm~Jh_Q{ytc4>5MWJWF_)JclZ}gutJd$r<*@62x;tC0KbR~}K?s3jV+AuG zNuo(Cbw z0yGSaU?{Vxe2;tye0*K)WvL?RB%x+4Ny+o+q6qF!&pd9YD|e@>_#AeHlbdP(8E9aD zHh9n^r}4m#Na*RSREpV|n3$$hAMXf_3=MHGZ!d=9M3l{#g*&|-62e7M8yE@4;z-Sz z>AXy*{6Ix&xWVe?Bw`38<=E_2+MV~h37bJC`AIUio_O~k$pl*cZ- z*qSafZVf5K(+g-f9;>UnUhOeVwz+Yb^osgN7}oyhxAKp5kM7Z; zDpbK~us9qjt1x(wY0&I_{sdFOlcK3Om(IJR!6pOYN&O(P;LD{RSL*!y_PRRkqzBve z6bjkx$PW8Q<^ycKvcgyv`X-mMe=OVc7Z|b@6&xFES&j@2d%7rUpsE_f!fgd&hWCKOwG;A%*@Rtm@8vKY$RGt=Ehw^9ld*~!5oaL3j|3S zio{XzygPl}{%%YLhe^w7G0CWeV$Q2{?rO8zio!h<{X(--FkdLOg+-eR4hNc6W4N-q z8iI&lS^B((D?lcbj=vc-AFl3*8^)o3!$Uq9G(60s|1S)c~vbmjBOisqs z7$%mnNd4LREEuwbD1V&5JXX6Ele4ufBiWNB*F>c8>2I@>c?Adv2u4OmIlLYw_V%G% zB?&WH5PKW=?Tw9}o^I*Ly+_}fk7phoK8~*WD1VPnh9+lbWep;}xW5pQDz;mF%;Iqy zfV1BQihI3y?mgb%^-#|?SVPGwe7-#n#Br|H(?v0zZE@xp=JRwBa$8%|d$_`yo}24A zx&qb+pSy#;l_GRAGVQ^jjJK+&yg%4G!~8D?%<=Ag0+#U|rKLD#i)ZUka@oAZZgwo2 zYJ%s}BPplGgH)Jb%*U*nKb=r8H3q}&t+l#}u)gAD*O{?l^V|wp8%Glggl`CfKt%0~ zq-?ASVKW!5_XG|Z8YeQm6=zQSfwJ4#Rb6J@Yei$xX9iA|C?%kh(-Ij(@xzAzOPSqz z9`$Z~R&_HIhqVOgB_`vLmpD?&I9lCS+QE&32QA+E%}vAD;H3->J>m1ayAO$ML@U#Vn{e6ah`g<=y!f^$Zm9@z*K2=%jpWsnO)7aKxjgn zNVqKNqz|N2CF+&ju{5eBK|9FElUc!HrG24DoIKS*LPoZ>q*@6%hCBmCx}=IEkBHaj{trjW(mVl<$< zC}6}DI{bz(;SNGV(pw~e4dMsFBA(0X{TPJ2!E$ly1CC>sH{64hR>ls0S=*F434@3j z0#c5_9ytsHr-Gg1u>HkkB-vKIdJP2pV6m1Z6p{Lv{C#f#s?*Z=*;+@^2NDRBZ>`+y zrmuY~yaMBzsH8U7!!^MUC&=!9hVf@XFey)CMhZ8#J79b_A5)nJ8f|`FLf0+TTfSs+ z!Sy@X+Mrt#d@~yh$6BM)Zlu?$Zyrt=1&L#2{=sj*W<<*jL;+f-AIWr3)(|qS112aV zJ#Wu-B$r2X)?dDtSDt7t!e~_Mg`B9ieOe8KLNb618$fkCTN~7ZQ&5;FQ!6Lre?|(3 z{&coRzZ9B8LJ|y%MXy|E21FDAQrUys6TB}x0ghmMAfp6}x^v|VsN9-?h@clvKfjsw zsm_hkGI$A1Wb=tpP^@SQ(a*NG>)Efh6MRcc!|9DeRwsLK4(dH~9$e5+O}USlqww=H zy+eg1e&c|U+5Dx#rwr}9#0td=lFw}eqp5fvQ`(pulDWT+U5Xj0CpFjyg40-^2o8#e zJ)DsEXN>O@@ZWA{!XB$N4&9*aq3tprqWAIfAt11uMt-`%tG8WVW3y)Okq-04&pz+e zadLqkMCoLe}laP0@sDp0tWO(u)gR=PyDQ&~oTqQ3T@?H)s4<(9GNw4&$M z0Bwpo3niY+$v~PKg9!%AAr}Ub1XgC4@qvhFSdpyjvf}Gk#6ZlbZo=trrd#4shX$20 z`L@C;Y=je$R=ZfvdhPCr_}G^54?!<82BE&SBp81KB|nHxYJY~&liQQ!KsM(2`3^&Y z?(o=<0NeD#*;2QI=?7r%b={woZm&<4-T_lD%oOl#^mz$kv!c==XACm1k!<7L`JSLa zMG69waW0Kf8<@rzid-0^S&hqPW%Qjh*~J+0XX(uPB@tn%G&9(3i|5m=ZQG};nng(M zWJ3-;sTQ|0AI%Ovhg<~p%Wjyf3*#@UiHS;N)QYjtI_>Uy!vzuw-DQ;6sC^+(gRp2O z;SI0xX6eDBX$`@~l$_X4>`-}GQVHnUtPdz?Xi;R@YPH|qeVYtYtkjBPO(g^-tA4$J z>*44?ga)vC9daO1qqDkG{Ea~guLeP+SILuB+T5__n}{G`937qTb-+e3-hZ(Q z%#lEUc%tFuW$dU~6R(oxq6VwM6vQs75xYC)a{1NYvO9)>$7@gtcS|T!re1c5B20l< zVt@of8_DJK{2mNHNvqlW3DapqdAaS5G1*usBu4&NU8COOqCjE-n72Zu(w9;d88_S$~Ev&DMh z7GME%I?d=23RQX?-)xuFw+mDtP&Ol9AY|QUE5cWT7(U#iWU^W%pmt#5>YAnnLBY)=iyy>YJWj#ZBfCXG*Q|Z%3lT_ofhiyfxI!UYt3OU1I6w8`@Z zRzN_1>Px*2)Uv=AHSUu9%1XL2K}vf0>+JKDAFY^NFvcRT$1zRz>vmpaXfYP$>T&~W zg(m0U*s0_Hpi706ploPp39L<_wnH@@Oab4fC&7|CbMp@~v1J}+<_&NMiOM#_c#Iak zyuFhk!OxJtwmX0pwd}0dk?3e{P~(&wAcFGnZ*2;>?cg!Tum`-AzR2YG$KN*vQLd z{*fZxqqInkzTNJ~s$t&L$W>-W@pyXp+t&xibnqFGELzb)e?w^>LNHv1;%9!15gKxT zRg~^eV2grC1lXL;8>YQK2p1V0CV&2n>f=aMo0$i+fY0y{7K6|5Zehk`|6PfH9mJwY`V=##k%;|4qW(HD zj1819iG1o-`ZK%%$Azf?CqpmDC;7Yf-&Y6@0wk5fcm*mt;P1x$-t&kCfQkySF);po zdf)^zBxpJl&KAD|`hSV+zYeG=fQkl6N+kcllK>%(WrDWYKR6)gj;D}I$HT?#^w=V2 zU}I;uo6PpELw^#1{Ay^X*mzP>KbaZrz$Dx4_&^8Y>gq~a%qA}Wv$wBrZg%!?&f2fK7zm$y2;RVA7+SbnjUx?J;s8)7m-DWy z6lrv{{N8xh&lYEG>BLfz|83nl9}Jo0V0VcB%VfL9QO9Sua8T3nOaOV`;bc~xpf57Q zVU2gV9DsQqFW4()ao+%u-f^?HMHK<$lvHQn@y5DJzw1Lar^`NwhqBr@K(_!^S@tkW z{Ev2RLd3HeGd2%KWk{OIwtd3i=^IO=o|!FWfyJZ^kafGmN}z~}2@l6*F%w>Ee_%G9 z4p=vyuduADnm9hemz9$cbU2@{c47U5~BgUV*x7;0opM6n<}R-X)a`EZGOY&g$okmWm~wTxHm`?Y$#gtyY;4x^ z6}l}>NmaT$k_}Y9wvf_zaBL3Iz2rlm)87rx?=kSUAv-jVPp0>p)c zTA;6;iG#smqq{Q@>W)}|sC#|>6Eo(K@d79rpai&{u2@3Pm8n&0)=qzwJ2H?aJ^-}+ z%}q$58$chLFV|qus8H18X|h|jn6G#TUpW**I505q`0ya4SlRpjfA<)FLKz}17D!T_ zPsfVOjrdG;XN$FPUvJ`>Ktf@pf$^HJ(uD$>&)I<2fFCzB%;Vfbww3`9X+&Y$=K$h3 z)zys+gFF}xXb5+IAaZ?qe_&%}71Ei_?@jAOz~>2)XCgHM@D{;tOcN3TA|ghK==Z|% zuaT>ZL8ahq*akdqb_#kqMgQ1(1Twp^MuCm5!E$D5sg;A5;AoyprZ2e1Z~t4RHixj# z4^>oTElfN-?G8`6Ae%g($zO#xBV1oz)+Ho{h~|&heKD3J!i;Z^-)WA0GaZ4v&Jgew zsx|3S%=fO5?{eZIgHZ=pcL9-%v^Y z1em#am|`w2*HZ;KQLu}Y{QUd?o4&lh?oZJK7=99|#4Q2et2*vU8cQ+IaT}y`U#6JZ z*)fW!OFwUPp8`QF2G6_+z$&wcGv@X22YezjSd5x8nwJl)U5eT!*6JVKx1KI| zX(mhCy58)Fk2$E*;fX^LgdL^1V{gsld3zjeJhVi@0w5PaZ$efilMdbu$B@zMx&>yZ zmZ<1mcP56)94RfKHf)GPjOd|ZApDA#rwfY)yQ-+X9aFRreFfhixV-C)&Z z;BO2_3|mJRqW`=9#wtOVq@|{MjcL}{hy#PUzAi8&E*_JOOhB-^-;7*zUa~=x46NkX z#Dr=ZT+u~r8#1+&F8~W}Y)r1tq?lS$$qsY)X7lqK9JqK{Q648NDJf~;d)R+;5RSj# z6Vh72trw8aBED4D)S{ll+d>-?y`R!IqPaDEbUJjkrU ze!{TZaoK;&4noNd>kcOU_uR=_8YPNSDk?AIS<5S3_Yut{|Im-m#lY5AA|HN1|MP?( zSSd+v_6OS!34cJV-+O5{5~U!^ZsT$C@*E<$gmHx2&;Ul;V3md{kt}g^KN2F zN-=LJ^WUiD*%Kn3)i|Bi^7S-p;^s(WXTiqCMyJ7Q3<$OPlG!yp-=tDSASPePtRqh$u4p(05&dvvN3GyBRxk)$1LuKxGu-Db>A<+!KRvvLx5=gU0X_e zJY|AcA^S}eU&`_;ngye%sE3jKtYBe0p6idK9<)@?ir=~6fx?b35 zbF%=y&vQv(tnBpUBvsn9z3Md^xcpVDfvU;(cyd6u%zx*>Ow`?_-4tzU$CVZi==M|1 zip}m9I?U+@YKb%{wb9YhCPLKYGv!!~f8ZJ^l*!R_wxduaLe&VvzKxU5SG$!!455~0 zVhKbjD0|3q=H=r9&ZdUQJ8us^h)~Q}Vp|PXpyJ^8)A`tQs^x^@iu-yzeWN zLYpk`_b2A1+ueP~$~wDg?D$D9ObbxVP}h17X7+g99k3=ccw0OhW_}Hfy&0?@zLw(>Ygk$&;URRfYk<{3wZ9?4eJHm9o_`6aB?`EwsTQ~0K|5Cx{3r2QVWH2 z8im8c%g+Ak^_jd#`sM6L(g+}T&&^yVWv$*fSaY8t>t=>`Vv*lM;UDz>+zq{MjWHA`R}lzS|_L39F;qDs|94xb1k`JTU@1yWI z;-r@wo+ctpMpezm(vN<9Gk?16h>oVY;8wTj-Kw>mxy|CatJZ2jWRF)}{ZU4+D?1GI zwDW4~OGnZWOWwG7mzy)K7{4>1cr+EUhl(D^`5iaIFtg}Ca0kB zR3X;gkvPWlp<{$$dlt}Aj#{Y%Gw9$zSB1xbcNB=GVmnp3 zm5w3a%=T*)z_Y>QFryw_Qp&%Fi!ge5qytu==s~*&A|p5nDd|RAcMO<<43I(r@Czb^ znVH9CQZFeKn+K`_o6~ma;oK$`#5*0t-A5xCkUZawZvMp&?!!BCj*I>o^MaW2Uy<0VGjOWfAa=L)F3d6(~+N>yA{Z-4)eO7 zV^^fR8w#|`0<@rpg~<<4yVOb)Ef1!}ieyr3=gR0t$%YjZC>t7B`lN!ts#ojz=L1ZX zs2RP1Xsg-xji5??nD=kQBbW|jAubw3srGYqwL=s}1{+4@>tZsUHUUEjhpm=?d35h_ zPazZwhHNDw!AdCEuS;87N@Ltmtfth?#ii(hYxJ{?O+1t+4vR@_G+GIXfykjL$Ia;? zn$1jWs=?K-n(yZXY{fexxj|vs)=7_2CsL@&0~)|1~4PTIZk+ZBqSu+@z}7t zm-9>m<_^O^qh5qQm;|mo+BHJbZgDclLC%42Fa`#N(Ilo#5uKTnG6NzgPiqU6!`=@r+_4n}D}jU#FqC*oc9akB@J~&afQFW5YLbYO{+OU`GRrd>li3 znYsSDTW^Sv(%mT^jYbs-Q>YNlL0jvGNKn>j799xXPUOjV6%-JDKNsQs{L56+%RmcG zfpqi^-TmW-+gfNu#JKUAMdI>O>Usl}o~0g^0?B^D>3acFuZONOjpE8m1eY2^#h-nB z2$Etn?ux-EsTKuqub=n(LW$5}^kW&(FSG>_z102v{c9SW_Si98?N?ig?a8Pll~5`s zu@c2l0)7PH7~9z)9;tdd`b{(FQM5}b1|q;nq*);BO&5(o;|NGmC;Xwn6{ZQs%RGxk z3`OHxEjN?f@9Xt508VTW346%_!dK?i5D-%vHF3G+Uxm8tfDRkk>r_uw@;Zn2l{M+oN$2VZ!F1bOK+D{k&7ad$d( zOIK2px49mL?a(mNovwB8SAh75e`6sSFc*hVPprEYAQNwk(PFo z-DM&ja&HW@IGj%m^il7xEEm)7W&y7lVnF4%&2dv{=mX^6)!v4^(eE* zYczq8DWHL9?cRtzjHE(WT(G^=vR6ibn+R4+)zQrt)VRQU0Z|zaS-JCCOb_mgm=-sA zkH~>=(~tyeP#G|SK!e89cqtJu8ZhquYHTz{UY>7teUi^=^{R!%5ZnMFqh?L5#T1Z+ zW$2*{c@IHCAx**i9x~>2v9_`8lWk0Nbn;P2IgR>TADsUrEw81+fI%ozi?A{?ufWV# zu5NW4o=@2DWrefb57dM;?drFs-K?4>bMbRdo<(Wzg$QPQ^VNp>7%kuzrHOU`Z(+&$lgRwPbN&=9FPJt z;$r@FAcj#9?I&a2|AmRs>2Se5Xy97&k)+`^32aRpi(UsJVq`1p!we%5zq2?>@>drk zap<$gDIUyR8VpMdDzoWSy{&ib^U5?y%+%1`4r;>wV->*O5tH%~h06vy2f&PQ%})1* zH!9;*lx!T@vq3@#D#<7SUW$;Wegg!0YHfDXm3LE9#dY~iO5~kCCn)=+Z;lpbmRchY z%dqnjFF{A1gmszNgFbqn9>+|4qgrjS##I4j%r(|~obOqTms3g#UtL&=g- z>h$KYDz#BQgI!8P!|h~g4A7=9tIwx$dAYnFZ8)71`BV4z_k)ta%kbz)$wqtg z(YXf_tw)lhfT$=K1Fg^-A_*tZ(J{yzqEhFi z$j1A|#ly)wHNgI~!wvX|LXW7^@KHonx;AkZYZbEMBWRTni6W_eP{o$q2?`mzL|vz8 zSa!hWJ0yWiOXbM_d(Fatf82l74nc0zT%3ex#-HeaSMitraYu9>O#ZrV41N3uI{g>b zQ5NwtleMx?O8L8Oe<>s2$Us$~c3`3ZP+wwk!B~xzMIu`Np^V`80f`iN2Q*HIzqi=m zVu=6j?}~7>X376oydMVnossd&=qCP$+Fcj|R5Ux8PyfGd5QHSk%_}ZW0S)Q-tAyYq z@^D4v$D?ZD%EOd0#SdqpF(^K-gj04?0bD%nbk0})<~lluo|c+*?q6kb^W$dco`se$ zWcI8-uIGyn1hjsvU(tJd%T;>Lt1e#cy3)rMw9qV^#zyTBlIH%;+UdrEDV)Mn0n8vk zwgjGlw_QAHN&lGC8-teat;uSR8!(+*+a_0%E95$EnE~V~;kBaTki7b>QU(s=1CS25 zbUk9XwzTv;>h$Tj_1z?lQ>Tb(*~+-F(U=kxaOP(z0Q0B|Th>I00IpO$ayUfGp~ql(yNp zO>1DQ`dC@c$5PLq@n7d{UsZpIPSd6cC0#y@Br>XfkUoT@E@k?Uqe-7E_dyIn?VT*4 zoZMJ`e*Wz2EWo1YI=zc8wj>~-pvtX$A~FH(4-b$TaL~}uuIQG`Gr~~!*E%Te++<}d zs1RUbd0h|P^V7@HNF}1@rlzvkZR4$!(w)VlaEq&RZU7VxP&G?CGIETaKn{S~J7_XG z@6H0deNmxZ$h75biDkLE?c?=&waQJygh#o2D0MDBsJ> zGopnmk}G%{wp9-lr&nJq!wvCJeN1=^Eqy|SRH8WZV!Le=rHnsp(OBv zMoi(j>H78crVLBB>nVg6?GmlY4Ik28{f8)XDPCdO_y6ejlG%b~W2s67gMA?%TbzD| zp$$#CoGht>L&BfTm7nE{UB#b;6$$Y8`@Zo3S>`fU9kJ6DGj8sW(~3-KA3oOM>U8a~~*^5qc%lwnF#L&b?4?F#_t3rG-Tzy=alA&8PL` zL(3f0D&y1eea@PWOE*P?vsxTfYNa;(#bYUupUTb5jF53~R=sE0x2;X5->=oRn%1tw zD(HXGZM(t^dNvdHkcB7OW@DS4RR!@ldIHr=#lgeIHS2*x{C>2vc~G4p_Ss*TWq%{J z>G7C_L!Wpnb00yAvvzpg3irEH ze8axnmYHIOB-)R#EM!wIT|VIDYUQOxMK`Z6pWEwwULG-ay~fA!085Nsm5xWVBH&y( z-C%qH+*y+vYE>H5hA{*kKt{~QQ0cci6desG5tFS5AkKS2a|?_8=_0sleT`>U{19K0-OjxF@qN!X2uM=Ez+Xg!`O`BpjJxUSKj%)?TV4Sa*z`wX65r?B zk9A*L+S=sOO_2JqS@Q1AUI25Y->1RIv{*_7y=`o~jG!Qhv!8WW8$IBcGM^lOR+g52 zERt@JPI?7$X9&2NfXE6YSvPV&Uv4vb0?0{>^fLNzzA}bgiN<_f$I#FafQ|=0XCUo5 zhKD67DTjdIo98_jYJ0jeFueiDd$UC{93@eN_IH;>PpM3#ll&&U&lcN2xTjI)%vUX4 z2k`Q+1ieYAk&Vqtop}tP_XH@7Wi*)pen8u3&$`_;ncU6D5!~g+uDl#(3wEL@V_Aif7e&}wS`%`^@EYUA19*M1z zA5;_-^{dt4w{_-3`|MzbGJt`(wj2J}xuSz~DXHE(SG6Thaj(5r=&2#irRGT%>1 zAI1l{ZX&QogNJF(+z3zkZ$qX6h)QHQ_|6%Zk?cXVcScPYa$`{F4z-}YE2?l-I?DEz zb5|u!*~(R>?Ib(+x7+~P413>{V7{(3JNh>G=rn004e3k`d~iAl)K%8$upnP8srNq6 z;b#2ko%MM5*Z!aX^^9(8_ZR(KUfyhRb<#RIISF1*tg4ERnb2-$^gQ3-zXtL+OD4SWB*B#9yvX9&-<- zOJNDsTU!aaCB=P!@@c=@jzWKVS63YCaa&-XWAuz*h3@@2jdg7nBLl)S+lqVmOSAJq zxjWQh8C0Ew+E1jBpo5N?8&~bxwZU3lxncqZmXp#oP_O;ET&;9+{-r7K*9&iyRnp|l znAh6@UMb0c(7$A&;Nkorkf1OEbG-QF`)b~9^Yd4!3T6JyrxWhEQkA#aQnd3?gHBH8 zT^$o)LUGA7X49<9WPtq_J8b6DY1K$cM95~YVnM*}W1dI(-dM8vCF;lU}#DIhsDRh^a9VIjH}XMx7j`*3AmUS3YB zdH}@GngYN=0r(`KUPKAmA2t9F1$m~@a#LF_!*vAZ`&(?tF!Qw^Wp)|tCu&b>xLoli zoB$8zJ(NkIUu$zS2l6XG79naK&WFN6Zl6?7USD6KfsNer_O`Cuw-0g;$n9WJDO&tU z#3>>15v}=zNuL?Pfe5%CX%%ycd^`c?eK0kc5ukiwbZmG5wldiQIyxDl!D>7uXX&m} zAbrro510mmrgpy@)5EunrqxMm2X>!#2NK`F^`V+=M&r}(qeEITKL7$GIBR=lH$Du^ zgP(Q`6Xn}EE1){cra1u~fqntbK&TkOr)j`6w_x5|HIt&>Ei*asiR0B~4`1luh{HeQ zcCFp%si=?|Mk{T$dd-{7X;7dpOWtrzpV5a{?y40twTI!On@`b5k}Z^-gcv16^{tgY z6F0@D$i5z3iBnqv7pz@SFZ_J!MaI73lcCYq?chD5o8kMGP$rOikMmh$rqrDb2I&`A zPlD#qKZu}nS<*#x)+ee3ozsSco`=9`~L+>b%(iAc)RW9-$nYqG9TwPf~R{c7Q z9^V`eEJvZ#&TBHy#HTESKKS%{tOfU%PD+#JFi}?o*M<~5P?3{6{gxN$ZFKetrFy|= za7qHZMQ7vNA2XXMQwU{P5^-Zey62oisk`pNI^)53r%2hJBK)p9?`poto+H7yZu@gYNS>~?9j&y?AOp@By;`Fpxr}-8GWd7z z0lnd35Cx2)4M@@T)g!&}bOCvC3cggo!SeHKaOhdUgy5TRJj$O!uWMqbx6$qIUBeO= zrfp`;gOjjucZNYs1GqWjzK$>g`T18rU-8-C9iqwvM~Bo9+0no{(~%I&(a}rTtS?`_ zcwCtYg!&5W1d{q2L;-%3ayN#bAErh4@69K&g=fabFuap!?kGd}%*SQhnL|C)YmIia8Y%$i zFX+1>pEyzhK%OWEggAwWwl=)WO@&xlu$FW(ng$95AhQF3IXjjC8>(>e3sbF(O0O@% z_)wKcKwur<{N2uTxk9Aa;n6K$cI%yCkN}m0iFfZp#>e-*J;qTY8?VtkFBnOt zdm4z?8_#)Dh|`ga2dqtDUt?KWMy?k0VeC)iRL4TScQ!Zuu`sE`yf)@5+s?s<1kfcZ zZqB>IMJ&fNxft|2O^l5ZJ|1)*Jx`ufX+*7pBBgRj zM`i3X`|((>L5MXcHYP)ke{K2J>Ha_vFyg=bMK2H;9W`2z`F)YAF z;GtP>zW}}h<2scO8weU&epCk}u7tW@FskU<33@Ag1R@<40E>dh&0*9<_!}2-z^RBN z#5b_Oq=E(Y79A90_tR6j;snEaTBAG0#m_7$If6+vO?*0hUc`wXsunSFmvY|GBz=bh z)vhSCXjVhrL0JxFn!1eHr?%0pu`IF9Uh9(sFO79_t z@77BHcEkc-SSlQk6rx4Y>XA`lGHnMeUKA#PiroX}y4|E>*;jWCLx(`rrbrM z!W{t$2Yh{o!%n9UNJ?}S=8{o0P>`dLLdnU#1lv+q3Cmu`A>l!qk9wkbY59PO z1*CQp2?!v%di2I}x^fle4>x+49xIAU--nL7(k{3D^AX;-d!QJc-}Qg{yILur!omDf&tw$R4zrH3{Z|v{B5)Y z)cOrSu&ev!l-z^8Vs{k3zU5`@74^j+At7vK;jPY2dz4@*7iFhG5}Z8s_E;u*xDhQ; z<_{ml7quL`4YH7!H`RL|eq^OM)Ieu-=e|9EdA(x6SYCI#D6xyhKQ=ZN$YdAEGg*he_?1%X6_KJ*(2P&y z&^%*M3mEj>KXnZm!PADNF&QKNN>|p?urNx4`s&G8SW64V1*mI7q~TnSR?AWkeH3QN zrx%^*_YgIf+GURcN04*|MzH3jA9}rnu@{G8VCxW^RVw2AK>A2YNP70A%N*NrLEZqz z6o~;Xbyni`*~$S}Uo~Jq05Y7hNo5AH;83^zYym|KUrzD(Jf9b9Nhho0lzQzz<2T7Z z^y1%<_;?`Aqi>2!e$BG-aX5zxiV4?pxbIfJxqP%Cra}-QtDPPkx8qIRd^(&deycGo zXme45Fe*CpFJ~DpOC8(lj{csGdnoL)hXp?ZX=p}5JN ztw5r!d8>e(EhSv_o%{5*07B41>0u$+P=1NyM(F>c>?^~nXuGxn0qJf;x|A*frMtU3 zMM6rE?vzHPRJuV@6lqC8kdP9j1yMSr<6Ay=`~Ld)!LbjN*?WeW>ssrqrEZbKSQ>B` z^+>CX;1PB6+spkuP7}NE&>O}gvZ%snBTpvI$w<(ptL}?72PcpgYWr_49FE^2yBRls zDdfTN@G?CA74DBeaHcaiWP%Ia7wv29mrrr2gw?Ceb6l6!w|U5T^^B%_J#PkleNX$! zWo=xg>0UT%u+TDid{wpZpc(Nod_^%k!^)bU>EBB(x8 zzy@exqoa0&rKNA8sr19*3GVEi*-l0iSPWe5SZ;_Gf
      yk1}drv6V+uiXbF{Iurs zSFYmdWUSK1VO|M;hCg9cpvb>YHv}ewDiSWA`_r#Q`rAR3+hK)%HDA*~vDfoLR6ilS zO8AUy7^gcspI!}s(m-C46HL9Q+Q?T3X5%wOoXqvmFr{w<2g+Om71{P7^4YD*chM-{ zhAQ&pww)s*Yg~r$wTdY%7@s&=h#9kDE&JLsEsi)W^pCBV_BkXnb z=x!JKVjy+e=@%Z?87h=9q`y?K& z-BNcm>V3#SeqB{sH4dBylulNksJZ<$H55Z7SA?ooyFAoQ)*D{;E!*?xTo>_)W~pCj zb`YmdH7HVCXnAo1)35Rk#v_#{Q(cMioZB>lDqo}h1~W!EqBdr#%HNMpiqE#ZO~+4* zwiEGcDQ()@7V#w^L><0(f{r7iL$&fJ=ok1ru<%YI0r_<@HeFCQbL*0dQ@d9#^~67x zzt3D$;Msg~I5*SiQP+)Sb$QVYT|K_LV6mV5wOmP6ZG*x>bu%!m+4|Jp_KIa2DpnQ#xn&5VcF(vk01CA7S3-;{O|SUsE3BJ`=L?#zf1XymCgz_s zdF2XDf7njhgNx(4@VVK)eKbMKy5b?NuB8>DIGbTVGVZaz{uz_IQ3hX^kQPCCb)HSE z^C##nn!u1NAaHIjI@21UR^f7X)T%Gxzxl<$t1#h>N2I2bD&KyOz+>~+(tJ^UpvR4>X=`<|8cMW)r6dpzFa0=C zUe3Z~D?2^gHvfdi7LX<2L^6dei+HAm%X-53nnp^S`1Q7?9evFDUaQj1*iu$a-R%lh zGW|Cud7ApdH7)~hC1%PnUIq+`a^K>2)GzZ~n(7*kj5l-9*Jrq%b(FGLR`&e)8#79= zw!VAemRe7W?zcp!F-x1%p?46+YmJqT?L@qwtaef2rdht7X&JoWtX+|`M0b64$bC@v zFHbo;U!x!+q2T@rU?1^-DdS0KeH`anAKx|sK4;Dj2?;*Wt^%#LdMLXczIbIaXW6-d zauknY$1}ZtLs7lFF#(X{MPaT1-^;WUEAAe3v+lvi{EH+ zmk3@a*)g@XzgyhOs>)^4pkgJ=K-Wt7B|`bg_sdb5`di~q_3&}VpZHvjY}&(HBYDrf8ijXB9cy?3W3 z2}$W8aa9g3EnmVp=a88QGZ?9Hzr=F+SM3B&UJ*A%CU2#3+zzZ)EI5;XvJ)?dqkkHe z!jyrohQ{`WH9DT2Kv_DBv9vHFYH+6QvDQf_%jm0DeEll1vnME5dz_hRbVesW3H0V% z?y4ZXW_`k=#h82}#b+^Fn9RN*fSpgLBl{0sW1E^Z&DboNt5X`Ph}xpm3X9_L9X7_k zUQX7FDE-S)sV-?_QBt*i9@o65Oz)B?9?vHxB;6zF?1>yPHqlnzx6q`+dCOPLuE} z3xa~qKg6)Vs^{Stg;(shz}>w^rvhVS(jBl>odc+04RlWC5O>J#D zj!*f!t%aQ9Dzu1>;VXep9gS5y;P|+K6pEbo=@nv(t(N8rIhSmtVvF!_>5GNe0^XZ@CqDz4*^B zY<~d4XYa!oMN_o@FgRx%K=_<-Jj$5(i-`E+*Z%(xFMo@dNvlw~BrGZXM#)C-$$#En z9I5qskoGffd;1?pT1XboVr#3zyubkK^r;6))Tq*M z&5ylLzU|z-pJ|rq4C)F6cXxNM!lbhaGaagHE0^bw9wlaRW=RS;&wedsscU2S&nd$7 z2@JGtP+y&EO$AHv^c!cUPln*P-??j<1aeVqb)y#F-sKOZUmpNMQ`#_L8`9?CXjTD#wdn){B6O|VPceGKuQ86*V z_dLJltN>!z%Oj}`C|4i;7}e67u=`x2p|3w#>8HmtHTEvt>+(WmQ(l&mtOqo(30R2i z>@PvQ_9;dI6+ik9VBX&p>HD5P)hFZfiCbJ;$Y>xweUDAShl7qj4#HclLgQN7mv=E&!_{WkP??FoU?(#y0;7;7>Q`e={8!!a7iD@Dj@0Y4l}y2&t}fPIq(v}h`T5SaQ-EhK zw4x&OJyD;6jzRO(JxI&|uhY!TOd&`*E9tB=1K1ED8H4N3fwl3M3K}Xm{78|Y+3Ps8zD7lw`$ov!);B_Qpnta=WuHpe zlJwtyNb>ZyLjfzzuEqC>At3lGHEYd@ieg>t`Fb{u>)hRq#IX}g1aa}T8?$fCX1Tu-Y_U=u#Ya$|k(%B2AMcZ9eVi%Qs zT>9+~^m{ZC-}0o^7*#Sh#JwX($}hL?_Z=%MJp z$uAj%?C*sHzL+nq0r5XbpVwIT1`paVT;2UZIFItDv?K7jIK@Qw`)5amHE#}|VN;HO z%oOqKiF^6VqJ{OxsDLPNuD6_OiV zgY|Uq?F0oqzMdtjvrhId1lgYu$wd`HkVSv;+B{~LM1*EGieF>9V|}L4 z;c#;U5_OhV>*Yr{b;|`sW4$+~h|f&wT}W<=N7B7=bas9Ob|1MOl#GmYKnmA3FOaBY zq@{D^k`>w2X@bl$5i-vZuQ-B>iRq1Xl@4lBl}i;9cIKejbtKM&Kku-w$VW(Osv&L- z_@0L!uR78Cv(eEZamD~NiEjzIVG{Tzgjz(-=Jgi;?8K9l44Io7Nf?6?MB~DEv6g znU6E}f7fU}8n$p>e0<_0S_Hkviw;G*^wrn89%+CZZFk3N6^xhP`VCleKUi83Ka9ZH zpe7=UJOg6lSw_advu}8FQ{Pgm6>hmn*MjAOHZKfxu3cr|Txz94bo3p`mFduZnQ?S{ zeC|Oyi1`EKS=ZDJ+W#pujGaHJEcWrH4JUn!4Y|14Z=w1e)uaKh?F+L-dTC6dtkd7>HCizxAW1GCC%O2m{Q>}Z7X`9Q9k*2 zUUU05)eE&e&6uq+$WeD((;#>f3rAgzDM%vy)`l6hi#8Hz!lnBxz!>&2WYJaVef70diw`dbc zcx8!WQ&Ps^FS7fMGnBIiMA0}E1ilQ?dU}JOy_SGZ00|2z*{YcRC>O)lm$wFm%3i>n zLg>Kp>FF)UNn{<R4o*!FvL6ku$8a81N} z669SiSK|?BqD(3H?2^R-f?&ZPEt{y4i=Tyc^@dps(v-v!FnfU%EmxhLx6JMBA2<8q zpXvVLyS@LVzR(-}|9E>1(DH4f0#^FdtDP#2LJ&igUT|A^1R;e%$GiIV71o^1v)hmG zc`VB8?CrtF48*Zvljpl4>k>w#6|;s13ze;<<0V?SyC4gID}ZK%qGR46Eho3|f%cas zybG>7@Q&Z$;X14R5@xIqf=mO)lA5*?4HPnW?_oy0qyS6L-uqQ64 z`A>0n+by~T66asZLEFrz4=&C=7buaYKO+@%F^6cK(*$z7d2kkz>p~XRW3^hR>DMSL zSCIu}UBFAV1~ntd@W9RW6KpPFA|b7XDn@Nd5+$)Jw{oI5b>Nyb*bOg&e(Z3^D_Ys} zq07Nx05t_gVcwGj>A15r;jxc{gNNYB;oxXoC^o3IeOg_;6Gt_TLw#}8UP3~`s#`f> zO-q#)@n`_d9#BD$GlyABD}z zxt59B9^9-%al zkMGrfRvnDbn zNk0-g@`v;Df|LVnl0uM~liCMQmlAdCv2*R?6$|5q zCd;lQs1SV5$O!Q8fPvR$HOqlb`@a|U8$-6OrDc*S{lv(~`1m*m4$ege>TqOc=Jk}_ zoBX+Xc_Cc97SG$Pu9#up;Z+na?H$fz4vmNq>JBh1RHI)1@Fm-M?z-__DaK==e-~N| z+l2V?5!pQ7?ZHO6&CK|TDH|o=Qko)>lAX);Yp=EN?zRg!U96to7|YHpDM5F}bxN~# zsgC^5r}M`^`u;t(H;pu=`RWbr;{1{l|8E~RlG%!S)AZhH{G);VU*Ro}?C-}b+o1is zW3?4EXy0J*(xGZz=RdtH0{R)zukMuSO;pIg9E!hgjU#2~a_^EP|L01<+Kd4*NdL#v zof3cRZ2vf-FXTO}@M0?d=K_c$iJ|;*ly*5S()_l_ixNV&oQ}fy`)wEul|j~`fNR2U z2g*YKl^fxwS|D!!rQQIbbaQiYj0e2AiokJ$u*axO*94-oZoMG|TP3+`@-@Q$cBtYb z$fL^2%1In5`PSfIgBUb}Mh_i28*!y-&1)bSKZFZL!vq0%m_dLqo$TQm+5X zOL+u>_PMRt*p;xUgr|mvXqcD|K)-Wv-~rKrs;Umn&CRfA=a-c&E$w+M_t|jKiszX$ z;($g89wm42K(XDQKYxOGX%zS|u(mu}8`qdOd~^Rp>*e*S7C(nvcCZSL&Cb3X9pw`c z*o5txOLb-NQ9Tsv;IS=KeW6ihj?cHad0{z{zvHGBos&b$MvkTSz!lu9ay>E-Nhr-T z{J6@+dw=yDQcf_VHPtKBb4F6wDRHjfLGat3EE)_9y5bZZB369BQt5edW+2xSmMi!B z_B|3Ne!{jBflWw7#qXTi5p>0eosDh!)xC&!kTTGYAn1D(Si7f4pXWF}F7O`489WAu z_rbQyGv2!^;JSNE$_Zf;`p>Uu$tfurHROX(Bl1kzC{xHiv%0z$+=~BXImqJwn3^8E zp`N`Rj{R|MqLM>BdnlQeHy@Su==Ag|Dk_Mb{dd29ui}Hd<>QOn8=IRc+Ffi0HEm52 zau7lhA%T*IStlI=APMyDvdV_JB7HYEKi6uBqW1lE^O>p9_%(402+VL12`bDs?F4HT zz`kQ?4P7R94p85^EYLxcMYy?*&Mh9E5g@g`!pCX1%F9W7&RQ_#)^yLJ$*M;HAB%*D zh|jhkd6>#u=;4pffoHc8*i66VDn2cxGZO}LfL&W)&gH4uJwY!=#}g616YD;r>9n*o z>l;&3abbudBym)?M<5Z8Ol*5Q?HTE0YXB#YmZrv!7yok5{CXJ08}I-tC^T!8sIwmn zk_gu4;peXtyJ*W=+}_(G1PAOR-wSFXx35P>+|t&I>swo?ymvWROKuduett8R`&V8V zrpf0$uy(ohmc!=Rl7)4gbm5n!=s%j z;8Wp7FV@F_0c=}YXd2JYd>1|k8qxFZ)9>fyS(&3)3=8@4%VUtL4hDEZ*39G-_7r1>qi`1wf3jl8v1kZ!EYy8VdB3cjvrT5q)X-nfC!tW49K4#FXH15efa(}F0KYe{N-6-+yA6`^cGxuk_ zBW-RdVBepp*xjH;~>+PwzCF!igDT9A+ zg`gMd?k>#boD}#w|H1ck+-G%2L&(i~Yk0}|9s`&&@l>HwTZi(;Dp5I_#-(g%V8Vbrn`zLZQNrVk!b$Tie%7X=fR1$zTCSlLGDj|$_{k8pA4fM-{ z=})R2f<66~dAd05@Z*|y%&&sp&3p6n@qrJAxkgi8gW}3xGP+-)`Cq#EO6G(ggJw)) zj0fb9q}j1zqQDw?24=DL&q%kwLcS&P)0YOdam@1tEAG{c+A z8y(e#tl5L59(1!;%3crcVgDl&Mg8~sBgPs;ZQgyBpYPvn@hRr`=O%0Aze)svAA0?~ zcW+5-ubJ2usRmGsc%ugBhwrbMQ2qPA!8SfpqeWg~ql^S5@prc4I5?j`tRF)xN5LW-sh&8K>;#F3j~4%_O2luV+nJ|+)z;1NmSq?M)M}C)O#1=gIu_mZ+L*HO z6=DW-XsNpnc2X9dQa;gP_x)A;N4I1$gjfL-;|n*nK~ zj+8}D1Oj$TrhoS5GbCid_%XjocQKY5zr7Ym>Z?Iy^kzZLcnm~~G}>jlwZ6w#+?6EqOZmZ0bt^aovOoHJrr;gG(^H6+r^eLZWSaxAyA&68<(!XojQe0w| z%>(eM_;dmLXsxm|tu7)g%;E>z`Zb6YQ-{m%^e$K?j{5SA?#n4ls*mB=)2|_D?DPN| zD2U9=%3pCnxFe$_9@~51i)kMkLaReUI-|N)=;h@#HKhtUpq=1Q0xNDQ1V_a`|Cr8u zrOYoMu`Njbm7Obf)*JN{o@L3tt86E~bmVW{mZ9Qc5&yIIA2}}jo{AoB%|(nPfx2*e zdmE&`^rQBd7kQs+dM_y5R)^5b?+<3a&=ix04eLv1C((eD(?(x1>rI`7&D*zco3*Ti zi2NrAEce$Y+{eq0^;u<`To!y`#o`*|F!7fjBxF{-Y1TqVKoe89KFeNvw*48fN05CYN*6x8R#;w}T86OVQCOm^Cw4NOs zP;yT-d36-2=ufn_Yn}yR1XY-$l%@H0@S`SA-tZ`>H zJqq#{2|S!~1%P8^-#%c3CSps>6Vj^GZS&g$m|wl9A}h1(>Vw7Nt?QC=IgS)G%-;bI z+Sze_SzaE2MScOvs#R57>mROSkp*jnV^an(wuNo|7`uszD#T65a$T?T?)Uyk)F3*dRbhlgR5U^Pg{jVzm5FkYhnlRLqFcLZ)oZXW&er3t4=LydG)67F?m z$-K7q1?)%#sW%c4>J{1Mcl^)rZegy;d`k%W7_&Ag#)*vlMJJ8y>_puS+!{mT?mNZV z$a@kbk4W|_O!h)5g3--;11|lj9%Ij6;pxPi)q3kTM#`B9k-t=rIf!ig$XcDH0$jJxMg97^ z3K04Du$Y~3ByoY)G^{d5_xPG8i``}MX^XPp{JffQw#DxgyzP+wdTY)Dh@T+6uK~g? z8Dj_)&m3ZbRq^U*!trvd*ROS5-t+291X;?-yzDXH6Uu;Ud;R(t;tclZgZevZv%)m! zoNTu)HBG5v2#P!1vU#HD5kuLSY%LPyUX)FKdCPMJlf#Zko2UVtcp~g znUrWg1td;dM&`%b+T7bE&deu}STpsRIPgxt%E1B75R0#`F0D~jwp0+(fn9LG(fh@( zuvIkDgYw3IRbD_q0OE*>O&YH&0znsJ7KUk0yW$QR9H7Xd^(b?irXGBLtdax`I`KZC zb-?*gH2;PBsV79l2Cp6K5~@Mij`ZX$NZ~SF>_pQ7ix)Zn*=CD%tO8LR#W^eQO={qO zdZT83v_0&3j@!!QD6*4D*!AAGyh|%8KR6DJeM=Q-<8wW5%h_h&x<6J zk$p|*lR=Uacd!REr_$69pCVuVRD)2~$T4-<2hSVdw?dtaiYj_;QvY)zs%6GdN%lsY zCN2N)*g2O|iMqR_*F$xNKpbH#3Q=z&{0R)8%JS zrtuvGi=pUzQD4iI@eYsqEy|)Ru~QDBW%%N~w*g{!k5rN?4VJ)7lr9-|E$4GCo^B1` zcS?gX4Xy^Ne~BfwU*H{8p=+7Cz}LHA6j#$9m93jel``^yFH9~%L#2IueAdN)Kzw7_ zWr>yzK@~`oR~A+oq!l4@ss8Su=;Xwr6#49|5)IQF`lqbaHo%qVWyXutF5!lxnMXv$ z3!Ps&f8^_H494IEYR|>c^%sXl#*?Pb=Xi^pYv@vBA2+9)e(Y?8xGnid&H*A^P z{Vpd#zAXSZDk0%lkO6IwQFy>d^*b){p@Ds7Palyq6fm&eV}io^bK{}eC3g_keUaqc z8#<*XExy0T4QM)BSX8?d~wf^m*O!a7Cn@*()DPs zkK}2dBWQ4g@bz+kA^*`2O+BD|n!tXdO6f3K%xe7fS9mk5RvM?XyeujQFh0f3G)J-k zgBXvKHaa5FyAhtj7c?hLCXI2CR1v8e#om`U*ChB9*4EC=@bU2>dpTsP@ES3_bUy9u zn<0%`7RS{L7MI7+d)&#^=Mm#HikQ zh+^;!B#5x-kiz}e#BSDtW|>REL}905Yr8U%{FN~GR*AI#N=ewr*G~j41R>RY+}t_F zZ!s8^gcnHUovvd42niUjimh*GSSSvsy8U{dmEinCEZxK6T89abE}gd( z#Eu3O!RUVhz(HHj136lJiwNGuQME#6Nk;o#kPU6tl3DG#98zNzI$<}|uY?l)BcxnR zs?UGSt541}WA?cwtIxG;t`2orX@lTsfiRd)wJ$hAp(oBs8>h3qQbs(KLq6}>!M3EZ zcL!04^ao_q=8jnPP&K>zbkr0%H0b=OlwTr8w`N(i{SL|x2*>a6om9W-&(n-*SIoIo z3c7}2fIV}tcB@{SwMfLr<7}r#=&bDCr$P~BJV7Kxm3c457jJTMBH~NiT~W{!gJ!db z`oM*$Gj+Rk!6106Sd!V$Rxa+$48RxxC&Q~cR~rcF;H$Lsc zdse}7$HZXwlhUiKs+H=YcttAImqfay31dSWKiB*PKQ{picyxt(Rq~m@OVZselL!g; zyp_`5Fj@r#41K6jop{STve~cU!;Bzg8`OY=Fyco5JdgOA&llj(5C8Mfh|?vsP+S>C z!L;qrn(O=;@*`NPf4=tXQf;X!73p*E%8D)BXUtcI0BQ82lZz;;&k)ochCqzGczR+= zBv)Y5)Z^T;e7twpXTLsH&|iAoVngu7V)K*PTVfAY{}Lj|&#&PR<#)?-oO-Us(4>E^ zC6)ik%*{P~yf?k{go;H%xfQKhoFY{pGebT)xTr;&gP2DGi6J`)p{WUPCBNoI8A*6( z=zLXOd4q68^j{>(d@D`1fPid=xh57?+~f8#%MB`9zWv@(PPKXWu5RDsba&~$?!aH@ z6WoMM4$2L7opL85#CdUG^&uCRwct3`l{Qal<^FN6zl^NTG1O(7yyJ94T$kBMQ*g+$l1 zY^9&=OtL~aXDgQ)PX?Tyl;yf#oHIN7Y2U>7J5$T|4YFPA@qK4MS(5vAQv=!pX`zlU zc8uAz`Jnrh?R&oZ&8Oc!+y#ueA%oxHCK~V!!EU}PIyrZ&KD#b88JqZ6mpc{O+1S|$ zx-LGzD>JM+VOI6*O?pavL%UC(S>U*TB@V*LOn06O)jVZ+ek)aBN=u{CaAD=AqOW6? z&Ex5_$t~5x z@juG(0HL|IDuaaqjm zFW;3_7CYNE2(|mU*G_oObXKZ@o2A4QALcrsh%%t;R=fsFQ*uE;SBX{+fGwlFzA3vF z9kLS9DGgBBE1Vus<+J@$17sy4yyz39?`NCUIavQ3O_b;qur}db?>v`@Rems5mf(Nx z{Wv@&#mjA3QOnc+@|^F&I=h4IlXRwRLv&5u0QL3jukX+Nc)<7+1q*xUyW!^o;{rbg z)ey&VFO`k*e#=FIb*F)0E;c%j8%!-m)4OAR)AXnFu19D5-|}&a;vIdDvx;CZWH(W? z9;|5nHaXC7cQbM-gBVkwRHr;pg~RV0w^G~9dV+c+FI-FG=KHfv%2yVZ)C4*oh*yUz za=)D|UEdTF{5nWQKyur4A?lVZI*QZ4M!A~=O>3+Wku5{8RNm4eVPXOYZ>=$mKbd{& z-l)9`k*bc4SlF@oAKBUWR(k1;P&og3AcF=~#a~iR9ah$ztbhwh>kA^I z^k6#J?|&88%gxhEv)$0IL^Czdtn+`cSD0PIQ7N6c8~JpBp_LNYdDWE1I)?h`>Q)#1PqLf(4nUb zxhuN4?MC8TEexU_`yQ8DS>+vWO#AGw(xSbw8!q)bjoT(tR91#g_dU$=%138mNM_{j zfb7|MqY5bM<)lNwW|aLW{g?g;!JzzOXQwqJO#?aaJXWewX*wev!DR#KsE(i#bLsIu z-VMvM!he7DYAa+=JsQmP!@|M>?iw=x;tAeEpi!&s0CmmXTWGie;1SseBzv@SuGr_% zVe4fJ6eKcic$dgPDq^iYz7xxCBoK35?2m)F@W+e9PL;oglieVuqhV@ z@P{`yU67KHgts?5TmxEStg{oSN?QnXhBO8Ok;u6kMkmxqm9!&Ta(t4DoyUPHtrrh( zb1|^8E=MThc<2`H?&^9egWJa5(sBFECFa_l!WV`qBJSTs`4S#~^f+(S^&uzlTit)L zTi{5AkzZ1`ggWZ}>W!e+MW&AF6I3xGbl+><3qR=Hd8M=nuh>bScsG3W4f&z_=)q<6 zNR3K>D&?4d41cjvM)XXnQ_Hu?JIPE{79AeNx4^0apfW`!clrLetRg`{A|%t*F~9@5 znn?~(290`?J_6j(=yS+%{}VXoATd7m`E!^aQV4l&!onoPxW@pm487eY;LtWtR)Oo?<; zm+dnI^tU^PM#q(uMAg;tKUe{ZuDh%2;g7Ev7J^l@_;`3+0T=6mfsH_G2fHzPZE zY68RZ{1jb7iaG7mKAdI-PY{`BQ=)|89900 z#^%g)_JqXSA9Dd*Y}z2!Lt-q4jXREOL2GJevVEA*d=JRB z*jx5=vy5u@coaj=ksr%>etpJW8^12%zc<)=9kaLnAVuaH8*bLYT+?OcvBSq!zh{$G zw%jEho%vr8O;5)+8+O-iwEZ2@@of_(E($0)>9|4K&7B@Sab00ozCWFpm||(**(FWT z`qy6Gs^=gCt1#WbzBv#>?ykYIiMg2kRCS?T{SYHG8L1Q|pUhz*@U!6OBrJtA z4o*&29K!J+YG%Y++(I~%8#dB!^eTU$`IjM>Klg&e8GpNFjvA*eMUQhTY0iNT1> zMw4$)n}QG)8m)AtX`NJ;o;qvn`t`hQil}hVgrg$X3rReQaI3eCeRBt!kdQYLhD5;- zk`Vy$r3t^2rj#8W36>jXpDsig##4(KHtLeteEs&wrX$=*kkbOZg6|cTo=mkLd2N{@ z)S#8(hbD^po#b=9Zqv80v58I!$F`W0H>kE`9RV-~Qjal~l-1QUL`cH8-bzb%N#)7Q zE6XA=em8xz+1fCFh-az6?Yx8e=9RCP^1Qjn@rhPgG0V3_7}D)66QO8ht!wsPKP@0~ zCaW5R+%;@5KUBWl*3vQ%dj6R%&&ECSah#SA`5k7@Ied}>3Urs+H;)oB^^aDdGh&Kb zsW+GH$P1PZ!yw+d?RUa3Ii6jQL&1l2S%P?6Rkcmdy8^ioWK1^8%ot=#i?i7|_56>v zPON}dsZ127H9WsKCD*S?1n}K@tn}Urn{|O};)={)^>H>MVx4`==*3LqBTv7{e1+PP z0wtv|x}ZxV&@($O_dRq`#K*aTfkaW`Ss8VBvN3%bnr2m>`>qo8vi6bN4Vdw;1(yeI z3mj4$z8?P%9~`cE5V))a)y7V`!k|!uIKB|npO9M2{F(-2u%Y?UN>X|gn}vn8p3KcQ zAG)=QRLw(>q=JU(S3a5`Q@;h3qa*<(zGHoJQ@2Cf^)ezfv^}Lyh3t4SnKx5~*2&Z@ z^YZ8yRvA6I6IvhMRAH{Jt<^H97%Fljq4aaKFQD>JS2qXsWK4|pJJcc5&^sO*@-#?@ zYF(k|PjYm5xH~g0~9PC!sn_5HQ8j$9VihzuMIh-ATDcDk0-E3SmlEosG()*E4lF`w%xxbgAgRQvBUY~pl8-w-_V)KqfcrK=BB2)qwPSF*Z0Y3QlgaD_OR%D-5-&GEX!^hWecQ+ zH$6Nx=dtOqt0q#3$il*5zYKjeRI2jZ(Rcj#Nqr;2_YW^XZh^_R#uDp!XVQevM}YowVgLtea^KUm7_3R zi=D-L;XGaz*!P?=S%$CS_{&GSLdLHf1V3TV)I9#HX&3iFvL7RJd;o&kSQQ4-p%hL| z_iFV+G4rD#QU#GV3?6mz@$%0!;SmHQ)mD^YCE{%ZFK-FMjLB{$2t+&eq-D3hBhn+O zCqdEtPNZXS>&6J9qF_{HG$C`G$M+E`3}OMV$*}b~PWSmljx;o`Ywf7&NQdzSN_y>r zpg>-^F7jpJB9z9liM|I?RGt8lZH2R{V*f$90oj}ZQHlkt_0nG#jlMYB_ZY)GP9*?1 z|KQ;3O@5SDH#A1u*|KYl{j-OL@a))JN*X+OnzV8F(Vav@nAuJ5P}{TnriX6G5G1IH zOURHkYRcnK3TU<{(!PxS3IqvWNtg@g5zg|Ub37W!Fi2W!ZXLR$OxHQw&TJb!T*c5u z2pb-$nW(%(x#U=7Pvtz7T$cI<%#$8_X&${=-rd0#z_K%V?@|QcHIJ>XN-$s^HK9R$ zS_8Zz1yP|JPNs|<#b4Ux!_&rop>s$RWX zpPn#TW-$1BxL7tetoT?IOV8=nJLb=JVL}9emF=pzHF9LamX;%TM5>hVI7}0y4GVnj zvxIkcT(^nLc0@mtB}qo$hf{SDo4bcgrm1gZmVJQyB$$_sTEx`!Om3mYuW|Wyk0>Rj zpdDu}9uffI@p#H2f|h6lTXVQEv9Tb05jLHsmo*NhdwQ&E7=&)3h#J&vR zk@GVV=1DL%BIcS9iO%JjJ5}}f#g?+0sotPOenTCw4y+jE99Pg@8cW0#-1fX-N;bD4 zH5Z~ZG~J+<(DHg|jL#6@2ZNgQq?hLHSV!9tj!cL&wBaGI_C{u6%wna4J+FRM)GhMSshBxlFGz(4a)C=)UKD z?s3?dx^8-97>iO1UQ{zZS1vDSFb%ACVzag zGO)H&jOom%Alo9;U*u9!s-8p8uL7H({L3WWM5aha7&%_#wI`r%tN!5h;H6ZA=tu7; z`Y!+LhL17x6E1vMM6}G?nYIRs9UZ9t+teD%?d=M*k8z z?S$A^KVGkze&d4{&B(KxH%n)4sWtw*k;TF%>SB&-JlY+f6|R`J5*uT6ZPT zy-p8I6cq_n+hy2u8!(AnRw1H8fRT&*;o89yNy6vi^XtYGu0*ihbVP3~bo7|tjhV=W znou|445xPYs*A;Op-9s8as}v18!BrzG%s)=_)Htq=2Q=E$AyS0d z(syEPi#Nj)gQ(3i*7({Xx6967jBp8;{n;hV-)7G4rO3mHO-!@^y~cJoX@*oRg_!we zgLN;`!**(;xS8w9j4)rv|74$48^@QJvU*~3ljqhsp!43|s-2m{5o0$VfXeG$6I%pN zt>3Bb-ETFUn|`3;+Fh&k!CQ^r639kxVYGg*kAOhqs30w&T@m?cjBA7D=Ts;^G6I{RoS!40BBO?zl6i zqLZYN-nJJrm{eS@$&pOG7`rZi#p%&D*>avox1l|g;5`+uq^vg#9HNK;+6Uwm6&t%U zd!eEEr}3|JzGmymmxlEX*Rg6JOD~wdpOdRkSxE8@DXlEuP^we@8+o=Zy`L$y<0s}@8^+cSaFv@0U7?5z@=w^ zZ0#t_BPu)EMlqhv=@%y}5{sTs2XR)rN2n(PeozQ~)%wN;r|FrLzhI#P0&-O?HCHxs z(a0XvGh2oNk4W)_jZcGNVyNU@pCPTx0Md-CC!5a8)}+ z2jA7?Z)y`>%rOPU=v%e)D_XaZ?(9(CCJ}vmUai9Nn;SpjE!wJ0#do*Y|Nhngz2*-e z{0)p3XQCJ9XL>TjrTSluy?mfOR@NU{(!ak4Da!`hD>F4(JpV0S8DWe}^vZ8%CSjwHg9`5>kEVQ=O5!T;-yFXr7^B{d59e4wq zG%!DdSz>C6if7-lTB${SX&B0MUuHgk{s5?#5{urX0!PPn)htmMOe5?vUj+mhcz?Tk zdX7&_u`n^8bf*0&mHp@R1|@&tq_6I|V43Y=M+9f;}**XA_0JHfkp$o*lz9~^Pguk6K0Uq+G@KZ)+W{{QEgG?1# zVcctzcO4uKKdG7205DZub3l-U)#z$fKp)nx`<}8umw= zRtQE*!T6-o_QLV|h#8G;vv=%+u>Z@HOcAQDX*11*fu<6$@Q#iS8L%ne16Mx-A|)jy zD|;4;aXncLry1%8Ql8(&l8GZ_$-@Q7D=N~1z~%ZB1AYBuPBZ)t5KO9J+1}6mFz_;- zuPQTh6CQyAN06<8g88vvdJ^M{#ib?uRZbml;FbPM-DLejqC+Yy9s-UpBgcFUk*>Er z9HF^q?*^Rb`}RUeesxdWPwB|kWOl7W$3(g=yybwkaqP~+4oa0$%fHFzzXq|1z6dnr zNA*a9$e)v=@{>t!i0<*(GHvU5o$IShhd|m1GXo^H!fu=zjE_}WSg~~9{dktLFnjG9 z23WWd?goR`Z)bN|>HC3|tu2VLm1t3|@+!Bo1j{*RbZ?-zeSII40|CK1M>~0Q{Q z?fdN0a(Rm%61a1piTDI1CUO&ntLa&p6Fk3tmC_j@K`BMV}LqhUw$p`9KS*d@3DVqDiD%!RD3jk8>bg6Ho{Ug~6QkJASf718L zOx~^Li>$(_ZF0XP^7H44oTlrs>^_#3?RO1e1VdvEdT3blMe^*IFWw8MF9D@J-|5kX zPN$36*n)GUumdj4YrA2PC9PC-1C`JMz~j`bBx^kLgAbe^G&Pgp`kgJsvx7YB;OzJl zsN2aYDV2E4*jypkE{@8mgXl^JSo-KeNO{~9z9RmwtN0ncxUTzbU(4ue2sZhMS&r|) z`uAL9$~v@@$dw{i`c?{VRJvq=dVHEay0K2o+oN%^&j}uLDpwhBthVd?` zryRcz<3Qn$W(95x?51#Yyg*^k-hPZ8d%7E(>C*Jx9fF{f&MQYTOCXx3A+#w2S|g@A zu%ryrIAXR<{^lPx2uz~G+VjDsus>S`u-xy5?o~o55g9 zOAb_bvE;tCJguOR?Ko;J&hz6Ew?_8`mh;jx2Yc6vkF0WHUq9B;CR=j7M@!hVeH@5b zjFRm`>jYpzNoDH2T>LDG)?M(!D$q<6B;SID>N=;khn=blvGyYZ=}R)r zO2HYYrD1(z03~}dF%$?PO*J+2m~oZk+G=hON#JqvCD*(_27e;@e9bKFZN2a6xw)42hq%3R!5lyE_Tm8{6ilP4lI_-nzVM@HA)cU&y1rqV4(p`neiE6Gjcx(Aw z)E{-vy1-`Im$MgNFHgm z+jL;9k@r=FUE``z?>uCM*wJj}8`nITjPi+vXX;4)k09N^0jfF1W5<@;9;N$F&;*al z=^54`5kR()^OQl4yP8fd-&MHky7OK;d@2e*llipz zGtK0(Oo<@pP1{&+$7xQUR zub7KvJGj!7R-!p$6BEBuwB&$<(vbkR)ivRz$q+|ODDP@WvS_-Xg$x~nYJG0SPa%nz z?I&s{E3-ka)_Z5Ov@0`3P~^$pF5%RicrUl2Uvjc5)d9xYMB+Y-+(L$an@nXtNkNfy zftyLyU$$$;A``#r)O=jIpitWC$pOTN3VSkx(8y6Q>TN~E`zTqE*=znnONrb<# z!$Z*{GH!k>yKhS3SF4E z^AD&C_l0KN9Glv0HE!9>&CS|Gr3_-e9bk}$YT-K1LILv~ypR>SyFb1p2Pq(6qdqZ_ z2#ddZkk@tH`7^oyi$DF<_hsIzLz{M%zX2pr;Q%9{nwHU2L7kne$0ED;#33Q_?`z2aXXCZ}XymybW3dfLDS@6-+)tsH+?ejP(pH_2 zrJ>zu8!YVr0rJ$;6dvyPtOayX6P!*Fh|3uld>4j~<-llwaB>P$gcMt58K0V)Z{2gi zGw`X-Q=%e;l+h=el!W9x5QG$v5ef@SW{QJ-+rM|K+^K)KF))(8E11g4j@|jqj&1)M zSDpkJxwNOd(_ogKp&^ev7E}VcWe%I+;j6HJOGuzmO-)T5Z&(y0cGGQwjTjRX(|C9A zgBI{c3_Md^``@_>Uw0oZHl6U;*}OV=mTUYR0Kuw6DDQ1+YinA^l@KY=FDIZlb;`!Z z=4>!xL0D82?(y*9goE|=zh8ra7y!r03cr5O^uvRt#--N_P6pW!gu^2Gf)8Er1bw^{ zs4|UFzS&hy=S>?H05r+oyVn4$On#j8WVLcrks@RF0y~D(!_R^8*Ol2=D%!p6{-amD ztQ+J0dV?By_XS;WgeAnqr9BVZ;i930Egd-QfgGpepA&M;^QR`jLDLQ~Y=*$V$Cj=Q-J6U*0n-=X@*Y9LfAH z_g`bYr@FaKQah0u2+x?k5h1lw`nAIsF-{3H`S_bpdw~wUc`vVVL}@PO8|YRt#7@>4 zrp_Ctp84QY+@1cM#;meY6 ztyo9*T#jdRX(;Ta5PgH%%D@@$=r(=`kRS$tuL)GzyEreaw}ao?1X*-Q3qwI@cUIvHGt9xnd)dnULn zRWaBl$#1*o*#|OjcXji8vfA@jO?!o2l7T6 zxtU`Jv>F0wcu61l(HYeGB^>^!t%>(VhOJIr*0DWKIe5o=lJC~>@=D{N>-4_aq~JXi zDS6FQ|H5m!>ht`OhM$ew*Yy^<^oqCKYMf02zt=0Ke-yMq3ADx_W~IDMHhl9>NQ-vl zUE{Y%>8hA@xj3#;*Nu&iTs86koEuhmzIdLKYmutwMVS@NVF{!)7cTNlx26|gc~7Mi zee&m_3SIYXiq88}iKEIz*DU1&tc)i3lD+5!=2+PR@OpImb0A#9~=2kBmwz+SvCS|g;SEH|m%lL7+7eRbB0XJM??p)=;Px%re{ad$^Y zzT4DS5Ck1RaUuafEnQ=_-(ms+2SKKT@@V&KeZZ-s_fB=#HO{SZPqgwfcIGC=H9g+K@6vtm^`luQC^1ftxwB0A(_92q<@}GxKf4W8W7g`wGXICzI zV_LdOmPa%i*x1-0mx_s+I@h@tN_p=6JTncEvJ3d&e#hvGdOaI5iSL8S{Wc#PR*y=B9+URZdJ%oWF@dpQCi4z+C!W zmKK);kzB_;Dnohm_AVJL1;%*8DeLk$gFP1&{#YTuK|9Ae^LFvXo>v|ciW}P^4bn<6 zspmN@d~+g*(o!CET5T-0H|C<1PF*-qaYoD0ux9d#6MT&T!|qg6RR0-|HB+T73cX$Qyg+8b{DT$ z7XgoRQ~!HIRko=vHY@J{gaUJoplJ;eF+863qqtStvs4L>e%e@NfUL!k$L!d!Z~0fT z`=ADdiMU6m5?K#&HKBXWp-}aE6Y!b{DhQ`J)O#b}Z>j&@+r~z_#vH~7>lc(jgw<9I3clkv5ocRq~H^aEZ5$D}pv zyTkA8gpxWyV3k?E_M}>D-gup-)r`6kvVDCi)o;rN2a^U$lk1DvZoxGmTxY%vWr8j< zUrbyalqD_TQ9ui2U25wrzyLl2mhD(WbMFf>h6J9g#NQF%)R9+^Me#xLIvDVa%Qi6cL`>?Z_F$;IR3op0(xYS`wT=C6ckie_CgW` zoD+T<-_z~i*n+VZ2@9iWVPRn?;ZC6I9vA>C`1Q%=T96^zy?stEOK z3Nn9P&eIbosF85_lEPWJq97kc5|?XMU!_2R2f?0X`*6+jjjZz+ z51p{3F4_pUB=+_hL6i) zU)`_FB;+TSh618wz+~r?>lGOa=L=_KSnb#EjszeqEerO|x+|z= zK~0)ft3;?;8-3!J!B5PJrzMxOPe98DY1-N4N8kDJC1j4p*$np80|>?1`wy2tRGu$8 zqe6atGxE`X8U_PJ30H0H&%ia4@x~y~6Y7cw7r(9d@{@eUN_A?g3wP++%bFSqHrAcq zBZ}5fF5G!2%Xaqc%3yXFPXMQSoCfOdx}%p{fd%9Zbj26SZNjmqLwz6;|BZE6G~ji3 z>~32KWi*}YZoknzfo2AmXhmy=t?*X%8`d2z`E zh)zp$;+@lpEx+NXAlD6YC*kX}eV;(mXeReL29fMa*fRLqpfZxX}K60gBkeR z$Vp}kq2>ws)1(+mdn9i_Wp+Op=kyEpvv2>1xj)Y$+M)1VOTukoSS^@h22z_goRhoL znvZG>ere^i6bo!>4$%O%`9uH+I;S4u9PNA=qxC>TB>P_cAnHrz_);^9&Ev$Og~NxF zsuq!#1Q{i^oAQJ$o3wK-UR0S{6t-&jzFzHQWmWE&{4MUqv~}|F1lN|pX_&oEa>_cq z^GVzNxxQ4-sX_C=xbvC@BR%GUe$7N+CHTg;xo9o;GJVgv z(o*3kJnUla$NIGKEU6!>N2_{K%@Nqz*1FdDOEPKREF3#YkPMxHUsOdySaZ180xDnI zW=(2j60aKDLb_EeNiP1^psEz^Y@69LttG@;?tg}$4$(sw09KqJe9_i6yCeZeh8j_# zO!d^rM)7k)JRlIvsfbgp4g*2?+}uRem)xa=L3Bo;i$SkGv2z zT5EJav^?3zl_AG~VQZF1)L=h6f&~<*!8-EYtCyyK2d!A|J9^4idS{0I`tMIW>~l?G z%X|ihA%+~TQ4%aF`F%WUMgOLcQucjBy}!Ej{$fPrXt;nHJw9$K@H^D>zwxw;3+Em< zQ{wp?-WBDRdyK*sOg)b0aZJ|Qwr9S2smt>LfU`;w;I*xUd=bUqZ^VgtvtNcvzz!dssk{7Jmn7_th%^TS9-r>Lx)oJ408 z)#&^w1>#wr-WtrB0l^SFEqO#mMPK=hf}wyOt^~-@g{g9N25%^ZLZby?v&I*1J*fy{ z;Ifs4n!|5a0KcYO>^1tTO(412SsXFFy&j%R3+tno=olDYGg&(pePF{}eO>8-r9>vd zG8Hrb=F{6s_8ygVX-_3G2tf8fffwKQsR3eo(*;a7vw<_Hbx-!wouxWN0q%b`o41H| ZShTvbNpFa94IY6XHKogn#qySc{|8+{b3Xt8 diff --git a/docs/images/vscode-findent.png b/docs/images/vscode-findent.png deleted file mode 100644 index a26de6b40d39e56731c69058271a95d5407e3e3a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 43037 zcmb5Vb9^4#`Ue^(jcuEaZ8UCd+qP|^N#itZ!^XCqG`4LuYH+7#pYz*2``r7-P2YSn zeP`CJHA~MI&qON7Ng%-D!h(Q+AV^7yDS?1Mh=72AqQZay-?(8O_(p8s!QDF&=ujjnuW}Vl5BK?=Y`T6tBmNnwI~6OCAN@J#hcYDG~?A$~{tyh8p} z?j~GHF2{(?bA*aED3pl+gfG1}u@FqCLFDw-#*P*>oKG{jB7zE?BrCd#O1*1~#0S-| zY;3G3nJ=aaXPXf!Ajk!pDd`QB^{4$+^4=A9mI}B00y~9=ex6EJx8|dN!@j?aS(wc} zJet@rn3O@EiG1Sgnv^~+y}6>3#UebM=ZtTzNgzFwS6H)>S`YjUS4a1CJ5C-6YZmFP z`RI;Gb%9wLu^`-}#lFK6{1QJg(CVt9)s5o3MHHL2>3NW|Paoi@!MGJV9f) z$1;B$nnX1Z8GU)g0d;C+<5lY5gnQ&NzYiPrP8)a!n`_twCPED6lkko!01+&Z5k&JD zLo+$FDm6-7I;13so(HYj)`v&Cuf95eWo3B>5VkYT%pc~vuo$3IZYgxhCh{v&$w=_TU?0A~vIV?nf-vjCT?9AZL~IKr zf&numhV2XP4}gP^Tt}_K-wpanOoSd}Yk)-!p7I3>A0oV4aSBW>sCJXI3AUx1!GY*D znB)>aCdl0YKZqD#Ebvl(z;+%vH3q6M3pLg<42DR*0*(sg zoUot>)tA~S({Io%a0o(VQ`U!QF+syswB_KLUCxG3VP}i3)6=1V(WCg{l<{zd@+LN(X5L(+Z`0DOHU9#-T!W3{^_> z6YM8S><8r^E_Lk71OyRr;?6%tr>v*6r%Vrn56x~pZxL=mywG1TM7u4F>6z`YIVcg6 zqcr1&2R|8DF%L3hF*P!Yrnzg-r-rfjw-|s|UoEno(w<_T>e-+*5Ud0f^u=vCa3N$- zOn_sB?QGUKJT~z+i8iq|>8&E4gXe@S^sel@T)p!^@dNLG(2p04z33P0k4O6iGXTLU zf*mNKAw^AkN>ztai53R4BW9XU^CKAhgDhDkRVpf8Bvu4cguNtr66kPBT>v?G1zAc` zT*CWAC`qDWS`#>y=q$<9#Kt6~gq30UVS8%ysCWIDNkYTz&Q<=q|Gn!TVmQt3jbn-RNf|8AcAy`d}SGx7%FE$BtL}x_*iGA)^XRm`c z^#!GSwSzLOZ=59?N^gb23zsvJ3yYOM@~;%oDlGGwg`AuB1;*hr80%E(SL>U!Ahjgw z&nO>Xg(!#bZ}JgwEPtK#PUM>^8UpUTshbx7y;@d6cR#Y74q6P(0NBpjK=#1JN7;`?A34(N(%>^oGiyFN%i_rrr74cJjisimX0EXfX0VRU zjNfOtYj!Vy|7Ee|OS1XrH7GAc5PK-{H4z11;c4>^m0OkONdQ4gTiPl1LCDB^e zTFq))%gdJCSg+i+R$)ea?&ClOFzetM7yBVe5Ps zS{Gksoy~A>kZ+3OE8_bOnkKzd@vPa)*0A>QHnlfb_P%aoovH8N4{dY_&UJSCvvtuJ zs0w)#Q!;TmcpDIDhmV^sR7(Ww1gSx1BT+(2Kz)W3M68BM45=FrKY$+JV15(+=J<`e zjsiZUy4Nj)AD$CIAM^DF>@?^Sat|&?Z1KacxQn_*VQ?XaSuZuYq0kulzAM6HhCL8x^UsB*{C;Y_KYmLbw)q- z`ZJ|%@n?h=LHBc#OI7$SLSgB%^$8luLsMN{hoitb1RuA~>*X7n>HiGrX{4=%_ zm9ki}juTtRT*Wpis8QOGYeGzW)GY%oQ!FoLdZ&>JMzfyTIwZatJ%a$B)+#ny6Lz32(pJb{k9PHxBR zXM_g4D9*Mu?AB@qc`AF|^-WID4YpmnU771&9L@Hn&zLV2mn)Uyh?(~`uUcJnO-dHp z8cGkIaPFfi7pEO`FLp-OBlDG{2l>7$RV!jEcJ}wnepMRHTwgsL2A>JWd5?JE+&b3k zO&0c02a`tD`qpaJUW!PHD!gOvY*ucXWfk1YR=>8Dh_o6x_y1~dYj6M6cF(SMtb(cL z_oVmml3f~5x^Ip2C)Zm{aId1wz+{I`kF;lbCP z1033#x)>6B*xJ}R^LX%+{_6@J;Q05~jHJZ>y2QnrpH$8C5pC|uW@LyGG{9Pq86F1YJb^dYckD|Yy zfk)oS5~$AbcP9!k^D+LVJI#>qLe4&sDoYE*W zBO^0CooYLQPQ5aV+nHkfGW)aF&*O#WTH~v2wQDb2HjC*7TW_D;bSFG3+x{rmP&h1< z^o=$+PtD~{LC`}D_IilU$4>vZCDA{+B@hDIIak0}NmR_=rBtAB_Vs&YxRP60l6aoI$*vN>8uj%0U7!?oi z>ecgRKaM^}Q3gT;Xu7FS4eweu}^SGm<~t-|{udmPLe6>O@+e^1)5qR7V+ZDtr0{rDXZhwD$=bNCG z79LPgMl41>hx>Da5)s2qaac_H@`8fkprPU1P7rd~7TQX)(Ny1C3w2{-G>e9X@4*8x zjw8u~Cc8sFns}TFM{CXXdczQcvf0bJulKCQHq0h-{9c|^75Q|t@6UKMxSh@Bv<2MH zW1>f4=ALtNmA_7OwzRa!=L&QmwV-1M}YBhJ^nyz_ky@3+_X2TPqM3_7(o z?MA%>(r=f`^>he$9CowchEwQ1vzU!VY*G5qsy%BfE7yw0YE@NR9Q-_4V4BJ*GL3xs zYV|9DN&)M7ak28=2UCo601&R{%)78}tMG_I_k|5Nqc>~^QR?2o9o9{I_BwjsY4 zsI6%7dK)XNFnk}Y`Emvp^$IPh#Ndm?*B5VcPTW5ij%Bn^&=2g@u+N{>tBurPd}9bs zbXr_AWoxx+&GzanYx@Xzc-#UK*{#(C1vkvbwa{sdNUkYxh?ACT_R^S*&w-YR$Ku9i zO&5&{#m3-;3x#tg6&Dxpji?3$Zu~%Ta&#j^%yu}MhP0rH;k`d!BOoNan-om3Uu#L^ z_eLZl${k55GrCQuioa^G%~XJeRvAfUz%xXrRcZ42nc?WEpN;I^?6_kUi#v}@rKP2n zz(1v{S~ia?r(7Hp9{A|ARBP^kL%G;TPGlq;PslG;{PiFii!ld|Q-1@?dZ9AJ*2rkO zP|BIUGGUv$hvX$II9NX(k5k&O^Yt}~T0)CkL{#+G{YAQ(*Qj3-$h(C9eEMXFnQ?-_ z!jUel=SDCKe6&~GgoTCI*K?E@_`Pn0Z6F*m;18L}=tRRN1&3t<5x3Gg?e(xl>bj_P zny9zAl~9$0hp@$Lm^wbyfr<|#P+WGpU*v>-s6L*n$a_yLh)>{cu*Z)J+^XsuQ9CMB zRG+J8VF%B5-BzoKEXYL+2LIRRrYh4>N~r;%b(gbcQEhF!b`eLK`CHXTc$}c%;17s} zpQej$Q)8l{l8S9;)_BdH>Mdswr&UBn(K0Ug$MF;*fBg92&rfH}T#vr6@OLo_xEf4HrjY(i$R?l1?Qe=?Pq#-K-xQVmwwW*-7AkEWFl`O}xm7~5 zN!Zv~{T?nsd7S$qgki?(ZI+5{{Z^kCvlgKVZmS)HCHFe-s3JW;d=yVH3eSIP*fppfB zP1F{MR*}%CkC_cZ+C##&Fil(5l&~$WjK2HNGalNrVR4&oUFRU7T z%K2i$Z?C`J20*08DL$=M8`I4<8eq4WjY~Hp*@5;d<3CX7EgN!kX`pNc-u8S`KbOUW zK>qYi{d>o4pqDUZ&RPV@dnRP>bS_7mg-QYv-o%j7qZxA$c*g)%!tJM@Wn0bn;dOV z=0A>S)c4`D?&`O=IPQq|BV#tiPr|`dRBwPJ0rS*qx^M|-w!w~&cFjI|d+ddR3;c%` zmm^F}%>AQBbg7cnf!LGf#tSb0*QCS4H1+R#hJ&m+{RD;=?6(jtW$KLm4WQfa4K9Z= zRQ(?=zt0cgb34JH-4QE-m~V-2p0Yp}=ywu&-xCH7D0qz`dl*sXp$>$?9c1%+up8nS(>zELUJ{7m`ZOh2LQl+etc=K2~7Uo3sNyF%hLI zlnT@C9rz4bk*p_0&j1!SE)++fY>{*d$plKBaE;B`V<+v$Jc z)J=61NreG}(zHV~D1Q!)k43LiE7bB?T!<@ihBXL&-%=~Lq3wsmNE$!`0!vJ%i*61k zw}Tt?^1qPBZU*PBUv-<1dxj1H@QG+*Tcg$tQb1n`r;sPH)_9P^r%74HGfTd6Wc3$d=N zV<|1Oj*!j!5|UkW1B^vckOmVt4F#>lTOwm_UxZ-zw{McRXR=9x2!G>4;=o*aVqu)* zPn8B-c=*q6u9Q+Vq>m7gkkSpS3e!y2GJ->4UfpI>r76ac%~q7omvt5lk`+1XvIlVGnB%*JtNzw65o zMkjNE%6lp;F0RS3-(+$Fa4rl8 z5s`yLaBN~=07AlS(4|n$BwVa<^7e9{LX+G8a~cwAc&0>6i_h=Xrc}?&{9~xQ(#yyc z&SvXffpm%$O#%@xhNvH7@Hj2cS3hWorr7EG(Q;kN{>>gb-vNwgV^_HF%ua~GfRSqz zoI`oN!*}CH!Pjau@Fb0spqD|Vy>+HgS^Ap6o|N8jc|vX{TwZzVIiH;Y*Ifg;Jp$f4 z;EA9))+y0(alr~CQKA7<-(WQ-ULv_YOsD?dP@nxlNH~T1O8sg(HEk@60Rok=zwA#G zCYS+YIu=j)d@#${U@c=oFxuu>Tdgm$n&XO7wNGf5_A=M(%zH&kSgjc}9cI7i^()h* z16{@A?qosP0`LU68R^v&AK`ZeLofa%ZbrqkLNUd)>~uGcE4RtyEnlHQn*! zG*048vpsd(*-y9g)v!iSBi42RD@3+RN*{Ep488q{fC^ba*~!QXR4S9^itNEWmJr?i zdexQ%VZhyd1~}Y3;;lr2U=z{WmX%&9m2V+fN2-+czm*rdmje(HAa-GItIe!Ae2V4C z-P=Sc2TP6ilVj=1NqQLke{PdXi6Ex3v^^%O{)`Ue^0(bNHAQFD;cdrs$Y^|odF;XXfOx}A0VK*@x{`suAy=F0ZjV- zJ(=A`$4@w(KFU99+=gMo?PUae=MxN~7xJ{AUqnwIWf(g?SEj!08+^c7x@r370#l(7 z!bvXW(!}|@?%xQpE1s$=d&G~=xZ%%P3mhkuLZIs4%>Zku3qijV z(d+&^o9_*J$%9$)WZsQJCUw9hNBujP()>v08wWO@huF_!_Bed*-Sdv;JsJPi+0|ya ztE4_)EBIP2mrD8vsR6kCLny!uty%%H>yaLott)f-gZ%OKbZK&W8rWLa0>OV3ju9Ce zOzODbn`)@Ux+54Vx@PnItfDkLo_$ASQRaML7Z~^*5q~khhTCbkORr0+#AKcC9*AXj zOEt_i6SpM)s4g7>^%L_H(-hLjjJm~Yrryqt@Z(sifm@|grJTcJD)J-0pD7!@KO7zhfQ-BbLPRBzp>Ur8 zp7}c-?h28qR_b7oGVndG0hs!|4p*by8m3K^cDvVj=Ub(T{f0R0hu}W~761-5-H8(x zQQrXWiid4Nr&Rdu@LRpBZW|rAB5tCKYj&2Pf1YX?pIW6(hM<3UwJ{Yb5#xNwaP&R3h;0o(>4#pjDoUZ6puiLrPK6X~on zdfNMAE!&~o01}P35n?2{Mnk{lCK5pD9v-d=BGS8NdU|Sr)6(}g+Px3f+j$e;_CHqD-eA+u z4_1Opo-bDaygfo=Dpe`b$`k1asuGeWdE6aFv$vPWE|sXaV$TuuZ?H%dIn(L%t9RTf zM%Dsq`E^UfK}`)4W`(ls$$xTWP*Vg3*_U^jlw^&v9Sqi zAQWh0bUI&ag)8uIEMqm7>*>NYA$=RqOaOE!Sl%mEH)Avf|6LyennroJYqn-_aj{g@+F%6p{oMBr zNiLsS8;8r2!$a(`pFAE4)$M6q#d6u9bMzTq=z2DlsvEuOa#*=i(;QrY`2EVC-M!o;9I|S;e!^1<-@K;9KFY;hu zU^X_VK0ZE|l&P;T;k#q$z1?~3O7`+Oe1^8VaEzAS_za?=#*XYXrtTN(^Z6f6P{?#R zY_-Cb)>?kjDty^ot}ojj>9F~cpVD|gQ&n{-92~Zj!U8b*z97t^;^eeGKk%Q&bAz!u zZ61{}pU)SgD$FM<6PP2$G_+EMHirfeoY`n1F{WexvE(GsBy|S*@*jZ>-oS9INCu0T zM9jXA*5CXf4^Wl}1y*s=6%`eo_s0SPWwuK%b?S!B`r$65Q%c1?_-ZuR0NYMwev-#% z6zO)GVQ-7gk`r-~a)S-`E-_cF&tnp=yIuEh#$daAYS@c@W@OKdh1IWTlCP*aliM0d zFkM*2WO8>93(Lp1TK!JAOszt@v7x`lkN))?ENsZiR`0J&&c<|hYrT{C@$Hc-vA-e7 zZ)kAYimbrO!t#{UVXzbv7boZ7;Lw%=PjHNmgTrjUZlm)-4AQ>(bbU?ONv^H@8}iJ+ zmqZm&QZ23J+jhqbPc00Kpv0P{y!@RfOYz>FpK{k&4>ec zQNF}T5i)xHNr8Vi-U;jzbLTTk75JaP3^*Pp15f~;-Yw;S-{@fvg4)>ck<8$qs(6xw z5G%=j7(!;77ly;$2t{)+fCBbL<|cFaLuIa?Lu{a-C5(-eBhdyacN12BE8ff;6LgIA z-uHKDY1p2Kw*TlV!OVY4+rTK))LPSEz2o=3tF5bxitupX?CL0VU}k3@&Ag|ZOZ=o1 z`A}!S@neWu-sSeqb@WF8bZ<`&Dh;V_seY&8%|1h`t8;>r#Xr_`;Rmn`V1EbLTZPp^ zp5g55YzCWUwecXPBRe2yPcfC|2yzb&4w?g^4UGkx`GgLjrYb2UeE5eM;713R0q7j* z0=`LBxx~f^OJ9UVr3QeVX=JUgu5KVU)51Fkxw*bd3jg2 zM>{milznv7yKBg9lR3V0s-;2Vq9P*dk?Nnx`{REm{`v(23wA3%T3$;nAmp&ZFiBINfHwdnf_e~+O_@j2z_BCtN;R#+ud|Vvj`@9dYX{Pt5O1CDOnH7?1QWzhB*ib z_{@a-j3SlwL;e;Y>UJ)XES$uq#&pyV;Bx4L2(XQgJ32u@U_gI08TK{+9+9Y#RR2uM zk8g^smx&wK_8rYV_KSwjH(=@I^HM4MKI{O5>^04>)c@MST>PR2Cy@dreTg(tJbJOY6 z?G`^oX$WBpwMY1T3dMcgzLCb>K0P>~i{Z2vaoQiF=_Ef52ncwGHUPs*N(vSh7#KK< zHul<6&J=?c+WXs0K)KMgz}68NG6f8oken~|Q=HALZ171<1xQ2!fHtY=N29w$z~iDs zntVHs0b=zd-;_(#`IXILV`&TherDLRF7(3{&_gf`B=Ue`w~6=b`SAu_y;2J~Sp?8| zo+G6O2jhQiLxa&ANMPG8*VQ+=YqWcXTFB5ml4+S_|GkkCQ(Yq91UG9iXfL}R&tfE| zV$kswCL!ZtUx_kA5TwIl(uc^z6A99*jZH5uYB-H1?$jb)U3jm;PI*Nk}a``O2*?T zPhop(cK)iYBR>tdKVcg|lbsZ#Bu&{)==FEJ6B>c>5gia>UG4BKP^;icqYX>BQo@Un zGl)}*#;j;-&kYL=MZ#sn?}oJq0G6d%`NRF?)&u~+DuJE&?vz_Z1pNwG*5&aacLd-( zD@~3SDXLO!@@6;tu7hy|iL}pzJAkB_Ha6eZ46xJBfRGo*&Os$lTU&0FuPb^lV#&9oBf93@g5u+u{%cK0RkGD zYYUH6#WgjPrTbp=tFU(~D^_)uV23_G$3(VHTjP zMMU1?eoSLJJ73dAw!hv595CmD_aVy?2=CSi&S(4kF*xJ0S(#E${OO4V#SK3@u!VQx ziglf@x8KZt9H0OwZ5c$KaIm;;>zxp^5Ih=9I09Zo=TbWBn)IiKlkI-E2jkl-&+}~- zr^jn{0GbX^`aQJyzu8^yUcLN63X4?&6#BthWo2b|C#Mp%3d&;iZT;ZhaHNSWZb*Sx zJWkP3K!Pn-?8P0O-W^t}$S`<|U#dO8danc6F5tIWSz!X+`?luh7n@Ui0G~Mw4hu5_ zBAKdv2>0JBAwdi*S3Q7yvmy;I%#(}@5OYC$iMPVI;Njsv5-WxwI1>u`)fAhFV|_;H zIRmKN;x$}w+VPyV5d>M3kfqH=M>Bw|fL?KOIlbEKZr5#fi}32hv6CKdg8v}8!B?fX zH<7K~&|qsmo)O*-0kFxt-C?p%BBA+mir^}M$;hQO=%A1jUpAV`@L^)Mq;?=K`|`Rd z_fq{@xL8bxtFV!^4=N=5A)@Fwo7X)!00J6fkI4X7+T4BQNe|hCc@58xaNEKjUIN{p zp_v@J5QbxL>VcREhfW=F19TPh9IO|}oRNDI5Wn|^62YZZk|?4D@M+a6?>4)A$1v(@ zXcZgJJDv8iRRJ@QNYpt3$FswPs=YU#!RF?2yPwtO;LF#~kRLzOse``6$HeqO3Hvkj2xsD}T(*LA{_J-DC`wwWP*4vjKcLApIr_eo zTOg|BsVG9&@%@dWi2ET>V+QIhXLMAKcW!zHic4mNPUfTZ4IK?UW^2vWV?yfc>v!?! zygizL=masURRvdjiGBb8gsosrYHU_R5L&B*g&67GVa0;5(P+3<`wha<^dU!Af>>d4 zzvV#~DJO-Du3&M%&NmE+4Wxk>&f$+5f7cgS#D2ECv?+1eXfJxjTQ?LEyeeTSzWO=; z=&%zz(#V6>4qGPd@|Kxc+-d4dha~2E9h2$8BbYWxUY8w15+cNiei9>aaJ=p<8#A*w zR#I#ra{$hi%RtB;ew73YnIF(0wC+yd^wH{lnt9#yzv;Hx0TwrjK+uV868s+I3ZywhzFu#%k<~09(!$4NK4+}NQXm7-|*=et5 z4u`dPbM$RX6upB3hLM;sH1ab*p~2A5l6@ki`F)=t?5+zVBd^O0R4)*(h(7h4ZD!Ip zKnS5iH_Qa63Af3Rr%XJ|3GE75&X%e|3Zs%=nMV+#*3ESIN+6qkiZWo0`Iw2`YK>0) zB@GT2|GCB69s2nZ5SgKHi)~lbhE`kenN&VzRl_M314_VD`k_#XlIf*!-}9q0U~{as zdD0D$FFGVs)z`CiyM8RXUC@H>}^ zP6LZ7uCg>fs3Yp7B#=^Uval%K)9J3kkeQrh;V-7;zMj5E{XP z$_TLPfnbst)I+0+Q*Fs8M=YQ>^18+a0|!s&%aS^JKF{t^i(UZ-%Ye0lCKaY7{i#3l zSe)nO{-6qS*vE;(YXwsB4MIjg1SY0&A{hE!IB+K^0`grR^?ZeJdw7UJV~mdHHFk6j zOza3}5(t zv>ua3w@1nR{JE8YapcGDi03V1K-GSE>0WD2x6LO#=jXWPBTY`zS!fa-9&X5jT^uNEGh1?FFEaH>xP~xjn_e_jupKd}Q=9BSm;2UT+w;aBsPOCoXT^%8I+)bYXfMeO;6lYBES-OK$|uec0KgO#0wPT?sX(& zLTSX~D#3Z5WWUkU_z%X}R!PLU0JINn-cjl?ZKVOo9-#k`=!D7)MA7gv zjmqGk45OdFi=)Fu8w&VFeJqsh`Ha4e*7&YD!WNvIlaWy#z*P$;i`8)Oo~Rj^iYzvS z5lo2NHr{vmd@hHDDRcTtnt$Y(T)qHgxg*!mt3)_slYEVdqqfES9?|dgyM8ALCV?Sy zq{oRxR*;bm!AxpZ8y*q1!vl*p?92dR9_moqe8pLf`DB=;Rem0$`3KW{NuByP zLBmRwc*1O6SF6ucvi*hb8ta(2$iBU7WpA9RTW<|bEv_fxpF~{1WY&M6mCP1@#A70Z z>w&u15G&@R2?@!_$fxy;zHaSxDhF&#Lrzu*c|c~}O1hk#8HJrA&t0WBSvgoP%mTP- zxo#`0l*{DoEPh~yfNx8`?u-A7WYlZKQ&CM%0?WZfcBByO9emde3a?v)3?OuOhe3NB zy1AVxiqR}pXj4(+$fAb~b+4o%k9FHw>VGSi{Yc}QAoU-XA9yPV@;&eQc_8IhF6cg2 z2@G3rr=DcG(j`(QxC$if;flwgxvjFY^7cB}!&ixp^@u>O?Za$AOG+qp5IZXjn$(jR zO}b?LqWAdpwAIZ%0$^j?tSvW~j&f*(u{nG(;=$zb@11QG8!6QrNv1;T5mpE*{hX8% zd=Q-tqH+QXim%k6glhd#O%UYMpk0Go^heGGxkvyDB??!Y7?@xt$oe6RK^O8N=ntmU zU-H>JTl?cDf~`b0@qa6Be)hi=l=~aQi)kXzQveY&X=raB9eG}DH}8rYOcOD!Gyg~I z5%MAjL>0nZo{K+ST_B^74fOq${7ig&_MZfkIPg{yXbHc7>-rz917wUsOQ1%}r>p9l zzX8^7ABONF4_kv0SZUUw$C${*Xbl21xk1nh+!Wuj_@tjuHaQV9!0z zS3^BoiS(kr78k2kXd$#=+3yZ@8yXtYe4~Z@08GF{25q+??6%Kjko}q=e?R!|7*1S) zCh5jzHk6P!#q>KTW~Ct|TXz(gT7aVf2=n|E!3J;tP^hM115G510XX6S2!H@>iRR^V z-1fNIrnoGIOFaEi;GRM|cU5x-Kp#MJKktt|0P-LS3Cn;iA*Etj%@Bng0bf4T5r`{V zc+~?Q*H>4E!zVzvmKj9_2tJTgayOMHXFBp}W_H%&?e(`q^IfMoOKqqo_aDzL7$J0> z&pa?NfQx$!Oy;C}v+khgoq<@9xY$@-AhibIWjy8+@E<>pOC=YRp}iuL04}|oyMC4P z!5xrq!e+b7LUJ&c&T2lEhQj!&U1PF!ccy(jTcX|J6AI+bOk}V#(9+iUzmZ(KS^h(F zE0hNtjvfG<0ra#SK2K5uz&V5u#9Aa05CdpDMkyIFvBAZv;JeWSCdJd0^O|3$!m|Df(l7M%(B|uC;^dF~jGZP|- z$~cGrMkE$+tBe}3V}SGnD{Je|^qREpcB14Y91egj!91}|tx=Vb!0hJ-%N)G(mm$y- zvA{h6DFBNQ42}>>cxGjga0d8ti*iCH*UvIAY!*`*+PulLE*2I;fZbKNJIQ%D2c*a< z%$IAnx?g}{yxj066l?dn`M*3N^vNUnuM6O4;jkCS+hmbtPM}>7XOC$;-k4&+7RD4w zrCdXDTy$3Ol*&CTHrQ%CtzvxtG@NGF;Gf%^(Nhz7JJQ{a0*4MH^^_gYG%BainvV15 zLJ#^qnP|>ZW0=ZTp0?QHrfRj{EU#2adbSot<9((#Yjavr^`x{(UVTa#$=L9|J|0?< zxR!axPuz_3A5~KlHgI|h8bABsXCbzMe$$XPLwL45 zso}VVW~t=;B=8u$_9r9D*xH*afK@bD{8*l-%zmal%a!_KJUF3{Bo)w(rnp7 zAlHH={NLLKDpdj>4jLXFfYQ$?KW4;YZ`HV+NrxEO*sg53caLXsen~%B_-?q4RX7B! zeC>LxVD%Ar+*w{e9Z&JVLxr{pXgmtJ5Qv1UfbyP%&Xz$H z9~mdNkB%-|C^=vLq+Y4BTxFa)i7S+g_H%XK-E9dO+)!~oy^Ie( z`qwr*d)8vmrO{E|CHtkyKD5O@AS0v4NvY}D(tSDox(L6P-6);nVypavDSSN#?Veyo zMeKI}$-jd&H49x`alS$7=$hi%%F@!x{P~TpwDi-c{mka~Rqon0zZ<{OU)5NzfR|{J zu{CQkan0&lhEAi;qA#{Ph$ACs2w|V5j8skRS`QCnL`)iDB`QL;-WHpnCGScmUrFB& zN0+~?NRT-d={@w-_6bn&_MaLk1J` zEGN@Y3=vl!Kk3E_l?G?+9sTElD#tMmuj54XFIA3l_n_m1bGM22Wgn~=VH)XMv}(oK zHCwK(_q3zZ1d;w7)g^&F)db#37y>F<_4TDu7)X{)=yUl_CV^hLS+xp9=d;*Y& z3)+3DU~&Kw|M2)|I-K;OX$#-|ONf!3SKGw)wD}-BPAY?Tl$0spRf%*oHk!XaLl()f z`9Xte;IP}RiUA4P$H!LR_1Z<+_U6h!Vy>$>*VbAaE6QJC-@QXb@;5g#3tP8atRg^+ z#bxi-=?18})9w(n=d}lb-}sEE4P!#|IuUVM2j2aJ$J_tJX)mz5d4f(z7&cCLcfQ8Z zxq*P!V2Bh6*kLN=4@hn=;-PYK1H()KMGn(0n)%lUaClt6o#9f z%`q7=!po%3^g1i~mY@Wbgv)0e$r(B4mgTXoWmpw~}q+Qa1PQK#mJCZJ6bJb zcf%X}?NTnh{ShNYVoo!?$4)QrlMX>KI7;E{&iz=%+LJD?DOxHXr)AbN?(g{UmcG zpX*vA^3c`fa?@XK`c+JI+s0Hi-~TNS3hD{QX?tErSNF2r)m=X>vgsjndT#C=j7Ma} z*~NN0xWCvmav~I6U-gc!)WYGbYwZc0AN`@RK8|@gNX<#38kMrR%VddrMY&hHouG&2 zz_f=)JZ>BrhSqy^xpp5C`@5r?WzTiHScRCe8V*=RWc6ZqL`MY{4 zo_4Ash5!_h-5p3u^fp*uZAr^*U_!Q3IsuGupM+D_#3&$+d}#o*5oRUy$3;k;*RzB}*a_Q;vXtq#q5MpH}6FfDp1;1XY8 zmD^bS44CPgD`1+@%vWbCjq?@SkC$7)9lp>;h8S+u!Ce8B*h~fy$umq3KlZnTf(?vOZ`^{(Yo&Cjkt zQBFIZaH8hC^AN%P(a3rO>H4krySF;JRGFDr8ucUKxCP2ogFrHi5mfQwIg*t*ux#ea zw1L+V2>g{7$)~!AdEFL3c<5Dvd(aU;hXmhL8fs_*t6A?z98x9 zN{C(q830Hkh^;VYBcE^-X|}+(0vVxfe!LH%Ffjxq^_4nHxWMCW7M468K1~SwE3%=p z70#^~iFod^v~n24cfOvu>{ePpZgtFQUj5TO(Q4zx7f^67Dc#t}$JueqGToi&IawY2ljCUaD^yGII zlL1Fnx9Y$Bx^8^GiH1_d_X`CVN|_Wu(MnYYhI~t@47Lq6ONC`+(P#Tty$Ti<7U779 z9_6B8w{(j6l2e{9kUA3J z7Ec}$L_i`OsexM|7?SptI7o@=B9vK(kMk+qlKW2(gkMCx^C&Z0oG-Hi z{kVNtH&>HDGQ0fXDdDRhmVdh9o@kL5e$y}?E2B!6OZ1Zr4bF*_6k`mOPaTne2zzll zaSB|k^8l*2Y>9)m-lO*e*FuRB_ROUi|KCEu7inS&7N~lmd_Fk?PmuS9d|#K9+PI}0 z!$_kV=~?|*0s#|aiww74+joC5*Vru8A4r;8M8QjcNL*aI63p}=lNk^+a*lLhBlwfAz)8S+eH%q@;X?}WaH?55za+9HZ+B>4y@)1 z^yiac1FxnCDOmJHbQ`U_g8^@Amh>3G6N!WA=?Vac3c}v&74W>~0uy7ZqRKgL@R-c; z9OXq)g_4(_q_QZJO?NuHtFuhLOy=Iz42AVy_-2TJ0}fr}mPjV}JG*%)EuzlD)033w z3PK8XXpLOEgu}B&A+KjJo~YgJBg$oURaLo))D>$R*FdauH_^o2XhP7+@mv{FUWDIv z(k*((3Xq4TU|1kNE`-XPCm|t`%j2q~gKAEV`OE~oE)(Z`AeYO1Ge^;!X#!-ay;CKz zG)lV9^%r<^iZ8ShxJ_wn`#Lk*yu>7w==X`z!hkIGHY0Mc9yY6W<#iZq!>N!JjbS_F!5BouNaS#5iNBn_Qb7dQN zUktxUM`s|?OX1yZKvl{zM*6g-i-rZZiC()GjyWr<^RV!+Lg`0oqd0s%=3A^~rPWaE zLo)pc{}?Y6wqSI{Qstb!@>=N>bT9D#hqbqis&eh#cq!@bl#uT34ke`(L^?#IySoJm zX_4-bP!MTp1OZVI5NV|wl@iY6-Fv&^{6CxzXN-63ca1&Ru-1B>=f3B>=5_t5xIXymB&*0_W%O%hjg}QWVe4k`h;MQVtqVyADw|BF zAR5N6$HxULkKF5pbjLP)m284TeBqK}425ZAg?%}kgee3t{MwRA5l(V=G|pNO6X!?yT_SK;7ED}Cx5KAN{O+KzG3VRdVtweJbr>( zUB`=W??p>sO5z?zy9}P|ta$e69hj&1Xe}gX8aW#iGdp!-%D;lDB!Xv zIQ&4>*Ki?5%#3{9+$Jj;F)J&}k~N0U#dSmFq|w{LYK??UO->yG_{kqhihqxZcQnxB87;%As$7uv=5joX$5+VavWgLC!P$l<2HPT~&_ z>pO3;hu(xb8pjSaa^4oF)v+WPkjb}9)d$RS$r9cypzCtcTuS?Cra^EuoN-IGXV;Wy<+!-jeT?mBX?z271(qc`GRU-JbiQ@p=Pq{lgHaEjlJd=b;a@J zAj*ty>CtWs>6{PABU=M_i0`yIzPx%QQqS$Vku&!+>f%C;EN5YdBtOUgL_DL2h3Axe z5gA|Zi~li(d>~)>56hjr^bm6cm++&}h4+J}B8=q@V}D42^9k2>k1xi8W&-vi14R+B z-|;qsuR#BJpQKjQ3X-fx3#RHVI(AgZzrapsW|0vYX~F*JtTU0=(wCZ?35KbPfow59 zz~)m}XjzMW=~D&W`g!BCYqO3iJ&VatR*hb~Y4qM7K||vRWUev#Y063bnvx3pJ&Ss0 zSERf_bFlu7WuJPY9T94Cc!P*4a=`GCd=$a)>tDAj^scm^Pfj&N-RWF?1tG%32ncSz zZb`*|s#BrCM$s?R+1H2rejPtkPHHtQIYE+woE%}qV3kK+f1C+jSy2WWoA77&n2OCP z$PdrI%#fNdzHfMtPS7jAin&@f0 zFYUDIy`tV^tTBG{pZ}n+i8@iIBo@wD>vsEML?0_7u;E_tG8={5>mBx#H|bmtY$_S9 zvGSt4GtG) zN`*a*jq2t03Kiu0+ivjiVL6(8vfJ%Ee)%p;Jh`=D~H;cv`Nz;$B^%ue>4>9CkY)q~M=TzXi{W;x~y(z1klc#|+ z$S}Vw=sx{o3Z^B6#GZ^qHP~Iw)G98d4O^3S#ojI)ar+=RMfo2yRfTp=c#?BiS|#iW zdfp?nX3FJJ_&6#Mq!{5!i(Lgj^pK{FSu^L6&iQ%Z(QA`!x>(jbzxLhs(#1(`?+(2f z(6lv@^jWFJi(tQ zyhUV=l(GBTFfjU5%5zisiSSmf65{gvrxLlJ*f3r~!*6lrc@O?pm|g zI*fHy{;!clv*rOF@dpb)gd8+uYH9xzur|BnAvWKAgk}Ta@6Q}`J5bUd4V!p2YxckC+L$j#v*|-Mcs-X_a)liO9rI!IQE-js zU5(iBim3jQp=*AIEt>W*YIst}bu*^>AEE}F*n)Y&Q2I5Ww*~Dx*@78Mz;8_HI>Y=|_r2OVZ z)3NKLD{)qAFXoJ9kfx!p*qJB(Y(_hr$Vq0m{|)KsH|t%*w5Xh#<a!aWJne8_&H z8u;kfvS?&QX5RUA@?Gx@nF=xR6$tlmlENa#5cwpyXBqZvkT{VzU%!66XQKZmoQ2tU zFalhKeGdII#Sa7I@d)0rY>t;49?{9y4k4vAL^JPpv2MO_w0uvjQC42ACQJB+tk`+T zfbp^SO6pNzp#54TYy5b1u_K}Om5bZ?s{CjgW}nR7OQMdR$rEN~G3{V<#pBCNddqGi z(siIv1xZZKBOb7)?k{Qd1xUHdZ}s~L&8jQP=gstuNQGvaS==&cb*#wr{(_^IJ^?Zr|9BFy z`HyY3NDL{iujti{AD=zQkzI}rBxldfXQ~9z(`KA82r$?(Es$mImo`=D@y>qVPe+xV-@5t+mY*`8-^;FxG^-Y>l!pUvrR0UC0&=NL~Sr968k7l zv|eFHRAAqF-1N0a2>T8DUP2|y)Pr2T(_HUIrok42E$bm%h^_w8H5s?tDzcCp9!JZZ zJBNmm92_RQ_5?^J=bIOaU%Mv5sMeilW>#xam$r_W8tTDWajYez+I9US%Ph4zBZuKI zxtgQ+3)Y8axI*f!DH$sNb3)_ufKAxDj`uN&P6$Hd+csaJx?=S5u|BWcE(=|+pq&V~ zXvyF<7EefDDDz~=_t)3_RwRySUqwxQBF(UV(C%Mua`E$aG>H(h_-!mdvY6Cg8(wo~ z=a`0n7@K8J=sQ)c*H#P18W4^!n;_eQzBxoAu@bI{)dd7-Z#*cD*kpKo-|r)pG&xo+jBT_&CE^uL`gez3^TaD36-%roNylEk57iIV9S=7&lFR$DlKwsA8`@Nf!Uoev=m+f0} z!-IPesIqJorRKNUoe$h2ef?Ps{6_bNojFWey(6*hK%6VnuYAK9-0p6qUV8TUhs;I2QYB6a;U05)O@f?h^?$0#6f;8>keoID%t&9w9 zt0~fmvjFcvnijz_3_CY!I#lg!Z5QLe7eye?gg?LQ`2?2TLMwIo z`EY)f)e4<<1LQC!!GWC*8Yttuupn!HQU+Qsj$iC(#pwdYT^y$)|z)Glx2H>C-RIAsjjXL z*1?5^1(~wITWWt^fR032OzSv^>Nz5RMdxj><$K2oA$6q|R$*^!}sj%dsyeA{SRR z1eCSvZ4Qw$%rA{-F4{ zxVBcw(QGkDljT-XuKp+Au)9KVRBesze0q9XeW&4UbZJE5KdC=uKE!RQR10^`|J>fY z43*Fg)q1mr?u4x5;#7eu}-v+1d>p|K~O>2qMS)Lx?T`D;j#T`G* z9dY{d(t2oO`Rx-tW02xjLF=!oen7^mRi;LE3h4<*H2z%wI23eY%qA{=GMxEXx0Idu zQH}}euq@zNh@Ei6U6=FRohSrsviZ7kc+llXfOUh0w|%;|bSXGOTUTCQ{&mojnv}HB zygLi@)}|JoAuzJry1-EXrPEw8JA`3^BoV2oJ{z|*R<=h7Lk|L}2w3@*pe|^oa zNZESKrE(G!D9jp^D=RCfVC}rOVh&H{a57V6PR`XgFm;s8%*f1C_zX7MkJHUJ^W`Iw z@Ng_GlD*b+ejXpJe5g9U@X7!eDIV_j_Q75VU%<&-(L!NS%k-_m$NhlWfk>0%KsIPS zva+(u(FMJ*rZGgJVH6P|q057-u(#VXJ}oWnEG^$WjmPw%T2|JXhAM949~r#PT+Lwq zZ=*qdGOM_d5ZOQfbqZ!OgvpKl{KBh&tADe7g4=ol6?L0j^#5~rIAchS54;ZCR4{fkf#>Somle*|v zgrH)a?V;?x-T64g2Qs-UQ&=^BVtCiuL^TmZZjdC(EZv`X*#O2anxq)cbouppm`{C( zIJN{;?&$U8usWZ@=4{)AA~Jl9_>tx1VsXCTDL+&j(W3f0gJFPUWM?)Y?K)&5l-Ji? zRj_$?l{-*!WPSpS;-Eljh|aj#vjHvIdg#{DPS?A-!Xr1e4qNY)KeoKJWZ8Oa^)S@< zJ)*oGc0s}AqrGc7`z%zTWkb-cGZ---(6z;$`xT16zeyhY)d_HVn-jC?=zV}d2K7P~ zgajb)A^pl@JQro03h|7_V`sb8dk>S9!ox#IeF^+Y3R+rbzDu2_fAO^Nl^f&MChG(O z`4eJdNR9$S<6f_S{Pxz!bK@J`9coE$QD*Hp2%4(I1=o%8B+TU^*tE{0SwaS2GD{3x z`*_-i6bo7DJioTKBo@+bWMpJmSkfUI2vJ(be2K0ua`l_tD9Te=MeF|;ktY1I+1 z#(5)#zXbT$+pA|sVw{9IrMsR)kK6XJ{aAcBk8nExz zEn1H=erjqt3VK`6ROZkTspPr z^K7iFijp%8`bsn;phd`Iw5;_RX>uWY`xeV0ryI~1`0TGWcm6Q7z+}n6`ulBV<=sSj zWXYKW=gXfIC*)DT>Y1VojAVe0B!P+3Tbbb%Di*SaxxMxN5t z*&*%a0@*?#>W9&tG+q&r8yAU+956Bv5gDE92&(zRArqTA2ZH$xsj`{34x}@+Z=isR zt*hg^KAdrO>$%MqM1h=-o=hS?+M&#Vt)b70Y03u*1~8=1(-rCwZrtM?l3`u_EW>5_ z5<#@mkv&h3{xRHkbY>P7i(6Y7#D7*@u$n6m-n7o-x9&32^Y7WtC1SbxHn#&fE|p)t zkgaZPXy!hfjKaKgh3CP`7caWhWWIsG%4FE}*5TXn!96I(T)}r^wxof68P>#fvdvgs zO#m@_s?84#v(f(kb8z0kL>^5J|Tu%WN8BR{0gRC&j{tLPj_ z$&4fA;+gul!6^_WBt@OQTTNz{piRu}8?gzp#UJWC~FL4a#y#4?Y;q~q3EeY?w& z_y8Wc#VK3Wa=Y`w477(}{`NiEm0P9o2R#In37PgrKW-P%LB|uJ2iir^y=h!ekdRCm zh_q=g=}a9#wE2YxVlmXme2&>zw^}UbW?>3Vul3x1icmqJ8;lVaQKn51k&(Dm-xzN2hwqR2I7Co`j_L6mI+@y*l%x48(b3tmkE5M24Tw1n&{z5s9{)=AP`t_e zcJu65fJR~(cukW0`+jpya62HY=r-8l?1h7uhY>sHzh$LhNQ$CmiX*uW;z9eJ7q(xw zehG4N`h%2)9x3U2s5Q)>>w1$hMx0`P18!&os5u+U(}QJ!0?bYqkrDc{vW3aIYta|r zvWL*BqHF&nF3|)E0Ys`DRi60c<~vHM__sxQ?koc#quy($YpxX|Q}BLvO3m*4KkI}` zAD=K(?%iJ%9d*^zjEsypI5{~9a-B@%nY@LB()Kxg)>l`}vNG{mq9^HYg$=|dC)l~J zYLyNQL|+ymIxih3(_dYk4T+D>(U;16jE)Gw4o*AyL@oka6R53@zMz}23_=kp39v1% z4f0ckKX0WuO*#_hRF$Wlr?R_A$!r2z3eL`wsRK$_J#mtm$_lfyCe=otFU3S@s4=2{ zXmvA&a^$N401E$ur9AF17#ELlFy?br&maDzk|y(v`QKwir;lD_Bgm{Tp0b{5wiB}d zmBY@iVy@Na8r#r)oi^mE#J?Z5|G5c0FwTzonLT{!g#UAoncfV3AO3&GPQfDS)4KYf zCt`O9YP_@k8=bhntJ6PTFeU(eW8eGTlYjr^`Si>3>}x_W&A<9mL_+1O&?qnO6^Q(+ zf=uk>VUeXc7@|d#fD87||0PO-H*;`F$?5;~0b~_4HF*r5+K%P9xVyW<-DQ<}5|FKy z!a7x;R0$8?#>R%9uk^3Owf8&kMSlF(XUT^00d$z;MV4dx=@(0okb#vj$#p#OUEz(L zI}PjCuV06h7`<9r)$7+ar-y6jP!0;ZV{Nkk`)$jLXX%wZdu9S_J~-zlKfhd?nF{4jGTjx^K#c!%uj8bMZ}rxmrRv8(yq%JKwZErF+S_^b<3}c8;fXH+uR1zv04rf^ z{1ozqAms&z%en~*J3x>&iA}de#3?i>7nmQ2$R{ss-!+3<3y@Q>=T!!E+YpL*B3zyD z@>`YR^XBH808M%n|H~ch{LznLFS^_2D`wdjx74S>sg=je{-?{ur>M8H6G0XA3y}uI z;RC?}0K23D|7@t1C@!ust#qr?eM2OeE#AKS((&VLTgyTMX^Y3k$Cj6t29rh~Nxxo! zE<^|-P=k;>)iJPH8y@$MZh%%SVSq7A(|45G)xjE#-aga6#6uG4+d^HL z-N*H;EJ}PO){S*>v7mGL%3D5FcV7txori++CWSqmfSQ_`kZ`=-dV|lBS@u2<2C}6C zx`u`X@edUTlK!p?EQ|7jhIP%lLU z2nm#H7m}i2d`pHd#(E$)VG$h@lQ6QQBj|2mBvgm(eq`MIF1Wb3Z&Ep4rsxUjJph&} zzGHhkPxy26($0}5BD5okDnbt?Lg}-*;~M@)rV!XH*JbJCN4LE32tt)lo7kMKjN4LH3$1t>RX-3xu@2 z2IKS;6yLzs&FbYq6n=LD6BbR88l8 zm|%-QfU#-n|0gu=0DRTxPp~P7cT#$sY5UUydoYpZGR(VC8*R;zal$?_E5#BEfq6|0 zNf$ zs}Lowbp3jCd|ch03($(1y}UZFTNMy@$(7wueN#y&Jn_QnZAHQn9_i1an!x9IGlq_( zO?j=!xlRI<2M3wYmHx5ITwZ-Ue&(3A*JF@9NcHt?Mt@*-NJ~Q_WfMm?b^hKExmj0H6>vMj|Lz}LwjR#?sqS;*??pH9COYGf z^+EU0;Fo`>(Z4s)#70ncimF$7XaCL||4*{9%8Oe_|4YOB^S+^rzeHMC;>CUWt0(>Q zQ^3!9{eS=2W8@BGh^^q!h{q(fwRO{a`?WIt^XqWeloj|wbmWF0_+X+Q=4QGj>fm4> z%iz1&#J9YY2;9nV)mBy4pcP^h~!09c)v3!Me*nL4!ILi59@B@v26}U35!%ow=jrA(@){>cqS_7zJBO%z~dA#3y zZ?yH`n~+joBw{8lip<(afE7eUMX`L5>CG{GzW#7WHuiy;+~1%6=qUyxtL4~z4UPDB zg)G<<<2zpMh(9#&4O+eFk$6C_Y4SNhm1b}oN{hdw5dkpb)yUJWjwt;wR1JQcv-QtV z=|0QI$k-`Ah)Vl~BViBy(|FPSz(8q*C|vbwKQQsyKp=U4`ev@Q;s5x|67b*!yesel z|NIodh!{*>TJ(+s$(3dKas8S7R6RI2koUfQ6XviMswMvWA?#6`uM8;%28nDiWbCff zgV>W~N+~=%*u%I3S$#nB0vHwoA|@{eaBv4;6q;L7Vgv4=YYYse-0mAQQ+!5^o3zsY z&R)4_B0fwnbdwO$_Koh`SwK4iA27oYi~EKJrZU(mA4xegfTjEv0A2n^yLCn{bHI@_ zRcr3>X4>KNgo(yhWdQ`)Z~B^<&q{g`Z-0K-e_Q`-pvTKowAYwQc=(mAHWoyj0|VR3 z6mzg~aAM-({P((8dQ&S&;d7&%&nzDwJwDvqi;0z282x%2GYNH_7R+Xs)q7a-)hQVpenuVkgD698D1vS-G&{Xa4SuK6!`1n`_2ly30 z3|j`Y)N>mRV57bPuoFO>K#oE_J~BV*iLr#`bL;)R&iRW5FH$pY>mAzCBz$~ie5D?w zUPpD_36s=@x)!60*ocrC83TCY{zGeUg9Myl7sMqY*!Un31e=)X);7s7Fi@xBk@NQS z-viL2jI-HJwUG$m86dY0MyAdc>Cxf$JAc?^`a_v5+e4vvm{_Y12UkCJhN zJWYYdoyhVPUx+ma93oq%O458DZPP7Y=}q5xJ88dE-hLezc<%$nJqPI=T`MhfSZ8}a z0{!Fst@j6P-(qP@nRZd zV=5Z4eIo2|B2)~5ffrVT@!nGKYsjvJ)H$I%NpwHhlhvn`DG47 z^uR;fpMu#R__h}MnmcV;oLU3m0?`5GJ5fCdluup+`tI}S&LPCSS)ncb!7s2POc-V%*#wH{!^{>2L*F0Ss* z%YqwJ1f$Ok8xzOUfoJ3e#aj9DFnxI)@Qyi|w?Q)$hNL}si?NnD) z!HSRb)6&3z{M*+sG`t%e*KRy|jgQ~u^?jX0p<8klBfK9*oB$F^s04ws!(}OJoULT3 zjMU+^?3YzYGbAKg*g}Xqq=cW3uP<$?*6GU$uwm}{{!E*jJ4AC-4MDoH7l!f-Nm{Qm zGqaWcgPEfvt|1bQt(jT0FTNzIfaWO0SiEK~s^X0s?Ax+Uu3yD(+$d$yJj-Y0byh?! zct0jwhQEjzGz378-nU)e+G6&3nJ#C?D-rO%Sv{~_0tUnaPVSA#y6ox8;hu!)&KQoh z0J7r+rg$(tkX1F%sXEcDGR%E60ZSPc76uIE_zPP6;nf5kBFW!1#y|s#^g=u$*{~ds z@kyo1xG*=#Lpd! zeu5kR`t>(2c}_Qxb)D7il=i@75BL1t7Ej~sn;E>6r64qCiM?+zR}iVzqbzdW0{WUj*jv9V`JF` z66iweS%QvxizFFIme(-tg`eJH{qAKW(dzfJ5zau!tIY^faF^@8#%VW@NMMk@^Ytr+ z(!$bnj571*?rRJI0bzKwgn5|rFG6H6E51R~-teG>7(fU>O4rO8Fs6-I?oSr6)kebneeoTwFy(+3)t+oU)LD13Us}?{p4?v;B zE0`P~|2Fgr7%y5Fpa1jlU&1eeBYyL<(Si!EX&7V+~4=I z2>cO(31nvWSTxi(pK6xsd@L-I$Jm|kcFu+7T{B0xh#9#3>8|Z6Rld2|{KC7!>+#dm z_qipSgo?y5s$0S;O3a1b0@HPmPkQE z6Q(IjzsJ^$p>d@FSu;XU(dg9jW$|zv(b^3(dPMgzUe=>cLxjXwWHr+?o(pYbhspe# z_HnpQD!x>#h_>X*-9M2uEFj-wZ5{Fc^UDjMDG12-rEqP;QDbAem@X1ZKYhx9PI1|R zC1GqPLR!{UB&iv>{o0YUv&WZajm43!`=~dviAketDp|3vL|=_{8d~Z_Ph9Cz!kn@9bAGI6-7#8Olvr>imHC(CXW$Dd$_>*|vv$ zmCCzx)M6QD4s-1kHp)whWXfy|gluaG$2!bJhHCR&5px7e6CD?Hw?Fk6>>{9{BO&db zQJDws7AnVB)Qz$)0s?rj#g z78d9#=;-Ld_hbj@!gSH12)90aMaRS#H>&p%UtmdO%e6GYd=77b>nNSKEl14l>RqDP zAI>yZ&K2G&Y&1kf@rf0XWS(hqY11w&x&P+opz1Mkg}#eJ-2PYhl`(+>sy<%N2=pua;K*XpBUP{MP3?Snrq;)|t6o30vkCo6#H9N~sKsF^?qOGo&O|q_ z0-S?l>S23S?A7>rT6MXi{>oUqQxa36I;T1AGiB?{BT5uF1R%0pAWilVIPvRxJe-!w zF@4AIFx8lMU#F4qG*Et9?h86WEHz)}iUlGs|6lWj;kWhRJ!4Lb76%pr$P zpcmO-1(Uko67$$nc}doZMCpL#0eVp%faQe?iR}(6qk61==+4R>O1~i9cv^Hes+KKt zA(574ri3{$p-^Ton@3lO~nINZf?>I|9Rdi2ul~< zC?B$PCK^ifi1c;wa$5r7ug^;gMD`%>000q;yxqZK!w}fOq7*m3rm3iZLhD2HN~} z9HOtuGZ_Q`d;3Ne&5e|-rj#FSHFB=lCAZS|IT#o$j&?&59oBC5q6?H`l&3V~ax^kg z3|ZYLFm~3=~^S+b;TW&(ct>M}jrlo`~P`wIz3U8v8Hi{HOEA9zb_q(@C-A{+Cz zo*+LeVD?sx395h#2{&aKvw#3rxnC@X_LG#t$%7R2@`G{=lo(*nQ*R{Ia%DW$6`MgS z-yF;Tm2WjqwYR$(QBC<{b1K9ssmwH=q+Grlda`S@cBGZTMXGdnYJZ?s9x(kn7~;8S z7C9#5ugUA%YZ5|E?SgLKZ9{*s0;@t#Vp2?wSt);+>E`vz)fqsKOVlNz95ov-O!g232@G=+AY z`!ou30MJxMtWC}~qnK=@vL+a2hlWdi3;I#;qFmlSi}llu9#L3GMs#`T3^hGS8Q8J+ zeh@ZtbQTb=q85ibqbwwU3$Z)mUf_bDudO#Gk4A57DrCS=%8|EF?h%{JOmzflYE$1N zKU6%p?PE8|`u2Bg?kXNKn#3m-Fud78m#EJlDfv7R!IQf0+lX^(w0M35WITV4%7{F# zjoG}V4_Ita)|hc9_@V@CyvO&Fzc>>89>Gk-!)(H{<=WgcnH0XcM;hne!p!syKg~2@fY|o^^E>ahP{{C zB>i8F;pMRIExP|Z!l1WVc_e@JJpU6{K(er6f-y%`(O~oMPxZ%(c0~C1P6(MA|CBZU z|NVI>4~N4w0fe1VTue+=Rn@bV+zv2wFmUeqws%E5q@{0BIK77&GsG_bu{_fr7=^unZtvmaETZUZ3VY&(y z_kkpXRzI?8R!g(_&AYSj-eI8n`uYwIUV}p@{LjyJk^^jr2KTQ$kFeGJ&p-&OsZ>7x z%*_wwkD;XTRQ%H`50)NI250#z=WUKlj&1y0TC4soci2-r#)IYv1T(n|h(@ zAt@IcpNFZj$Cb?A*E7)p!~afS-Ucv3#t5P7T#F*0p`pRw?U`sSb03_Ukv{`Blu9N$ z5tOe33DMD=FR;HG85*7*Rl&?`ZaC8oCStuP8xvRNCqh7Uyv42t67(H|nPlsBCZuI*R9UTEDveMyb({CF4OT9 zi1@Vynol*-mJ_JOaM|xv*g-3@y-ic3%lvzxsZR`^&f}+{xs(R3y}%}V3I$ccAbhTJ zd-5S0)im{|Bx~#I_LH?r8Riz#b(TiO47{r!D{0wzZjXST)&eQR?$K-Zl2R=4m2~mb zXJ;dTQX{#4qu&*@ghbJR6KGeY=*j>kuT^ER*Bx~sq}j!Z|F+tojyNq^(CC#bO|}5! zgLkH$d&N^W>@V|$524?Hvs@g%G{;Ei2^;JW5F?h!xfD_f!JK_8L_L+H&uKOsn|ks_ z5v1tN9CO&c15e-L$>eG;1eHWH#B1VW`q|I(Si|W%xi8e6%&e>!9v!9&jt*Lu-81H` zsZO10X~Of2;L_sdWZ+&m_W$Xb`ar+2d+qVcf{f#lafS29^%v^z-#zfo z{7;Wwoi5rvt?12~;4uEsM;(-!+!oTly_>`RRn?Gw<)s>;5w3|sflYCN)aTpZ&-Ol) z&3bG-T*kt9nAyJUZa))c5y53&J#4Pk(}xsF5%Vekoy%T~vT{^r<}vi^aQ(Ty`WJ`C z$Hyln)#>>_;uMQGF(DM~uT4TWjR>mCvE=gmCW@!F_Xkbd{p;?Hj(`iM!v5-`M}Rhm z`$P&tA4%ivTe|BXViOWhw_dsdq9)NkJd#aEaeLCm?ZM{yG&;s6cd(|nF^m!+K=BjY zV!eHR3;R6&|85tuPd_#RD%C7aBKj(r{*R?b8=wG-jHNp{f z@;$WgN z{h z4BVPWc)>CSK$JZ?eo7(~JsNvcxZAfW`ml;`A7SKukmSsd_wg;~^eQTY9+gv{?|jvN z@sizax+;)Om#DjA=ZX>8z~@&Uy>3BLkx1q1_7Y`A)wk*2^`C9u<~Evax2>ppDmeM^ z^~nA(Z9)}hmhdy9@e7~Th{{pU;kf-QN_m2{b=!+Twmfr(s9703qlT@~sik%z2b`@O zN{f}}8{@RMb5v<2>#aqWHNZy(MCFJb^6T&os)H)liDfM1waq#6z{PYoz|GaQ-FxpR z8s61;VKCpr@nNd`hU1{u>^h;C+}&fkbV#vlUc}3za9({oPw0qKp`^tzU46So4rIfV z!#(BupRl&A$x%>H0Lw?BX_Yc<+;*~bp-_II{<};nW6ZnNXSU6nc2vp9Y(4#1qEp26 zr{j9p-A$^&F zvk>XE*|x_P%;PT|e{F5vy*hdWhCRe2Bx1gYD8p=Unp3G&pRNYFpyL@x-8Ffnyc-Um zwxc{YmNy>dnO9X~DaiEn_j~Tls#V-DZh!WSTdyD3#`uA^8tmdP9Ya{U!2D7_(jwJu zGkpHdlFD(_2t@)8L!+RFquYiDo_zW+JuUt<tm8f?ZCw9A9}$3tsc(C zsl8#E#GnNK1Y4`|-F3NKj(4)dS8YatlkN9Q+3L|Q{a%C}upvgjZ=@?pUk^dJ z8IIKW;1eRp`_|SH1`8Y{0F#|U{_eqSt4FRhGBQ%m{Edp0_3HHQd(=7nFW#Mo_e5+2 zDFmu#OB!rUSIeGt>WB8SC)X*O3FSU&95-Vc+>8dE$M zQ@Z4UfKOjKg76rCX833o;7Z*Xn+xwaL`9GKX;&^eh!>%krz7#$o$Op~e_`2wp4;C3 z`c10Z?hG89VyIg(+!S=N4d&^0+knsA+}e8S@Hs9|byFfi?R}{qdjp5~u;%YpLjxU3 zUJ7DiVPO~wV&>=rhv{Q)F?T`Nttx};kbn|yIqBE>&5b4~zbLlH4=`HeFDdf(!*6d(h4-jm$51go8VhI7$RPoC_gRS64ny zPcLdW>$v2Ah*#o%1&g%H^8O6n@Bw}W8b#R3)NXgSs0)fr8DcmZZiAHuCi+$K{E9T4ZZn0G11%{;~DhV>6@m!1-u?O_X_0*|g2~$_QyMFN;-)3><&r zw!iGM49{%<*bI`c?aTJVl8j7DxXZd|-my!0eDaJ|$nNgi_@e^CXlndm_HIkR=x)HD zu#fW!356Mg9?ori@?aqGyde4z1BaHDHcA`I9Wv2=V15O0lQ;Mt96M{g>v>h0Gq*-f z;qe=J+E{(_F_}S{sFbLv+B?gX$maJWFf$lBH}~JBtNN8lq$k}l|M<+#v|65k(aiFG z5*mh!cg=oSq@1`gH@%aIk96o1L*dte=-5ZPQxyK1yR-;uYl#RV5)yuER9JYt?P|Nj z(Qg*6ci+Bpe}LRyUZ(pc>VmlY>Hst|!TtsYqQdBG+65>kfvM+ISK`L{SXmu$mN}X! zDNk-mipa4Y<$~J)H;msp+ipVL3RzN7NKyTwRhKRn z_)6+L{I&*95t%7sizTJ{f#r|#9?Pmd=pt}!TxpTr2EmpfA#=2}&F(t8*RPY0Uh{hj>WPc$V}lgpEQ+@V@uF=cEGW;2KW)7T08}!He1S_-I2#% zQ`k&)(F(ZsNX945o7&~;s=C@Rn$H5@gag7KyL^jJ*v7|PcSq@P z$nd4}5f!DSX{f0cDJfAg(B=KP-iZv#G6K33JPDb?4l@L!sAP+gI2(DIDfUIW0s;@A zs(7fYSRO*yTDYi3nPpYQ4^A`2{dXME`bBWG0{Bq4zEgYG{fc~3pLMT2kcunrH73S~ zomDOTn4zGd@9ell*M7YSpZOW#Zyw{W_(pnUalLZvgI@}x+Qj*%4jiB2F6J;zswZ8w zp`#j;ve66+%X+u6F>$VuL`BL`o>1g=36YVJJ$BWX2y;r&yUS<(fFs>%_sPeao!IbI zwj2};s$x$PEdJl#&AdmK{du{rM5=Wp9&HgnZKkwzG({cwDvvW_(75&nvu*|3OLT7v*pI96F9q+fXYtDXf{U+8nIP(gHVgd7jzqV(=h>BGW~Ma$)w22ZOvg6qG`s z%)Rcv_mMW}3^xkF?`%N+z1XmpB&aSy(oznfYiLqM`{>x$~!7rFP`)9%uGHIhA48?c)p6S>w6CA5U1kn`OqR z*aFcNt+N~H?RWk@&%^d6UEx&Rw+4S4HObjq44q=T zxkj|Ann$J&_II_`|}31&|+1y*n=_z5|#_gIju0;$F&n)oIVP9v}2X`xTHatI6K z-mXj1%hIT*J1QRMug>}4o8Q8$c{SlHt3g3LSzL5oo~U~l$V2#5=n+fvS`60i4Bi-5 z-k+pUeqeUuVsh2Vfpw0uhtp$wCSWi*)gUi|M07E!bw+tXx$curQAjlsA>ks-?;Fg! zCql1OPgI|hr!l{IpZvKN0fCZRMNv-Ae3KBj>X%~$BfQ=0ZG31O@WKKu?(1}Mh64^FY@0{$}ggq1swcEZD8UX=;ZhpM`0nvI-n*9e6J3mwc>+MCnu+;YV_u-rTOMLqXyjw zbx}gX`T0)c3EJg;qWVQ4(z04HOcZNesjg#~UF%&sKU8lu7wr@Cxei<~nr!L^(+7>K zTN6>*P=0+UA~>f1N|5&RQ**u`1I6{MGR<4jZxJ>zpG1ZCv2N*=)aQkS#rHF1$d%#0~jtycLX6F9SOCW>7-=Ej%{Ml!3)Mv03u4 zfGbGIrgz)VK9NaR+^)zj{ioV%c!^HNGXGXv!D{I`iDT*YTl)mzX&l`-CWsQ_{BIoj zr8-VHKo4Xc*MWEok$?X1|9&1^iAnSS_4HF;f}*2lSUn&A{YEckExJn`|Ns2;habK_ z*UUxqrZCmg($djcl({$q!#|NZ5Xl`fIoE)0p(DpqS}!cz2#%#)e$iH+Ur?!ge>d{? zzl;mni(STQ z36k^5=3PYo5(BjTDv-9Q1HM1vH$=6A~-{UpNq}~M}~pbo;?e?BRd?Cdwa{r#5t9quuIrJ#Q&L5^IJ?5wdXB0m+&A&YQv zO@Uqxqc9&xR=t~r*FfiGZ;)~+U`abtD+Muy)39Ff)-f2#u{KT#;+c&teh<0+GNra> zL!E;xGYrObu!Zw~?n_}KqLuQ^n9_OiF97)EU5SI??;Fz*N%Ai4-!~b!{Bc66Quz1{ z_g}6F8vW;F(Sf%pFRH7n-42f24kmH1v0V>##XNuaXK)f-wi+Er8=qJ@lHbk$%qzms z%ZwLu!}>a(1v((vJaRbrbhYq7%FY9kl_T8OANQ&3~`A419AhY{#ceQf)~c^$G=#_3OvA^uIl!v}<7F5m?v|Pc_?1`THAp<$(2P z#&@OTyy^7Sz`8i&OI8lusg#^YX%R_j5q0}YsmGphGUBZ?!zY76qXVca7oQkaUXhRf zb0Kjhy8IpPFFO_tzPmT5k|tK-e$uJ19=`XpcUpZ&yrv#+<@p0kxqp6P*~+pSJqc;I zKyrY&bZBU3ax&q?@yZU&VQi&a8y*CR*cnCUvWK?ZEj@L51U*2TT(tKv#=*>7HQRuhR;Mp-xJd9&>Bx|2(W7U}s>UHihLJ)kE{m_PI|O!qVH{fXS-ksbotU+Wu`!{)zkgr= z)_MZ4>oiN5b~tqGSZVMQS4c<*C_UI7FH$~0LhW1JuAD}?VKO!t z%u_H@e?7%AuJFxY%fgmd1FAZ$#c-QCFS7-8O%~VjWW}&4uII*A=A=Ar^#i9z4fcuk zzuUXx_|Rk#c^IgUNbNAmQyqOA_d3d;4Nz@P>B}G;Q4XL1=TQh9RFsoDcd>E9R!SrWv@Dp(UTW8df4hjP*79 z4vi6`E)oS9Y`N}R%q4k(&?jjpp*T9*IEKo|bH}O6cu!_Tp~BSqNB!*(rbXwZFrBek zJ9+X+sr1FmttTT+{(F6Q7EZ;^3>l2F_XQzLH^Af?eq;m>p>)s(C|xk^Z%eVaw`6Ox z=NrLnAPH+-9T{aHLqii$Uj8ywJb{UcNk{yht?l#|fPO_p{QAT(5RH4}0Q;r4Z^Kts z#EgyO0S~RdGV&DqvBMaH_hLQR+qN%H$Q<*WmS{%ZeC3TtAtf&`9pc?m_It_9GR2nM z80jXt)Y2cXVfrfFVsU&$DECgw5`xa4(~~7GIZWF?YoIO!W4+&GGIy8sF{zmWewW0( zF33W&x7ScrRYjpts;Xr`vBUQRZUV)?w)Sf8;2<3mW*F-Vr;-|TY|c{AsTtT{xH=|# zgUeVu(5R!J7-?*-&H=8~5W=nKL8vLvn@jR`ax%l({({UGSS3l@t9L9J`zoF<^985NTT?%(!xk@uKPOdE?ctbS^!=J@pqrDfnsd1{Z}t1o)3#d` zr?nsLC|VnI+y4ltwg{z`Liw&>S^)IXmNUS^yz@cf;>}25tqm(%+p-9q4*2-iwl z)jb(`s^7yPBjOe$+Lb`lbHwg>QCxNPaSq@f2Ce-lN&MhZ2nbV^Kjmg|_Hmm~U)aa` zjJ+8-d0*=MQ!N@x(IB!dHT_KIqbHO8T9ltvdK+%RDaW`BBN1e;_>E;5D(~tsgvWj# z!+?B;xAmQ&0eeLzsu>@2jr_%`UFA(XeL~`>=XsOBUs*~PB!X|!Db+Imr92kyfQ8Ke zEj%@;x7ew9gPn~}Eh$|hSwOG>EW3k3KGcD2B<+paA@)lTES?chco2BdTQJH!N!dG& z*S!g(HnloNU36DdlZfoX-FCbM71*S#tgyH%<%ET{MTfg#cWd@)Bb}DNBb6aVaZW~SL#vQ!}D?rwTdID}t zR{V=#s0_VAD%Pz`6V&5nWo38eY}NGjTT`AUdpL}1XzqD^=vczIZ?RHSz3vy1+V$Y2 zOE*pun%rDJQhCRBLTAo@46W#3dI~3a-Dg#k{qur)Lhg?$#!S(u*7j=$8^a-jNX~@a zTl~W*nI>HmJ6p)`90StC5&!P>n~*UIY^GRl8Q+anQ&UMP<9QQzVihmf%i>ZB zg7WyKn0IfKVNO8t<>V$9FkMNRUv}`A!glnHl@I zyk34UgJ`T%ks04-7c0>tEA|$(_&#srJwMUSTxgb#dK-szoHXvRSoY4+9jZW`wbEMU zN!bLdcy)CEgguuM&~=XbM-jh|rvH7Wxv;HiXT8~Okh&RMtXp9hBcQgHiW!p$3XlKN z-6IbX$gxa=ik%scq85U4+Zr`+!suO}bdDOL#EY^#z@mc$CtC|1zs-<%ewfP6Zt{2w zA;64FD6g%y^4^5XqvqY0mWv9gL~~!; zSY2DQvdX+RGk_imf};Tx9T4jr1iO#`r7;zu@vi>rZ8!7UYu^Y@PX81N%kg&4YA{T7 z8>`{(35S9N7gD&|rtqX`qiTQ=)=~eSK&4wZ<5!M9r?+gjGcyUvjLsrAA&(Jj7jj?1 zlp_mAj`k+&Vknf}Wn9z7zQ-3!Hb(oMDs1e+AE)x!Kv2loTMF0+mj@w|G?*)IC4GK8HPJ zFl0oNA+}jdcw2qC%tHd#BhI<3KS%ORP5n`xlEP-3ZHPa37kMBW_jxxzDL&#(@P&$=gwgThCw;zu$H0CuZI~?vTO7j3V zI~WyTm*&WT9!`)j8)zA{RnoJDK#&w8?8zSki)KH6ZAmHB$~ZmH4x*zq`;ypvnj8{3 zzcpZ(=z|KdB=Bcv;;giW)V{T4&*M^ya3iuTgRRpbkqE}WlZ%rY!1@VWnGFUuKk=3S zvCB|JuLpM@@Z#m=1<5B2i3@P@D0vYJC?&Zkf9=cX;O34BO+Nq3Iw6Yno6Z7>(B6(G z5X^fs-FGzDaNvcX=4fx{?<+PV9+^i=;^Ps1PaJ=_+M1Km?uS<>LBOtusQ@U&pG*2Gb=-Acbcb_mx znr_<~Gq75sqA)a7gxsS% zz_Css7QR-?Mf0xzqD-{Ja_Wd?8jFYgUJHm~u`6$+$;$!>7$l_Hl~jO;U0kfgEIs+Y z?p|)@a@3^4)iQokfw3TE7Y1U#Bl?Rq5giLGO;Tp{ti>Ee+k*7kF&C%la?5T5&r zJmj62rP6!gxfee_M17NAU+!>O95jm6l(KrCr9e|krgX2fhlJIKValCaIDF5=5TyjV4a&0PoIdKeXpu(YOoF;-*a6VDl`+#%KZ`}a?TN>|S^%3BV> zfPKAp($bbY)6|2gSaJ{rhpt*pEBJwlFB=yZluO;{D%D_SZmA@4)<+w~vmw#}v@u|t zm@lakivQx~o?*tMt@3H;pvkAWPt;Ddi>$Pus%VU)b5Gy+-`4EEt(XzCV#GBC2Zy7o zx4X;vt!Q1l-@PNH$HWBxysKp9J4<5b-Ght1AAv{Mge%D^D74K}JNe6&Twc5F(+*xe zY&Hc)6%TW=GsFw3r!tT3ed>byTmk`nQ~CEb!_Fv8yuW1i%19wz+f{wH0i^JQ1FOco zsoe%G^X`C$>K`zw+KENANA5krDA^VH+wD(hOuyp*huDV9AbocISM4R+AnbImbHlFN z5fly&<2$Nf=F#jz$ij1s0E2xpid@-k=<9pr-s%92yu12~k5LkrEPT$j z3oJ@Y>#qxrtFNyI;lb*swCLN#;7dLUy3gcf)1o4AP+tKlR|OJFvC=j#YJD7sfzEfh zuf2V0aT3kMef@}#vueO}Ar6;F_yO?>_6;m~@~#E diff --git a/docs/images/vscode-format-on-save.png b/docs/images/vscode-format-on-save.png new file mode 100644 index 0000000000000000000000000000000000000000..a03349b6f8d55325bc40f55d9974b86e12989b26 GIT binary patch literal 41262 zcmeFZWq4dWmIZ2Nierp1W-c=`GsnyrGc(&UJ7#8vn3#)_Dp~CCVhXs zUvJ8%Tq+&yBOOU4?Y-8j3YC`?LxlST2Lb|uC?PJa2m%6y08CH7Kmq@6Z&KobfFN*~ z2?@zd2ni9&+uN9!SsH_Yh=(SqLaQkaV`OT^M)QBok%Dc9oi2?>(a4vC#`z43A{pYB zZ2$;|tI(#=6H*mH(^lr652L`q0QJyDQIMbS_t$od18X^_-blMh<9dHR81tD(=W@8f z15uu+3hcpEM)%bc@S`9j@y(1+7bL$0MJNXQWD9<0DcceK0S^yJ58LcrXMG(aB){E+ zeCo;c-G|m(ONSR4gyhpUvo$X{=5`*)COU3TF$hTRH?|A~!gxJ3zaSVWm@7uuiRdjj zSlPI(Ud6N~EV90F5DJRwrCbD%_?6FcfL$Yg#65u!JP5505D;|EzK-T*H?0t*&kg>p zf+3_&_+}eNMlUiQBH(#X@)`( zl5Wh7Ui2{fYy-2I9wE!vL!1b821b#?5>`%8_WFmsa-5Ec$b=?zjl%Q2NjvbvYIm^h zUsY4M6SWAG=td%>z9oZItAFPEjA~#Ua&}W|*t^TR6V8|tL(EEK7eV696k_P=9}SYi ztCCCy7a6mXw7VZQhPe_mY$`HhXC+{wRZPRD#uQBZonQje;s6%wikP$QCI2#}+1AZZ zpr+Z-i(A06OzWV%ijYv06{85oA$RYt2^K&u+>^$C8mo&%O%P6w)&)s9GdL3nIb~PF zew9me_wB1X_k%eKQZgaRPd}`A=4j{|kWQ;?Z;N)S(uZ`HA_sqM_M$n9s^JLF)<=(g@mU*X~KZu5J?;m6OQ(04O z_Py`^jzXTh&j5ztl}FMcS4%DhlC@#T>aU*9rXJf0jtkRcF={gc>jC+gb10Qj%?}V=|1bznT=3-O<7YBPY2;pPL zkdAJEYQYAgu<993V-=R~l}B)JaFovukvS-P3$FG1$p-tVRgKGeKOSy%vHZYREIeoj zsq&`m3}jFjnp*cGdv|3r+adUWVyJdiciHVRn!h;`x3Nt9f&haD4!#m<0 z`!W8cXGY5KH_4uvB65UnL0$W%k_-Kl^B0XfWV@ep&g9f*1ii3i43mf@eSEBs;XR5~ zj?&-8dnKzF%TP%-C{TL#x_S;72)J9zAe-LUurI1TSojKd`jn z5cGAT7DIUX({_h<5s`dggkgf||HjyZ-^0-3)|BK9YZEG*i!l{@h;(nj$Pmt+*5u!m z;2Po@v?y@;87W4bL_3ytI2cXDAP!EvKYu(QJbxx%RuOR2?w{));~ytjB^c(Lfnu!LP9rm~6OE^b@DKRj$Lj39nC!7@HsGA^M{k~-mzDnp?q?^mj1frk8R z3FR!I$GEOp>;}GL1se7s9EUk6)wD7cvDv|S4 ziS98$N#lzX*0dsHzzTt zQ$KOby;mvdRg{@nm$+lfJ#R*I@-WpAiYK@ubX}T&d7cf41q0`T*_!Fi$iNKMre

      ~N&M>Q_~(1*=M90_)D9j`g>G_F6m2o%sk0?EAUyxzB_8jlDc#PJ^(K;kY<> zx*SXFcIhJ-6yPB>KXx$rb*9rS9BdZeDmb+EPrddUs7MSTi&P1N^6vW7Q$d{WR;>v>MJ zot5v_Pq)(h(uJDgnoF7oA&>nn1spQ<*T>qBa>}dJ7FpITo`Q}7a_OfsJxP2dy@mXs zUSe#}HA8(+T`-?85-~fnV(52CO=z=j>nNHIla?MVCr%4F1{^RZjxtA+ zTOIHj0aiLQo->b9`}cG(>Qy$MjrH$(HZVD8G+GbGxBL3POCcoEs7>D}4av>*kM!qm zYf7~zS?dM?b^sQd=WU)h*OjEJv7-e@1;zzgsNIMsOWc0zOo5 ze{j}o>eI>ia@BGnF}|32WGX>9yC|26V({$v51g{evI}!@>qBkgUf~sSzH(0Lz_&SX zah^OS;KZ{AAL<|%9X#&53}$&Gap&+-dYJ#J`!QK^A?#!8^IR)2>7E6j<@1T+P3deh z3{wRV`L_42dZIV2cOf-3x}{33bJDT?Jg_G-Bme7XZ)39!Upuv1<+Jw&bQCfz!ACyc zSLPk2qnkp&yzZyYAg^}5bS`chqwvLPT~GuSW*$6WRS(c?GI0KYcer?onwzXT!WyPh zG{5(6#-_q%cHr4itg#!e``92zz2;lU_4+uFE9^eLoLo`!F}10`v?wWsU6B^I2n8}k z#k!(IocCYo&IvRL6`Vl%8s5P^(|S^H7wrCyB@&I*Bur#vK&XIe7!XKMR1k1r3KaMU z0{RIA@*ims5J^y+|4J)@Qv6j035Z0ulYZ)WRg zW@AnG`?~rDHcpN_L`1(U`me`7+iC1-_TM#GJN$K9z#9boJ_BH&qX+zNW{zeie=z%f z=AUN&xUYX!$Nl?aobqO_#+GWrW>&zi1~!eCfrXi!`yciEzfS#kOaE#5#lhHK$i@n2 z>B#%vgY}p3zn}b{hX1Hj{lDvEq-Xv2D*x@wzghmi2Tny}2OCSL-+lPS+RTxcksI*8 zW&ckr_5U{GWngCh%jn;8|EGo8|7!8?x&PBb&fW~z5Bk5G#>?|lxyK(P!P8K(8#F#ZaL2{AS7D}y{FCLa14Fdb0kC!4?qX)SS9-B-Eao_)V@PEke z_C@#mk7a;Y;Qy)DCCLv)@;65S=*izTE!r1YVZwiI)bF!U;ParUgnx5L_*!69efrOR z0Xz$AJm=rE9E_w38>$Ta?`{w*7DOAh`u}SDJ^%jy(W}0k(VvB&6iVk=hztiJ%25Ai zhFoTmL?3n9F3>}?yTx|y)&pRAU5D$D$BV;rlp`p`mp~&>9S2=v(d48xZJ{`PHAU%yWagU7>QRaW)CQYU3FSm+aAD4D`w2(h|6Dh zV9?gXi2TEcmQWj}?_0OtW>+_n=|nmxI2PZV*VQDS4|F;&FRzYriQ>3qr_BcMsGjXb z`#rTGD3Zxgw8E;74>W`8WvR-tk5abVji$)+9WsQcROefZRs_MjPS;Tiy(^f@>XayN z+_Olxf1nYM<2x=utBJ6|W`m4OCY8|p)k*ylTkJ9d4xK8jLYv@&@kso~$D0FHCObt% z#lFyws-%+WLP@1CN=!eBOXzx>IVseA zWiYPlYgQ_f{Q&GXq}|z&0<)jlF~vIVK_keMk%E6*iew>HKS>tlDTK8i|0qqU;r%(9 zK%-7Y5#ZP9$!4=okuAPZW3|GHr>q%Y?r>0{vic47B3veoRpVJz5kxeu#&{G`Yj=0o z=o13>*V~f?-FP}}(S8H6kt+QF9z}=-ct}Q*hTXB0(W`G`DNNyE=+vQ~h1OBHoGme< zc;;o&IUEKUtTaT|ombAbQ%p0_?dt7;uA$A7TPQp zDyT2lrxbIAhkX&C9@^(BH{`Pl8@~Kd{@&8vr2=yP$Cb?&8O)hBJ4*O{|4`RErASmP zi`z}`b+}b%(@oZA+g`+5;R4BoIo)>mTcH*kEHK`; z2ZyWyut{l!gN~PLoETb7=Sd;6mMC>duP5#cV;b8QiU@0Bu}EjmUzHI70!7B7DkbYU zSc-q#P&Oq$qkLpSkXFN_OP8C29Bpy37+2~+io$!AU3Ak5#V%97Nm^{QshrGxe>|Yd z8gwOO2E!`hvs{Epd;Z)MqF!%akj$`yQ|)qr&jJroQ8SW2ZKF*h7Kv*Q@osxHs}!Yf zXNDaTC5J*0K$)z5vlYD4zg%x&ggqM8V6_rTCS%2wt2Ji)gYNaff(u_%~yc)#lovl)|-?^Db5J|$1k?~i_xYb{Q58jzek$-LL%nC+#< z6vvcW?oKE3LjAom3eR_VxNB+xZr*cWR7*BwOB9VEjz_%8+l{A1V%g8kRCN^;>rh&HiBgX-#zr;F-TWQ}24y}FIt+~6$cvuKk%_p#`& zTfqdy3cY75eA#Ff^M0d#n$~8Nm(bXpzrGm9H+hOvJ_I3PlO==%I>y&~9p(goQP*+Z zQU~<=B++RX5IsOqpD|7TYU74mE6^JRjWC*rQ)sF)o61dicsw9Th+W}ifCI%cdb%f| zSlcnWY0Ox?pXBWSkV;-pD!6^_vu zI!JIqiGD`hHk@0hXUea9Y&jV4QcUEOp!3P6s%Er>}V2h)S|>pnax z%BrHQ-SB?a1}t#H!onVNY^A?G--kY*TLfq8Hs7kKu1$qv(52fjVH~x(gf`Zq{zn2_>42bT8KRq?~Qeq0f80 z&5gEjF_`f!(_?iK-!3|s;GAr^u6eYc_`UP}P3@@R$id=$N{j&0Wz8vS{Ln8zyTwsy z@)(%YfSq3UF#ti&3rKYZb7nf-uibMFJckJ{owrs7sHVi=OTGiQG$r6>FnZ-kBh6#b z$E6cKNKUScVmKJ-%st4&s4>P}IqLNXSJrRw^JS%4?`EdQvecf9p~PG{{d~x1JS904 zlBdi?;SvU%BSlL_1msgL#pvah%_wB%t04iqZ53|HDJ#a|O?5xT(`TWeQ7c0?U7*%{k<^SQnHV2)4lw)zy`s>Q7EA4&pbIZ=*bVY63t)?c6< zF3qsG>k{EbP){~R`VAHO69R_;2Mu#|GesGu$X@_f*H0A z>BiVDeo*4jkI*DkT1_EZRS!&l*km~{CZJ|!(|u>L5`+5TDQx}WttN>21nDoZBda;R zLcF69G4Ec_cMfHZYAf4kjf1Y(@U}c{V(xdRw5Hlii2Rwx5*8+z3p>1j2%`8cQ7WfHry)y)OU)HCd|9x&bPqU{?9tw{bm-LSaW->;TMmtMR)Btmx}E7{=9haIOhwsT z^i$xj*gVGAF9}5q8UcwCZ+tRO3-*|@UGl5*q@vX-95IW_MWsyVHP}8XfV*y!mw{S% z6u6!C@x7PT@ByD`?0Q>pU>- z6VhhAVDoub_J_)5=IIY|Gf0X;2-?csMULa zd$pf^+)0c@hmUKpz)ZJ5G3s!=61;U8rKK&KnheR}eU)OcS&xFzuzx;#Cx4x86^qQ` z@eri~A*hQ_4unHT1#W6_Oz>LP22?6#G_TF73LV4c(w2T`^-X0(+h`K=<(lMPHL6vL zHj7o=aL_o1Keq&$>AGkmi~Md{FCuFqZ;x)$#|gN!X7!YtF`Aa$&YOW9@QLWoQn47ULfE z(ZWUnVLycf7MJtsV#T%f&rQ)%>vUc(Nyp>aZj~So2X6)M)fg=A-Foh4OB?ib2E#;S z+pg`7rxwnP&T@`z+@l7|rBgt&)2Xl4MK?F51+Qf+JPMZt&;v3%bnV(kVq?Oxsw^=7 z(mEwL$YoUxQ+sp=O;g!i*zhFe-o&9%z3sC-Bgbd2)d^aW_p1d5xL?K7#bhdlbDdax z$6-?_pYij;0u95UEyVE3WIdC*+6>4jH$}*LdwL|c8ci%OGhAdd#oY9+*V`AkSm)`_ z@~N0tnC6*;K5h(#p%0|alAmYp(!jhuVN-tWxlK9v1fC3=4_OiGetVqf(%t}c#Ah(r z?6#o|u6O0inpAc1h`yt;{qVx7dAjq`xwhj`!ji432%`*uLX5WXd@0Md-ybXSMowng zk;?5KTe!uR`$KSn!UeI~+izGTZH~r;W+>~U<~ono^!C$V;T6#Kb5K!{2!Dig3`$(e zY_%zr_Sp|yw;=+O-FCAJGz|>Ju3WQKbb$DjlF8J&a-QZgV(=|VS2hv;=8Y=*bRf4n z%bRnUQk~yU9$yIi0*r$A@C+-1)Be07PnpC*1(CXKVzqWck#bJap= zc7>72nSOd%8N)FDeJW4vJDOmH*w4vjIayf@zBl%jWib$VQj4RtX9*7KywIoCn+dMA z5nmC5dOb8A1e6%mCK5*Doq^l^ib;Btl4OHx$@=pg@J~eX^B*#lP48wywQUwA5qQ|Rx@81dd zCO9EQp(*z3na%8Lff0by+VEx3j7o{3OvQV2wo8KkC^N=pmoF%Ql8o~M0-k$fs7Ybe zmP_$>$dCYqQdL0X2a%$gm9LC53%iMb3XPp%g=KL*6?iZwcr}s4Cu-1}zXC&3;LbOZ z^&XBZp*6f5D9x-M;dq@TQn=i-vs782)N>KY{4u7Vil{YEunT0!a0jLeQSL}fxBw`DPGAzp5FXx(v>rz$K+ep{{H z_l@J%hc@(AX#?($Ym_NrQqrq?H)rW&FBx>+Z$T2={T~EE0B?@xN`I&KG>~2ZqrFC$D)bFDSg$?!Mi@e$HB40O-t4T z=zRHMpSPoq#f`jbN}`S8rek=b@@xr9;idGkDT3j<6a~47T7FWOtFIIHWpIr?=ml_{ z*6e4{R;{;Ol6+cmX$`MI9R?8{-|^J-cLA9%ELJIRkyI>Av>@X@nYSuaqR#`ffc-iJ zPjKS3z;s&?K+nFZo`)dI6#MJ3#HvU(gUD3b@yk7^F?R$p+uCej>Yi^sxgyh>+neb2 z&JG^nx`xYxKa{bXpuWrgM-OD4Nhc-rMyQ;32`dI31-j~LkeWyx8U&uk3$D^X= z?dOZm1nY0}#fK-AmE=Hh$(pP>ut@e*>k~rI5B8T1`kC!z3kyv%@Ap?96)ZoXt2P9g z)v9J^)6Swbmj0MgPjCd1Ns6I7PzEiYM7Oqk3U==fuj|9ZGbeSv(m0v8e_UD`#^GSH zv|VL5LDJR1D%?dI!=VIO%R45L8H2IS5!a25<7M*Hviir#Mh3be=9tM1+5rzW-E8HnzJfVQ~M18pr=N|+uW!e zzDfbIV5)5Lk>->-ZOPYb75BFo;pA!lA}NLv6+qX+3To(dskZO=A_{$3&9_FSRE2nx z$b+s6Zz$B~wSGDAbT0|IgayqqCdp;9u~WO%!z!2?)3E_BVpI11Jc{yO(3WAg^PPVW zY>@Iz0ygr&Y=-qhW)U?X3(>9?SB6-(Oi? zchzTgzy*&AJU7yE@uwB;wB4e?I9wA`ukPLHIg9)lvtJOoOsXEK$l4T?(3sxC(}~$U zgRWl!wNE3Sy}L_xgqoTKiKo>HvLkf(sP|~;+N1OP=cepeGFQB z{Yt4RZUbUsh=W(+mu>x+y20vZhtz2l-Dx!3{-I!3@#34uOH}rm#<2HU}?Zy_R z^g*>Uc^m05{L`{=Bt^Kdg}OJMCP&%xs*lb0#&fk3<)9pEw<8*^khfkd8rkbKT%}LE z#|eX3;Ln)XX$i&&l|)e3RX?~ptP4kx1&wqH0J`5a`{U0F{2$bF1W6N^fyBf1nhRgF zS!_Hb%jfQLH8KCk8=o4juw*xA)bqvaS`cCw1ZrfSS#_#JXb5|AHM1ZDw=bS=kIJLB zsAyfaCa?LPUB9=-{bz!XonXXT>ek*C*Ke{qo!%MBbvjiTOIE=f9ph?QV;ml08eagvQooBU&hd4Rjn&ye&1nS1JUc)cE^mRt#sdH3$ zDFVPyibkXwI}2m0+2J5$z5Q8Zj~{!(%O#!N?n8mepf<9w`=nG2t1|FonNQG24{j1ut`KCTvr$kx?C6PPl&-P ze6DwgsmHJdi;F&zML3L+CyO_s^aw5&N~g20uioN#?TEsk_Y@{(%Qs`JPPmYkzIspSbjVZ%4YJT8WLU0rXx#31#Mkb7drqHuGG zgzS8JxV_=1d#n^C;!mt@2rL+bK0Uo-7^uM2ue7%no6!P~7+A$-w~3t>v})HYu-^n# z!$Uk;`)_| zy$>=PfppcAOQTWC54(}U2nR{{d5!er$OA9G_Qa{Y4GaQr_Vs-nfIE`BA1_aMjy+r9wZ?9J>dpj$dcmyHDkw(GncNe>SaKDYeDI=exJAym}_l$!NgOMgT|50AT}ljD@*?$C!v zonz85Cl&geE~RPzlmnKgKZeH75Zk+g-RsMFi-5*SRD*oBRVV@VCa-7Kqtu~ttvfeG z6zI*y-~3~<2?Hh=Ypw5d0+0s%VNZyk=aFL+rL4XQ-y!-vb^D@oVHty%bu@ZjKVm2t zo~*0{WaBA~%_dgz7mu0OQpkQ(%sD!>ipt)dF@(gKfAUrggP~{|!PD%-6?f#5Mys=S zGnBAdJq#dz0EobS5v7tdZarw8S_Nn}q&M9ybN;aIWtj;>@02p^aTfzmF>R*z06Ss+ zy4M2O@jY)3^R^#1~G-ohq68AUY(^x>NKUIszuGOLUfIfk@Ty4_HXT1^8g=aFM zQti+ff9n2(y#EBlDPz7u9iwi3-?#Ipjlu83!vZz}SgTbb(cg#~Q0Za&zDW_)@*~9k z!Fm5LT2MF(1QBY=bb|U%p4VR``Nx1V55j$XSa{(-taAU7M@*6P2MGL1xe5Ezef*V= z;sEiLKBQT!2Q214Hj!N;r zxfcd8U#Ng&4-y)bzp48Fy752tg> z`i1!qx5slIDJdzpU+*_QVghuenNaJ^wW&EBUF9v;TGS)(o-1~oMiObsD>^$ei7Z*nXa>yTmAmTw-N0E=kR^DT#3?S&pEo!ZmkBZTBf<~oWgEWy=6O{$xt%I$j z!{s*)?y})kNwouH48!rb8pO)m-s|D(t=B~3Y19>Q*=^;e)9(6x&hEfFHfYpqLMpUd z!<(Aes~wL}tKDy@PPBAy7bOY7JC?1m8I4fnxUb?pp$hs234AE#E3^$WF&wt2%iE4X zQLMh-9887-H~NCdy~he^ylOtta?M6`nbcJp?U zd^ql&wX$258lS2bw~Jul&NgF+=fWy=%`Po<1c_P z<9k(0=XPTpKR*HrMwG(Frwc~IfGByG+l_afcIlVW`CO% z^nfk)6mkSbJ|WP2LU_@H0n+#a2>35SL&*$zPExS2SIk&y%m&mbCYi{oAhCn`i z&I*%Kk=Yz7VD=v)hEAo73am$IFHj&2Dxj{k`nS5L9(p2^M<~FLV654GFEOltpGu@q zI>izST=!PZ^q_JLD$qDj^!pdZ-I-&m)oQE&r4Fv$J@WM|X`Ev1!X-L014 z;oFyP()^NJq z6{}pRxtoYQ*LdVZiIHf!y*I4Y22aZ|`zzlq?g z-y}38J2J10qT#+O;8OY>o+OgByR#*Tt z;{YK%9?s!bD-94@bdKUOhTTBox$o|51&sH7Bee>sn@}n8+8xq2Ge>)BWQ?ePKHl)j zHm32la|BW)+m)Sf5%mV5?c7JVvR+4|3pZ-DCiOtL;Ygv=Mu+|h!vAsI)%zk>S3@TT zqKAA_Jxa-<(X9}<6Jl#GT0@g!egtQIEy%|iDErQ+X!6#>MUfCz^p^-r+dQF8PQp{LGMKF*)6W54yH{1^=5OzmBDbbl$0}tuB4`(*wBA&(< zH%vxoDfXBj+$=UK-;ikB#c(yB%UxQSBSR;ZB++bm6pcn=CY?#g7>6{^QoEyTzqE> zQjthpj=3u!4222wDlsPcHU=fL*8QLmter}xB6+IYQ>bp>o}zTT^DJ#+@t+BhA9}$X2bglq2h7`WPy6A z_CVeRC}og1lHAT=b|Q5q-IA5Cf~tZtXy%+}ibADWB7G>y9oR6e(lc#h)5df(b$j#= z90f7blk60ZhH^0+Vgh!T3x|kLGDEtu@h#6@pJ@$#M9}wcTh(>u!HIw*9Ubo+;uZ6thoX6cqJ3|=s=z;W`1|uP> zyEMC8SQ{f;YPEvo87?<=>K2B7+#6LzYh0aHY&lD|${6JT1=9tnIKo+IvrnL!D_c{q z^{(pahR7}p&@%!34%r=TxJ(_&zc-?)-mhJMjQj~6xXwlcjq>l>ukPE!btv6PQDLI~ zIYNlUcT-1gio253HX3&2Urs)yRqMSzIT`%S1~oqeyGbpy5N;Clyy{O9X|z5U&@#~o z%9Gn{z34!H$a~>}(PD4VJWYQ4I%^FTKp$0h&59;m4x-Q^U)L;p)L?MO7?{RuiVeTH zZh9~));2%LUS$+PVXKYF(hI^Cd%yhLH;mUARy$pcf=FpAp6~4?Q?|nnU1s- zfQLzbJ=da&R!lx4A@HzaLJy=PeR12KW1lmziTns*jbIqPQb~M{OH5}qActOF9v$pC zPirIL@qBLQlsVit*7Scvv7LL}?l3^vk}~`S2DOTo-iJE9Js>9hgS)CpSVO!-v0%=i zh(47a)>GAh1RbOFCSl-++sCdc2`J2=#U!r4Mg8dGwu2=qW3g0in1%#Z|2+<1J5+60 z^4!|%06FM>`w4~{@Q{b3qUeFd*$Lz_#GRdHpAb1GRt+G45wZ5gO;d_WFi-`WcT8~| z*&v+jE%L`YQ3a9-eP)@2SBmg_w4l&HAmD=f_R);-g(k^j|kxm zr)|`d4Z>@reUBaGME-3ebsevEanI+=*Y0PCjS4+d)CDn*9NCN(dld1&Y;UgaL>APe zE9=l-_k8I#^d{@MYXMeGsG-hjbl{?;d21Tg2BdiCKUv$C1-H1ty$o~e0tC%Y4o@Ik zMBXLgF*tGQH$?!3ppiB}DPG&vfL?}j3&c42d0TBp{RO~x12WTv-ip=dv7nzJ{=>$S z{7A?>?#of0_77772qjTZa0Z7Duk2RoNc%5()7x)9kp?`dl6mv2h4Lb%z6wD*$Yq*U zV?ZBk((m=X>I>XI-D+EzV)gqcsQoywv%}syJToA&$SH-?>JiptG@77V5Tq!r$f8V} z)zvz$h1QBhND&t79-)fzoeUKeq?t`4b+L;nxBbHMgqt3aFt!9AW-0O`4B@I`X{Tdi zGM=YXoI+mUyQPa{9EaHFei-5naP)^Gu?+roGuovvUE-Rg=I#~*(S0u3LPW#4?hUe# znUzF!vv4+#DY$3&?97tq;p5EiO+fohb(x5^4)(WnFMGXETx}bmo=H$LjIl6-t4bjw zvs@Xkvy*Z*=G)7jNFukQ=|{_U7pm+mc5aU*B}IfwE-6C^_*cE+4HB=?oVyP_kNZ2z z8kHfQM4z{Q-4id(Bj4&67zFw0gn+YMEn9&1AI%hbu1{|F!_Vbve;w;NAmeNXih3Ih z#GrpjC0Vl)Jcvi9rEVLk-bn=4XUNH7; z&04W;T`LuUVErw5t~D8-O+s+>07_71d(?rtOREE1K5ywZAf^Ng5RZt1M!?FCH@udi zKJRG#J_3|+50si3nDClJcq}h%c7wmtsUa40J4`OoW+zMJy7|BFM7cE93`*@Tnd-_T z+Lbxz!%auxzc#cLIhoYK{Nived$g_qtzZ*FoH?-XhvX#}IGCSQy1SpJ~1E0d;Wm zZ%T4J81a)!^2e&hogYf0y}@ipne@6!kMGmBuImIyI$f`FA8r?nN5(Nl5!~T8MdWyw zM(tG#qk!rq*>PS*ZF26nhd4oiJdiZ<;KfA8XW9oZRaz{W0dKgUdcAj1z9n?nr+HE| zZ}o7=eL^H9JFn?~UOrm7F|(kB%h*3}y@=~9c%D56@@L`IhHI0U1Z6->dIVVwJLBb= zRiqh%pXWwvceNJj+5Nz^Q0k%u|B&lT0EkrE&21~%)dSwyYO_$=)A1-MEfS3J-brQD zPxT+P9kfqtwN57{kJk3oI*x)AsnCe-+LQyUc=AgR@pQA7<(FRwJbC2G?ioGqq>rw5 zh`mCU8+Qg|&>n9vQTFc#xXq^XCuc9fHyVJ#$bCSE2eQ(T|V7!p5! zu-^E&e?@NgD%)2t^ayprxZxn@G1XwjwZetmc>#p*#i2HijdV1N+;P9QB7!sUzPW~t zI4sqWZkIO(dF=UYc;U4zOFXm_@OcBjB)}*8a<^h%=`j6+7ERnu$PH?%AwbaT#MKX; z5Nw0~Yy^EH(KPGq?DmbV_HidF0SvtMmj*Q3hG+OVEx~bybshrNrT^EZYv=lk^d;z? z+}-5RYoPep#N-TX;4~Oh*HZ*fv(@?gwuf?WZe3VCZT4ERA)j(pw$n@h4UN|rE z6Gi43>#xsK2iK>q%Z%5Hj}JSOdwRvEHCA?N6}JohJHX#~hz5S0;mSQL6DYBlPQL8u zvYD6odDrd1ZnNHYU6uA>89a{M2h~=$7RaR4$auuHKy(m4WG4F`L>wS?i>q?mD2?3^ z__U>+zT?s(m(tJI3uZ7QLb_u7#_y9Xw7eKQz5qo&0L-V3`FXxx53})9KI4sdmL=zw z?6^{^{F7$d8(SBnwAxK4%USwf~2o<1znQFf_gh;(1KNE z6XC9iaxDiZtqyj}eyVLE+Z*&o8Ei~emR7wb)!U*g6nF0sb%a=ee!=rOI)yzt{u;(! z^CX35Yz5Eern1}75-85$BWn42>aFn7upsQOTr5PF!AHv~*VHQskI8_&;}BY_;EV$S z=^@~z`?OvTHhgh>b?eaAU0~R*b!QYSd1{~0sUm?)hhN_CXzo%cx=Nt-kjQ>_f8WEj z*6&ax?1$4L>GK3xK8pJ;rek=;rC8)8yIZoXk+{c@_WASU*Ie=RHQnZ^YT0Q&;J%Y{ zLV(fyW1UWq9;k(SH_i9RZoh#F4>yfE`KoZ5s45%@$ENWN6Yn+jy4v79D@#INa1O=k zg1*3oeX#R3dHM=3kX3Uqs4B8_M^M6oSQQD4AbSvLsdU7HtO zE5lJTJINXco-RSUO9F7s7dmEb{qZ6efmQg6YQEoyF!o6x1Ay?W+dFRT!j!`6n|#M( zOWR^@=kpLT&#cS9EOo9AkJnRD!(FsnW~VLt>#O|A)7!|$V}{m5mRYSHc4Rod@~<4u zry&mq1U7p=Oz&QwJF_{d536vwOfDYu9U;&x_WhfmJekdL*sQ5=!~lmB7Nt0CSb_AO z4=X<$%v3N)`i5c~*WDLb-MNLJT);<1PVKw6HzwY!90=SG^`{EQwHriZ zcq1pEFvu*{UsQnZ4aWC%>$TMp&>IrRMQFrNKXkB6+B$6urI(M-JA9O;P8=(qaf|W< z=L4iCpy>vW-E%*-zdfay_eBn?6ZF=)?iLOIF;f^_e$qz5!x@cQDantLY`k7-h zG;rv!J+GGz^)kcEC|{llMZ;P^a=8rqZTOXHxOllr}) z?oOQA_c-LHxLO4Wl80C+2J`wp7r0E?G_$w-8zsdz^gXQRvx_I%VH*lZ)5iVJ7jiXd zfn+$7w&tAx-N9--7KHV?9ea0+ju-p7eeqJdlm#KY0J|QgP+w+O3?M3_Liusr;U$pG zTB{N%Pse>iaVU)~>-M?J2A&vM2DBH*T$fTzB6Y}Oj_?F&nBKB@S>-+AFlUuKuk5|8 zKT_pk6AWLcJ_cQ%^*%mv`Q0Y!eVrQsW4hq)+0r4990Tejw+mK#>T{IcZ)EPJ6@B(n zIBq;n=+Pu(!S+yJ&V}d=8CVQKrwjJDK0F3LAr3TSiGvlCtBdyS+^^LbQ|m`kh_zA5 z-Y(vxSrm$?Wf{KVJMu8j2tJh+Xs z)HlRd>a=rax4idb#wB#)k>}EWQ?Sz*I5o&ab$j02{Nh9)jd7tu=-M3@!aB3&N8l=d-%yao4v~e z>Hg4-7wz8FN2S!+ZTE+r_Uj684wY)a_Z)HQ=8G!;X+@m*r!NCXyaAlL?JOU2aVNQn z6Kbwq_9=m&45}R8+TfKNv(>Wn8u2o0=6%RL*;8t}2j4+T!Oq+J+kGi|B_g!SHv}!G zxi9nQ<7{lTJ)FKvEhrQw=@F1@>x;r28|RnD!CUIT!J|};>>I{Lp`f-L6W}izeB9af zE!Qx&{eRedtEjl5Y->2dgA)jDfh4#EcSvx82X{ztcPF?*@ZfI2f_oJbBxvxUg2~zx{7#6ve82_St*wv(}n(uKWz@b-8)hiTl0<4xJN%bX$@H&~u_n zAnYYtP?&WeUnTuWLb7{cJLtW&?oB77o)xS%`+6z<{4Fspj^7MP`D3JusCjNtynGlR zO7zn67QBX7ROYGM^aek3>+WxK3M&^N#^pWvO}Rz1f=?X&yQGfhPuW?>wri#oQd&20 z76v_UMm|Pi2M7-H;G=%dP%=hnRm8b1D9jK`XI?dsVSU9#OD$~aWW}60dWE@in*!iH zH&5$~+gEfxZ}ouEurr=Z-Jy#SdKW+a1z_i>*Ujh5Kt*p8)Iz(m{ zP54bFZNt|1lkzPo1hV}Rw+?LqgYT{)>NC|pjz=<1-Ai}WJ$bg(Fs7bg#ppiYLFZcm ztmcMdh+7VSL;_=5K)SFNid}z%sZBo zx40h|aL9&wrYbBw%hfG+os^S7G+6l8%0v{IE&v1u1+~b5EdW=;L=jvwsY&V{jdq2_ z(OE_GlXN?b3H+7Ya=g5HS9~<~i%DqzcTE;e29J@nF=kvXiP%pOCMkzN3Xu84G^ibo z$XxYalJhM-rcx}1g3@nV5CDf@CX=yK$-V{Yv^s&*i&s4KSteV#$Q_-}2Y>hMmP2Q1 zf;L-EM7+-d}kF)AGk$7)}=x_TPG6gS$>-_H21qt(0GJge;Pz!AyEv~S<0EJYuc6c1U z$^RWL5p)I=KNQ|C2&w%o^_J_J^C}|a02Kn7#H$0{R9yPh{7}EW0(P4>*mMwI$41^t zlZo8!0O7<6W9RSmWP6TMD_`;gZ|(O9-jiO1C0>zAhe2!y<8xAa38~0+x&!Z>QHDu>qAGss%ZcjOcz=JP zBE$%tQ5x3a-x8YnmlnVmjQar+woDG_(({UZwt`{JPOoQI6jWmO_ICk$JDx-|=iQF@ z^uH$Mdu1_#A%ZfI?=CM;NJiNwuTZ%yiP`U^?}4~$_(~Iq9!e7F(p_jc0j}gi8?<8l z=HB!5?BByh=Lvq%Gg<~^N^O}>_whD!oicCzB~q9)l)FwQ_x+EWp61Hg!GZGm+f~sT z0!?(h;}(OpJ3U#{`R*q0V?el1dXbT-2L+L-m5IpRmd0D-mLT%Dmoo&_p+QNAvb>$) z3=HAV{*JF8{Yo>!$Y`5}9UemQCXFu)j_=P$LIoB_=VD+W2K!)iaPKiOr&O3mi*L1hROdbca#E+A`rE}YaqvZ4U+ z)G9<0CxGw{J~Do$Qw)Aw_Y0Xc3NO?efn5cToB-6awbtyq#gB2<;ZFrgpS7%n+nS1U zbvDpiVO1O4b(qCDvaJfHvS_EtZhRzf6eT3|tZ3YyCC1z(D-W&=>}mO%qiL-r@hb;F z%yaTV*aK5hT>1nu(ip3cx!msV_X`b{pF2Fmvz1OOZ3qh;b|y~L<4tyqZ;o>`sS${3 zfPYifGGBR3nsSi~dD-ZD_2kFVQj2hVrTZ|Af3d)VOoZKHqa+#mk0I_w92{~Ub%;sI zi<9hHaPCej>Ue*Z5h+g^t1c@shY_uAN-AWpG~E(DP_cjo5F89CMSXrk{YHZ$^8LSD zGl4qXp+*dWW&D+VY>RH3a=^nZGTKEWTqjq%ix%m>qC!`>A7KAQ*5<`9^F2%w$$6tB z-6(P3C$$*>+0wc$Pk?o{xmu1aK=W8W3ogF=OG&()t<+X&%E*DKYRSC)BJ>3!)@sTl zj;*4%c0R(R3`G=(#d{=DxBjqS(xS3oDzp!~7J_ZxvaeCh74(JJm|z?~l?nMw-N5*l zlySiEw)X?dCC%?$8FBKE&ic=;Y`1Ze;qc6<>rqDLarZ~OKJ)4YOHIA6Kj>x6a8RcD0NTPP$hFIjLVa{%b}YT z7E#>khTVHHTi*}0222ZKw2(Zf_Cu^2kx+Y2LeB;Vqmf)SQC4{RG) zTIvc;j5q76=z(6%=)`eJ4ai!GsP3j}l_JKmu!@p4MUhDe z^+ss+l{3>_)%3oRa~S}DE%*GYKDFj3vw2tFRC(^4rM^%I1mugi3?a0u6_pE@7aeqLIe`vY^Ne4~MzcOELs2Sb0Aj z2by|L22W+_h@%8(8}Cyxrx?*whFsN=T#mRcMj2-#KQd4}3VBE&kH7vFk4*AGkC;ub zJOxJDUqT@l#H!!{t={A8*jjP~t5g1n2wwoIu%8(Lu}3=GIZij?cLerBf-YO-?m{wP zp*Z5Y=cG?RU>SlDH1sk<1gm9T8=MMQ2#J?g5@Hvl8fkFq*2lZ!4#(L&qgWl;qI)35 zNsQ|;ZT7p0uied0=xAmdmi~GSypA@i8RBVJHFY9jCf1$01s=|R+ruwh$WLWm#Fg*H zX7+!C1wEY(O->pgA~@};Ry!0pf!3DAOo+kX@wSg8%9})rYg8b=W=L7P+^U4x|Pv03=(#Jwx=HkiRzF+t%+@g3^AShtpGm|VDkeBP6yK9Dq znJcfZo+K3Nh*~4+OebXQ>=LfQw8Z3S= ztHY^WSmXc{?mCXqmi9@nOfe5)(!4L&A6wmiZrd~7l&31K&*?TW{yo!RU0fsh9|Weh z`~h;DiU;wrQDP*@$&Re~dkKIp8k%fPZiC)FKUy<+wd_GrGuw92H}`rlfyNS!Sl5qy zDnv?!-7|#f2{Be%zqG*$yTJa~!|{mKOhu%iKiFyX!?ba?>He-v@vQLX!T#oO!M;ft zVA?T*L!g~W?-LQD+@jUZ{4m1u5GN*pO67gg+plyG+)ROuhR=8+ii5VJ=T2%s7@02` zN|tVA2@qQ~$1Pm&NWZM3ps_vV^shZ<2nm7;F>P$88-GQMh_kr?UN=8J#1PQSR6JE| zoj6{hNktC+U3*E4ZE-MJl(lVyGmki^w6>99!-jsd297G2N5Sy4%8e#6y_48tVe%WL zANB9_@wfW`V&m8S#iod>r9KJr>J)%66?0e{+c5s#m&|?!ehj5u8g{M+YjV%NEyM}) zd=@ZG%JW&F!J;LzWB5sEbFBlvWKb={mNatnmFk9xL`DFyTuAd==rbCY5H#%PCYag^ z_@m9CrWnBjjnhsl_?Lv169~!cK!`T7Fy|WGOVh@;*ySh#V7XaWdc_x`*|IJ$@ka=x z4;)CBbY0b~%r%}BP5zi?W+-I0_>HMlX z?;92A0bY5IXs0Hu%$QlBJjE*sN0%`$6J$-2cv_S3ZIRJ%FL^{OBD_%xWV z8`7)nbJDSIq|Q$Y*FE-n&!n8!8%In`USARpW%GjFFGqW>v;>;|hI((|q}~aeQIN}e zXE9n5=5a><+uf=^QY(1NWI2K+^CbIzqAd|xe$4g5yiAR1=nY(_=r>}PTfHOl9oo^! zSvy!W{tQ8IR?dNw&nF`L>=%DNcg64syn2mbuOH$?dmgQLGc~n`;;Bb6k)wLo+nOKi z?eZq5tmn!0d`(=u;%0Cf6{Rg)=KB6jT7SIe_v(#btc%_SG_8890yF-hbj8 zwc~_5fZ$M<;6nm|oZe{omv}6Tm;n+L(58}k&^U73Dk|0`MuWiMez6?gp{3lTVMwwf@T>ku`tHs_VnN1*n$T4Iud!FlmT2kng<__FuNfDrqO4m*eQ# zU3{1Lr$kZqisXA;cdq&3@oa@_j{DQw^1*Uj74Q9$0EMXV+w<+5>OY{|5KANY_0h!v zC!1lr&Kp-==HE=e0kiBfo85n&o>g%GUCTQ9Ws&7j?~75r+Qb#)o&{iR3umvlE(wj_t6P%_Su)mmfY+MDM>296-XnRW#r z$5Zu#?3RDdooBVtz}KD%5Z-Y!f?w{J9LPaHU3PLAzkKn<1jx|NGa&D zXVnC-zQday?=SqTf8a{2BW?1a?4rToDj$|h#?KDRq5engPa1MZZxTI_gB-JtKUBuX z2KKC)7avrqp=j=0!f-OTF?h1IPGaT!;itHMH!Cg3T~sWFuWH2|vf=(U9Gv!f-wtv~sx!&9mVvim+H8)xHZlRa0R8c+nJRJ;Z4MAO0 zS%rU{fFF-%uLnGDPQXoX*~Uktb2Y>`c_ixaxGb}wjqK?XHSXw0T=|=wKp9~;=pEko z6RffP$^tDzM+H=HC8>CoaER z#|+}|uL@jaQmvseKm@Vqt?H+B9=BVRiZoZ?UPGSjG#!#NX*1ZMcoBF)I@AJaj zlZyQ4_mRG*Gd`YTr+2WnVKkNf#VMI}n!}15%!3m5$_>iiDRySZ6>i^d>+%h=sWsmV z>Djw#dyKJnevmA88 zF%n@rk5}_HS#=WW*0-lG=R6x#3+RLvPx!JC0j$ke+;?3|jFddWP8P`Ye-w-AiYP?% zyf;z?0nG>L&4IC*0^6DjdP83?{Sfz}!3!YwZ|Gpr>$`8(Bg?==Az(Y_m9CiA@Ok7- z$)BGi;3~JiP_!2D9>(N&D&dM(R@niUlb;0r-P$O*>gC+oCx^gE#WtEZSU_@OB~JQ+ z`nTL5kG~u4Rix2{K<{6-B*d5?iaL54q1FZPV$MaXu1z_=JSV4j^Lr+%eaWXTiPcS51u_S>Lf#7&3-c0jqy>E!^6ySR$e&l3TKYrs^$Gyp=*=aRt z=CY+u&8s-TQ~G&y57AZFfTqns8kZ1HeS3gcy1y}$ZD_*$EB|Mg671_W0|3jq@DwOF zcWQVl88KnKC>&o6=uh3}(LHXkdTK`UZ$otEC-=bz%-ZH)#q{H;)TKwJmQSk8w{Wy? z2E90N7!}}%J1^dK{LLzxzuw5~SPb%a zs(Uf)`C5Hm{Iz9-py4Bs$bY-atB;0uA@S3%%(wlu&17N8Xz$g-!#cWW8T(g1_e{Bf z$G$tXqU!uO3&g79w~CJ?3cQB*Jdn9+C^=O;)*VH^n9YoSz{vCJW>tZS?h7=(E(-sv z7j%1vNAjf9&SDniA2NA# zuOqZ8J#GMQae8?C1%my^3tJ{!_}Ho_z9$YDyPNbfKMwp2C!8$rTi6qlSO6FC(YjL0 zovCQOaCYX|HEQLxuQ{8Z)Zr@O6$?il#T2nK1}@e(F#xz@tz2 z5cu)KjY2pXb&%YYm}7vKcJZq`ZM2uhen~1+&vnmJ6GyOG;SIU-eZ6zKF6sDW8?Mo@ zE~Th*JVWjasqrk;j)tL@Mis{l47&1fEhj9)G_dmT7f-{aV{?91$?lxROtB>pPh63^ zbxu_CkRPVUD4e7_#Ji+baI7JiZ6|GP(7uSFLjzNi90EPYyapy|Biw#>d`^?e!q#<- ziq-8FjObpZ&>MAUkFSQWHmydAMD99$y84*&VXNFL2D48f$q)A9McynYX*X(O@~0VY zZj*1x4HV;4E5|9U`K@x$zma(cDsD>x{sI3Z9*x85r13(BXUmrW^mYq|n=*?#0^BAr zO{KlRHcRgXdr@mbSbWpRsyzhlL90Z|&fb#`l2@|YDJ}~wc@Db08EoLZ+3n-v1zIK4rKf(av@uce>Aw-$!0v!^C9H)?!r>E$PR8o zTD9zLDLnfl{3)~E^9tCDeaO)7f?D}`(vymD5}{@QB=|89;PqC?ou_gozM8@m@uID}HKV45j z^JhADe`AH0oFJeX2I;cG+2s&@!iejkLsTZ8JK44gQ8>++>Z_!G#HLL)ZNdpoFEFS5aP5mfI(x6DeX+j5! zY!n%5V26yumv&ReW8phl)^m&YY}hSQKn|lR$^UMfL`&f76Htp&oYPTL6WgW)?QVuO zr};p7ci1NfYtHUbol9;Jbhq2A>Nq|M8L4+?s;xh4EjnwVw=w*(GxW7Hi$u4p03V{) zhR_u4CqRy?6nlP*{2+fX3Baa{maj)Mx782eED>U8oA_ug-G8u-IY~{RHkQSVBr#S+ z&DO5z05~vP2xmfm!tBhFNXY9n9~5gJ0~LIRrfSu80>TyAbA^sL5d!YS=)SjZ#q6ev zWRwxSUKO?iOS}k3Ikv>JCu&2%-cBUEb((iMKDD5_T+B@dT{LyajhqEq>>D;|`fsa> zoi-cXpO}Oq;%j|wKcvvT7)%@L@zdR6w8vOxz9Z7z`LxeLjfKZR)V9dAQ1WTlXD>tG zb(7o6(_gyBGKt`L11wec9~5kDPKzrHN{n8b-RZoRxvwa^zmauICnp;u*$RiUo!{jx zx63`eto;kiqkQ4;{0=I%rN^Up@LZwUU*8U~#bByanfUcdB|T}f}G#Q zLz5}j#d9=d479Dgx9n>I!-ZG;e^ic^VtLyC;RDi}pS)IL0A5@Z+_$GnR>X-|-iCew z-`Fz_ui!`H2WhAy4I`(%#Se0+)~+4g9?B`<6OXeR(yZ}IHRy!CuqA#+d&i};htf@s zwE_erj82@3=+n_f^oiBR>nUV3;m0e&Bho|Ss>BBKR^Hn2q<3!cqw4LM#;7TpE?=Ve zfDmHIAN-K)gw>*_WxrwLKKUyTPC-6ABfm9+f7o2}UBA z@nk(fuP|JiU7xSP{W0+L)53NIyq$g}U-JEn1V|h>JV7C4{IRAHvX-i~>K4#xY78j< z?C636kJ2#ca~g%|NLTWUW7wWOP#l8eD0D!HW~MGUjiTRcbLJrE{#1~qZXHx#V^9qV zkl)cZ3i?SScIbeP$_+)KuWveBZqq=Ywu_mBb$E8jL}wwtZLB2sLkEOTNl&i|L>|{d zzD>ZIyG}c-jIu08Dn4zI8QPH2HObs!f4)c1n{vcBO>bT9ewVg@JFA0KjpPL1k`=eNcgLIFYOcKOAvzH z(24p7ncQmKx6;2o6NUF{i<~E z%+L8{J%t6a12(J}rB?Ib-Q$=sE#x|HRy%BF;_i}s?zV&KbK7N`WWO(48-jb87>)y* z4MMR4t@g}kHXa|0^%pXn;(`bE?!^3aNjN%BtJ<-#*+~gddwLfgyRJ%)$jsaSZ2g)B zgcJi?iHYQN1SqJ84JO=VdE5_(mY4z`yJXx&2<`v{*6nw{8tezBZP2$xfW+`yR^a^X z-ubO5kogOVuIUrEqqHGl#D?s+G+58a`AM<-Y=T%6 zjLqV2Z&KeRojJY#2nLPZMiQtaECw^@jPA8n-=r5r`Rf-7!qr^q`?Gm(&ev! zYHyp|L-o10rPkS6q^DOgifzdr-*5T^x3kOw$_l6yOCC4eFr3tYL(JHFFf3}8%bZW5 zc-Ui3r+hBkek~)=Pwd9?S&fz%z-vCfPs~wR$o&d2^r&?i?3YjfAgy`1;6Ls|R_j`b zpUCCPm)Me4>4-f388e|zI%#7COF+$pi+ zx+#MI`H|au zavZA(?D#geq&WZ$dOXeag@C_Z5>tAhJE-=K?b*Ggd1l2(i8A+o{Z_F;LSmPXjak(5 zYiZL_Z0L-097t*zfL@HgCwKRJsPFI05}=^*z#c^c*3vM>=j9kvx_~B+O;mz*gz{Wx>0^8r^>${jHcsK61FO2%zsc@teNq_WNDNd zr?Q{{I*DRPifOD#vg$LFTGhutEYv45E<)S~+TCkzxC}S|y>-ogbNf2EVIb{WeaQKB zLxH4~d@8BB)%HikDu2sDOxO)#;_J)gj2z7Og0Yh`U+ts~(P*1C&s5rM+bBIf0uLGI zM5C>jL^~j#|8y62lWpYSM4qV!RmukBEu7S7H^)wyGU&^Dc8Q%2TG~v0p4Rz7_nAda zI6p~ppQb8%`L@ViAxc;VgOu}LzNXSaGX}eo=e)zsCtdO7$w{_TLXV+FoAUIGam_H> zy+t~gz7e!FH!6usEZs#q3|Z$7>=w4bXa01fA@y>M^e%g~8T*%%!+sj0m?K#tQ$*#7 z`{BvS$Id$yisJe$CMNJphZ8i5%tqXZBAVDsex~2PaWni7H%CV!3YmbaF6175{;#|N z?~YCeZS=)gaL~RaB;x4(?rsNOvVG>8`*|MIjeMlz1Dw15{C>t$rUpps$(9USZ5egJ z{*3qI%4qUA_+4z@5@i)Gvp9bxXfKF)3xkf{jS!2gf5-?k`52yj4)TYif9#{N9`zjr zaggy?MH=+2VYQXdTE>3{l;KQsd;ks}3uR>xWZSGvkJ|4?!}g>4pecOO_Wkyd^ZW>3 zHd2hvgX?6JM$ng7$zlQj0|tdTUK^FjI)7-u)Xj{xkIV`DG?N z&t<438|#05K+b*k%xAa_ieW*r?4JHeuuU3=1LZ(zu)DOXla4V^(AHM2d33r#>SsY2 zReE%(A$k{oz|JNHxBCw0xU`dUntYAN_3d!T>2MZu+jFX|Sl?^C-k+XmA3vC_takE2 z@2!SbbZIas-%HJAsTB>Bt3~ZRydy9l7jgM6Y~fS(!$WP`jdez#W#g@~$#-z_C7@qF zOFvU$0(xB&MrTOnK1v*7w`8F$W8%h!0wF#^d%}%J$Mmlan)M$W6g5D9k!_x>rSU76 zY93=@d&Dq@H*i-5s?!QF5p6}YUtaC%0;gMvf2`JH(`zZJL4IEx04{u31>m5yP)~s1 zTeC2uMYeN=J>mq$D`*bu^+z+}Coz!{u%}{d0aUKOFEa17qA}m%BJLaXD_jAZOZ5V+ zvNur5&Kh2eHNQnDe>)A*sOO1#uY1*k>=4B{MHS3TbUGTGh)rgI%;*%q57XEU;;lj= zAY~s;uU$*MoYjudgG?MPtvoPHgnnZ?v>ttz1%wrrRmG(QbJ5sz`SYZ`Rz5QXDm}Cv z&Qm1}i-cC()@_f7`0o#wzZf*Od9_7QZh*>|iAPPirR~hVU$%w)B2g8 zc^9|KZD})CZATXW3SX9Epuna23DdP_Gn8%|g4gwj>;87P^5F|fo>#>ht4?hPixEh8 zoaXAG<5Wmjb_ii`J#{5@T&Xv#2Gw=5%XCO)r@(efe9ra>qLkJ{lv3ms)1x)hMw)5* zg*U75)6ikH%8*`T>6m7sawU*!@tFQolu*{(PyS+2RC&P8TdHoUxNadNZ=7C|ebKOZ z-_=K(67fKPm*{*|Sv|yqk-gab(}gV59n<8AQxbMYL$n|7NfU04XgQAC8*|4Hxi@W3 zoR2H-Dd^&>a|+J;_0YU)?Q472JO)gko^iw3Z|+JE-vL;RmiMSc4@G;_c@9V`ur)v+ zi5S+S3YK4AmMsR|kzSgS)3{{-I;^WU6#MY$K|lMx{ga5LIay%>2tW3WWETDNB&O#X zp;>>`$xAr;aa?A8jLhPSEo)Y4X=9x^EH=vjl@nk`Q`2C3p7r(XYGGoKdf`wP7<(#{{$VJ=fdf>4Y0O>2!(KOgVOQ-QYM=ZXh64S1XBU@U!&d7nTCzCTaS#MN#&zOwNM&0UO#NWZG3 zIu;GppV#m$d#8pP<^!-Be`YzxCt*y+>=Oc42)nv zH=^)ho23?;ShXBL7L3iUFVG_1=OCN5C1NSL*ZQA z$N(J01E3(TLI%D(j0C!bEGQ3ltx**v^wn+zA*0(__pZoS3S}9AdsMxPrM=Z?rY@G! zSLaoZbk}lLt8}q!U*S*rwtrJ(OK23M9_RN0R!hlJ;>-F-XO~OY_tx3tY-=89C%pjP zFd7h0OrPub91ZLZy$RFm_1K?MYMMVoMAQ=5dm=4z zL9@G42EYQ)i=Hi%jv3~wjxnW`mJol&?d+Zfh~mSCAabr;<^%jLhF`{PibWQc>=&0m zmq>y%N+5s+gkzqEVd6%>;k#x2R(J(Cwrexas~>|MxMMt69x{0GDe! zRw`kvinXW!NDydrth9?3!f3IG@2g<-R{GZff?b&z;E>H>qCeMpJ^%DC@uM;)2+_sF zqIF-hT$(?+=oCrzCXr~AFKh{;mAAiY1W?LKwy(~c?S*i57eJu7f{BIk(&w;>ZB$fS zo9KZpZib)xR3lYY*Bq2g(L8}_N9lGCr2_REgw8&2N0(22%83n~Gu|IP$5!i=G3dVf z9Yj*zWvk>Hgi(kx#XDwlB&i&}_?1qQFM7Eom00w_pCJ8pC8N_rADwHnpUe86*Bcud z<^U%A(eXq%|Bw+X6%?o|H;RjGLW^NakV>Bq;ueF%_6cIsA2`eGM%71dQasho;rtRD zzd5aDp-Of=i(;heWC-=`-Cw*qyAeUcQtE!?epBv?0sKA8(Gv zyZrBF1y@=eX0^9ZhF7us{H4DhsETpxSnmfo$a&2Uy-eDF7xXQA%mwKdwU>kL`?#_zFs>G!}P zn)|TBf=Y_kHThD{=_(0sYrD8!EnB)5>2=lnIO-6sqD;sQ{-g4MQ(NWL&gZ+^LX+iB zEL-LtceV2#13+RdP7#ZFg?^w9812A7%8ic;%a{9~7-S zm^v&5?@X=XAwEbhlh=qC@WINZqjl4Jp?2%O5vEK;Mm?n9F8M)i$z(yaVS2HQ=2zyG zUW&UTI1YYoR7N6dXDv|#<0bCCAzcr3&ziWu6jjcBK^A#pxNY=?NsQY z*TQyA-r+H8Tb@C!?zsf@Va&w%3_oRBnL(Y2QQvE`6=6yzuT{14Eq^>^?g50N-d)xm z6B4O;edqBvLFI8VC|8y7^{0c%&Ao6IM^0yfV?5mJ>=|0$R0fq8M^BAvDpkpdLC`aYvS`d^uNl z6M=l-1##D%)jJQ!Y4~xx7sY2f_NhXp;Z|BkJQcA!DWRKX*LqyP%~#yafeK(N@w)6| z1pH)Vkq+E0Qn7#5`bTg*^f=~sj>n>4;1vD2_vK^+p4CdrvWtdRh)Mc=F9)b|Q`Yo; z7SDCZK(noAxHZvZ=w*b(QMStH;=pCOK5r|3o!$7e zseAhzPH<0Tr?Ph(LcLY#z6%T_2b^hB(?K3DRq{AgzVjf~LT+|<C+{;6-G*rSHpUqJ+DH$7OD^pZPZm^XeW!{X4r8dD_tB z=7o#*-1G0o4nx>5HJy7+YTeDQgpXz}h)mB;Rr<$v@RFnmxt+T@AFd~>*2_B+st~YW zu*rmguMVAOu)eIN{AF z1Y^fb%D`>Y?V^^F3b>=Ld2x2>HX^!1r#=2K_dVYOX zje`-j!^p_enK1XR+wPX>b1{eTxw7g&aV}pv5Gm~YzUnB=_xT#7+TwoxoQ!Ls^Gu?# z=Sri&G-ul4Qe(lE4v*>&TWO$#cu!lnFx;?xq^ChW8a(ymdf&M0S%2GSM0=jWehN@9U-jfU*6~O+dpu%o(qXbOSW0id__8_WFHY zd~4L%zDiy$L?regCNBK;H=AA~XO7p#U_;inXyUBPqL=zbFVXePhJcSwbKW)a@W02MNj0yJK!Q`y#9=`Hv%UjNMfe_^lnYCO6Ay zb9-+)ieXk_%zXR8-O_~Lj)u4X&9)24{>HDI)^%c%lI?}rMfM?^QW2vMiyMPdA~=3M0HA-i(KZTA;O(EyN=B8yEEZPGEW{M? z1?VEj@pBUjNato@Keq!I{(Wm4h;NubU}M1Y@DYeYh$}0AOv}*w1-v?Ln-hMA!#m2k zHx~42W1>h{{hW@gO8r)S^B7Yr9!q0gVk6SMw+2R@E6ax++u3I7CG+RIJOSN&u)VwZC~wX9_3!)954wktWBZ$Xj`+9&k-3)Z9N1|e zUJ0P6;Cz8oz6uu*(+4!r&VJb7F5BIyC za|0vvV`Nl9&d6fziQ$!AY`gRW6x**$Ne2C6`C<3C+5zaU$1x(r+bp}n zrFd?n<3~4JbvKsn-;6r>hF$%d)7YRDTp9=w9tFsJL&#(ct4H(&hGR@$i%bf-|3H>nA}LFPAEHnAR3fg=lW)wqjOCHZe=l+ZjCsTh$s(o znUWv0R8f0uocFE{5CtIcZXSg9Bf3Yyji*dY$Y60;4c zYUG;nNK15djxEMk$NqH8O;#3SmmX|cXfdjtaULUq7(?gW^C;kOu_#FK*%#dhp$)x< zVHS=N8(+~G+m&s8Xg#E^&d(rX2JejOD&g@qgUv?l+VbO8gBM#Zw+)to&wdzAZA2f( zHN2uMx3S-nTP*O5R=Eh0>3oELv7z@lzi%@^TuW%Y{k#kYomX=RE-%{;U#);$Fsi2| zB)Gu7(VUpmNGXNLKy(RI#Tej6!hr!NfNyojy%gX$pPjcg&Z*&3hFsh+?T827q*~wA zf|mS?TE2bja?m-m({tG*v%V_y^({?1e)h@J%67VADh(P(j>3UBUu<+%Vsg^ZdqW&> z7dF^nfA7D#0CW(}lHEYtsqe5X(@}Z&o$AwUC|-My2&;PkXOH7$I0;Q_jfidKW|*z^ z@)MdheDA;mn1;p-?H{wDxt0yEgJO*1xPy!5Y;{Lx^|{xB!tllLW{F#v+L>PFtZ2Kp zG0`^bjySyGVhSt6d(uFYOEh=G*saf6w}BszB)Q(p?Bt{uhog2VSfZ??b$!LQT-^C8 zvu!&|Q{`Sn^lD{u>L5UfEB=j_QLCl0p4S7D^=3O;V9Rb$jM=O|>6L;8m?Qc#Mdtv* z(B-0R8q3o-XVyn&g;x3+Cy&arE{_Cp`ty+c^wFmzN@67`Yh0P2n+4Alv26I5Y2`6*nq%ODaPo&;2GBttld`d>_wC-U8ji*b2$wq*Fvrz-g zS3_(!4a^X+i7?qR|FK)Vaj!LQ?%(D!bxAofmVGe-KeRO#<`3L!5MgVk0YBUD`?JR{ zotU@Llnt>6IN^7#rkRhDCfiugEC8gF^2EAi{TSy2q@a;Dp?|rVt45Dl9IPXbu$g(r zKZ~WMN=sr#P4lbXyGfH^NjHf}h-7Qim1d5(`@u{nvj+;^Mqy>f%iN?@`xdeVjmDyS z3OTHcozzTSV^#`w_+f*iQQSjR)k3ko>6BeATt8s+8<#i5`DDe?!R$iRV+BJ?EB=Y& zoz{2^LlMv-twjX?df9ard`~|y$-eM2D*2q|=~;*qXP*D&1tJtwfPCi1U8^h@ly*8xzpAk9m20m+O0+%1@6E zi8;$@Wg8YI`fR(SQ+u8xWIk}L+aSj6k{lF}24gm!A&xm2Y<+5kAXw0b1t}*ykd2i| zyAn8?o9gEjp=C~3OySLQEq$L@Ghqv-2Um;TH2J{euB9($iFOlOb;NeQ(Kllh^XZkQ zPNVta#=CAqjap;_sG}*2o!PC@ZQBYzIGgjru)ZhNT8!h38DYJ+qZ)=DR#Rypcg;n; z9T*$2n7FB1LBVb@30^zVB-<+=}e`8~0df zGZ$hfwg9*Al_5qC_YClM#xi*}eP=xWiFs5Wf4JZ)ODnHz?=4uxtu%_QFUjX89sM>b z8YXPCiOcV5n;%#0K87Po!~A((zZlc#?|TPy>RD;5^c^Y%Z!bBl?$ue}&lpaZR~0R^ z-nDXd+zEf|`*t>2;OPN{rKZFDp8H+4%3Cj|>@Q63n_pPOoR`L+c@?#(1<1y&vNI3Q zAfd-iVedBXHP8;f*v6W^;`oe5n?fB-Id0G2aa>3E$S9q4O;Jzri=w`?5bdp0n`}bP z*Q1lGg#csWuhPCHapsoG@!Zp`)(drl9)1BA52-H{r$;!%5|3uCTUSWEDZv*Y>*Z_i z`ib%SMu!E*2J#oPHibKb4~;7g=H}iWePY6V;cXv^xclmo%gVSm>nH9G#NGG__+pnR z?py4;^M~@akx(%3X(hfqd5ZM#tP^OM(bZO)VMTom3U88!>#vF+q3AK-OBPwZ zdvi=$W6(w?JvL=8%7aOY{R%G*2@P4-NbjEpB!r*E+Lw(EVLknq#UN%RAm#H*_yl-R zkd%34s8K14q5JH%CUJWBlOSR&DL7&>4IzmxO|i4E*}vel;y%Aqiy-))!JuF?Dob?d zyI(hd_&c`0gXEM8D*q1G4!oN0N<$!Sz`|8y0hf#4_)#!;UOUaG(a0CcT)9=;>=h*x z=RF*bm(E$6{(C4ps3_Q({EcY;{=l9U|A81Ftg5eqd>bhcn>3KG$6Yta_Sslj^b#gN zkS4j-TAerRudj_i+^l$dMt?D`4BxBbf<*%z*_Ed_y|!@u!T%Hn34at-GAT0|33l$ zpRWKDyGkrB08QHXaJ^LajPOk{(5|XUNVr+$Uu%Xl6v@!g(E4bx$@=bm+xh`^^}f}j zlI}krc~Akdm3235Fe)INS}D<^dZKwnS=#;N3I2n;l;lS!{Xf6k7$qTs|JHfq=l%Lu z%Uo}n-}y?{F?RpC_VN=Y6p_)?8fXKgYIGakRO{5y0YJ$LHEN}Q*}x|)KmwW$Do>Xx zjf9{%AKlzvOeFkH8shuU6(nSwU*bUg_19ggK}(GhW!ps>Z41^e z3swKmeU<-!sz=Vr2xC=k$bY~i5`6W~L1Sy>x6ZNDJfL+@kNn#s{T*}nDP|*&31_Et zgU7#o$$yUF?;gni{^g6LCe!}E_rw3bkU+=6Aay$(*W~#x22?eH{rNq`?Z0iG5MX-> zdF?Wj|KA_}=d&wkrZrL3R1o?v=70AfA)!%qy1t0}FAnJA3w+LU=GRpJ#r&QLu>EmY z+oEOuwO0OfQT)I5u0EdWwT+jDBI~H+B|=5%!Ko=PC2y6Nko4ju!&;>yMxu=j)9mSu z4($W{e~CcxO9O9EQBD>|mDHHP5}LX4dD~^WXE|*kIuRLAfwz4C-0}D`-wYT%| z-(g$`(DO$YKuO_E9Zn~5jpF9&93Rzv7wskxywZ$wH+o`dM z96>Kjdw~FK5Qbt#4=J_2CRHyKlEXo()ShZDxD+X$R33ZL1Sgu5IkZ~M(qN_8MaVNS zDk^ZHlcfDG#SWFuwbI=8jT%om2UHEBl0$Jx)pu)9d=b=Hhyw9#yp!C1t<8!!()_~U zbN#uk=~t@I@ZyMCPY=CsB)E(m(mvcqE$G|0CG)O`F3?A$%kb>U=D7hSdd6VeH(C>e zl=nT9I^oT+3E(4=+ zv#f10;{;yQQy)q6gGkEda2R-Z$ztRurBP-fKf3qh%(1M+KhzlTXil%;ydjB}g5|&0 z8FtnBL>O5Ab&70P*+GY;#lBgAr8)Sl%vJxF$tm9Wvo^@?NMX)T9m{E&uFkn{HKQCT z;QN?N9N2dFuEGje1m(&)_^-!5y||csEp0S;3)AoAV0q&nf(1H=%3~B!@n?l{;S*;Kkrd3-z?ofK#w=^IrnU_>CLz1lHb~>;-;^_a!!KzY-9h_Cb4=sq zR-a#~D%;zNytvUSSH-yb;fx`-d7bP1huNV^Gjo<1k$v+MfqgWc(f8n0n=PnT$7Joy zl8Or_67ug{0GFVg5}E-M9ELGLqpy^{PbHBB;K(gc_x=Hk?|mzvy?)9DXx0rf)5m|)k$1O6g zX88dNgKBLJ1(`8ieK|;wg~Jz!;UbhPc#K5Gt0Yb4TI-9gmT*p(Pl9vao;gDlE2{W#Qp-8g)!b{pr!I5{QXMk-=evu^ zKbLpXXR9WPk}@3gPh_UkwM>KDE&6ZZ8Ap{q7h3j+(xU8Q*%Io9GFntlosvz?c~^XI z1hK>L>;`t?wxd2Oc0Y&>3QT}F3!JtyZR0BN-ivccV}t&ZUkHu#;CU5?uAt7ldC}qv zfZNSvgxi+pZkstYe)cAk##NIah83YR9#PIiPpy zn@8XVu{|xBiyWFC3!FGxX+@9gbLruX^_pgR&)TeWEgM9rl0ZE$K=r3Gy3|{>z*vxz z!&BWagY}T<<~n8}-IirhKcKGqLOwO^@u3*C5YXYUvb;(g{0={w!y&qo4gVyFV#$xd zeG*SBoBjv&+AAX_&hgryPV7Jeg|}-JVG6Hu z2T7}VlZdSTFJtc!tYa~ejxrpg<3VYOqwFp3>_?`MTQ7n=m+P37q84)J4r|W}FCps4{?8{RzKI($=T~;();sCu!s@ya8HL zXG_W?iVpE)xC8)4m4E6KuXJ$VZ7w Date: Mon, 15 Apr 2024 17:28:56 +1000 Subject: [PATCH 426/814] (docs) update vscode findent info [skip ci] --- docs/developer-guide/vscode.rst | 10 ++++++---- docs/images/vscode-findent-flags.png | Bin 44635 -> 96394 bytes docs/images/vscode-findent.png | Bin 43037 -> 0 bytes docs/images/vscode-format-on-save.png | Bin 0 -> 41262 bytes 4 files changed, 6 insertions(+), 4 deletions(-) delete mode 100644 docs/images/vscode-findent.png create mode 100644 docs/images/vscode-format-on-save.png diff --git a/docs/developer-guide/vscode.rst b/docs/developer-guide/vscode.rst index 2e32d871a..1922b1068 100644 --- a/docs/developer-guide/vscode.rst +++ b/docs/developer-guide/vscode.rst @@ -2,14 +2,16 @@ Coding Phantom in VSCode or Cursor AI ===================================== In VSCode or Cursor there are several helpful settings when editing Phantom source files. After installing a modern Fortran extension, to enforce the indentation conventions in Phantom you should use `findent `_ as in the indentation engine: +and pass it the same options as used in `the bots script `_: -.. image:: ../images/vscode-findent.png +.. image:: ../images/vscode-findent-flags.png :width: 800 - :alt: findent option in VSCode + :alt: findent flags in VSCode -and pass it the same options as used in `the bots script `_: +and yes, you do have to type each flag in a separate box. Then it is useful to select the "format on save" option in Settings->Text Editor->Formatting: -.. image:: ../images/vscode-findent-flags.png +.. image:: ../images/vscode-format-on-save.png :width: 800 :alt: findent flags in VSCode +Thanks to Yann Bernard for getting this working! \ No newline at end of file diff --git a/docs/images/vscode-findent-flags.png b/docs/images/vscode-findent-flags.png index 39595e0c32f67c6ac9de3859b932566b47b35ede..19dc44f180418c3c41c6364b31c853d04f63ba4c 100644 GIT binary patch literal 96394 zcmX_o2RxPi`~OWU*(+oxA;cjen~=RTvdP|iQwrH3WUr9y>`q8RR+5lSCo3!2`+w>A z{{GMFyq>4mc}~ZD-=ELty58#&p{{z55RV2AK@dU(c^ORv!GS+wbKzpce=x1e`3S;< zD9A`@`(&(4dYe+*OG6#~7P_O5_~PCjYZffBJC{(Y=c6wP)NKd{)bX@X?Rf2e@n3KD zuU{7P_s%@0`qIXYQbU^Q`BSp)J2Cus!n4*+PHb+KB;j;WpR*rXXXL*vHgsPM`}b1N z8@vI#S|lXLUz!9bgozk^nFL3Q1m~Dtoud8iig(4u)3y7OU*jlM22sc(CfpFF#nuL% z{9xo9f_uPC9p?K(<=?xw2VP&pClUDn|6UAq)QIH2FOvEihf9F`_b$`oJ)8^3e{Yj) zUBia&`0w)vq^+OKH`<)qj<1qMC@CuP)2x1emSy(x=qTjMEh|DoLf@vW@W~qI4-1>R zrF!&aWPJSmJ}o-l|NCh<3SteGk|usjL(iT)8yovQiEhc*bF#BL_&djW9=mk|bFad< z?0xtFIeFr6slKy7x`>E~kLXF{lcxi zeaY#9w8Fw;<6{rjbIqo0+9QXQl0~ifuJl>CySoqWy5jxs`hSWxAWS!J8Wm`k45d{x zkKNPw-r$Xohqt+je-zZB>b*IIjnH-O2Z+aY-qrZNysgJYS@6vXMcwQuh9mXq(G}GYnUuQG`@4TI`E3wp20@A z8)cc}zht+}>}^CD8H z)krIBsjBrtulA;DU1(zuVIqt0IM_;f{d%!Iig9`U?4Kt0b0`9f(QyHvyv>FFG-a!j zp>HFC%~m*4)M5LvzEabA{gWn?|K0pz#pIKzOVm=&N2?c7Qc^_dc1&k$YzJ@CtbTej z`0d-RTh*3)S5$84l*~;u@>P#g1PHRqrKAYT7HbdiJEEc=a3xn+4=nxUr-|vaT3xic zh&*R$G;L)LWtL$f8(k$z?D9F-iVz_vy%A|=Z(m&A{H3Y1v~+KdC-^cf=ZhEo{QM~U zVZ%nlsmaNL!FGToT1Fj&{dc0<%%~z{+S_kYM1I{| z=#i7#G7Qx$c9?p9K0rKpcP;bk)$YALpC_#-e*T%weFUM2sjIA%FVG~%S#tT2o<{R~ zd08(xCMv4GFVmdw3XhR+f6Rz=Um7g~gRxOyjFOrr$9-AZL6;06uN4wmjojSsj~|)K z1fp4diNf>C$_nc0(hf}>9FD#h4;~!&`G^L|$WVklsNtu+CIgh77ktyhWRb>#fCJ7tNI&0rnMg}L+9C;-9C^9zoWai24iWe=y z#IN1xib?M6F7#i>_hMTw$(0NJiJa;tj$rY z$K~jF^MAz(_n_532Mdwi7ZDzVD;ylW)zibXA7G3~Y7EqT{>+{~FyrzgKi_jAUPD8J z=lvfyJw2a$_wM=b!}iqFARioYHe1c`58EEJZR>p*z4YCa`^}t@5TpR(DTN{rD=IDjn^WE2($f zb==6PjHJ!(dVhWtdiYae7jf6kBk%6R2Uf%;Pf;p2Ntf@7wyQ=l2uo{*NdOd(rl z+~jp~6zWvJ{57{CEbKy5l=Z6uOVRybb@TJAQSH6k(j|mY9XL5fCI<&6Cnf?UnjikJ z2*mH?Xg#vCD=#W6w6?S?8Tx&4B2LhDi|_3(xAr8?%gpiYK0jXEkk!!Oy>{(@Slp+m zq=X##Iz7GH%^94Xl$5XjRF7-^{rek1EvG-KuKDk-VI%wk0-~o!N=r+riCG>tHkEmK z@6qVZt))cd(YtrFrzh*DxdS#B4EY)>@+>;~L8Du(HpeX*!gJ>W4X?JL1f9OW-~7Tj z=_H7l4!x=6<$d?%OYHRNNxe?VdBhYI?J#wuEiIj=S^Une;O(o2h0>&HnVJ6kZg;|F z_4P-^vnvYb<{R8?Yt2$qM;YRFKRiB$WjE8Wdv`F_a(WmnBik+`E1Rx-dvek!G;~l} zS{gyFU#}*?aYY-MSFvz&H&<6*6BfQ8_5Am5d!g9=j630ZNAL}k_0EEAsF)Z+o|dEf zhzNzjLKO+G6^PI9o2iueTTb zk(kR&37q6l^iP(jtAd{^sEzKw`r9%*@83YNH{<46dkf?(5@Zr(EO zJ^Qh7XGegJ4MD`S>+|z7X^+n#{4_U1m>x@-?yNMn8oSJ0y_zfNEU>e?J3p_gATR%> zwDcukfh0!~{OH*9d;&yXSvf(mfMSj+s-07(^a7H@{?kJkL9SfUhh;KE>)hAoH!6y1 zM{)7;4lHce)lBq$`Ev6{>gecbd`8AkFZ9KW7coD7`icfINpey|&h_YG0gBi=7DpuQ z?EFy3;_`B6e(=ACmcy8Iksd)2Xqg0G6BDzT?;T}RV^C63BF4vec4{6S86g)9W5P{U zj%0eKQ!-g;hAA`0k<|#xZ8vw-ei6$gpVCt>LVQu;Hb4I-LKn8~-d^J>b5B1%;aGBl zwy*p#X4E}Xwn+>GZM*~pwofe|4=z#D(Y-Ei4BGpHg&I|qjhY0{r=cj6c&l3%=_p{1?REWRr(4GRj(>gK+=ACRTT zl_lsb&4 zyJmb93*i?OJU=okMe@iDN9E#$3kU7y3QQzS3Yx5mqYgT2u%luzi5?d_BcK3VT3KC* z3H$pu%D5st4|{X|CN4fc`tCJ)qQimw@WaDHEJPr^w!VJBYv6pieaBqSWg{bc3)Psz z0CA@m)02~y{4_s*{sf#=^FW1(L@4-V;*(#7YSHxif7Q$KWyQs{3B`Odu}K6;?D{c2 zo|u-FmXVRC%~4@gV&~}Sg*I|)bbvyIF!?o2ne!TOu}0!i$8!A2bvkiWLJ25msIxTbW4La;BT6T_pY{(E!3!KmMmdts;~NhyV!=cdt{ z!FEDoVgdf|Dy2nbW$jkgmqMBI2lO;tBP{hPWZm62^Yii=sM{O_c6WCR3Jd$7e)Llr zzV{I)!Tmlm(wE(03jNus9$i$FUbqw%=2tOtEna@rYaIGyqaWX`YR`9iMT5R6ng2t` zK|Tynpb#P7zk4C)3wU{j)2#gb(VdQu&LcLqjkbJ!c*Mlh?>xsxtBV{34nxl4L+KxL zs9PQ>**cglFOLlg$@}*0`eS5hdRow;W2L5MOQD_&ABR1vy>uw7?$9W8eI#In7jhjU(obYVk`&JLkR#tP3kB?i_k5|8S+Y2}u zD$#Y)Qk(uDdHUi;sQqwhqC5-KEMMRA1qD%e?8UN6|}>G>Qqrs;QJ-RH;VG6m40DW)zzCf-MbPB>}n4N)x7xyhNq|3 z?*2zUf^RaYBBp#-oF`s$-$eSPVg%wvG;twWzMH3Fl2CW=f^8@o{C=bBL*j$0r+pjwFu6 zE+NsQ?N?KiXz#G6PhS;TJ4`f$rtct#jh!99-rgoJy8qFvlJJQ3pBLQ=|NOyyVph}K z{N*7ZHUdXao!!CF@s4+Sw1{MZCfcyPurTcL`l(9rK)9ao&ej38QKEXJ;JI|PGf`d)&-p!m|Cnmh#XjmQ=_HK4Ix2{en zyT1oj(`N-pSvdG)<%49)UKww{a24gjX`mtG|Cc zI6399ch9+bdU~2t&wIQp)#;g;nVIWJ*;yIAtUTw9HsVMcv#LHXh!nEpb-LD%8|mv0 zOip?(qrBDB1Vfk@;>NA2i3kaeTY@|nzVtVWy*!VdE6HTztI zOpGS<4#|6|$CYP0w(6x8p#F&InI4zf%dTnqi)}9P@{1cjA=lQ|&&6V-bN_e|p6EQ4 zzA8n+ox(|i8<64$TSeh76b0|niy=AV@$#>PGh@-bSf_bsOdzh|o*42dhY{su5g9Qj zm%jl;YRznf_*?Xq>R)dApZ>Odi^T|?tW-;6-nK6vvfJOo5SJS^9wDl4v^k2@cv2hw zV%2}=+jSs0TYJ`Rm-#b7j_5T9480=tv9|7vp}oxzw=nevTF+SpCnQ{5SrK*px#(?= z*)?yEyl+=)W$t_Lp1-4G%!q#+eakvv9G!B*Yb3bkCM{mucGq=Zt3NH(s{-yi*`U#O zlPfImwLD7)N|~J^^yyRamvw+w9e-3Ra3n=@7TL~!im-^&Mk?Lr(tiD-$RBXoTAZE9 zc%6`-4|Ml9C|G~AI9)KE!3qB=Zb*=WDWDkQ7l+^1YU@Kmby%^xFyhs1%^FR3R> z_1&fKCXq#K4GC4u)om5%RUprz#-;NPTABwj~{gnTU4DvFDZt*fcQIrnI3 zu&6(~oZPXwacSGN5cvv~=kVqylD%+EcRw6?w| zD4XT4#600+w9`%st!AakSY_dG|59{<>+t&qy@gV*RdxRYVU`#Nhp@OfmTVQE3MkvAcF!f5v`dESg}Hk_e|8gcP*I7& z3zcS$hodt)YnG&#l$t8Wmj}qG3q_!iP+YtOthJ-#U|=A=icOY8rU-5;rh3$&tgNp! zhVPeKqhdh^ib9H{N{@~_zxqKLf+Q)%VDu`#T2Cz==5*ONRl%t6dnF>Zc z9PGx%eX@vG<>kYsCal4KA|*3S9&VEYKI>nqS<|!oj|Z zFkQdCy&w@>R$YzJZ8?~$?iWukuAUw?g@nS?`T4@PZwKv1%17+lPy_|+Z|ds&I%A3Hi7rZ!XceiN z)HxJr7Jqb&HhU?_gedt61&Gl@|NosAK%|mYY}dv zcOOvEGR&jz_q+Zn8_Wc4*pD9#E(v)oewb=P=jB@jZKh90wv!=`47r2nQx^!rh8P34 zrto>*v!sOQut(-CzPWEt$!!?0_*FMM_#{G)YqY_2Fi%!VK0$_rg#?#?Xy& z1{m^c+HHGY0txr|?-_U86%s~9M$UK=_02O_ispEoBkTpZuSq9zJWwoc4z|eB3a5h(iK)XPWXvOE(vp&5%wF~{T*EbF zB6;=dRhbcb7Fc#m$89}!iZa7SVOUo|qGq3sqo&EUm}k!>;BjSSh!V8DH|A;kYF;ID z{krGjPImM04kH?k#=$;mh$Y9lvXU>)qQh~YUuDyWCDQ!PoyHqCikahoENuSu5q&Hv zcA~n$f9I^`fgHw^_XcRp58n>ZdH*0p#<*Fwj9+k z#{`@DZZ#Jt1s)68jW!fZ7lu1jhWRq?Q{V!IHl3Ia8Rmhp+U1gx3X#k++)PNDrOt65 zL0YESlDa8*f(RzkR6h(=+71ra)DVQXNs&B+-skLpg^HVN^1Uyo_YFFta2aOOsCG5c zs`Ik(P5!&;FHD%@ee z>DiATdg3N1r@Hba^!VE#~rZv(6L0k1A3B+LU_($9RSXUpYQ9tZ}@p& zXh>hjYixZNm=^nu8+QZ*f&i$mx16f}xdxFA*05U~K8#V`A4q+M{Z3F>AO;vSvb6-6BOhyU}Y#JEg1s?%U78DJjKX8`-6LiWR z0Jd6Qb~b$HVdmn3ASk{(6A-oJS-{B<4Q_Vu@mciZ#K#DMV&Jv2Vv9V#Uos3BBUL#o zBSX``z{pVaZm~8mf%~Qv25JyXmq9}%zo@ABieP9S^{&BVjQ2sf@SQvRKyL8D9uS2e zSND4{;eI?%4Jhz){1a%;3JN#yDY+7Q=71{$jBa+#XWg4SL;WINpO&}lYWS5{Ox6kR zYMjuEh;RCc0+CfxRwl!f6%!K!(Q*6m7*yYb%1W0^Zk=4*f#q;8Kmx^E+RXu^su^-y ztEx_cey`ZlNq_57jRy;6Bcb;+xI9!#uX;7C}>B7;5va|%9 zumYrnf`WpiWNuQt(BtF4!`*e>^gh6>F9phku3qJp2=4yzzEJX!xXX-Eld*HP{<@L? z4G#EDgn-!=uU=D_vWP3gZ6?6Mmdkhb@p+w-gUD*2CwIoDPddQ)I#XFr_OpZK5`NX# zw!>l(2mSgSfA?@_m8ki<&Bul<+WPUpeYgD|?!KZ~{Sv3I-u%Yfefw`SQ^b<<^76Vh zel+JDU-hbe04k;p|Cnj{(ag*TAmZqE!mf1v-QDw9(lT;#ULG}Z%Su{WnB|Joeu)!I z%WLi5x+cfr_0uPJb#*)Gg_|8lyJwUl^P=V2{`^rlo}vh0GU6U-4n#K=8bf1Rt(TbD zJP+N`;@qRQaN?ltp()oPz{YXneiaoJ^;K2k;^G=bQA5k&AT~}846sr}Qt}uplDtwZ zxPZ`!`Ry$ZvYi2eJ`XyP!i^40&qanLX#tIQK-32Y<4#Tb~ z-gFfs{`0*G+9Di@hPfh`ZJ31PDbdNMn(4z#!@%NFjNef3iZ=a8Jzl^UIro7`EsLt&xe_i)Z3 z6(gJQHOn0x7uGC;PAJyGBO@b?(9J+$`O^Rfrxn7v05^gBOza0!Ptr7Tdp2Hzhf5=_Yp}a zCs5xL3YUh5hb12+D_V|}-=F*SOQGP~)>d?tkvK@QBR9^f+SCUG31Q$1GwYc8LX3kw zK{RN{@vIXwD|d=K0#V#)u~_|SbXhJu2JZfLLQDvc28B^WWexZS%B+~peH-VdhvN?@ z0)$Ituytvm)%GV{DD$sT>)9^;* zA654NYz2*X1J}!`GCkvZsXcQ?+Z86XB9_DE`F?}e z(s4sv&_+)6wvHN>F^0`0q~1cX{=yyO#}fdI34ot+w7-pAHOn z4Af7ir>D=BR@oyr6n zTe=U66p6RKk6^=jW$0Iye50TsLYV{rF!?S9moMmRbl#%iT9mTJ3u6gUr=01bq4p#Y zp)QmtDl1FFC3~%qKUrr7CRak(i7KtCnw|8XwsUey6ZSml58A<}pl6gbrxw^KCf()i zKAxDI>=U#5QEjb@Do|k|0|f3rML`S_MjFLgH76bVsxIh0PZuv=W7$&&ls7pE@T4HvGWc7growCLc~1c%w(bEG*DWO;2Z}rS_9nyN(im) zBdQd*$w)cRnq!ESmX_9o2Vv^$hBY=-Bg;E}P2g0_ZtQXOTu2OA!*?RQLeQqnnh*9% zPdXVDmBbDLq84F(Vj}##LBcT7`~hk%Wkp3*6%|1mLd=?4@U<{A8X6jNa}ViUo3^kR z@Ofu9d_Yujm?8}`Ea?I;W`*;XlfqZBnrRFmCR+RCoC+?$CpP;9QWg$XSzH~c}0c)YHjv(g}@p12e&lm z-uKj7MR|GVAkE|9NB#Z#mlS6<*|M~(jA%_!q5UQ*M?b)I$xA5q11UZad^QTmORXNioCX1Fpi{oZ#IyhI0q<)$GmFGeKLzqrir-PO@ePx+98V(nmnwpF&?!iH- zHEY>xw+DE2#$G|h7iFkdX4NhJe)cXEPnQ3Bled$1q(T*!|DTzlMnfG``3faxc3ILbp$6t2g`iu=*3 zT1VFeZ9)jHR0x9XCb;2AeGT+Lv#bseCufRCEU&F$KWcZSYeR*Z{r+vYyRx5PkiFp5 zb@ke{Yk-a#Z*yu;%*h2M&aY)l1lN_9Cl{W>k&-X?wzl?VYKj3t{CmnMPulw@vdQ~F zCu=_XTWxZBPz%rtLlkuyy|njBjPc6A`czYO^T~y_uhe0)LRiS+%F5o+rdq>jc71v{ zsyyJ^&a~n~Yb@kmES;T0sWo*P3&4c2(NTsBqwei5%i9^ko*!-aE4iZb*z5DlMwZ3E zWmsIa0ply)fDIe77NE9rO&1u5*XmfK|8B}ce|FjHhMM5hEbr;#!7{@DN@QmH08p4- z^0vPhq*x_9Iji=kjAIh9|u`!yw_hFbgp<;lVb5KW8rgK<1jz~#pvPUxG zetc{CP5))9#VvYWkN<8tGZ$f3%_2M;L z>4b+eGOs3`Zl(7bUaEic<0a*ZZ$p3P))&WS9{PJEGF+7R?sYQZ@(Bq&tk&Q$!vpyTC4j{C}an^yZ=rfueCI4fo2#T8>=cDf1neJTTec^%6&}= zl=pa=m<}6$B7&{BGCbKTgP5bJ9-x>AlitnxYgkl&k1a3ZULa$S3=IqWJQoR$K*dPU z?P$x?s>x1NbSLIKHdf2DL?Ocq76lwBF$V9-=lxVN_d4ZSer9DcM77hspZ6ZMJOfd* zt;meitkB8vO)=8TmopO+!NgU~7Pl2hS5!**v09gwW>+ynOP-&8+uqA^ZVqkon=~Zn z-b5IoTB%{<1z8P<$x zHm}|Kvy3Qi2RS~6*Zw^5wTt! zBlJQar$E+VeM$f~q?zqP+aj&=dt+_>o40SPaHkv|fB*Amrq=%cxpT+FXj{0ZFf zqIw&Dy>w=5G!qm1T~Wu8QdG1uX>c)HS>0S3RMO_y{`3TbXK$^lm}s+awloajlKspSy~2r6zL%uYj~kCpEI``8~KZDv%NvvsszZKw)X zR+>a`?pZeD*-na*#m-C&?5#L1QKoP6dJ|ap`o(YUow84Mao3H#Z@la zq+OWlC&q%r<*k0vqMHT7D2sTMF zsq5?W3P_t$gFcMihKkH{fl?U&UANA$|JS_gtU%*K{b6(7L>AwJEd@lvI(vvJ(3zQZ>tbJ&`;C7ow|84L3?*04sAy@{G1-1Yd;xzI4Jo2fNO?0!@ z{edHO{YwZjuydsCfYu6zF{rO>SFc_|m?)K!ZyEp|J0l;k=^;+JDR~Zw{99jF_iKR) z?jtG1WXrD!c?5Xj+O>Rw3s2h2;vypEVxuDln)ZHj+SS(8*3Q8~^QC(1toVk8f`@gA zUT>b;^d-f)s*t5z_`0;z#-S9_QaoH42T(`A1-g58a}W$9sEE zA-M%$$-(YTi_7eL9a;g%k!55|td3^~pB{U6^i`-REC1TuS1qzIH8nL?#e()iU}PJ4cCoSaCB;|`h>yP)Ns8dMS_rkEHSb??Yj^M!WsZ} zuuWk11}%Nt-<|UJ?|u<-nNug9{a|N2*rU-9A{Q9$u^+wcwGTFbMpZlw4J9Vn$`o>q zX8L@`eZKwEqJZPr16|$2PKjm>*aYAbsupeTww#ttpAy~*13Cx0Er&7pVkWi+MovXe z4vtx}V!_h-db_KrnAly`M8VrhN-RHT%s|E6SRzAY5Bm$PNY%5weRdrzawJ@7_fowYIiGM(Mdc%LEpP%fdzuP?2e! zkFu1Cc&Q1->%>Y1+rz@|d3bxrI6|87gX@G{Ef~7WE3&9f3E{|9kr&PW&LJs)_;m3YNkr@^oKOh>XxvFV^dE5wu;v_R!L5tKZZ4 z?=0pp#y}WnFQEC|yRnZSi^2RnJoK*}tAylMvSssu-Fos(H8;Qm%t_ty3E>zSv)S+P zF$B`Xq&V?CbD+DIP z9)&1r&s)U;#RAPZe8eWrY_y_ibt+fHyb5&n*k}T1e(gyOhF<_VfQbeE=|orx@(A3& z*w_l)4Z(C3%Bbu7+BXur8jVov#>&yLEM2p+tuuSgWo2{3!9I7HNCGVW{O<%w&9q(w zWr3gnJH!-0I1uvNasfgmm*3=D?dtNUUvTVF$aBT(2vYl?+HZTz^iE_Rze<#hi3EF& zEo%dc2)Khnf~9_XADQSBW@BP39?&Z@Gcy(f3+&;s^-`F34TBl8t$K-#rN|r)f?8dj zz;w9?P0R%;5&#GSDz7UlQtU;go*PE=FSrZ0Fyv@a2##a9xYIUY&Q-@nD#uq_2M74e zMu-E){r+z;%Kl46*}VZ?Q36Spj5`oNX#|U|x!GyOE%~wJBlPX5@88w$dtTRzH4|$4 z3i>1YvWF0zQ$4<{MkY6rtcKI6Z-M3=FW0MyT{y_=H}Cia#4fbCv`kNb;|qE=Jum>m z?+eAG2W4{%6gbnG#oA{)8@1A#I%t^b))?SW*sNH9jp%VDA2z$A1U00%DC2Ij;9|=T zI8R(7_+J4>km&=~EpI_#VK7gVbl0&kj#zszJm5Xm0@A ztK_824%du+DrMm}R@7FerXSXKiwZ2cOqvyowL3c5;13+);#Yl?y}hY=-a>qDZjP!^ zxIgP=8!DQ~h1-<6$DFsmz8-kF^VHGSROLz_fT1jdWjuiu z&}<4pJLFMTmQ%%udv^I~Hd<06s7wIje5srfF){x8b1lb3!3QG-TJ(B|9)+wz!uyt@ zGsXk2AZmt>o0it`2RndH2yI(3SvZc4{lz* zJjb2lZk`E{{yGcGuer-`M|QuzFR>`R8KS8lr_Z>BLVcAG7AB*mtq(lJ2hOqW*94j| z7e|^f>gxy?AbeLk@B94vJPRi;Rk_)BGZEV2n>X*^0>r%6j^4iqjRhQsgX18GpiNDI zL)BzEm=fk&^&5ZZl#Glrck8kKbsed%Cg^Z-7&IvS{re42MnBOkFc;M(gzJlo zH=qIgE*0oPiVE^v`pNBQbu2?X@aJ%rAx6TSpGN#(@m%tG2(~_dPLf7s*lY-q&&bF^ zx1s6xqYci}YuQH+@0yuufRK#n5wyj~VH(}78%vK};iA3QPu!NiSqf*a6&GcVzMZ>4 zA?uRif}R9?CgJ-R2l-%Cz4l{c;8wqbnxdlb->xG4UG^BgVaMu0X&Ba|z8S9gzz$mu1zW3lk$G3tW$R8f| z-ZF6V_WHNVk!{b0$|0=F?hXn{Lp! z1u5z>ft9~=e20sYvMYAB!Fx3 zGXcgfE=PP~P23o(8w-xRW&n`2cYp zrvXOUke|N_BK_sdDGkKJbg{X)R}sC$E`A{)l-Gsx|HY1QATafhlDe?5M}o8*W+uwe zPrnAv>wI5&i+MXuBwmK7Z)w3CYflKMEHSi#x$HYXqsBX(Dx%K(_J(xfC!IYH-Kz9f zJcP@1dR|3{;fBB+(RGS3>;`5ZiYzV3FuO95y!1%JI!ge9oiy$K{Oq72NGyg$A%Vr0 zc)3xGSueT37TmGJfM)c5#h=!h`O0{f2n;dX-Pu`l>W+oY{o|7=&V0$QyR#a^$Xb>p z)805#fRzAe-0zAcs36O9xs9a55h)?_r?|Dt3ecU z8A7oTLWWe9*Ifp_w8G4@lxXk|!pA|M84U5h?%pK9-P+kPrIsUks?2(iZEy7wo$Pef8fnzeDoz1AIC|X)tV!9uK zYd7QNKRJ3`a)oZ*HtXZ@wmOILCF6rw`jqc`l?GT+-j;o7o-mJq!Lv=f19`ck>>v+k z&yMzXwaf<-qoc<6J?9=D_s73@@!n|?1Kp8{WQKJ^!b2!F!?dL7}HV``hrauoG39 z^Ha>;>e{irwCw1OG5MGmW>VA7w?Ec0q?utMOP9Le*Zk4CoOz9Pq^VXwLWT44<{O$Y z!>siURxyPH;u#)U2M0qdE25r|2&@nAEj`zdN-0zfUt!-JXw~rd^~@eTwwdc75qf9p z2V1<8$5ZpMf*cbWX=)-3CGAx3@&GH{}$hJrdSN%t*eAvV*9!0A)BBp!;u6r zS%^CdD8-oBlne#*ds1FjF?i>p51|gI!54RwB?JV-nVCPDR~^j~x70tlNj(3`o0S3& z%=MuqbIAQ(IEO%*|A$473agfp(Ik-HHpkh!uXOAg{2lf|v_c_!RSHT7e z?@}P2KfQnHk~%cIN?RA_AN6722kxD?Pc&nMe2XVNUR^r`)F^IZ%1^WA zVgcEVL>60qFG2qA$FhT@GTge)+RecU@=^;rOk~21VeNg$=O?;mdNmefSKDDq4H`RN zY6gn}tX0(&94U?@#gZXDfmjgA&T7etTSFKe&jg&v*cKsC28ehG(Rro!c^yWT@}??V zjQfhPM}~!Qkm59MdZN!ku2=gFL6}B%zhEJuXpGz~Vd0OLnQ>tZ1|sT}51AR_sL06d z_)1%?PM3a~M+>{xZ;KF%MZT@#!6#7ogR5YbXIJ^a?!mW=c?s;!p%V)3+mF78#_ z2~*U>+FN-R&0KXGRJ7_*D4T+2!M7g{Iz@x7;abWEYQq_MK1MR1hYqF^Q-swi2$L@L z4zJs5nz%VEz6nir6bp;n8H)B-;+_=~5WKB@)oyRHID(Om_nlqZ1$k`RuW@m7C<=X) zm~s9KL+3>a@7i=TJjO-x7-bR2^qGARz^y?`8S_IvA<>Ckn;yP)cuXt?r>6&I6T| z0Z0Q;1-PJFq2qS<1B9fLICa}UeKM#1g4&ufJuNp9f!t6smp;H>xBk~1rgZEQ{p`>I79k?nf-OAqz7)BO>bEe0X8=*m8!wPT1LVQ+hP0l@9 znLM0}p{jZK1F$ShQV1$8~ zQCxEH@mctelM^NgQ#hvrHtD01b4Zy z0r9j3?(i^tc(s`zkcg-q&f~3 ztRJK@z~~`%x|j-J+;3YL@{W1zDz`vELwl{#(XCuWKF|F%Ir^y!a}iZl&97}Be>+lc z1X-NnB@g5gNG*cX0Yxn>yMitIJRwY=J%35PmC{dD$@Rx?5=PEo6i-~hCt-1A-=y zB|*8GMq98e2{d90!Lhj@g(#TfhU~F@-*=2>x#PVS0)vkbo5qoXslx5$ z5hA)D3vPF?kbcokLoctX4NUmvUp%nxBJ&_t3R|$axbaJ1Ad5n|el^?_M_i``bzxIe z-@>7nzTCz@?uF{*k3&w0L+23GOCtm!kVQhi*84>=Ka0ytts0pfuD$N^f~6Aa+dB#- zqG<%k*c5aiGOxgl`$3(8X{I;HDcRE2FTjzE^a?Z8e({I+O-G^>VgzO9m5UpKVOOcP z=#OPW+B&GDzwTcA7ZHq%Q}fvwU4YqXIwEwtd3@JHm|%e9Z~a+5%E+ipogK!Y-5Qy% zU+-J;XfWh%nO@&$IERIYkl?Cwr}QjuV}Iy=__neVm85tcsnp}*PKnBU4MJPJgKs3- z7kp&Jf;2Ek)!74%w@>9Xv~zI@@$pUGKD?tc2w7=%3b}io4xnV2z3fTp=@bCXAg;6T zxJY#{dVKYlQ`^G)JQS7pFbkNf%$=gdt=pS%$Dmldd81?5syd<*6CN5mz)#MYZCX8A zsuKm7Lj^uAuIR$0m(-c9C`FAE2wtnCXRWNSW3nzhlgWd?Ik}p{hL0$C;%<#cNxCPh z`2#PN<%$MxBq_o=y-*y2Ko7C(z8Hhx?&<51ZS@U2m zT^jBWc>3Y7Ij`<(ITF*_2ViDQuLGqUZ9d-rH~qTk*7!ov(soIcj!pdNk5OdaL%vj< z5*XVf#IeaAkk@#jLt7WHuSnMk2?ETvpR*W;*`!lZCx*ehXL!yHh6N#o*=X2$-GdZI zLz_Rde*v=dvCDjsdE@mh&r?#I`DwT)tJT>Rm6U?Ppz&YGl$d-!N=-xaW+*Hsa|vd% z!HiuixvHR zUlf)|%&nzr!ifXSedBtkCp~lDmbZmsVeJZf*`hmJo>6$pi^R0ZABl#B$uzjLI&w7hv}1#;f&4xbKRB{vJl^f$_Xry znjoL6M>SOw*U7yom<|U^lQfQn7mKl8SX7iuHxw5OKUznyC*+Q76&dNeol&q~-UF&D z9~Vd+jq<4~cKrgdfC_2W-q`q!p&Hl3yx8DXOpoj(W@%eUMV~R(#9|7hlU+r+fm~&WRMm0 zs>L<93Ole5oqc_{a!8jNCwSl1@Az=gn_B zAD=yl7m#1Ma+xXx#eJ5dTW{Lcv0eHG;dJl`0-@M#90o$ytLjXKIeqZ|q4^UK5xpub z6g$}~1pf~%bZvBVyU#R)3GAtN9!t_DCKc`GIwz;_J3@T4M^aIL+}AUw&~o2iNBgal z$v&H^YV9DZv+bxFiOp1bOUst-@D{z_+?Uv&&cOENU5aTmA+^IG`n5FnCC}V2{@*Zm zwREdKFxZg#Aqf+T3AMfs(bRYDJ&oR0p90r?`~5xqo|0tq2)X9@OgA^d?+5^%3ZYTI zrjxI^$1vPVL@e0!=cAHvCQvY#yKT4T2ExEBJEEIluMbi$E4_EaaudW1394T#G-PNh%q)yD2 z?r#0s->INKG);XSFiZV>FT_$qUmwyo#cONa=)i~by?1c065NHD>GkVu00m(dBxtWK z7^3DN=}c5%Hcw7YK7PD{PsN=j;OOV>uI0KhJ0lWw} zJluEt_WiT@^d%RelZD`*y9q42{DQBGi>uJ+@rRKw#REGa+D{@4CWv`eLw?&g7(csj zkNHW~J5Qb7S7*_=&>2US-Zy{Se)yiOEc7d2T`IojgJnCI?Ekr1%xP)_Xnbl>8=@!+;ySEO%Ou3xC$XTd8;{Sv9+Bs6au zy%=mg-kmEXu{5kPX89F?^FGSxnl3hit%h3uJ9sT1$WGDf;iFgQ13o%vqMIIDSl`6W zRc~^b`?&Roq@aiV&jGe(#D~B;%SJ^BqIFEyxfMqQ7bz}9=xdqR+I9JlbC5{iaJ{-Q zAY3b*VLI%8{6gmQt$Q|M_e3vm2bLtivcFGOrr3S$PeCvq^K&g^-Kp zU#=>PphzmKru&mMHR$;8p73ogt|3~tnbbE!8|&#>sYX8Xfoi<_K5_UP#*a(7%kabW zG$S+2AssJhnMz*6Z*wUkMpXHm|A2;;f0OmMC$=N$BUk#D)<*5qXs#<5_bTvF5nRd1 z2?Y6LOvhm=$up?@*|#^R9d~0Z8X{)>^g%GJj(!L+3RD8K!q#@lcXP=Kdn3|<_7fyY zP)%b|=w#zI%gV$&ylWxy1~mXC7D0veg&f~q$EF;~2ns4VRr9ohX^HSd*xS!;-MY22$aZ1H z3o3lv4^DE%VjM_I#3>Dn_$|N0c>2Xls z9USgLM>0L_JJ(PFuV|o>OmOx10^~A^UL1Z^r$`IfiWixcgAQd2ZHziscLy1wmE*Yl zRMg$b;6K(XB@2to%F1$BY`vaT2mHQ0J$0h!ar&bc*3Ys zDxf|(Ihm{R1O8bYEy&pZl81Af z-JJ#I_e^xH3_^8|7c?~mH}2+oZ%*~ck0@IEMC%P(psfo`sGmXv7`{*i`ugl&! zb?n%eQKz8Ww;`WUh~K!Tt{y-$HaU4c^Gv3CPD5=i#Z+S2s6xEBrLFC5UiQno*d?1| z#B;j>%e$UU<2}JUgDvpJ;-q$&UT@e9m!)l-bRpFLbM3cJ;Xm_Uo96FxR8i=9fBazTiNWOT)fbII^Rw>DzU2Zr{Ovl|daYbn zf@QksgSZCOdt?sgvPg_BHLI1Xv-Q$bkB7xPMupk zae-iW1$zPmfm4*tEiJX((+>UvBF@6-3K*FScj)8oPa$=NSkO&9?Hr!NdAINU{pL|7 zM(X<}Y!bdMaLK~>L=m{<)`fIzYMGe?>iMytRG;Z}i*LC5Qa^o~J2EoTp~T4K!@-FR z1I_3YF3*%W{YC6cyW17N4Z~|ai4BDz{oQ2$)}1Bt9+XwIL}*#Kxh*006^PT}-2Z!J z3$J+GGNpo!@Gc_f$&)7qek+TqF&(EN0yhMInuvEyy+xtc@w`i6(nt1&FjMVzU5cPd z=CqvdVH~`#1A>okyg6*J{&mgL#?Rpsoppl~4oY6CBBdN58glG_0V%P2*cU}fzD8N) zaDAKY4??slN}8v_&K?*%%F91#9Bv)o!y7ZVw&K`sb{y3az#EEj0yj~yV2}eV%+Kn! zOTml1-#F5++}gHejcsQ5wJ5ohdqawk3MzcJR-d{H0sypk${F9r_w2f@jD?U_d0N_u zZ7x}AnVpl7^#=fT(SC30)%_nCR@uqPqQb(*_;T2Ue~4ly3J3JaSF+5)!H*|do&OZE zn%7>Y(k$f3OljZPc>OzPGWyw84x^Frk3NMB-a8bF-iZCGo}%^jJ7xzBYX0Q|hte!3 zUrn9wc|TZ~A2a8_U-_bB>|@ifehmqGZ(N`_!WHyxHkM)!9f2*-GX9SXtJN{CH@3Bd zi{#G^lM&5_n~nv3jYvH4=!(>;qM(8o4Sy9ssVon@0%d?#IVQ4oCIUsBVvAfpSR2kv z!eY!*k2wiVu~s(r=*Bf0!b~Y$yM)AeFQ4)ZKf@llF_VAPJ0QHFG?Q7sQSCjyYVWs- zar1o*ujop%USErltsR(~>5B~xirx^bdAxOhcdHP06otj(Yqf#fv#me$AEgjI)8j{z zcm8b}4a%0%j`I$=j?dV{CT4GsMn8?r+)n1}zU;4eQg2BkTJJH-R`ha zRP>Tyaz$3R-bM9$6sdl~oPdV>*4Or9gKRL{T2NL|_|u6d%>FpvL}rI=xnAj_W`^p} z(kj>8w_%UdFjs&s?YD6FMT(I$rzdiG@@g6O)%Z6{= zN#X2=;u;3ebpYFf*dZzvIMjZ~pT^@we~z&SZSH2Kudl z%CFzQYwGGcPd?^2)KNSOpYRud|BSA$SWvYK)H{CobxV|Yg$6?>{tgi z_mVUHYW1(7;kT2E_Xg*euW*YLv+v`m{z`e`-K*T`=E&1@-ekMjozh-pCYQ%N8=05g z8g9&8;#N8DW}`rsIP*s~*L-i9bEegyu?fbIh_)NYZVMJ_AE|0pEb_Ic-cE33B$Zfs z_L~Z(nr${kR)xa3%b)zN6_N~q#r;W@>G1<^?4wU!oH6?xdo=Qn>*OEH`sfBQFEU%# zf6{HHwpv!yg^(}I&%e=8WVuSiz|hv|IhrUKCXL0Sw6yg;t`v97Q9eIDBa@-p+M-&v zI;D+y2t`uj=9&a(K{;BEZ(mH(yIvV|62{UUV*$Rb>t$~KmNU>{}^8=TNz@EiV~{pFTcg; zC94q)1-OQnmzSmGfXF3;sGQR4)yyNhf_*2GaM52+;#-p?} z>BnXtdp;crgd4I@R}kLN%G{$Q&#N*P$$h6iaTSl!JG3oR&5C?WQvG1T_bi*D_*LG( z;CTOsH!@YZGgQqAsXRre7#n%&osZhf3fRr`m1Fr|XYyM!-wbQh*hh~KTS&_my7Ro2yTQavh+I07>wDS3HCn{^lKI-rum%7Fs1^Cd^)hAH& z)ctaO_FC*xe#;Efgu(ef@@h|7Nz4s80^>i8MC7*%E6L z_oXMN;U&M#Tyd!T4y)fPf{yc_tBX0kFG}wZ>Sq^TseGtVd3LKEb=O-FdICR}u!x8q z6ZGmZeSfrvG&)N&|7jx~Mh297bX_^Q6`FZMF&vXiE$@*iI2Ud&#hsa%Df<9oLeza) z*;9&zZ?m&oN1a}@j!A_^W1;8IrpoQ?v!M!e{P*wfGE|iVv&&xM^?7IE7cAUMZYUUZ z?AWm#>J*D%U{>m#sfxs-%YM+QBfcEloF6^?{yj9=pF%?FDptD_F@*DFUFxB&vCmL- zDT|NA;vu~`sd+Sp&-cmrcAy(pE2(`7TqZqU?s`}=0Nc1$c69tz?(^rXtyv^Q*0yur z&Fhreze~!-=BX0r2YcMSv-LN-Y<*X2(i8Pg&#u=F?n+W}DtpEjn(A%xA^PdlxW|uC zZ=*W?sC%>0U#enb!HTbJ-n&Gnsk3u^G(Em}$EHy(IlJJwj>gs`=&g7{9qMP zyXV(Y3L@uzUj2>Y3v7^4GIgFfCRU z*=%+^=XoU$549Ijb-6W!vxrDF$(3~U|F(~Lnc=-`l-@92;nb<1Oj*Uhmo{z8OAmmU4Ic=GN)rj`K{(4;w#6%);Rt9bdreC$igvKq$V-eBR+4kRxZ# zthZNeBw}PWV(y4pTJtE+NwL#{g60BJ_e!q=wn4O3R)(5t^S^?EUo-voX&$K-Z&Fjw z18)J785oF<>JNb7u;tcFxM;i#STuWBBz&A&U)+EqjDeZ?G@yl;Opr)HUn`7j+C&_1 zTkLIbkGX&UQGER7`t%&v-Ji!U(U-pOGw_v{pBRXcI7CMW5p)b(%_wqp6yxMKpl5Aq zQDqi(>KkbaXlfez_3M%T#&31NhP=cjpzvm+5j?Ah<=U3Y)@~m7q)DFo#KzTXzK!gh zoTV4)jfpw3SNXKxx{Vq~h(*T6{<1rV!2q<}SFY?6`aJOd_MaKMX8h)iCUaWiwrwf^ zAKo;HweBrmgd&xcm2ixs<}ebUe?Ujb_HJ3n-h4jqwUbhOv*6 z>&0%lh2`bt*uNf*gt5lU&F#rfC0b%YK*08ZQ|#*rr3GJJ>_$|W`G~)-aFcL?8)fpQa8p5rHwb{hj*xitju)B9zSXh3P%!M-Qkma;b zF0Jm_KG5j9k%%c5T1)H?>gu?Xk_@k3j{+k>@#Hhk7ca&{g(iM6zNa}zmk}8f!XBUg zW>ot2GqmafDI0_{H!LY5E*Ne%_19$O;W<6FOI2twaBMIq>#4)g+v zrcI=36ylrOOhZGz(G5w~b8PW{N2#?EBg1gn;fZGJIs8J!^eS^o@3D+ll+Jhx78Zy0 zZ5Fdg=sk&wI(<{C|8!#(H1!7bXCXcYrYQ0ew|HW$te|vo#^I_nahDBmGPezw3LV-b zrTjVW#g}B!xrd?O8iky$?N3pYQy#b^u`=e>?zfM;q~(ZVtan{+Xqm z;k7n<91dapLra7Pytll22i1g>vBO}_r;O~EFS9Z-6fZ-ta^(j7AB<&qH{B<$nLj42 z%XN5#;toRs{Fz@K#hI+^b5-urx5q+h-aPR4TCo%Q+`IlmlLTnZ5yFB@MN(kq#*Y3Vl(9%vxm!DwJ=R{{8!tI@Nv(a$Ms}O5Ev#w0WY( z8-lL`;I=$-3qA@!!-=;2dSZ44fO;lK_!@e7 z8F_gfCPK%&gz}<7lqa@qtrt?&7LKC{jSUS~t~M%h{?hj;@y1E8g-qhuv9qFG9}+f3 zn~z^j5I#SZRW(q$;e9eFi7PIWCsa!~h<6*I>(ju|c+{R&466>xRWYCC7XQ>8N!Na0 zyhp3>QJG-kg%}M^4W-yu);8QyO){DE5}Fr&$J9oH3>Go z>M}NhibwFq3OgB$ev>KLQYom=-lm2LH9$SNy&rNa;wj(EU%n)$usOiW3b+C8tz0T; z?13I09zQzy($dm;l_}qaFHy-!u6}ry13U3FF%hb2Odrp$6KO!7p-D z^su~CGf%|3KS2pyN@Rgw|7-Bhd+S}j*0SyPPL75dyS16PD=F`|9&=@n36Aamp3$E% zE6sAN$hA{3N}uYDMj(wc*M}=+M_1RLNhrBqC)kxWXWKAvemb4cV_8VK<0WednVpaU zh-y7dqsJvyAiRWOa0PA3TZnA#WksDxMA?Bs7vQ@eCYgW2-jJ_&qvQ4D>6b1G-DYQN zY&vFid83SY9&q@sk8e75TBMjcW@+%?6Y*<`{#}uVTQNK*lzaBP(RpdF{?1;MgF`i^ z{X~>paFt=cCRC%vB71H29t|=C1UiQy=|s#47)@k3@;WCmlf;xFy%~jU?ot+g(5RCK z1dqxYGSb%G-rjpdRN4BdfkGFx$yNig4@^}513#q>U(<-K8+E!D@6GYBZqIgXG=DnG zo+l=KHQ*mx@CcE#EQ%l%gw)jb3WIYi$5c2JRCMaDQC*w?6w3VZ*x1;wDeC>ZQl(QC z;96X(q+o|%M9m5!=MwIRyKW0`aDYK3lAvfKeY#K!M%s7Ys}%lU%?lvAuL=30xLas< ztSra3(fM7szfCW}ZZrn|TIYIA|kOAI_Q z1woz9j~<~X*L(Ng5DpHGmg%K!GAed%qUB(Tjqg#;aKfAE)FMuLo@eo@6w?`3UHZTvcoUJk}MIqjXTt?V=uc&@$EyY(z7tJGeueYtz!1n8w3Ys079j{V;D#z z^K<8Fy}$V%2g}^MRrY7S{=QsrN-+{Sb53U>$^CJ5(HGd@V*WPl~&(lR7y!w~qQ)rY0 z>&v(g{(gUHzd*=;zO|F!MYjJ|bGCkGsUrtb;b#SKfFTAZ*nfJNLD%RWFkwPaK!M)>2#Bs-i?oPK)=| zyg(qX%aVC)dRm=3io9}s#9W5LUOyE_%%Bo)J;Pojr*qObUtekUQRO}()E!?x$Ur}` zw7L!%;h=-wY7E{l-FWqV$+WAN%~}r7GoD@>4ItF6VRtAYC6o~}|tA2uPnWj#uEcfpzMp`^%kU|!1{9# zU9asl4LtLV!U=|G<_FqTO9p=b-lgZWvcsX|2}fP7Z~PXr&CHyQnI9F;_RZUFE?!A# zDt4WovVSN94DJZ(afj+m>4fpB`Dj+U8Iq3W58=!a+LL+)f!9;<<2% z)d^Q7jtGBA7GfNUfwJ>Vd&BJ7?3p<<>9^d$#h&V>xsz2unS z0VTHE+4)RV)B&^vq2Xs^q7ql?%Oq;OP835vgyr@ z@kL4;d!LGFN5{kfR?T%67l6)E*Y?7Flw^csFW!3UYs7 z{q~XPn${25uaZF$+n%L)wOKHz``Oj5>81X2FPlfx<>NfSk+6ZF83XFlwR^*I$1k`Q zkAj{hNKY)T$mgj?J?Opo{diZH_(hrs(LAr&pQbwA=0S!yATQ+_01(!%*f^i6T)lA8 ztxPXWdJgN#k_rLr3wDxkk&?pgR80NUtK#Ju=y^Erf`(!#dnYoU2I(LSltF+(^~UQx zw~CXeg&_@iKYw5;B*M!Izb{Q;O4VGj~+P!kSXWGI@AfR!f)MXm2EoVp#))- z@)F)P6rc@Xz9`7b-UAwKZiS9lkm=m3oL6>3*y}fqFLW&=SqSsx^cA-Ibho!NB2~q< z2Um*72M-P&IM8stdq{B;0K9GxOij&?e*0WUGuaRnAZW;a)Ct$By;5fA0oaiIu@?U4M>;r4_=X{*8kE5gQ zfB&+#@oK$y2%xqj#n-$6QtNs=JG(RI?e9woioIQ3Fm$m~RtL;mP>+RjJ5r_8V$kkfQ**ZD|YF-yYBA z=27M|p}R2hJYoE#J7kjid3pG7Q8Np}kS652kqjLVEUl5IamYr|VMLKq{mtjk{A(bV zFgQmn38+>(uuey3&B-hN-juW*IQTeZ(LdZ)&*YF_7Qpp!{uOuJ>x& zP0Y>h20l`keCgdy$FKq1*HuYLRkvabH#bg+3aC%6tEsI`+WH!5F0QRO#MBo$3_k2K z_6$_I)?^(bsjRQR6yfV-P)Mb&rba>jez2YuzUN{lteL*5>rZx6_)cFB>q54II(=uq z9n7JOltEx7jBg_dC-^LkEf{b5sa?PB19>triSx`E3_ao0;}WVf1$^T~&Kf^}xn<0IbCR4j)}JI&vpVhMx|%Rod$$DPaN`ntC$!&v`+?j;~6#{PX|_WM-ZKd%*nh zi_FZyWRoDna2Bz*=$vm8LufF�HxbiSWjxPQZqGdjMG#f3_OklY=b-vsg{)cD`R+ zyyESM>%Dkl44a#B#=OT3NgC9f^qpJ(Q>vvU0^@j2(aG64Tip;j z#BOG4^CPsM{_BjCRhTuLK701;ks}XJd_Bm@io5zwe~Rq{%1b+TN4bfz1RF!3q<`ip zH_lIlqjbp6yWCHHo*+_TKyL<-6Hooq^D22}4IX!sN$fy_-=8H(ArJcTadBsy$L666 zlUGn^AK!zkUgghb3U-!=ngi{u+U}3jEK0k>X$0crNvP4i6%za|Kb3=xAEogf{md1` zoum|K82g=x@qp>j!R^!c1|7DkcRxwXuo@?SXkuVJm}n5yJ3cx-?me8a$?Qp6EJJ6O zf2fK-*x1SX8^mSDtM~yn&QR48?~+{AE8!kuVya2>@n}H8Px0|TIsvC9ti+ml>ODl& z&)%{o@%IS?KO2i5}1oF(_tmmAGXRK@>6og+4yB~!I zCJG7*9iBFKlZzRh0@yiXgfR6RDl&I=t^H!*3!sV<%v%lOur@npr(;V%iM^x#+t@bdOp zGD}lf2>zI#muISBqN)iS-g%6|$lBU58_Zq!Y)F;fN_Af!A)@AVyzwz*u|0oZi0Chy z^GEOw13EnQJ%28qX#vv3E73d7RD}7KyLg_nm z%JIp`smV!citDP6hKCOR`t@tQS)xow*#SEXQ;0tIh6u(U^fuNM1xm>ifnA`6Qi|kvtVN56-7nl zgqT}f(+fF+y11L&gr6R32GZ#vV5)Vovc+Hr_Q|BL_S5Gt5oM&MQA+~najSj&d#>?# z;owUKM!vTYyyukvX$HF$%9B8vpnhDAI$wK#y#5iB4M`l@u9DqD4ch!SzK90iZxx=^3z;VYZhU+SH+5#zP#-y`P?gjNJp zgy2*705V-{vn!%zomAu`UuYNkvod#}zdx+g9hzu8}Ab+xs5^b@^x zbk=b5z~uG}WmU)I5#zCIuaquQ{(VjNLMhT3x^5zUtEdQZLXS_-k2wkN^fxzuK5SM^ zq~O~B2`Z2`Z?tSCavIE->FL=nf3sws8Xv!T^X7L{nBY8heG*iF*3o`n9!4LyhM}JT zNe3tk%&VxWsMrGEl$L_B+d29Adln7~Vo)Fo8yxy1MKQYY2NqwjCvx-G#unHQUh%|@ zw{J!>RoNnc4{*r~^EzU46c_t+GLq5U+lN+uw|{vVo2i`NY*>NH zu(G!9D6)-cAJ5g`!PN{YJd(-imVf_ttn7wXF1|raSGO8;X42P;-TQme113fN(soS4 zyZRvmu}^<>VApN(%DI)d?eTrl_36hi3((B;cE8r!5o8EiNX>wISx>HUf-Pl@J!O^6 zn{v`}t!sF$@`&%>N93nn^8EV^{#6{n(s%wda&1UoMZ32A`-Z@B_@T-+5MBmA#Xb-s z>1wBiD4*pvWBQMiE>(R(gz}vvu><+Ja4SKETn(?X%5nU~kGBm`N4@TxR2&XVYau6e zk@61Zx1iWK7}{-9R6pn+tO4Y$J^4kl#Keaum)^$?z~2fuI@OmDXN@3*#o8){uYx z{P|!isj|(DPRgpTF{)~#*`Pg*tLq!c#VSflnzAW4M0(_&S#Bunf_97>-*2u!v#^yaK zlmXD|Bqcjf5e^Dsdh^OUS%~EChWHzTL8MX)V|VYhSsCD8dcA^4zq?pyDu)0~)~6qZ zjX{C*Tgf(IHmE3ch^mys5fp_*#*eIBS&(~ElrzvM_+j8;d%?426 z`E-WAVSL}(W`+#DF6zox;4_DYx|Zl*aQOG2_mMfUZX#k)me-eo0?bn%zG}cyV;?Cii75h0r!mRZ zz3wBS&}<@pEolQ4E~m-hqQ#W|T@Iw)oYscoK8kwX@rB zY!u-A>W{4h{~;-dq(kT)^q9eq{8;mZTE=d9kkBY5y%x5Rzm&5HkllS~@Ge+O9%ncgr zk4;Vec(b6Af8Na8oQ6HnP(w`(KF#r}swzzglBAneRUfT@kb|T{bSuad!942xd3TSp zTQvjt@q=4mzrJ$qS%N=Cb7E%zJNSi^Rk9C&soPke)=%N&K781yEsHeF zMf)kBLxe<%{yl#n&3k)FcKIBkJCdM$rYNRkv;j8ikPNH$1ez`kRGh~ONN+%toRw83 zk|>bhxqEjgKtuJ;qvyS`!pA+kZF~>n>mb^#tIIfbDi=8q0AH9}SbXGXVmA?xax3cr zbrGM4(dHYHGV$u!9%(OMPJIX&@TtgoZtema*U6KkqoY4PwnHhZLlr#Gd{sznb1hU; z^E|2*+nkDx^jzvDuM_$i-YDjNZ6W$2yTKtE!Ei?SZ`dj>F>>d)6K=a1B`tk!~ z{bY+b1qIJ=uB@IB7dPyFvj=U_aHBfYc?aZpdi{-8%D^uFQ>X1_LaET+&}xA=>)|iV zFaRK6vDj(!_h|EOP#N04D$y}ARyYj07HA<7sIDnR=JQZ2PCSI2k-TB>>YQC-delhA z_5oUs{Is;Zq9UQ=$8-KOc+oiAS>}1;`t?D8&C}r>eERg7#<_ux+?1s?FF&=AJzHS=Ym&8bwE)psodeai(3j3m4!3ne&?r{9r8;NIrv(^ig%aK6rD=N~TJtIvamnZgAy#jPi z2!*l~g|mwbe7KIdx}sIbmeBgF)x}Cx7_hO={PE*)skZ`dUvIvB+gsGRzBb2)#qNVT z6W@(F*6llX&=BEdse2%!=QVo(KgNY=0z=t6?OpGRde`?7YE2v>Widd&KEr=ETqmW< z8G_4Jo}QiM-k!&rQ!HkdTnBBaQ9)oBO1$wYEkHDu~T~;Lbk}o4DhS-yUV1MZRB-64?SF zdx9NN1VUC!djgdZ=i*k(1)9;ZV+Xeo_)DzMcEWP)FHzcUlc9QdfIgx|g>yeF!C4c^ zT3>4KU=xj;ozT_m>CIO-lpk=&$V^t=&dyfg;^M-{wQ`-Bnz|6RqlCJ;`uPM!=x19k zwY8@kR>%nD*Db9wdwn+(ST|<$G36^?D)Yq$bu+Pd8lfgDW3A&DjD<6IhBKW%_x&b$ zUy@w~Ia0|YI4&dHS1e$7|AB^sp;GV}RoOEMF;p#1cESvH+Yp`F33YLIcPU;vBHHy5 z0#c5(cnrmYrnJvWdjBK-Q>3H&UZI?B4u%xRDBT}d(I}LcUr{$r-t1# zTW#&k_Ho=}^~=}nZxh)`Yelh(eTO4QSac2%Z2TCvR;|l7Q(oTAFCRpM)Di?$V6S-T z($>l-1iAQM>Va1PS}~5jCw2df{H(4ozD<4$*H?ae|M(8;*L}xqiXIx$Pj$NTec3~p zxv8qHy*?CgOR{-G>f$pSs*fv8mR?zS@^g$XS5f{XJw8iV`iN5nn@~(pqU4wl9lEZf z(r{ALV;-0Kixlt_R99C!y8eIW#uyg`ot)kG?I8)7+_o(T# zMi#aQDmge<;u6#@1XzjXlt%2L=OB$)8Zr$^`#AQ=ybr-=-1_E6O zjrH9Jcfg$m82}^~ov%+~826TS7t_|6`?vrRGMzgH?04UOk1h|5%^xrEz^_9MtVaSN zio`654Q>|C=(_dI&v6fO0|J4&xcvM5?Vu1QP9P4JXMZBHEH~a$^eJ+LppLZ?iW4v6 zJbLt|ot*(9h*=^K=Lbeoh81mNOWqVAG14m%!kdNZF#NpNh~E{=BuUo^Hs#RkUpnadqbn- zU+PPk%3VE*AkG(W*PzY9EqrWkCDdhlgL@eXW2XUhI1~h<;{^)f)T2#dg+h8{@hO5) zE)d2*552{GCe73xc0EUj-^5E*J)YAiZ3^sV@7UvhZp z0Xo)Q$>iJ&IYO5$ygt^}z%nk3q?~}9f{qUXvqO!*9mf^{zjrcv5r-CIO^83CI^7;% z2+shfOmG;2L*VP#dDM3H+OiYzhpDNir0Fdz zd%MZEq?~H8WEQvo*&(^u+uI9MLxEPe|F+Q2Lmj9AvvP9Ew2vcZhu|kNEWV4tdDm+^ zTL_uviII_ofPg~AX;*()052%tc|2W5&j-7otK#2_QO;y#b!BDg1k%*!L1utq_V@^* zt@G+v86{jxP}D$*qM2)i?1e{bYg`oUP$#UeVx^dZ4qK>x1);kDR+{Cn!0^Kt2+syU z{JU;H&^}+hQ=Xb~DhpX+kYU=*$VvO?>nAE_FfcI@DbO0DyzB5V4d~mNnl`HGI-v>0qRVcuh_rqG9V78lcQxxfQ`Nw%>;vcs=OEsE z9M4EgM4M=2F+Dn(#K~Q}iLM(A?m>!3j+NEk3go#sdX$l|FM6cVlKL0BipqbDu@z)^ z$x@+VANdQl!UjIn-XVR^5ag&nc=T$Vz!?z{b)IN`$^nU*>bp;b;s+FzUZsZFD#JiK2|fXxwhPF#cV;MZIfCLfUVFVwK6p z^Z@D-VU?klBrCqT#6vo#Y+2DHF9%Jf?EfzpP>%WzoB{X zsr}#f&2I;@`1gM!HMHd-h@SZSHA8djf4=hzructq$R7rnYBB}$vEeT=P*&M71&6p2 zmXA#}3;aj$Dh1AbX_b_e-57lS85zOgC)TdJ5J~O%f4BU{$fT}8gqxuXh(w*uZUR9R zigV}EZmMA8|NVc08;1ij21(DwZu;Ubfqzfx|8)rPzb}KGzFnd4^!p$*KrBL~yg z*byR;96d&6=H~AfNt|QhLezgB)o;gpZ`JKi*!E-7)A)qzJ2dWvInabJ85Hy8qZ_*qu@O%?Mi-xdGumrXRpyRxSQ~atM)3ZZby*WrXV}IU>6@5?*{XGkp3R%OlU%(WI)4&#bNNMtTDGiAEVo zNrtc_QI_6Or$^Dzs@D^!Sx%iek^bBqcCek~wNq2!s8&&lyEd)SImd)X_5FK!topW)JxG=<)CwToD@8=;YC=fM0Zddse;#_ePPbn^l@o4? zs~XX9r&7!@RLsi41y}KEBhZS{@NE*4un{3~@SjFStph_d2O2G96*k=M*_{AYUu>o% z0<0|pU*Gxj5bFLLW?&N6=V7n~_|unK$!eJ}kn3Sf1RE3v_N=~J0~5#Z^`+j7 z%uMe;qh~}}HZdeg=oUB1{|?U^k)C*`b5D^_wwk_{mcvY+c(z&*05<{bzcSL*pl{9z z4vv57#QXyyuZk*H+PN?3Th|9wb)@P%>w& zAp>&e1}=FtzgNAD+ZWwz1Xlk29gM|xoFl~E>Adotm4(Gf^P|b#`}Koeds!l4o<6mg ziT`&v-f=9uY$tT(dok7Q3A*3e0R<8Z6BEQpjA!58fAD~TmUiLS!>d5W^p2YSn*rM8 zbn6HB!MSL;K=QS_7{V9S@q29_a>lUu(#qD%{b?T}>9FCoa`L84ZUN-z?(x7EuRb3~d=Pm;`6)5X2Se&m>D!W$j2B~Th0XI0@%PsE==v=7 z_W0zMlt6rn=W)Z#Y_o4iFThq^yNuP#EpJpZLs*Nt;g452XhArVkJGFyxiepIlSVBA zh5w$k-;R&o`w39Hl5$ONw)yz_vJ#)aecLtYfX@GKqeR6lY+i(d#>R#j)1j7(eIWkZ z6dehaebDu0A%A1Tr>y5fb3y0i;mf~~O$IqNX{{0!lbGK*39dk83a01GqQ$-ac5H#< zTMSVmRfnFe2?uqGh}hr;Gu^yjw1HnoMn=kt|4u`3b}+{_nLn90+a+}_{74{uP)TYw zW?_&yC011_pe+^id<}_%rQnbBrykPTZPq<&r#_Sa8~n5AEM231*KL^6S@cFdz*V+WYq)`*{XoLiMmaXqBoyFCifsF9)60z^pyf_*foT zrRekdM1*-Bc4I(I`m*UQf_UlQ_xx=|jvx&G{d!l-_CMeK|Ct#7@6F=>!#(fs z3f{bN$cz7X^<%MoTW9m`02tX7xcus^J_4Tg?Lu2G7`_Sjq;;_-SCo|GP-uooA3M1& zVw7A$qJ$L3UdZ|%#l)b+3jA7N(R_(`k0R;q+qbAKV?Rs(ePqAj9-LDn3qc@pTg7;a zvSh2dPIo#QUlpBA0A&6FN0DvsYxlXDuJ;i5(&@Qje1;1%gpMbpT>`(xojzJpvJG7) zO6`X~O#U6#sdNHc?O*R*UZc--H9dAn6olCMG8OkrYl#>nj@) zp2N&6)y}+Yr%!i!PXB0q;o5Svh0qj#ikY$N%9C@s#>dM;BzogLA9iu{Dy;rwjOp_W z3p+(GZ~M`Son}loQ%~L7b9!$5lv_5%t(|>@#T7B1HS;fT9e;e`9Tpotsl$t65h1!@ zvYtIFH!}%8OUrVw#2QuA zE0nDSLY(|T3Vbw>&z1ijvVsG#)G?TmRj1Xjo{{*^$>&MgJMe{k@j!+wpqUS zrPI`K!O`HRywc_hMEI3bny?D}@L?HlBL;>s0)b;M zs^iThCC>M=UqklQ$X%gB(LXelhTHLGy2SdSD7n+|3c|YD($W~-|Mu`+SSW;73E9^w z4h{l|eEjs3%*>P8MdkY_mdWs777Js}7}VhfRvT&ZM9o{e?J1?uBfR^A@_{%4q1|@RG{nGs67&2 zXCmk8n}~m3i9Z@8r^~AjPRETz?;p+03ikj+T|hIA{ngj&kWFJI$$ziq`}f(!PTP$u z64WFi3yw`~(Vf+6WU;j57ts+FA;u?C7ARwT7`4!3A=4AUd)TcXOTI_EgQ>uI!iChk zG!%gZLV)3eN(0mp7!&2R$45th8FUCS7e&tX9NfS*uzw1G=tm$m24hIAJ*YN6cn7DoU9Ric@0yfh_J95xgAcz z2x!Fa7hCs*KLqsB94AjENFKH*yhiYQwa>-m8S0&NOtZ-eh&>sLlsW5IqVrQtRTW7O zgLB)!$mOK$!kFXlNl@ZFC9{p~FcCDTA2X?XIXN$1s&ZeC5L@I3u7V02cjtZk_5u9P zs}8H4IOdlrDMzGJ*w-lH8xA2C>bv#&`g*0oea>gf8C1b#g@u|N4={s)c@aj*Q>U6p z`$^zG58Wnm@$kUu2?LSVr^kzg?DD5xooJ8G$XW+8Br@>i+r|rWBH-LR44@b#zaO}wKn4rgxM31LGRSZS-Ob7Wt)~OEuW=64?4rx)gPKkG0fc$e>fx)PRQkXF|wL(41+n~2)*aLo1`r5=*W@6-ghRT>;HZA<=R~liyZrR z-L5nU+DvIaMDTm|jN_*bh88L+Tf>9DJXv{feU=QM+Gg{^>1{KWJ31K{8Ic-TKS)W3 zd`K`j+{zFJjyLV{qk^JwJ0`TyhpBe`r4>AUxG#oRw?Knu=gyFdKdrXtN(&7tiSLVH zN$JiuRFuC5C=fb>(>D}pr>Y4As$dlj4N2=o(21a>!w-Uj{$P-`L-^2^f1g2$U*i2f zqGWJJcZs}r`Ft#WI$l-sL@!~&&!=mRPVFSpj%CpJ+R#0(AjV-NCCq5MZDcU?8?74&Vtm3}l34NBu=K|X>WHkJE z9?YtzqUK`1{zu_|=%27yOdDw%U0wok8fC+jqv@^(}Ni+EPrHvitnhm(}&$^ zqIct;SxCNbyF32|9mZ>nln>Jt69nmxO*^|{^->ii1DooPPG?;2%gY!Z$z9je6TeMF zE{(aBRY_@g0O^7%_UqO)0{2n29`A1M2*)b~z&pQ}r{w5rRSUe*7fvW4|o zPh8dE+r#!MXY+fTJ(Gm}&t>e;%muY11GQ4`LIozuf`he{%)8zV$=9jM-xmfw*1sN4 zoOlu)J=J#c+M_y?2eKSF?ILH=d)BM+8-1=Gj$@x(!lrMko3(fG-Lx=V#NVwE#LgQ7 zZ5UmihBf6SUEZShaWVotEZ_5Y&&}=bvWaOjN8Z`KP5*Mtq;GaDLr?oyjb+z1q{TQ+ zb&ZBGvLXi%ACMi?J^(A&ri4sPbm0$8`C}=!uiJ1DL|Le-Wc6}t5DKEBd^pmk;}zE# z=jitF?h;2Cs5Es)38c@)JMT1tj!62`*|$H;^2-<6;(`10($ZpxZ!pY1Pl|_jUHLs& zu{Ici{!DFR!M2~1X$L9X<57(Mr~3MoCUd#ePXn{^^7pQ!3hWKp|FZ9A^=^2rVIII` zo+h~ENEpVKTh6^pB@zl zB+P1AZg(UPD`b-YzVI+EPHaFp7KzK8EuDHhP)CUU89A7%@vW;%Ht_kI-rCQfkq6Qq zb2=_d^_^1;@KqVlQuJw#}rBgN+ zi+uZL-6kjB=&z5_3DJFlsQR__QCe5Sp0_JXWPTUe?w8hjKO;Or_Fa1V4gvnhLe<~J_l3@YuGw(f+r zibc#LwqdBad#bK(C*d7FXyx9CfWMrL&sGbqAN=w9rj@!nQv0N7oV>iOG45q&50O7M zzHmvh@cQ)wdO4nLS(FT6R0J6Kwi56t5fVL3y}fj_NzybpNZLF@A3y#AKn&Q zHG5s>NNrJo5@$ze=jlQd0|UQWS#M9fbFizk@87lJRmr?G#rW&bEo!QsCVT>{&&u#b z1G1W=M9*uI+kxv%RsSyX!^yazAlS#r!2!{IT_eNe@m1!6dn>HcPDs z_YBRUM0uk^Pr03RgI$Qg(YV>UakkLJ+S;l8Wkgyu?x`rpZdiusNfcYP%LE=L&?XNf z97AQBf2D!0?oD0Y$%3IQwQ&Fl)1n2>wh5hW3+9848vmq=6d0s+Tx|o(I7VeYwc`uYQq|8@ zX}4ENVza2AaI~pPglT!&XQ@}^%9@XF@ef!JmzUij$xX%?p@G+=pm1O|3b5A8SK@CE zxS^g@R(^nfhne}jlezD;CZ-adDJNlMOryj~PDX09im|b`m6fAj&&2YwByUV-Z*ON? zo7{)ZZKOnvf&wStMPg1&xU7zhyi!a@t|U2O|Ni|*(%3ued*(5iw`W~lT_a_mp~u^G zdkf*t9VIMEN+7|*K@m`{@3*Tpd7!~_h?yA`VfY=TPV3hj8$I9%*4D}vbvF0*YF~G5 zwJtx{2rcvQ-~mXmAISbfz*<^b5G0!1QNoD+?0>IGAVAEW(XzejS(RZ$ouFQs$Kd+X zruf3Mrcoy{0t)j(lxE7x$}+*>@@ZMRrB5pj!o$K~h=AO(RyG@*)K?{aP0fp+&-=4s zTN@Xr37^=&EV7x8RCQFI)|Dx%;hB@J%eIKiMg+I$MzwSwmB ziVBS5oc#78f%2$fsA&3E+_Ocfg#BKA#7i$ZgJ&h?GqN74g8>BS;ZKQWc_o|f!dx#!5M z%htipr~LBrTD{h#Pw_~iH@K-u9~H3#)>F2+Ha1dztXSe;mB8i}P^xV9LPSWbx3AA_ zYoi;WD(8tzjB%~4#sv~|ax|Ik_<$>{IwsrNc4}X&2ks5yf`;xLLsl9-L`dfR2oI;! z&eBPp?YUprVRbx41%cctKa53^@*y5i*E%C8NUYRMn!a!OwtB~j$eA~pMXt@5wUyK7 z9YShMXhRfmQ0xtqcXM-Vczjm)_Aeam@PP2^y%*!-Lrx_YB_$=R5EWpG-zHqJ@&)u6 zd3*aB$}FP8(9!5wO2de4_q+mfDE+G_MZb4;uD70_DSR(Xm|?ed)3v=Lhf)sXh}5ji;;ju zUVLt${m-H~&1hv|2??Tmh%=_xZNXHHv%yU0pQm)fpPtW;A2s$CJJ&`Z+f70cO4t~Q z^FgQNIVKVJk57GleJwScM;lMVR5XU}+qk#|caKsa^rA^gM@R@fx>ApxJQ;E-Ui_De z^MOo`gn%a!d0CQo|8kv7$hYaHV2}5O-07aC8u0MQpHyW8GzhM$uY%jg;5?)*0Gjky9?VSZ#EztrsH988O+Edr7%cRNnPPY8f=P#Hi7<5Ga<> zJeSd9ErsIgnCkna0&KmU5^}mg6_t!f58^bQ#f)DuWCO-GMIZe6{6i>X+>i)NM z@^iv(I9CYH{jvW6 zcDUI)0CEIb3*mpw$t*vAt^g(vls{BX8R(Gah#xaE^A?i&<=CUwHp?;S%2x8nesz=T z$E4b1-Z0W|^E8zdeTj%K=xELuYP93PE>iQjo}MnGaoBNc$sa=F>cK1>MAbUu-cL(2 zMOC2+2b4C9%*>CKUjPLV(keBnd4=$l=H@%88qaiI351)8BynYV9W4VviqRfR(&u>`a0hOzdePPYz4Q z*O=h#xRetKD>I-q46%38EU{?N(k8x5jvAObq4$KAISL8wFc)>(h@|j?Zd(|Q)zvW& zIlND1wJOTQ)RdMC`P%B4c-nv_sPB_{kes~!dH64DNa}C*2qia+v`$Ee)%;ml`)SvS@`};sZo)i=q@-;$i?Xqi z5O8Yh=_NWyEdoTS{i1|f$!E1X?ijl;viZ2^aWG{9dV$&Qa99meKJZ~A#u|Yqf$HT^ z^`MCG_lnKsB+*0Y?ZLI+gFZEqZ02^E~HDZ z|Ji%|xN~(2%43?F)uWZAq@}%`cf^*JZN$fS%?@=8zODE-sVYi$N8+f@_WBRgS}Ig} zBg^0CmCmbR@-rzd$Vd2mEwtO_Uk!i1g{>{1r_Jt`evK@h!CP^>*Z5+;8t{#sXPIV| z55u40A8onuLiarGJRrCMGPTfpY;4ZVV6ugGzcAlCJxsv_CYWE9<^1JhYZIBfCtUt@ zb&ad?du=Nvqum`x5V@a=i_5r+ZB|x3NI^iNc6R;3J1d9h(7R=`zFbk-hgADAtB%7I zfmVgRGXKW?(dgDXv6!;?X8<{epXTv0E2RyJL7SR@OY7IdPW0+=G#AyG%_r*@$YJUB zC)FXaKJcIneGZ?)plXGTtU_H#_;*qQ8gd7#cRMh_9S=bgFE4MZR$fujYSx)2XFWK} z{#A$@=B|ui*|5fP@xNSv*6Km$7bPW$U%t3=#-JFq*s?v%fG?_Pl#~Dj3O6VZ0hzr4 z*UB13pl78E`OFnMzqVmXfj>`ltruvs(!dx;tXVY^GAwZ!OgZYRqa#eHoW4W67Rbxp z@Ij@kUO}CDx{!(0zFW)f0p`{lZC-=1|&rM8X-%y_%G zT~n;N$r+Q7lq3VYDP-O8^2qlWN%9&S+_=tnOJAP{RXlST8-W0k$$_W{eNLQ5vAspH z$oLHx)ed*(-@4*B_hdG*6kX$jQGC2wz`v}ltVtwb5?o4tWMu3Ll$X0ohSnjGB$SB|l+DfWsHrg#?pYkH ze%sji#B^sVU{vS zBrMcI*VM{bjXqEJdIh$ zt00I64j(?Op0ed>VKKY>>4iM;N!a_}lMvoAR_Z$E*%g3zK)TZP&wh;~PVQ37LqF>3 z1dPXpPOT1KRFlpC9OLd@-lP7*f*nN~LdTECDzN(=sja^)_9sB--Y{EXFHx?+_9L*< zR6xzJ+<<|W7W<;JlM}E^yZ0Q3|Ij|V2e-Mk^?t&=>cM*_TWtsg?+TRO0Vw?xDBOr~ zXQ^XIOr3*@n(WQ-s-<ja z2oSKwGAhs~uASXR08Msq{fix##*2l2J3q8_bac0-?)AYJHNyFcIZEWv zTCj&aki>oyAPC8u5F@9TG=C~@{m2F8C~AU{0He5g@r`nn4HFb0f;(!*4vaJ{U7RV> z=f|7-H6|yHAE(`_#p#06m_P{FMjI_WzpO5rq!j}!KM3_^bU+~qV#(?i+dZ!n)iR6( zXg=gv+1L<^OC25er11ZmTSc)60;D0r>&qMVpLcQ{qQJOwPIf1Ow7Aw)>MynQ>iUw$ zgMcfQ-)a5`ACBl!!N+(veZp;FbiZSOyN3tJ3NLAUt4Ut=m7liw`VJzG$t17I+*z?E zHpxaAGC*v>EB~BKT>h)!i>X(pZ$np&tm~Znm8+OhE?hWFc$SkBtMLXqD$w>D>%Wf5 zyUHN%fHOuht(APIeIj*bPFi~b5*Snde)I0L5n0>xhK@6>RfGQcXhOYNV5!3A^ScPZ zjj(poo;XcTN<+49*AC3xl9pcFz){85^nULkqQ%}LB$qPV@nL0f6SU{ty>zoLv(min zelq)-j*rRsP*8QbZSMeH8o0@_be_h?e>M{;=o!Z@4!LZ=4G|&~@MFgT0ubPvHa2QR z;^a_Z;BgdnGTzTIC=Tsm9|E+sZ?TaN%@qxJE?gQOHl?K{ zh6YJaGMb;f|+-xL^8NA{fw_KGH-nyp&-mo_ijhB zvZ7aWA~Pi{GLn{}COTU0B>}+K3>6Uo`>Tx-N*;QOUH)_Ub0}R92!9kG4^bHmX&u>D z?B<^}j4Zl`T)f$Y#wCqR>*GUGhOlpt$e!cW{*gOimVd3FhpRwh{(~gW_$#@Fz~LtE zl%l*{S6lnGM{gUxTS$Hk`0fI5qX>i#i-VJMzjWfrNL=~Wn*RN+HpoVfh)50HDP=!a z;8g7N>Rz`E=kh1Kv+%KZl$4ar&xbLD1#*R>GiYrj1=lW(<~93d4KA0p`Qtev7g%XV zM@HcCLja^uf_!}Dejz040h>llX@pWW#MH1X|80)9m$kQVnVl7&-7!gI!#{sUP$LY# zd-whlLp^VNY%H=$p^bhJA3wgb8@M*!76{f@wpV4e{V(0 z^pv|$RJjW_)Qj0}UvA~{!}nWp`S;J0v$ylz<$zu$H*ra z+<16$4O2XSsdMr3V`azs`ohePi=HwN)|w>sTle_;*wAAc{zZi$tj0(HeQU@SQLGus z%hU8X_NyNJX0hn!$Ie6zx9h;mkRz6|csPs&;xVi|Yd@qQ@D1HddnqWgzFQaDpQL|< znr&hUF;6UQVLGAl+j7J|B^^->!ZupxyVVj5qqUu~M-KX&pfe zIK?0bUH!}oa!j`vF0-bz=-;>@de`oxe-#%muWlB5#z`XYXOf4&Q-N>x!rlceGj~c+ zM2~N|%SK&Jt`#J)MEkc{^eSs*y@yE&6Cw7*;W>k1r;PV5#;)Wj|3xIrgZkfyJ;gi5 zcpuz+P__5qr!~oyHMA=|*iBA+qgKK}lBKo&au72Ywng_fQkxE@IXcVB3kAxP5LR5v zuDp4aB5~V~=G#=z?GjzWy}m8#lZD{hf8@+S`VLfOFF{DGi<*Evp+>+aQE>~E#*R#Y zeOf2NjRd-SdhlABnhf#c12wsQz(X&(F`#urJqd||LkSZew3k&5;Yw)X~UTUy>1M$XAKP;pWfc)7Z{{e`4{T zx@Bo%f+BTXQ2iEDCAi^Q#xAL=lM+0oZ=hSxzlxD@^+Hi;X_&$%uq)B;a$ZeN!o3xj zt{Uek_EUpPSV%|Qimhn5a}G|s9P}gsAry*lneq-3jagHW!xIGgZ=@#Rnb4p zMgLx}!u`n7ztquDPRet8rV?dYk+Y!dUxhOxz_@FPubD37MMZ_Z>(v{e>8!R)nW)d4 zIYayOt8RA3*g`?!6uQm~w>vZmq0bLrd|@cFnl!NSP>u5#IZ9K%nh71`GmtNnC*1q+ z;W2`sQUIMQX6a~gJ(6WbA`}&iwCl*%eV4_EcciW#5`R4Uc9Z|s4>Vb55j?zude@?) z_w6g(FIp|6nEB~Hg#?^0++q!V&K2sNvnCe$+<>oT*s;YT#)}&H@&R)nJFNBu$(Nut z_v_fg6ZI2=T@uGWtI-81F>8~0aqsX_&ed(+3j&*v94k#{wJYXZ+ zSQth-*Lh_pF{YsEL(PuM{FtBEo&5mFwia>Gzq-l`5@J{N@9E?PqObLZk$}TNXM4@8 z?_(+3-g0u$*pQt^!#;Z4MRtbteBJ1$PbP%QH`iGLZykW7q7BIqeRe4sQlPKv?vlBZ z5`2HoKv18Tm)GkmKu^(kq3a2ZtRhKvXnk~W`*3h7bI~IVmUyCGeb|+>eMMejyQ~<)@loa<11daXk-JIn ziZ4RMdX$+tLxbql3_0=Cdt)v$I5^u^)(BN1t8;1FTz?V-@ADFI*YlN7B7FS2gKR#> zFIhL>VI6_G`>>IjV_hR9^;EL@ZWtBug9>$zEnHFyM+MK!Kt*AG{-)u|UpXLwy~A?? z36!W{=G4YbQ&;D3bEE^R8ks+rD2Wmc!o_>wrkbydlK6S*(}sK|^?jg}w$ooOs9G8r zX~i|;v%&u*7$e?nhwr@(E8yzB`4}!)+wXD8f%l4ChKT zscc%SrSPlX>GBYs{=0huYE0m~5=x+>+=b+wKD*LVOAW-@5pN*Y0lB}&b{Z{=)*=7| zLxRtIeX~bjoCjrs+DSgXYj2J6E*y{}1-p{*ggO9^>(fYr66?{#E-wv>G z3}MrAMfUx^V9Xmv=DB%tv5B@%--)h&1j1I-&J*3FNK?oFEx`+86(eOv?{rCYA3f27 zPo!W?zMbWcMLi$B!RYQ=N+h7?9lBD_(*5_DV5h3{e?dTWU~^I-m@g?dyIh=TLCegisIjqw3=9l{35~L>VnWaDt*uX;Opuh2 zcn9{1)YqZm@d?Dq699tewKTqT4kjE+*X}0s z{Db_44Ey(=M{W%B-P^aZtX<}gg{lRt78${aarxUh>e`y)-z;1z21JE~-q{b>vG`MseMHck!xh#tHZ?IJeS0#X!)hnNqM#K9&BE^2 zK>lDMqo*h?E8{(RGEn^%FavI>6EOL;XPhGUgZLSP7H$aOW}4}ttT89yzb!2tM&)L} zVF9ETft@NZXXcK5)oQWny}h-W^69Pn|9{S?*{Q=xX%1z1jl}v4JBWE#un?Z8WgzF& zQS3=ysmv|{Fhe9HeI0R1)d(II3pM!_)Nf?|s z=pg+g5V~wI6;XxY-mEj;$$I?wDIqO@pc>b%VROCVF})N_ew&Lp`$Crk#$AK!XP#+k zlleJKm+78;z`;HVJZu>|r-`AHxmx3JgdO(Y5|?QCRJeh@0lpQaL^mQxa&hs?9CWq= zTm9jC;tlxFycH6rim-a&gz(RX>$_QOOob8xpk?nVnu{)WR;4A|M@Fg;XuxM*8)=J7 zeqIKk5AGlPF)h)BAVdStgqe_=iAh^mm-1B-F21Ld9(St7$6q##pec^X`70?gM2iNg zal+U~dJna&bz=*tq6LD%dHgt#5CTnh$5(UbturZ-|9fP~fB&7YnSPbq8cSNw+z-SfLhNuF;(--7Lqn`ZV#k;C%W*m?XW@UNNQya^~gWb0B| zYU-P3&s;lRok0@PIncD#|B&|o(fiwAk@@Bgy%M9rPsb5~^QW61dd2oO^HX~7%?3Z! zK(dOd4Vh8G?kIqPj0W*om`u}Jaa%u%jXk$|Rh#P(>=YD%5=hOIdOc9K22}=AQqywH z!IZ)eA_wW|4<3x;y;0s~A_%PNFyS66bVjz;)*n6B9vaHL=%nsXZaMIOXI<_HWG;CA zckS9$QX=8uQA#2UutHByBCg>a4Tw2;bE9Y5{?uE4SJuI|0>VFdN>45G^hx>)o}PXh zT<`QwfrPQJx8Fh3Ys|ZXQC!rwfvB!#&;jhFh^Xk0SbuvvK1WoeLJmPNTK+>yub7lH z1v>+*-39N3^>ZGBevGUg-a!c7LBbGrdqS%lI+sP)vgzq*q}kvUA08UIW%Cz>-t-h_ zcz7h)*pS=ZI^uN7u%ge&=D{asiy&%c%yqQmvby8>C_`GkAlzk|E*+*pMJntJ~yEX<;!GJJf# z8bFV*qa!KhC<{wzatrnU|MZ-EX7O~wy^F^LmA`l{ZwVzxF-KJo67Cr>GKhrP+uH6a zeKWb_?<;#x;nPc*HK4}|~q$(rS zKak03(C;L0#nO8F-~z{IMLUm76hz`3qsMQ<6|GE=g~4l~W&0k@vsMcNq!82LP2hjf zKCq3LKY)`s>Kzf8Bzsj$=zN+c0O}iD1lS)txfm2hR3H+fkEy^hSOC*tiwI1a%z)%z=M@$W8R2B^H6MyTGM*= zWMReQ=g-Bd&n_Y;qe_4m!UiXNNvNGOJIF}$>(`m1@o$w+XPeq*r< zs5b*ie2h#Ev;wH?13bEjL;|4=9WSGjyrxceM4JWs9%Fh%M<%#_4o9dzQVVOtYW8p4 z!`XQO%#Nk7o{0(iT9L~1OLc*nQ2F}W#Gu`NuVXPP=z{n{@qfbv4*C0}K)F>_;S}-< z4V`b#ytL-&%^bA?+Hh~+bA7j;Rs{eh;g{BV1xge>#MR%e_6gNYveY8fC9{Mips?)_ zrIMp#h|>P7_5x;cr{LgwYv_YyG;G4;Z&jcPQ=3v6GVKYnNWo5O;{4lVql?519VO5C zdiCTtOAV7y_WD&FdLD>cPiP9#TEBh&j^`JG#+jKTjN@?^(m{Wjm=2>xx@ceq;#qLb zIoa83uO!GEi+`$T4l6AbcVYY;9UUs+eIrf~CEOkG@^Eo+wF<-@ z4pGck4&n$KP7{>=`O?>qe;bYhVMP>!Oo1Cwgu8MAAIP&-1tCVt(mq3d{q~+7QUVtj z*N~H2;i~K1yP2&P*f??YE@JgM#h?nn8eh;`%pA^Qf7Cbuzks44Djp!JU~s&`LFZgt z2BTzGmn?4)T)fJQv41tSwSkf&PoVhD^uMr!E$FMjOvDpYPwLA`fEW+NHJKbF6QK9b ziOs`O0Udaknb7j0%cZHDtGsTLS+|9}^wBW8<2i9hUYmW} zKjK6}0M-H+xVDy9CihEe!Kknoj5EU1#c!#fOm2ph6A8o|cKfKOU=)Iq@!h)x1r;n8 z=H|NazCtB+s`)f-DzzPony4{O)j%HfjvTxW%#^#}oIx6-AT=NhUn$w2Hz){xtf0N4 z&wo%m1=YU2eJ3>V32KH~LY-p^iV82s8c)^;{9(wRo|qs4Au!*?B}%AfM*uyb+|@qp z*gioiUpe>|SIcp_39xfBpF`4s7j11QN-?K&O`r>1Bq>6HeQcyjB(s!8ZT2*`OciN{qcGc65kOBka!ua@z+rV&QEsm zbgq2J$+>A_f@yB^*KQf)Ys%w`)!^dhdkWF_$ddc*5)nw;Qc}?Dg)o(!gzp_4;5^`5 zo?G+Vd$76BlUqGSx&RpyP~?2NoTvfA33>((N8ACLhJEr4k{lwqd3g~AdwNtGipvN3 zByu#!2uRgn9#5Ac@nhwn+fyxoz>56tU)0CQNZp+^vbM9fgzi0HexV5eAimBPu4qZ^qZ3Y&mRAR=r^VnK8%hyzjrlJQ4JzkrgtAw!+2 zF4l>k}?PN0sSgn)S?#k&M;#g`QoYk(IZ2dcNPwRL$gs5i5D zYzb~F{NxW~wD;Yw#}O3RfCBqUlRV_X+|UxrePMbO*mAXR4d-1J7 zzgS~}PxX)w9g1V*<>`W|-{j;7CYUQP5HHP@9oXY=5(Pp)HFe!%&;CcC2oFWkztkLTux|e$8eGE6AG2E~|iy9j$_*jGTRTq7h0M>vrt$!pH0^##GpQ zGw&*9zToFXA>r?ahK4djdlwhpn0m~Kz^r*0l3K<@&zvD85VhhEOnvzxn81sQy^aq2 zADRj6G?uR(nMaX1@G5i|`Bw=is7a?F+ysuzUYpJ#(%9H!0FYJ%_v_7|W6AF}xaJ0k zfApCIEMiz~;B;oCfh8I(LBfg9IAGZfI`9;;WZ~6D{GlqNA_F^rV+8&tuI~0Qdgime zIY}f#+(xtXF}KwsF)4|ghX<}94K9OsW`_vBzQ#5LP(}`4zI+Ap0$@VJt4sQlcuVl_>3$Rx zyP`K5TQ}~yqlXWNhkrLWH%IVVOuf$a>ne2sV{k6eZKmXHS>nDyoJbm1s4-d-T{nNc zZWt+Xo!baM0JS69J=S*}7>q%&_I)jVDj?K22pFbh=yL!Vju>dCjvSF1Kv% z)@}lU+z)C~Us=Xwp$cZcICR$?qU0nHK= z$yBTFfEZJxEUQ_*_yDQ@gI*)N;%jS2UOAQGIp1n4RSq-(aviQv7)b88ydQ|=b1W{y z$4V3Ox%95j&u+II^;8Xz6fbppj_O7lcZJ_iB=>8qZ+-FkEBkK)GR2Dwoh%<>cb*d? zJYzj(qT=XzbGULY?0Tn+D-TDlG6TaG9T6%WVafrOG5BC<_l{{A=XXvh^zJJV?k#Roh4cdaZn_UM2E_eyIbK5fz8ROC%b8lPWvIXg`3dU!O; zPnE3nTvJ7gYV*U919KCHcUJh+x%Qr+p}&=t#!ePzy)L=C@ic{jjIggP2Yskt)h`HY zaMTP@NjenLgmAzH*6ywKzQ^J}zNbIiP!95j<{cS?pCSm-ILyL=km`tFjhOluaL>R{ zl9^TZ;rzm0eCWsN@;aw-UcEw!;_Fu>?pL^j5EPKb{(Z6zOCd7*4rL)w z3`Z>0!0~8hOzQ@3jPhVjceAkAb?!A{asuV65YfPyW+>Ctyc=Q8sWg$S!MaCKq(@5z z>5Hf+F!<3?CHfjQ&X~?AMa@TI7SCJ90a=pz1~-}a+WeTCn|u0{&!i^gxdjvgtTc>= z4(Vo}kxxZ0FnksGQm@)WQUy6a&e|sPBsHb9Rz@n3+s-s(n%tMs7us@gbrT0?TW6ay=R}_JU=Cm8Qgi@1r-cdX4l@4X#IU)Z2)_p1;3j zKS^A}f9#3*tQ~+&cT*dZ^rSj#UziG?AyfR zf4O-V7`uQ~BFTJgFR3pf&)FtV?S>=f<AAzY=T_ZX!m-%aCs*uR6MHJTFRU|JCC&a{5K%WY;6akvQUAxya|1QH;d*y~#(+o8+zwdhKopbO^ zO4gGC5*q^M(EJ?!1j7|R~Hw-X!BnLaqG_)SJ;Q2mzdHs6cz(> zp?c=_Vy299X&=DHxw#O`vIHZMBx;s^pN&;b0wJ!U_pPzEO1%L)8}@#Ttf+z#^Vw?b ze9AlW`*-g3QfVPARmNj(Qcou*vk@V5EV30g^2-F8kKW)+8LHoY{ThlE1E3p-??2D$ zLsAKxw#eYA4tH<E{#LT&X4mP0&Y++m2==y_Sy4EqK@G{yo^$W6g*EVH?| z|5Fbl&Cf#z2FD!^>8re02WD18MMbx^Rw`h_ggg7vgo^|L1U|ak@=8k=mO5{!A}@Eb z^%Umh&k5nZ({^@t|Hji+GSh!TT_*FdHA}GGr=}A)Du7?TdJPdkXR~g)4;kZ9SXo8+9Ovu=2NG$k)<0_MTRKLyL zpXEb&_@Y204Rvg`Mj4V2HvZnNKx-I+6WoSEZsCR+EGz*9`1EXPaKREZ!bqJ$6#MY- zen1KU2vt=VkiG^E+scX?|7A#SYL$T7{O>$Km;q!%szD%=X1epkf{z_MdUOE_$bbR% zih+UF)ZUNl!*FOqyu{ANwud0gscq;neY;{{WiV(4(mm4vFN|N=x^E1Kk$F)vTMrc2 z&#wK>FD@>=;q8oug@P2%cQFo|dWCjguw5+Qxvmg^85#BNL_V2XV&DK#C?rEmp{Qqz zPDD5&=hk;1)*XEI;4f8*K&R^aa09y7*t}0oHRPhtNN)nrJsA5~_egJxKV-zk0VgPauQd{YXa^Z&t*z1F;c5jE??91zdG$fu^(hd|fn&Q!tDqx= zJ?C1!5O8c5A7JVk9867W+z}{$?W22+E^_J_E$r+bDZc>RhY1eHQ~)XP)d;0_t2D@J zpm{=cB>tblAoI|NVjS{->H*It5n^p_(U>(^9aG$rU2SN7>!Q#Ut$)xH*WW`faPa!rYSfBC!aZb(& z7u&OE&#I`@*F&c4%9I2yEVyulm9_8?DFH~SbMUqoZoSruTV80BOU^kZ$M z^(=VO@Jw4iRm18D8R6H`&Ryqo>@FEuI;wd-3eYIA(px-{u}b*;qAu)R+N-2RdFHdy z7u3=pJmDK?T_}0nyhlD$Eu4-oDW=lARf7!P<=GRE7lA-}%NwC|daX(dv_QWX|t59w~?IkM7 zhmfrNZW|yBybSA~LrkSp?pj#LvPVmAt!i5pn7gN;y24>l`+9>CNDD0|D+ z<~BCEkyQtvhbrjov134$DdQTJAbtLG=ZN1k0xKp3^Za5sc|3&xHZvPMBXZfQcu;W} zU>E}-gG~?teCb-K^i<~Xyo$HO;LRTt-4Ipcir5hm)!NHw_{sd{$mg1xsBp^dxv1^9 zt{}tr78Ag>Bu(}4o7;-?mbs-Pr~&(5u^}kb(Xp0{R*PFLPm$$*#Q6K1&sGaR7(hhy z%%zjU<_*bfB`AFYAvX33L{^u5WgjFaibzNxw+OxPI2JEGm7*d%XgC02_Y8_9U0fEM z4&WCMlaPQs#ph2Ktx4%7wqpGcHi}M87hKPTvyOM?pD48Vi7G-4X=k9kCLELlTgxJj zck+NdVl&#-UWj5OeIUh{ukf0L?=yj|CH-^N3`^Jz_Bh3aX z7Gwl_&DE$7?jgZ+W_v5;`SXYQw=UgvG1wb_T1aT)#`ehJ| z|9xGS$Q3b8Y zKsZT^q|qwl=hF93oQ#wI;=p8cEtZ7vwnu7rxy9D@pT4_B1|0=l8(z(e{W=-Srzdp_ z%r39=JK8g<5qA5r%|7&qiCceYQ2xHbt6ueQ+`4k==lHIBwm*N{6|cOqx@^r6(epCy zWTLe5*Y)9exw?z@qRp%~x8!br})C+lXC*p$3=fhPw ze&6R(IPIL~W^hNfv}Wu?%hu>1VnjSllq-*xByQsLjr(-PqdtI6f#b{u? zAX^JxgOTx7mD~FFp3S!%yTY$*JIy#gc{emrDpvlziQzki&(=262PujKqhIY))sp$C zU1nru;N&S5*JP46JJH>$EwqoEEwf>zwBm+q9lw^PWnPEXMb#vD@FSV(Z(Ufl>z+4P z2q-Tuo9VK6TcbG`{o7t&b0#LCzOMe!(=(62ttqyVik_ZEq!I9w`@MYi%5|yZ z)P;1UQ|6<*Kv`4A(y}$zdx=F;Q`4!q4AyuDF}waUZ}_In548XWGW5Ew3g%9Je12pv zQMhUUZeWIb>qo(d4@mg17VepxeC6k7N}l@ueF*$;94deN*4Kd0)5=Fj|HCuygH*t! z$&QAq%~6~t-rMWj_j1@sTqR^l36(El1K)KHk{+anq14&jS=HJ)OfM%v#%C~D@{Cv{ zM(f0kiy7|bi%~SMP}Cyr^;j>*xcoA)YZ{OwnYCfE^!2we*M0joYfp1YA;6IDN|C`| z{5Vz7KXdd&wYA&d>)F25hl)ZsP$*&YEOViJs*(IzAmQNpiw)jX(Hv!9;Ebt9*#F#W z)dCPJ#u8|d5mwBkw@5> z&DTd0#>O{>KkgmS0%Z%7?hL)Cl$ZLQQ~u}>@y;FLMf99|B z5MSIe4h}WGZKo^qU%yhAQ|J<wNS(dz=wJS%n!kAMra%K(Qzz{(f zLRtM5Fib!|>5&hJw?_VzqS9oy&GI?Adjz@U($;6%4H;&PT%polIaF-F=XNz-N4fox z!d|a^mC0}E6sS>;#1`xz^r9L_v3`A$o?mVaQ=TB|Ogwz>0XQ6EEk zjIEwv$Td&T^rEctbbg*Q^0}AkFTekAyPH;Cdb`u`c7!o5a9Q#*!op;CJ>dcsPHJ-h z$aehr^k`G*neot2yFUGmLWEVX87DU7peB=xUgS(d{CS_Hr6uxKh=f#xwzpR9(xS|r z>*PsAzBp_v#{%M2EUI7VBFYloEBI&cmYrlWQ56y6wN`pvTN_r=_1ivFgnM~=kc*{+ ze!QD@-w|c7H7dFtLW6+&YR8{O!N~3Ai&N#IM>(G>0fJ;;#(sNb&0dhO(LX7!Lg>S~ z`5swU*LZn0Xl4C*7<;Bgf~tW+*O&;N)>wA`Smnrkv7KJ=Sb*RH105ab>#KR@L!aT= zJHm!w{kjUZDgT4yApgLFNP9|YLH0o7KSiZWm*U_J z(Az^$q4Tcr`R0-8@Puj?@(B|@ZU|6@)X)(*Bgce8{gmb-vMw%-2h$vSrk2RAKn>v? z`kYy7!DV~v;}KD57KRMN0;}oyk!%c{_I)Lq8V*m2^S2zFio<0d zmm{yXWBGCT2b=Oka=0d${=K5*@ z7Y_1SPrvmZc6v^XaG;|lYwhV_viUPH0T#kWL=uVA@r1>dfm=?R4rfGE=!7rEaE#m; z=!=VZUiZrn(V3_SDln;;oOL)8IZWP4%~!D~3&j>IaEA>KpTZ^g&4c^i56lEjOA=hI z{yV^s$cxO3@$6$Fi5Z`&J0>P#_zc8UX~-f?8za9{N~g4pcwhS*)175o*C*{OyV^8_ zFfwnSd)-sQVnmXvQKNE(+EY++WNWW`jY)mzfo$-GunnTQeAD{|9RE^o-1)C(2QjB( z@Zq8%pPZWFeOxYk51csUxjq`(TU*|_olt3=Ieh)CX3meFrDs3=+T8ay`TA*34iznW z+rr+jUoZGY@G=BtWZ4_UZhwie1~k^5*h4{BM>I`&8G5H~?xo!$<8h4^#Cg9r=U+d!d!x=eK!(^hG7Ln1(4z9d51KqiA^JS!zK=ekZMz?QJhn z?R&u)mZSTI8I@9NwRb1f#{_L`qEQ1VO}mRjl=5Qb#UDWjloSHI0fr!eJ|Y6C_f&qY zu2S9tqDMF%zTgT4rBP++O^(R3CY__JdYPmIsgtY-ICc3YX8k3+TlgXbG4KD|c~@8d@^$w2o98WN>#)Ue-aN?AZ}jE3RRM6m!h(cN?}6&w-z2Upz{REV5U9HQ z@RxlLIdonwEJ*&lZmvx++6(e5+tN|0>Z?fv_h|?T;E< ziGrq&b+h+MA4hduhGoJZ2n_=?E?nqw@GIsAXomDz-%3=VxqHm02Luyc3ySza2A}vI z8r`|lW18QMiOQGYxauISs3~#%GYSxi%Dd=j@hADH5Z;fy1c@LAv@PK?;ikWkm~r@U zc|V^Xv23*L{K~mHbK?K%V*G=yjt=ykoM=p=lfFT-f4}5v@wec?ch{JfimTQifWB$crP|dmcUan@Lt8cPzdu zn1j&`htP^Dno|s65T`S%KEZLki+CKLx3bc6EkfoCnlShE3z-;IK8+I#?-fO-`;w9jTw}F+1UX^y}C$fX|+A|uxnqMx&jX=rknV~J}Zh36b^iDIm`zPXm;O8nfu2#ysY6kY_;X}v^Lyft_*0$J)?Kxx)OkfNEE#vpY zuDeH_$z7}h&B_>N!o$L91s=iRilaNI;&)wiHKGDw3)TOy@iwm&w88v>;2uTjVO=JKlKGw&6o?nS8q-Hz0epgF$RFqen*9BH2xzz?QY68wq>ZM& z$5o%62hfPUc6ks~YrrtF_exjio~K6%!w4FFW^g%OC~ zeG-n367FSEau5jNk@Yc|!8Pch`uFNpZg`G|yE{q|ZkGhB#Jp>MdiKEn{inVDy+&s} zfK;fTqLqI;P?DYSh9(ZySG5#r=PEx%#PA>+hBM|`&g0$FbLf}u?PO7>La1K-6e_5xzxzOU%f?&KF+%Q`D`qke*x)s60jaYPK)gtZ}>N}Xo9=&0S zeE9G=e!7<(lW{k^JBH_=c0Zp%tPBaF8o}ZY4WE^;UVw(BWeEJNRx|1puU@{4KVyyI zb_pdEZ?5KnJb+v$=;^$1{I8fkNAHW&W!RO0em$Ki}8 zPs+Nw!~$sYle%ic#{76bv4mXv{@yREuc2*lGRAOe~U2s<|rvOvGqz z;jcRi zO$8Kk^b3vAMklj55k(^p%*)M98`E0Z+Gx~Xibz;*evh|Sn3<$Z~7awx$+jY*~{?fH;d9}l6 zM$660(#?_w$bR3LSm*KDZ0ZMfyrnp{ykp1mb8}Zlo2K~U!uE(k-^@{uw1I!_rjCxO zC@CX`ZHgy1`}qx%$*p?!_ZBt)DEV#`ap6E)m&L1>TrBfDCjR~{an97sjgrSbUs6yo zf!^W65kG81PM>STON9&yM@QPzeLIOYppc2GKb3M^noP%|4*Xp6sw;8NRO965<_1Ig zzSp*gAQ(XNO=1v1WFacNG;YNXG(Pc57E0-W$a4Dw*0|yx8IIO>LR@<|S8L z{ck3!-Wh7(nYUfu-!d~RF=*B=wAC31 zdGO;>SeMQ6gNsw>mElu8%6{0v{j2qi_C+nW!ILjYA94r=NIk8b?%@k~aDneZsN24r zP21~t$C}Phn0d=+nodsqy({{D*|M5LimGAwSTo`-?I*Oql11cfo=V9CxPK(y5BY8ps%GbVoNJZBT2+#hxv1fx-9bGTgv z1E|H=3pu(|{>|I0RbNApMi*VEjA=r`^ovbc4U7n5YN@fs&IfIJ7TGUqBe1Sw-y2V|erdTjX`=X5Xx%aS(&NG5?DMBV}a14tH$ll%p6Ewa>J_`b(`q)&Sne zTlP|WQ>q8wUj0**9mEpSG6otps`jjafWrVa&JGNdxmTh_j|{$Z#F&2f-^NPPK#TdH z)5(;kPrIK;NAb@V{4LAB>KZJsO!MM)WdrX)Dp*te3x9em1Q@)zaA0U<9embZ9c5f} zdEHDI^M5{`PdGcn70R@61m;d)3Rip%;D&4-bU4M(K;D96gm3|6Bo8*0hoPiUH8ae0 zeR=@?6sV>8`XYv16%@!Khtt!KZ!g{OVVoW(Aio{D)f)G!w%<%|flzt%^nC^rz)5*m|2T>7KB%m8L+TOS1HfGeYzCo{)h~96t!eX_{Y5fL!j;00 zyeHKQ7cwmWeM?2)xu}h6vyGiNa;!{!q|xe)*4$m0?Rg$6x1y{E4B(%mtp8do zWn)W45J;k-{b~)rH(CI)$*VCTql4CM&DQ(^Tr;PEU?ZUtqCRWunO|b4jULc{_xn&{ z1|r<-eiosENXGOFZ*HeE(jv@nrQ3(s4kO5#mJGn&m!Iqxl$G_~8quoIffQ!kdZJ0F zJk~1Q*WP}1HD#|rh6eo^0RdLHSq%6hhmXBw{w1mSkR!iu-fOIT2cdGm8Rc;T8yg$< zWh5KgTD+9;6qD&f^XfTy`2!TkqeOqwc^?tAJIwfYWpPpX3{vlxmXu<$s!S$OWTrqK z7?gclh|}%k)1jeHNFIkd?NlHxNonsqIMU0zfqk((!ofr1GxTV)Qdl$NnO z)Lw@hbXcf=Y!GWka&l6+LJtifei5zY<>gz*@jrc14s$bLPgOtG```0`(D5>O7*%=? z_{>2p5LV+PRxV_W#`4gbArJ_!eL9gh-7Hy=!DUr<@fdXS^b|)UeRp3mse+JZfThUZ zk_tKL=J`jdc5e)j69gW&3SXr8TsN~HIqbjWzUY$5whOD!Niq90CEkV;gWCOF)bJ|i zP|N^D2FxlCckEckI08%Dpjf%X;6ns;Fx3Xi4?4GeG%C=epooM;6SF6h>yeMpJKB`{ zrRF#?XVB0%nXQi)4S?tPB$|?ZzWp%oFJ9RHkb_1Z8zJ}<`1Y$E8;9pGk0eWb2^GD= zm~y-R;Vr}`-XCO+Dt-A9EM>m%MOdz-L`C5e(xxv!%X|K<7D?|70l5c&g=UuAw^1Q; znxA^_-Wvs05qdcz4qehI12%SNT^+V7?;T~M$D-u9#+{gfR_ulO42WMs*|D-wvosfW z+uSfXdlQ{;6oC}Aj)lFKbzG*}()SK%S|Xtn|I9u*tMaP7o@?-4)kxKusD!o7!4hIL{{9cS7N56b!gV_~O*kE;#sNzgi?Btc;TH)VB$C znA6T68-z7j_8yWovA|FS4q@1@vnxCq`wEKq5QW62Poet%uOA+QCh*f3vpl8kAzRb8 z-^|9*t`1}e8GS&2AU082&i`K*!6gpQ_d6KB+7-ehO6lAfYsfR-njZ-Rra1Y1LR>uN8n3RE z)hiuvemrXnDch@mOMTwFc>~S};R`snQ+&!7;OQ|h>^=2(3*3G!(juu&NAIboalRe! z4bFZ}^~Uk3DM$qJw>Me_h-BiR16*2s`X8hi@5xrKxJpUh@!XiYu|40I5Cb11DjB(B zDcFQC18k5;hsaUOPfz{oQ=5d_pNa>pJe~(dRySdF-5+jKAM8w6>L39`P zC{FF_2WgO*u}7~0K8MTZ82R&zjFOKZH}Ti31P3dB?AN&Jir_4EbT_=~okok(IYVgy z0oc{!53S*5Sb01GoCSn3?x58eY=$iaFP^)<)GyJqRgYknVTh~8b#--($sTzwVPQ(P&)+2=JH`s7iz92Ldfw!}Us-_H zRFDLJ5L`T7@`#WSVgu@ZHM;}>wmoeBmZ#tS`twZk?yL2G|JaW$!6MLmXNZt*Y5zeVAxV z-?{fO_=xigg;#51c5$UL203p$5LWX zs2~rITT|+uF{uX6^++8D63eGS^2pZ1X1gf zvwL#Pn$Cdd;a6<-Z)LLwy^()+LRck1#yb_R@(9=3)wLJmFk&J?P$ylS)7tCeiex#% z+fdDR(2rCNO!_PmJdWT5zD4x)_fJbvG1elVEElnApYl2IR^aMK^~CcP1CyT8V?m59 zTG}zNRbyvk+jNaxSVcgibnJZRz@#|S_H=a-TO;u%09_`ZVzKpRUfP;_sI0tr>F;3# zibkAGyKW)8|9DvG^_FXT*%~a}oAURsT`r-UwQ6)1fpWk%0k3>*;c7o_02jb$v!=q{ z-d^wdTK$ef$CH`g@Z9ILjv$7pu&_vUWZ5f0mIbukhvdYkPYagw_z-i{oDm6CV4=sn z5=wiK7^tg&>%oP+QFGYtjU;ovEQ@BYiLRoet-AUYoUk`u+vn-&Nqqw2Q5=;<3{Hzq zgZC%(OFRtwJ~rDA@PQe*ZQC?r)8IhF7nzG@S4?{YBTeH!&Ilx+Objm?qJ(hVI5{~{ z&vO6w?VP82XJIPgqOTpD8W^wzWGId2n!6>{FI_^c&@|!T#q|KQR~z~Z?1EPdKRsC?=mH-4Lw5B7PXA#Wph|?gtw=X{KSJ3Egm@af+W3=?A3n6dFuVf$eHE2@YwyJwQ-4a%%nh#f z__dO*@L<3QkFrR2@4ij?GPqGef{pU8B?T}X>AqXmXD82=(_!WQCr=cN){`V-$a6tK z`%^&qp>d9z)Px%XM~)w#elsAlH%Nhg>$%g9kiU+HIrpU^vU20NCMF zJE@_O)-=d4pMgE%=%GV>?QfdgXGZqTXZVEr8!`xeJK&pY7Cry5hhZ*zbpaS#!-q|j z#d0I9jzNh)BGbuZ+gt8%UR|<0`@Zk*lM93IZgh;5HoV=>7kT)hQioN8&roWvChr@a z9vd+X`Mg#p6FS@0RokYk_d69~D%JGf#2zH+4l8y=yVKWb%AZ`=8{CVw!97F}2$j4l zqNi<=Wmz7au0T{!=L)>wYx`O)zAeUYle~+-%X40TbLZxK%Yrs+sFs=Q9;<8N4BxD< zO8I16c+sDXlMqT)cs4EL*)vJIUj{6sceWmbU;1F~1G)48&#AJogAKp>&!RbrRY*o_ z3{j?ZLN<_?6JpWkp75PShRR(buSW} z0Qc(^PW81T%exM8B>2zLoW#!axLZ?EQNaFpX8sDYm~`LR*<$o(ltay0n4dojvjtoX z>T$U7926AXS$!E?QSe~KFcS@CmbyoZ=4Ul)ec2}%MOAH!#(B}H6^bovz<~kM+;rk)6pTL%(JyMw6pt&Rt~-tcr<9qZl3CZ zV4?lnx$|Qk%TA*2MxS-84*hkCw^;CG<~B&fq>(D@iHG!2|MI&b=gy~-Ut29>TMeiT z!%%~o_L10yqxcl?%JikHSRY$Pp>h z_!R~|x-B@x4+Q|07bJ7z>8%&_hAom5^A43Jaw5N^4(z-zD^OBZhvzvtQHc^HTQ{}? zT_gPAo<5~y3~zu3`yiVfn}DAoA`lt|1ez95u1-LtSWEHxm2Y}=o*Vql2)O$@dy70v zpmCuA%tmPqcer*pHLcHIqU@97b3vKZgmV5&k)Oy(D(kKa3;PMacv6z~!Gj=?s$t8y zE_e)N(F>g6d-m+nD{|VvTJfCeo9Qe3cL4E^xy?Vtx`Kd+`)zG4s-gY>VqEXh_6>ZI z6su@?`Fucy;17p~heJ~S3gB7YUd)7b<0b%BgFoES(IFVc%dltiz;^$pwzgd7u>q9w zj3O3bpMLuI@zBwuhq=Y7`u@VI?P&`m=IYrxZ=N@ridwoMcB|!ECtSiIbxshv)``Oz z7i&LoR)rD*$AGPX;l;qf7$_)Ere1z+k)oAZUmu63WWH;uzYFFW{^RG$a(;OQb4ZxpVy~-PUYx!6eG_#FJF3cSd7_kc^)6que!@07v`2AWm`depuOw7I(r`+T-{6mF{>%{~Yjs`!K2*Y4S{a(={@hF=Byy z7VeF_^mu~7BDvyKnvEZm)G3BmRxw;Kikbjc$rSA0hKBCd<@@X;(2dvtwYuKI$L^b@ z^X5TVn1bq8;0Ui?zh?0b3x_o#+nmQb|8f<0v}QB|d2Go#*Va}~OziCJ#FF`N+DDo5 z3Y*-W60hYUbjZZSm6esvyTZWSN12B?PfJG!5G3-ehJimrLq=I%(?h$HbH15A&(k_$ zA+q@K;Tf>?C7DHec=qwE?Lruk?9<*%AUj;U1|fY@cj}KH=KX;f$3e*npV<)j&mjvO zv$NqL^G&nD`>vNVXeXnyT5wBNNJay+`)&nTPSq1|&TP?h_ZfVw&ST32OAENOn%Ro) zH<>ISeGjQ6?B_lH%r359CqrfsS~x|-G$D)wiQ$2_{r&L>3k2r^jjCm;wAEqh?iGVb zx9z*B(WlQX&Z1h`Exprj0yLX%zu%!)0(p@6LQXq#4qHk=dN z$4bY$Y3e?Ry!a{?c)b%ISK!DpU)b=wzn+m2-F}{%hI$FD!hSo4(}qlel>wwMrK`X_ z>rJjOfUAo3FDjYAuSu9q@d68pI(ub&+%($jtJnx1ysu%!&8DhQ^~8WZu#!`e%u6rS z6~-Y?(!X+b;N{iB0G4?o50l6oieH35JCkCb9d97S%b_UKEt0mhvML#C1dYRaYz5KB z&c;4#$KEari-Uw6)h4+>I?r;3BikYIe8JV)9boLA%wMdfeNje|D)3fUrz1bj%}vhF zuO6O;KTB_Q2!^VX-`AD%-(rb9>#wx?uggitH#$H-;p!CU>?JX0C#+JW^U441ct!~? zO@m1;H1Mo+0cii+rhXe@8s+yCGUIKjySmMq!Bs?1u=HweRS`H3&upF6E0txxcd53_P4W&i*pJH+?^Lce!SV>4x8fp9vc$1VSbw!(^&@x zVM;Xt3%II^3aiegA*7~mpG;k8fjR1+-EkB_Xvpo4=eI!^5Pd}3i-9?7Z@;1q(~jUV z3|c~}VF`>fba~km6-l<}Q}t)n%>NK8m%^Y-E&_v}yxebnPsiHsDlB}TO|x*|#1oFg z9Qt%fuO%+?&ImQ|YUi4Gg16aWb;T_}?mh63Q@3yDn?`@Ej{}BeetisMA2#3M{Sxre zMNliOHf8vZ96{PJWo4ay(vr0;?$nfKdx@@yrIzQVOEak|N2{v2FabjMgt@b{>1>Ys zyoVmmNsO6eM2gjQJTgj3J`Fm6MU9I|Rewf4c@hSx6&B9px)uMzb>lCg)_-i~YpAKN z?x6lv!{o0fuP5eH`Z-39aB6IAcl&i(8nFfE_B=^Z5oSoD^o=3jZ>y)k3=g<-2Nr>)f)g1rm)!NuLVP$x`&Qw?6)c7-}l{Z*Ys*V+$Z~ku*Y1=z=@s* zL#}<-&&7(p#$NX7)xB4*Xrfbrn*)0GFK1@@;ylj3ma|BZyoegnX2Ai_Ze{VGI&qEg zbi>6NOYohL%|=W_e*p0jC@DUBR=zdw1*w~MZ~7kaH2srHIyKcM`=)*a{QLgLskoB` zzS+#@yuH009XI5*TyS=t7bshm4XR(dSscy+R5lP&>pV54|NOpG5x+B0NJY8B- z?f1g;;j?KcvqcdsgEo-W0lW_czhqwG+Ig30`za{p6q0vu*h zpzZmuA?Y^rPj4P-4DJztc3E_wUc10~EX#AzK!cb6US39N5F`GGUj{N_L z`@CUG{Vy_W!oovCV_S*n>^#m{x!gK%}?JQu&ID`lPy@ocMdXrE96Js}r-D181+n?kKkv5MCF8gnUy&n+6R^aKM2o-N9Ed zyE%Rz(5LK{!*q5cF-=WP0DCykDz8=^T`84ifdbP)Btt3Xi@75{iqhqYkkV2RKj4dn z_6jvy^8Phwuj(nS3Q~ukaPvs&=X$9n2j9+qEEkIeA z9_oW0h5s-$rHqSOcKfy{Mh_)uHbO)F;B>#XYM)SUCO&@Qbu5ZQ zz?3Nv$#MJFHR|3AQ#GvnVa2DHjXa>uJ2W8U&TsSSeN;wDX&J^-jzWV(A+T3eJh^|L zbW;{I135NZ7!}JQG5X2Pq^Ghh80vzOfFV4JDwa)zbJTp1h`P)=&%IGJT6r4`W$RjW zb#*12mclviLRA?hbnSW`E%+mlbEa|+jrT0UW>uPl17wkV3L}&Yb$NepitaHG_4n^% zno{dEUt3(os2aIV#hx}yYhFADu`R=d$#s$*c3?*@|5ZLwCV->|X|#NJy`-e~K)&jt zkD)(J$*lMI{rM&$FyNh1A1{SMODSD_8vXIe;`;6w;tmb(G54cz{-?2$^epT~V_N6Y z0pp%9YVw^V?taB+99b(&rqMI=ZyEdy8ASeuQnuLcyFyV7?5F6;gvmH4<95z+Gdbk^g9?C1)NPg%v0zHephs=%<57u zJ{5moU)X(~#+0#aU~*=98mp}=2>pFowom#P%XuLTSSiWm+;p90mX>G=TSC01!k<5n z#ULLe#QWRnwX_#{rb%WT+WLb$D*Q+mr*}1DG9#3lOK5g?Bddjth+m76R16= z(fA*qjDuAC5z|vsZzn%lD;y_Me!;yR$wG1%78bcp3kFu=In9z|W43#cItZL-Tsxtm zw$6q@XDl}9gS*~zN97tELwKiV^mQ~8L6najB*N$ahYNtRKVAK~R$fGHpT|K?rjR># zXwI5O)b3VF2}>O;D_ZL#@e50Cs-7V{zf>C~#0BIQ8nu_3`27sAA(?bbJ_1qnW?lOpQ9Weq4u!a^WX~`umHnUQNM=tmk11v}3;= z2&}Hqc%T=7sv(@~9Htmx0Zz}(1}Vi7?j->vTY`-Ewbqfc2xN%a{yy*JJR7;SeRbU5 z8PoJD$%nopy=HNytrYptDJf=h@Zv&?@<{akW`fjQ1Q2+D$x<4aO$LNXlk zvKt54V1d+Om64Hg-MrAurO@?Tb~^gw)NRUF$(RAqSUYn4PBj`A{VUJ zjt>B3KRl|#62NxmOd$S@{jnDA6xdg)vrRdyqPXKzoWvvp z+kej4^z{$_{yX6qPAS;aju#Ve71*ambKC`YFoS}I*koOzCZlg%jJ9fwtKPFEf!kx8chL&jSF;@4sbSrYqZ!WqmmSEz<78D zx6{zjNQe9jU&!@W7@c;5??$oS*!>x}2E_4w8JL7sp)ctKHKg8%85%DPiIih=9euOs z$%V^aDx1a%nJ;I$pkz7u$vRI9IoX$Vb&o$;o*yU`HMVr z!L^&>6Qo1M5?M=&b}5YGCW&+BT?~E0!ooICmC3BWY3{Q-M7ISg&|y!idqGbY(?Kc% zdhJJ#nD*|Sui?U=)64h1EDM5y8T=@57L(x|wp}p`5F(E|&U>6NGP(fioR=b-JMv?9L7N-_Ae2|L8J|P`(4gZL0du{0`z8~pyl?!*ge$lUcVkGz*2QD)-ePhSn8gJ7#iY5*W=$r)`czsAr`LyZl=eA-2=29X8mdYsr(kkog{{ZGh*O0tLCTyV_k!1+bfo@D$%VZjOLdLGh2cjiyFWjTc8NzbfE=qXK3EuB8-E3cjh2qid+5`EhAjZ9 z6`~LHocf&zhZNuYI(+*1qph%shpdMr2MzaVM*<8$9`gLE+*8`nV}m&gB6-+-v7EB? zia!~ff6uuBZP{Alj8x2{M+hX2fBEu@^?X%X_*rf`1%-X^qyVqwg=$7~W#vI?s+Ds8 z$=Q)sQiQkVEtqpx(2vZGa?L=0ni>`mu5sAUF0237w2LE!zi4j@v$`!g!?m%@sG~t3U z*Yn(h3`rOv;`!<_&%;b{&>@slO)8uK3u6{OKA7K)wm~YEe?6}-Hn#oq=NAzX5!S0& zW#NaVz1{~NwL->dC4X$HS!Asvx*8bRI>L65w!pSm>+J0_ab)+rwZpAl~xC2uXq9*P2G225mW%q`SlT+jo;YI5Rh{a{nbn^Ij7!z$DD5Sc{ zA}$`0YK9T_aM@Pq< zcR3Jy4Kffh(R-=4I6gl9oJ@yw!Riym%R<*aaVoxi`qai@?a+DmT?EH2vgE?bGz^Cf46Rp%m z<-%*wLgYH~Ecqw+W3*pecUAF5$MUlt!l#z>6r|hE#>Sf@9&RzXvfaPWeOJPPzosINdymbVs(RUW2Y?4-Riulse7QiXSYmZ`znEn zA9CX_=UR=nyCPZ$`)yfioJx#dtkAXi(;Pt5J*3AVUIiPDx#I)nH0BoxGNl59j+qzS zXnAN(GWfCkBCZ2PJd~^}_ch=zlB4NM+V|E&ghYgSF?DH*+1J+jcWtX{=7dORJ3`cJ z>9fNwx&&Jf{kO3%VHz5C2*5*uB#TSfix>P9^UY)Os^G4JOLQiq*(^^SHc9lUsG<%Y ztUURVH0VGJhC=n_^mH?151P^4tsvrQyFoIy5QhJV4=c)V*bzf)1=2KdaG=;QadUIq zc!Gqe_42vKTUJlBN_I|!XlWs4v8-9uRaFu52y#hiC_F3>E*~AeZ>-~%EN=wlRZP`+T9z&a(PkAC$AC@O zU$r#vMGy`MgBPEXqEo?~=Q^0;3tKO)G;~y2yvsga$6T~PUV@7_KOdi$P4a1uLdRhf z3|VZnWXcC7|Fq4{-xmUB=m-+jZ2JKPYiM4$7^1q`U2`?}vUL~V)zrcb0x1cn!;B-++h=b>9s)Mfa>{mGC)@A72_XRe^fl-`}=};k+CX=?daZ>!CssR*{Gc{_-Wsz2QpERFMw6Y+%d;jnRr)KpFjZ|6C|^O1r$57nEPY2gGnhj#zn*lF ze514OUm@tnV88js**z2Bg_W}TQd1?KP20M8bER#&>0A3bo0U72a56&m4MwjE8eNhcpC<*t++^06lBx%x94^4NV) zNd2+{Y2hosC&+53PocJ&a+5O2-OCCwP-{~Yg1_PQW!MuG>egg%4`ep&SEe<$Hf+s! zhVN^^x&%`Vq?e90Aw#}aCcKx$#b;6?MUbabQdA_t%j*F;9E{tM02zk5njnTGoKUJXJ+bud!J^uaJ}9l)okkiN?mB# z{?lRKi=4q^i9L25tP?AwiIAV>=MTU&TA#N%PALr8G95j9*v#4*M%IO1%Rf+&V-Ub6>I`QV2pQlR zfq3JoK{d>nUzJn(*LRP6fH#J|xqu5!Xb|0pI8pb}wiDT+zo%8pv`2`I9Ew_*m%so< zpHKuAkun_SjMb^gQ5W|2o^mMzG zv$uCbqf2$qoSnFugM+f1+!Khc_l@yy-Tdf}Zrs^ZW@ZyMo$L&1|94Qd+Kyb@IsSg@ zQ5Y56ZY3gP6tV8`0V=M0B8W%^llnq%yAaIDRDCF5XmIclx0ut<3W5B#X-x{&2-=A8 zFCd{+cdO$G{4fPpNX9M<9Ax$nY}cmUPC~KMZ0>rmWvz!+GpWnOiPes9uzi2;n-epd zsZM%RUPW@}%5Of(Hx$aihW{h_$p2S_lo8q@bT7}eGEoFlpJ4G_^3p$b%AG=MR8`*e zkOu_}a+igV9oy~&T?!=m92{Rw--5!2Qqp6II!_B@wq-9F`)99Ti=c)}9i(*!t%dR> zc~^mNolDQ{NCXbGTZx{4m;~J@@}-lLdwWAxX^Hp?R6(F+m|eYE*|oYd+MOtwaFl|F zxw%yVZ9{4^@J~uQRkV2H*sNzLVXmmCXlQu#fcxxThDt}i?W=WlGtD#2qt8a4Juj4_ z9h%}Kbr|qd;h3B2tWb;{eh~Ak#LL>l`X?io?asEcjw%s`nC(07Z0B(x?Hnq$(*I+= zI9j(_{(U&_oiJm~qk&m7xboKtu}jBZ>wf^!Qn5*{S>5Owa74J_{^|Qc0(vCYU(;?d ze(*D7+I}uW1rbeP43E9dtue`k#&3;ucPj2QNlx<-=;NEIseDP$VobO&_(A%W-*&rK zET&#jNvY9192HWkO7;esL;pT5g2LV+OmBb9F21&2eg4+tC>ail$ai*VeYxpnZW`{u zCH0Y_%v6j=Wme~h<|nVwLMD}|r(0;#lZ0-HNyh6{PEJpj+`j?PyJBnQT{q6J#rrgH zDL;A?5dp19iHaJX{6+PVGs+aZQ-~bNR0OZnfS}+Et2Tm^_jrZhzYmxEBlPwj9!Uzx*faz0+<^|q%lq-m zm$&rT*FGDA2LdWEbydCak`leZ;KxsMiU^lT%*^7Bt1&(o;{V+B-DNi`&o5qBqUxpu z5G@1hO=PA%iw7j3&;;#-JGt?N<8U>7plhAgrW>{=RMo-Q>+Y5{N)nNhqBMkXC4-R{ zC7|MW-iw9B#ZR&6#~7x1_phy)l8`Dl;(2H1NF;X0gMUI^aup%Y7&pU|60aUdR z0S6Hy^B;d++is_&EYB{DE5$Uw(Q5y`DqDImyJZnRZ(nL}P>uUk8<3!{8Cq^cggELrfzz?@6nR#P-(`C@T$YTd6*C4t9FVYL`LR!jI)4U&_$>BA0$^`V$ z6b2GpVSoQ-fD2W%Oo_U_{vNFZobM?AsQc1AGb&kCZU?6^ZVp!;-Jqui8v+)R_6M+) z4inZf9N6g7^EuIHdRjlGVyF1~`aZkm->1%j84(ti;Jp%wrM8v+!M*4ys>NGt$mOMb zx>V!Y-o;f$IUv-Qq?568HD^pGx>J2-3J$ewd(Cv*?rC1$2G%Dn!_srzy3kL+3ADv$ zqk%G*i|}=7SE`3O;*&FKK9`P(DgU?0KbjDOLuLOY`#Nv;E^r zDL-#x|41oi-xvd7?!;Z4*)zAwlc`opX7!lHG%5d;py0zQyY>yC{lC+|Zt4GWBWM3R zEG!85?@8tP-&x}5e+iQ|2mU)jT>LMe^8fWE`Kv~hE??e-oaMN){#|3Ih^~^OkaPN+ zI2ZP7fBqZW-Yb}u;Krh!>e5{s4-p7U20^-1FW}2nA(vU(_hc6#yXBhjzKxqUiCDUU z($O*Hz*N0;Ynp<5C6i=9mr>5=+c0H^Dk(E__y3GQttxQ@fOD6`jezwD7t(tG4hp*> z@8AE>XNLec{W9rgQNx_?0D&M#K&>O1xrW^n2nAWVvn2A(8{P<8>+5r;1)U?~iSYy& zoSe#!9wg|??de3SqJ>CIrBSb#ZAUUPg$E|#gnm5)e%evW3aTG0L>jveWL5V4g*A1f zDU7T0y|4Y}1~66$uOq@$-+8R_xb4qhXeVIj~ZJ_@-kNl#mCJW6501lzslzt@Lf%H0G9GRLC7UL4v@zaN#S~-||XKh|*f= zMCgtevI6Jl4u@iH>pc>}puV-V`1i_@Z#nhXwU$xKuAQP*=H?tV1o=<~h3w06s$VrG z{SfgDhYREce)vF4Xh;w?3m_*h{IT}N>4S0H&&pZ=npMVv^(I09#?;|&wKt}|HQzeF zx)+l^AdU*q98#?dtR#m$(aKcKIK~_@kgETmnyX+>&^4-e1O8^h`@%TtO+c&1%vkBn z88x1Z7t-r2L|A=sU+$0)){Q)c&k%sXs7(};F74MIU)$R;XDumMw=ucY8!Godc=s37 znp!ds2O`V#^yvbJK_g&wcrN)O-MeL7RaAD9zrHdPN!}m|nQSdyZ-FX*>!qv(CS*Y+R^dGg%;3o5Mgr?j&0ihDQQhS(UOy;US%_F77F zzhnHAW5uR{p@|y)w{RJl+E_k}lLd7yiZa~sBa!}?vm(7c-nXjD+>%r-9?S$v1M?4BfACj933O!Z3~s`mQaqU2M=~0NRW+$ zp?Z3=t#pF5vGK2>5at_2EU?_>*co*19t;u~6JykAwrxW+Z1KyNNyWu+%;(pppEif9 z>~}xD4rN|bS_W1)9b*POb&H%VcQC`v)NT1ZI$KOOuy$SNOM-)6Gv7$##6@~@bP0b%Vr5+ihtIeh+NUXS5$gV)TJgdH=lC{@L~ z7St?=PH^bmLbH(_^ZPGPYPQ@~N@IL$)6@P`V-Y=BetuE@Y=%Z6)_3y0#$iXdV!l@u z79##m6DJ29PKtM&H?8?_XL+c3A*ORHp$kSmM__)zW^0-#$996)IR8vxmv=8cdSW@Y zgLkqs4cv!?`q!5A>Kt?ZI)wR9w3bR&>ExMZyg>bMealW|a1V)oF{0ieV4d9B)}~EM z#_y(+m&cCn{9${vu$i5gm#V#eFQDDp+F6kI{Wy_SDp9bW@{S0ypJ%z(*}RDb<9Gjl zOUT@g9lO{I($EzU7J+V!7WxAZ!t%y8iEX8K#T}Tz^gc{%z`025RLg7-M&>kSP~kaLyy71plAa zH|g5tK4!VyU&y}yIiih#i2IU?$4hIBmzomvo@EqCb_!6=&2BwPHPz(|^sre&A26=c zxrX~nS7|nuTZlx}_k(WS+^oBA>^J4bZ9*t|4)+^~mRXuSH~XgzFv;dykW(of30rGb zYyv5&koX>_A{fS2NvzSI+S?4GY$*R4`{4g!J@$WVd4wX1f(UzP4^?lue&w{PDbtig{S z*BiG2dPo?APdP3XOs8TNmJlj+Frq(fNQW-P*(OMnaYHbmH;k z$KwefS@4^0ts+GUmIVgr9$5U)_(?cwwa*1*68Ij*};QznxjxULPk>`o#FI z4)dozyVGIt9Mjd^56=p5@0Ip~ittc@vf*int2>0(olj>|I#Ww}4>t9PjTm_cEO%hO ze2t$$A=&n4MGgGgnYN2cN;3Vc8E=gFpz@PrqfIzqB0Piy8g%vjFzEt6nr=&{m%AEB zZT0)!!Ba(!?azpX_v*4UZZJcI$E*RvYm3(P2wnmm)~$Hu<3nc7@coR8;2zP!i@R1| z+FEdLwL}$Tj@A)8q2}fbUs7si=6@xBK6&t9AO8#fV&4Uf8B(`S*!pYvN`?O#Sv98jxUUW=0sW248{s6@#Dd zn+r%@Iq-uwxVNWg3r#sfW>~sQX9^koZu=kR4iIFRa@c%=q?Gb;Y!-r|Fpg}-Om&`e zek9f&3fSj(r_8|D|1j8SroM?2+;mF5_w}+DQ>%alYH1ao=f>we!f3rzZl1^HD;!-g z5brJxZ6yF$92W;1k0&%-6N$-c1KS%&vaz5pBM%ub$V0cKr~^7=>w{iXeeC<0Uw>)+ zkq4z1u((SxlBk4XKvvYjR~TDwaxPlZrn#K6zYG<6Edr!u69j5yTIYHec0c|8q`?mgh zjmWi(l$5*MV`_}0$KUzjIxR#ZlRkvfg81O-IIUR7UTeTVP!}cPKC@>+jEUWUhX%8> zj$-w$fbt&VZ8l$&w0j0SVQiX~<__*G-Wh%1ahEqJjS&CHAI0m-9aI0>eKr^a^96hx zFXfKoz0yKtQ~CYs-puE`GIqc4O^@9hfKi7x`oMPk<0p856f`$;iCV98S52_{^3$9- zeOjmJ^}X7@jZ_o?F+MZwV*7RjSwv~FbxW!e$IFqCLl-Y{4gP)pTv0Hp-GnhKqX@-6 zc2Rm>%_mLUivNC0_`PKp*I6%=Q*5Es)dC3(&PZ5 z?+xB7WQ*s8FaIJCNrILPH@0&!%e;O)P?Ottm95IG?G1~~1=&<`Y`zRMRIC+7IUhfY z(C>-FhZ0#UPpZKBKPNT)Tq_gMomIXBiO2%Q=Z&^Me;131iI;Qx5!~F1J^;n_7^Sk# z)SexWJw7QwbCP)IAryO0(OErHr^SEnwPp9c^jtH~L?vBmch5w@`kS(-cglCb*<4%p zR5DU>*^|Fz=^l;rmxu!yKlJ|nx$uM~tc=iL&~ckFT}3_#?AnsJ^TbCRPbFxUcpUVs z+^|&%yN}V8W_V5_{sPlvMCoZ+draP z$W+eH8J?of^UoHKlSGta4rv)KHd`XHO3PSO23$mQ)?+h1zZ4t0giVl(`16N03Ls%I zG0+c?o;@thKY806elNJVz;A!FOEZV zE6aXqJR1ezYZt|ZT9d-klJySuh(<10L2 zkV?SR6G+jW+CKW-DyZ95?(G!<>#54b9#;-B?zuQ|RlSlO<)1;A03}3?8p0kPW98$+3LczxyD9tV{{0)h5G8YE z@4tt%tbo8hTc~ekXbgi61K(VP62XmK+I=P#UYS)@88Atf)CrA`Z)|CiF#BT691=qM zVje!X#Gl_57Zw&k0^MN9`LFjHqTO9`EOj&C1V23-l@MR=%g-FbMHfK4WolXgTfHDs zL?|+V1+}%c!Q?xsY7A1prKKa7ym0ta385@IAJZx^o$Bs2?SzdtTB&6D2JkB8x zTXL+VD-(sqKY_ixwy)k>PCyZAV_;w(F@HrlvAv3(3hl`6#N1;E~40IZoVgL&m=R86n!ovJO!osrG zLmo2ELo|U{d$AO!p*+jB2;})bTH4?8GMqdL+jV;^IkrwN*8z9fZ>yg z{qM^k&_$FP`1xlZ@LpnFmN zP6`T`Is^uu0m&M98Mti)Nk;lcN%X8(_qTRXvsU!|<)^9XvkT+Uj-S_VOv=Kwj zRizQCsa{PR$&jYO&%=&WV=+|+Br8pF8%y^G(SS=Ll*oAanadEA5bvH@MRskJR|G=JY zG&DHh;?BZL&$i?{|ysC-`ChCZf&r zuyNX!32J>fqSYAd#vn6$eYNdIAKK>>45nkMZI-0|;SerVQb0Tz8mF+C8Ju1EA&a?&TdiD*4EY5 zuJ4`Lx%1Uw4e3Ym@s~Bl@{)`WNQFPDG4|_xj8`t|z@aRuGcnhD4oMeb9N2UQckD~% zJE8hDv-%v2vdbPm;11a0>DB_JS!_&9Le%jSyb*Z3TmLxWsnL@d+{^0Q3o9}XMZeDA zhJk#oBhm>wSigRE0SUCK>e;Sc;YLPZEiI3LNn?_WYz#2op=SpMGddc>w`cL>F2)SK zVhZ+_1++idnU_*g%&{``9w$6#G<~A~3I?jUEp|UE6kT06pf5Gatr>KHqZ53eJjct5 zTH;;*NU9fg^iR8iH0ZrNyjn2&H?n0P^XrA>638GCe6%CqMd^OiV3K}N)6sr2WlkY> zb{M*8T#OqT8v0OMYmL~WVSRn(Jkf7?bX)r17fVXg^IksSz;QNh5}Aj9#bJKyOI}BQ znwgpR)bvNnnLYZhSErPsiHT4YAot8wvU7*D%fPRiURc%vDEnLMUEDioJ$v&rEK|hn z`(q&#{_lKsX!@!>RN#78t`FJa`6AfEAaRmGL zc#pEI#B{7o4^9`t^OrvG;(3bN8+3|NvqvRmk40lta9HD3!sg1)P?>WQDI?2G2`d*g z#U5rgeft*B>vG~mV!42k@IIttUb}WmQ&SWCWdt;2d9StdgwgK>nN-Focnz$3WnGi5#(Y;gNG&|0Z%|gueVv0iw3zOKOIvtu#xba z)RB4SQ}*FwG=gPAn5AG%52_h#b)_7KrnnM3;0(}$IGd{~Xe_ao;hev}86L*^z@5B@+dMd z`5BbMYq-N}Rwre=5li>1+5C#pS5akx)y`EF>(!W%&SIgX**EkuuC-+C@0vQ8n36IN z03H-(KJ6JKRA+ZFm(_T? z!D<*sO@3D=%uq3zLw@vN7$9)8dY^~qb=r0vta-OMRtn`WE(jh8H%ah@1x>2+wPkJO ziD2o2uPO!|N+v(WpdUx84%nTRte1^0@5f31?O&P^->n9&ui2MhOG{*5xN@Q^TN%mC zoT8^r#5C~c`aU}OBU-P7;bNxOyOT1a?CbdxcECOkAK-l(7kW8#H%vMLBuZN%V79mnc8~<7Q+u zolLI!t@c%;A!Lnk`f*_LTHT|#_;^L{-GhUJd`G)lKHJ=;ENi8sT;?!>2eH5uUoPMG zF=sL4El+wL=2d>-wOkGgF360aRvapD*iG4I-yM0c&eQx|M=|poe^ebh`Owhph&!RD zIlvbtjXOIzp$7!rl9`z~3z314P+N%LV#@eXD1_Ji0u+~cbPi}V!U!Y%uP~U1#7wyr zR~n_d#~~;X&tJEJ_wU`b@6i&H6JflI9?n>BXxc5t@{u&=32=8rS>j_Kj8R99rcs{O zJ%#c}fit_er06h@Iu$*?6nIvY?nlX*N&xr>Q#H-TVicq?DqT|-ViEGid6qW}=ZRXSI)I=Uq0oB#xbj$aMQNo6R@JGw({q1RdvY8sk1nD($@)Hz}k5-juzu z!on{sEXK23aAFBP4_PglQvdo!+N{KfP}Z=IA22ccS27)h=|vhA&Lo0RI_ z(Xp}QGvMlgSfS1X+78YmQ{kcM!tTj3{b3Z7%a+uYo*k=got-lkyBJ+1SDMbPJ}oGyFcw^zZ#W9VTzqHQKFS^H z{)QPV;hpDCzJmmr#nw`prE&J!h|JG}4zQC785&aSDzT;fT)TgjJ(mH25X3@Exgc-t z#RTtla>-0Ldf9v}?;xFm`;cne*|o0E_ZHyJiL?vy zNLyS@Z05X84|2@vfQ1x8+;r)7JOttM9}gcbcQT_~ zK*2hcK@8qg=!<4soQfu0N`ABkmG^v>L4U%`wBX&L);+z37Ff~r!|h^!kyWI6UoA+@*OUjqykBwY1Y5JV5THJr&R_VvuoDmJqRSjY9TkUw+(;b%gxj zB<|9#)f%ptko^)n={a4d8mlo%5$-%e!ScG}sR0qsQg1<+i;MK~R5*65boH63rUuS~ zDfgV!*WT&uI}!__gyI2)6s^*zdd`IefbB?SQqa+P+xDkqV$_22bA*-+;WyUJ1$*W* z-dw{8J@O5R|Isx4Z%y+*eE+ka|EdxMcAHn4hCwHp0g^lCQ6dm%$aGf@zUPM!om&GZ zazgHX&(=wYO;X}Duo4jr zU#!>l+2-oV=s&4ldrTGII?XqBjvyM3C)|{MXO6u1Dv)}RlXit(;l48GVV-ErQ7|MQ zon0Io%KHjp{;?EZ=#exBZ)x}AiOFWPB+!q7?=C-yX z`+;j~qf5|DU`UG3GQ8${VkR=Rsn@PoX7DpHfzNm<##C}}42RJ<%@L`z?7D=kwuFbNl2 z)j$5&AgB$oy>%3=slo~4J_1hY@wiFjV_l`$6rveE-=rjv@ED;Tc=?hOvleL46VD@# zF|g93!%2(@_Yh+tY(jhxjxhK|DOaibn6I@5iRaxUnUfpA+I$hqVzbfbCh0x@NVJ;R zmfP_IKP@x{07?oEWjq_%jfeUBqM%?9WqNF5SlnSxpk2G@#Dup#J@J{y3O~k zB9@Sth#oRwWol1OPBi$W3+!ua6LXNxN1TMj(_xaXe_gDsyu7>;$%z#d3e_9QrLs*e zPtvXlMk$9q!PG~3+2PEYGrQzf0W_5^{|N+1R;10wq@Q}D5BzqvGjStb{Y+#QQpbs` zMI9@jBx0cI;|`D`))@c2m~rWvu`#Sa-PD(HUZOjmp7%H>J+JKK1jVl$v3TlBf)3xT z_i~H1#cM;L!bX)J;o1Lr9mZKjPJapz3!dj%nYk6wLHu<_0-_>%DQA|vR^mb_$w zy#+RFv(d8q!uaVo1$%`X_wctPKsS*xwL~AXckQj-$ljYzeZvoq*LOxY@f7SieDT$bR5FN(n4aI_YY}@uyb6pT;)^iIe%HbickbHtI z6hKY&0q=#p7CnFty>@SKhXVpqL+;%JPY<*DOV@!vo+8ba`Rv|aeWzRiE`ZztCG? zSGH+v<1l{2Q@ta95t1ozK$L&-5wPmjSyPYM1@tcvWYh{!a!J&xdqxu!= z0WLi_$)FShf|GGU{<&_^+2p%N`S@Iyr%RjC;9&&RcfXX|Y2JwE+8Pn}A3GLFK|S}z zrU&7YAK61BIe~`!cmj+cDBmG9J6LhUIPSXnGfZEkex*J!R=nDG6HVL9>}+I2gesle zpS)7-O!}e@>8nbg9vphZ7kPblbpN$aUqANsAlv?|ii-A|zhzLHB}kOi!-59vD^N@@ zkg0Dt${(Y$W`CuzFGxS=sJMM9_+iO1Qzu*hGD!%mAt*qq1AKiH16S=eX%ue057a(hC;{#|pszl8aOigW^{nPwsR(Tjk&fHK*!Wuwo^QSbRuhzwxXk*-d^ zckjc{&^(N-rl&PfjW$sV=+A>q$6zg66Lyv7qA{uvtxO=l?Js&7QM2OEMzQ@x1s0J| z;H&nA0+KKP*DYe2Z+x$mU_eg1!?A%9{sVL$uaw}mpy=%l%L2H116zLbM0#-~WblU$ z-;QcqXc2lR26qNlGBF)I7Y0*tz>D8mXIvyH%*R}y1F4lL|7R8PC{gTe?dpQuP?RRiq(1LdkbZo4kQgQQ+qB9MxapFX+v(} z^mNNAGh+rA187CTk=cc$h_kW0B%;@JhCYigM8VFZ5Lpf&rzI>p8iz#Q4~{pI9w3QY z<-50J{c(_BXP-f!UTA3O=PIPvq1?Crv&JhR+*s_uMu!iqAwCYBHLEXBC}89}sZWeK z0wW?)og&gw)6&mW21GFU#njVhG?S0E_>hvg?Y=IK4S)J{mH&}guo_+8M1jw3>4XrD z^+fQL2Y#sW)36ga%ESChNSJ`3nTY;1+eA!@5L@0bu!TzJ1q@C z-)|%(xwx#C7yNhae8m=Oiioos;|p|svx|s_p#)NF_usX9x2~2}#KU6(N3&TT5im>x zmMVNqcbnyEdYadR*jSIaw0{r$yJJ;zTM1WTs5*=&1B6n$kK}Nn1;VO>XWx5-cEv$r z;EaLAY?t@I522I`gPHnOMgo|PZ1ma7n6a52hQx{I!H)LHm|*ec9|=74flmH1FK0ji zoVwhGGexc3?v|8v!dAaed$S2f6ByE9veXcpPML(Hw+v%m3mkU$7Q}kqYZ-R`6mn6ob~m)yHYxyE1p{V?Qf)TaSQ{go@2u83&LR8V?|$Crx$o<~1`xY}801F-F|ZZC zj&}nBx9@ys+u@6{7!F}0-M_JD0~Cz%6kLb^7*q!ynn+%|)-4OL7tVk;hhluM+Py{G z13pD)24G#&GO9>KzXdK5L7}YI9+q2s_r?%Y(B6NIqlZevz3$PkEZr00X77HEj|;KY zLc5LO*L4y1&21zT50Jn+11H1xN2MxpK>W6aw7ZV{CO0Vd&C0pao}bH zcY^T~RC7)KAcwEaH$KnGx?Lpoo6Oj=y+4poO6mYcE|`a&O+VKOQi}{A!a7UXrna@4 z?5&+7eZG#3RsVWrlE-DWxyY8NsZ&Huo6Ykj>4{)#abZ5oNUa1DJsFuE`~6r>x>+&C z^X#=#u*{CCx5|$mrFGcUFi5d+S6vWALTz9*xCXPweQ2s7>(UW`>l%CL#avXuLrs^f zD67zN1DD`Yb#-&oW>U)KKmrz8<)UsYVdfXQXKgFp)G$1+!4yt1My(BXu(-IbgzsN% zVP?|F!Jea{qB6VWh0X*(^LNf$<$EyFpeG{5Qm%4;*Gstb6YtK3FU?=S?Qq1Y_Xrhj zDD~pXch9MzLI+;XQ!D*inY}4F;|wQMH`z-4v|z_n zo&dF>^1d(WZ+V@C5?pv4?qxncW|;Qankgtyl-X=n=ap_mlFBGaKEpTa=@JrIk zW8VkxO+x=Ra!{ZqPdsVa0pfo!2Xk%c{$kfC(zghH$DKW?2(Y@VLtgC1{&6!=kS$=_ z9>yc}J>M_iT9_FQ{Jw9~NIzRi*Km!80PA>2tC^IpbHI?@_Ht`=WDkUcQhZ8y)u*CbMD*tLPfU|7EG_Tm6qwft z&<0*KE(gNd^F$aHpvchLMXhA@i>%DpEh@+9Fk3DB$-~3XkBuE^Z)uBH1pUs={UAwmG9Txk^HKgCpxDM93fZp|Ww z5d5{hot5Y%vUujnJ>UnY)2gglPZPJ0|7>dN-&Yi$Wby`#@1#cfkOemmuh_r)*FN^0 zEn3)u)P#L9`XGED(0Rf!*lT_1_3=eoz`hp*B4ODoS?+!x1G|Vbk)3ugJMF5DH8BK1 zz;qZbXGi`u#E=p}DIab)^gVANKRx~D;^KSk^;~y}w>gO9)p=KsytjPG#m(Jd&6pt2 zL!F|1@q zIB7MGiC@X70V+S-KM`f@AtfuDl9BNnPHn6=O5`}eO5_cnYMY2HFCCLrAgw9FB!zQ# z7U8B$BJ?}h^Xea;s5H$Z!2wRaULw1iH_N_#=TQS8 z$ef<$5f4n3;Y3sY;DN;5hl*TP!k_Jn;9Jlf@{q^C;HFBX~0)}Z*Q0FI1(@kzJWk02Xf^;j?H&lkRXUd6-_Zyo6fkl-Laop`(B<*z|*Wr4!3 zpJ+v~RLal5xD%1zS5Xk!pGwifQO0d}jo}pRv-&Y#RpT9N+Yr~*ZVr`Qwp3H2dBDiC zcjWKin=60S0c2u?0L=+8h3=%+0_3m66i^b-?ccoj4yw0TAmGWTC=%-%8Zb!#3+5N# zn;DOZ@&9$57d9TZ+^ZE;f5Essw86SDuE>vv0u4c(`pSKpt>;OC^wsz86~pUfWb9sb z{}qivX!9UGDnPTwx#245AUUCx{|wO`GPv-mz$Y|cUldZX&72wzdIW=j3gr?f(Vb^} z5^HW}YVhehh}4zdw<+k}%mc6}*b%4pAuMbsQ0Fj}6N$OJLKe)tk!P;QCwq1PM#h^~ zgkr4DQat7}*1VXryrt#rWM1olBTL9uVBPe=17=yh_HNSqNd6lFBm$a!p895Pr$0t^ z|J4q{VG?}_PRaW<<`Qw3HF-t|=HLUH4!mWI>Tp*z zGA$e(AL6b=i;T5x`-$m0=~B*|xmRP}I(7q2`rO=Ob$q_FzzUOpSLCj7yY*0AbwlU9^~mh6QHTY1gk`#}$I4$)lPmd+7v< zHIV+((=Fq!y}>Z%eb68vnpv$yQbTwlVYT+81o}ac#V`uGA)Np#XVPvF7n_5?6F1Xj zfbxg+wVVbkL9W`nKPkCo$F=XPK6-jKMnQ_}t3K_7Uku*)k)2A^DwC`P>s+9A^h;SRbyYR7NxkW`77yX4W zDoN%hM0;5;WE|n#e@jlw=&d8dIE!8q_#X_S+0j({_S>aIQ?|3``}d4i-pI#~4;(l! zJT&Cc{n~2c`z4qRu&5gWMXCRV9snj1;9DYfd3~u-@9f!nuwziO`792ULgJ9|@2p<+ z^NtItggo$iys5B#Ay(ST)Lq74nW>*c~(|_f}VCLYysJ8pg zG#s1t@P_p(X0>%csi?XzRYN&q*SFpoBUZRc7;DZYExwV5Zdt8h`fQ*Kz8FMZJC&Z! zl-mvfTj|=hqoi3(ldbsB&`?~%2RV*@$KZ#S1WtH>G=Hf_`27=Wi;Tne|B~Q{uFh*I|ea>%fx<8oVEurz_Ij@f*xx*NNEWgZilD{Nk@{i4ja6b>3|CO6j4b@2}$vxwY^PEj#EFDR#&<5 z^_`Yo)L|%7^!A^M+VMz9IHh0p0POzU005&_z=lUv_NE~l3Bsx6%uP7zV$^uo))VV2 zw~mdtlnj_{2cCN!bgYFHB(vd++KD@^k`}Zws+pt*v?49d;UPhbY1f}^fs0)N$EuVZ zh_`Q<@zZlq+`6h+yrcc1QXsX|Jx8`o{(E(nkACjSqAKpSFEh5u*B=QzNK9$!Wa8QT zrsg4jprTrsnNn%MBvIq{oHV3&q0tC$#pv9p-#GW!o7BxJl<+3E$CVs~0k~#@M*2>_ zzXhSDGIHarznIcahbxC12XuUR@V4tlA1{(Tbk*F#q8e8{x<%yL>w%JzvmiIi-+t`l z#_lq>OOWCgK}nnP6y;e*Hq@pr1r!trpwI)-sq@@)%ae1Fj~+?L*cIaupX5rZ_k(#E zTdfGqhA1Jp#=O_`fVzjDy1sr#5+Yh5PS#cyp>dXElYDSh{CbuAGo5wyAXp?u{r0Iw3sgEdx=E+$3r3cATaQdB-@u`a}`jjwT%9Be1i=UdM*xnA*`cl zx`#Ycl9IT;00zK2#X>0iG6JulWsCxBEP*fD>45%+aUiD18*QRQd%=0@ia{$=_S$TY#>{-vH z>jv`lvJD|*ky{8?(wTX%l6gp^Nbn#*t^b__) zD?`IxV)s%}wlnVAmjL(Vf}}Or6~;6U+gNLGs7@nylb90D7YfmqQTBtCB45vOuwZnv zP>E)wr#ngZAZgblmvFbKzu!+c?yb*S004WqpADC^U%7e}XCqJ?62kB79InQTVv6e0 zC7b%kp^%oM;@MaXHGyRmHm=L!*WuAMIdJA~6X`f-<|LlhZWfPGD~CoBWJXYTV5*A^ z_Yl*W(Aw~r7$v%?4PGb?N1C}&3&FBo;DVy2W)ZX_Dk`ACSr&uF|b(xV&H{rvOawh)J6b0koj@+w~s=t&F(ds0!k~` zHWb?g$jK^BGiqu+LF%G9ZLNy4vzR>pfdg}Od`X~&zJ|h@hMv^K5f)QQLg3r4VBO))_xK@ZuU7Pj=O(cyCL`nQ}nc+`*6ZBe0Ctkgn>_J zH~jU<%yGAI;)7Hvm!~i;he^uq+o^a~G5;y2RQ0)$g4sO4`V-S1EdX)i(1OS)XWSfH z>*SqNdU~~w5AV-5ER^Owy^k?1ga4DQI7v2LUQSDLKL9XD8T-aKX`es z@M*+@3ki28Ha5t1bh27!*R;Rg*xi!*TpC#?u<*wL)2!f)B4oVxIM^q_^dME)cTP7m zY7#9hT9=mmiQ0gr$;m{;#17HFS$em+M<^bV>KKY}ZT>SFSnM`IlD29@3qQ-t`;VuN z#Ht7nrehb(EIJGYprmug>zwhgz;zKl0@N1yDA4wCk}*?I>IuZWdXRgt(sA+k^d)Nd zKd&>WJzI>wx@EP5IK~q)_6kL@h9HcL7+AfNc$Y?D8~Lq#5qkOe=4b&P z)`!DrzI}{p>m7?h*k2t)*q%HRQ$V^R^J^Rqlux-{>I^QeL>wb+phfr9{<-$%iXvRrjmV}xj zy^Qo_lQ$(|x5jU>ksI!`JmYsGEy00Usdm^d@zm$K_U!Y?cN@f1e15-I-bLPY|5nJw zKcq`v5XA2(8Q%MA@_x-v-&~$8$GTP$l{idx+;>XRa_+sj$hA-A;r5%)sc5eg-wMaA z4xUS8Fg{rKu<{+v$4Whx&0j&g`73tWa$F#nk@(#3woG$~itGvHqq~($^Cl1W8oHOn z3x0aHlMF96l6VX6U_pX*`%sK(FgXi{0$D&1`-hp1hk|cB+Sj=SjOdam%w<*F8QB=F zJM=t@*!Hu#=N3WbCP)8jKQrlF&fe+Yu-jQuv`gR=ub=E5;?3m8r(CIL-E-Nk81*A} z+`RH`Se}Ras4hok@Kv*7sxz~98~wGIV(n;FhQ1Q0=-PJqsj3nxU)aYDg#N{rPyEY(G_ZQFGgf?xIRUDo=SxsDf7lyM$CLq}ze2@iC11j@$oAiRxk`Vw9n2AT)#Zfl+Ooa(`q<2n zPk3!&EkC7NVM@BVca($_PlFPs*@N`Kl}g(!7OEJvqcb?og$9ENgox*+H7@eaj^*1l zT*S_?%RE%4p3@5?(1_|sDBm@b?4`=|VCLMmJ4W@^dPa$B;6R_I7@bx1SFf*j{tH*5 zO_>O$bK=oC{>FQ}+CEC&5k8(E_{l$V%g=cKy|b5MCbNgq)G=Urp6omiYSMBwaqoHK`sLg0X`QWw4QCH^4cQ)B- zYlO*St&Gy;%;DK8K6SOEZM1Gxe%o!g8oqFR!MfEuFL&2Fk%v@rm5FcbNsnZTNQMg~ zEPNs#fBE=X9CRx5L@v^3#E!}QAty-0t#w#vevT1aSe)Wsng44RJ=GH75T=pox%4Xu zW|b3NbNP+KWm8lZnA#$<4b6N}H;6z$(#HP$VP+o5yzJpLs5r9ipcp+ZtDrG|JApu1 zT}jZftPB%MwtYxNMvyk@54rTrVY__pebt@5ahy-d2(d5JCcCL0(9eeY$xm|+)~S+l z(!CLkzQ&`pe8{(kWp5tQ@?efG>#SS^IpM!%`ZT}Ps(s}5$Oy@MiM4W-Thv;2;(c{n z{$?NqDK38&8>_Fk0a`~JsL-N=^xGHlD?@P`Fawojvp4=Oo}iHw7l*Kr!70_m)k9Hy zaSc*56!IyPfxLv`;udyqmk>D)VxU6MBk;*)mabe8n&??F<9BgxJi9a2&Pd`Xu9w>7 zVJ0V`(t?6aB@B<7c&XgSZ3IWF{?!|sKHmzsh3=D=Yw@mv^-QSpV z*qGmjtY)_f`_f)l2*gw?Rw|T$W7G~Rr8Vc|2od_H-Y^8|Wb5V{&e3zibjM`e#cxD* z&XIN?ziJ;LlkW7y(_Q9TD#9j@@;`+od$L`JyU7P;Y8>C4mm z+3IZXm$4ITD_H{;p2x5+w5HJ*-K-2Ht(fEX_ZSGpMzYtsT<+c5FXgm&hwe2QfiwN3 z)Az@RkBrV;hA{{tvz}*{8C~>T>T(7bQ9kUqqojGh?GME#=W2w5TSlYvjv(%;JrilS zNsXS>&lGX?#i(KBfx)@Z4u?BXT5=gqX6gLSOfuHHP?-Gc)t@d(4k;-Efk*?vJ3(pz z^f0gCisF-EbFJ8@&AkFP%auZ2mXH!7g?9E|Q|^Y@2$3o_Qh*WS#as2ie$QP-3JqAK z%C&yu?BujeS2#7QrzEU3>sxP>70gW*2$;7$jF8}^-x5n^A;4^@H^230rkuyu*3(;+ z{m4F^XAFtX2QYjuGI?nrcP?@=cU8Fmjtb4WbW>fqdSPLjJSv?hr^*Aq8OEHaD4Gt! z0^}5z%HSu-!UcC9VxrzbGkf3+a{$;95nB9e>K8y0BUD1hXQ-_`HQLf=*F7Hvs;8Y?V(`(guMTQ3H~a?&sb3X#>l0a$di5g8isQ zgv|0ttTMa7B|W|H*yrCyXF(5HnRi3H&!>8u6YGoNuq?fs$A1qqkd6L3NKeZKSmX`2 zGbEPudCi!RK}6@!IgQz_w4-TX)twbGjw23ThjQNzId=4UFZ@;EdFk})Id+B_cP|2z zb+Ej&1D868Qb8ax+jwme8KshJwAD~_gAL}b{D94znU{~xttI2Ikx*_yL0P)xRzUOa zlP%yReE(4tG`{tKfYv8d9zw{23A;bORn+Umk#G)m>dciC{(WE1_xnrzG@|1k2&bl) z{IJ@*;GWz|YrX5OuF{t|QF5UO8+x*ZZFhG*@k`}APsVz-|0{>M zY5Hrf_AH%?k$6jtaf1^UrSi7V)tiOnAm$lxgz#SoJ?w{IC!whAuqt7b^%?=vZ0q1a zfo+B>9QkG+?Q|41gx_SN-AD)0lKrXXF((C|Z7p(eOj1dRGb zW8OY}Y6)Wo5|M8o)^JVD6Qp~cd-kpU1KN;$pS9BkQneEcy!Ok(pP%)-x_p)^kM&XA zPk_sI5}DcAN3}84vlLzW9J6cdo$HpC@2?b6-l=-|ayo?dn3c6P1R3k=vauN%nvK5W z#SOgY+dh8G)8ZH8=U0nQeEb+>?zs4PBO{|n9hpzxdOem;Nq+jK{^)G~9XjkE#HjkQ z-@n<|*wg^Mm(GtuRly_l4bUg1j#Y!F`C5Vrggp%;F2K|a-K_2tk7A!2!EoAt`+fq3 zIY%NteQgnY{(SdW@oV||<(F!M$FJFucRu4_yxmKY&D|%(l$nyTU!QWwDva!;mt)ZN zEgali+P-icn&D*jmpD!^s@rRKsza}lCRol;^ua%1lmuIdG|>Rfe^4`h7r zr7s;K6R%0=SK(v3x`m)0LDAUAx&0+4TVPtYW1Z{V?A2{U(N}#x98@4xlz&B(xC!Fw zn6ocV)wXLSCFZvN#y}s)7lvEC&CNq|#%`$^GVHlIvd;aLKF@TPVWP-NgSl+QwQkSC zLhxn&!1P!}{Q~%wU%nigi9$x+(o8EdZ=ohtQaaEmQ&5ia$(uK`02SEUr;+vuJ8KJz zwZs#pe_TDy%$o6kwr{@=UcnI@uV%td#j6Vy8++u@;!H2eKM@65y;9I9yKm1Ve1-6Q zDW5h%XT3CRg5>~*Cp^D@96JyTg2&RZK*|$TBfNHz{#G$jn!36=0D;s>0Px8C($jge zb!`d_XP3nZ%xr8wor?YamEc9+n0N^f*rPhjEWMN3#%u?)aIwLK zqkZ;86Wv8C9@~ADPY0Y_cUS(ASXf@(W-8p;-ku;eqb|vI#V**z&Fx8sK*LacGbLtz z>rfMvo&bwegEhMj!V-} z>`M%qXeO&>>31UF%Wg+uR{vs$GKf+_xwbAJ;z}17LLgc7cI%RFX+DiFoNP z%|z`z)6mYCD7yS!njwgQoj$bIf&j<=v}Ph9*gHQ8srRKKzRJqon=0Or!B|+-V5BUc zV%zz0*Y@3lXPD0LFc4H^+>#zP4ui#_Krk)nWC;3Z`xy?mu<=a?AL_%0LsEX|;Ioqw z6G2iy5J`tp5gb#*)e%SP&vnE0BW^^7<`E9dsAk)jhKKPi7#G*IyZ#+Z#KH6m%}b@yKa zeaPvRmFw$ANsEx4Jo+W2A95~>jqas#g?)sr3mF(4BXgH?%jW3}vq8(&h$g5>ZeR4A zpW9osqAsIBMu^7Q=F*FW?<+H5+$IN%K_kscdS8mx zMfsZ5`{2}rT4;yAf_wlgK{comW zHm)b_SdW2$0imhAT`b2C8HmEnsri@b1%7g336F{5OieyFY2>CF9 zC_b`TUTSQPU@St{E4@#s{bBo<_A_w^E0QmlWM$P4?uD*KlttZsfk@yR|hHPmtoSU6EkJG=BPowB27&euGhdNMJ}@qOD@CZGTQkN^V z2)X*+TyZUhliu^zPUm4=6r;FMi1ro-TE(m*5~OcTSJQ1sn+>Aulaj)zB=`=_(bLn| zTab~~)g@!*O$r9_giQ|~_kFabjl=3^&ziin+!EISq#Ua*HUpnf!ONF5KkQH%gMgUS z*xu5T5Ou69J>AZ|BeG+{L`ZXaF4tFCdn)_l##g9S8jkS+s}mKaxl7{f$SdNYyp@X&{TKWwJ8La z+g*<7zwYxxP$=rWzP>oi=gCROt5@q`b{?xgST8(V#ChokG?e-Jt7x=w^R1mFs)aWL zN<-m5&$tT!VeKH?cT2pM&ZT0jv#+^l7N#OD{u93S1bUjSZsR>9l`uSRpSQ9En7tcl z!s^Fera%qm*_f!g=vDQ?U{}y~*3eq;S=UB0S9nSkC%*5^-#y$^6MLQG4@0oex=ax zUMhqg9}WkcKCf1^zQ2=vr$WuP*X!dRH{3tneid1<^Z87MXx<93+Py23_K)wHM(r)E z-QJK4drFR5X3-!s;ZJwF5d+9}{daV<{Cl&b zlmT6wwjhpQWw3JvJC1=%dkUPd{>Bz8z zsI|G1%NMaK)V|$uoZ>{L0oSi|yIcOJMRek)>CUC39N$MIZHiILK|BPE{FA(0P2cTZ zCH5vT$KLbwtm^j6q&S83*0lDE?-2otAdY;}_WX$QneWVOe_U?~Rx0+xx5kYPukQT2lxw6TOpyy-BLj{d z=6ls5glW#>;%f&FMZ%!y!LR!LUek3p0Re1?2S1`bQGCq4XSI^zEW)Q(5U*H@bgT8H zJveItzf=n&olYVSo6x<0fD#DvLs+*~3V+5 z8%qdcS>gSnp{LglKQ3r@4=@B#-Ex%ln*S36H>$wu0h^@WHlys2)L!&@p9UK&q`lx>LowH z$5n8n2vZ^XsW@A2iK^cM16t(n!u9D(PL4)g0}IX8$TJsCooXI2*tM&`U*7EedG5e! z$ROq}T-Xi`DEx^l^cm3j+GnA=s!b(Y`XE^R50LL$+YJEw|`bhSmc5x_#xeQdxR9;aq- zI*kfDNoQv#fu7o*cj}Pbzda+v4*3nEaLDWi*zjve!*j_B7Yo{)l;^yfvT`Xj(9FoU zg_}Ec@)vYI=VX^*lBD}s>VOgwhnHc4)9^eRF%FV!FovDPuv@j|Gg5aFJ+AaNOcd9d z=L6w@oy&hU=6Lwieub&bhHJ{g+ZMT|J{1#s70ZP>0w)054A#=sntub67QRfn22v9} z#aHfI<-z>XRQPdZBq%=YgrUzde7o--Ki-YX;{5sZwev^a>@Vo*zOE6STwl2e^8it? z5MUyrF)sxK1l;~~j5~IaQNu@@WQ_*4QO0FMAmE;;v%-0wmb zJMZ1ruU~swS}Y`N&hmUkgYmb!Zyy_5p5eBQ`JzVBW3+a{sko=uIZMK>Bws&1G7_=Z<*U=q2q=4$I=S@L#Me8%dLSKI zG{sZ|k78g5ikUyxQTP>Px4n8LuB`)m2?7CTN(2Ict0IdcQk#aOBPp)rn%u#A(k>(Q zX#2m!9=({>3|JI}pFpGs)+cz4W4W5~vTJkrD8qpcMOr;jeCOe9D9mi<;PB+>8+}2{ zCIK^utMeJ&SLDLyymD*~DZ*Is51%R!&6qPvOULfeeGgUSO1tqv*6PS%3_sG-`EiTH zyR@C0sFNDcXSLE)qbf%!qWt9Cn2QIT`gSx@#8C^cM%Byk1arWpFS1CD{gEKi)HKPu1_CphpJuBXi-k7CLS^jB%rIw z_(2V}yB@u7%jnnl=GT8vc`GQar7GRW%mWJ^3JsK?!Kc#*{Vvk)2J+54K_Yjl*Af>2 zO=(Mp`o_9O^}xsBr2TJ}+MQaz8F}E;K-3g;yH)l{rWen}X27E>CN2(0{WG2C?lQ7w zgDF}~=J_8jr}0E&<>n^j@+{I6>$Pev(_7!Vaf+nIJ>MJMRK zN=ImIwL#vII7>mI=lIREW<_nC3$4gCI9_}T8VqcTY0Wwp3j5*n;!|;iyL$3xcq1lm z`z7-xAao))F3&zAjS#f7qTTED&1)O4->x!saM0Ay7zZ4O7^KXK3YhI9Pw2#AKm1VZ z;cJMryO*6WWRr?g&1pFSsct2QaQiv%? zjP4J{lww=9D8Y{f{zqyCpyn176hH-~-7t^`o7@9!HErLFSlC?;e7Ytv25xa56s{A} z3F|R7iCf^)-qPM49%dH(p5t=tI{Z!bvORw0*Cz4{2uyjD0ZzJ7m{C@iU0i%nn~#37 z{hLwZ@uGXFPZJY!pxV6J9aKBm+M4O?JQIAnB`bH`+ra_Pp-9ZhYQmwc_AT|va{o7m4hf`{`g4Tn+p z9(6HjFm&QGo{iNgU}s|AzmVF8(au@u?=0)4QAsH#WMl*Y+&9R6+*|;~5cr~8VUsZP zQEngoN1Ou6v zYy&heF8=LFrj23tohsAG-8tf$MXh|hk~m94#Juu;Cc^$+T24g}TOtLb>W_+w z2A3{x9yS<^{XR`#U=9Gi81>28DH{ys9zEJCogjO%BDu7*Wn#g`n&mSI2w0zMujM=O z5f2oMt;hZf(+s-8@@XOanE$`}F5NV=_u@>>E^2>}jGdjF&{(0n-`uQVB!JMtob2r4 zmgdb)fYYTh`u9P(BKhpL$B(}>jkOSA27gXZ@3?T2TjrgAZ+^ts=?E#`g!B=oTzp^B jg4%!cl`?4mZx^wClIwE0wxjSrqME9bhGLGq>Fxgks+~x#%XL@cY1!D{^#DC>^yt2XTERd z+*A7#Zmq38Ug#`ftL6DLZRR#fp5C#DOMTG_fKKX>X=K}%)yJRUMq9`RILZs+q zZ)Ry@3IZY-mXrdes&atp_x5=Pj}G}DXe~}2gqpY>1Z-MJRTx#0iirXOqqeR&fF?W~ znhLI&DtF@$c32A;u2HNzz*`9OovSYGqT)|D-rm#Bt2G|`@w6vj^V8?6iP4rfE@#kO z2&evE@R~4wvP#KhB;BC|SUG}22%xmNps0f2bch-s%tAs#K}5~wyGGiULDF^XH5CRQ z@9y5zRNcL(u|TL$Hche&q%c8BM82##cqF^Wx1p#f5y6l=FOwC^UxiA^ zXB)A4{Gj|05X^`V!kg9?R|qE9D13ZvWA_0yl=ov`?H|N{#MKVlPy~^3lx(egQ5}jPY-%EI0NS2|E{DnW|h03vA@>`gy9EJs%%@8+UzW%tCB-;n76D zgGm|mn<&J+u1e|S(wZwdSuDcCdCYj{nE2B&dWN(ptM|fRad!4xcHra@vt*K7n~!Xn z)E1bfGTcOD8h)RKe)vd@is>A}75~%O^kB-V&2J)kXaYraVBDdRk-{aU=pe4Aj-R$g zmn0%~ZvyMx{b=?PLp7huV~S_6&BGe4kZNxGr*WHCFBE6?udMRfcrj;397kw$cUa~R z!xO0HK_f2@IG|2#tUSt{9B>bu=64|@pHl~6U~>$+!GwvxykcQE{Sd+Y89+WhV|+{q zu1OBpkPa#hpyftuvGwBC?r*5gUtV5X24(bcD;5alaQk{nCfYZ#-U$J6%wZiN zb}HzN55ju#F=NVn8x{j}@>3E`f{DWNWC9XA5tvvmEUO-Xa&7NCL%_xqJcMumYY#7u>?1dSm)popXTZca!* zm@>C+(zFDs6%Ij=bkcesEi&MH&4&u`jBaN`$kCv{O)7VkOjw3M=M7$W8XZ`TzR(S` zds;7y&Ubfx6Prxvf^mwhiTpos2Lx*s4ND+YVWk7K0zU{Q<(4T$m9VQ)9zvE8-hkbp zM2V?Pxzw{Q;p2aa7I&T+nY5nNo;2ML+&8=SxJI}J@kD>Y5b3cnre(6jW~V?*2>%%U zeJIhuifM=mi?NAOB-KrmHaUcCpw$4p_F|Fs_`@;gv7QZDBmQzAet-0)11CZz`8YUM z$kxU;hlggqW|3x=X1x{UQ}FDdg}&vjmkSto6d&+T2>lp=sIviqff%$z=s^e$VQha1 zO(`mpW6FAzDzp&jEm6~a>Zw3%F)-CSl-|U z*d5q0*bZ0*44Cl2aM^)@aISFj@FDbSnodO$sx+$FL{4ez#2-oWR5#R7)GA3QiG7JI zNljD>H2UfU>OG~YCHJN0s+X!(s^g{b%1WvtA0mDf*%h7^>*XSr8mY;t{VcOA3oZ*) zYg3h&Q=NT3XEdu`l2o3hd{mrgLBYyS7pN}EBi$zV#42Hq=#1z)zRMNm?77#jv7mgX zzE_S_!cn@e{8lKma6Tisuvj&ff1!w0X_?m|=-jf)KL(f1P_Nps($K8+PD`TU)Ut00 za|vasyxzLL+A`)~{}5vTi|g%v=8Q+4%*@Ta+{|j}XDv6;n6kZ6%Gu>oH}NwZ-KgL!DuEV(2#|7+NC;se@O|igSt0l#1>&CKS5Zz;xRIwg zXpuOBU|Xw$S%YVCvT{ap>}mC>@EK(p-{hQS@ni{8l}6h~lhf2PR#}JASw?5Z?$X_~ zyD{Z4!6KX@j*@GN>WU_vs!d}s27k;+o2c2&naeerX_;$tXd*36+6ddQFV-)%XIisz z7@pp?WI1;&asM=1JZDN^1?BOxQvxy3)k zBd=QgAfJ)Ro!QCR#wnADmnESSsS~gBLFW;>EYe{RbC6skvOMNUYayYEa5Z!F+e&on z%ck8)_Nm?(KktMKf$!R@M<4+t!TXpGF+K{d=J9)X*)MvJdhe^Ps)yD>)_Bjf&WdH7 z&2X=fuZm(SWBT`+Cq5_RS+kX|V(s8+11k?WQ(R6Z}j> z!N}?G*?>?xbj)<2Rw7U*KpiRzi2_OjGUc5BVl8xBQ2kiw9@N-6)0ei(=d2F5=3hDWdZdoe`H|AHrJ+Z87O0PQNHcN=24N zcn}`pX}@14XJFQ?H=5cRNRME_ z%+bnk4yxPMM5Ul+FXcaAp^Q`+!;vwg)F6v-`na;Xvd3$`Ccg%~9;iR+oBk_KIg>f_ zFs_xQ%MCWFsI;X?!qZ~Y^R#LvlC2ah3Erf5!?&aK6R$PAW)HO(KWId0sw(R> zTRe7V-oIrMs^@7qYPfD6?p00TYmVvYHb816w0||O++1pJ5IF*y$JbHN$?1GeL1@Ga z=V)KWZmXqJptRRr+u#6QXWgdRmbrXlZ?P|X#(b$fU#=QM%(%08)#|2cR<_XARKE9s za~nxIJMN@;u`{y%F<(Wpm+!q?vn;x7XMeZkQ={3!S?umG^o&2obHD@lsdKf#WMKz& zDE`N4|LV8Zmm=b#%FmIvHp^EnvWlO|SBl$9h1-mr2cA0GJ35})@7UB2RWa3l9`){D zvda9*cC8W)<8f`|K8+>3Fg@}38ayj%lz-ILeA@Bb7kuma61aDyb9i{za1?>N0r|0S zIImx1HPjoaiCv3Booy-|HpY+i8|j3P?Bm7l)J6gR5cUwRFY{~ZFU}ixA(q+pZyxnx zlhfr2ig`=SyVpO-IkY<>70l;2Dqs2fzoio=Sp?>->Fd`um7oih_=zj%CZCSHna4Ov6?e=ZjPONK5%c z>&VT#-NI>Owg+GF=MK+_wet?g3yP=RIqkeAPdkbA&Y6_O1>aCN^Lx9&RgJrEXHo0= zcOX}}8+p@x@e)fhWxi~04W;WXZ?k@9-3>!=F=t3lP&scDFDF-uYiK_b;)^{MjzUgC z6{7EBTm-c5ZT4I4AMPWb*OPp!-7Rk~iv`->n%QwVxUZ!zt$y7kbKu$|w!3;QGhy=I z?(6QhUEIARWaWSVJbb_SKz%zibFq`-m?P7b>TCIg`+UBHrR6+AyG zdk`MZ;TwGtImeouXfZ1x@r3xWFplBlFDy_SGVA^Q?j!yEDOzMdKZDeFWn>>vzKa;W z9C&0TLd*t7+sI+&J9{e{^sO>r2A4RWxKW7P!`ZU&B0mAZu92yxl$o3y$OqsU8Uzd! z6$BhO0tJ3SLM=fc{yGK$p#a`NK)~ZeK%jtkRNzlB7wkW0A%t_m|8oqK2Y!T9M5LsE zcNJqNQ&T%<3wxKxPZ0os2IIF>)pXI6ljSzHx1~2Uu{ScMcei!;T?B;Jof|l`HFYs0 za<{dybLMvEBl+tJZs7R$#|$Jye_i5Y%}1gsr${7X?_^5EPR~fsNWu?GL`1~vWMamx zEGqu*;=q4=Bo;0%4%`e3Zf*2fdCxyi{ZaIH8@LsmEP>k@ z{_aG6CSHdB>$87f&&%+;hyUpDe+}nfp915_56jE&-?_mLd(uLO0|FulA|)!M>JECG z^-dG>Bi2v~aw2k#pkgiDa|PQxW?P%aK=-M7e|Ik;yy|gx72EvjDLsTLG71^Q!Tl=( z*3i$pcMzgtFB5$%pHDmX2A|FJ?y|Y|)|6P7m>vS5U}8c3=k?4BG3%S1=Tt~02=+g( zTp~f1kcl392|-<5UAZWQS9`a0kDmWt(uE2tzw1-f_TBn{*`L|;2R@(Y?*5bt1w~6& zg&YDZ5$Jzj{_s+QEF#h2fj_=LAmVe!k;`Dt#p$-YuZ`PfTD{&)lxkGxRaKovU`?E@ zcTsu{`Qfozz(4#*lCfX+6e&?ENDc`ZB=ogVt2D%3Ed)PF1VgP0Bl8B4w1ynm|yb@t|SI2(3(baSij&gGL#N=0R{Klv&! zV!geHFzE#I`H_tSfz{Q8}Qg|RI79bYiny4s&vyh9anONL^9ZI zPEJm~Jh_Q{ytc4>5MWJWF_)JclZ}gutJd$r<*@62x;tC0KbR~}K?s3jV+AuG zNuo(Cbw z0yGSaU?{Vxe2;tye0*K)WvL?RB%x+4Ny+o+q6qF!&pd9YD|e@>_#AeHlbdP(8E9aD zHh9n^r}4m#Na*RSREpV|n3$$hAMXf_3=MHGZ!d=9M3l{#g*&|-62e7M8yE@4;z-Sz z>AXy*{6Ix&xWVe?Bw`38<=E_2+MV~h37bJC`AIUio_O~k$pl*cZ- z*qSafZVf5K(+g-f9;>UnUhOeVwz+Yb^osgN7}oyhxAKp5kM7Z; zDpbK~us9qjt1x(wY0&I_{sdFOlcK3Om(IJR!6pOYN&O(P;LD{RSL*!y_PRRkqzBve z6bjkx$PW8Q<^ycKvcgyv`X-mMe=OVc7Z|b@6&xFES&j@2d%7rUpsE_f!fgd&hWCKOwG;A%*@Rtm@8vKY$RGt=Ehw^9ld*~!5oaL3j|3S zio{XzygPl}{%%YLhe^w7G0CWeV$Q2{?rO8zio!h<{X(--FkdLOg+-eR4hNc6W4N-q z8iI&lS^B((D?lcbj=vc-AFl3*8^)o3!$Uq9G(60s|1S)c~vbmjBOisqs z7$%mnNd4LREEuwbD1V&5JXX6Ele4ufBiWNB*F>c8>2I@>c?Adv2u4OmIlLYw_V%G% zB?&WH5PKW=?Tw9}o^I*Ly+_}fk7phoK8~*WD1VPnh9+lbWep;}xW5pQDz;mF%;Iqy zfV1BQihI3y?mgb%^-#|?SVPGwe7-#n#Br|H(?v0zZE@xp=JRwBa$8%|d$_`yo}24A zx&qb+pSy#;l_GRAGVQ^jjJK+&yg%4G!~8D?%<=Ag0+#U|rKLD#i)ZUka@oAZZgwo2 zYJ%s}BPplGgH)Jb%*U*nKb=r8H3q}&t+l#}u)gAD*O{?l^V|wp8%Glggl`CfKt%0~ zq-?ASVKW!5_XG|Z8YeQm6=zQSfwJ4#Rb6J@Yei$xX9iA|C?%kh(-Ij(@xzAzOPSqz z9`$Z~R&_HIhqVOgB_`vLmpD?&I9lCS+QE&32QA+E%}vAD;H3->J>m1ayAO$ML@U#Vn{e6ah`g<=y!f^$Zm9@z*K2=%jpWsnO)7aKxjgn zNVqKNqz|N2CF+&ju{5eBK|9FElUc!HrG24DoIKS*LPoZ>q*@6%hCBmCx}=IEkBHaj{trjW(mVl<$< zC}6}DI{bz(;SNGV(pw~e4dMsFBA(0X{TPJ2!E$ly1CC>sH{64hR>ls0S=*F434@3j z0#c5_9ytsHr-Gg1u>HkkB-vKIdJP2pV6m1Z6p{Lv{C#f#s?*Z=*;+@^2NDRBZ>`+y zrmuY~yaMBzsH8U7!!^MUC&=!9hVf@XFey)CMhZ8#J79b_A5)nJ8f|`FLf0+TTfSs+ z!Sy@X+Mrt#d@~yh$6BM)Zlu?$Zyrt=1&L#2{=sj*W<<*jL;+f-AIWr3)(|qS112aV zJ#Wu-B$r2X)?dDtSDt7t!e~_Mg`B9ieOe8KLNb618$fkCTN~7ZQ&5;FQ!6Lre?|(3 z{&coRzZ9B8LJ|y%MXy|E21FDAQrUys6TB}x0ghmMAfp6}x^v|VsN9-?h@clvKfjsw zsm_hkGI$A1Wb=tpP^@SQ(a*NG>)Efh6MRcc!|9DeRwsLK4(dH~9$e5+O}USlqww=H zy+eg1e&c|U+5Dx#rwr}9#0td=lFw}eqp5fvQ`(pulDWT+U5Xj0CpFjyg40-^2o8#e zJ)DsEXN>O@@ZWA{!XB$N4&9*aq3tprqWAIfAt11uMt-`%tG8WVW3y)Okq-04&pz+e zadLqkMCoLe}laP0@sDp0tWO(u)gR=PyDQ&~oTqQ3T@?H)s4<(9GNw4&$M z0Bwpo3niY+$v~PKg9!%AAr}Ub1XgC4@qvhFSdpyjvf}Gk#6ZlbZo=trrd#4shX$20 z`L@C;Y=je$R=ZfvdhPCr_}G^54?!<82BE&SBp81KB|nHxYJY~&liQQ!KsM(2`3^&Y z?(o=<0NeD#*;2QI=?7r%b={woZm&<4-T_lD%oOl#^mz$kv!c==XACm1k!<7L`JSLa zMG69waW0Kf8<@rzid-0^S&hqPW%Qjh*~J+0XX(uPB@tn%G&9(3i|5m=ZQG};nng(M zWJ3-;sTQ|0AI%Ovhg<~p%Wjyf3*#@UiHS;N)QYjtI_>Uy!vzuw-DQ;6sC^+(gRp2O z;SI0xX6eDBX$`@~l$_X4>`-}GQVHnUtPdz?Xi;R@YPH|qeVYtYtkjBPO(g^-tA4$J z>*44?ga)vC9daO1qqDkG{Ea~guLeP+SILuB+T5__n}{G`937qTb-+e3-hZ(Q z%#lEUc%tFuW$dU~6R(oxq6VwM6vQs75xYC)a{1NYvO9)>$7@gtcS|T!re1c5B20l< zVt@of8_DJK{2mNHNvqlW3DapqdAaS5G1*usBu4&NU8COOqCjE-n72Zu(w9;d88_S$~Ev&DMh z7GME%I?d=23RQX?-)xuFw+mDtP&Ol9AY|QUE5cWT7(U#iWU^W%pmt#5>YAnnLBY)=iyy>YJWj#ZBfCXG*Q|Z%3lT_ofhiyfxI!UYt3OU1I6w8`@Z zRzN_1>Px*2)Uv=AHSUu9%1XL2K}vf0>+JKDAFY^NFvcRT$1zRz>vmpaXfYP$>T&~W zg(m0U*s0_Hpi706ploPp39L<_wnH@@Oab4fC&7|CbMp@~v1J}+<_&NMiOM#_c#Iak zyuFhk!OxJtwmX0pwd}0dk?3e{P~(&wAcFGnZ*2;>?cg!Tum`-AzR2YG$KN*vQLd z{*fZxqqInkzTNJ~s$t&L$W>-W@pyXp+t&xibnqFGELzb)e?w^>LNHv1;%9!15gKxT zRg~^eV2grC1lXL;8>YQK2p1V0CV&2n>f=aMo0$i+fY0y{7K6|5Zehk`|6PfH9mJwY`V=##k%;|4qW(HD zj1819iG1o-`ZK%%$Azf?CqpmDC;7Yf-&Y6@0wk5fcm*mt;P1x$-t&kCfQkySF);po zdf)^zBxpJl&KAD|`hSV+zYeG=fQkl6N+kcllK>%(WrDWYKR6)gj;D}I$HT?#^w=V2 zU}I;uo6PpELw^#1{Ay^X*mzP>KbaZrz$Dx4_&^8Y>gq~a%qA}Wv$wBrZg%!?&f2fK7zm$y2;RVA7+SbnjUx?J;s8)7m-DWy z6lrv{{N8xh&lYEG>BLfz|83nl9}Jo0V0VcB%VfL9QO9Sua8T3nOaOV`;bc~xpf57Q zVU2gV9DsQqFW4()ao+%u-f^?HMHK<$lvHQn@y5DJzw1Lar^`NwhqBr@K(_!^S@tkW z{Ev2RLd3HeGd2%KWk{OIwtd3i=^IO=o|!FWfyJZ^kafGmN}z~}2@l6*F%w>Ee_%G9 z4p=vyuduADnm9hemz9$cbU2@{c47U5~BgUV*x7;0opM6n<}R-X)a`EZGOY&g$okmWm~wTxHm`?Y$#gtyY;4x^ z6}l}>NmaT$k_}Y9wvf_zaBL3Iz2rlm)87rx?=kSUAv-jVPp0>p)c zTA;6;iG#smqq{Q@>W)}|sC#|>6Eo(K@d79rpai&{u2@3Pm8n&0)=qzwJ2H?aJ^-}+ z%}q$58$chLFV|qus8H18X|h|jn6G#TUpW**I505q`0ya4SlRpjfA<)FLKz}17D!T_ zPsfVOjrdG;XN$FPUvJ`>Ktf@pf$^HJ(uD$>&)I<2fFCzB%;Vfbww3`9X+&Y$=K$h3 z)zys+gFF}xXb5+IAaZ?qe_&%}71Ei_?@jAOz~>2)XCgHM@D{;tOcN3TA|ghK==Z|% zuaT>ZL8ahq*akdqb_#kqMgQ1(1Twp^MuCm5!E$D5sg;A5;AoyprZ2e1Z~t4RHixj# z4^>oTElfN-?G8`6Ae%g($zO#xBV1oz)+Ho{h~|&heKD3J!i;Z^-)WA0GaZ4v&Jgew zsx|3S%=fO5?{eZIgHZ=pcL9-%v^Y z1em#am|`w2*HZ;KQLu}Y{QUd?o4&lh?oZJK7=99|#4Q2et2*vU8cQ+IaT}y`U#6JZ z*)fW!OFwUPp8`QF2G6_+z$&wcGv@X22YezjSd5x8nwJl)U5eT!*6JVKx1KI| zX(mhCy58)Fk2$E*;fX^LgdL^1V{gsld3zjeJhVi@0w5PaZ$efilMdbu$B@zMx&>yZ zmZ<1mcP56)94RfKHf)GPjOd|ZApDA#rwfY)yQ-+X9aFRreFfhixV-C)&Z z;BO2_3|mJRqW`=9#wtOVq@|{MjcL}{hy#PUzAi8&E*_JOOhB-^-;7*zUa~=x46NkX z#Dr=ZT+u~r8#1+&F8~W}Y)r1tq?lS$$qsY)X7lqK9JqK{Q648NDJf~;d)R+;5RSj# z6Vh72trw8aBED4D)S{ll+d>-?y`R!IqPaDEbUJjkrU ze!{TZaoK;&4noNd>kcOU_uR=_8YPNSDk?AIS<5S3_Yut{|Im-m#lY5AA|HN1|MP?( zSSd+v_6OS!34cJV-+O5{5~U!^ZsT$C@*E<$gmHx2&;Ul;V3md{kt}g^KN2F zN-=LJ^WUiD*%Kn3)i|Bi^7S-p;^s(WXTiqCMyJ7Q3<$OPlG!yp-=tDSASPePtRqh$u4p(05&dvvN3GyBRxk)$1LuKxGu-Db>A<+!KRvvLx5=gU0X_e zJY|AcA^S}eU&`_;ngye%sE3jKtYBe0p6idK9<)@?ir=~6fx?b35 zbF%=y&vQv(tnBpUBvsn9z3Md^xcpVDfvU;(cyd6u%zx*>Ow`?_-4tzU$CVZi==M|1 zip}m9I?U+@YKb%{wb9YhCPLKYGv!!~f8ZJ^l*!R_wxduaLe&VvzKxU5SG$!!455~0 zVhKbjD0|3q=H=r9&ZdUQJ8us^h)~Q}Vp|PXpyJ^8)A`tQs^x^@iu-yzeWN zLYpk`_b2A1+ueP~$~wDg?D$D9ObbxVP}h17X7+g99k3=ccw0OhW_}Hfy&0?@zLw(>Ygk$&;URRfYk<{3wZ9?4eJHm9o_`6aB?`EwsTQ~0K|5Cx{3r2QVWH2 z8im8c%g+Ak^_jd#`sM6L(g+}T&&^yVWv$*fSaY8t>t=>`Vv*lM;UDz>+zq{MjWHA`R}lzS|_L39F;qDs|94xb1k`JTU@1yWI z;-r@wo+ctpMpezm(vN<9Gk?16h>oVY;8wTj-Kw>mxy|CatJZ2jWRF)}{ZU4+D?1GI zwDW4~OGnZWOWwG7mzy)K7{4>1cr+EUhl(D^`5iaIFtg}Ca0kB zR3X;gkvPWlp<{$$dlt}Aj#{Y%Gw9$zSB1xbcNB=GVmnp3 zm5w3a%=T*)z_Y>QFryw_Qp&%Fi!ge5qytu==s~*&A|p5nDd|RAcMO<<43I(r@Czb^ znVH9CQZFeKn+K`_o6~ma;oK$`#5*0t-A5xCkUZawZvMp&?!!BCj*I>o^MaW2Uy<0VGjOWfAa=L)F3d6(~+N>yA{Z-4)eO7 zV^^fR8w#|`0<@rpg~<<4yVOb)Ef1!}ieyr3=gR0t$%YjZC>t7B`lN!ts#ojz=L1ZX zs2RP1Xsg-xji5??nD=kQBbW|jAubw3srGYqwL=s}1{+4@>tZsUHUUEjhpm=?d35h_ zPazZwhHNDw!AdCEuS;87N@Ltmtfth?#ii(hYxJ{?O+1t+4vR@_G+GIXfykjL$Ia;? zn$1jWs=?K-n(yZXY{fexxj|vs)=7_2CsL@&0~)|1~4PTIZk+ZBqSu+@z}7t zm-9>m<_^O^qh5qQm;|mo+BHJbZgDclLC%42Fa`#N(Ilo#5uKTnG6NzgPiqU6!`=@r+_4n}D}jU#FqC*oc9akB@J~&afQFW5YLbYO{+OU`GRrd>li3 znYsSDTW^Sv(%mT^jYbs-Q>YNlL0jvGNKn>j799xXPUOjV6%-JDKNsQs{L56+%RmcG zfpqi^-TmW-+gfNu#JKUAMdI>O>Usl}o~0g^0?B^D>3acFuZONOjpE8m1eY2^#h-nB z2$Etn?ux-EsTKuqub=n(LW$5}^kW&(FSG>_z102v{c9SW_Si98?N?ig?a8Pll~5`s zu@c2l0)7PH7~9z)9;tdd`b{(FQM5}b1|q;nq*);BO&5(o;|NGmC;Xwn6{ZQs%RGxk z3`OHxEjN?f@9Xt508VTW346%_!dK?i5D-%vHF3G+Uxm8tfDRkk>r_uw@;Zn2l{M+oN$2VZ!F1bOK+D{k&7ad$d( zOIK2px49mL?a(mNovwB8SAh75e`6sSFc*hVPprEYAQNwk(PFo z-DM&ja&HW@IGj%m^il7xEEm)7W&y7lVnF4%&2dv{=mX^6)!v4^(eE* zYczq8DWHL9?cRtzjHE(WT(G^=vR6ibn+R4+)zQrt)VRQU0Z|zaS-JCCOb_mgm=-sA zkH~>=(~tyeP#G|SK!e89cqtJu8ZhquYHTz{UY>7teUi^=^{R!%5ZnMFqh?L5#T1Z+ zW$2*{c@IHCAx**i9x~>2v9_`8lWk0Nbn;P2IgR>TADsUrEw81+fI%ozi?A{?ufWV# zu5NW4o=@2DWrefb57dM;?drFs-K?4>bMbRdo<(Wzg$QPQ^VNp>7%kuzrHOU`Z(+&$lgRwPbN&=9FPJt z;$r@FAcj#9?I&a2|AmRs>2Se5Xy97&k)+`^32aRpi(UsJVq`1p!we%5zq2?>@>drk zap<$gDIUyR8VpMdDzoWSy{&ib^U5?y%+%1`4r;>wV->*O5tH%~h06vy2f&PQ%})1* zH!9;*lx!T@vq3@#D#<7SUW$;Wegg!0YHfDXm3LE9#dY~iO5~kCCn)=+Z;lpbmRchY z%dqnjFF{A1gmszNgFbqn9>+|4qgrjS##I4j%r(|~obOqTms3g#UtL&=g- z>h$KYDz#BQgI!8P!|h~g4A7=9tIwx$dAYnFZ8)71`BV4z_k)ta%kbz)$wqtg z(YXf_tw)lhfT$=K1Fg^-A_*tZ(J{yzqEhFi z$j1A|#ly)wHNgI~!wvX|LXW7^@KHonx;AkZYZbEMBWRTni6W_eP{o$q2?`mzL|vz8 zSa!hWJ0yWiOXbM_d(Fatf82l74nc0zT%3ex#-HeaSMitraYu9>O#ZrV41N3uI{g>b zQ5NwtleMx?O8L8Oe<>s2$Us$~c3`3ZP+wwk!B~xzMIu`Np^V`80f`iN2Q*HIzqi=m zVu=6j?}~7>X376oydMVnossd&=qCP$+Fcj|R5Ux8PyfGd5QHSk%_}ZW0S)Q-tAyYq z@^D4v$D?ZD%EOd0#SdqpF(^K-gj04?0bD%nbk0})<~lluo|c+*?q6kb^W$dco`se$ zWcI8-uIGyn1hjsvU(tJd%T;>Lt1e#cy3)rMw9qV^#zyTBlIH%;+UdrEDV)Mn0n8vk zwgjGlw_QAHN&lGC8-teat;uSR8!(+*+a_0%E95$EnE~V~;kBaTki7b>QU(s=1CS25 zbUk9XwzTv;>h$Tj_1z?lQ>Tb(*~+-F(U=kxaOP(z0Q0B|Th>I00IpO$ayUfGp~ql(yNp zO>1DQ`dC@c$5PLq@n7d{UsZpIPSd6cC0#y@Br>XfkUoT@E@k?Uqe-7E_dyIn?VT*4 zoZMJ`e*Wz2EWo1YI=zc8wj>~-pvtX$A~FH(4-b$TaL~}uuIQG`Gr~~!*E%Te++<}d zs1RUbd0h|P^V7@HNF}1@rlzvkZR4$!(w)VlaEq&RZU7VxP&G?CGIETaKn{S~J7_XG z@6H0deNmxZ$h75biDkLE?c?=&waQJygh#o2D0MDBsJ> zGopnmk}G%{wp9-lr&nJq!wvCJeN1=^Eqy|SRH8WZV!Le=rHnsp(OBv zMoi(j>H78crVLBB>nVg6?GmlY4Ik28{f8)XDPCdO_y6ejlG%b~W2s67gMA?%TbzD| zp$$#CoGht>L&BfTm7nE{UB#b;6$$Y8`@Zo3S>`fU9kJ6DGj8sW(~3-KA3oOM>U8a~~*^5qc%lwnF#L&b?4?F#_t3rG-Tzy=alA&8PL` zL(3f0D&y1eea@PWOE*P?vsxTfYNa;(#bYUupUTb5jF53~R=sE0x2;X5->=oRn%1tw zD(HXGZM(t^dNvdHkcB7OW@DS4RR!@ldIHr=#lgeIHS2*x{C>2vc~G4p_Ss*TWq%{J z>G7C_L!Wpnb00yAvvzpg3irEH ze8axnmYHIOB-)R#EM!wIT|VIDYUQOxMK`Z6pWEwwULG-ay~fA!085Nsm5xWVBH&y( z-C%qH+*y+vYE>H5hA{*kKt{~QQ0cci6desG5tFS5AkKS2a|?_8=_0sleT`>U{19K0-OjxF@qN!X2uM=Ez+Xg!`O`BpjJxUSKj%)?TV4Sa*z`wX65r?B zk9A*L+S=sOO_2JqS@Q1AUI25Y->1RIv{*_7y=`o~jG!Qhv!8WW8$IBcGM^lOR+g52 zERt@JPI?7$X9&2NfXE6YSvPV&Uv4vb0?0{>^fLNzzA}bgiN<_f$I#FafQ|=0XCUo5 zhKD67DTjdIo98_jYJ0jeFueiDd$UC{93@eN_IH;>PpM3#ll&&U&lcN2xTjI)%vUX4 z2k`Q+1ieYAk&Vqtop}tP_XH@7Wi*)pen8u3&$`_;ncU6D5!~g+uDl#(3wEL@V_Aif7e&}wS`%`^@EYUA19*M1z zA5;_-^{dt4w{_-3`|MzbGJt`(wj2J}xuSz~DXHE(SG6Thaj(5r=&2#irRGT%>1 zAI1l{ZX&QogNJF(+z3zkZ$qX6h)QHQ_|6%Zk?cXVcScPYa$`{F4z-}YE2?l-I?DEz zb5|u!*~(R>?Ib(+x7+~P413>{V7{(3JNh>G=rn004e3k`d~iAl)K%8$upnP8srNq6 z;b#2ko%MM5*Z!aX^^9(8_ZR(KUfyhRb<#RIISF1*tg4ERnb2-$^gQ3-zXtL+OD4SWB*B#9yvX9&-<- zOJNDsTU!aaCB=P!@@c=@jzWKVS63YCaa&-XWAuz*h3@@2jdg7nBLl)S+lqVmOSAJq zxjWQh8C0Ew+E1jBpo5N?8&~bxwZU3lxncqZmXp#oP_O;ET&;9+{-r7K*9&iyRnp|l znAh6@UMb0c(7$A&;Nkorkf1OEbG-QF`)b~9^Yd4!3T6JyrxWhEQkA#aQnd3?gHBH8 zT^$o)LUGA7X49<9WPtq_J8b6DY1K$cM95~YVnM*}W1dI(-dM8vCF;lU}#DIhsDRh^a9VIjH}XMx7j`*3AmUS3YB zdH}@GngYN=0r(`KUPKAmA2t9F1$m~@a#LF_!*vAZ`&(?tF!Qw^Wp)|tCu&b>xLoli zoB$8zJ(NkIUu$zS2l6XG79naK&WFN6Zl6?7USD6KfsNer_O`Cuw-0g;$n9WJDO&tU z#3>>15v}=zNuL?Pfe5%CX%%ycd^`c?eK0kc5ukiwbZmG5wldiQIyxDl!D>7uXX&m} zAbrro510mmrgpy@)5EunrqxMm2X>!#2NK`F^`V+=M&r}(qeEITKL7$GIBR=lH$Du^ zgP(Q`6Xn}EE1){cra1u~fqntbK&TkOr)j`6w_x5|HIt&>Ei*asiR0B~4`1luh{HeQ zcCFp%si=?|Mk{T$dd-{7X;7dpOWtrzpV5a{?y40twTI!On@`b5k}Z^-gcv16^{tgY z6F0@D$i5z3iBnqv7pz@SFZ_J!MaI73lcCYq?chD5o8kMGP$rOikMmh$rqrDb2I&`A zPlD#qKZu}nS<*#x)+ee3ozsSco`=9`~L+>b%(iAc)RW9-$nYqG9TwPf~R{c7Q z9^V`eEJvZ#&TBHy#HTESKKS%{tOfU%PD+#JFi}?o*M<~5P?3{6{gxN$ZFKetrFy|= za7qHZMQ7vNA2XXMQwU{P5^-Zey62oisk`pNI^)53r%2hJBK)p9?`poto+H7yZu@gYNS>~?9j&y?AOp@By;`Fpxr}-8GWd7z z0lnd35Cx2)4M@@T)g!&}bOCvC3cggo!SeHKaOhdUgy5TRJj$O!uWMqbx6$qIUBeO= zrfp`;gOjjucZNYs1GqWjzK$>g`T18rU-8-C9iqwvM~Bo9+0no{(~%I&(a}rTtS?`_ zcwCtYg!&5W1d{q2L;-%3ayN#bAErh4@69K&g=fabFuap!?kGd}%*SQhnL|C)YmIia8Y%$i zFX+1>pEyzhK%OWEggAwWwl=)WO@&xlu$FW(ng$95AhQF3IXjjC8>(>e3sbF(O0O@% z_)wKcKwur<{N2uTxk9Aa;n6K$cI%yCkN}m0iFfZp#>e-*J;qTY8?VtkFBnOt zdm4z?8_#)Dh|`ga2dqtDUt?KWMy?k0VeC)iRL4TScQ!Zuu`sE`yf)@5+s?s<1kfcZ zZqB>IMJ&fNxft|2O^l5ZJ|1)*Jx`ufX+*7pBBgRj zM`i3X`|((>L5MXcHYP)ke{K2J>Ha_vFyg=bMK2H;9W`2z`F)YAF z;GtP>zW}}h<2scO8weU&epCk}u7tW@FskU<33@Ag1R@<40E>dh&0*9<_!}2-z^RBN z#5b_Oq=E(Y79A90_tR6j;snEaTBAG0#m_7$If6+vO?*0hUc`wXsunSFmvY|GBz=bh z)vhSCXjVhrL0JxFn!1eHr?%0pu`IF9Uh9(sFO79_t z@77BHcEkc-SSlQk6rx4Y>XA`lGHnMeUKA#PiroX}y4|E>*;jWCLx(`rrbrM z!W{t$2Yh{o!%n9UNJ?}S=8{o0P>`dLLdnU#1lv+q3Cmu`A>l!qk9wkbY59PO z1*CQp2?!v%di2I}x^fle4>x+49xIAU--nL7(k{3D^AX;-d!QJc-}Qg{yILur!omDf&tw$R4zrH3{Z|v{B5)Y z)cOrSu&ev!l-z^8Vs{k3zU5`@74^j+At7vK;jPY2dz4@*7iFhG5}Z8s_E;u*xDhQ; z<_{ml7quL`4YH7!H`RL|eq^OM)Ieu-=e|9EdA(x6SYCI#D6xyhKQ=ZN$YdAEGg*he_?1%X6_KJ*(2P&y z&^%*M3mEj>KXnZm!PADNF&QKNN>|p?urNx4`s&G8SW64V1*mI7q~TnSR?AWkeH3QN zrx%^*_YgIf+GURcN04*|MzH3jA9}rnu@{G8VCxW^RVw2AK>A2YNP70A%N*NrLEZqz z6o~;Xbyni`*~$S}Uo~Jq05Y7hNo5AH;83^zYym|KUrzD(Jf9b9Nhho0lzQzz<2T7Z z^y1%<_;?`Aqi>2!e$BG-aX5zxiV4?pxbIfJxqP%Cra}-QtDPPkx8qIRd^(&deycGo zXme45Fe*CpFJ~DpOC8(lj{csGdnoL)hXp?ZX=p}5JN ztw5r!d8>e(EhSv_o%{5*07B41>0u$+P=1NyM(F>c>?^~nXuGxn0qJf;x|A*frMtU3 zMM6rE?vzHPRJuV@6lqC8kdP9j1yMSr<6Ay=`~Ld)!LbjN*?WeW>ssrqrEZbKSQ>B` z^+>CX;1PB6+spkuP7}NE&>O}gvZ%snBTpvI$w<(ptL}?72PcpgYWr_49FE^2yBRls zDdfTN@G?CA74DBeaHcaiWP%Ia7wv29mrrr2gw?Ceb6l6!w|U5T^^B%_J#PkleNX$! zWo=xg>0UT%u+TDid{wpZpc(Nod_^%k!^)bU>EBB(x8 zzy@exqoa0&rKNA8sr19*3GVEi*-l0iSPWe5SZ;_Gf
        yk1}drv6V+uiXbF{Iurs zSFYmdWUSK1VO|M;hCg9cpvb>YHv}ewDiSWA`_r#Q`rAR3+hK)%HDA*~vDfoLR6ilS zO8AUy7^gcspI!}s(m-C46HL9Q+Q?T3X5%wOoXqvmFr{w<2g+Om71{P7^4YD*chM-{ zhAQ&pww)s*Yg~r$wTdY%7@s&=h#9kDE&JLsEsi)W^pCBV_BkXnb z=x!JKVjy+e=@%Z?87h=9q`y?K& z-BNcm>V3#SeqB{sH4dBylulNksJZ<$H55Z7SA?ooyFAoQ)*D{;E!*?xTo>_)W~pCj zb`YmdH7HVCXnAo1)35Rk#v_#{Q(cMioZB>lDqo}h1~W!EqBdr#%HNMpiqE#ZO~+4* zwiEGcDQ()@7V#w^L><0(f{r7iL$&fJ=ok1ru<%YI0r_<@HeFCQbL*0dQ@d9#^~67x zzt3D$;Msg~I5*SiQP+)Sb$QVYT|K_LV6mV5wOmP6ZG*x>bu%!m+4|Jp_KIa2DpnQ#xn&5VcF(vk01CA7S3-;{O|SUsE3BJ`=L?#zf1XymCgz_s zdF2XDf7njhgNx(4@VVK)eKbMKy5b?NuB8>DIGbTVGVZaz{uz_IQ3hX^kQPCCb)HSE z^C##nn!u1NAaHIjI@21UR^f7X)T%Gxzxl<$t1#h>N2I2bD&KyOz+>~+(tJ^UpvR4>X=`<|8cMW)r6dpzFa0=C zUe3Z~D?2^gHvfdi7LX<2L^6dei+HAm%X-53nnp^S`1Q7?9evFDUaQj1*iu$a-R%lh zGW|Cud7ApdH7)~hC1%PnUIq+`a^K>2)GzZ~n(7*kj5l-9*Jrq%b(FGLR`&e)8#79= zw!VAemRe7W?zcp!F-x1%p?46+YmJqT?L@qwtaef2rdht7X&JoWtX+|`M0b64$bC@v zFHbo;U!x!+q2T@rU?1^-DdS0KeH`anAKx|sK4;Dj2?;*Wt^%#LdMLXczIbIaXW6-d zauknY$1}ZtLs7lFF#(X{MPaT1-^;WUEAAe3v+lvi{EH+ zmk3@a*)g@XzgyhOs>)^4pkgJ=K-Wt7B|`bg_sdb5`di~q_3&}VpZHvjY}&(HBYDrf8ijXB9cy?3W3 z2}$W8aa9g3EnmVp=a88QGZ?9Hzr=F+SM3B&UJ*A%CU2#3+zzZ)EI5;XvJ)?dqkkHe z!jyrohQ{`WH9DT2Kv_DBv9vHFYH+6QvDQf_%jm0DeEll1vnME5dz_hRbVesW3H0V% z?y4ZXW_`k=#h82}#b+^Fn9RN*fSpgLBl{0sW1E^Z&DboNt5X`Ph}xpm3X9_L9X7_k zUQX7FDE-S)sV-?_QBt*i9@o65Oz)B?9?vHxB;6zF?1>yPHqlnzx6q`+dCOPLuE} z3xa~qKg6)Vs^{Stg;(shz}>w^rvhVS(jBl>odc+04RlWC5O>J#D zj!*f!t%aQ9Dzu1>;VXep9gS5y;P|+K6pEbo=@nv(t(N8rIhSmtVvF!_>5GNe0^XZ@CqDz4*^B zY<~d4XYa!oMN_o@FgRx%K=_<-Jj$5(i-`E+*Z%(xFMo@dNvlw~BrGZXM#)C-$$#En z9I5qskoGffd;1?pT1XboVr#3zyubkK^r;6))Tq*M z&5ylLzU|z-pJ|rq4C)F6cXxNM!lbhaGaagHE0^bw9wlaRW=RS;&wedsscU2S&nd$7 z2@JGtP+y&EO$AHv^c!cUPln*P-??j<1aeVqb)y#F-sKOZUmpNMQ`#_L8`9?CXjTD#wdn){B6O|VPceGKuQ86*V z_dLJltN>!z%Oj}`C|4i;7}e67u=`x2p|3w#>8HmtHTEvt>+(WmQ(l&mtOqo(30R2i z>@PvQ_9;dI6+ik9VBX&p>HD5P)hFZfiCbJ;$Y>xweUDAShl7qj4#HclLgQN7mv=E&!_{WkP??FoU?(#y0;7;7>Q`e={8!!a7iD@Dj@0Y4l}y2&t}fPIq(v}h`T5SaQ-EhK zw4x&OJyD;6jzRO(JxI&|uhY!TOd&`*E9tB=1K1ED8H4N3fwl3M3K}Xm{78|Y+3Ps8zD7lw`$ov!);B_Qpnta=WuHpe zlJwtyNb>ZyLjfzzuEqC>At3lGHEYd@ieg>t`Fb{u>)hRq#IX}g1aa}T8?$fCX1Tu-Y_U=u#Ya$|k(%B2AMcZ9eVi%Qs zT>9+~^m{ZC-}0o^7*#Sh#JwX($}hL?_Z=%MJp z$uAj%?C*sHzL+nq0r5XbpVwIT1`paVT;2UZIFItDv?K7jIK@Qw`)5amHE#}|VN;HO z%oOqKiF^6VqJ{OxsDLPNuD6_OiV zgY|Uq?F0oqzMdtjvrhId1lgYu$wd`HkVSv;+B{~LM1*EGieF>9V|}L4 z;c#;U5_OhV>*Yr{b;|`sW4$+~h|f&wT}W<=N7B7=bas9Ob|1MOl#GmYKnmA3FOaBY zq@{D^k`>w2X@bl$5i-vZuQ-B>iRq1Xl@4lBl}i;9cIKejbtKM&Kku-w$VW(Osv&L- z_@0L!uR78Cv(eEZamD~NiEjzIVG{Tzgjz(-=Jgi;?8K9l44Io7Nf?6?MB~DEv6g znU6E}f7fU}8n$p>e0<_0S_Hkviw;G*^wrn89%+CZZFk3N6^xhP`VCleKUi83Ka9ZH zpe7=UJOg6lSw_advu}8FQ{Pgm6>hmn*MjAOHZKfxu3cr|Txz94bo3p`mFduZnQ?S{ zeC|Oyi1`EKS=ZDJ+W#pujGaHJEcWrH4JUn!4Y|14Z=w1e)uaKh?F+L-dTC6dtkd7>HCizxAW1GCC%O2m{Q>}Z7X`9Q9k*2 zUUU05)eE&e&6uq+$WeD((;#>f3rAgzDM%vy)`l6hi#8Hz!lnBxz!>&2WYJaVef70diw`dbc zcx8!WQ&Ps^FS7fMGnBIiMA0}E1ilQ?dU}JOy_SGZ00|2z*{YcRC>O)lm$wFm%3i>n zLg>Kp>FF)UNn{<R4o*!FvL6ku$8a81N} z669SiSK|?BqD(3H?2^R-f?&ZPEt{y4i=Tyc^@dps(v-v!FnfU%EmxhLx6JMBA2<8q zpXvVLyS@LVzR(-}|9E>1(DH4f0#^FdtDP#2LJ&igUT|A^1R;e%$GiIV71o^1v)hmG zc`VB8?CrtF48*Zvljpl4>k>w#6|;s13ze;<<0V?SyC4gID}ZK%qGR46Eho3|f%cas zybG>7@Q&Z$;X14R5@xIqf=mO)lA5*?4HPnW?_oy0qyS6L-uqQ64 z`A>0n+by~T66asZLEFrz4=&C=7buaYKO+@%F^6cK(*$z7d2kkz>p~XRW3^hR>DMSL zSCIu}UBFAV1~ntd@W9RW6KpPFA|b7XDn@Nd5+$)Jw{oI5b>Nyb*bOg&e(Z3^D_Ys} zq07Nx05t_gVcwGj>A15r;jxc{gNNYB;oxXoC^o3IeOg_;6Gt_TLw#}8UP3~`s#`f> zO-q#)@n`_d9#BD$GlyABD}z zxt59B9^9-%al zkMGrfRvnDbn zNk0-g@`v;Df|LVnl0uM~liCMQmlAdCv2*R?6$|5q zCd;lQs1SV5$O!Q8fPvR$HOqlb`@a|U8$-6OrDc*S{lv(~`1m*m4$ege>TqOc=Jk}_ zoBX+Xc_Cc97SG$Pu9#up;Z+na?H$fz4vmNq>JBh1RHI)1@Fm-M?z-__DaK==e-~N| z+l2V?5!pQ7?ZHO6&CK|TDH|o=Qko)>lAX);Yp=EN?zRg!U96to7|YHpDM5F}bxN~# zsgC^5r}M`^`u;t(H;pu=`RWbr;{1{l|8E~RlG%!S)AZhH{G);VU*Ro}?C-}b+o1is zW3?4EXy0J*(xGZz=RdtH0{R)zukMuSO;pIg9E!hgjU#2~a_^EP|L01<+Kd4*NdL#v zof3cRZ2vf-FXTO}@M0?d=K_c$iJ|;*ly*5S()_l_ixNV&oQ}fy`)wEul|j~`fNR2U z2g*YKl^fxwS|D!!rQQIbbaQiYj0e2AiokJ$u*axO*94-oZoMG|TP3+`@-@Q$cBtYb z$fL^2%1In5`PSfIgBUb}Mh_i28*!y-&1)bSKZFZL!vq0%m_dLqo$TQm+5X zOL+u>_PMRt*p;xUgr|mvXqcD|K)-Wv-~rKrs;Umn&CRfA=a-c&E$w+M_t|jKiszX$ z;($g89wm42K(XDQKYxOGX%zS|u(mu}8`qdOd~^Rp>*e*S7C(nvcCZSL&Cb3X9pw`c z*o5txOLb-NQ9Tsv;IS=KeW6ihj?cHad0{z{zvHGBos&b$MvkTSz!lu9ay>E-Nhr-T z{J6@+dw=yDQcf_VHPtKBb4F6wDRHjfLGat3EE)_9y5bZZB369BQt5edW+2xSmMi!B z_B|3Ne!{jBflWw7#qXTi5p>0eosDh!)xC&!kTTGYAn1D(Si7f4pXWF}F7O`489WAu z_rbQyGv2!^;JSNE$_Zf;`p>Uu$tfurHROX(Bl1kzC{xHiv%0z$+=~BXImqJwn3^8E zp`N`Rj{R|MqLM>BdnlQeHy@Su==Ag|Dk_Mb{dd29ui}Hd<>QOn8=IRc+Ffi0HEm52 zau7lhA%T*IStlI=APMyDvdV_JB7HYEKi6uBqW1lE^O>p9_%(402+VL12`bDs?F4HT zz`kQ?4P7R94p85^EYLxcMYy?*&Mh9E5g@g`!pCX1%F9W7&RQ_#)^yLJ$*M;HAB%*D zh|jhkd6>#u=;4pffoHc8*i66VDn2cxGZO}LfL&W)&gH4uJwY!=#}g616YD;r>9n*o z>l;&3abbudBym)?M<5Z8Ol*5Q?HTE0YXB#YmZrv!7yok5{CXJ08}I-tC^T!8sIwmn zk_gu4;peXtyJ*W=+}_(G1PAOR-wSFXx35P>+|t&I>swo?ymvWROKuduett8R`&V8V zrpf0$uy(ohmc!=Rl7)4gbm5n!=s%j z;8Wp7FV@F_0c=}YXd2JYd>1|k8qxFZ)9>fyS(&3)3=8@4%VUtL4hDEZ*39G-_7r1>qi`1wf3jl8v1kZ!EYy8VdB3cjvrT5q)X-nfC!tW49K4#FXH15efa(}F0KYe{N-6-+yA6`^cGxuk_ zBW-RdVBepp*xjH;~>+PwzCF!igDT9A+ zg`gMd?k>#boD}#w|H1ck+-G%2L&(i~Yk0}|9s`&&@l>HwTZi(;Dp5I_#-(g%V8Vbrn`zLZQNrVk!b$Tie%7X=fR1$zTCSlLGDj|$_{k8pA4fM-{ z=})R2f<66~dAd05@Z*|y%&&sp&3p6n@qrJAxkgi8gW}3xGP+-)`Cq#EO6G(ggJw)) zj0fb9q}j1zqQDw?24=DL&q%kwLcS&P)0YOdam@1tEAG{c+A z8y(e#tl5L59(1!;%3crcVgDl&Mg8~sBgPs;ZQgyBpYPvn@hRr`=O%0Aze)svAA0?~ zcW+5-ubJ2usRmGsc%ugBhwrbMQ2qPA!8SfpqeWg~ql^S5@prc4I5?j`tRF)xN5LW-sh&8K>;#F3j~4%_O2luV+nJ|+)z;1NmSq?M)M}C)O#1=gIu_mZ+L*HO z6=DW-XsNpnc2X9dQa;gP_x)A;N4I1$gjfL-;|n*nK~ zj+8}D1Oj$TrhoS5GbCid_%XjocQKY5zr7Ym>Z?Iy^kzZLcnm~~G}>jlwZ6w#+?6EqOZmZ0bt^aovOoHJrr;gG(^H6+r^eLZWSaxAyA&68<(!XojQe0w| z%>(eM_;dmLXsxm|tu7)g%;E>z`Zb6YQ-{m%^e$K?j{5SA?#n4ls*mB=)2|_D?DPN| zD2U9=%3pCnxFe$_9@~51i)kMkLaReUI-|N)=;h@#HKhtUpq=1Q0xNDQ1V_a`|Cr8u zrOYoMu`Njbm7Obf)*JN{o@L3tt86E~bmVW{mZ9Qc5&yIIA2}}jo{AoB%|(nPfx2*e zdmE&`^rQBd7kQs+dM_y5R)^5b?+<3a&=ix04eLv1C((eD(?(x1>rI`7&D*zco3*Ti zi2NrAEce$Y+{eq0^;u<`To!y`#o`*|F!7fjBxF{-Y1TqVKoe89KFeNvw*48fN05CYN*6x8R#;w}T86OVQCOm^Cw4NOs zP;yT-d36-2=ufn_Yn}yR1XY-$l%@H0@S`SA-tZ`>H zJqq#{2|S!~1%P8^-#%c3CSps>6Vj^GZS&g$m|wl9A}h1(>Vw7Nt?QC=IgS)G%-;bI z+Sze_SzaE2MScOvs#R57>mROSkp*jnV^an(wuNo|7`uszD#T65a$T?T?)Uyk)F3*dRbhlgR5U^Pg{jVzm5FkYhnlRLqFcLZ)oZXW&er3t4=LydG)67F?m z$-K7q1?)%#sW%c4>J{1Mcl^)rZegy;d`k%W7_&Ag#)*vlMJJ8y>_puS+!{mT?mNZV z$a@kbk4W|_O!h)5g3--;11|lj9%Ij6;pxPi)q3kTM#`B9k-t=rIf!ig$XcDH0$jJxMg97^ z3K04Du$Y~3ByoY)G^{d5_xPG8i``}MX^XPp{JffQw#DxgyzP+wdTY)Dh@T+6uK~g? z8Dj_)&m3ZbRq^U*!trvd*ROS5-t+291X;?-yzDXH6Uu;Ud;R(t;tclZgZevZv%)m! zoNTu)HBG5v2#P!1vU#HD5kuLSY%LPyUX)FKdCPMJlf#Zko2UVtcp~g znUrWg1td;dM&`%b+T7bE&deu}STpsRIPgxt%E1B75R0#`F0D~jwp0+(fn9LG(fh@( zuvIkDgYw3IRbD_q0OE*>O&YH&0znsJ7KUk0yW$QR9H7Xd^(b?irXGBLtdax`I`KZC zb-?*gH2;PBsV79l2Cp6K5~@Mij`ZX$NZ~SF>_pQ7ix)Zn*=CD%tO8LR#W^eQO={qO zdZT83v_0&3j@!!QD6*4D*!AAGyh|%8KR6DJeM=Q-<8wW5%h_h&x<6J zk$p|*lR=Uacd!REr_$69pCVuVRD)2~$T4-<2hSVdw?dtaiYj_;QvY)zs%6GdN%lsY zCN2N)*g2O|iMqR_*F$xNKpbH#3Q=z&{0R)8%JS zrtuvGi=pUzQD4iI@eYsqEy|)Ru~QDBW%%N~w*g{!k5rN?4VJ)7lr9-|E$4GCo^B1` zcS?gX4Xy^Ne~BfwU*H{8p=+7Cz}LHA6j#$9m93jel``^yFH9~%L#2IueAdN)Kzw7_ zWr>yzK@~`oR~A+oq!l4@ss8Su=;Xwr6#49|5)IQF`lqbaHo%qVWyXutF5!lxnMXv$ z3!Ps&f8^_H494IEYR|>c^%sXl#*?Pb=Xi^pYv@vBA2+9)e(Y?8xGnid&H*A^P z{Vpd#zAXSZDk0%lkO6IwQFy>d^*b){p@Ds7Palyq6fm&eV}io^bK{}eC3g_keUaqc z8#<*XExy0T4QM)BSX8?d~wf^m*O!a7Cn@*()DPs zkK}2dBWQ4g@bz+kA^*`2O+BD|n!tXdO6f3K%xe7fS9mk5RvM?XyeujQFh0f3G)J-k zgBXvKHaa5FyAhtj7c?hLCXI2CR1v8e#om`U*ChB9*4EC=@bU2>dpTsP@ES3_bUy9u zn<0%`7RS{L7MI7+d)&#^=Mm#HikQ zh+^;!B#5x-kiz}e#BSDtW|>REL}905Yr8U%{FN~GR*AI#N=ewr*G~j41R>RY+}t_F zZ!s8^gcnHUovvd42niUjimh*GSSSvsy8U{dmEinCEZxK6T89abE}gd( z#Eu3O!RUVhz(HHj136lJiwNGuQME#6Nk;o#kPU6tl3DG#98zNzI$<}|uY?l)BcxnR zs?UGSt541}WA?cwtIxG;t`2orX@lTsfiRd)wJ$hAp(oBs8>h3qQbs(KLq6}>!M3EZ zcL!04^ao_q=8jnPP&K>zbkr0%H0b=OlwTr8w`N(i{SL|x2*>a6om9W-&(n-*SIoIo z3c7}2fIV}tcB@{SwMfLr<7}r#=&bDCr$P~BJV7Kxm3c457jJTMBH~NiT~W{!gJ!db z`oM*$Gj+Rk!6106Sd!V$Rxa+$48RxxC&Q~cR~rcF;H$Lsc zdse}7$HZXwlhUiKs+H=YcttAImqfay31dSWKiB*PKQ{picyxt(Rq~m@OVZselL!g; zyp_`5Fj@r#41K6jop{STve~cU!;Bzg8`OY=Fyco5JdgOA&llj(5C8Mfh|?vsP+S>C z!L;qrn(O=;@*`NPf4=tXQf;X!73p*E%8D)BXUtcI0BQ82lZz;;&k)ochCqzGczR+= zBv)Y5)Z^T;e7twpXTLsH&|iAoVngu7V)K*PTVfAY{}Lj|&#&PR<#)?-oO-Us(4>E^ zC6)ik%*{P~yf?k{go;H%xfQKhoFY{pGebT)xTr;&gP2DGi6J`)p{WUPCBNoI8A*6( z=zLXOd4q68^j{>(d@D`1fPid=xh57?+~f8#%MB`9zWv@(PPKXWu5RDsba&~$?!aH@ z6WoMM4$2L7opL85#CdUG^&uCRwct3`l{Qal<^FN6zl^NTG1O(7yyJ94T$kBMQ*g+$l1 zY^9&=OtL~aXDgQ)PX?Tyl;yf#oHIN7Y2U>7J5$T|4YFPA@qK4MS(5vAQv=!pX`zlU zc8uAz`Jnrh?R&oZ&8Oc!+y#ueA%oxHCK~V!!EU}PIyrZ&KD#b88JqZ6mpc{O+1S|$ zx-LGzD>JM+VOI6*O?pavL%UC(S>U*TB@V*LOn06O)jVZ+ek)aBN=u{CaAD=AqOW6? z&Ex5_$t~5x z@juG(0HL|IDuaaqjm zFW;3_7CYNE2(|mU*G_oObXKZ@o2A4QALcrsh%%t;R=fsFQ*uE;SBX{+fGwlFzA3vF z9kLS9DGgBBE1Vus<+J@$17sy4yyz39?`NCUIavQ3O_b;qur}db?>v`@Rems5mf(Nx z{Wv@&#mjA3QOnc+@|^F&I=h4IlXRwRLv&5u0QL3jukX+Nc)<7+1q*xUyW!^o;{rbg z)ey&VFO`k*e#=FIb*F)0E;c%j8%!-m)4OAR)AXnFu19D5-|}&a;vIdDvx;CZWH(W? z9;|5nHaXC7cQbM-gBVkwRHr;pg~RV0w^G~9dV+c+FI-FG=KHfv%2yVZ)C4*oh*yUz za=)D|UEdTF{5nWQKyur4A?lVZI*QZ4M!A~=O>3+Wku5{8RNm4eVPXOYZ>=$mKbd{& z-l)9`k*bc4SlF@oAKBUWR(k1;P&og3AcF=~#a~iR9ah$ztbhwh>kA^I z^k6#J?|&88%gxhEv)$0IL^Czdtn+`cSD0PIQ7N6c8~JpBp_LNYdDWE1I)?h`>Q)#1PqLf(4nUb zxhuN4?MC8TEexU_`yQ8DS>+vWO#AGw(xSbw8!q)bjoT(tR91#g_dU$=%138mNM_{j zfb7|MqY5bM<)lNwW|aLW{g?g;!JzzOXQwqJO#?aaJXWewX*wev!DR#KsE(i#bLsIu z-VMvM!he7DYAa+=JsQmP!@|M>?iw=x;tAeEpi!&s0CmmXTWGie;1SseBzv@SuGr_% zVe4fJ6eKcic$dgPDq^iYz7xxCBoK35?2m)F@W+e9PL;oglieVuqhV@ z@P{`yU67KHgts?5TmxEStg{oSN?QnXhBO8Ok;u6kMkmxqm9!&Ta(t4DoyUPHtrrh( zb1|^8E=MThc<2`H?&^9egWJa5(sBFECFa_l!WV`qBJSTs`4S#~^f+(S^&uzlTit)L zTi{5AkzZ1`ggWZ}>W!e+MW&AF6I3xGbl+><3qR=Hd8M=nuh>bScsG3W4f&z_=)q<6 zNR3K>D&?4d41cjvM)XXnQ_Hu?JIPE{79AeNx4^0apfW`!clrLetRg`{A|%t*F~9@5 znn?~(290`?J_6j(=yS+%{}VXoATd7m`E!^aQV4l&!onoPxW@pm487eY;LtWtR)Oo?<; zm+dnI^tU^PM#q(uMAg;tKUe{ZuDh%2;g7Ev7J^l@_;`3+0T=6mfsH_G2fHzPZE zY68RZ{1jb7iaG7mKAdI-PY{`BQ=)|89900 z#^%g)_JqXSA9Dd*Y}z2!Lt-q4jXREOL2GJevVEA*d=JRB z*jx5=vy5u@coaj=ksr%>etpJW8^12%zc<)=9kaLnAVuaH8*bLYT+?OcvBSq!zh{$G zw%jEho%vr8O;5)+8+O-iwEZ2@@of_(E($0)>9|4K&7B@Sab00ozCWFpm||(**(FWT z`qy6Gs^=gCt1#WbzBv#>?ykYIiMg2kRCS?T{SYHG8L1Q|pUhz*@U!6OBrJtA z4o*&29K!J+YG%Y++(I~%8#dB!^eTU$`IjM>Klg&e8GpNFjvA*eMUQhTY0iNT1> zMw4$)n}QG)8m)AtX`NJ;o;qvn`t`hQil}hVgrg$X3rReQaI3eCeRBt!kdQYLhD5;- zk`Vy$r3t^2rj#8W36>jXpDsig##4(KHtLeteEs&wrX$=*kkbOZg6|cTo=mkLd2N{@ z)S#8(hbD^po#b=9Zqv80v58I!$F`W0H>kE`9RV-~Qjal~l-1QUL`cH8-bzb%N#)7Q zE6XA=em8xz+1fCFh-az6?Yx8e=9RCP^1Qjn@rhPgG0V3_7}D)66QO8ht!wsPKP@0~ zCaW5R+%;@5KUBWl*3vQ%dj6R%&&ECSah#SA`5k7@Ied}>3Urs+H;)oB^^aDdGh&Kb zsW+GH$P1PZ!yw+d?RUa3Ii6jQL&1l2S%P?6Rkcmdy8^ioWK1^8%ot=#i?i7|_56>v zPON}dsZ127H9WsKCD*S?1n}K@tn}Urn{|O};)={)^>H>MVx4`==*3LqBTv7{e1+PP z0wtv|x}ZxV&@($O_dRq`#K*aTfkaW`Ss8VBvN3%bnr2m>`>qo8vi6bN4Vdw;1(yeI z3mj4$z8?P%9~`cE5V))a)y7V`!k|!uIKB|npO9M2{F(-2u%Y?UN>X|gn}vn8p3KcQ zAG)=QRLw(>q=JU(S3a5`Q@;h3qa*<(zGHoJQ@2Cf^)ezfv^}Lyh3t4SnKx5~*2&Z@ z^YZ8yRvA6I6IvhMRAH{Jt<^H97%Fljq4aaKFQD>JS2qXsWK4|pJJcc5&^sO*@-#?@ zYF(k|PjYm5xH~g0~9PC!sn_5HQ8j$9VihzuMIh-ATDcDk0-E3SmlEosG()*E4lF`w%xxbgAgRQvBUY~pl8-w-_V)KqfcrK=BB2)qwPSF*Z0Y3QlgaD_OR%D-5-&GEX!^hWecQ+ zH$6Nx=dtOqt0q#3$il*5zYKjeRI2jZ(Rcj#Nqr;2_YW^XZh^_R#uDp!XVQevM}YowVgLtea^KUm7_3R zi=D-L;XGaz*!P?=S%$CS_{&GSLdLHf1V3TV)I9#HX&3iFvL7RJd;o&kSQQ4-p%hL| z_iFV+G4rD#QU#GV3?6mz@$%0!;SmHQ)mD^YCE{%ZFK-FMjLB{$2t+&eq-D3hBhn+O zCqdEtPNZXS>&6J9qF_{HG$C`G$M+E`3}OMV$*}b~PWSmljx;o`Ywf7&NQdzSN_y>r zpg>-^F7jpJB9z9liM|I?RGt8lZH2R{V*f$90oj}ZQHlkt_0nG#jlMYB_ZY)GP9*?1 z|KQ;3O@5SDH#A1u*|KYl{j-OL@a))JN*X+OnzV8F(Vav@nAuJ5P}{TnriX6G5G1IH zOURHkYRcnK3TU<{(!PxS3IqvWNtg@g5zg|Ub37W!Fi2W!ZXLR$OxHQw&TJb!T*c5u z2pb-$nW(%(x#U=7Pvtz7T$cI<%#$8_X&${=-rd0#z_K%V?@|QcHIJ>XN-$s^HK9R$ zS_8Zz1yP|JPNs|<#b4Ux!_&rop>s$RWX zpPn#TW-$1BxL7tetoT?IOV8=nJLb=JVL}9emF=pzHF9LamX;%TM5>hVI7}0y4GVnj zvxIkcT(^nLc0@mtB}qo$hf{SDo4bcgrm1gZmVJQyB$$_sTEx`!Om3mYuW|Wyk0>Rj zpdDu}9uffI@p#H2f|h6lTXVQEv9Tb05jLHsmo*NhdwQ&E7=&)3h#J&vR zk@GVV=1DL%BIcS9iO%JjJ5}}f#g?+0sotPOenTCw4y+jE99Pg@8cW0#-1fX-N;bD4 zH5Z~ZG~J+<(DHg|jL#6@2ZNgQq?hLHSV!9tj!cL&wBaGI_C{u6%wna4J+FRM)GhMSshBxlFGz(4a)C=)UKD z?s3?dx^8-97>iO1UQ{zZS1vDSFb%ACVzag zGO)H&jOom%Alo9;U*u9!s-8p8uL7H({L3WWM5aha7&%_#wI`r%tN!5h;H6ZA=tu7; z`Y!+LhL17x6E1vMM6}G?nYIRs9UZ9t+teD%?d=M*k8z z?S$A^KVGkze&d4{&B(KxH%n)4sWtw*k;TF%>SB&-JlY+f6|R`J5*uT6ZPT zy-p8I6cq_n+hy2u8!(AnRw1H8fRT&*;o89yNy6vi^XtYGu0*ihbVP3~bo7|tjhV=W znou|445xPYs*A;Op-9s8as}v18!BrzG%s)=_)Htq=2Q=E$AyS0d z(syEPi#Nj)gQ(3i*7({Xx6967jBp8;{n;hV-)7G4rO3mHO-!@^y~cJoX@*oRg_!we zgLN;`!**(;xS8w9j4)rv|74$48^@QJvU*~3ljqhsp!43|s-2m{5o0$VfXeG$6I%pN zt>3Bb-ETFUn|`3;+Fh&k!CQ^r639kxVYGg*kAOhqs30w&T@m?cjBA7D=Ts;^G6I{RoS!40BBO?zl6i zqLZYN-nJJrm{eS@$&pOG7`rZi#p%&D*>avox1l|g;5`+uq^vg#9HNK;+6Uwm6&t%U zd!eEEr}3|JzGmymmxlEX*Rg6JOD~wdpOdRkSxE8@DXlEuP^we@8+o=Zy`L$y<0s}@8^+cSaFv@0U7?5z@=w^ zZ0#t_BPu)EMlqhv=@%y}5{sTs2XR)rN2n(PeozQ~)%wN;r|FrLzhI#P0&-O?HCHxs z(a0XvGh2oNk4W)_jZcGNVyNU@pCPTx0Md-CC!5a8)}+ z2jA7?Z)y`>%rOPU=v%e)D_XaZ?(9(CCJ}vmUai9Nn;SpjE!wJ0#do*Y|Nhngz2*-e z{0)p3XQCJ9XL>TjrTSluy?mfOR@NU{(!ak4Da!`hD>F4(JpV0S8DWe}^vZ8%CSjwHg9`5>kEVQ=O5!T;-yFXr7^B{d59e4wq zG%!DdSz>C6if7-lTB${SX&B0MUuHgk{s5?#5{urX0!PPn)htmMOe5?vUj+mhcz?Tk zdX7&_u`n^8bf*0&mHp@R1|@&tq_6I|V43Y=M+9f;}**XA_0JHfkp$o*lz9~^Pguk6K0Uq+G@KZ)+W{{QEgG?1# zVcctzcO4uKKdG7205DZub3l-U)#z$fKp)nx`<}8umw= zRtQE*!T6-o_QLV|h#8G;vv=%+u>Z@HOcAQDX*11*fu<6$@Q#iS8L%ne16Mx-A|)jy zD|;4;aXncLry1%8Ql8(&l8GZ_$-@Q7D=N~1z~%ZB1AYBuPBZ)t5KO9J+1}6mFz_;- zuPQTh6CQyAN06<8g88vvdJ^M{#ib?uRZbml;FbPM-DLejqC+Yy9s-UpBgcFUk*>Er z9HF^q?*^Rb`}RUeesxdWPwB|kWOl7W$3(g=yybwkaqP~+4oa0$%fHFzzXq|1z6dnr zNA*a9$e)v=@{>t!i0<*(GHvU5o$IShhd|m1GXo^H!fu=zjE_}WSg~~9{dktLFnjG9 z23WWd?goR`Z)bN|>HC3|tu2VLm1t3|@+!Bo1j{*RbZ?-zeSII40|CK1M>~0Q{Q z?fdN0a(Rm%61a1piTDI1CUO&ntLa&p6Fk3tmC_j@K`BMV}LqhUw$p`9KS*d@3DVqDiD%!RD3jk8>bg6Ho{Ug~6QkJASf718L zOx~^Li>$(_ZF0XP^7H44oTlrs>^_#3?RO1e1VdvEdT3blMe^*IFWw8MF9D@J-|5kX zPN$36*n)GUumdj4YrA2PC9PC-1C`JMz~j`bBx^kLgAbe^G&Pgp`kgJsvx7YB;OzJl zsN2aYDV2E4*jypkE{@8mgXl^JSo-KeNO{~9z9RmwtN0ncxUTzbU(4ue2sZhMS&r|) z`uAL9$~v@@$dw{i`c?{VRJvq=dVHEay0K2o+oN%^&j}uLDpwhBthVd?` zryRcz<3Qn$W(95x?51#Yyg*^k-hPZ8d%7E(>C*Jx9fF{f&MQYTOCXx3A+#w2S|g@A zu%ryrIAXR<{^lPx2uz~G+VjDsus>S`u-xy5?o~o55g9 zOAb_bvE;tCJguOR?Ko;J&hz6Ew?_8`mh;jx2Yc6vkF0WHUq9B;CR=j7M@!hVeH@5b zjFRm`>jYpzNoDH2T>LDG)?M(!D$q<6B;SID>N=;khn=blvGyYZ=}R)r zO2HYYrD1(z03~}dF%$?PO*J+2m~oZk+G=hON#JqvCD*(_27e;@e9bKFZN2a6xw)42hq%3R!5lyE_Tm8{6ilP4lI_-nzVM@HA)cU&y1rqV4(p`neiE6Gjcx(Aw z)E{-vy1-`Im$MgNFHgm z+jL;9k@r=FUE``z?>uCM*wJj}8`nITjPi+vXX;4)k09N^0jfF1W5<@;9;N$F&;*al z=^54`5kR()^OQl4yP8fd-&MHky7OK;d@2e*llipz zGtK0(Oo<@pP1{&+$7xQUR zub7KvJGj!7R-!p$6BEBuwB&$<(vbkR)ivRz$q+|ODDP@WvS_-Xg$x~nYJG0SPa%nz z?I&s{E3-ka)_Z5Ov@0`3P~^$pF5%RicrUl2Uvjc5)d9xYMB+Y-+(L$an@nXtNkNfy zftyLyU$$$;A``#r)O=jIpitWC$pOTN3VSkx(8y6Q>TN~E`zTqE*=znnONrb<# z!$Z*{GH!k>yKhS3SF4E z^AD&C_l0KN9Glv0HE!9>&CS|Gr3_-e9bk}$YT-K1LILv~ypR>SyFb1p2Pq(6qdqZ_ z2#ddZkk@tH`7^oyi$DF<_hsIzLz{M%zX2pr;Q%9{nwHU2L7kne$0ED;#33Q_?`z2aXXCZ}XymybW3dfLDS@6-+)tsH+?ejP(pH_2 zrJ>zu8!YVr0rJ$;6dvyPtOayX6P!*Fh|3uld>4j~<-llwaB>P$gcMt58K0V)Z{2gi zGw`X-Q=%e;l+h=el!W9x5QG$v5ef@SW{QJ-+rM|K+^K)KF))(8E11g4j@|jqj&1)M zSDpkJxwNOd(_ogKp&^ev7E}VcWe%I+;j6HJOGuzmO-)T5Z&(y0cGGQwjTjRX(|C9A zgBI{c3_Md^``@_>Uw0oZHl6U;*}OV=mTUYR0Kuw6DDQ1+YinA^l@KY=FDIZlb;`!Z z=4>!xL0D82?(y*9goE|=zh8ra7y!r03cr5O^uvRt#--N_P6pW!gu^2Gf)8Er1bw^{ zs4|UFzS&hy=S>?H05r+oyVn4$On#j8WVLcrks@RF0y~D(!_R^8*Ol2=D%!p6{-amD ztQ+J0dV?By_XS;WgeAnqr9BVZ;i930Egd-QfgGpepA&M;^QR`jLDLQ~Y=*$V$Cj=Q-J6U*0n-=X@*Y9LfAH z_g`bYr@FaKQah0u2+x?k5h1lw`nAIsF-{3H`S_bpdw~wUc`vVVL}@PO8|YRt#7@>4 zrp_Ctp84QY+@1cM#;meY6 ztyo9*T#jdRX(;Ta5PgH%%D@@$=r(=`kRS$tuL)GzyEreaw}ao?1X*-Q3qwI@cUIvHGt9xnd)dnULn zRWaBl$#1*o*#|OjcXji8vfA@jO?!o2l7T6 zxtU`Jv>F0wcu61l(HYeGB^>^!t%>(VhOJIr*0DWKIe5o=lJC~>@=D{N>-4_aq~JXi zDS6FQ|H5m!>ht`OhM$ew*Yy^<^oqCKYMf02zt=0Ke-yMq3ADx_W~IDMHhl9>NQ-vl zUE{Y%>8hA@xj3#;*Nu&iTs86koEuhmzIdLKYmutwMVS@NVF{!)7cTNlx26|gc~7Mi zee&m_3SIYXiq88}iKEIz*DU1&tc)i3lD+5!=2+PR@OpImb0A#9~=2kBmwz+SvCS|g;SEH|m%lL7+7eRbB0XJM??p)=;Px%re{ad$^Y zzT4DS5Ck1RaUuafEnQ=_-(ms+2SKKT@@V&KeZZ-s_fB=#HO{SZPqgwfcIGC=H9g+K@6vtm^`luQC^1ftxwB0A(_92q<@}GxKf4W8W7g`wGXICzI zV_LdOmPa%i*x1-0mx_s+I@h@tN_p=6JTncEvJ3d&e#hvGdOaI5iSL8S{Wc#PR*y=B9+URZdJ%oWF@dpQCi4z+C!W zmKK);kzB_;Dnohm_AVJL1;%*8DeLk$gFP1&{#YTuK|9Ae^LFvXo>v|ciW}P^4bn<6 zspmN@d~+g*(o!CET5T-0H|C<1PF*-qaYoD0ux9d#6MT&T!|qg6RR0-|HB+T73cX$Qyg+8b{DT$ z7XgoRQ~!HIRko=vHY@J{gaUJoplJ;eF+863qqtStvs4L>e%e@NfUL!k$L!d!Z~0fT z`=ADdiMU6m5?K#&HKBXWp-}aE6Y!b{DhQ`J)O#b}Z>j&@+r~z_#vH~7>lc(jgw<9I3clkv5ocRq~H^aEZ5$D}pv zyTkA8gpxWyV3k?E_M}>D-gup-)r`6kvVDCi)o;rN2a^U$lk1DvZoxGmTxY%vWr8j< zUrbyalqD_TQ9ui2U25wrzyLl2mhD(WbMFf>h6J9g#NQF%)R9+^Me#xLIvDVa%Qi6cL`>?Z_F$;IR3op0(xYS`wT=C6ckie_CgW` zoD+T<-_z~i*n+VZ2@9iWVPRn?;ZC6I9vA>C`1Q%=T96^zy?stEOK z3Nn9P&eIbosF85_lEPWJq97kc5|?XMU!_2R2f?0X`*6+jjjZz+ z51p{3F4_pUB=+_hL6i) zU)`_FB;+TSh618wz+~r?>lGOa=L=_KSnb#EjszeqEerO|x+|z= zK~0)ft3;?;8-3!J!B5PJrzMxOPe98DY1-N4N8kDJC1j4p*$np80|>?1`wy2tRGu$8 zqe6atGxE`X8U_PJ30H0H&%ia4@x~y~6Y7cw7r(9d@{@eUN_A?g3wP++%bFSqHrAcq zBZ}5fF5G!2%Xaqc%3yXFPXMQSoCfOdx}%p{fd%9Zbj26SZNjmqLwz6;|BZE6G~ji3 z>~32KWi*}YZoknzfo2AmXhmy=t?*X%8`d2z`E zh)zp$;+@lpEx+NXAlD6YC*kX}eV;(mXeReL29fMa*fRLqpfZxX}K60gBkeR z$Vp}kq2>ws)1(+mdn9i_Wp+Op=kyEpvv2>1xj)Y$+M)1VOTukoSS^@h22z_goRhoL znvZG>ere^i6bo!>4$%O%`9uH+I;S4u9PNA=qxC>TB>P_cAnHrz_);^9&Ev$Og~NxF zsuq!#1Q{i^oAQJ$o3wK-UR0S{6t-&jzFzHQWmWE&{4MUqv~}|F1lN|pX_&oEa>_cq z^GVzNxxQ4-sX_C=xbvC@BR%GUe$7N+CHTg;xo9o;GJVgv z(o*3kJnUla$NIGKEU6!>N2_{K%@Nqz*1FdDOEPKREF3#YkPMxHUsOdySaZ180xDnI zW=(2j60aKDLb_EeNiP1^psEz^Y@69LttG@;?tg}$4$(sw09KqJe9_i6yCeZeh8j_# zO!d^rM)7k)JRlIvsfbgp4g*2?+}uRem)xa=L3Bo;i$SkGv2z zT5EJav^?3zl_AG~VQZF1)L=h6f&~<*!8-EYtCyyK2d!A|J9^4idS{0I`tMIW>~l?G z%X|ihA%+~TQ4%aF`F%WUMgOLcQucjBy}!Ej{$fPrXt;nHJw9$K@H^D>zwxw;3+Em< zQ{wp?-WBDRdyK*sOg)b0aZJ|Qwr9S2smt>LfU`;w;I*xUd=bUqZ^VgtvtNcvzz!dssk{7Jmn7_th%^TS9-r>Lx)oJ408 z)#&^w1>#wr-WtrB0l^SFEqO#mMPK=hf}wyOt^~-@g{g9N25%^ZLZby?v&I*1J*fy{ z;Ifs4n!|5a0KcYO>^1tTO(412SsXFFy&j%R3+tno=olDYGg&(pePF{}eO>8-r9>vd zG8Hrb=F{6s_8ygVX-_3G2tf8fffwKQsR3eo(*;a7vw<_Hbx-!wouxWN0q%b`o41H| ZShTvbNpFa94IY6XHKogn#qySc{|8+{b3Xt8 diff --git a/docs/images/vscode-findent.png b/docs/images/vscode-findent.png deleted file mode 100644 index a26de6b40d39e56731c69058271a95d5407e3e3a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 43037 zcmb5Vb9^4#`Ue^(jcuEaZ8UCd+qP|^N#itZ!^XCqG`4LuYH+7#pYz*2``r7-P2YSn zeP`CJHA~MI&qON7Ng%-D!h(Q+AV^7yDS?1Mh=72AqQZay-?(8O_(p8s!QDF&=ujjnuW}Vl5BK?=Y`T6tBmNnwI~6OCAN@J#hcYDG~?A$~{tyh8p} z?j~GHF2{(?bA*aED3pl+gfG1}u@FqCLFDw-#*P*>oKG{jB7zE?BrCd#O1*1~#0S-| zY;3G3nJ=aaXPXf!Ajk!pDd`QB^{4$+^4=A9mI}B00y~9=ex6EJx8|dN!@j?aS(wc} zJet@rn3O@EiG1Sgnv^~+y}6>3#UebM=ZtTzNgzFwS6H)>S`YjUS4a1CJ5C-6YZmFP z`RI;Gb%9wLu^`-}#lFK6{1QJg(CVt9)s5o3MHHL2>3NW|Paoi@!MGJV9f) z$1;B$nnX1Z8GU)g0d;C+<5lY5gnQ&NzYiPrP8)a!n`_twCPED6lkko!01+&Z5k&JD zLo+$FDm6-7I;13so(HYj)`v&Cuf95eWo3B>5VkYT%pc~vuo$3IZYgxhCh{v&$w=_TU?0A~vIV?nf-vjCT?9AZL~IKr zf&numhV2XP4}gP^Tt}_K-wpanOoSd}Yk)-!p7I3>A0oV4aSBW>sCJXI3AUx1!GY*D znB)>aCdl0YKZqD#Ebvl(z;+%vH3q6M3pLg<42DR*0*(sg zoUot>)tA~S({Io%a0o(VQ`U!QF+syswB_KLUCxG3VP}i3)6=1V(WCg{l<{zd@+LN(X5L(+Z`0DOHU9#-T!W3{^_> z6YM8S><8r^E_Lk71OyRr;?6%tr>v*6r%Vrn56x~pZxL=mywG1TM7u4F>6z`YIVcg6 zqcr1&2R|8DF%L3hF*P!Yrnzg-r-rfjw-|s|UoEno(w<_T>e-+*5Ud0f^u=vCa3N$- zOn_sB?QGUKJT~z+i8iq|>8&E4gXe@S^sel@T)p!^@dNLG(2p04z33P0k4O6iGXTLU zf*mNKAw^AkN>ztai53R4BW9XU^CKAhgDhDkRVpf8Bvu4cguNtr66kPBT>v?G1zAc` zT*CWAC`qDWS`#>y=q$<9#Kt6~gq30UVS8%ysCWIDNkYTz&Q<=q|Gn!TVmQt3jbn-RNf|8AcAy`d}SGx7%FE$BtL}x_*iGA)^XRm`c z^#!GSwSzLOZ=59?N^gb23zsvJ3yYOM@~;%oDlGGwg`AuB1;*hr80%E(SL>U!Ahjgw z&nO>Xg(!#bZ}JgwEPtK#PUM>^8UpUTshbx7y;@d6cR#Y74q6P(0NBpjK=#1JN7;`?A34(N(%>^oGiyFN%i_rrr74cJjisimX0EXfX0VRU zjNfOtYj!Vy|7Ee|OS1XrH7GAc5PK-{H4z11;c4>^m0OkONdQ4gTiPl1LCDB^e zTFq))%gdJCSg+i+R$)ea?&ClOFzetM7yBVe5Ps zS{Gksoy~A>kZ+3OE8_bOnkKzd@vPa)*0A>QHnlfb_P%aoovH8N4{dY_&UJSCvvtuJ zs0w)#Q!;TmcpDIDhmV^sR7(Ww1gSx1BT+(2Kz)W3M68BM45=FrKY$+JV15(+=J<`e zjsiZUy4Nj)AD$CIAM^DF>@?^Sat|&?Z1KacxQn_*VQ?XaSuZuYq0kulzAM6HhCL8x^UsB*{C;Y_KYmLbw)q- z`ZJ|%@n?h=LHBc#OI7$SLSgB%^$8luLsMN{hoitb1RuA~>*X7n>HiGrX{4=%_ zm9ki}juTtRT*Wpis8QOGYeGzW)GY%oQ!FoLdZ&>JMzfyTIwZatJ%a$B)+#ny6Lz32(pJb{k9PHxBR zXM_g4D9*Mu?AB@qc`AF|^-WID4YpmnU771&9L@Hn&zLV2mn)Uyh?(~`uUcJnO-dHp z8cGkIaPFfi7pEO`FLp-OBlDG{2l>7$RV!jEcJ}wnepMRHTwgsL2A>JWd5?JE+&b3k zO&0c02a`tD`qpaJUW!PHD!gOvY*ucXWfk1YR=>8Dh_o6x_y1~dYj6M6cF(SMtb(cL z_oVmml3f~5x^Ip2C)Zm{aId1wz+{I`kF;lbCP z1033#x)>6B*xJ}R^LX%+{_6@J;Q05~jHJZ>y2QnrpH$8C5pC|uW@LyGG{9Pq86F1YJb^dYckD|Yy zfk)oS5~$AbcP9!k^D+LVJI#>qLe4&sDoYE*W zBO^0CooYLQPQ5aV+nHkfGW)aF&*O#WTH~v2wQDb2HjC*7TW_D;bSFG3+x{rmP&h1< z^o=$+PtD~{LC`}D_IilU$4>vZCDA{+B@hDIIak0}NmR_=rBtAB_Vs&YxRP60l6aoI$*vN>8uj%0U7!?oi z>ecgRKaM^}Q3gT;Xu7FS4eweu}^SGm<~t-|{udmPLe6>O@+e^1)5qR7V+ZDtr0{rDXZhwD$=bNCG z79LPgMl41>hx>Da5)s2qaac_H@`8fkprPU1P7rd~7TQX)(Ny1C3w2{-G>e9X@4*8x zjw8u~Cc8sFns}TFM{CXXdczQcvf0bJulKCQHq0h-{9c|^75Q|t@6UKMxSh@Bv<2MH zW1>f4=ALtNmA_7OwzRa!=L&QmwV-1M}YBhJ^nyz_ky@3+_X2TPqM3_7(o z?MA%>(r=f`^>he$9CowchEwQ1vzU!VY*G5qsy%BfE7yw0YE@NR9Q-_4V4BJ*GL3xs zYV|9DN&)M7ak28=2UCo601&R{%)78}tMG_I_k|5Nqc>~^QR?2o9o9{I_BwjsY4 zsI6%7dK)XNFnk}Y`Emvp^$IPh#Ndm?*B5VcPTW5ij%Bn^&=2g@u+N{>tBurPd}9bs zbXr_AWoxx+&GzanYx@Xzc-#UK*{#(C1vkvbwa{sdNUkYxh?ACT_R^S*&w-YR$Ku9i zO&5&{#m3-;3x#tg6&Dxpji?3$Zu~%Ta&#j^%yu}MhP0rH;k`d!BOoNan-om3Uu#L^ z_eLZl${k55GrCQuioa^G%~XJeRvAfUz%xXrRcZ42nc?WEpN;I^?6_kUi#v}@rKP2n zz(1v{S~ia?r(7Hp9{A|ARBP^kL%G;TPGlq;PslG;{PiFii!ld|Q-1@?dZ9AJ*2rkO zP|BIUGGUv$hvX$II9NX(k5k&O^Yt}~T0)CkL{#+G{YAQ(*Qj3-$h(C9eEMXFnQ?-_ z!jUel=SDCKe6&~GgoTCI*K?E@_`Pn0Z6F*m;18L}=tRRN1&3t<5x3Gg?e(xl>bj_P zny9zAl~9$0hp@$Lm^wbyfr<|#P+WGpU*v>-s6L*n$a_yLh)>{cu*Z)J+^XsuQ9CMB zRG+J8VF%B5-BzoKEXYL+2LIRRrYh4>N~r;%b(gbcQEhF!b`eLK`CHXTc$}c%;17s} zpQej$Q)8l{l8S9;)_BdH>Mdswr&UBn(K0Ug$MF;*fBg92&rfH}T#vr6@OLo_xEf4HrjY(i$R?l1?Qe=?Pq#-K-xQVmwwW*-7AkEWFl`O}xm7~5 zN!Zv~{T?nsd7S$qgki?(ZI+5{{Z^kCvlgKVZmS)HCHFe-s3JW;d=yVH3eSIP*fppfB zP1F{MR*}%CkC_cZ+C##&Fil(5l&~$WjK2HNGalNrVR4&oUFRU7T z%K2i$Z?C`J20*08DL$=M8`I4<8eq4WjY~Hp*@5;d<3CX7EgN!kX`pNc-u8S`KbOUW zK>qYi{d>o4pqDUZ&RPV@dnRP>bS_7mg-QYv-o%j7qZxA$c*g)%!tJM@Wn0bn;dOV z=0A>S)c4`D?&`O=IPQq|BV#tiPr|`dRBwPJ0rS*qx^M|-w!w~&cFjI|d+ddR3;c%` zmm^F}%>AQBbg7cnf!LGf#tSb0*QCS4H1+R#hJ&m+{RD;=?6(jtW$KLm4WQfa4K9Z= zRQ(?=zt0cgb34JH-4QE-m~V-2p0Yp}=ywu&-xCH7D0qz`dl*sXp$>$?9c1%+up8nS(>zELUJ{7m`ZOh2LQl+etc=K2~7Uo3sNyF%hLI zlnT@C9rz4bk*p_0&j1!SE)++fY>{*d$plKBaE;B`V<+v$Jc z)J=61NreG}(zHV~D1Q!)k43LiE7bB?T!<@ihBXL&-%=~Lq3wsmNE$!`0!vJ%i*61k zw}Tt?^1qPBZU*PBUv-<1dxj1H@QG+*Tcg$tQb1n`r;sPH)_9P^r%74HGfTd6Wc3$d=N zV<|1Oj*!j!5|UkW1B^vckOmVt4F#>lTOwm_UxZ-zw{McRXR=9x2!G>4;=o*aVqu)* zPn8B-c=*q6u9Q+Vq>m7gkkSpS3e!y2GJ->4UfpI>r76ac%~q7omvt5lk`+1XvIlVGnB%*JtNzw65o zMkjNE%6lp;F0RS3-(+$Fa4rl8 z5s`yLaBN~=07AlS(4|n$BwVa<^7e9{LX+G8a~cwAc&0>6i_h=Xrc}?&{9~xQ(#yyc z&SvXffpm%$O#%@xhNvH7@Hj2cS3hWorr7EG(Q;kN{>>gb-vNwgV^_HF%ua~GfRSqz zoI`oN!*}CH!Pjau@Fb0spqD|Vy>+HgS^Ap6o|N8jc|vX{TwZzVIiH;Y*Ifg;Jp$f4 z;EA9))+y0(alr~CQKA7<-(WQ-ULv_YOsD?dP@nxlNH~T1O8sg(HEk@60Rok=zwA#G zCYS+YIu=j)d@#${U@c=oFxuu>Tdgm$n&XO7wNGf5_A=M(%zH&kSgjc}9cI7i^()h* z16{@A?qosP0`LU68R^v&AK`ZeLofa%ZbrqkLNUd)>~uGcE4RtyEnlHQn*! zG*048vpsd(*-y9g)v!iSBi42RD@3+RN*{Ep488q{fC^ba*~!QXR4S9^itNEWmJr?i zdexQ%VZhyd1~}Y3;;lr2U=z{WmX%&9m2V+fN2-+czm*rdmje(HAa-GItIe!Ae2V4C z-P=Sc2TP6ilVj=1NqQLke{PdXi6Ex3v^^%O{)`Ue^0(bNHAQFD;cdrs$Y^|odF;XXfOx}A0VK*@x{`suAy=F0ZjV- zJ(=A`$4@w(KFU99+=gMo?PUae=MxN~7xJ{AUqnwIWf(g?SEj!08+^c7x@r370#l(7 z!bvXW(!}|@?%xQpE1s$=d&G~=xZ%%P3mhkuLZIs4%>Zku3qijV z(d+&^o9_*J$%9$)WZsQJCUw9hNBujP()>v08wWO@huF_!_Bed*-Sdv;JsJPi+0|ya ztE4_)EBIP2mrD8vsR6kCLny!uty%%H>yaLott)f-gZ%OKbZK&W8rWLa0>OV3ju9Ce zOzODbn`)@Ux+54Vx@PnItfDkLo_$ASQRaML7Z~^*5q~khhTCbkORr0+#AKcC9*AXj zOEt_i6SpM)s4g7>^%L_H(-hLjjJm~Yrryqt@Z(sifm@|grJTcJD)J-0pD7!@KO7zhfQ-BbLPRBzp>Ur8 zp7}c-?h28qR_b7oGVndG0hs!|4p*by8m3K^cDvVj=Ub(T{f0R0hu}W~761-5-H8(x zQQrXWiid4Nr&Rdu@LRpBZW|rAB5tCKYj&2Pf1YX?pIW6(hM<3UwJ{Yb5#xNwaP&R3h;0o(>4#pjDoUZ6puiLrPK6X~on zdfNMAE!&~o01}P35n?2{Mnk{lCK5pD9v-d=BGS8NdU|Sr)6(}g+Px3f+j$e;_CHqD-eA+u z4_1Opo-bDaygfo=Dpe`b$`k1asuGeWdE6aFv$vPWE|sXaV$TuuZ?H%dIn(L%t9RTf zM%Dsq`E^UfK}`)4W`(ls$$xTWP*Vg3*_U^jlw^&v9Sqi zAQWh0bUI&ag)8uIEMqm7>*>NYA$=RqOaOE!Sl%mEH)Avf|6LyennroJYqn-_aj{g@+F%6p{oMBr zNiLsS8;8r2!$a(`pFAE4)$M6q#d6u9bMzTq=z2DlsvEuOa#*=i(;QrY`2EVC-M!o;9I|S;e!^1<-@K;9KFY;hu zU^X_VK0ZE|l&P;T;k#q$z1?~3O7`+Oe1^8VaEzAS_za?=#*XYXrtTN(^Z6f6P{?#R zY_-Cb)>?kjDty^ot}ojj>9F~cpVD|gQ&n{-92~Zj!U8b*z97t^;^eeGKk%Q&bAz!u zZ61{}pU)SgD$FM<6PP2$G_+EMHirfeoY`n1F{WexvE(GsBy|S*@*jZ>-oS9INCu0T zM9jXA*5CXf4^Wl}1y*s=6%`eo_s0SPWwuK%b?S!B`r$65Q%c1?_-ZuR0NYMwev-#% z6zO)GVQ-7gk`r-~a)S-`E-_cF&tnp=yIuEh#$daAYS@c@W@OKdh1IWTlCP*aliM0d zFkM*2WO8>93(Lp1TK!JAOszt@v7x`lkN))?ENsZiR`0J&&c<|hYrT{C@$Hc-vA-e7 zZ)kAYimbrO!t#{UVXzbv7boZ7;Lw%=PjHNmgTrjUZlm)-4AQ>(bbU?ONv^H@8}iJ+ zmqZm&QZ23J+jhqbPc00Kpv0P{y!@RfOYz>FpK{k&4>ec zQNF}T5i)xHNr8Vi-U;jzbLTTk75JaP3^*Pp15f~;-Yw;S-{@fvg4)>ck<8$qs(6xw z5G%=j7(!;77ly;$2t{)+fCBbL<|cFaLuIa?Lu{a-C5(-eBhdyacN12BE8ff;6LgIA z-uHKDY1p2Kw*TlV!OVY4+rTK))LPSEz2o=3tF5bxitupX?CL0VU}k3@&Ag|ZOZ=o1 z`A}!S@neWu-sSeqb@WF8bZ<`&Dh;V_seY&8%|1h`t8;>r#Xr_`;Rmn`V1EbLTZPp^ zp5g55YzCWUwecXPBRe2yPcfC|2yzb&4w?g^4UGkx`GgLjrYb2UeE5eM;713R0q7j* z0=`LBxx~f^OJ9UVr3QeVX=JUgu5KVU)51Fkxw*bd3jg2 zM>{milznv7yKBg9lR3V0s-;2Vq9P*dk?Nnx`{REm{`v(23wA3%T3$;nAmp&ZFiBINfHwdnf_e~+O_@j2z_BCtN;R#+ud|Vvj`@9dYX{Pt5O1CDOnH7?1QWzhB*ib z_{@a-j3SlwL;e;Y>UJ)XES$uq#&pyV;Bx4L2(XQgJ32u@U_gI08TK{+9+9Y#RR2uM zk8g^smx&wK_8rYV_KSwjH(=@I^HM4MKI{O5>^04>)c@MST>PR2Cy@dreTg(tJbJOY6 z?G`^oX$WBpwMY1T3dMcgzLCb>K0P>~i{Z2vaoQiF=_Ef52ncwGHUPs*N(vSh7#KK< zHul<6&J=?c+WXs0K)KMgz}68NG6f8oken~|Q=HALZ171<1xQ2!fHtY=N29w$z~iDs zntVHs0b=zd-;_(#`IXILV`&TherDLRF7(3{&_gf`B=Ue`w~6=b`SAu_y;2J~Sp?8| zo+G6O2jhQiLxa&ANMPG8*VQ+=YqWcXTFB5ml4+S_|GkkCQ(Yq91UG9iXfL}R&tfE| zV$kswCL!ZtUx_kA5TwIl(uc^z6A99*jZH5uYB-H1?$jb)U3jm;PI*Nk}a``O2*?T zPhop(cK)iYBR>tdKVcg|lbsZ#Bu&{)==FEJ6B>c>5gia>UG4BKP^;icqYX>BQo@Un zGl)}*#;j;-&kYL=MZ#sn?}oJq0G6d%`NRF?)&u~+DuJE&?vz_Z1pNwG*5&aacLd-( zD@~3SDXLO!@@6;tu7hy|iL}pzJAkB_Ha6eZ46xJBfRGo*&Os$lTU&0FuPb^lV#&9oBf93@g5u+u{%cK0RkGD zYYUH6#WgjPrTbp=tFU(~D^_)uV23_G$3(VHTjP zMMU1?eoSLJJ73dAw!hv595CmD_aVy?2=CSi&S(4kF*xJ0S(#E${OO4V#SK3@u!VQx ziglf@x8KZt9H0OwZ5c$KaIm;;>zxp^5Ih=9I09Zo=TbWBn)IiKlkI-E2jkl-&+}~- zr^jn{0GbX^`aQJyzu8^yUcLN63X4?&6#BthWo2b|C#Mp%3d&;iZT;ZhaHNSWZb*Sx zJWkP3K!Pn-?8P0O-W^t}$S`<|U#dO8danc6F5tIWSz!X+`?luh7n@Ui0G~Mw4hu5_ zBAKdv2>0JBAwdi*S3Q7yvmy;I%#(}@5OYC$iMPVI;Njsv5-WxwI1>u`)fAhFV|_;H zIRmKN;x$}w+VPyV5d>M3kfqH=M>Bw|fL?KOIlbEKZr5#fi}32hv6CKdg8v}8!B?fX zH<7K~&|qsmo)O*-0kFxt-C?p%BBA+mir^}M$;hQO=%A1jUpAV`@L^)Mq;?=K`|`Rd z_fq{@xL8bxtFV!^4=N=5A)@Fwo7X)!00J6fkI4X7+T4BQNe|hCc@58xaNEKjUIN{p zp_v@J5QbxL>VcREhfW=F19TPh9IO|}oRNDI5Wn|^62YZZk|?4D@M+a6?>4)A$1v(@ zXcZgJJDv8iRRJ@QNYpt3$FswPs=YU#!RF?2yPwtO;LF#~kRLzOse``6$HeqO3Hvkj2xsD}T(*LA{_J-DC`wwWP*4vjKcLApIr_eo zTOg|BsVG9&@%@dWi2ET>V+QIhXLMAKcW!zHic4mNPUfTZ4IK?UW^2vWV?yfc>v!?! zygizL=masURRvdjiGBb8gsosrYHU_R5L&B*g&67GVa0;5(P+3<`wha<^dU!Af>>d4 zzvV#~DJO-Du3&M%&NmE+4Wxk>&f$+5f7cgS#D2ECv?+1eXfJxjTQ?LEyeeTSzWO=; z=&%zz(#V6>4qGPd@|Kxc+-d4dha~2E9h2$8BbYWxUY8w15+cNiei9>aaJ=p<8#A*w zR#I#ra{$hi%RtB;ew73YnIF(0wC+yd^wH{lnt9#yzv;Hx0TwrjK+uV868s+I3ZywhzFu#%k<~09(!$4NK4+}NQXm7-|*=et5 z4u`dPbM$RX6upB3hLM;sH1ab*p~2A5l6@ki`F)=t?5+zVBd^O0R4)*(h(7h4ZD!Ip zKnS5iH_Qa63Af3Rr%XJ|3GE75&X%e|3Zs%=nMV+#*3ESIN+6qkiZWo0`Iw2`YK>0) zB@GT2|GCB69s2nZ5SgKHi)~lbhE`kenN&VzRl_M314_VD`k_#XlIf*!-}9q0U~{as zdD0D$FFGVs)z`CiyM8RXUC@H>}^ zP6LZ7uCg>fs3Yp7B#=^Uval%K)9J3kkeQrh;V-7;zMj5E{XP z$_TLPfnbst)I+0+Q*Fs8M=YQ>^18+a0|!s&%aS^JKF{t^i(UZ-%Ye0lCKaY7{i#3l zSe)nO{-6qS*vE;(YXwsB4MIjg1SY0&A{hE!IB+K^0`grR^?ZeJdw7UJV~mdHHFk6j zOza3}5(t zv>ua3w@1nR{JE8YapcGDi03V1K-GSE>0WD2x6LO#=jXWPBTY`zS!fa-9&X5jT^uNEGh1?FFEaH>xP~xjn_e_jupKd}Q=9BSm;2UT+w;aBsPOCoXT^%8I+)bYXfMeO;6lYBES-OK$|uec0KgO#0wPT?sX(& zLTSX~D#3Z5WWUkU_z%X}R!PLU0JINn-cjl?ZKVOo9-#k`=!D7)MA7gv zjmqGk45OdFi=)Fu8w&VFeJqsh`Ha4e*7&YD!WNvIlaWy#z*P$;i`8)Oo~Rj^iYzvS z5lo2NHr{vmd@hHDDRcTtnt$Y(T)qHgxg*!mt3)_slYEVdqqfES9?|dgyM8ALCV?Sy zq{oRxR*;bm!AxpZ8y*q1!vl*p?92dR9_moqe8pLf`DB=;Rem0$`3KW{NuByP zLBmRwc*1O6SF6ucvi*hb8ta(2$iBU7WpA9RTW<|bEv_fxpF~{1WY&M6mCP1@#A70Z z>w&u15G&@R2?@!_$fxy;zHaSxDhF&#Lrzu*c|c~}O1hk#8HJrA&t0WBSvgoP%mTP- zxo#`0l*{DoEPh~yfNx8`?u-A7WYlZKQ&CM%0?WZfcBByO9emde3a?v)3?OuOhe3NB zy1AVxiqR}pXj4(+$fAb~b+4o%k9FHw>VGSi{Yc}QAoU-XA9yPV@;&eQc_8IhF6cg2 z2@G3rr=DcG(j`(QxC$if;flwgxvjFY^7cB}!&ixp^@u>O?Za$AOG+qp5IZXjn$(jR zO}b?LqWAdpwAIZ%0$^j?tSvW~j&f*(u{nG(;=$zb@11QG8!6QrNv1;T5mpE*{hX8% zd=Q-tqH+QXim%k6glhd#O%UYMpk0Go^heGGxkvyDB??!Y7?@xt$oe6RK^O8N=ntmU zU-H>JTl?cDf~`b0@qa6Be)hi=l=~aQi)kXzQveY&X=raB9eG}DH}8rYOcOD!Gyg~I z5%MAjL>0nZo{K+ST_B^74fOq${7ig&_MZfkIPg{yXbHc7>-rz917wUsOQ1%}r>p9l zzX8^7ABONF4_kv0SZUUw$C${*Xbl21xk1nh+!Wuj_@tjuHaQV9!0z zS3^BoiS(kr78k2kXd$#=+3yZ@8yXtYe4~Z@08GF{25q+??6%Kjko}q=e?R!|7*1S) zCh5jzHk6P!#q>KTW~Ct|TXz(gT7aVf2=n|E!3J;tP^hM115G510XX6S2!H@>iRR^V z-1fNIrnoGIOFaEi;GRM|cU5x-Kp#MJKktt|0P-LS3Cn;iA*Etj%@Bng0bf4T5r`{V zc+~?Q*H>4E!zVzvmKj9_2tJTgayOMHXFBp}W_H%&?e(`q^IfMoOKqqo_aDzL7$J0> z&pa?NfQx$!Oy;C}v+khgoq<@9xY$@-AhibIWjy8+@E<>pOC=YRp}iuL04}|oyMC4P z!5xrq!e+b7LUJ&c&T2lEhQj!&U1PF!ccy(jTcX|J6AI+bOk}V#(9+iUzmZ(KS^h(F zE0hNtjvfG<0ra#SK2K5uz&V5u#9Aa05CdpDMkyIFvBAZv;JeWSCdJd0^O|3$!m|Df(l7M%(B|uC;^dF~jGZP|- z$~cGrMkE$+tBe}3V}SGnD{Je|^qREpcB14Y91egj!91}|tx=Vb!0hJ-%N)G(mm$y- zvA{h6DFBNQ42}>>cxGjga0d8ti*iCH*UvIAY!*`*+PulLE*2I;fZbKNJIQ%D2c*a< z%$IAnx?g}{yxj066l?dn`M*3N^vNUnuM6O4;jkCS+hmbtPM}>7XOC$;-k4&+7RD4w zrCdXDTy$3Ol*&CTHrQ%CtzvxtG@NGF;Gf%^(Nhz7JJQ{a0*4MH^^_gYG%BainvV15 zLJ#^qnP|>ZW0=ZTp0?QHrfRj{EU#2adbSot<9((#Yjavr^`x{(UVTa#$=L9|J|0?< zxR!axPuz_3A5~KlHgI|h8bABsXCbzMe$$XPLwL45 zso}VVW~t=;B=8u$_9r9D*xH*afK@bD{8*l-%zmal%a!_KJUF3{Bo)w(rnp7 zAlHH={NLLKDpdj>4jLXFfYQ$?KW4;YZ`HV+NrxEO*sg53caLXsen~%B_-?q4RX7B! zeC>LxVD%Ar+*w{e9Z&JVLxr{pXgmtJ5Qv1UfbyP%&Xz$H z9~mdNkB%-|C^=vLq+Y4BTxFa)i7S+g_H%XK-E9dO+)!~oy^Ie( z`qwr*d)8vmrO{E|CHtkyKD5O@AS0v4NvY}D(tSDox(L6P-6);nVypavDSSN#?Veyo zMeKI}$-jd&H49x`alS$7=$hi%%F@!x{P~TpwDi-c{mka~Rqon0zZ<{OU)5NzfR|{J zu{CQkan0&lhEAi;qA#{Ph$ACs2w|V5j8skRS`QCnL`)iDB`QL;-WHpnCGScmUrFB& zN0+~?NRT-d={@w-_6bn&_MaLk1J` zEGN@Y3=vl!Kk3E_l?G?+9sTElD#tMmuj54XFIA3l_n_m1bGM22Wgn~=VH)XMv}(oK zHCwK(_q3zZ1d;w7)g^&F)db#37y>F<_4TDu7)X{)=yUl_CV^hLS+xp9=d;*Y& z3)+3DU~&Kw|M2)|I-K;OX$#-|ONf!3SKGw)wD}-BPAY?Tl$0spRf%*oHk!XaLl()f z`9Xte;IP}RiUA4P$H!LR_1Z<+_U6h!Vy>$>*VbAaE6QJC-@QXb@;5g#3tP8atRg^+ z#bxi-=?18})9w(n=d}lb-}sEE4P!#|IuUVM2j2aJ$J_tJX)mz5d4f(z7&cCLcfQ8Z zxq*P!V2Bh6*kLN=4@hn=;-PYK1H()KMGn(0n)%lUaClt6o#9f z%`q7=!po%3^g1i~mY@Wbgv)0e$r(B4mgTXoWmpw~}q+Qa1PQK#mJCZJ6bJb zcf%X}?NTnh{ShNYVoo!?$4)QrlMX>KI7;E{&iz=%+LJD?DOxHXr)AbN?(g{UmcG zpX*vA^3c`fa?@XK`c+JI+s0Hi-~TNS3hD{QX?tErSNF2r)m=X>vgsjndT#C=j7Ma} z*~NN0xWCvmav~I6U-gc!)WYGbYwZc0AN`@RK8|@gNX<#38kMrR%VddrMY&hHouG&2 zz_f=)JZ>BrhSqy^xpp5C`@5r?WzTiHScRCe8V*=RWc6ZqL`MY{4 zo_4Ash5!_h-5p3u^fp*uZAr^*U_!Q3IsuGupM+D_#3&$+d}#o*5oRUy$3;k;*RzB}*a_Q;vXtq#q5MpH}6FfDp1;1XY8 zmD^bS44CPgD`1+@%vWbCjq?@SkC$7)9lp>;h8S+u!Ce8B*h~fy$umq3KlZnTf(?vOZ`^{(Yo&Cjkt zQBFIZaH8hC^AN%P(a3rO>H4krySF;JRGFDr8ucUKxCP2ogFrHi5mfQwIg*t*ux#ea zw1L+V2>g{7$)~!AdEFL3c<5Dvd(aU;hXmhL8fs_*t6A?z98x9 zN{C(q830Hkh^;VYBcE^-X|}+(0vVxfe!LH%Ffjxq^_4nHxWMCW7M468K1~SwE3%=p z70#^~iFod^v~n24cfOvu>{ePpZgtFQUj5TO(Q4zx7f^67Dc#t}$JueqGToi&IawY2ljCUaD^yGII zlL1Fnx9Y$Bx^8^GiH1_d_X`CVN|_Wu(MnYYhI~t@47Lq6ONC`+(P#Tty$Ti<7U779 z9_6B8w{(j6l2e{9kUA3J z7Ec}$L_i`OsexM|7?SptI7o@=B9vK(kMk+qlKW2(gkMCx^C&Z0oG-Hi z{kVNtH&>HDGQ0fXDdDRhmVdh9o@kL5e$y}?E2B!6OZ1Zr4bF*_6k`mOPaTne2zzll zaSB|k^8l*2Y>9)m-lO*e*FuRB_ROUi|KCEu7inS&7N~lmd_Fk?PmuS9d|#K9+PI}0 z!$_kV=~?|*0s#|aiww74+joC5*Vru8A4r;8M8QjcNL*aI63p}=lNk^+a*lLhBlwfAz)8S+eH%q@;X?}WaH?55za+9HZ+B>4y@)1 z^yiac1FxnCDOmJHbQ`U_g8^@Amh>3G6N!WA=?Vac3c}v&74W>~0uy7ZqRKgL@R-c; z9OXq)g_4(_q_QZJO?NuHtFuhLOy=Iz42AVy_-2TJ0}fr}mPjV}JG*%)EuzlD)033w z3PK8XXpLOEgu}B&A+KjJo~YgJBg$oURaLo))D>$R*FdauH_^o2XhP7+@mv{FUWDIv z(k*((3Xq4TU|1kNE`-XPCm|t`%j2q~gKAEV`OE~oE)(Z`AeYO1Ge^;!X#!-ay;CKz zG)lV9^%r<^iZ8ShxJ_wn`#Lk*yu>7w==X`z!hkIGHY0Mc9yY6W<#iZq!>N!JjbS_F!5BouNaS#5iNBn_Qb7dQN zUktxUM`s|?OX1yZKvl{zM*6g-i-rZZiC()GjyWr<^RV!+Lg`0oqd0s%=3A^~rPWaE zLo)pc{}?Y6wqSI{Qstb!@>=N>bT9D#hqbqis&eh#cq!@bl#uT34ke`(L^?#IySoJm zX_4-bP!MTp1OZVI5NV|wl@iY6-Fv&^{6CxzXN-63ca1&Ru-1B>=f3B>=5_t5xIXymB&*0_W%O%hjg}QWVe4k`h;MQVtqVyADw|BF zAR5N6$HxULkKF5pbjLP)m284TeBqK}425ZAg?%}kgee3t{MwRA5l(V=G|pNO6X!?yT_SK;7ED}Cx5KAN{O+KzG3VRdVtweJbr>( zUB`=W??p>sO5z?zy9}P|ta$e69hj&1Xe}gX8aW#iGdp!-%D;lDB!Xv zIQ&4>*Ki?5%#3{9+$Jj;F)J&}k~N0U#dSmFq|w{LYK??UO->yG_{kqhihqxZcQnxB87;%As$7uv=5joX$5+VavWgLC!P$l<2HPT~&_ z>pO3;hu(xb8pjSaa^4oF)v+WPkjb}9)d$RS$r9cypzCtcTuS?Cra^EuoN-IGXV;Wy<+!-jeT?mBX?z271(qc`GRU-JbiQ@p=Pq{lgHaEjlJd=b;a@J zAj*ty>CtWs>6{PABU=M_i0`yIzPx%QQqS$Vku&!+>f%C;EN5YdBtOUgL_DL2h3Axe z5gA|Zi~li(d>~)>56hjr^bm6cm++&}h4+J}B8=q@V}D42^9k2>k1xi8W&-vi14R+B z-|;qsuR#BJpQKjQ3X-fx3#RHVI(AgZzrapsW|0vYX~F*JtTU0=(wCZ?35KbPfow59 zz~)m}XjzMW=~D&W`g!BCYqO3iJ&VatR*hb~Y4qM7K||vRWUev#Y063bnvx3pJ&Ss0 zSERf_bFlu7WuJPY9T94Cc!P*4a=`GCd=$a)>tDAj^scm^Pfj&N-RWF?1tG%32ncSz zZb`*|s#BrCM$s?R+1H2rejPtkPHHtQIYE+woE%}qV3kK+f1C+jSy2WWoA77&n2OCP z$PdrI%#fNdzHfMtPS7jAin&@f0 zFYUDIy`tV^tTBG{pZ}n+i8@iIBo@wD>vsEML?0_7u;E_tG8={5>mBx#H|bmtY$_S9 zvGSt4GtG) zN`*a*jq2t03Kiu0+ivjiVL6(8vfJ%Ee)%p;Jh`=D~H;cv`Nz;$B^%ue>4>9CkY)q~M=TzXi{W;x~y(z1klc#|+ z$S}Vw=sx{o3Z^B6#GZ^qHP~Iw)G98d4O^3S#ojI)ar+=RMfo2yRfTp=c#?BiS|#iW zdfp?nX3FJJ_&6#Mq!{5!i(Lgj^pK{FSu^L6&iQ%Z(QA`!x>(jbzxLhs(#1(`?+(2f z(6lv@^jWFJi(tQ zyhUV=l(GBTFfjU5%5zisiSSmf65{gvrxLlJ*f3r~!*6lrc@O?pm|g zI*fHy{;!clv*rOF@dpb)gd8+uYH9xzur|BnAvWKAgk}Ta@6Q}`J5bUd4V!p2YxckC+L$j#v*|-Mcs-X_a)liO9rI!IQE-js zU5(iBim3jQp=*AIEt>W*YIst}bu*^>AEE}F*n)Y&Q2I5Ww*~Dx*@78Mz;8_HI>Y=|_r2OVZ z)3NKLD{)qAFXoJ9kfx!p*qJB(Y(_hr$Vq0m{|)KsH|t%*w5Xh#<a!aWJne8_&H z8u;kfvS?&QX5RUA@?Gx@nF=xR6$tlmlENa#5cwpyXBqZvkT{VzU%!66XQKZmoQ2tU zFalhKeGdII#Sa7I@d)0rY>t;49?{9y4k4vAL^JPpv2MO_w0uvjQC42ACQJB+tk`+T zfbp^SO6pNzp#54TYy5b1u_K}Om5bZ?s{CjgW}nR7OQMdR$rEN~G3{V<#pBCNddqGi z(siIv1xZZKBOb7)?k{Qd1xUHdZ}s~L&8jQP=gstuNQGvaS==&cb*#wr{(_^IJ^?Zr|9BFy z`HyY3NDL{iujti{AD=zQkzI}rBxldfXQ~9z(`KA82r$?(Es$mImo`=D@y>qVPe+xV-@5t+mY*`8-^;FxG^-Y>l!pUvrR0UC0&=NL~Sr968k7l zv|eFHRAAqF-1N0a2>T8DUP2|y)Pr2T(_HUIrok42E$bm%h^_w8H5s?tDzcCp9!JZZ zJBNmm92_RQ_5?^J=bIOaU%Mv5sMeilW>#xam$r_W8tTDWajYez+I9US%Ph4zBZuKI zxtgQ+3)Y8axI*f!DH$sNb3)_ufKAxDj`uN&P6$Hd+csaJx?=S5u|BWcE(=|+pq&V~ zXvyF<7EefDDDz~=_t)3_RwRySUqwxQBF(UV(C%Mua`E$aG>H(h_-!mdvY6Cg8(wo~ z=a`0n7@K8J=sQ)c*H#P18W4^!n;_eQzBxoAu@bI{)dd7-Z#*cD*kpKo-|r)pG&xo+jBT_&CE^uL`gez3^TaD36-%roNylEk57iIV9S=7&lFR$DlKwsA8`@Nf!Uoev=m+f0} z!-IPesIqJorRKNUoe$h2ef?Ps{6_bNojFWey(6*hK%6VnuYAK9-0p6qUV8TUhs;I2QYB6a;U05)O@f?h^?$0#6f;8>keoID%t&9w9 zt0~fmvjFcvnijz_3_CY!I#lg!Z5QLe7eye?gg?LQ`2?2TLMwIo z`EY)f)e4<<1LQC!!GWC*8Yttuupn!HQU+Qsj$iC(#pwdYT^y$)|z)Glx2H>C-RIAsjjXL z*1?5^1(~wITWWt^fR032OzSv^>Nz5RMdxj><$K2oA$6q|R$*^!}sj%dsyeA{SRR z1eCSvZ4Qw$%rA{-F4{ zxVBcw(QGkDljT-XuKp+Au)9KVRBesze0q9XeW&4UbZJE5KdC=uKE!RQR10^`|J>fY z43*Fg)q1mr?u4x5;#7eu}-v+1d>p|K~O>2qMS)Lx?T`D;j#T`G* z9dY{d(t2oO`Rx-tW02xjLF=!oen7^mRi;LE3h4<*H2z%wI23eY%qA{=GMxEXx0Idu zQH}}euq@zNh@Ei6U6=FRohSrsviZ7kc+llXfOUh0w|%;|bSXGOTUTCQ{&mojnv}HB zygLi@)}|JoAuzJry1-EXrPEw8JA`3^BoV2oJ{z|*R<=h7Lk|L}2w3@*pe|^oa zNZESKrE(G!D9jp^D=RCfVC}rOVh&H{a57V6PR`XgFm;s8%*f1C_zX7MkJHUJ^W`Iw z@Ng_GlD*b+ejXpJe5g9U@X7!eDIV_j_Q75VU%<&-(L!NS%k-_m$NhlWfk>0%KsIPS zva+(u(FMJ*rZGgJVH6P|q057-u(#VXJ}oWnEG^$WjmPw%T2|JXhAM949~r#PT+Lwq zZ=*qdGOM_d5ZOQfbqZ!OgvpKl{KBh&tADe7g4=ol6?L0j^#5~rIAchS54;ZCR4{fkf#>Somle*|v zgrH)a?V;?x-T64g2Qs-UQ&=^BVtCiuL^TmZZjdC(EZv`X*#O2anxq)cbouppm`{C( zIJN{;?&$U8usWZ@=4{)AA~Jl9_>tx1VsXCTDL+&j(W3f0gJFPUWM?)Y?K)&5l-Ji? zRj_$?l{-*!WPSpS;-Eljh|aj#vjHvIdg#{DPS?A-!Xr1e4qNY)KeoKJWZ8Oa^)S@< zJ)*oGc0s}AqrGc7`z%zTWkb-cGZ---(6z;$`xT16zeyhY)d_HVn-jC?=zV}d2K7P~ zgajb)A^pl@JQro03h|7_V`sb8dk>S9!ox#IeF^+Y3R+rbzDu2_fAO^Nl^f&MChG(O z`4eJdNR9$S<6f_S{Pxz!bK@J`9coE$QD*Hp2%4(I1=o%8B+TU^*tE{0SwaS2GD{3x z`*_-i6bo7DJioTKBo@+bWMpJmSkfUI2vJ(be2K0ua`l_tD9Te=MeF|;ktY1I+1 z#(5)#zXbT$+pA|sVw{9IrMsR)kK6XJ{aAcBk8nExz zEn1H=erjqt3VK`6ROZkTspPr z^K7iFijp%8`bsn;phd`Iw5;_RX>uWY`xeV0ryI~1`0TGWcm6Q7z+}n6`ulBV<=sSj zWXYKW=gXfIC*)DT>Y1VojAVe0B!P+3Tbbb%Di*SaxxMxN5t z*&*%a0@*?#>W9&tG+q&r8yAU+956Bv5gDE92&(zRArqTA2ZH$xsj`{34x}@+Z=isR zt*hg^KAdrO>$%MqM1h=-o=hS?+M&#Vt)b70Y03u*1~8=1(-rCwZrtM?l3`u_EW>5_ z5<#@mkv&h3{xRHkbY>P7i(6Y7#D7*@u$n6m-n7o-x9&32^Y7WtC1SbxHn#&fE|p)t zkgaZPXy!hfjKaKgh3CP`7caWhWWIsG%4FE}*5TXn!96I(T)}r^wxof68P>#fvdvgs zO#m@_s?84#v(f(kb8z0kL>^5J|Tu%WN8BR{0gRC&j{tLPj_ z$&4fA;+gul!6^_WBt@OQTTNz{piRu}8?gzp#UJWC~FL4a#y#4?Y;q~q3EeY?w& z_y8Wc#VK3Wa=Y`w477(}{`NiEm0P9o2R#In37PgrKW-P%LB|uJ2iir^y=h!ekdRCm zh_q=g=}a9#wE2YxVlmXme2&>zw^}UbW?>3Vul3x1icmqJ8;lVaQKn51k&(Dm-xzN2hwqR2I7Co`j_L6mI+@y*l%x48(b3tmkE5M24Tw1n&{z5s9{)=AP`t_e zcJu65fJR~(cukW0`+jpya62HY=r-8l?1h7uhY>sHzh$LhNQ$CmiX*uW;z9eJ7q(xw zehG4N`h%2)9x3U2s5Q)>>w1$hMx0`P18!&os5u+U(}QJ!0?bYqkrDc{vW3aIYta|r zvWL*BqHF&nF3|)E0Ys`DRi60c<~vHM__sxQ?koc#quy($YpxX|Q}BLvO3m*4KkI}` zAD=K(?%iJ%9d*^zjEsypI5{~9a-B@%nY@LB()Kxg)>l`}vNG{mq9^HYg$=|dC)l~J zYLyNQL|+ymIxih3(_dYk4T+D>(U;16jE)Gw4o*AyL@oka6R53@zMz}23_=kp39v1% z4f0ckKX0WuO*#_hRF$Wlr?R_A$!r2z3eL`wsRK$_J#mtm$_lfyCe=otFU3S@s4=2{ zXmvA&a^$N401E$ur9AF17#ELlFy?br&maDzk|y(v`QKwir;lD_Bgm{Tp0b{5wiB}d zmBY@iVy@Na8r#r)oi^mE#J?Z5|G5c0FwTzonLT{!g#UAoncfV3AO3&GPQfDS)4KYf zCt`O9YP_@k8=bhntJ6PTFeU(eW8eGTlYjr^`Si>3>}x_W&A<9mL_+1O&?qnO6^Q(+ zf=uk>VUeXc7@|d#fD87||0PO-H*;`F$?5;~0b~_4HF*r5+K%P9xVyW<-DQ<}5|FKy z!a7x;R0$8?#>R%9uk^3Owf8&kMSlF(XUT^00d$z;MV4dx=@(0okb#vj$#p#OUEz(L zI}PjCuV06h7`<9r)$7+ar-y6jP!0;ZV{Nkk`)$jLXX%wZdu9S_J~-zlKfhd?nF{4jGTjx^K#c!%uj8bMZ}rxmrRv8(yq%JKwZErF+S_^b<3}c8;fXH+uR1zv04rf^ z{1ozqAms&z%en~*J3x>&iA}de#3?i>7nmQ2$R{ss-!+3<3y@Q>=T!!E+YpL*B3zyD z@>`YR^XBH808M%n|H~ch{LznLFS^_2D`wdjx74S>sg=je{-?{ur>M8H6G0XA3y}uI z;RC?}0K23D|7@t1C@!ust#qr?eM2OeE#AKS((&VLTgyTMX^Y3k$Cj6t29rh~Nxxo! zE<^|-P=k;>)iJPH8y@$MZh%%SVSq7A(|45G)xjE#-aga6#6uG4+d^HL z-N*H;EJ}PO){S*>v7mGL%3D5FcV7txori++CWSqmfSQ_`kZ`=-dV|lBS@u2<2C}6C zx`u`X@edUTlK!p?EQ|7jhIP%lLU z2nm#H7m}i2d`pHd#(E$)VG$h@lQ6QQBj|2mBvgm(eq`MIF1Wb3Z&Ep4rsxUjJph&} zzGHhkPxy26($0}5BD5okDnbt?Lg}-*;~M@)rV!XH*JbJCN4LE32tt)lo7kMKjN4LH3$1t>RX-3xu@2 z2IKS;6yLzs&FbYq6n=LD6BbR88l8 zm|%-QfU#-n|0gu=0DRTxPp~P7cT#$sY5UUydoYpZGR(VC8*R;zal$?_E5#BEfq6|0 zNf$ zs}Lowbp3jCd|ch03($(1y}UZFTNMy@$(7wueN#y&Jn_QnZAHQn9_i1an!x9IGlq_( zO?j=!xlRI<2M3wYmHx5ITwZ-Ue&(3A*JF@9NcHt?Mt@*-NJ~Q_WfMm?b^hKExmj0H6>vMj|Lz}LwjR#?sqS;*??pH9COYGf z^+EU0;Fo`>(Z4s)#70ncimF$7XaCL||4*{9%8Oe_|4YOB^S+^rzeHMC;>CUWt0(>Q zQ^3!9{eS=2W8@BGh^^q!h{q(fwRO{a`?WIt^XqWeloj|wbmWF0_+X+Q=4QGj>fm4> z%iz1&#J9YY2;9nV)mBy4pcP^h~!09c)v3!Me*nL4!ILi59@B@v26}U35!%ow=jrA(@){>cqS_7zJBO%z~dA#3y zZ?yH`n~+joBw{8lip<(afE7eUMX`L5>CG{GzW#7WHuiy;+~1%6=qUyxtL4~z4UPDB zg)G<<<2zpMh(9#&4O+eFk$6C_Y4SNhm1b}oN{hdw5dkpb)yUJWjwt;wR1JQcv-QtV z=|0QI$k-`Ah)Vl~BViBy(|FPSz(8q*C|vbwKQQsyKp=U4`ev@Q;s5x|67b*!yesel z|NIodh!{*>TJ(+s$(3dKas8S7R6RI2koUfQ6XviMswMvWA?#6`uM8;%28nDiWbCff zgV>W~N+~=%*u%I3S$#nB0vHwoA|@{eaBv4;6q;L7Vgv4=YYYse-0mAQQ+!5^o3zsY z&R)4_B0fwnbdwO$_Koh`SwK4iA27oYi~EKJrZU(mA4xegfTjEv0A2n^yLCn{bHI@_ zRcr3>X4>KNgo(yhWdQ`)Z~B^<&q{g`Z-0K-e_Q`-pvTKowAYwQc=(mAHWoyj0|VR3 z6mzg~aAM-({P((8dQ&S&;d7&%&nzDwJwDvqi;0z282x%2GYNH_7R+Xs)q7a-)hQVpenuVkgD698D1vS-G&{Xa4SuK6!`1n`_2ly30 z3|j`Y)N>mRV57bPuoFO>K#oE_J~BV*iLr#`bL;)R&iRW5FH$pY>mAzCBz$~ie5D?w zUPpD_36s=@x)!60*ocrC83TCY{zGeUg9Myl7sMqY*!Un31e=)X);7s7Fi@xBk@NQS z-viL2jI-HJwUG$m86dY0MyAdc>Cxf$JAc?^`a_v5+e4vvm{_Y12UkCJhN zJWYYdoyhVPUx+ma93oq%O458DZPP7Y=}q5xJ88dE-hLezc<%$nJqPI=T`MhfSZ8}a z0{!Fst@j6P-(qP@nRZd zV=5Z4eIo2|B2)~5ffrVT@!nGKYsjvJ)H$I%NpwHhlhvn`DG47 z^uR;fpMu#R__h}MnmcV;oLU3m0?`5GJ5fCdluup+`tI}S&LPCSS)ncb!7s2POc-V%*#wH{!^{>2L*F0Ss* z%YqwJ1f$Ok8xzOUfoJ3e#aj9DFnxI)@Qyi|w?Q)$hNL}si?NnD) z!HSRb)6&3z{M*+sG`t%e*KRy|jgQ~u^?jX0p<8klBfK9*oB$F^s04ws!(}OJoULT3 zjMU+^?3YzYGbAKg*g}Xqq=cW3uP<$?*6GU$uwm}{{!E*jJ4AC-4MDoH7l!f-Nm{Qm zGqaWcgPEfvt|1bQt(jT0FTNzIfaWO0SiEK~s^X0s?Ax+Uu3yD(+$d$yJj-Y0byh?! zct0jwhQEjzGz378-nU)e+G6&3nJ#C?D-rO%Sv{~_0tUnaPVSA#y6ox8;hu!)&KQoh z0J7r+rg$(tkX1F%sXEcDGR%E60ZSPc76uIE_zPP6;nf5kBFW!1#y|s#^g=u$*{~ds z@kyo1xG*=#Lpd! zeu5kR`t>(2c}_Qxb)D7il=i@75BL1t7Ej~sn;E>6r64qCiM?+zR}iVzqbzdW0{WUj*jv9V`JF` z66iweS%QvxizFFIme(-tg`eJH{qAKW(dzfJ5zau!tIY^faF^@8#%VW@NMMk@^Ytr+ z(!$bnj571*?rRJI0bzKwgn5|rFG6H6E51R~-teG>7(fU>O4rO8Fs6-I?oSr6)kebneeoTwFy(+3)t+oU)LD13Us}?{p4?v;B zE0`P~|2Fgr7%y5Fpa1jlU&1eeBYyL<(Si!EX&7V+~4=I z2>cO(31nvWSTxi(pK6xsd@L-I$Jm|kcFu+7T{B0xh#9#3>8|Z6Rld2|{KC7!>+#dm z_qipSgo?y5s$0S;O3a1b0@HPmPkQE z6Q(IjzsJ^$p>d@FSu;XU(dg9jW$|zv(b^3(dPMgzUe=>cLxjXwWHr+?o(pYbhspe# z_HnpQD!x>#h_>X*-9M2uEFj-wZ5{Fc^UDjMDG12-rEqP;QDbAem@X1ZKYhx9PI1|R zC1GqPLR!{UB&iv>{o0YUv&WZajm43!`=~dviAketDp|3vL|=_{8d~Z_Ph9Cz!kn@9bAGI6-7#8Olvr>imHC(CXW$Dd$_>*|vv$ zmCCzx)M6QD4s-1kHp)whWXfy|gluaG$2!bJhHCR&5px7e6CD?Hw?Fk6>>{9{BO&db zQJDws7AnVB)Qz$)0s?rj#g z78d9#=;-Ld_hbj@!gSH12)90aMaRS#H>&p%UtmdO%e6GYd=77b>nNSKEl14l>RqDP zAI>yZ&K2G&Y&1kf@rf0XWS(hqY11w&x&P+opz1Mkg}#eJ-2PYhl`(+>sy<%N2=pua;K*XpBUP{MP3?Snrq;)|t6o30vkCo6#H9N~sKsF^?qOGo&O|q_ z0-S?l>S23S?A7>rT6MXi{>oUqQxa36I;T1AGiB?{BT5uF1R%0pAWilVIPvRxJe-!w zF@4AIFx8lMU#F4qG*Et9?h86WEHz)}iUlGs|6lWj;kWhRJ!4Lb76%pr$P zpcmO-1(Uko67$$nc}doZMCpL#0eVp%faQe?iR}(6qk61==+4R>O1~i9cv^Hes+KKt zA(574ri3{$p-^Ton@3lO~nINZf?>I|9Rdi2ul~< zC?B$PCK^ifi1c;wa$5r7ug^;gMD`%>000q;yxqZK!w}fOq7*m3rm3iZLhD2HN~} z9HOtuGZ_Q`d;3Ne&5e|-rj#FSHFB=lCAZS|IT#o$j&?&59oBC5q6?H`l&3V~ax^kg z3|ZYLFm~3=~^S+b;TW&(ct>M}jrlo`~P`wIz3U8v8Hi{HOEA9zb_q(@C-A{+Cz zo*+LeVD?sx395h#2{&aKvw#3rxnC@X_LG#t$%7R2@`G{=lo(*nQ*R{Ia%DW$6`MgS z-yF;Tm2WjqwYR$(QBC<{b1K9ssmwH=q+Grlda`S@cBGZTMXGdnYJZ?s9x(kn7~;8S z7C9#5ugUA%YZ5|E?SgLKZ9{*s0;@t#Vp2?wSt);+>E`vz)fqsKOVlNz95ov-O!g232@G=+AY z`!ou30MJxMtWC}~qnK=@vL+a2hlWdi3;I#;qFmlSi}llu9#L3GMs#`T3^hGS8Q8J+ zeh@ZtbQTb=q85ibqbwwU3$Z)mUf_bDudO#Gk4A57DrCS=%8|EF?h%{JOmzflYE$1N zKU6%p?PE8|`u2Bg?kXNKn#3m-Fud78m#EJlDfv7R!IQf0+lX^(w0M35WITV4%7{F# zjoG}V4_Ita)|hc9_@V@CyvO&Fzc>>89>Gk-!)(H{<=WgcnH0XcM;hne!p!syKg~2@fY|o^^E>ahP{{C zB>i8F;pMRIExP|Z!l1WVc_e@JJpU6{K(er6f-y%`(O~oMPxZ%(c0~C1P6(MA|CBZU z|NVI>4~N4w0fe1VTue+=Rn@bV+zv2wFmUeqws%E5q@{0BIK77&GsG_bu{_fr7=^unZtvmaETZUZ3VY&(y z_kkpXRzI?8R!g(_&AYSj-eI8n`uYwIUV}p@{LjyJk^^jr2KTQ$kFeGJ&p-&OsZ>7x z%*_wwkD;XTRQ%H`50)NI250#z=WUKlj&1y0TC4soci2-r#)IYv1T(n|h(@ zAt@IcpNFZj$Cb?A*E7)p!~afS-Ucv3#t5P7T#F*0p`pRw?U`sSb03_Ukv{`Blu9N$ z5tOe33DMD=FR;HG85*7*Rl&?`ZaC8oCStuP8xvRNCqh7Uyv42t67(H|nPlsBCZuI*R9UTEDveMyb({CF4OT9 zi1@Vynol*-mJ_JOaM|xv*g-3@y-ic3%lvzxsZR`^&f}+{xs(R3y}%}V3I$ccAbhTJ zd-5S0)im{|Bx~#I_LH?r8Riz#b(TiO47{r!D{0wzZjXST)&eQR?$K-Zl2R=4m2~mb zXJ;dTQX{#4qu&*@ghbJR6KGeY=*j>kuT^ER*Bx~sq}j!Z|F+tojyNq^(CC#bO|}5! zgLkH$d&N^W>@V|$524?Hvs@g%G{;Ei2^;JW5F?h!xfD_f!JK_8L_L+H&uKOsn|ks_ z5v1tN9CO&c15e-L$>eG;1eHWH#B1VW`q|I(Si|W%xi8e6%&e>!9v!9&jt*Lu-81H` zsZO10X~Of2;L_sdWZ+&m_W$Xb`ar+2d+qVcf{f#lafS29^%v^z-#zfo z{7;Wwoi5rvt?12~;4uEsM;(-!+!oTly_>`RRn?Gw<)s>;5w3|sflYCN)aTpZ&-Ol) z&3bG-T*kt9nAyJUZa))c5y53&J#4Pk(}xsF5%Vekoy%T~vT{^r<}vi^aQ(Ty`WJ`C z$Hyln)#>>_;uMQGF(DM~uT4TWjR>mCvE=gmCW@!F_Xkbd{p;?Hj(`iM!v5-`M}Rhm z`$P&tA4%ivTe|BXViOWhw_dsdq9)NkJd#aEaeLCm?ZM{yG&;s6cd(|nF^m!+K=BjY zV!eHR3;R6&|85tuPd_#RD%C7aBKj(r{*R?b8=wG-jHNp{f z@;$WgN z{h z4BVPWc)>CSK$JZ?eo7(~JsNvcxZAfW`ml;`A7SKukmSsd_wg;~^eQTY9+gv{?|jvN z@sizax+;)Om#DjA=ZX>8z~@&Uy>3BLkx1q1_7Y`A)wk*2^`C9u<~Evax2>ppDmeM^ z^~nA(Z9)}hmhdy9@e7~Th{{pU;kf-QN_m2{b=!+Twmfr(s9703qlT@~sik%z2b`@O zN{f}}8{@RMb5v<2>#aqWHNZy(MCFJb^6T&os)H)liDfM1waq#6z{PYoz|GaQ-FxpR z8s61;VKCpr@nNd`hU1{u>^h;C+}&fkbV#vlUc}3za9({oPw0qKp`^tzU46So4rIfV z!#(BupRl&A$x%>H0Lw?BX_Yc<+;*~bp-_II{<};nW6ZnNXSU6nc2vp9Y(4#1qEp26 zr{j9p-A$^&F zvk>XE*|x_P%;PT|e{F5vy*hdWhCRe2Bx1gYD8p=Unp3G&pRNYFpyL@x-8Ffnyc-Um zwxc{YmNy>dnO9X~DaiEn_j~Tls#V-DZh!WSTdyD3#`uA^8tmdP9Ya{U!2D7_(jwJu zGkpHdlFD(_2t@)8L!+RFquYiDo_zW+JuUt<tm8f?ZCw9A9}$3tsc(C zsl8#E#GnNK1Y4`|-F3NKj(4)dS8YatlkN9Q+3L|Q{a%C}upvgjZ=@?pUk^dJ z8IIKW;1eRp`_|SH1`8Y{0F#|U{_eqSt4FRhGBQ%m{Edp0_3HHQd(=7nFW#Mo_e5+2 zDFmu#OB!rUSIeGt>WB8SC)X*O3FSU&95-Vc+>8dE$M zQ@Z4UfKOjKg76rCX833o;7Z*Xn+xwaL`9GKX;&^eh!>%krz7#$o$Op~e_`2wp4;C3 z`c10Z?hG89VyIg(+!S=N4d&^0+knsA+}e8S@Hs9|byFfi?R}{qdjp5~u;%YpLjxU3 zUJ7DiVPO~wV&>=rhv{Q)F?T`Nttx};kbn|yIqBE>&5b4~zbLlH4=`HeFDdf(!*6d(h4-jm$51go8VhI7$RPoC_gRS64ny zPcLdW>$v2Ah*#o%1&g%H^8O6n@Bw}W8b#R3)NXgSs0)fr8DcmZZiAHuCi+$K{E9T4ZZn0G11%{;~DhV>6@m!1-u?O_X_0*|g2~$_QyMFN;-)3><&r zw!iGM49{%<*bI`c?aTJVl8j7DxXZd|-my!0eDaJ|$nNgi_@e^CXlndm_HIkR=x)HD zu#fW!356Mg9?ori@?aqGyde4z1BaHDHcA`I9Wv2=V15O0lQ;Mt96M{g>v>h0Gq*-f z;qe=J+E{(_F_}S{sFbLv+B?gX$maJWFf$lBH}~JBtNN8lq$k}l|M<+#v|65k(aiFG z5*mh!cg=oSq@1`gH@%aIk96o1L*dte=-5ZPQxyK1yR-;uYl#RV5)yuER9JYt?P|Nj z(Qg*6ci+Bpe}LRyUZ(pc>VmlY>Hst|!TtsYqQdBG+65>kfvM+ISK`L{SXmu$mN}X! zDNk-mipa4Y<$~J)H;msp+ipVL3RzN7NKyTwRhKRn z_)6+L{I&*95t%7sizTJ{f#r|#9?Pmd=pt}!TxpTr2EmpfA#=2}&F(t8*RPY0Uh{hj>WPc$V}lgpEQ+@V@uF=cEGW;2KW)7T08}!He1S_-I2#% zQ`k&)(F(ZsNX945o7&~;s=C@Rn$H5@gag7KyL^jJ*v7|PcSq@P z$nd4}5f!DSX{f0cDJfAg(B=KP-iZv#G6K33JPDb?4l@L!sAP+gI2(DIDfUIW0s;@A zs(7fYSRO*yTDYi3nPpYQ4^A`2{dXME`bBWG0{Bq4zEgYG{fc~3pLMT2kcunrH73S~ zomDOTn4zGd@9ell*M7YSpZOW#Zyw{W_(pnUalLZvgI@}x+Qj*%4jiB2F6J;zswZ8w zp`#j;ve66+%X+u6F>$VuL`BL`o>1g=36YVJJ$BWX2y;r&yUS<(fFs>%_sPeao!IbI zwj2};s$x$PEdJl#&AdmK{du{rM5=Wp9&HgnZKkwzG({cwDvvW_(75&nvu*|3OLT7v*pI96F9q+fXYtDXf{U+8nIP(gHVgd7jzqV(=h>BGW~Ma$)w22ZOvg6qG`s z%)Rcv_mMW}3^xkF?`%N+z1XmpB&aSy(oznfYiLqM`{>x$~!7rFP`)9%uGHIhA48?c)p6S>w6CA5U1kn`OqR z*aFcNt+N~H?RWk@&%^d6UEx&Rw+4S4HObjq44q=T zxkj|Ann$J&_II_`|}31&|+1y*n=_z5|#_gIju0;$F&n)oIVP9v}2X`xTHatI6K z-mXj1%hIT*J1QRMug>}4o8Q8$c{SlHt3g3LSzL5oo~U~l$V2#5=n+fvS`60i4Bi-5 z-k+pUeqeUuVsh2Vfpw0uhtp$wCSWi*)gUi|M07E!bw+tXx$curQAjlsA>ks-?;Fg! zCql1OPgI|hr!l{IpZvKN0fCZRMNv-Ae3KBj>X%~$BfQ=0ZG31O@WKKu?(1}Mh64^FY@0{$}ggq1swcEZD8UX=;ZhpM`0nvI-n*9e6J3mwc>+MCnu+;YV_u-rTOMLqXyjw zbx}gX`T0)c3EJg;qWVQ4(z04HOcZNesjg#~UF%&sKU8lu7wr@Cxei<~nr!L^(+7>K zTN6>*P=0+UA~>f1N|5&RQ**u`1I6{MGR<4jZxJ>zpG1ZCv2N*=)aQkS#rHF1$d%#0~jtycLX6F9SOCW>7-=Ej%{Ml!3)Mv03u4 zfGbGIrgz)VK9NaR+^)zj{ioV%c!^HNGXGXv!D{I`iDT*YTl)mzX&l`-CWsQ_{BIoj zr8-VHKo4Xc*MWEok$?X1|9&1^iAnSS_4HF;f}*2lSUn&A{YEckExJn`|Ns2;habK_ z*UUxqrZCmg($djcl({$q!#|NZ5Xl`fIoE)0p(DpqS}!cz2#%#)e$iH+Ur?!ge>d{? zzl;mni(STQ z36k^5=3PYo5(BjTDv-9Q1HM1vH$=6A~-{UpNq}~M}~pbo;?e?BRd?Cdwa{r#5t9quuIrJ#Q&L5^IJ?5wdXB0m+&A&YQv zO@Uqxqc9&xR=t~r*FfiGZ;)~+U`abtD+Muy)39Ff)-f2#u{KT#;+c&teh<0+GNra> zL!E;xGYrObu!Zw~?n_}KqLuQ^n9_OiF97)EU5SI??;Fz*N%Ai4-!~b!{Bc66Quz1{ z_g}6F8vW;F(Sf%pFRH7n-42f24kmH1v0V>##XNuaXK)f-wi+Er8=qJ@lHbk$%qzms z%ZwLu!}>a(1v((vJaRbrbhYq7%FY9kl_T8OANQ&3~`A419AhY{#ceQf)~c^$G=#_3OvA^uIl!v}<7F5m?v|Pc_?1`THAp<$(2P z#&@OTyy^7Sz`8i&OI8lusg#^YX%R_j5q0}YsmGphGUBZ?!zY76qXVca7oQkaUXhRf zb0Kjhy8IpPFFO_tzPmT5k|tK-e$uJ19=`XpcUpZ&yrv#+<@p0kxqp6P*~+pSJqc;I zKyrY&bZBU3ax&q?@yZU&VQi&a8y*CR*cnCUvWK?ZEj@L51U*2TT(tKv#=*>7HQRuhR;Mp-xJd9&>Bx|2(W7U}s>UHihLJ)kE{m_PI|O!qVH{fXS-ksbotU+Wu`!{)zkgr= z)_MZ4>oiN5b~tqGSZVMQS4c<*C_UI7FH$~0LhW1JuAD}?VKO!t z%u_H@e?7%AuJFxY%fgmd1FAZ$#c-QCFS7-8O%~VjWW}&4uII*A=A=Ar^#i9z4fcuk zzuUXx_|Rk#c^IgUNbNAmQyqOA_d3d;4Nz@P>B}G;Q4XL1=TQh9RFsoDcd>E9R!SrWv@Dp(UTW8df4hjP*79 z4vi6`E)oS9Y`N}R%q4k(&?jjpp*T9*IEKo|bH}O6cu!_Tp~BSqNB!*(rbXwZFrBek zJ9+X+sr1FmttTT+{(F6Q7EZ;^3>l2F_XQzLH^Af?eq;m>p>)s(C|xk^Z%eVaw`6Ox z=NrLnAPH+-9T{aHLqii$Uj8ywJb{UcNk{yht?l#|fPO_p{QAT(5RH4}0Q;r4Z^Kts z#EgyO0S~RdGV&DqvBMaH_hLQR+qN%H$Q<*WmS{%ZeC3TtAtf&`9pc?m_It_9GR2nM z80jXt)Y2cXVfrfFVsU&$DECgw5`xa4(~~7GIZWF?YoIO!W4+&GGIy8sF{zmWewW0( zF33W&x7ScrRYjpts;Xr`vBUQRZUV)?w)Sf8;2<3mW*F-Vr;-|TY|c{AsTtT{xH=|# zgUeVu(5R!J7-?*-&H=8~5W=nKL8vLvn@jR`ax%l({({UGSS3l@t9L9J`zoF<^985NTT?%(!xk@uKPOdE?ctbS^!=J@pqrDfnsd1{Z}t1o)3#d` zr?nsLC|VnI+y4ltwg{z`Liw&>S^)IXmNUS^yz@cf;>}25tqm(%+p-9q4*2-iwl z)jb(`s^7yPBjOe$+Lb`lbHwg>QCxNPaSq@f2Ce-lN&MhZ2nbV^Kjmg|_Hmm~U)aa` zjJ+8-d0*=MQ!N@x(IB!dHT_KIqbHO8T9ltvdK+%RDaW`BBN1e;_>E;5D(~tsgvWj# z!+?B;xAmQ&0eeLzsu>@2jr_%`UFA(XeL~`>=XsOBUs*~PB!X|!Db+Imr92kyfQ8Ke zEj%@;x7ew9gPn~}Eh$|hSwOG>EW3k3KGcD2B<+paA@)lTES?chco2BdTQJH!N!dG& z*S!g(HnloNU36DdlZfoX-FCbM71*S#tgyH%<%ET{MTfg#cWd@)Bb}DNBb6aVaZW~SL#vQ!}D?rwTdID}t zR{V=#s0_VAD%Pz`6V&5nWo38eY}NGjTT`AUdpL}1XzqD^=vczIZ?RHSz3vy1+V$Y2 zOE*pun%rDJQhCRBLTAo@46W#3dI~3a-Dg#k{qur)Lhg?$#!S(u*7j=$8^a-jNX~@a zTl~W*nI>HmJ6p)`90StC5&!P>n~*UIY^GRl8Q+anQ&UMP<9QQzVihmf%i>ZB zg7WyKn0IfKVNO8t<>V$9FkMNRUv}`A!glnHl@I zyk34UgJ`T%ks04-7c0>tEA|$(_&#srJwMUSTxgb#dK-szoHXvRSoY4+9jZW`wbEMU zN!bLdcy)CEgguuM&~=XbM-jh|rvH7Wxv;HiXT8~Okh&RMtXp9hBcQgHiW!p$3XlKN z-6IbX$gxa=ik%scq85U4+Zr`+!suO}bdDOL#EY^#z@mc$CtC|1zs-<%ewfP6Zt{2w zA;64FD6g%y^4^5XqvqY0mWv9gL~~!; zSY2DQvdX+RGk_imf};Tx9T4jr1iO#`r7;zu@vi>rZ8!7UYu^Y@PX81N%kg&4YA{T7 z8>`{(35S9N7gD&|rtqX`qiTQ=)=~eSK&4wZ<5!M9r?+gjGcyUvjLsrAA&(Jj7jj?1 zlp_mAj`k+&Vknf}Wn9z7zQ-3!Hb(oMDs1e+AE)x!Kv2loTMF0+mj@w|G?*)IC4GK8HPJ zFl0oNA+}jdcw2qC%tHd#BhI<3KS%ORP5n`xlEP-3ZHPa37kMBW_jxxzDL&#(@P&$=gwgThCw;zu$H0CuZI~?vTO7j3V zI~WyTm*&WT9!`)j8)zA{RnoJDK#&w8?8zSki)KH6ZAmHB$~ZmH4x*zq`;ypvnj8{3 zzcpZ(=z|KdB=Bcv;;giW)V{T4&*M^ya3iuTgRRpbkqE}WlZ%rY!1@VWnGFUuKk=3S zvCB|JuLpM@@Z#m=1<5B2i3@P@D0vYJC?&Zkf9=cX;O34BO+Nq3Iw6Yno6Z7>(B6(G z5X^fs-FGzDaNvcX=4fx{?<+PV9+^i=;^Ps1PaJ=_+M1Km?uS<>LBOtusQ@U&pG*2Gb=-Acbcb_mx znr_<~Gq75sqA)a7gxsS% zz_Css7QR-?Mf0xzqD-{Ja_Wd?8jFYgUJHm~u`6$+$;$!>7$l_Hl~jO;U0kfgEIs+Y z?p|)@a@3^4)iQokfw3TE7Y1U#Bl?Rq5giLGO;Tp{ti>Ee+k*7kF&C%la?5T5&r zJmj62rP6!gxfee_M17NAU+!>O95jm6l(KrCr9e|krgX2fhlJIKValCaIDF5=5TyjV4a&0PoIdKeXpu(YOoF;-*a6VDl`+#%KZ`}a?TN>|S^%3BV> zfPKAp($bbY)6|2gSaJ{rhpt*pEBJwlFB=yZluO;{D%D_SZmA@4)<+w~vmw#}v@u|t zm@lakivQx~o?*tMt@3H;pvkAWPt;Ddi>$Pus%VU)b5Gy+-`4EEt(XzCV#GBC2Zy7o zx4X;vt!Q1l-@PNH$HWBxysKp9J4<5b-Ght1AAv{Mge%D^D74K}JNe6&Twc5F(+*xe zY&Hc)6%TW=GsFw3r!tT3ed>byTmk`nQ~CEb!_Fv8yuW1i%19wz+f{wH0i^JQ1FOco zsoe%G^X`C$>K`zw+KENANA5krDA^VH+wD(hOuyp*huDV9AbocISM4R+AnbImbHlFN z5fly&<2$Nf=F#jz$ij1s0E2xpid@-k=<9pr-s%92yu12~k5LkrEPT$j z3oJ@Y>#qxrtFNyI;lb*swCLN#;7dLUy3gcf)1o4AP+tKlR|OJFvC=j#YJD7sfzEfh zuf2V0aT3kMef@}#vueO}Ar6;F_yO?>_6;m~@~#E diff --git a/docs/images/vscode-format-on-save.png b/docs/images/vscode-format-on-save.png new file mode 100644 index 0000000000000000000000000000000000000000..a03349b6f8d55325bc40f55d9974b86e12989b26 GIT binary patch literal 41262 zcmeFZWq4dWmIZ2Nierp1W-c=`GsnyrGc(&UJ7#8vn3#)_Dp~CCVhXs zUvJ8%Tq+&yBOOU4?Y-8j3YC`?LxlST2Lb|uC?PJa2m%6y08CH7Kmq@6Z&KobfFN*~ z2?@zd2ni9&+uN9!SsH_Yh=(SqLaQkaV`OT^M)QBok%Dc9oi2?>(a4vC#`z43A{pYB zZ2$;|tI(#=6H*mH(^lr652L`q0QJyDQIMbS_t$od18X^_-blMh<9dHR81tD(=W@8f z15uu+3hcpEM)%bc@S`9j@y(1+7bL$0MJNXQWD9<0DcceK0S^yJ58LcrXMG(aB){E+ zeCo;c-G|m(ONSR4gyhpUvo$X{=5`*)COU3TF$hTRH?|A~!gxJ3zaSVWm@7uuiRdjj zSlPI(Ud6N~EV90F5DJRwrCbD%_?6FcfL$Yg#65u!JP5505D;|EzK-T*H?0t*&kg>p zf+3_&_+}eNMlUiQBH(#X@)`( zl5Wh7Ui2{fYy-2I9wE!vL!1b821b#?5>`%8_WFmsa-5Ec$b=?zjl%Q2NjvbvYIm^h zUsY4M6SWAG=td%>z9oZItAFPEjA~#Ua&}W|*t^TR6V8|tL(EEK7eV696k_P=9}SYi ztCCCy7a6mXw7VZQhPe_mY$`HhXC+{wRZPRD#uQBZonQje;s6%wikP$QCI2#}+1AZZ zpr+Z-i(A06OzWV%ijYv06{85oA$RYt2^K&u+>^$C8mo&%O%P6w)&)s9GdL3nIb~PF zew9me_wB1X_k%eKQZgaRPd}`A=4j{|kWQ;?Z;N)S(uZ`HA_sqM_M$n9s^JLF)<=(g@mU*X~KZu5J?;m6OQ(04O z_Py`^jzXTh&j5ztl}FMcS4%DhlC@#T>aU*9rXJf0jtkRcF={gc>jC+gb10Qj%?}V=|1bznT=3-O<7YBPY2;pPL zkdAJEYQYAgu<993V-=R~l}B)JaFovukvS-P3$FG1$p-tVRgKGeKOSy%vHZYREIeoj zsq&`m3}jFjnp*cGdv|3r+adUWVyJdiciHVRn!h;`x3Nt9f&haD4!#m<0 z`!W8cXGY5KH_4uvB65UnL0$W%k_-Kl^B0XfWV@ep&g9f*1ii3i43mf@eSEBs;XR5~ zj?&-8dnKzF%TP%-C{TL#x_S;72)J9zAe-LUurI1TSojKd`jn z5cGAT7DIUX({_h<5s`dggkgf||HjyZ-^0-3)|BK9YZEG*i!l{@h;(nj$Pmt+*5u!m z;2Po@v?y@;87W4bL_3ytI2cXDAP!EvKYu(QJbxx%RuOR2?w{));~ytjB^c(Lfnu!LP9rm~6OE^b@DKRj$Lj39nC!7@HsGA^M{k~-mzDnp?q?^mj1frk8R z3FR!I$GEOp>;}GL1se7s9EUk6)wD7cvDv|S4 ziS98$N#lzX*0dsHzzTt zQ$KOby;mvdRg{@nm$+lfJ#R*I@-WpAiYK@ubX}T&d7cf41q0`T*_!Fi$iNKMre

        ~N&M>Q_~(1*=M90_)D9j`g>G_F6m2o%sk0?EAUyxzB_8jlDc#PJ^(K;kY<> zx*SXFcIhJ-6yPB>KXx$rb*9rS9BdZeDmb+EPrddUs7MSTi&P1N^6vW7Q$d{WR;>v>MJ zot5v_Pq)(h(uJDgnoF7oA&>nn1spQ<*T>qBa>}dJ7FpITo`Q}7a_OfsJxP2dy@mXs zUSe#}HA8(+T`-?85-~fnV(52CO=z=j>nNHIla?MVCr%4F1{^RZjxtA+ zTOIHj0aiLQo->b9`}cG(>Qy$MjrH$(HZVD8G+GbGxBL3POCcoEs7>D}4av>*kM!qm zYf7~zS?dM?b^sQd=WU)h*OjEJv7-e@1;zzgsNIMsOWc0zOo5 ze{j}o>eI>ia@BGnF}|32WGX>9yC|26V({$v51g{evI}!@>qBkgUf~sSzH(0Lz_&SX zah^OS;KZ{AAL<|%9X#&53}$&Gap&+-dYJ#J`!QK^A?#!8^IR)2>7E6j<@1T+P3deh z3{wRV`L_42dZIV2cOf-3x}{33bJDT?Jg_G-Bme7XZ)39!Upuv1<+Jw&bQCfz!ACyc zSLPk2qnkp&yzZyYAg^}5bS`chqwvLPT~GuSW*$6WRS(c?GI0KYcer?onwzXT!WyPh zG{5(6#-_q%cHr4itg#!e``92zz2;lU_4+uFE9^eLoLo`!F}10`v?wWsU6B^I2n8}k z#k!(IocCYo&IvRL6`Vl%8s5P^(|S^H7wrCyB@&I*Bur#vK&XIe7!XKMR1k1r3KaMU z0{RIA@*ims5J^y+|4J)@Qv6j035Z0ulYZ)WRg zW@AnG`?~rDHcpN_L`1(U`me`7+iC1-_TM#GJN$K9z#9boJ_BH&qX+zNW{zeie=z%f z=AUN&xUYX!$Nl?aobqO_#+GWrW>&zi1~!eCfrXi!`yciEzfS#kOaE#5#lhHK$i@n2 z>B#%vgY}p3zn}b{hX1Hj{lDvEq-Xv2D*x@wzghmi2Tny}2OCSL-+lPS+RTxcksI*8 zW&ckr_5U{GWngCh%jn;8|EGo8|7!8?x&PBb&fW~z5Bk5G#>?|lxyK(P!P8K(8#F#ZaL2{AS7D}y{FCLa14Fdb0kC!4?qX)SS9-B-Eao_)V@PEke z_C@#mk7a;Y;Qy)DCCLv)@;65S=*izTE!r1YVZwiI)bF!U;ParUgnx5L_*!69efrOR z0Xz$AJm=rE9E_w38>$Ta?`{w*7DOAh`u}SDJ^%jy(W}0k(VvB&6iVk=hztiJ%25Ai zhFoTmL?3n9F3>}?yTx|y)&pRAU5D$D$BV;rlp`p`mp~&>9S2=v(d48xZJ{`PHAU%yWagU7>QRaW)CQYU3FSm+aAD4D`w2(h|6Dh zV9?gXi2TEcmQWj}?_0OtW>+_n=|nmxI2PZV*VQDS4|F;&FRzYriQ>3qr_BcMsGjXb z`#rTGD3Zxgw8E;74>W`8WvR-tk5abVji$)+9WsQcROefZRs_MjPS;Tiy(^f@>XayN z+_Olxf1nYM<2x=utBJ6|W`m4OCY8|p)k*ylTkJ9d4xK8jLYv@&@kso~$D0FHCObt% z#lFyws-%+WLP@1CN=!eBOXzx>IVseA zWiYPlYgQ_f{Q&GXq}|z&0<)jlF~vIVK_keMk%E6*iew>HKS>tlDTK8i|0qqU;r%(9 zK%-7Y5#ZP9$!4=okuAPZW3|GHr>q%Y?r>0{vic47B3veoRpVJz5kxeu#&{G`Yj=0o z=o13>*V~f?-FP}}(S8H6kt+QF9z}=-ct}Q*hTXB0(W`G`DNNyE=+vQ~h1OBHoGme< zc;;o&IUEKUtTaT|ombAbQ%p0_?dt7;uA$A7TPQp zDyT2lrxbIAhkX&C9@^(BH{`Pl8@~Kd{@&8vr2=yP$Cb?&8O)hBJ4*O{|4`RErASmP zi`z}`b+}b%(@oZA+g`+5;R4BoIo)>mTcH*kEHK`; z2ZyWyut{l!gN~PLoETb7=Sd;6mMC>duP5#cV;b8QiU@0Bu}EjmUzHI70!7B7DkbYU zSc-q#P&Oq$qkLpSkXFN_OP8C29Bpy37+2~+io$!AU3Ak5#V%97Nm^{QshrGxe>|Yd z8gwOO2E!`hvs{Epd;Z)MqF!%akj$`yQ|)qr&jJroQ8SW2ZKF*h7Kv*Q@osxHs}!Yf zXNDaTC5J*0K$)z5vlYD4zg%x&ggqM8V6_rTCS%2wt2Ji)gYNaff(u_%~yc)#lovl)|-?^Db5J|$1k?~i_xYb{Q58jzek$-LL%nC+#< z6vvcW?oKE3LjAom3eR_VxNB+xZr*cWR7*BwOB9VEjz_%8+l{A1V%g8kRCN^;>rh&HiBgX-#zr;F-TWQ}24y}FIt+~6$cvuKk%_p#`& zTfqdy3cY75eA#Ff^M0d#n$~8Nm(bXpzrGm9H+hOvJ_I3PlO==%I>y&~9p(goQP*+Z zQU~<=B++RX5IsOqpD|7TYU74mE6^JRjWC*rQ)sF)o61dicsw9Th+W}ifCI%cdb%f| zSlcnWY0Ox?pXBWSkV;-pD!6^_vu zI!JIqiGD`hHk@0hXUea9Y&jV4QcUEOp!3P6s%Er>}V2h)S|>pnax z%BrHQ-SB?a1}t#H!onVNY^A?G--kY*TLfq8Hs7kKu1$qv(52fjVH~x(gf`Zq{zn2_>42bT8KRq?~Qeq0f80 z&5gEjF_`f!(_?iK-!3|s;GAr^u6eYc_`UP}P3@@R$id=$N{j&0Wz8vS{Ln8zyTwsy z@)(%YfSq3UF#ti&3rKYZb7nf-uibMFJckJ{owrs7sHVi=OTGiQG$r6>FnZ-kBh6#b z$E6cKNKUScVmKJ-%st4&s4>P}IqLNXSJrRw^JS%4?`EdQvecf9p~PG{{d~x1JS904 zlBdi?;SvU%BSlL_1msgL#pvah%_wB%t04iqZ53|HDJ#a|O?5xT(`TWeQ7c0?U7*%{k<^SQnHV2)4lw)zy`s>Q7EA4&pbIZ=*bVY63t)?c6< zF3qsG>k{EbP){~R`VAHO69R_;2Mu#|GesGu$X@_f*H0A z>BiVDeo*4jkI*DkT1_EZRS!&l*km~{CZJ|!(|u>L5`+5TDQx}WttN>21nDoZBda;R zLcF69G4Ec_cMfHZYAf4kjf1Y(@U}c{V(xdRw5Hlii2Rwx5*8+z3p>1j2%`8cQ7WfHry)y)OU)HCd|9x&bPqU{?9tw{bm-LSaW->;TMmtMR)Btmx}E7{=9haIOhwsT z^i$xj*gVGAF9}5q8UcwCZ+tRO3-*|@UGl5*q@vX-95IW_MWsyVHP}8XfV*y!mw{S% z6u6!C@x7PT@ByD`?0Q>pU>- z6VhhAVDoub_J_)5=IIY|Gf0X;2-?csMULa zd$pf^+)0c@hmUKpz)ZJ5G3s!=61;U8rKK&KnheR}eU)OcS&xFzuzx;#Cx4x86^qQ` z@eri~A*hQ_4unHT1#W6_Oz>LP22?6#G_TF73LV4c(w2T`^-X0(+h`K=<(lMPHL6vL zHj7o=aL_o1Keq&$>AGkmi~Md{FCuFqZ;x)$#|gN!X7!YtF`Aa$&YOW9@QLWoQn47ULfE z(ZWUnVLycf7MJtsV#T%f&rQ)%>vUc(Nyp>aZj~So2X6)M)fg=A-Foh4OB?ib2E#;S z+pg`7rxwnP&T@`z+@l7|rBgt&)2Xl4MK?F51+Qf+JPMZt&;v3%bnV(kVq?Oxsw^=7 z(mEwL$YoUxQ+sp=O;g!i*zhFe-o&9%z3sC-Bgbd2)d^aW_p1d5xL?K7#bhdlbDdax z$6-?_pYij;0u95UEyVE3WIdC*+6>4jH$}*LdwL|c8ci%OGhAdd#oY9+*V`AkSm)`_ z@~N0tnC6*;K5h(#p%0|alAmYp(!jhuVN-tWxlK9v1fC3=4_OiGetVqf(%t}c#Ah(r z?6#o|u6O0inpAc1h`yt;{qVx7dAjq`xwhj`!ji432%`*uLX5WXd@0Md-ybXSMowng zk;?5KTe!uR`$KSn!UeI~+izGTZH~r;W+>~U<~ono^!C$V;T6#Kb5K!{2!Dig3`$(e zY_%zr_Sp|yw;=+O-FCAJGz|>Ju3WQKbb$DjlF8J&a-QZgV(=|VS2hv;=8Y=*bRf4n z%bRnUQk~yU9$yIi0*r$A@C+-1)Be07PnpC*1(CXKVzqWck#bJap= zc7>72nSOd%8N)FDeJW4vJDOmH*w4vjIayf@zBl%jWib$VQj4RtX9*7KywIoCn+dMA z5nmC5dOb8A1e6%mCK5*Doq^l^ib;Btl4OHx$@=pg@J~eX^B*#lP48wywQUwA5qQ|Rx@81dd zCO9EQp(*z3na%8Lff0by+VEx3j7o{3OvQV2wo8KkC^N=pmoF%Ql8o~M0-k$fs7Ybe zmP_$>$dCYqQdL0X2a%$gm9LC53%iMb3XPp%g=KL*6?iZwcr}s4Cu-1}zXC&3;LbOZ z^&XBZp*6f5D9x-M;dq@TQn=i-vs782)N>KY{4u7Vil{YEunT0!a0jLeQSL}fxBw`DPGAzp5FXx(v>rz$K+ep{{H z_l@J%hc@(AX#?($Ym_NrQqrq?H)rW&FBx>+Z$T2={T~EE0B?@xN`I&KG>~2ZqrFC$D)bFDSg$?!Mi@e$HB40O-t4T z=zRHMpSPoq#f`jbN}`S8rek=b@@xr9;idGkDT3j<6a~47T7FWOtFIIHWpIr?=ml_{ z*6e4{R;{;Ol6+cmX$`MI9R?8{-|^J-cLA9%ELJIRkyI>Av>@X@nYSuaqR#`ffc-iJ zPjKS3z;s&?K+nFZo`)dI6#MJ3#HvU(gUD3b@yk7^F?R$p+uCej>Yi^sxgyh>+neb2 z&JG^nx`xYxKa{bXpuWrgM-OD4Nhc-rMyQ;32`dI31-j~LkeWyx8U&uk3$D^X= z?dOZm1nY0}#fK-AmE=Hh$(pP>ut@e*>k~rI5B8T1`kC!z3kyv%@Ap?96)ZoXt2P9g z)v9J^)6Swbmj0MgPjCd1Ns6I7PzEiYM7Oqk3U==fuj|9ZGbeSv(m0v8e_UD`#^GSH zv|VL5LDJR1D%?dI!=VIO%R45L8H2IS5!a25<7M*Hviir#Mh3be=9tM1+5rzW-E8HnzJfVQ~M18pr=N|+uW!e zzDfbIV5)5Lk>->-ZOPYb75BFo;pA!lA}NLv6+qX+3To(dskZO=A_{$3&9_FSRE2nx z$b+s6Zz$B~wSGDAbT0|IgayqqCdp;9u~WO%!z!2?)3E_BVpI11Jc{yO(3WAg^PPVW zY>@Iz0ygr&Y=-qhW)U?X3(>9?SB6-(Oi? zchzTgzy*&AJU7yE@uwB;wB4e?I9wA`ukPLHIg9)lvtJOoOsXEK$l4T?(3sxC(}~$U zgRWl!wNE3Sy}L_xgqoTKiKo>HvLkf(sP|~;+N1OP=cepeGFQB z{Yt4RZUbUsh=W(+mu>x+y20vZhtz2l-Dx!3{-I!3@#34uOH}rm#<2HU}?Zy_R z^g*>Uc^m05{L`{=Bt^Kdg}OJMCP&%xs*lb0#&fk3<)9pEw<8*^khfkd8rkbKT%}LE z#|eX3;Ln)XX$i&&l|)e3RX?~ptP4kx1&wqH0J`5a`{U0F{2$bF1W6N^fyBf1nhRgF zS!_Hb%jfQLH8KCk8=o4juw*xA)bqvaS`cCw1ZrfSS#_#JXb5|AHM1ZDw=bS=kIJLB zsAyfaCa?LPUB9=-{bz!XonXXT>ek*C*Ke{qo!%MBbvjiTOIE=f9ph?QV;ml08eagvQooBU&hd4Rjn&ye&1nS1JUc)cE^mRt#sdH3$ zDFVPyibkXwI}2m0+2J5$z5Q8Zj~{!(%O#!N?n8mepf<9w`=nG2t1|FonNQG24{j1ut`KCTvr$kx?C6PPl&-P ze6DwgsmHJdi;F&zML3L+CyO_s^aw5&N~g20uioN#?TEsk_Y@{(%Qs`JPPmYkzIspSbjVZ%4YJT8WLU0rXx#31#Mkb7drqHuGG zgzS8JxV_=1d#n^C;!mt@2rL+bK0Uo-7^uM2ue7%no6!P~7+A$-w~3t>v})HYu-^n# z!$Uk;`)_| zy$>=PfppcAOQTWC54(}U2nR{{d5!er$OA9G_Qa{Y4GaQr_Vs-nfIE`BA1_aMjy+r9wZ?9J>dpj$dcmyHDkw(GncNe>SaKDYeDI=exJAym}_l$!NgOMgT|50AT}ljD@*?$C!v zonz85Cl&geE~RPzlmnKgKZeH75Zk+g-RsMFi-5*SRD*oBRVV@VCa-7Kqtu~ttvfeG z6zI*y-~3~<2?Hh=Ypw5d0+0s%VNZyk=aFL+rL4XQ-y!-vb^D@oVHty%bu@ZjKVm2t zo~*0{WaBA~%_dgz7mu0OQpkQ(%sD!>ipt)dF@(gKfAUrggP~{|!PD%-6?f#5Mys=S zGnBAdJq#dz0EobS5v7tdZarw8S_Nn}q&M9ybN;aIWtj;>@02p^aTfzmF>R*z06Ss+ zy4M2O@jY)3^R^#1~G-ohq68AUY(^x>NKUIszuGOLUfIfk@Ty4_HXT1^8g=aFM zQti+ff9n2(y#EBlDPz7u9iwi3-?#Ipjlu83!vZz}SgTbb(cg#~Q0Za&zDW_)@*~9k z!Fm5LT2MF(1QBY=bb|U%p4VR``Nx1V55j$XSa{(-taAU7M@*6P2MGL1xe5Ezef*V= z;sEiLKBQT!2Q214Hj!N;r zxfcd8U#Ng&4-y)bzp48Fy752tg> z`i1!qx5slIDJdzpU+*_QVghuenNaJ^wW&EBUF9v;TGS)(o-1~oMiObsD>^$ei7Z*nXa>yTmAmTw-N0E=kR^DT#3?S&pEo!ZmkBZTBf<~oWgEWy=6O{$xt%I$j z!{s*)?y})kNwouH48!rb8pO)m-s|D(t=B~3Y19>Q*=^;e)9(6x&hEfFHfYpqLMpUd z!<(Aes~wL}tKDy@PPBAy7bOY7JC?1m8I4fnxUb?pp$hs234AE#E3^$WF&wt2%iE4X zQLMh-9887-H~NCdy~he^ylOtta?M6`nbcJp?U zd^ql&wX$258lS2bw~Jul&NgF+=fWy=%`Po<1c_P z<9k(0=XPTpKR*HrMwG(Frwc~IfGByG+l_afcIlVW`CO% z^nfk)6mkSbJ|WP2LU_@H0n+#a2>35SL&*$zPExS2SIk&y%m&mbCYi{oAhCn`i z&I*%Kk=Yz7VD=v)hEAo73am$IFHj&2Dxj{k`nS5L9(p2^M<~FLV654GFEOltpGu@q zI>izST=!PZ^q_JLD$qDj^!pdZ-I-&m)oQE&r4Fv$J@WM|X`Ev1!X-L014 z;oFyP()^NJq z6{}pRxtoYQ*LdVZiIHf!y*I4Y22aZ|`zzlq?g z-y}38J2J10qT#+O;8OY>o+OgByR#*Tt z;{YK%9?s!bD-94@bdKUOhTTBox$o|51&sH7Bee>sn@}n8+8xq2Ge>)BWQ?ePKHl)j zHm32la|BW)+m)Sf5%mV5?c7JVvR+4|3pZ-DCiOtL;Ygv=Mu+|h!vAsI)%zk>S3@TT zqKAA_Jxa-<(X9}<6Jl#GT0@g!egtQIEy%|iDErQ+X!6#>MUfCz^p^-r+dQF8PQp{LGMKF*)6W54yH{1^=5OzmBDbbl$0}tuB4`(*wBA&(< zH%vxoDfXBj+$=UK-;ikB#c(yB%UxQSBSR;ZB++bm6pcn=CY?#g7>6{^QoEyTzqE> zQjthpj=3u!4222wDlsPcHU=fL*8QLmter}xB6+IYQ>bp>o}zTT^DJ#+@t+BhA9}$X2bglq2h7`WPy6A z_CVeRC}og1lHAT=b|Q5q-IA5Cf~tZtXy%+}ibADWB7G>y9oR6e(lc#h)5df(b$j#= z90f7blk60ZhH^0+Vgh!T3x|kLGDEtu@h#6@pJ@$#M9}wcTh(>u!HIw*9Ubo+;uZ6thoX6cqJ3|=s=z;W`1|uP> zyEMC8SQ{f;YPEvo87?<=>K2B7+#6LzYh0aHY&lD|${6JT1=9tnIKo+IvrnL!D_c{q z^{(pahR7}p&@%!34%r=TxJ(_&zc-?)-mhJMjQj~6xXwlcjq>l>ukPE!btv6PQDLI~ zIYNlUcT-1gio253HX3&2Urs)yRqMSzIT`%S1~oqeyGbpy5N;Clyy{O9X|z5U&@#~o z%9Gn{z34!H$a~>}(PD4VJWYQ4I%^FTKp$0h&59;m4x-Q^U)L;p)L?MO7?{RuiVeTH zZh9~));2%LUS$+PVXKYF(hI^Cd%yhLH;mUARy$pcf=FpAp6~4?Q?|nnU1s- zfQLzbJ=da&R!lx4A@HzaLJy=PeR12KW1lmziTns*jbIqPQb~M{OH5}qActOF9v$pC zPirIL@qBLQlsVit*7Scvv7LL}?l3^vk}~`S2DOTo-iJE9Js>9hgS)CpSVO!-v0%=i zh(47a)>GAh1RbOFCSl-++sCdc2`J2=#U!r4Mg8dGwu2=qW3g0in1%#Z|2+<1J5+60 z^4!|%06FM>`w4~{@Q{b3qUeFd*$Lz_#GRdHpAb1GRt+G45wZ5gO;d_WFi-`WcT8~| z*&v+jE%L`YQ3a9-eP)@2SBmg_w4l&HAmD=f_R);-g(k^j|kxm zr)|`d4Z>@reUBaGME-3ebsevEanI+=*Y0PCjS4+d)CDn*9NCN(dld1&Y;UgaL>APe zE9=l-_k8I#^d{@MYXMeGsG-hjbl{?;d21Tg2BdiCKUv$C1-H1ty$o~e0tC%Y4o@Ik zMBXLgF*tGQH$?!3ppiB}DPG&vfL?}j3&c42d0TBp{RO~x12WTv-ip=dv7nzJ{=>$S z{7A?>?#of0_77772qjTZa0Z7Duk2RoNc%5()7x)9kp?`dl6mv2h4Lb%z6wD*$Yq*U zV?ZBk((m=X>I>XI-D+EzV)gqcsQoywv%}syJToA&$SH-?>JiptG@77V5Tq!r$f8V} z)zvz$h1QBhND&t79-)fzoeUKeq?t`4b+L;nxBbHMgqt3aFt!9AW-0O`4B@I`X{Tdi zGM=YXoI+mUyQPa{9EaHFei-5naP)^Gu?+roGuovvUE-Rg=I#~*(S0u3LPW#4?hUe# znUzF!vv4+#DY$3&?97tq;p5EiO+fohb(x5^4)(WnFMGXETx}bmo=H$LjIl6-t4bjw zvs@Xkvy*Z*=G)7jNFukQ=|{_U7pm+mc5aU*B}IfwE-6C^_*cE+4HB=?oVyP_kNZ2z z8kHfQM4z{Q-4id(Bj4&67zFw0gn+YMEn9&1AI%hbu1{|F!_Vbve;w;NAmeNXih3Ih z#GrpjC0Vl)Jcvi9rEVLk-bn=4XUNH7; z&04W;T`LuUVErw5t~D8-O+s+>07_71d(?rtOREE1K5ywZAf^Ng5RZt1M!?FCH@udi zKJRG#J_3|+50si3nDClJcq}h%c7wmtsUa40J4`OoW+zMJy7|BFM7cE93`*@Tnd-_T z+Lbxz!%auxzc#cLIhoYK{Nived$g_qtzZ*FoH?-XhvX#}IGCSQy1SpJ~1E0d;Wm zZ%T4J81a)!^2e&hogYf0y}@ipne@6!kMGmBuImIyI$f`FA8r?nN5(Nl5!~T8MdWyw zM(tG#qk!rq*>PS*ZF26nhd4oiJdiZ<;KfA8XW9oZRaz{W0dKgUdcAj1z9n?nr+HE| zZ}o7=eL^H9JFn?~UOrm7F|(kB%h*3}y@=~9c%D56@@L`IhHI0U1Z6->dIVVwJLBb= zRiqh%pXWwvceNJj+5Nz^Q0k%u|B&lT0EkrE&21~%)dSwyYO_$=)A1-MEfS3J-brQD zPxT+P9kfqtwN57{kJk3oI*x)AsnCe-+LQyUc=AgR@pQA7<(FRwJbC2G?ioGqq>rw5 zh`mCU8+Qg|&>n9vQTFc#xXq^XCuc9fHyVJ#$bCSE2eQ(T|V7!p5! zu-^E&e?@NgD%)2t^ayprxZxn@G1XwjwZetmc>#p*#i2HijdV1N+;P9QB7!sUzPW~t zI4sqWZkIO(dF=UYc;U4zOFXm_@OcBjB)}*8a<^h%=`j6+7ERnu$PH?%AwbaT#MKX; z5Nw0~Yy^EH(KPGq?DmbV_HidF0SvtMmj*Q3hG+OVEx~bybshrNrT^EZYv=lk^d;z? z+}-5RYoPep#N-TX;4~Oh*HZ*fv(@?gwuf?WZe3VCZT4ERA)j(pw$n@h4UN|rE z6Gi43>#xsK2iK>q%Z%5Hj}JSOdwRvEHCA?N6}JohJHX#~hz5S0;mSQL6DYBlPQL8u zvYD6odDrd1ZnNHYU6uA>89a{M2h~=$7RaR4$auuHKy(m4WG4F`L>wS?i>q?mD2?3^ z__U>+zT?s(m(tJI3uZ7QLb_u7#_y9Xw7eKQz5qo&0L-V3`FXxx53})9KI4sdmL=zw z?6^{^{F7$d8(SBnwAxK4%USwf~2o<1znQFf_gh;(1KNE z6XC9iaxDiZtqyj}eyVLE+Z*&o8Ei~emR7wb)!U*g6nF0sb%a=ee!=rOI)yzt{u;(! z^CX35Yz5Eern1}75-85$BWn42>aFn7upsQOTr5PF!AHv~*VHQskI8_&;}BY_;EV$S z=^@~z`?OvTHhgh>b?eaAU0~R*b!QYSd1{~0sUm?)hhN_CXzo%cx=Nt-kjQ>_f8WEj z*6&ax?1$4L>GK3xK8pJ;rek=;rC8)8yIZoXk+{c@_WASU*Ie=RHQnZ^YT0Q&;J%Y{ zLV(fyW1UWq9;k(SH_i9RZoh#F4>yfE`KoZ5s45%@$ENWN6Yn+jy4v79D@#INa1O=k zg1*3oeX#R3dHM=3kX3Uqs4B8_M^M6oSQQD4AbSvLsdU7HtO zE5lJTJINXco-RSUO9F7s7dmEb{qZ6efmQg6YQEoyF!o6x1Ay?W+dFRT!j!`6n|#M( zOWR^@=kpLT&#cS9EOo9AkJnRD!(FsnW~VLt>#O|A)7!|$V}{m5mRYSHc4Rod@~<4u zry&mq1U7p=Oz&QwJF_{d536vwOfDYu9U;&x_WhfmJekdL*sQ5=!~lmB7Nt0CSb_AO z4=X<$%v3N)`i5c~*WDLb-MNLJT);<1PVKw6HzwY!90=SG^`{EQwHriZ zcq1pEFvu*{UsQnZ4aWC%>$TMp&>IrRMQFrNKXkB6+B$6urI(M-JA9O;P8=(qaf|W< z=L4iCpy>vW-E%*-zdfay_eBn?6ZF=)?iLOIF;f^_e$qz5!x@cQDantLY`k7-h zG;rv!J+GGz^)kcEC|{llMZ;P^a=8rqZTOXHxOllr}) z?oOQA_c-LHxLO4Wl80C+2J`wp7r0E?G_$w-8zsdz^gXQRvx_I%VH*lZ)5iVJ7jiXd zfn+$7w&tAx-N9--7KHV?9ea0+ju-p7eeqJdlm#KY0J|QgP+w+O3?M3_Liusr;U$pG zTB{N%Pse>iaVU)~>-M?J2A&vM2DBH*T$fTzB6Y}Oj_?F&nBKB@S>-+AFlUuKuk5|8 zKT_pk6AWLcJ_cQ%^*%mv`Q0Y!eVrQsW4hq)+0r4990Tejw+mK#>T{IcZ)EPJ6@B(n zIBq;n=+Pu(!S+yJ&V}d=8CVQKrwjJDK0F3LAr3TSiGvlCtBdyS+^^LbQ|m`kh_zA5 z-Y(vxSrm$?Wf{KVJMu8j2tJh+Xs z)HlRd>a=rax4idb#wB#)k>}EWQ?Sz*I5o&ab$j02{Nh9)jd7tu=-M3@!aB3&N8l=d-%yao4v~e z>Hg4-7wz8FN2S!+ZTE+r_Uj684wY)a_Z)HQ=8G!;X+@m*r!NCXyaAlL?JOU2aVNQn z6Kbwq_9=m&45}R8+TfKNv(>Wn8u2o0=6%RL*;8t}2j4+T!Oq+J+kGi|B_g!SHv}!G zxi9nQ<7{lTJ)FKvEhrQw=@F1@>x;r28|RnD!CUIT!J|};>>I{Lp`f-L6W}izeB9af zE!Qx&{eRedtEjl5Y->2dgA)jDfh4#EcSvx82X{ztcPF?*@ZfI2f_oJbBxvxUg2~zx{7#6ve82_St*wv(}n(uKWz@b-8)hiTl0<4xJN%bX$@H&~u_n zAnYYtP?&WeUnTuWLb7{cJLtW&?oB77o)xS%`+6z<{4Fspj^7MP`D3JusCjNtynGlR zO7zn67QBX7ROYGM^aek3>+WxK3M&^N#^pWvO}Rz1f=?X&yQGfhPuW?>wri#oQd&20 z76v_UMm|Pi2M7-H;G=%dP%=hnRm8b1D9jK`XI?dsVSU9#OD$~aWW}60dWE@in*!iH zH&5$~+gEfxZ}ouEurr=Z-Jy#SdKW+a1z_i>*Ujh5Kt*p8)Iz(m{ zP54bFZNt|1lkzPo1hV}Rw+?LqgYT{)>NC|pjz=<1-Ai}WJ$bg(Fs7bg#ppiYLFZcm ztmcMdh+7VSL;_=5K)SFNid}z%sZBo zx40h|aL9&wrYbBw%hfG+os^S7G+6l8%0v{IE&v1u1+~b5EdW=;L=jvwsY&V{jdq2_ z(OE_GlXN?b3H+7Ya=g5HS9~<~i%DqzcTE;e29J@nF=kvXiP%pOCMkzN3Xu84G^ibo z$XxYalJhM-rcx}1g3@nV5CDf@CX=yK$-V{Yv^s&*i&s4KSteV#$Q_-}2Y>hMmP2Q1 zf;L-EM7+-d}kF)AGk$7)}=x_TPG6gS$>-_H21qt(0GJge;Pz!AyEv~S<0EJYuc6c1U z$^RWL5p)I=KNQ|C2&w%o^_J_J^C}|a02Kn7#H$0{R9yPh{7}EW0(P4>*mMwI$41^t zlZo8!0O7<6W9RSmWP6TMD_`;gZ|(O9-jiO1C0>zAhe2!y<8xAa38~0+x&!Z>QHDu>qAGss%ZcjOcz=JP zBE$%tQ5x3a-x8YnmlnVmjQar+woDG_(({UZwt`{JPOoQI6jWmO_ICk$JDx-|=iQF@ z^uH$Mdu1_#A%ZfI?=CM;NJiNwuTZ%yiP`U^?}4~$_(~Iq9!e7F(p_jc0j}gi8?<8l z=HB!5?BByh=Lvq%Gg<~^N^O}>_whD!oicCzB~q9)l)FwQ_x+EWp61Hg!GZGm+f~sT z0!?(h;}(OpJ3U#{`R*q0V?el1dXbT-2L+L-m5IpRmd0D-mLT%Dmoo&_p+QNAvb>$) z3=HAV{*JF8{Yo>!$Y`5}9UemQCXFu)j_=P$LIoB_=VD+W2K!)iaPKiOr&O3mi*L1hROdbca#E+A`rE}YaqvZ4U+ z)G9<0CxGw{J~Do$Qw)Aw_Y0Xc3NO?efn5cToB-6awbtyq#gB2<;ZFrgpS7%n+nS1U zbvDpiVO1O4b(qCDvaJfHvS_EtZhRzf6eT3|tZ3YyCC1z(D-W&=>}mO%qiL-r@hb;F z%yaTV*aK5hT>1nu(ip3cx!msV_X`b{pF2Fmvz1OOZ3qh;b|y~L<4tyqZ;o>`sS${3 zfPYifGGBR3nsSi~dD-ZD_2kFVQj2hVrTZ|Af3d)VOoZKHqa+#mk0I_w92{~Ub%;sI zi<9hHaPCej>Ue*Z5h+g^t1c@shY_uAN-AWpG~E(DP_cjo5F89CMSXrk{YHZ$^8LSD zGl4qXp+*dWW&D+VY>RH3a=^nZGTKEWTqjq%ix%m>qC!`>A7KAQ*5<`9^F2%w$$6tB z-6(P3C$$*>+0wc$Pk?o{xmu1aK=W8W3ogF=OG&()t<+X&%E*DKYRSC)BJ>3!)@sTl zj;*4%c0R(R3`G=(#d{=DxBjqS(xS3oDzp!~7J_ZxvaeCh74(JJm|z?~l?nMw-N5*l zlySiEw)X?dCC%?$8FBKE&ic=;Y`1Ze;qc6<>rqDLarZ~OKJ)4YOHIA6Kj>x6a8RcD0NTPP$hFIjLVa{%b}YT z7E#>khTVHHTi*}0222ZKw2(Zf_Cu^2kx+Y2LeB;Vqmf)SQC4{RG) zTIvc;j5q76=z(6%=)`eJ4ai!GsP3j}l_JKmu!@p4MUhDe z^+ss+l{3>_)%3oRa~S}DE%*GYKDFj3vw2tFRC(^4rM^%I1mugi3?a0u6_pE@7aeqLIe`vY^Ne4~MzcOELs2Sb0Aj z2by|L22W+_h@%8(8}Cyxrx?*whFsN=T#mRcMj2-#KQd4}3VBE&kH7vFk4*AGkC;ub zJOxJDUqT@l#H!!{t={A8*jjP~t5g1n2wwoIu%8(Lu}3=GIZij?cLerBf-YO-?m{wP zp*Z5Y=cG?RU>SlDH1sk<1gm9T8=MMQ2#J?g5@Hvl8fkFq*2lZ!4#(L&qgWl;qI)35 zNsQ|;ZT7p0uied0=xAmdmi~GSypA@i8RBVJHFY9jCf1$01s=|R+ruwh$WLWm#Fg*H zX7+!C1wEY(O->pgA~@};Ry!0pf!3DAOo+kX@wSg8%9})rYg8b=W=L7P+^U4x|Pv03=(#Jwx=HkiRzF+t%+@g3^AShtpGm|VDkeBP6yK9Dq znJcfZo+K3Nh*~4+OebXQ>=LfQw8Z3S= ztHY^WSmXc{?mCXqmi9@nOfe5)(!4L&A6wmiZrd~7l&31K&*?TW{yo!RU0fsh9|Weh z`~h;DiU;wrQDP*@$&Re~dkKIp8k%fPZiC)FKUy<+wd_GrGuw92H}`rlfyNS!Sl5qy zDnv?!-7|#f2{Be%zqG*$yTJa~!|{mKOhu%iKiFyX!?ba?>He-v@vQLX!T#oO!M;ft zVA?T*L!g~W?-LQD+@jUZ{4m1u5GN*pO67gg+plyG+)ROuhR=8+ii5VJ=T2%s7@02` zN|tVA2@qQ~$1Pm&NWZM3ps_vV^shZ<2nm7;F>P$88-GQMh_kr?UN=8J#1PQSR6JE| zoj6{hNktC+U3*E4ZE-MJl(lVyGmki^w6>99!-jsd297G2N5Sy4%8e#6y_48tVe%WL zANB9_@wfW`V&m8S#iod>r9KJr>J)%66?0e{+c5s#m&|?!ehj5u8g{M+YjV%NEyM}) zd=@ZG%JW&F!J;LzWB5sEbFBlvWKb={mNatnmFk9xL`DFyTuAd==rbCY5H#%PCYag^ z_@m9CrWnBjjnhsl_?Lv169~!cK!`T7Fy|WGOVh@;*ySh#V7XaWdc_x`*|IJ$@ka=x z4;)CBbY0b~%r%}BP5zi?W+-I0_>HMlX z?;92A0bY5IXs0Hu%$QlBJjE*sN0%`$6J$-2cv_S3ZIRJ%FL^{OBD_%xWV z8`7)nbJDSIq|Q$Y*FE-n&!n8!8%In`USARpW%GjFFGqW>v;>;|hI((|q}~aeQIN}e zXE9n5=5a><+uf=^QY(1NWI2K+^CbIzqAd|xe$4g5yiAR1=nY(_=r>}PTfHOl9oo^! zSvy!W{tQ8IR?dNw&nF`L>=%DNcg64syn2mbuOH$?dmgQLGc~n`;;Bb6k)wLo+nOKi z?eZq5tmn!0d`(=u;%0Cf6{Rg)=KB6jT7SIe_v(#btc%_SG_8890yF-hbj8 zwc~_5fZ$M<;6nm|oZe{omv}6Tm;n+L(58}k&^U73Dk|0`MuWiMez6?gp{3lTVMwwf@T>ku`tHs_VnN1*n$T4Iud!FlmT2kng<__FuNfDrqO4m*eQ# zU3{1Lr$kZqisXA;cdq&3@oa@_j{DQw^1*Uj74Q9$0EMXV+w<+5>OY{|5KANY_0h!v zC!1lr&Kp-==HE=e0kiBfo85n&o>g%GUCTQ9Ws&7j?~75r+Qb#)o&{iR3umvlE(wj_t6P%_Su)mmfY+MDM>296-XnRW#r z$5Zu#?3RDdooBVtz}KD%5Z-Y!f?w{J9LPaHU3PLAzkKn<1jx|NGa&D zXVnC-zQday?=SqTf8a{2BW?1a?4rToDj$|h#?KDRq5engPa1MZZxTI_gB-JtKUBuX z2KKC)7avrqp=j=0!f-OTF?h1IPGaT!;itHMH!Cg3T~sWFuWH2|vf=(U9Gv!f-wtv~sx!&9mVvim+H8)xHZlRa0R8c+nJRJ;Z4MAO0 zS%rU{fFF-%uLnGDPQXoX*~Uktb2Y>`c_ixaxGb}wjqK?XHSXw0T=|=wKp9~;=pEko z6RffP$^tDzM+H=HC8>CoaER z#|+}|uL@jaQmvseKm@Vqt?H+B9=BVRiZoZ?UPGSjG#!#NX*1ZMcoBF)I@AJaj zlZyQ4_mRG*Gd`YTr+2WnVKkNf#VMI}n!}15%!3m5$_>iiDRySZ6>i^d>+%h=sWsmV z>Djw#dyKJnevmA88 zF%n@rk5}_HS#=WW*0-lG=R6x#3+RLvPx!JC0j$ke+;?3|jFddWP8P`Ye-w-AiYP?% zyf;z?0nG>L&4IC*0^6DjdP83?{Sfz}!3!YwZ|Gpr>$`8(Bg?==Az(Y_m9CiA@Ok7- z$)BGi;3~JiP_!2D9>(N&D&dM(R@niUlb;0r-P$O*>gC+oCx^gE#WtEZSU_@OB~JQ+ z`nTL5kG~u4Rix2{K<{6-B*d5?iaL54q1FZPV$MaXu1z_=JSV4j^Lr+%eaWXTiPcS51u_S>Lf#7&3-c0jqy>E!^6ySR$e&l3TKYrs^$Gyp=*=aRt z=CY+u&8s-TQ~G&y57AZFfTqns8kZ1HeS3gcy1y}$ZD_*$EB|Mg671_W0|3jq@DwOF zcWQVl88KnKC>&o6=uh3}(LHXkdTK`UZ$otEC-=bz%-ZH)#q{H;)TKwJmQSk8w{Wy? z2E90N7!}}%J1^dK{LLzxzuw5~SPb%a zs(Uf)`C5Hm{Iz9-py4Bs$bY-atB;0uA@S3%%(wlu&17N8Xz$g-!#cWW8T(g1_e{Bf z$G$tXqU!uO3&g79w~CJ?3cQB*Jdn9+C^=O;)*VH^n9YoSz{vCJW>tZS?h7=(E(-sv z7j%1vNAjf9&SDniA2NA# zuOqZ8J#GMQae8?C1%my^3tJ{!_}Ho_z9$YDyPNbfKMwp2C!8$rTi6qlSO6FC(YjL0 zovCQOaCYX|HEQLxuQ{8Z)Zr@O6$?il#T2nK1}@e(F#xz@tz2 z5cu)KjY2pXb&%YYm}7vKcJZq`ZM2uhen~1+&vnmJ6GyOG;SIU-eZ6zKF6sDW8?Mo@ zE~Th*JVWjasqrk;j)tL@Mis{l47&1fEhj9)G_dmT7f-{aV{?91$?lxROtB>pPh63^ zbxu_CkRPVUD4e7_#Ji+baI7JiZ6|GP(7uSFLjzNi90EPYyapy|Biw#>d`^?e!q#<- ziq-8FjObpZ&>MAUkFSQWHmydAMD99$y84*&VXNFL2D48f$q)A9McynYX*X(O@~0VY zZj*1x4HV;4E5|9U`K@x$zma(cDsD>x{sI3Z9*x85r13(BXUmrW^mYq|n=*?#0^BAr zO{KlRHcRgXdr@mbSbWpRsyzhlL90Z|&fb#`l2@|YDJ}~wc@Db08EoLZ+3n-v1zIK4rKf(av@uce>Aw-$!0v!^C9H)?!r>E$PR8o zTD9zLDLnfl{3)~E^9tCDeaO)7f?D}`(vymD5}{@QB=|89;PqC?ou_gozM8@m@uID}HKV45j z^JhADe`AH0oFJeX2I;cG+2s&@!iejkLsTZ8JK44gQ8>++>Z_!G#HLL)ZNdpoFEFS5aP5mfI(x6DeX+j5! zY!n%5V26yumv&ReW8phl)^m&YY}hSQKn|lR$^UMfL`&f76Htp&oYPTL6WgW)?QVuO zr};p7ci1NfYtHUbol9;Jbhq2A>Nq|M8L4+?s;xh4EjnwVw=w*(GxW7Hi$u4p03V{) zhR_u4CqRy?6nlP*{2+fX3Baa{maj)Mx782eED>U8oA_ug-G8u-IY~{RHkQSVBr#S+ z&DO5z05~vP2xmfm!tBhFNXY9n9~5gJ0~LIRrfSu80>TyAbA^sL5d!YS=)SjZ#q6ev zWRwxSUKO?iOS}k3Ikv>JCu&2%-cBUEb((iMKDD5_T+B@dT{LyajhqEq>>D;|`fsa> zoi-cXpO}Oq;%j|wKcvvT7)%@L@zdR6w8vOxz9Z7z`LxeLjfKZR)V9dAQ1WTlXD>tG zb(7o6(_gyBGKt`L11wec9~5kDPKzrHN{n8b-RZoRxvwa^zmauICnp;u*$RiUo!{jx zx63`eto;kiqkQ4;{0=I%rN^Up@LZwUU*8U~#bByanfUcdB|T}f}G#Q zLz5}j#d9=d479Dgx9n>I!-ZG;e^ic^VtLyC;RDi}pS)IL0A5@Z+_$GnR>X-|-iCew z-`Fz_ui!`H2WhAy4I`(%#Se0+)~+4g9?B`<6OXeR(yZ}IHRy!CuqA#+d&i};htf@s zwE_erj82@3=+n_f^oiBR>nUV3;m0e&Bho|Ss>BBKR^Hn2q<3!cqw4LM#;7TpE?=Ve zfDmHIAN-K)gw>*_WxrwLKKUyTPC-6ABfm9+f7o2}UBA z@nk(fuP|JiU7xSP{W0+L)53NIyq$g}U-JEn1V|h>JV7C4{IRAHvX-i~>K4#xY78j< z?C636kJ2#ca~g%|NLTWUW7wWOP#l8eD0D!HW~MGUjiTRcbLJrE{#1~qZXHx#V^9qV zkl)cZ3i?SScIbeP$_+)KuWveBZqq=Ywu_mBb$E8jL}wwtZLB2sLkEOTNl&i|L>|{d zzD>ZIyG}c-jIu08Dn4zI8QPH2HObs!f4)c1n{vcBO>bT9ewVg@JFA0KjpPL1k`=eNcgLIFYOcKOAvzH z(24p7ncQmKx6;2o6NUF{i<~E z%+L8{J%t6a12(J}rB?Ib-Q$=sE#x|HRy%BF;_i}s?zV&KbK7N`WWO(48-jb87>)y* z4MMR4t@g}kHXa|0^%pXn;(`bE?!^3aNjN%BtJ<-#*+~gddwLfgyRJ%)$jsaSZ2g)B zgcJi?iHYQN1SqJ84JO=VdE5_(mY4z`yJXx&2<`v{*6nw{8tezBZP2$xfW+`yR^a^X z-ubO5kogOVuIUrEqqHGl#D?s+G+58a`AM<-Y=T%6 zjLqV2Z&KeRojJY#2nLPZMiQtaECw^@jPA8n-=r5r`Rf-7!qr^q`?Gm(&ev! zYHyp|L-o10rPkS6q^DOgifzdr-*5T^x3kOw$_l6yOCC4eFr3tYL(JHFFf3}8%bZW5 zc-Ui3r+hBkek~)=Pwd9?S&fz%z-vCfPs~wR$o&d2^r&?i?3YjfAgy`1;6Ls|R_j`b zpUCCPm)Me4>4-f388e|zI%#7COF+$pi+ zx+#MI`H|au zavZA(?D#geq&WZ$dOXeag@C_Z5>tAhJE-=K?b*Ggd1l2(i8A+o{Z_F;LSmPXjak(5 zYiZL_Z0L-097t*zfL@HgCwKRJsPFI05}=^*z#c^c*3vM>=j9kvx_~B+O;mz*gz{Wx>0^8r^>${jHcsK61FO2%zsc@teNq_WNDNd zr?Q{{I*DRPifOD#vg$LFTGhutEYv45E<)S~+TCkzxC}S|y>-ogbNf2EVIb{WeaQKB zLxH4~d@8BB)%HikDu2sDOxO)#;_J)gj2z7Og0Yh`U+ts~(P*1C&s5rM+bBIf0uLGI zM5C>jL^~j#|8y62lWpYSM4qV!RmukBEu7S7H^)wyGU&^Dc8Q%2TG~v0p4Rz7_nAda zI6p~ppQb8%`L@ViAxc;VgOu}LzNXSaGX}eo=e)zsCtdO7$w{_TLXV+FoAUIGam_H> zy+t~gz7e!FH!6usEZs#q3|Z$7>=w4bXa01fA@y>M^e%g~8T*%%!+sj0m?K#tQ$*#7 z`{BvS$Id$yisJe$CMNJphZ8i5%tqXZBAVDsex~2PaWni7H%CV!3YmbaF6175{;#|N z?~YCeZS=)gaL~RaB;x4(?rsNOvVG>8`*|MIjeMlz1Dw15{C>t$rUpps$(9USZ5egJ z{*3qI%4qUA_+4z@5@i)Gvp9bxXfKF)3xkf{jS!2gf5-?k`52yj4)TYif9#{N9`zjr zaggy?MH=+2VYQXdTE>3{l;KQsd;ks}3uR>xWZSGvkJ|4?!}g>4pecOO_Wkyd^ZW>3 zHd2hvgX?6JM$ng7$zlQj0|tdTUK^FjI)7-u)Xj{xkIV`DG?N z&t<438|#05K+b*k%xAa_ieW*r?4JHeuuU3=1LZ(zu)DOXla4V^(AHM2d33r#>SsY2 zReE%(A$k{oz|JNHxBCw0xU`dUntYAN_3d!T>2MZu+jFX|Sl?^C-k+XmA3vC_takE2 z@2!SbbZIas-%HJAsTB>Bt3~ZRydy9l7jgM6Y~fS(!$WP`jdez#W#g@~$#-z_C7@qF zOFvU$0(xB&MrTOnK1v*7w`8F$W8%h!0wF#^d%}%J$Mmlan)M$W6g5D9k!_x>rSU76 zY93=@d&Dq@H*i-5s?!QF5p6}YUtaC%0;gMvf2`JH(`zZJL4IEx04{u31>m5yP)~s1 zTeC2uMYeN=J>mq$D`*bu^+z+}Coz!{u%}{d0aUKOFEa17qA}m%BJLaXD_jAZOZ5V+ zvNur5&Kh2eHNQnDe>)A*sOO1#uY1*k>=4B{MHS3TbUGTGh)rgI%;*%q57XEU;;lj= zAY~s;uU$*MoYjudgG?MPtvoPHgnnZ?v>ttz1%wrrRmG(QbJ5sz`SYZ`Rz5QXDm}Cv z&Qm1}i-cC()@_f7`0o#wzZf*Od9_7QZh*>|iAPPirR~hVU$%w)B2g8 zc^9|KZD})CZATXW3SX9Epuna23DdP_Gn8%|g4gwj>;87P^5F|fo>#>ht4?hPixEh8 zoaXAG<5Wmjb_ii`J#{5@T&Xv#2Gw=5%XCO)r@(efe9ra>qLkJ{lv3ms)1x)hMw)5* zg*U75)6ikH%8*`T>6m7sawU*!@tFQolu*{(PyS+2RC&P8TdHoUxNadNZ=7C|ebKOZ z-_=K(67fKPm*{*|Sv|yqk-gab(}gV59n<8AQxbMYL$n|7NfU04XgQAC8*|4Hxi@W3 zoR2H-Dd^&>a|+J;_0YU)?Q472JO)gko^iw3Z|+JE-vL;RmiMSc4@G;_c@9V`ur)v+ zi5S+S3YK4AmMsR|kzSgS)3{{-I;^WU6#MY$K|lMx{ga5LIay%>2tW3WWETDNB&O#X zp;>>`$xAr;aa?A8jLhPSEo)Y4X=9x^EH=vjl@nk`Q`2C3p7r(XYGGoKdf`wP7<(#{{$VJ=fdf>4Y0O>2!(KOgVOQ-QYM=ZXh64S1XBU@U!&d7nTCzCTaS#MN#&zOwNM&0UO#NWZG3 zIu;GppV#m$d#8pP<^!-Be`YzxCt*y+>=Oc42)nv zH=^)ho23?;ShXBL7L3iUFVG_1=OCN5C1NSL*ZQA z$N(J01E3(TLI%D(j0C!bEGQ3ltx**v^wn+zA*0(__pZoS3S}9AdsMxPrM=Z?rY@G! zSLaoZbk}lLt8}q!U*S*rwtrJ(OK23M9_RN0R!hlJ;>-F-XO~OY_tx3tY-=89C%pjP zFd7h0OrPub91ZLZy$RFm_1K?MYMMVoMAQ=5dm=4z zL9@G42EYQ)i=Hi%jv3~wjxnW`mJol&?d+Zfh~mSCAabr;<^%jLhF`{PibWQc>=&0m zmq>y%N+5s+gkzqEVd6%>;k#x2R(J(Cwrexas~>|MxMMt69x{0GDe! zRw`kvinXW!NDydrth9?3!f3IG@2g<-R{GZff?b&z;E>H>qCeMpJ^%DC@uM;)2+_sF zqIF-hT$(?+=oCrzCXr~AFKh{;mAAiY1W?LKwy(~c?S*i57eJu7f{BIk(&w;>ZB$fS zo9KZpZib)xR3lYY*Bq2g(L8}_N9lGCr2_REgw8&2N0(22%83n~Gu|IP$5!i=G3dVf z9Yj*zWvk>Hgi(kx#XDwlB&i&}_?1qQFM7Eom00w_pCJ8pC8N_rADwHnpUe86*Bcud z<^U%A(eXq%|Bw+X6%?o|H;RjGLW^NakV>Bq;ueF%_6cIsA2`eGM%71dQasho;rtRD zzd5aDp-Of=i(;heWC-=`-Cw*qyAeUcQtE!?epBv?0sKA8(Gv zyZrBF1y@=eX0^9ZhF7us{H4DhsETpxSnmfo$a&2Uy-eDF7xXQA%mwKdwU>kL`?#_zFs>G!}P zn)|TBf=Y_kHThD{=_(0sYrD8!EnB)5>2=lnIO-6sqD;sQ{-g4MQ(NWL&gZ+^LX+iB zEL-LtceV2#13+RdP7#ZFg?^w9812A7%8ic;%a{9~7-S zm^v&5?@X=XAwEbhlh=qC@WINZqjl4Jp?2%O5vEK;Mm?n9F8M)i$z(yaVS2HQ=2zyG zUW&UTI1YYoR7N6dXDv|#<0bCCAzcr3&ziWu6jjcBK^A#pxNY=?NsQY z*TQyA-r+H8Tb@C!?zsf@Va&w%3_oRBnL(Y2QQvE`6=6yzuT{14Eq^>^?g50N-d)xm z6B4O;edqBvLFI8VC|8y7^{0c%&Ao6IM^0yfV?5mJ>=|0$R0fq8M^BAvDpkpdLC`aYvS`d^uNl z6M=l-1##D%)jJQ!Y4~xx7sY2f_NhXp;Z|BkJQcA!DWRKX*LqyP%~#yafeK(N@w)6| z1pH)Vkq+E0Qn7#5`bTg*^f=~sj>n>4;1vD2_vK^+p4CdrvWtdRh)Mc=F9)b|Q`Yo; z7SDCZK(noAxHZvZ=w*b(QMStH;=pCOK5r|3o!$7e zseAhzPH<0Tr?Ph(LcLY#z6%T_2b^hB(?K3DRq{AgzVjf~LT+|<C+{;6-G*rSHpUqJ+DH$7OD^pZPZm^XeW!{X4r8dD_tB z=7o#*-1G0o4nx>5HJy7+YTeDQgpXz}h)mB;Rr<$v@RFnmxt+T@AFd~>*2_B+st~YW zu*rmguMVAOu)eIN{AF z1Y^fb%D`>Y?V^^F3b>=Ld2x2>HX^!1r#=2K_dVYOX zje`-j!^p_enK1XR+wPX>b1{eTxw7g&aV}pv5Gm~YzUnB=_xT#7+TwoxoQ!Ls^Gu?# z=Sri&G-ul4Qe(lE4v*>&TWO$#cu!lnFx;?xq^ChW8a(ymdf&M0S%2GSM0=jWehN@9U-jfU*6~O+dpu%o(qXbOSW0id__8_WFHY zd~4L%zDiy$L?regCNBK;H=AA~XO7p#U_;inXyUBPqL=zbFVXePhJcSwbKW)a@W02MNj0yJK!Q`y#9=`Hv%UjNMfe_^lnYCO6Ay zb9-+)ieXk_%zXR8-O_~Lj)u4X&9)24{>HDI)^%c%lI?}rMfM?^QW2vMiyMPdA~=3M0HA-i(KZTA;O(EyN=B8yEEZPGEW{M? z1?VEj@pBUjNato@Keq!I{(Wm4h;NubU}M1Y@DYeYh$}0AOv}*w1-v?Ln-hMA!#m2k zHx~42W1>h{{hW@gO8r)S^B7Yr9!q0gVk6SMw+2R@E6ax++u3I7CG+RIJOSN&u)VwZC~wX9_3!)954wktWBZ$Xj`+9&k-3)Z9N1|e zUJ0P6;Cz8oz6uu*(+4!r&VJb7F5BIyC za|0vvV`Nl9&d6fziQ$!AY`gRW6x**$Ne2C6`C<3C+5zaU$1x(r+bp}n zrFd?n<3~4JbvKsn-;6r>hF$%d)7YRDTp9=w9tFsJL&#(ct4H(&hGR@$i%bf-|3H>nA}LFPAEHnAR3fg=lW)wqjOCHZe=l+ZjCsTh$s(o znUWv0R8f0uocFE{5CtIcZXSg9Bf3Yyji*dY$Y60;4c zYUG;nNK15djxEMk$NqH8O;#3SmmX|cXfdjtaULUq7(?gW^C;kOu_#FK*%#dhp$)x< zVHS=N8(+~G+m&s8Xg#E^&d(rX2JejOD&g@qgUv?l+VbO8gBM#Zw+)to&wdzAZA2f( zHN2uMx3S-nTP*O5R=Eh0>3oELv7z@lzi%@^TuW%Y{k#kYomX=RE-%{;U#);$Fsi2| zB)Gu7(VUpmNGXNLKy(RI#Tej6!hr!NfNyojy%gX$pPjcg&Z*&3hFsh+?T827q*~wA zf|mS?TE2bja?m-m({tG*v%V_y^({?1e)h@J%67VADh(P(j>3UBUu<+%Vsg^ZdqW&> z7dF^nfA7D#0CW(}lHEYtsqe5X(@}Z&o$AwUC|-My2&;PkXOH7$I0;Q_jfidKW|*z^ z@)MdheDA;mn1;p-?H{wDxt0yEgJO*1xPy!5Y;{Lx^|{xB!tllLW{F#v+L>PFtZ2Kp zG0`^bjySyGVhSt6d(uFYOEh=G*saf6w}BszB)Q(p?Bt{uhog2VSfZ??b$!LQT-^C8 zvu!&|Q{`Sn^lD{u>L5UfEB=j_QLCl0p4S7D^=3O;V9Rb$jM=O|>6L;8m?Qc#Mdtv* z(B-0R8q3o-XVyn&g;x3+Cy&arE{_Cp`ty+c^wFmzN@67`Yh0P2n+4Alv26I5Y2`6*nq%ODaPo&;2GBttld`d>_wC-U8ji*b2$wq*Fvrz-g zS3_(!4a^X+i7?qR|FK)Vaj!LQ?%(D!bxAofmVGe-KeRO#<`3L!5MgVk0YBUD`?JR{ zotU@Llnt>6IN^7#rkRhDCfiugEC8gF^2EAi{TSy2q@a;Dp?|rVt45Dl9IPXbu$g(r zKZ~WMN=sr#P4lbXyGfH^NjHf}h-7Qim1d5(`@u{nvj+;^Mqy>f%iN?@`xdeVjmDyS z3OTHcozzTSV^#`w_+f*iQQSjR)k3ko>6BeATt8s+8<#i5`DDe?!R$iRV+BJ?EB=Y& zoz{2^LlMv-twjX?df9ard`~|y$-eM2D*2q|=~;*qXP*D&1tJtwfPCi1U8^h@ly*8xzpAk9m20m+O0+%1@6E zi8;$@Wg8YI`fR(SQ+u8xWIk}L+aSj6k{lF}24gm!A&xm2Y<+5kAXw0b1t}*ykd2i| zyAn8?o9gEjp=C~3OySLQEq$L@Ghqv-2Um;TH2J{euB9($iFOlOb;NeQ(Kllh^XZkQ zPNVta#=CAqjap;_sG}*2o!PC@ZQBYzIGgjru)ZhNT8!h38DYJ+qZ)=DR#Rypcg;n; z9T*$2n7FB1LBVb@30^zVB-<+=}e`8~0df zGZ$hfwg9*Al_5qC_YClM#xi*}eP=xWiFs5Wf4JZ)ODnHz?=4uxtu%_QFUjX89sM>b z8YXPCiOcV5n;%#0K87Po!~A((zZlc#?|TPy>RD;5^c^Y%Z!bBl?$ue}&lpaZR~0R^ z-nDXd+zEf|`*t>2;OPN{rKZFDp8H+4%3Cj|>@Q63n_pPOoR`L+c@?#(1<1y&vNI3Q zAfd-iVedBXHP8;f*v6W^;`oe5n?fB-Id0G2aa>3E$S9q4O;Jzri=w`?5bdp0n`}bP z*Q1lGg#csWuhPCHapsoG@!Zp`)(drl9)1BA52-H{r$;!%5|3uCTUSWEDZv*Y>*Z_i z`ib%SMu!E*2J#oPHibKb4~;7g=H}iWePY6V;cXv^xclmo%gVSm>nH9G#NGG__+pnR z?py4;^M~@akx(%3X(hfqd5ZM#tP^OM(bZO)VMTom3U88!>#vF+q3AK-OBPwZ zdvi=$W6(w?JvL=8%7aOY{R%G*2@P4-NbjEpB!r*E+Lw(EVLknq#UN%RAm#H*_yl-R zkd%34s8K14q5JH%CUJWBlOSR&DL7&>4IzmxO|i4E*}vel;y%Aqiy-))!JuF?Dob?d zyI(hd_&c`0gXEM8D*q1G4!oN0N<$!Sz`|8y0hf#4_)#!;UOUaG(a0CcT)9=;>=h*x z=RF*bm(E$6{(C4ps3_Q({EcY;{=l9U|A81Ftg5eqd>bhcn>3KG$6Yta_Sslj^b#gN zkS4j-TAerRudj_i+^l$dMt?D`4BxBbf<*%z*_Ed_y|!@u!T%Hn34at-GAT0|33l$ zpRWKDyGkrB08QHXaJ^LajPOk{(5|XUNVr+$Uu%Xl6v@!g(E4bx$@=bm+xh`^^}f}j zlI}krc~Akdm3235Fe)INS}D<^dZKwnS=#;N3I2n;l;lS!{Xf6k7$qTs|JHfq=l%Lu z%Uo}n-}y?{F?RpC_VN=Y6p_)?8fXKgYIGakRO{5y0YJ$LHEN}Q*}x|)KmwW$Do>Xx zjf9{%AKlzvOeFkH8shuU6(nSwU*bUg_19ggK}(GhW!ps>Z41^e z3swKmeU<-!sz=Vr2xC=k$bY~i5`6W~L1Sy>x6ZNDJfL+@kNn#s{T*}nDP|*&31_Et zgU7#o$$yUF?;gni{^g6LCe!}E_rw3bkU+=6Aay$(*W~#x22?eH{rNq`?Z0iG5MX-> zdF?Wj|KA_}=d&wkrZrL3R1o?v=70AfA)!%qy1t0}FAnJA3w+LU=GRpJ#r&QLu>EmY z+oEOuwO0OfQT)I5u0EdWwT+jDBI~H+B|=5%!Ko=PC2y6Nko4ju!&;>yMxu=j)9mSu z4($W{e~CcxO9O9EQBD>|mDHHP5}LX4dD~^WXE|*kIuRLAfwz4C-0}D`-wYT%| z-(g$`(DO$YKuO_E9Zn~5jpF9&93Rzv7wskxywZ$wH+o`dM z96>Kjdw~FK5Qbt#4=J_2CRHyKlEXo()ShZDxD+X$R33ZL1Sgu5IkZ~M(qN_8MaVNS zDk^ZHlcfDG#SWFuwbI=8jT%om2UHEBl0$Jx)pu)9d=b=Hhyw9#yp!C1t<8!!()_~U zbN#uk=~t@I@ZyMCPY=CsB)E(m(mvcqE$G|0CG)O`F3?A$%kb>U=D7hSdd6VeH(C>e zl=nT9I^oT+3E(4=+ zv#f10;{;yQQy)q6gGkEda2R-Z$ztRurBP-fKf3qh%(1M+KhzlTXil%;ydjB}g5|&0 z8FtnBL>O5Ab&70P*+GY;#lBgAr8)Sl%vJxF$tm9Wvo^@?NMX)T9m{E&uFkn{HKQCT z;QN?N9N2dFuEGje1m(&)_^-!5y||csEp0S;3)AoAV0q&nf(1H=%3~B!@n?l{;S*;Kkrd3-z?ofK#w=^IrnU_>CLz1lHb~>;-;^_a!!KzY-9h_Cb4=sq zR-a#~D%;zNytvUSSH-yb;fx`-d7bP1huNV^Gjo<1k$v+MfqgWc(f8n0n=PnT$7Joy zl8Or_67ug{0GFVg5}E-M9ELGLqpy^{PbHBB;K(gc_x=Hk?|mzvy?)9DXx0rf)5m|)k$1O6g zX88dNgKBLJ1(`8ieK|;wg~Jz!;UbhPc#K5Gt0Yb4TI-9gmT*p(Pl9vao;gDlE2{W#Qp-8g)!b{pr!I5{QXMk-=evu^ zKbLpXXR9WPk}@3gPh_UkwM>KDE&6ZZ8Ap{q7h3j+(xU8Q*%Io9GFntlosvz?c~^XI z1hK>L>;`t?wxd2Oc0Y&>3QT}F3!JtyZR0BN-ivccV}t&ZUkHu#;CU5?uAt7ldC}qv zfZNSvgxi+pZkstYe)cAk##NIah83YR9#PIiPpy zn@8XVu{|xBiyWFC3!FGxX+@9gbLruX^_pgR&)TeWEgM9rl0ZE$K=r3Gy3|{>z*vxz z!&BWagY}T<<~n8}-IirhKcKGqLOwO^@u3*C5YXYUvb;(g{0={w!y&qo4gVyFV#$xd zeG*SBoBjv&+AAX_&hgryPV7Jeg|}-JVG6Hu z2T7}VlZdSTFJtc!tYa~ejxrpg<3VYOqwFp3>_?`MTQ7n=m+P37q84)J4r|W}FCps4{?8{RzKI($=T~;();sCu!s@ya8HL zXG_W?iVpE)xC8)4m4E6KuXJ$VZ7w Date: Mon, 15 Apr 2024 18:25:54 +1000 Subject: [PATCH 427/814] fix nbody and blob test compilation errors --- src/main/cooling_ism.f90 | 6 +++--- src/main/h2chem.f90 | 2 +- src/setup/setup_nbody_test.f90 | 2 +- src/tests/test_ptmass.f90 | 30 +++++++++++++++++------------- 4 files changed, 22 insertions(+), 18 deletions(-) diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index 60d574c75..13cde246f 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.f90 @@ -126,9 +126,9 @@ module cooling_ism ! Distance measurements needed for chemistry - real(kind=8), public :: dlq = 3.086d19 - real(kind=8), public :: dphot0 = 1.0801d20 - real(kind=8), public :: dchem = 3.086d20 + real, public :: dlq = 3.086d19 + real, public :: dphot0 = 1.0801d20 + real, public :: dchem = 3.086d20 integer, public :: dphotflag = 0 private diff --git a/src/main/h2chem.f90 b/src/main/h2chem.f90 index a79faa951..2281fa78c 100644 --- a/src/main/h2chem.f90 +++ b/src/main/h2chem.f90 @@ -67,7 +67,7 @@ real function get_dphot(dphotflag,dphot0,xi,yi,zi) use units, only:udist,umass use physcon, only:solarm,kpc,pi integer, intent(in) :: dphotflag - real(kind=8), intent(in) :: dphot0 + real, intent(in) :: dphot0 real, intent(in) :: xi,yi,zi real :: MdMo,ad,bd,r2,bit1,rhodisk diff --git a/src/setup/setup_nbody_test.f90 b/src/setup/setup_nbody_test.f90 index c02933307..bb0a9142c 100644 --- a/src/setup/setup_nbody_test.f90 +++ b/src/setup/setup_nbody_test.f90 @@ -42,7 +42,7 @@ module setup !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas - use units, only:set_units,umass,unit_velocity !,udist + use units, only:set_units,umass !,udist use physcon, only:solarm,kpc,pi,au,years,pc use io, only:fatal,iprint,master use eos, only:gmw diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index a5eded415..3e5752d9a 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -32,9 +32,10 @@ subroutine test_ptmass(ntests,npass) use eos, only:polyk,gamma use part, only:nptmass use options, only:iexternalforce,alpha + use ptmass, only:use_fourthorder character(len=20) :: filename integer, intent(inout) :: ntests,npass - integer :: itmp,ierr + integer :: itmp,ierr,itest logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening,do_test_merger if (id==master) write(*,"(/,a,/)") '--> TESTING PTMASS MODULE' @@ -51,14 +52,21 @@ subroutine test_ptmass(ntests,npass) gamma = 1. iexternalforce = 0 alpha = 0.01 - ! - ! Tests of a sink particle binary - ! - if (do_test_binary) call test_binary(ntests,npass) - ! - ! Test of softening between sinks - ! - if (do_test_softening) call test_softening(ntests,npass) + do itest=1,2 + if (itest == 2) use_fourthorder = .true. + ! + ! Tests of a sink particle binary + ! + if (do_test_binary) call test_binary(ntests,npass) + ! + ! Test of softening between sinks + ! + if (do_test_softening) call test_softening(ntests,npass) + ! + ! Test sink particle mergers + ! + if (do_test_merger) call test_merger(ntests,npass) + enddo ! ! Tests of accrete_particle routine ! @@ -67,10 +75,6 @@ subroutine test_ptmass(ntests,npass) ! Test sink particle creation ! if (do_test_createsink) call test_createsink(ntests,npass) - ! - ! Test sink particle mergers - ! - if (do_test_merger) call test_merger(ntests,npass) !reset stuff and clean up temporary files itmp = 201 From c1633bef97aafa7c65c5ba082b1560e45417545e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 16 Apr 2024 14:46:38 +1000 Subject: [PATCH 428/814] fix fourth order test fails + make FSI default option without vdep force or oblateness --- src/main/checksetup.f90 | 27 ++++++++++++++++++++------- src/main/ptmass.F90 | 25 ++++++++++--------------- src/main/step_extern.F90 | 22 ++++++++++------------ src/tests/test_ptmass.f90 | 12 ++++++++++-- 4 files changed, 50 insertions(+), 36 deletions(-) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index abbe26d7f..336a503a4 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -56,7 +56,6 @@ subroutine check_setup(nerror,nwarn,restart) use nicil, only:n_nden use metric_tools, only:imetric,imet_minkowski use physcon, only:au,solarm - use ptmass, only:use_fourthorder integer, intent(out) :: nerror,nwarn logical, intent(in), optional :: restart integer :: i,nbad,itype,iu,ndead @@ -433,7 +432,7 @@ subroutine check_setup(nerror,nwarn,restart) ! !--check Forward symplectic integration method imcompatiblity ! - if (use_fourthorder) call check_setup_FSI (nerror,iexternalforce) + call check_vdep_extf (nwarn,iexternalforce) if (.not.h2chemistry .and. maxvxyzu >= 4 .and. icooling == 3 .and. iexternalforce/=iext_corotate .and. nptmass==0) then if (dot_product(xcom,xcom) > 1.e-2) then @@ -527,11 +526,15 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) use part, only:nptmass,xyzmh_ptmass,ihacc,ihsoft,gr,iTeff,sinks_have_luminosity,& ilum,iJ2,ispinx,ispinz,iReff use ptmass_radiation, only:isink_radiation + use ptmass, only:use_fourthorder integer, intent(inout) :: nerror,nwarn real, intent(in) :: hmin integer :: i,j,n real :: dx(3) real :: r,hsink,hsoft,J2 + logical :: isoblate + + isoblate = .false. if (gr .and. nptmass > 0) then print*,' ERROR: nptmass = ',nptmass, ' should be = 0 for GR' @@ -620,6 +623,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) ! in order to specify the rotation direction ! if (J2 > 0.) then + isoblate = .true. if (dot_product(xyzmh_ptmass(ispinx:ispinz,i),xyzmh_ptmass(ispinx:ispinz,i)) < tiny(0.)) then nerror = nerror + 1 print*,'ERROR! non-zero J2 requires non-zero spin on sink particle ',i @@ -630,6 +634,13 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) endif endif enddo + + if (isoblate) then + nwarn = nwarn + 1 + print*, 'WARNING: Substepping integration switched back to leapfrog due to oblateness' + use_fourthorder = .false. + endif + ! ! check that radiation properties are sensible ! @@ -1004,15 +1015,17 @@ subroutine check_setup_radiation(npart,nerror,nwarn,radprop,rad) end subroutine check_setup_radiation -subroutine check_setup_FSI(nerror,iexternalforce) +subroutine check_vdep_extf(nwarn,iexternalforce) use externalforces, only: is_velocity_dependent - integer, intent(inout) :: nerror + use ptmass, only : use_fourthorder + integer, intent(inout) :: nwarn integer, intent(in) :: iexternalforce if (is_velocity_dependent(iexternalforce)) then - print "(/,a,/)","ERROR in setup: velocity dependant external forces..." - nerror = nerror + 1 + print "(/,a,/)","Warning: velocity dependant external forces are not compatible with FSI switch back to Leapfrog..." + nwarn = nwarn + 1 + use_fourthorder = .false. endif -end subroutine check_setup_FSI +end subroutine check_vdep_extf end module checksetup diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 00bff775c..5c0f64511 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -242,7 +242,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, if (tofrom) f2 = pmassi*dr3 ! additional accelerations due to oblateness - if (abs(J2) > 0.) then + if (abs(J2) > 0. .and. .not. extrap) then shat = unitvec(xyzmh_ptmass(ispinx:ispinz,j)) Rsink = xyzmh_ptmass(iReff,j) call get_geopot_force(dx,dy,dz,ddr,f1,Rsink,J2,shat,ftmpxi,ftmpyi,ftmpzi,phi,dsx,dsy,dsz,fxj,fyj,fzj) @@ -321,8 +321,6 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin logical :: extrap dtsinksink = huge(dtsinksink) - fxyz_ptmass(:,:) = 0. - dsdt_ptmass(:,:) = 0. phitot = 0. merge_n = 0 merge_ij = 0 @@ -436,12 +434,12 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin phii = phii + pmassj*pterm ! potential (GM/r) ! additional acceleration due to oblateness of sink particles j and i - if (abs(J2j) > 0.) then + if (abs(J2j) > 0. .and. .not. extrap) then shatj = unitvec(xyzmh_ptmass(ispinx:ispinz,j)) rsinkj = xyzmh_ptmass(iReff,j) call get_geopot_force(dx,dy,dz,ddr,f1,rsinkj,J2j,shatj,fxi,fyi,fzi,phii) endif - if (abs(J2i) > 0.) then + if (abs(J2i) > 0. .and. .not. extrap) then shati = unitvec(xyzmh_ptmass(ispinx:ispinz,i)) rsinki = xyzmh_ptmass(iReff,i) call get_geopot_force(dx,dy,dz,ddr,f1,rsinki,J2i,shati,fxi,fyi,fzi,phii,dsx,dsy,dsz) @@ -487,13 +485,13 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin ! !--store sink-sink forces (only) ! - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + fxi - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + fyi - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + fzi - fxyz_ptmass(4,i) = fxyz_ptmass(4,i) + phii - dsdt_ptmass(1,i) = dsdt_ptmass(1,i) + pmassi*dsx - dsdt_ptmass(2,i) = dsdt_ptmass(2,i) + pmassi*dsy - dsdt_ptmass(3,i) = dsdt_ptmass(3,i) + pmassi*dsz + fxyz_ptmass(1,i) = fxi + fxyz_ptmass(2,i) = fyi + fxyz_ptmass(3,i) = fzi + fxyz_ptmass(4,i) = phii + dsdt_ptmass(1,i) = pmassi*dsx + dsdt_ptmass(2,i) = pmassi*dsy + dsdt_ptmass(3,i) = pmassi*dsz enddo !$omp end parallel do @@ -1881,7 +1879,6 @@ subroutine write_options_ptmass(iunit) call write_inopt(f_acc,'f_acc','particles < f_acc*h_acc accreted without checks',iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) - call write_inopt(use_fourthorder, 'use_fourthorder', 'FSI integration method (4th order)', iunit) end subroutine write_options_ptmass @@ -1956,8 +1953,6 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) r_merge_cond if (r_merge_cond > 0. .and. r_merge_cond < r_merge_uncond) call fatal(label,'0 < r_merge_cond < r_merge_uncond') ngot = ngot + 1 - case('use_fourthorder') - read(valstring,*,iostat=ierr) use_fourthorder case default imatch = .false. end select diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 95670505c..f70e19de1 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -459,7 +459,7 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v if(use_fourthorder) then n_force_order = 3 ck = ck4 - dk = dk2 + dk = dk4 else n_force_order = 1 ck = ck2 @@ -494,12 +494,8 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) - if (.not.use_fourthorder) then !! standard leapfrog scheme -! the last kick phase of the scheme will perform the accretion loop after velocity update - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) - else !! FSI 4th order scheme -! FSFI extrapolation method (Omelyan 2006) + if (use_fourthorder) then !! FSI 4th order scheme + ! FSFI extrapolation method (Omelyan 2006) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,fsink_old) @@ -508,10 +504,14 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v 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,ck(1),dk(2),force_count,extf_vdep_flag) -! the last kick phase of the scheme will perform the accretion loop after velocity update + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(2),dk(3),force_count,extf_vdep_flag) + ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + else !! standard leapfrog scheme + ! the last kick phase of the scheme will perform the accretion loop after velocity update + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) endif @@ -547,7 +547,7 @@ end subroutine step_extern_pattern !---------------------------------------------------------------- subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) - use part, only:isdead_or_accreted,ispinx,ispiny,ispinz + use part, only:isdead_or_accreted use ptmass, only:ptmass_drift use io , only:id,master use mpiutils, only:bcast_mpi @@ -839,7 +839,6 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (nptmass>0) then if (id==master) then if (extrap) then - if (iexternalforce==14) call update_externalforce(iexternalforce,timei,dmdt) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n, & dsdt_ptmass,extrapfac,fsink_old) @@ -850,7 +849,6 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dsdt_ptmass,extrapfac,fsink_old) endif else - if (iexternalforce==14) call update_externalforce(iexternalforce,timei,dmdt) 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 diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 3e5752d9a..1171a7c05 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -101,7 +101,7 @@ subroutine test_binary(ntests,npass) use io, only:id,master,iverbose use physcon, only:pi,deg_to_rad use ptmass, only:get_accel_sink_sink,h_soft_sinksink, & - get_accel_sink_gas,f_acc + get_accel_sink_gas,f_acc,use_fourthorder use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fext,& npart,npartoftype,massoftype,xyzh,vxyzu,fxyzu,& hfact,igas,epot_sinksink,init_part,iJ2,ispinx,ispiny,ispinz,iReff,istar @@ -145,11 +145,19 @@ subroutine test_binary(ntests,npass) binary_tests: do itest = 1,nbinary_tests select case(itest) case(4) - if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit with oblateness' + if (use_fourthorder) then + if (id==master) write(*,"(/,a)") '--> skipping integration of binary orbit with oblateness with FSI' + cycle binary_tests + else + if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit with oblateness' + endif case(2,3,5) if (periodic) then if (id==master) write(*,"(/,a)") '--> skipping circumbinary disc test (-DPERIODIC is set)' cycle binary_tests + elseif(use_fourthorder .and. itest==5) then + if (id==master) write(*,"(/,a)") '--> skipping circumbinary disc around oblate star test with FSI' + cycle binary_tests else if (itest==5) then if (id==master) write(*,"(/,a)") '--> testing integration of disc around oblate star' From b3d1de10a31b26d2c9bebc007c08924b4889f404 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 16 Apr 2024 15:07:29 +1000 Subject: [PATCH 429/814] add precision switching sub --- src/main/evolve.F90 | 8 +++++++- src/main/ptmass.F90 | 31 +++++++++++++++++++++++++++---- src/main/step_extern.F90 | 12 +----------- src/tests/test_ptmass.f90 | 6 +++++- 4 files changed, 40 insertions(+), 17 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 5aadfdeee..53b9d7928 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -91,7 +91,8 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,gravity,iboundary, & fxyz_ptmass_sinksink,ntot,poten,ndustsmall,accrete_particles_outside_sphere use quitdump, only:quit - use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot + use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & + set_integration_precision use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries @@ -162,6 +163,11 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) dtmax_log_dratio = 0.0 endif + ! + ! Set substepping integration precision depending on the system (default is FSI) + ! + call set_integration_precision + #ifdef IND_TIMESTEPS use_global_dt = .false. istepfrac = 0 diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 5c0f64511..5af5e48a3 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -55,6 +55,7 @@ module ptmass public :: calculate_mdot public :: ptmass_calc_enclosed_mass public :: ptmass_boundary_crossing + public :: set_integration_precision ! settings affecting routines in module (read from/written to input file) integer, public :: icreate_sinks = 0 @@ -69,8 +70,8 @@ module ptmass real, public :: f_crit_override = 0.0 ! 1000. - logical, public :: use_fourthorder = .false. - integer, public :: n_force_order = 1 + logical, public :: use_fourthorder = .true. + integer, public :: n_force_order = 3 real, public, parameter :: dk2(3) = (/0.5,0.5,0.0/) real, public, parameter :: ck2(2) = (/1.,0.0/) real, public, parameter :: dk4(3) = (/1./6.,2./3.,1./6./) @@ -94,8 +95,14 @@ module ptmass ! calibration of timestep control on sink-sink and sink-gas orbital integration ! this is hardwired because can be adjusted by changing C_force ! just means that with the default setting of C_force the orbits are accurate - real, parameter :: dtfacphi = 0.05 - real, parameter :: dtfacphi2 = dtfacphi*dtfacphi + real, parameter :: dtfacphilf = 0.05 + real, parameter :: dtfacphi2lf = dtfacphilf**2 + real, parameter :: dtfacphifsi = 0.2 + real, parameter :: dtfacphi2fsi = dtfacphifsi**2 + + real :: dtfacphi = dtfacphifsi + real :: dtfacphi2 = dtfacphifsi + ! parameters to control output regarding sink particles logical, private, parameter :: record_created = .false. ! verbose tracking of why sinks are not created @@ -1622,6 +1629,22 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_i end subroutine merge_sinks +subroutine set_integration_precision + if(use_fourthorder) then + n_force_order = 3 + ck = ck4 + dk = dk4 + dtfacphi = dtfacphifsi + dtfacphi2 = dtfacphi2fsi + else + n_force_order = 1 + ck = ck2 + dk = dk2 + dtfacphi = dtfacphilf + dtfacphi2 = dtfacphi2lf + endif +end subroutine set_integration_precision + !----------------------------------------------------------------------- !+ ! Open files to track sink particle data diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index f70e19de1..68277bf26 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -432,7 +432,7 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v use part, only:fxyz_ptmass_sinksink use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent - use ptmass, only:use_fourthorder,ck,dk,ck2,ck4,dk2,dk4,n_force_order + use ptmass, only:use_fourthorder,ck,dk integer, intent(in) :: npart,ntypes,nptmass real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce @@ -456,16 +456,6 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v last_step = .true. endif - if(use_fourthorder) then - n_force_order = 3 - ck = ck4 - dk = dk4 - else - n_force_order = 1 - ck = ck2 - dk = dk2 - endif - timei = time time_par = time diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 1171a7c05..6a2798f98 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -32,7 +32,7 @@ subroutine test_ptmass(ntests,npass) use eos, only:polyk,gamma use part, only:nptmass use options, only:iexternalforce,alpha - use ptmass, only:use_fourthorder + use ptmass, only:use_fourthorder,set_integration_precision character(len=20) :: filename integer, intent(inout) :: ntests,npass integer :: itmp,ierr,itest @@ -53,7 +53,11 @@ subroutine test_ptmass(ntests,npass) iexternalforce = 0 alpha = 0.01 do itest=1,2 + ! + ! select order of integration + ! if (itest == 2) use_fourthorder = .true. + call set_integration_precision ! ! Tests of a sink particle binary ! From a9a80d6618e736fcd9bb95cc146924a5a76b8c87 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 16 Apr 2024 15:38:11 +1000 Subject: [PATCH 430/814] update main integration sub for subsys with the new design --- src/main/initial.F90 | 16 ++++++++++++---- src/main/ptmass.F90 | 3 ++- src/main/sdar_group.f90 | 2 +- src/main/step_extern.F90 | 30 ++++++++++++++++-------------- src/main/step_leapfrog.F90 | 11 +++++++++-- 5 files changed, 40 insertions(+), 22 deletions(-) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 314b72644..126010b75 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -130,7 +130,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& nden_nimhd,dustevol,rhoh,gradh, & - Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx + Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx, & + n_group,n_ingroup,n_sing,nmatrix,group_info use part, only:pxyzu,dens,metrics,rad,radprop,drad,ithick use densityforce, only:densityiterate use linklist, only:set_linklist @@ -150,7 +151,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use nicil_sup, only:use_consistent_gmw use ptmass, only:init_ptmass,get_accel_sink_gas,get_accel_sink_sink, & h_acc,r_crit,r_crit2,rho_crit,rho_crit_cgs,icreate_sinks, & - r_merge_uncond,r_merge_cond,r_merge_uncond2,r_merge_cond2,r_merge2 + r_merge_uncond,r_merge_cond,r_merge_uncond2,r_merge_cond2,r_merge2, & + use_regnbody use timestep, only:time,dt,dtextforce,C_force,dtmax,dtmax_user,idtmax_n use timing, only:get_timings use timestep_ind, only:ibinnow,maxbins,init_ibin,istepfrac @@ -210,6 +212,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use fileutils, only:make_tags_unique use damping, only:idamp + use sdar_group, only:group_identify character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile logical, intent(in), optional :: noread @@ -495,10 +498,15 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass - ! compute initial sink-sink forces and get timestep - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& + iexternalforce,time,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) + else + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& iexternalforce,time,merge_ij,merge_n,dsdt_ptmass) + endif dtsinksink = C_force*dtsinksink if (id==master) write(iprint,*) 'dt(sink-sink) = ',dtsinksink dtextforce = min(dtextforce,dtsinksink) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 483113cd1..e2f276165 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -46,6 +46,7 @@ module ptmass public :: init_ptmass, finish_ptmass public :: pt_write_sinkev, pt_close_sinkev public :: get_accel_sink_gas, get_accel_sink_sink + public :: get_gradf_sink_gas, get_gradf_sink_sink public :: merge_sinks public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured @@ -835,7 +836,7 @@ subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,group_ !$omp parallel do schedule(static) default(none) & !$omp shared(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass) & - !$omp shared(n_ingroup,group_info,woutsub) & + !$omp shared(n_ingroup,group_info,woutsub,istart_ptmass) & !$omp private(i,k) do k=istart_ptmass,nptmass if (woutsub) then diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index beba710bd..f84347b54 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -188,9 +188,9 @@ subroutine evolve_groups(n_group,nptmass,tnext,group_info,xyzmh_ptmass,vxyz_ptma use part, only: igarg,igcum use io, only: id,master use mpiutils,only:bcast_mpi + integer, intent(in) :: n_group,nptmass real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) - integer, intent(in) :: n_group,nptmass real, intent(in) :: tnext integer :: i,start_id,end_id,gsize if (n_group>0) then diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index b7634a832..78977c559 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -535,7 +535,7 @@ end subroutine step_extern_pattern ! and external forces except ptmass with subsystems algorithms.. !+ !---------------------------------------------------------------- -subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & +subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & dsdt_ptmass,fsink_old,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) use part, only: isdead_or_accreted,igas,massoftype use io, only:iverbose,id,master,iprint,warning,fatal @@ -543,8 +543,9 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex use sdar_group, only:group_identify,evolve_groups use options, only:iexternalforce use externalforces, only:is_velocity_dependent + use ptmass, only:ck,dk real, intent(in) :: dtsph,time - integer, intent(in) :: npart,nptmass + integer, intent(in) :: npart,nptmass,ntypes real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass) @@ -555,7 +556,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex logical :: extf_vdep_flag,done,last_step integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step - real :: dtextforce_min + real :: dtextforce_min,pmassi ! ! determine whether or not to use substepping @@ -586,21 +587,22 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex ! Group all the ptmass in the system in multiple small group for regularization ! call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - + !call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + ! vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) - call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call evolve_groups(n_group,nptmass,time_par,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) fsink_old = fxyz_ptmass call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) - call kick(dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) + call evolve_groups(n_group,nptmass,time_par,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) - call kick(dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) + call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt dtextforce_min = min(dtextforce_min,dtextforce) @@ -616,7 +618,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex endif enddo substeps - print*,fxyz_ptmass(2,1:nptmass) + !print*,fxyz_ptmass(2,1:nptmass) if (nsubsteps > 1) then if (iverbose>=1 .and. id==master) then @@ -674,7 +676,7 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx if(nptmass>0) then if(id==master) then if(present(n_ingroup)) then - call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) + call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,group_info,n_ingroup) else call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass) endif @@ -969,7 +971,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real :: fextx,fexty,fextz,xi,yi,zi,pmassi,damp_fac real :: fonrmaxi,phii,dtphi2i real :: dkdt,ckdt,extrapfac - logical :: extrap,last + logical :: extrap,last,wsub if(present(fsink_old)) then fsink_old = fxyz_ptmass diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index c733e6283..3561d773f 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -127,7 +127,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate use step_extern, only:step_extern_pattern,step_extern_gr, & - step_extern_sph_gr,step_extern_sph + step_extern_sph_gr,step_extern_sph,step_extern_subsys + use ptmass, only:use_regnbody integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -249,9 +250,15 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif else if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then - call step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& + if (use_regnbody) then + call step_extern_subsys(dtextforce,dtsph,t,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fsink_old,gtgrad,group_info,nmatrix, & + n_group,n_ingroup,n_sing) + else + call step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& dptmass,fsink_old,nbinmax,ibin_wake) + endif else call step_extern_sph(dtsph,npart,xyzh,vxyzu) endif From 65e1b4f5187a4a8b041f87b668a46cee5d6cafe2 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 17 Apr 2024 10:55:07 +1000 Subject: [PATCH 431/814] fptmas and dsdt need to be zeroed if there is only 1 ptmass... dtfacphi still needs to be low if an orbit is really eccentric --- src/main/checksetup.f90 | 4 ++-- src/main/ptmass.F90 | 10 ++++++---- src/tests/test_ptmass.f90 | 1 + 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 336a503a4..eec4f19f0 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -635,7 +635,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) endif enddo - if (isoblate) then + if (isoblate .and. use_fourthorder) then nwarn = nwarn + 1 print*, 'WARNING: Substepping integration switched back to leapfrog due to oblateness' use_fourthorder = .false. @@ -1020,7 +1020,7 @@ subroutine check_vdep_extf(nwarn,iexternalforce) use ptmass, only : use_fourthorder integer, intent(inout) :: nwarn integer, intent(in) :: iexternalforce - if (is_velocity_dependent(iexternalforce)) then + if (is_velocity_dependent(iexternalforce) .and. use_fourthorder) then print "(/,a,/)","Warning: velocity dependant external forces are not compatible with FSI switch back to Leapfrog..." nwarn = nwarn + 1 use_fourthorder = .false. diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 5af5e48a3..e6c179def 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -97,7 +97,7 @@ module ptmass ! just means that with the default setting of C_force the orbits are accurate real, parameter :: dtfacphilf = 0.05 real, parameter :: dtfacphi2lf = dtfacphilf**2 - real, parameter :: dtfacphifsi = 0.2 + real, parameter :: dtfacphifsi = 0.05 real, parameter :: dtfacphi2fsi = dtfacphifsi**2 real :: dtfacphi = dtfacphifsi @@ -249,7 +249,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, if (tofrom) f2 = pmassi*dr3 ! additional accelerations due to oblateness - if (abs(J2) > 0. .and. .not. extrap) then + if (abs(J2) > 0.) then shat = unitvec(xyzmh_ptmass(ispinx:ispinz,j)) Rsink = xyzmh_ptmass(iReff,j) call get_geopot_force(dx,dy,dz,ddr,f1,Rsink,J2,shat,ftmpxi,ftmpyi,ftmpzi,phi,dsx,dsy,dsz,fxj,fyj,fzj) @@ -328,6 +328,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin logical :: extrap dtsinksink = huge(dtsinksink) + fxyz_ptmass(:,:) = 0. + dsdt_ptmass(:,:) = 0. phitot = 0. merge_n = 0 merge_ij = 0 @@ -441,12 +443,12 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin phii = phii + pmassj*pterm ! potential (GM/r) ! additional acceleration due to oblateness of sink particles j and i - if (abs(J2j) > 0. .and. .not. extrap) then + if (abs(J2j) > 0.) then shatj = unitvec(xyzmh_ptmass(ispinx:ispinz,j)) rsinkj = xyzmh_ptmass(iReff,j) call get_geopot_force(dx,dy,dz,ddr,f1,rsinkj,J2j,shatj,fxi,fyi,fzi,phii) endif - if (abs(J2i) > 0. .and. .not. extrap) then + if (abs(J2i) > 0.) then shati = unitvec(xyzmh_ptmass(ispinx:ispinz,i)) rsinki = xyzmh_ptmass(iReff,i) call get_geopot_force(dx,dy,dz,ddr,f1,rsinki,J2i,shati,fxi,fyi,fzi,phii,dsx,dsy,dsz) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 6a2798f98..c98a9a4a3 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -52,6 +52,7 @@ subroutine test_ptmass(ntests,npass) gamma = 1. iexternalforce = 0 alpha = 0.01 + use_fourthorder = .false. do itest=1,2 ! ! select order of integration From a901f80d4ebd55f7424b13986c8844903ee41a64 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 17 Apr 2024 17:05:06 +1000 Subject: [PATCH 432/814] rename and fix star cluster setup + fix cooling function for blob setup --- build/Makefile_setups | 4 ++-- data/starcluster/README | 1 + src/main/cooling_ism.f90 | 6 +++--- src/main/h2chem.f90 | 2 +- src/main/step_extern.F90 | 3 ++- src/setup/{setup_nbody_test.f90 => setup_starcluster.f90} | 6 +++--- 6 files changed, 12 insertions(+), 10 deletions(-) create mode 100644 data/starcluster/README rename src/setup/{setup_nbody_test.f90 => setup_starcluster.f90} (97%) diff --git a/build/Makefile_setups b/build/Makefile_setups index 23dc79fdb..55347ffb0 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -342,9 +342,9 @@ ifeq ($(SETUP), galcen) KNOWN_SETUP=yes endif -ifeq ($(SETUP), nbody) +ifeq ($(SETUP), starcluster) # Cluster of stars (ptmass) - SETUPFILE= setup_nbody_test.f90 + SETUPFILE= setup_starcluster.f90 KNOWN_SETUP=yes endif diff --git a/data/starcluster/README b/data/starcluster/README new file mode 100644 index 000000000..fd80156c9 --- /dev/null +++ b/data/starcluster/README @@ -0,0 +1 @@ +file with mass position and velocity... (should have 7 column per ptmass) \ No newline at end of file diff --git a/src/main/cooling_ism.f90 b/src/main/cooling_ism.f90 index 13cde246f..60d574c75 100644 --- a/src/main/cooling_ism.f90 +++ b/src/main/cooling_ism.f90 @@ -126,9 +126,9 @@ module cooling_ism ! Distance measurements needed for chemistry - real, public :: dlq = 3.086d19 - real, public :: dphot0 = 1.0801d20 - real, public :: dchem = 3.086d20 + real(kind=8), public :: dlq = 3.086d19 + real(kind=8), public :: dphot0 = 1.0801d20 + real(kind=8), public :: dchem = 3.086d20 integer, public :: dphotflag = 0 private diff --git a/src/main/h2chem.f90 b/src/main/h2chem.f90 index 2281fa78c..a79faa951 100644 --- a/src/main/h2chem.f90 +++ b/src/main/h2chem.f90 @@ -67,7 +67,7 @@ real function get_dphot(dphotflag,dphot0,xi,yi,zi) use units, only:udist,umass use physcon, only:solarm,kpc,pi integer, intent(in) :: dphotflag - real, intent(in) :: dphot0 + real(kind=8), intent(in) :: dphot0 real, intent(in) :: xi,yi,zi real :: MdMo,ad,bd,r2,bit1,rhodisk diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 68277bf26..1497bfa5e 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -989,7 +989,8 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl real, intent(inout) :: nucleation(:,:),dust_temp(:) real(kind=4), intent(in) :: divcurlv(:,:) real, intent(inout) :: abundc,abunde,abundo,abundsi - real, intent(in) :: dt,dphot0,pmassi + real(kind=8), intent(in) :: dphot0 + real, intent(in) :: dt,pmassi integer, intent(in) :: idK2,idmu,idkappa,idgamma,imu,igamma integer, intent(in) :: i,nabn,dphotflag,nabundances diff --git a/src/setup/setup_nbody_test.f90 b/src/setup/setup_starcluster.f90 similarity index 97% rename from src/setup/setup_nbody_test.f90 rename to src/setup/setup_starcluster.f90 index bb0a9142c..09dbec6b9 100644 --- a/src/setup/setup_nbody_test.f90 +++ b/src/setup/setup_starcluster.f90 @@ -27,9 +27,9 @@ module setup ! ! setup options and default values for these ! - character(len=120) :: datafile = 'ic01.txt' + character(len=120) :: datafile = 'clusterbin.txt' real :: m_gas = 1.e-6 ! gas mass resolution in Msun - real :: h_sink = 0.0 ! sink particle radii in arcsec at 8kpc + real :: h_sink = 1.e-14 ! sink particle radii in arcsec at 8kpc private @@ -105,7 +105,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! Read positions, masses and velocities of stars from file ! - filename = datafile + filename = find_phantom_datafile(datafile,"starcluster") call read_ptmass_data(filename,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr) mtot = sum(xyzmh_ptmass(4,:)) From c922e9ac320bb8fa8b2f644bbbb730b2c110c4ce Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 18 Apr 2024 08:59:25 +1000 Subject: [PATCH 433/814] continue implementation of subgroups --- src/main/ptmass.F90 | 2 +- src/main/sdar_group.f90 | 113 ++++++++++++++++++++----------------- src/main/step_extern.F90 | 30 ++++++---- src/main/step_leapfrog.F90 | 4 +- src/main/utils_sdar.f90 | 4 +- 5 files changed, 86 insertions(+), 67 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index af356533b..777e1bd98 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -317,10 +317,10 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin integer, intent(in) :: iexternalforce real, intent(in) :: ti integer, intent(out) :: merge_ij(:),merge_n - integer, optional, intent(in) :: group_info(3,nptmass) real, intent(out) :: dsdt_ptmass(3,nptmass) real, optional, intent(in) :: extrapfac real, optional, intent(in) :: fsink_old(4,nptmass) + integer, optional, intent(in) :: group_info(3,nptmass) real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii real :: ddr,dx,dy,dz,rr2,rr2j,dr3,f1,f2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index f84347b54..8f7261af8 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -3,7 +3,7 @@ module sdar_group ! this module contains everything to identify ! and integrate regularized groups... ! -! :References: Makino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 +! :References: Makkino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 ! ! :Owner: Yann BERNARD ! @@ -12,11 +12,11 @@ module sdar_group public :: group_identify public :: evolve_groups ! parameters for group identification - real, parameter :: eta_pert = 0.0002 - real, parameter :: time_error = 1e-10 - real, parameter :: max_step = 100000 - real, parameter, public :: r_neigh = 0.001 - real, public :: t_crit = 0.0 + real, parameter :: eta_pert = 20 + real, parameter :: time_error = 2.5e-14 + real, parameter :: max_step = 100000000 + real, parameter, public :: r_neigh = 0.0001 + real, public :: t_crit = 1.e-9 real, public :: C_bin = 0.02 real, public :: r_search = 100.*r_neigh private @@ -29,11 +29,11 @@ module sdar_group !----------------------------------------------- subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) use io ,only:id,master,iverbose,iprint + integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, intent(inout) :: group_info(:,:) - integer(kind=1), intent(inout) :: nmatrix(:,:) + integer, intent(inout) :: group_info(3,nptmass) + integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) integer, intent(inout) :: n_group,n_ingroup,n_sing - integer, intent(in) :: nptmass n_group = 0 n_ingroup = 0 @@ -87,6 +87,7 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) integer :: stack(nptmass) integer :: j,stack_top,inode + stack_top = 0 ncg = 1 inode = iroot group_info(igarg,n_ingroup) = inode @@ -114,10 +115,10 @@ end subroutine dfs subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) use utils_kepler, only: Espec,extract_a,extract_e,extract_ea - integer(kind=1), intent(out):: nmatrix(:,:) + integer, intent(in) :: nptmass + integer(kind=1), intent(out):: nmatrix(nptmass,nptmass) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(in) :: vxyz_ptmass(:,:) - integer, intent(in) :: nptmass real :: xi,yi,zi,vxi,vyi,vzi,mi real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu real :: aij,eij,B,rperi @@ -169,7 +170,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) else call extract_e(dx,dy,dz,dvx,dvy,dvz,mu,r,eij) rperi = aij*(1-eij) - if (rperi0) then if(id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& - !$omp shared(tnext,group_info,gtgrad)& + !$omp shared(tnext,time,group_info,gtgrad)& !$omp private(i,start_id,end_id,gsize) do i=1,n_group start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) - gsize = end_id - start_id - call integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) + gsize = (end_id - start_id) + 1 + call integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) enddo !$omp end parallel do endif @@ -215,14 +216,14 @@ subroutine evolve_groups(n_group,nptmass,tnext,group_info,xyzmh_ptmass,vxyz_ptma end subroutine evolve_groups -subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) +subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) use part, only: igarg real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) integer, intent(in) :: start_id,end_id,gsize - real, intent(in) :: tnext - real, allocatable :: bdata(:) + real, intent(in) :: tnext,time + real, allocatable :: bdata(:) real :: ds(2) real :: time_table(ck_size) integer :: switch @@ -233,7 +234,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas integer :: i,prim,sec - tcoord = tnext + tcoord = time ismultiple = gsize > 2 @@ -246,9 +247,11 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas n_step_end = 0 t_end_flag = .false. backup_flag = .true. - ds = ds_init + ds(:) = ds_init switch = 1 + !print*,ds_init, tcoord,tnext,W + do while (.true.) if (backup_flag) then @@ -258,11 +261,11 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas endif t_old = tcoord W_old = W - if (gsize>1) then + if (gsize>2) then do i=1,ck_size - call drift_TTL (tcoord,W,ds(switch)*ck(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) + call drift_TTL (tcoord,W,ds(switch)*cks(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) time_table(i) = tcoord - call kick_TTL (ds(switch)*dk(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,start_id,end_id) + call kick_TTL (ds(switch)*dks(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,start_id,end_id) enddo else prim = group_info(igarg,start_id) @@ -324,6 +327,8 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas endif enddo + print*,step_count_int,tcoord,tnext,ds_init + deallocate(bdata) end subroutine integrate_to_time @@ -494,8 +499,9 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t real :: dtd,dtk,dvel1(3),dvel2(3),dw,om do k = 1,ck_size - dtd = ds*ck(k)/W + dtd = ds*cks(k)/W tcoord = tcoord + dtd + !if (i == 1) print*, fxyz_ptmass(1,i),i,j time_table(k) = tcoord xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) @@ -507,7 +513,7 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) - dtk = ds*dk(k)/om + dtk = ds*dks(k)/om dvel1(1) = 0.5*dtk*fxyz_ptmass(1,i) dvel1(2) = 0.5*dtk*fxyz_ptmass(2,i) @@ -600,34 +606,37 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: i,j real, intent(out) :: om - real :: dx,dy,dz,r2,r,mi,mj - real :: gravf,gtk + real :: dx,dy,dz,r2,r,ddr3,mi,mj + real :: gravfi,gtki,gravfj,gtkj mi = xyzmh_ptmass(4,i) mj = xyzmh_ptmass(4,j) - dx = xyzmh_ptmass(1,i)-xyzmh_ptmass(1,j) - dy = xyzmh_ptmass(2,i)-xyzmh_ptmass(2,j) - dz = xyzmh_ptmass(3,i)-xyzmh_ptmass(3,j) + dx = xyzmh_ptmass(1,i) - xyzmh_ptmass(1,j) + dy = xyzmh_ptmass(2,i) - xyzmh_ptmass(2,j) + dz = xyzmh_ptmass(3,i) - xyzmh_ptmass(3,j) r2 = dx**2+dy**2+dz**2 r = sqrt(r2) - gravf = mj*(1./r2*r) - gtk = mj*(1./r) - - fxyz_ptmass(1,i) = dx*gravf - fxyz_ptmass(2,i) = dy*gravf - fxyz_ptmass(3,i) = dz*gravf - fxyz_ptmass(1,j) = -dx*gravf - fxyz_ptmass(2,j) = -dy*gravf - fxyz_ptmass(3,j) = -dz*gravf - - gtgrad(1,i) = dx*gravf*mi - gtgrad(2,i) = dy*gravf*mi - gtgrad(3,i) = dz*gravf*mi - gtgrad(1,j) = -dx*gravf*mi - gtgrad(2,j) = -dy*gravf*mi - gtgrad(3,j) = -dz*gravf*mi - - om = gtk*mi + ddr3 = (1./(r2*r)) + gravfi = mj*ddr3 + gravfj = mi*ddr3 + gtki = mj*(1./r) + gtkj = mi*(1./r) + + fxyz_ptmass(1,i) = -dx*gravfi + fxyz_ptmass(2,i) = -dy*gravfi + fxyz_ptmass(3,i) = -dz*gravfi + fxyz_ptmass(1,j) = dx*gravfj + fxyz_ptmass(2,j) = dy*gravfj + fxyz_ptmass(3,j) = dz*gravfj + + gtgrad(1,i) = -dx*gravfi*mi + gtgrad(2,i) = -dy*gravfi*mi + gtgrad(3,i) = -dz*gravfi*mi + gtgrad(1,j) = dx*gravfj*mj + gtgrad(2,j) = dy*gravfj*mj + gtgrad(3,j) = dz*gravfj*mj + + om = gtki*mi end subroutine get_force_TTL_bin @@ -709,9 +718,9 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e om = om*0.5 if (ismultiple) then - ds_init = eta_pert * (E/Edot) + ds_init = eta_pert * abs(E/Edot) else - ds_init = eta_pert * (semi/semidot) + ds_init = eta_pert * abs(semi/semidot) endif end subroutine initial_int diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 91ba089ca..670085d80 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -538,8 +538,8 @@ end subroutine step_extern_pattern !+ !---------------------------------------------------------------- subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & - dsdt_ptmass,fsink_old,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) - use part, only: isdead_or_accreted,igas,massoftype + dsdt_ptmass,dptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) + use part, only:isdead_or_accreted,igas,massoftype,fxyz_ptmass_sinksink use io, only:iverbose,id,master,iprint,warning,fatal use io_summary, only:summary_variable,iosumextr,iosumextt use sdar_group, only:group_identify,evolve_groups @@ -551,9 +551,12 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass) + real, intent(inout) :: dptmass(:,:) real, intent(inout) :: fsink_old(4,nptmass),dsdt_ptmass(3,nptmass),gtgrad(3,nptmass) integer, intent(inout) :: group_info(3,nptmass) integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) + integer(kind=1), intent(in) :: nbinmax + integer(kind=1), intent(inout) :: ibin_wake(:) integer, intent(inout) :: n_ingroup,n_group,n_sing logical :: extf_vdep_flag,done,last_step integer :: force_count,nsubsteps @@ -593,18 +596,24 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx ! vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) - call evolve_groups(n_group,nptmass,time_par,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) fsink_old = fxyz_ptmass call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) - call evolve_groups(n_group,nptmass,time_par,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + + call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) - call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass, & + dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt dtextforce_min = min(dtextforce_min,dtextforce) @@ -620,7 +629,6 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx endif enddo substeps - !print*,fxyz_ptmass(2,1:nptmass) if (nsubsteps > 1) then if (iverbose>=1 .and. id==master) then @@ -655,7 +663,7 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer, optional, intent(in) :: n_ingroup integer, optional, intent(in) :: group_info(:,:) - integer :: i,k + integer :: i real :: ckdt ckdt = cki*dt @@ -862,7 +870,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, call summary_accrete_fail(nfail) call summary_accrete(nptmass) ! only write to .ev during substeps if no gas particles present - if (npart==0) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & + if (npart==-1) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & fxyz_ptmass,fxyz_ptmass_sinksink) endif endif @@ -1027,6 +1035,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass endif else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 3561d773f..478c46ec6 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -252,8 +252,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then if (use_regnbody) then call step_extern_subsys(dtextforce,dtsph,t,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fsink_old,gtgrad,group_info,nmatrix, & - n_group,n_ingroup,n_sing) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass,fsink_old,nbinmax,ibin_wake, & + gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) else call step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& diff --git a/src/main/utils_sdar.f90 b/src/main/utils_sdar.f90 index 8ca52f85f..7b0ce4401 100644 --- a/src/main/utils_sdar.f90 +++ b/src/main/utils_sdar.f90 @@ -1,13 +1,13 @@ module utils_sdar implicit none integer, parameter :: ck_size = 8 - real,dimension(8),parameter :: ck=(/0.3922568052387800,0.5100434119184585,-0.4710533854097566,& + real,dimension(8),parameter :: cks=(/0.3922568052387800,0.5100434119184585,-0.4710533854097566,& 0.0687531682525181,0.0687531682525181,-0.4710533854097566,& 0.5100434119184585,0.3922568052387800/) real,dimension(8),parameter :: cck_sorted=(/0.0976997828427615,0.3922568052387800,0.4312468317474820,& 0.5000000000000000,0.5687531682525181,0.6077431947612200,& 0.9023002171572385,1.0000000000000000/) - real,dimension(8),parameter :: dk=(/0.7845136104775600,0.2355732133593570,-1.1776799841788701,& + real,dimension(8),parameter :: dks=(/0.7845136104775600,0.2355732133593570,-1.1776799841788701,& 1.3151863206839063,-1.1776799841788701,0.2355732133593570,& 0.7845136104775600,0.0000000000000000/) integer,dimension(8),parameter :: cck_sorted_id=(/6,1,3,4,5,7,2,8/) From 3d79a1ce7303565e4e4ab6e468ed74425691542f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 18 Apr 2024 09:40:19 +1000 Subject: [PATCH 434/814] step_extern to substepping and move precision switcher in substepping --- build/Makefile | 2 +- src/main/checksetup.f90 | 4 +- src/main/evolve.F90 | 4 +- src/main/ptmass.F90 | 38 ++----- src/main/step_leapfrog.F90 | 12 +-- src/main/{step_extern.F90 => substepping.F90} | 99 ++++++++++++------- src/setup/setup_starcluster.f90 | 20 ++-- src/tests/test_gr.f90 | 10 +- src/tests/test_ptmass.f90 | 13 +-- 9 files changed, 103 insertions(+), 99 deletions(-) rename src/main/{step_extern.F90 => substepping.F90} (93%) diff --git a/build/Makefile b/build/Makefile index 4ebb89354..86b4fa780 100644 --- a/build/Makefile +++ b/build/Makefile @@ -537,7 +537,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} \ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ - utils_shuffleparticles.F90 evwrite.f90 step_extern.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ + 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 diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index eec4f19f0..8f296fb40 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -526,7 +526,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) use part, only:nptmass,xyzmh_ptmass,ihacc,ihsoft,gr,iTeff,sinks_have_luminosity,& ilum,iJ2,ispinx,ispinz,iReff use ptmass_radiation, only:isink_radiation - use ptmass, only:use_fourthorder + use substepping, only:use_fourthorder integer, intent(inout) :: nerror,nwarn real, intent(in) :: hmin integer :: i,j,n @@ -1017,7 +1017,7 @@ end subroutine check_setup_radiation subroutine check_vdep_extf(nwarn,iexternalforce) use externalforces, only: is_velocity_dependent - use ptmass, only : use_fourthorder + use substepping, only : use_fourthorder integer, intent(inout) :: nwarn integer, intent(in) :: iexternalforce if (is_velocity_dependent(iexternalforce) .and. use_fourthorder) then diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 53b9d7928..b003934fc 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -91,8 +91,8 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,gravity,iboundary, & fxyz_ptmass_sinksink,ntot,poten,ndustsmall,accrete_particles_outside_sphere use quitdump, only:quit - use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & - set_integration_precision + use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot + use substepping, only:set_integration_precision use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e6c179def..971e13a62 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -55,7 +55,7 @@ module ptmass public :: calculate_mdot public :: ptmass_calc_enclosed_mass public :: ptmass_boundary_crossing - public :: set_integration_precision + ! settings affecting routines in module (read from/written to input file) integer, public :: icreate_sinks = 0 @@ -70,15 +70,7 @@ module ptmass real, public :: f_crit_override = 0.0 ! 1000. - logical, public :: use_fourthorder = .true. - integer, public :: n_force_order = 3 - real, public, parameter :: dk2(3) = (/0.5,0.5,0.0/) - real, public, parameter :: ck2(2) = (/1.,0.0/) - real, public, parameter :: dk4(3) = (/1./6.,2./3.,1./6./) - real, public, parameter :: ck4(2) = (/0.5,0.5/) - real, public :: dk(3) - real, public :: ck(2) ! Note for above: if f_crit_override > 0, then will unconditionally make a sink when rho > f_crit_override*rho_crit_cgs @@ -95,13 +87,13 @@ module ptmass ! calibration of timestep control on sink-sink and sink-gas orbital integration ! this is hardwired because can be adjusted by changing C_force ! just means that with the default setting of C_force the orbits are accurate - real, parameter :: dtfacphilf = 0.05 - real, parameter :: dtfacphi2lf = dtfacphilf**2 - real, parameter :: dtfacphifsi = 0.05 - real, parameter :: dtfacphi2fsi = dtfacphifsi**2 + real, public, parameter :: dtfacphilf = 0.05 + real, public, parameter :: dtfacphi2lf = dtfacphilf**2 + real, public, parameter :: dtfacphifsi = 0.05 + real, public, parameter :: dtfacphi2fsi = dtfacphifsi**2 - real :: dtfacphi = dtfacphifsi - real :: dtfacphi2 = dtfacphifsi + real, public :: dtfacphi = dtfacphifsi + real, public :: dtfacphi2 = dtfacphifsi ! parameters to control output regarding sink particles @@ -1631,22 +1623,6 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_i end subroutine merge_sinks -subroutine set_integration_precision - if(use_fourthorder) then - n_force_order = 3 - ck = ck4 - dk = dk4 - dtfacphi = dtfacphifsi - dtfacphi2 = dtfacphi2fsi - else - n_force_order = 1 - ck = ck2 - dk = dk2 - dtfacphi = dtfacphilf - dtfacphi2 = dtfacphi2lf - endif -end subroutine set_integration_precision - !----------------------------------------------------------------------- !+ ! Open files to track sink particle data diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index a03680e54..724315733 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -125,8 +125,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate - use step_extern, only:step_extern_pattern,step_extern_gr, & - step_extern_sph_gr,step_extern_sph + use substepping, only:substep,substep_gr, & + substep_sph_gr,substep_sph integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -242,17 +242,17 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if ((iexternalforce > 0 .and. imetric /= imet_minkowski) .or. idamp > 0) then call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) call get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtextforce) - call step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,t) + call substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,t) else - call step_extern_sph_gr(dtsph,npart,xyzh,vxyzu,dens,pxyzu,metrics) + call substep_sph_gr(dtsph,npart,xyzh,vxyzu,dens,pxyzu,metrics) endif else if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then - call step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& + call substep(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& dptmass,fsink_old,nbinmax,ibin_wake) else - call step_extern_sph(dtsph,npart,xyzh,vxyzu) + call substep_sph(dtsph,npart,xyzh,vxyzu) endif endif call get_timings(t2,tcpu2) diff --git a/src/main/step_extern.F90 b/src/main/substepping.F90 similarity index 93% rename from src/main/step_extern.F90 rename to src/main/substepping.F90 index 1497bfa5e..7f43bf2f9 100644 --- a/src/main/step_extern.F90 +++ b/src/main/substepping.F90 @@ -4,18 +4,17 @@ ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! -module step_extern +module substepping ! ! Computes sub-steps in the RESPA algorithm ! ! Multiple option of sub stepping can be choosed depending on ! the physics and the precision needed ! -! Only Hydro : step_extern_sph -! Hydro + GR : step_extern_sph_gr step_extern_gr -! 2nd order with all fast physics implemented : step extern -! 4th order (Work in progress, only gravitionnal interaction -! sink-sink and sink-gas) : step_extern_FSI step_extern_PEFRL +! Only Hydro : substep_sph +! Hydro + GR : substep_sph_gr substep_gr +! 2nd order with all fast physics implemented : substep (use_fourthorder = false) +! 4th order without vdep forces and oblateness : substep (not yet implemented) ! ! :References: ! Verlet (1967), Phys. Rev. 159, 98-103 @@ -34,16 +33,27 @@ module step_extern ! implicit none - public :: step_extern_gr - public :: step_extern_sph - public :: step_extern_sph_gr - public :: step_extern_pattern + public :: substep_gr + public :: substep_sph + public :: substep_sph_gr + public :: substep + public :: set_integration_precision + + logical, public :: use_fourthorder = .true. + integer, public :: n_force_order = 3 + real, public, parameter :: dk2(3) = (/0.5,0.5,0.0/) + real, public, parameter :: ck2(2) = (/1.,0.0/) + real, public, parameter :: dk4(3) = (/1./6.,2./3.,1./6./) + real, public, parameter :: ck4(2) = (/0.5,0.5/) + + real, public :: dk(3) + real, public :: ck(2) private contains -subroutine step_extern_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) +subroutine substep_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) use part, only:isdead_or_accreted,igas,massoftype,rhoh,eos_vars,igasP,& ien_type,eos_vars,igamma,itemp use cons2primsolver, only:conservative2primitive @@ -78,7 +88,7 @@ subroutine step_extern_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),& pri,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_sph_gr (a)]','enthalpy did not converge',i=i) + if (ierr > 0) call warning('cons2primsolver [in substep_sph_gr (a)]','enthalpy did not converge',i=i) ! ! main position update ! @@ -90,14 +100,14 @@ subroutine step_extern_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) niter = niter + 1 call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),& pri,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_sph_gr (b)]','enthalpy did not converge',i=i) + if (ierr > 0) call warning('cons2primsolver [in substep_sph_gr (b)]','enthalpy did not converge',i=i) xyzh(1:3,i) = xpred + 0.5*dt*(vxyzu(1:3,i)-vold) diff = maxval(abs(xyzh(1:3,i)-xpred)/xpred) if (diff < xtol) converged = .true. ! UPDATE METRIC HERE call pack_metric(xyzh(1:3,i),metrics(:,:,:,i)) enddo - if (niter > nitermax) call warning('step_extern_sph_gr','Reached max number of x iterations. x_err ',val=diff) + if (niter > nitermax) call warning('substep_sph_gr','Reached max number of x iterations. x_err ',val=diff) ! repack values eos_vars(igasP,i) = pri @@ -107,9 +117,9 @@ subroutine step_extern_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) enddo !$omp end parallel do -end subroutine step_extern_sph_gr +end subroutine substep_sph_gr -subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) +subroutine substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) use dim, only:maxptmass,maxp,maxvxyzu use io, only:iverbose,id,master,iprint,warning,fatal use externalforces, only:externalforce,accrete_particles,update_externalforce @@ -229,21 +239,21 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me pprev = pxyz call conservative2primitive(xyz,metrics(:,:,:,i),vxyz,densi,uui,pri,& tempi,gammai,rhoi,pxyz,eni,ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (a)]','enthalpy did not converge',i=i) + if (ierr > 0) call warning('cons2primsolver [in substep_gr (a)]','enthalpy did not converge',i=i) call get_grforce(xyzh(:,i),metrics(:,:,:,i),metricderivs(:,:,:,i),vxyz,densi,uui,pri,fstar) pxyz = pprev + hdt*(fstar - fexti) pmom_err = maxval(abs(pxyz - pprev)) if (pmom_err < ptol) converged = .true. fexti = fstar enddo pmom_iterations - if (its > itsmax ) call warning('step_extern_gr',& + if (its > itsmax ) call warning('substep_gr',& 'max # of pmom iterations',var='pmom_err',val=pmom_err) pitsmax = max(its,pitsmax) perrmax = max(pmom_err,perrmax) call conservative2primitive(xyz,metrics(:,:,:,i),vxyz,densi,uui,pri,tempi,& gammai,rhoi,pxyz,eni,ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (b)]','enthalpy did not converge',i=i) + if (ierr > 0) call warning('cons2primsolver [in substep_gr (b)]','enthalpy did not converge',i=i) xyz = xyz + dt*vxyz call pack_metric(xyz,metrics(:,:,:,i)) @@ -260,7 +270,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me xyz_prev = xyz call conservative2primitive(xyz,metrics(:,:,:,i),vxyz_star,densi,uui,& pri,tempi,gammai,rhoi,pxyz,eni,ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (c)]','enthalpy did not converge',i=i) + if (ierr > 0) call warning('cons2primsolver [in substep_gr (c)]','enthalpy did not converge',i=i) xyz = xyz_prev + hdt*(vxyz_star - vxyz) x_err = maxval(abs(xyz-xyz_prev)) if (x_err < xtol) converged = .true. @@ -269,7 +279,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me call pack_metric(xyz,metrics(:,:,:,i)) enddo xyz_iterations call pack_metricderivs(xyz,metricderivs(:,:,:,i)) - if (its > itsmax ) call warning('step_extern_gr','Reached max number of x iterations. x_err ',val=x_err) + if (its > itsmax ) call warning('substep_gr','Reached max number of x iterations. x_err ',val=x_err) xitsmax = max(its,xitsmax) xerrmax = max(x_err,xerrmax) @@ -383,7 +393,7 @@ subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,me call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) endif -end subroutine step_extern_gr +end subroutine substep_gr !---------------------------------------------------------------- !+ @@ -391,7 +401,7 @@ end subroutine step_extern_gr ! forces, sink particles or cooling are used !+ !---------------------------------------------------------------- -subroutine step_extern_sph(dt,npart,xyzh,vxyzu) +subroutine substep_sph(dt,npart,xyzh,vxyzu) use part, only:isdead_or_accreted real, intent(in) :: dt integer, intent(in) :: npart @@ -414,7 +424,7 @@ subroutine step_extern_sph(dt,npart,xyzh,vxyzu) enddo !$omp end parallel do -end subroutine step_extern_sph +end subroutine substep_sph !---------------------------------------------------------------- !+ @@ -424,7 +434,7 @@ end subroutine step_extern_sph ! algorithm over the "fast" forces. !+ !---------------------------------------------------------------- -subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & +subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & fsink_old,nbinmax,ibin_wake) use io, only:iverbose,id,master,iprint,fatal @@ -432,7 +442,7 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v use part, only:fxyz_ptmass_sinksink use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent - use ptmass, only:use_fourthorder,ck,dk + integer, intent(in) :: npart,ntypes,nptmass real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce @@ -468,7 +478,7 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v substeps: do while (timei <= t_end_step .and. .not.done) force_count = 0 timei = timei + dt - if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + if (abs(dt) < tiny(0.)) call fatal('substepping','dt <= 0 in sink-gas substepping',var='dt',val=dt) nsubsteps = nsubsteps + 1 if (.not.last_step .and. iverbose > 1 .and. id==master) then @@ -527,7 +537,7 @@ subroutine step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,v call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) endif -end subroutine step_extern_pattern +end subroutine substep !---------------------------------------------------------------- @@ -769,7 +779,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & - ptmass_vdependent_correction,n_force_order + ptmass_vdependent_correction use options, only:iexternalforce use part, only:maxphase,abundance,nabundances,epot_sinksink,eos_vars,& isdead_or_accreted,iamboundary,igas,iphase,iamtype,massoftype,divcurlv, & @@ -925,8 +935,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,ckdt,dphot0,idK2,idmu,idkappa, & - idgamma,imu,igamma,nabn,dphotflag,nabundances) + divcurlv,abundc,abunde,abundo,abundsi,ckdt,dphot0) endif endif enddo @@ -971,9 +980,10 @@ end subroutine get_force ! calculated in force and requires a cooling timestep. subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & - divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,idK2,idmu,idkappa, & - idgamma,imu,igamma,nabn,dphotflag,nabundances) + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0) use dim, only:h2chemistry,do_nucleation,use_krome,update_muGamma,store_dust_temperature + use part, only:idK2,idmu,idkappa,idgamma,imu,igamma,nabundances + use cooling_ism, only:nabn,dphotflag use options, only:icooling use chem, only:update_abundances,get_dphot use dust_formation, only:evolve_dust @@ -991,8 +1001,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl real, intent(inout) :: abundc,abunde,abundo,abundsi real(kind=8), intent(in) :: dphot0 real, intent(in) :: dt,pmassi - integer, intent(in) :: idK2,idmu,idkappa,idgamma,imu,igamma - integer, intent(in) :: i,nabn,dphotflag,nabundances + integer, intent(in) :: i real :: dudtcool,rhoi,dphot real :: abundi(nabn) @@ -1095,5 +1104,23 @@ subroutine get_external_force_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew, end subroutine get_external_force_gas +subroutine set_integration_precision + use ptmass, only:dtfacphi,dtfacphi2,dtfacphilf, & + dtfacphifsi,dtfacphi2lf,dtfacphi2fsi + if(use_fourthorder) then + n_force_order = 3 + ck = ck4 + dk = dk4 + dtfacphi = dtfacphifsi + dtfacphi2 = dtfacphi2fsi + else + n_force_order = 1 + ck = ck2 + dk = dk2 + dtfacphi = dtfacphilf + dtfacphi2 = dtfacphi2lf + endif +end subroutine set_integration_precision + -end module step_extern +end module substepping diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index 09dbec6b9..fcadfe5b9 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -41,15 +41,15 @@ module setup !+ !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) - use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas - use units, only:set_units,umass !,udist - use physcon, only:solarm,kpc,pi,au,years,pc - use io, only:fatal,iprint,master - use eos, only:gmw - use timestep, only:dtmax - use spherical, only:set_sphere - use datafiles, only:find_phantom_datafile - use ptmass, only:use_fourthorder + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas + use units, only:set_units,umass !,udist + use physcon, only:solarm,kpc,pi,au,years,pc + use io, only:fatal,iprint,master + use eos, only:gmw + use timestep, only:dtmax + use spherical, only:set_sphere + use datafiles, only:find_phantom_datafile + use substepping, only:use_fourthorder integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -132,7 +132,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! setup initial sphere of particles to prevent initialisation problems ! psep = 1.0 - call set_sphere('cubic',id,master,0.,0.002,psep,hfact,npart,xyzh) + call set_sphere('cubic',id,master,0.,10.0,psep,hfact,npart,xyzh) vxyzu(4,:) = 5.317e-4 npartoftype(igas) = npart diff --git a/src/tests/test_gr.f90 b/src/tests/test_gr.f90 index 1e424118b..c429752e2 100644 --- a/src/tests/test_gr.f90 +++ b/src/tests/test_gr.f90 @@ -59,7 +59,7 @@ subroutine test_precession(ntests,npass) real :: dt,period,x0,vy0,tmax,angtol,postol real :: angmom(3),angmom0(3),xyz(3),vxyz(3) - write(*,'(/,a)') '--> testing step_extern_gr (precession)' + write(*,'(/,a)') '--> testing substep_gr (precession)' if (imetric /= imet_kerr .and. imetric /= imet_schwarzschild) then write(*,'(/,a)') ' Skipping test! Metric is not Kerr (or Schwarzschild).' return @@ -107,7 +107,7 @@ subroutine test_inccirc(ntests,npass) real :: m,omega,phi,q,r,rdot,rho2,theta,thetadot,vx,vy,vz,x1,y1,z1 real :: R2,rfinal - write(*,'(/,a)') '--> testing step_extern_gr (inclined circular orbit)' + write(*,'(/,a)') '--> testing substep_gr (inclined circular orbit)' if (imetric /= imet_kerr) then write(*,'(/,a)') ' Skipping test! Metric is not Kerr.' @@ -160,13 +160,13 @@ end subroutine test_inccirc !----------------------------------------------------------------------- !+ ! test the geodesic integrator using test particle integration -! and the step_extern_gr routine +! and the substep_gr routine !+ !----------------------------------------------------------------------- subroutine integrate_geodesic(tmax,dt,xyz,vxyz,angmom0,angmom) use io, only:iverbose use part, only:igas,npartoftype,massoftype,set_particle_type,get_ntypes,ien_type - use step_extern, only:step_extern_gr + use substepping, only:substep_gr use eos, only:ieos use cons2prim, only:prim2consall use metric_tools, only:init_metric,unpack_metric @@ -217,7 +217,7 @@ subroutine integrate_geodesic(tmax,dt,xyz,vxyz,angmom0,angmom) nsteps = nsteps + 1 time = time + dt dtextforce = blah - call step_extern_gr(npart,ntypes,dt,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) + call substep_gr(npart,ntypes,dt,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) enddo call calculate_angmom(xyzh(1:3,1),metrics(:,:,:,1),massi,vxyzu(1:3,1),angmom) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index c98a9a4a3..a6a30b030 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -28,11 +28,11 @@ module testptmass contains subroutine test_ptmass(ntests,npass) - use io, only:id,master,iskfile - use eos, only:polyk,gamma - use part, only:nptmass - use options, only:iexternalforce,alpha - use ptmass, only:use_fourthorder,set_integration_precision + use io, only:id,master,iskfile + use eos, only:polyk,gamma + use part, only:nptmass + use options, only:iexternalforce,alpha + use substepping, only:use_fourthorder,set_integration_precision character(len=20) :: filename integer, intent(inout) :: ntests,npass integer :: itmp,ierr,itest @@ -106,7 +106,8 @@ subroutine test_binary(ntests,npass) use io, only:id,master,iverbose use physcon, only:pi,deg_to_rad use ptmass, only:get_accel_sink_sink,h_soft_sinksink, & - get_accel_sink_gas,f_acc,use_fourthorder + get_accel_sink_gas,f_acc + use substepping,only:use_fourthorder use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fext,& npart,npartoftype,massoftype,xyzh,vxyzu,fxyzu,& hfact,igas,epot_sinksink,init_part,iJ2,ispinx,ispiny,ispinz,iReff,istar From 29a21c6918052ed8e06bfdb7435e95b82517b28c Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 18 Apr 2024 10:01:01 +1000 Subject: [PATCH 435/814] comments --- src/main/ptmass.F90 | 7 ++--- src/main/substepping.F90 | 61 ++++++++++++++++++++++++++++++++-------- 2 files changed, 52 insertions(+), 16 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 971e13a62..a214ab349 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -540,8 +540,7 @@ end subroutine ptmass_boundary_crossing !---------------------------------------------------------------- !+ -! predictor step for the point masses -! (called from inside a parallel section) +! drift phase for the point masses. (just a position update) !+ !---------------------------------------------------------------- subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) @@ -567,7 +566,7 @@ end subroutine ptmass_drift !---------------------------------------------------------------- !+ -! kick step for the point masses +! kick phase for the point masses (velocity and spin update) !+ !---------------------------------------------------------------- subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass) @@ -599,7 +598,7 @@ end subroutine ptmass_kick !---------------------------------------------------------------- !+ -! force correction due to vdep force. +! force correction due to vdep force for point masses. !+ !---------------------------------------------------------------- subroutine ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 7f43bf2f9..d3045433d 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -21,7 +21,7 @@ module substepping ! Tuckerman, Berne & Martyna (1992), J. Chem. Phys. 97, 1990-2001 ! Rantala + (2020) (2023),Chin (2007a) ! -! :Owner: Daniel Price +! :Owner: Yann BERNARD ! ! :Runtime parameters: None ! @@ -39,6 +39,9 @@ module substepping public :: substep public :: set_integration_precision + ! + !-- Parameters for switching between FSI or leapfrog (FSI is use by default) + ! logical, public :: use_fourthorder = .true. integer, public :: n_force_order = 3 real, public, parameter :: dk2(3) = (/0.5,0.5,0.0/) @@ -432,6 +435,7 @@ end subroutine substep_sph ! Also updates position of all particles even if no external ! forces applied. This is the internal loop of the RESPA ! algorithm over the "fast" forces. + ! (Here it can be FSI or Leapfrog) !+ !---------------------------------------------------------------- subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & @@ -495,6 +499,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) if (use_fourthorder) then !! FSI 4th order scheme + ! FSFI extrapolation method (Omelyan 2006) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,fsink_old) @@ -508,10 +513,13 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + else !! standard leapfrog scheme + ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + endif @@ -542,7 +550,7 @@ end subroutine substep !---------------------------------------------------------------- !+ - ! drift routine for the 4th order scheme + ! drift routine for the whole system (part and ptmass) !+ !---------------------------------------------------------------- @@ -590,7 +598,7 @@ end subroutine drift !---------------------------------------------------------------- !+ - ! kick routine for the 4th order scheme + ! kick routine for the whole system (part and ptmass) !+ !---------------------------------------------------------------- @@ -769,7 +777,11 @@ end subroutine kick !---------------------------------------------------------------- !+ - ! force routine for the 4th order scheme + ! force routine for the whole system. First is computed the + ! sink/sink interaction and extf on sink, then comes forces + ! on gas. sink/gas, extf and dampening. Finally there is an + ! update of abundances and temp depending on cooling method + ! during the last force calculation of the substep. !+ !---------------------------------------------------------------- @@ -835,7 +847,9 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, call update_externalforce(iexternalforce,timei,dmdt) - + ! + !-- Sink-sink interactions (loop over ptmass in get_accel_sink_sink) + ! if (nptmass>0) then if (id==master) then if (extrap) then @@ -869,6 +883,9 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dtextforcenew = min(dtextforcenew,C_force*dtf) endif + ! + !-- Forces on gas particles (Sink/gas,extf,damp,cooling) + ! !$omp parallel default(none) & !$omp shared(maxp,maxphase) & @@ -925,6 +942,9 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, extf_vdep_flag,iexternalforce) endif + ! + ! dampening + ! if (idamp > 0) then call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), (/xi,yi,zi/), damp_fac) endif @@ -932,7 +952,9 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, fext(1,i) = fextx fext(2,i) = fexty fext(3,i) = fextz - + ! + ! temperature and abundances update (only done during the last force calculation of the substep) + ! 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,ckdt,dphot0) @@ -973,12 +995,17 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, end subroutine get_force -! NOTE: The chemistry and cooling here is implicitly calculated. That is, -! dt is *passed in* to the chemistry & cooling routines so that the -! output will be at the correct time of time + dt. Since this is -! implicit, there is no cooling timestep. Explicit cooling is -! calculated in force and requires a cooling timestep. + !----------------------------------------------------------------------------------- + !+ + ! Update of abundances and internal energy using cooling method (see cooling module) + ! NOTE: The chemistry and cooling here is implicitly calculated. That is, + ! dt is *passed in* to the chemistry & cooling routines so that the + ! output will be at the correct time of time + dt. Since this is + ! implicit, there is no cooling timestep. Explicit cooling is + ! calculated in force and requires a cooling timestep. + !+ + !------------------------------------------------------------------------------------ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0) use dim, only:h2chemistry,do_nucleation,use_krome,update_muGamma,store_dust_temperature @@ -1066,7 +1093,11 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl end subroutine cooling_abundances_update - + !---------------------------------------------------------------- + !+ + ! routine for external force applied on gas particle + !+ + !---------------------------------------------------------------- subroutine get_external_force_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew,dtf,dkdt, & fextx,fexty,fextz,extf_is_velocity_dependent,iexternalforce) @@ -1104,6 +1135,12 @@ subroutine get_external_force_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew, end subroutine get_external_force_gas + !---------------------------------------------------------------- + !+ + ! precision switcher routine. FSI or Leapfrog (use_fourthorder) + !+ + !---------------------------------------------------------------- + subroutine set_integration_precision use ptmass, only:dtfacphi,dtfacphi2,dtfacphilf, & dtfacphifsi,dtfacphi2lf,dtfacphi2fsi From 3a499f432326a3c47e5e471c9fd1fcff9d291a93 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 18 Apr 2024 14:39:06 +1000 Subject: [PATCH 436/814] (github) updated actions/checkout to v4 --- .github/workflows/build.yml | 2 +- .github/workflows/krome.yml | 2 +- .github/workflows/mpi.yml | 2 +- .github/workflows/test.yml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 2acd7ba98..dccaebd65 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -35,7 +35,7 @@ jobs: nbatch: ${{ steps.set-sequence.outputs.nbatch }} steps: - name: Check out repo - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Generate sequence of batch numbers for normal tests, or run sequentially for scheduled tests id: set-sequence run: | diff --git a/.github/workflows/krome.yml b/.github/workflows/krome.yml index 25204531a..51302f869 100644 --- a/.github/workflows/krome.yml +++ b/.github/workflows/krome.yml @@ -32,7 +32,7 @@ jobs: compiler: ${{ matrix.toolchain.compiler }} - name: "Clone phantom" - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: "Clone krome" run: git clone https://bitbucket.org/tgrassi/krome.git krome diff --git a/.github/workflows/mpi.yml b/.github/workflows/mpi.yml index 46099c9f2..1eb06909e 100644 --- a/.github/workflows/mpi.yml +++ b/.github/workflows/mpi.yml @@ -53,7 +53,7 @@ jobs: sudo apt-get --yes install gfortran openmpi-bin openmpi-common libopenmpi-dev # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - name: Compile with MPI run: make SETUP=${{ matrix.input[0] }} MPI=yes DEBUG=${{ matrix.debug }} OPENMP=${{ matrix.openmp }} phantomtest diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 8526cebfd..d78ab7eb4 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -87,7 +87,7 @@ jobs: printenv >> $GITHUB_ENV - name: "Clone phantom" - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: "Compile phantom" run: make SETUP=${{ matrix.input[0] }} DEBUG=${{ matrix.debug }} phantomtest From 50748db023a8ffd12b8008b29b935c87722b1124 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 18 Apr 2024 16:22:39 +1000 Subject: [PATCH 437/814] fix weird failure --- src/main/checksetup.f90 | 4 +-- src/main/evolve.F90 | 4 +-- src/main/ptmass.F90 | 45 +++++++++++++++++++++------ src/main/substepping.F90 | 66 +++++++++------------------------------- 4 files changed, 53 insertions(+), 66 deletions(-) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 8f296fb40..eec4f19f0 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -526,7 +526,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) use part, only:nptmass,xyzmh_ptmass,ihacc,ihsoft,gr,iTeff,sinks_have_luminosity,& ilum,iJ2,ispinx,ispinz,iReff use ptmass_radiation, only:isink_radiation - use substepping, only:use_fourthorder + use ptmass, only:use_fourthorder integer, intent(inout) :: nerror,nwarn real, intent(in) :: hmin integer :: i,j,n @@ -1017,7 +1017,7 @@ end subroutine check_setup_radiation subroutine check_vdep_extf(nwarn,iexternalforce) use externalforces, only: is_velocity_dependent - use substepping, only : use_fourthorder + use ptmass, only : use_fourthorder integer, intent(inout) :: nwarn integer, intent(in) :: iexternalforce if (is_velocity_dependent(iexternalforce) .and. use_fourthorder) then diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index b003934fc..53b9d7928 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -91,8 +91,8 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,gravity,iboundary, & fxyz_ptmass_sinksink,ntot,poten,ndustsmall,accrete_particles_outside_sphere use quitdump, only:quit - use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot - use substepping, only:set_integration_precision + use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & + set_integration_precision use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index a214ab349..e6c179def 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -55,7 +55,7 @@ module ptmass public :: calculate_mdot public :: ptmass_calc_enclosed_mass public :: ptmass_boundary_crossing - + public :: set_integration_precision ! settings affecting routines in module (read from/written to input file) integer, public :: icreate_sinks = 0 @@ -70,7 +70,15 @@ module ptmass real, public :: f_crit_override = 0.0 ! 1000. + logical, public :: use_fourthorder = .true. + integer, public :: n_force_order = 3 + real, public, parameter :: dk2(3) = (/0.5,0.5,0.0/) + real, public, parameter :: ck2(2) = (/1.,0.0/) + real, public, parameter :: dk4(3) = (/1./6.,2./3.,1./6./) + real, public, parameter :: ck4(2) = (/0.5,0.5/) + real, public :: dk(3) + real, public :: ck(2) ! Note for above: if f_crit_override > 0, then will unconditionally make a sink when rho > f_crit_override*rho_crit_cgs @@ -87,13 +95,13 @@ module ptmass ! calibration of timestep control on sink-sink and sink-gas orbital integration ! this is hardwired because can be adjusted by changing C_force ! just means that with the default setting of C_force the orbits are accurate - real, public, parameter :: dtfacphilf = 0.05 - real, public, parameter :: dtfacphi2lf = dtfacphilf**2 - real, public, parameter :: dtfacphifsi = 0.05 - real, public, parameter :: dtfacphi2fsi = dtfacphifsi**2 + real, parameter :: dtfacphilf = 0.05 + real, parameter :: dtfacphi2lf = dtfacphilf**2 + real, parameter :: dtfacphifsi = 0.05 + real, parameter :: dtfacphi2fsi = dtfacphifsi**2 - real, public :: dtfacphi = dtfacphifsi - real, public :: dtfacphi2 = dtfacphifsi + real :: dtfacphi = dtfacphifsi + real :: dtfacphi2 = dtfacphifsi ! parameters to control output regarding sink particles @@ -540,7 +548,8 @@ end subroutine ptmass_boundary_crossing !---------------------------------------------------------------- !+ -! drift phase for the point masses. (just a position update) +! predictor step for the point masses +! (called from inside a parallel section) !+ !---------------------------------------------------------------- subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) @@ -566,7 +575,7 @@ end subroutine ptmass_drift !---------------------------------------------------------------- !+ -! kick phase for the point masses (velocity and spin update) +! kick step for the point masses !+ !---------------------------------------------------------------- subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass) @@ -598,7 +607,7 @@ end subroutine ptmass_kick !---------------------------------------------------------------- !+ -! force correction due to vdep force for point masses. +! force correction due to vdep force. !+ !---------------------------------------------------------------- subroutine ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) @@ -1622,6 +1631,22 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_i end subroutine merge_sinks +subroutine set_integration_precision + if(use_fourthorder) then + n_force_order = 3 + ck = ck4 + dk = dk4 + dtfacphi = dtfacphifsi + dtfacphi2 = dtfacphi2fsi + else + n_force_order = 1 + ck = ck2 + dk = dk2 + dtfacphi = dtfacphilf + dtfacphi2 = dtfacphi2lf + endif +end subroutine set_integration_precision + !----------------------------------------------------------------------- !+ ! Open files to track sink particle data diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index d3045433d..ddbf29dcc 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -37,20 +37,6 @@ module substepping public :: substep_sph public :: substep_sph_gr public :: substep - public :: set_integration_precision - - ! - !-- Parameters for switching between FSI or leapfrog (FSI is use by default) - ! - logical, public :: use_fourthorder = .true. - integer, public :: n_force_order = 3 - real, public, parameter :: dk2(3) = (/0.5,0.5,0.0/) - real, public, parameter :: ck2(2) = (/1.,0.0/) - real, public, parameter :: dk4(3) = (/1./6.,2./3.,1./6./) - real, public, parameter :: ck4(2) = (/0.5,0.5/) - - real, public :: dk(3) - real, public :: ck(2) private @@ -446,7 +432,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & use part, only:fxyz_ptmass_sinksink use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent - + use ptmass, only:use_fourthorder,ck,dk integer, intent(in) :: npart,ntypes,nptmass real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce @@ -791,7 +777,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & - ptmass_vdependent_correction + 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, & @@ -942,8 +928,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, extf_vdep_flag,iexternalforce) endif - ! - ! dampening +! + ! damping ! if (idamp > 0) then call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), (/xi,yi,zi/), damp_fac) @@ -996,16 +982,16 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, end subroutine get_force - !----------------------------------------------------------------------------------- - !+ - ! Update of abundances and internal energy using cooling method (see cooling module) - ! NOTE: The chemistry and cooling here is implicitly calculated. That is, - ! dt is *passed in* to the chemistry & cooling routines so that the - ! output will be at the correct time of time + dt. Since this is - ! implicit, there is no cooling timestep. Explicit cooling is - ! calculated in force and requires a cooling timestep. - !+ - !------------------------------------------------------------------------------------ +!----------------------------------------------------------------------------------- +!+ +! Update of abundances and internal energy using cooling method (see cooling module) +! NOTE: The chemistry and cooling here is implicitly calculated. That is, +! dt is *passed in* to the chemistry & cooling routines so that the +! output will be at the correct time of time + dt. Since this is +! implicit, there is no cooling timestep. Explicit cooling is +! calculated in force and requires a cooling timestep. +!+ +!------------------------------------------------------------------------------------ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0) use dim, only:h2chemistry,do_nucleation,use_krome,update_muGamma,store_dust_temperature @@ -1135,29 +1121,5 @@ subroutine get_external_force_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew, end subroutine get_external_force_gas - !---------------------------------------------------------------- - !+ - ! precision switcher routine. FSI or Leapfrog (use_fourthorder) - !+ - !---------------------------------------------------------------- - -subroutine set_integration_precision - use ptmass, only:dtfacphi,dtfacphi2,dtfacphilf, & - dtfacphifsi,dtfacphi2lf,dtfacphi2fsi - if(use_fourthorder) then - n_force_order = 3 - ck = ck4 - dk = dk4 - dtfacphi = dtfacphifsi - dtfacphi2 = dtfacphi2fsi - else - n_force_order = 1 - ck = ck2 - dk = dk2 - dtfacphi = dtfacphilf - dtfacphi2 = dtfacphi2lf - endif -end subroutine set_integration_precision - end module substepping From 01f607f295ed8d2e8cc395031c6c4b167ba1ebf2 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 18 Apr 2024 16:35:23 +1000 Subject: [PATCH 438/814] (test) fix build failure --- src/tests/test_ptmass.f90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index a6a30b030..f6e05b3f2 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -32,7 +32,7 @@ subroutine test_ptmass(ntests,npass) use eos, only:polyk,gamma use part, only:nptmass use options, only:iexternalforce,alpha - use substepping, only:use_fourthorder,set_integration_precision + use ptmass, only:use_fourthorder,set_integration_precision character(len=20) :: filename integer, intent(inout) :: ntests,npass integer :: itmp,ierr,itest @@ -106,8 +106,7 @@ subroutine test_binary(ntests,npass) use io, only:id,master,iverbose use physcon, only:pi,deg_to_rad use ptmass, only:get_accel_sink_sink,h_soft_sinksink, & - get_accel_sink_gas,f_acc - use substepping,only:use_fourthorder + get_accel_sink_gas,f_acc,use_fourthorder use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fext,& npart,npartoftype,massoftype,xyzh,vxyzu,fxyzu,& hfact,igas,epot_sinksink,init_part,iJ2,ispinx,ispiny,ispinz,iReff,istar From 6e73965e302e8b5693fa8321d7f3d406affada1b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 18 Apr 2024 16:58:51 +1000 Subject: [PATCH 439/814] fix wrong dt in cooling/abundances function --- src/main/substepping.F90 | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index ddbf29dcc..36eb261c3 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -482,20 +482,20 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & 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,ck(1),dk(2),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag) if (use_fourthorder) then !! FSI 4th order scheme ! FSFI extrapolation method (Omelyan 2006) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,fsink_old) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(2),dk(3),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) @@ -772,7 +772,7 @@ end subroutine kick !---------------------------------------------------------------- subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, & - fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,cki,dki, & + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dki, & force_count,extf_vdep_flag,fsink_old) use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc @@ -794,7 +794,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) real, intent(inout) :: dtextforce - real, intent(in) :: timei,cki,dki,dt + real, intent(in) :: timei,dki,dt logical, intent(in) :: extf_vdep_flag real, optional, intent(inout) :: fsink_old(4,nptmass) integer :: merge_ij(nptmass) @@ -804,7 +804,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real :: dtf,dtextforcenew,dtsinkgas,dtphi2,fonrmax real :: fextx,fexty,fextz,xi,yi,zi,pmassi,damp_fac real :: fonrmaxi,phii,dtphi2i - real :: dkdt,ckdt,extrapfac + real :: dkdt,extrapfac logical :: extrap,last if(present(fsink_old)) then @@ -817,7 +817,6 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, force_count = force_count + 1 extrapfac = (1./24.)*dt**2 dkdt = dki*dt - ckdt = cki*dt itype = igas pmassi = massoftype(igas) dtextforcenew = bignumber @@ -877,7 +876,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$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,ckdt,timei,iexternalforce,extf_vdep_flag,last) & + !$omp shared(dkdt,dt,timei,iexternalforce,extf_vdep_flag,last) & !$omp shared(divcurlv,dphotflag,dphot0,nucleation,extrap) & !$omp shared(abundc,abundo,abundsi,abunde,extrapfac,fsink_old) & !$omp private(fextx,fexty,fextz,xi,yi,zi) & @@ -943,7 +942,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,ckdt,dphot0) + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0) endif endif enddo From e3cbe5eafc3880dddd2c4e484a1450ad63edb314 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 18 Apr 2024 18:15:42 +1000 Subject: [PATCH 440/814] fix starcluster setup import --- src/setup/setup_starcluster.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index fcadfe5b9..4e691d16a 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -49,7 +49,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use timestep, only:dtmax use spherical, only:set_sphere use datafiles, only:find_phantom_datafile - use substepping, only:use_fourthorder + use ptmass, only:use_fourthorder integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) From fca8becc7eeb6910601edd9d652e7d88d670d0ad Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 18 Apr 2024 21:22:33 +1000 Subject: [PATCH 441/814] (test_derivs) cleanup ifdefs #55 and fix bug with mask, resolves #529 --- src/tests/test_derivs.F90 | 498 ++++++++++++++++++-------------------- 1 file changed, 230 insertions(+), 268 deletions(-) diff --git a/src/tests/test_derivs.F90 b/src/tests/test_derivs.F90 index 4423158f5..8f69b00ab 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 + maxdustsmall,periodic,mpi,ind_timesteps 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 @@ -53,34 +53,24 @@ subroutine test_derivs(ntests,npass,string) use viscosity, only:bulkvisc,shearparam,irealvisc use part, only:iphase,isetphase,igas use nicil, only:use_ambi -#ifdef IND_TIMESTEPS use timestep_ind, only:nactive use part, only:ibin -#endif -#ifdef DUST use dust, only:init_drag,idrag,K_code use part, only:grainsize,graindens,ndustlarge,ndusttypes -#endif use units, only:set_units use testutils, only:checkval,checkvalf,update_test_scores use mpidomain, only:i_belong integer, intent(inout) :: ntests,npass character(len=*), intent(in) :: string real :: psep,time,hzero,totmass -#ifdef IND_TIMESTEPS - integer :: itest,ierr2,nptest + integer :: itest,ierr2,nptest,nstart,nend,nstep real :: fracactive,speedup real(kind=4) :: tallactive real, allocatable :: fxyzstore(:,:),dBdtstore(:,:) -#else - integer :: nactive -#endif real :: psepblob,hblob,rhoblob,rblob,totvol,rtest -#ifdef PERIODIC integer :: maxtrial,maxactual integer(kind=8) :: nrhocalc,nactual,nexact real :: trialmean,actualmean,realneigh -#endif real :: rcut real :: rho1i,deint,demag,dekin,dedust,dmdust(maxdustsmall),dustfraci(maxdustsmall),tol real(kind=4) :: tused @@ -91,11 +81,8 @@ subroutine test_derivs(ntests,npass,string) real :: stressmax,rhoi,sonrhoi(maxdustsmall),drhodti,depsdti(maxdustsmall),dustfracj integer(kind=8) :: nptot real, allocatable :: dummy(:) -#ifdef IND_TIMESTEPS real :: tolh_old -#endif - logical :: checkmask(maxp) - + logical, allocatable :: mask(:) if (id==master) write(*,"(a,/)") '--> TESTING DERIVS MODULE' @@ -134,6 +121,7 @@ subroutine test_derivs(ntests,npass,string) testgradh = (maxgradh==maxp .and. index(kernelname,'cubic') > 0) call init_part() + allocate(mask(maxp)) iprint = 6 iverbose = max(iverbose,2) psep = dxbound/100. @@ -159,13 +147,13 @@ subroutine test_derivs(ntests,npass,string) nptot = reduceall_mpi('+',npart) massoftype(1) = totmass/reduceall_mpi('+',npart) -#ifndef PERIODIC - ! exclude particles near edge - rcut = min(xmax,ymax,zmax) - 2.*radkern*hfact*psep -#else - ! include all - rcut = sqrt(huge(rcut)) -#endif + if (periodic) then + ! include all particles + rcut = sqrt(huge(rcut)) + else + ! exclude particles near edge + rcut = min(xmax,ymax,zmax) - 2.*radkern*hfact*psep + endif print*,'thread ',id,' npart = ',npart if (id==master) print "(a,g9.2)",' hfact = ',hfact @@ -204,7 +192,7 @@ subroutine test_derivs(ntests,npass,string) !--calculate derivatives ! call get_derivs_global(tused) - call rcut_checkmask(rcut,xyzh,npart,checkmask) + call rcut_mask(rcut,xyzh,npart,mask) ! !--check hydro quantities come out as they should do ! @@ -214,8 +202,8 @@ subroutine test_derivs(ntests,npass,string) ! !--also check that the number of neighbours is correct ! -#ifdef PERIODIC - if (id==master .and. index(kernelname,'cubic') > 0) then + + if (id==master .and. periodic .and. index(kernelname,'cubic') > 0) then call get_neighbour_stats(trialmean,actualmean,maxtrial,maxactual,nrhocalc,nactual) realneigh = 4./3.*pi*(hfact*radkern)**3 call checkval(actualmean,real(int(realneigh)),tiny(0.),nfailed(11),'mean nneigh') @@ -225,68 +213,73 @@ subroutine test_derivs(ntests,npass,string) nexact = nptot*int(realneigh) call checkval(nactual,nexact,0,nfailed(14),'total nneigh') endif -#endif ! !--check that the timestep bin has been set ! -#ifdef IND_TIMESTEPS - call checkval(all(ibin(1:npart) > 0),.true.,nfailed(15),'ibin > 0') -#endif + + print*,' COUNT=',count(ibin(1:npart) > 0) + if (ind_timesteps) call checkval(all(ibin(1:npart) > 0),.true.,nfailed(15),'ibin > 0') call update_test_scores(ntests,nfailed,npass) -#ifdef IND_TIMESTEPS - tallactive = tused + if (ind_timesteps) then + tallactive = tused - do itest=0,nint(log10(real(nptot)))-1 - nactive = 10**itest - if (id==master) write(*,"(/,a,i10,a)") '--> testing Hydro derivatives (on ',nactive,' active particles)' - call set_velocity_and_energy - do i=1,npart - if (i <= nactive/nprocs) then - iphase(i) = isetphase(igas,iactive=.true.) - xyzh(4,i) = hzero - else - iphase(i) = isetphase(igas,iactive=.false.) - endif - enddo - call reset_mhd_to_zero - ! - !--check timing for one active particle - ! - call get_derivs_global(tused) - if (id==master) then - fracactive = nactive/real(npart) - speedup = (tused)/tallactive - write(*,"(1x,'(',3(a,f9.5,'%'),')')") & + do itest=0,nint(log10(real(nptot)))-1 + nactive = 10**itest + if (id==master) write(*,"(/,a,i10,a)") '--> testing Hydro derivatives (on ',nactive,' active particles)' + call set_velocity_and_energy + do i=1,npart + if (i <= nactive/nprocs) then + iphase(i) = isetphase(igas,iactive=.true.) + xyzh(4,i) = hzero + else + iphase(i) = isetphase(igas,iactive=.false.) + endif + enddo + call reset_mhd_to_zero + ! + !--check timing for one active particle + ! + call get_derivs_global(tused) + if (id==master) then + fracactive = nactive/real(npart) + speedup = (tused)/tallactive + write(*,"(1x,'(',3(a,f9.5,'%'),')')") & 'moved ',100.*fracactive,' of particles in ',100.*speedup, & ' of time, efficiency = ',100.*fracactive/speedup - endif + endif - ! - ! Note that we check ALL values, including the inactives. That is we check - ! that the inactives have preserved their values from last time they were - ! calculated (finds bug of mistakenly setting inactives to zero) - ! - nfailed(:) = 0; m = 0 - call check_hydro(np,nfailed,m) - if (maxvxyzu==4) call check_fxyzu(np,nfailed,m) + ! + ! Note that we check ALL values, including the inactives. That is we check + ! that the inactives have preserved their values from last time they were + ! calculated (finds bug of mistakenly setting inactives to zero) + ! + nfailed(:) = 0; m = 0 + call check_hydro(np,nfailed,m) + if (maxvxyzu==4) call check_fxyzu(np,nfailed,m) - call update_test_scores(ntests,nfailed,npass) - ! - !--reset all particles to active for subsequent tests - ! - call reset_allactive() - enddo -#endif + call update_test_scores(ntests,nfailed,npass) + call reset_allactive() ! reset all particles to active for subsequent tests + enddo + endif endif testhydro + ! + !--for subsequent tests involving individual timesteps, cycle + ! through different numbers of active particles + ! + if (ind_timesteps) then + nstart = nint(log10(real(nptot))); nend = 0; nstep = -2 + else + nstart = 1; nend=1; nstep=1 + endif + testavderivs: if (testav .or. testall) then -#ifdef IND_TIMESTEPS - do itest=nint(log10(real(nptot))),0,-2 - nactive = 10**itest -#endif + do itest=nstart,nend,nstep + nactive = npart + if (ind_timesteps) nactive = 10**itest ! !--check artificial viscosity terms (pressure + av) ! @@ -300,9 +293,7 @@ subroutine test_derivs(ntests,npass,string) write(*,"(/,a)") '--> testing artificial viscosity terms (constant alpha)' endif #endif -#ifdef IND_TIMESTEPS if (nactive /= npart) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' -#endif endif if (maxvxyzu < 4) polyk = 3. call set_velocity_only @@ -316,18 +307,16 @@ subroutine test_derivs(ntests,npass,string) if (maxalpha==maxp) alphaind(1,:) = real(alpha,kind=kind(alphaind)) call get_derivs_global() - call rcut_checkmask(rcut,xyzh,npart,checkmask) + call rcut_mask(rcut,xyzh,npart,mask) nfailed(:) = 0; m = 0 call check_hydro(np,nfailed,m) - call checkvalf(np,xyzh,fxyzu(1,:),forceavx,5.7e-3,nfailed(m+1),'art. visc force(x)',checkmask) - call checkvalf(np,xyzh,fxyzu(2,:),forceavy,1.4e-2,nfailed(m+2),'art. visc force(y)',checkmask) - call checkvalf(np,xyzh,fxyzu(3,:),forceavz,1.3e-2,nfailed(m+3),'art. visc force(z)',checkmask) + call checkvalf(np,xyzh,fxyzu(1,:),forceavx,5.7e-3,nfailed(m+1),'art. visc force(x)',mask) + call checkvalf(np,xyzh,fxyzu(2,:),forceavy,1.4e-2,nfailed(m+2),'art. visc force(y)',mask) + call checkvalf(np,xyzh,fxyzu(3,:),forceavz,1.3e-2,nfailed(m+3),'art. visc force(z)',mask) call update_test_scores(ntests,nfailed,npass) -#ifdef IND_TIMESTEPS - call reset_allactive() + if (ind_timesteps) call reset_allactive() enddo -#endif endif testavderivs ! @@ -363,7 +352,7 @@ subroutine test_derivs(ntests,npass,string) call check_hydro(np,nfailed,m) if (nalpha >= 2) then ialphaloc = 2 - call checkvalf(np,xyzh,alphaind(ialphaloc,:),alphalocfunc,3.5e-4,nfailed(m+1),'alphaloc') + call checkvalf(np,xyzh,alphaind(ialphaloc,:),alphalocfunc,3.5e-4,nfailed(m+1),'alphaloc',mask) endif call update_test_scores(ntests,nfailed,npass) else @@ -391,30 +380,29 @@ subroutine test_derivs(ntests,npass,string) bulkvisc = 0.75 call get_derivs_global() - call rcut_checkmask(rcut,xyzh,npart,checkmask) + call rcut_mask(rcut,xyzh,npart,mask) nfailed(:) = 0; m = 0 call check_hydro(np,nfailed,m) if (maxdvdx==maxp) then - call checkvalf(np,xyzh,dvdx(1,:),dvxdx,1.7e-3,nfailed(m+1), 'dvxdx',checkmask) - call checkvalf(np,xyzh,dvdx(2,:),dvxdy,2.5e-15,nfailed(m+2), 'dvxdy',checkmask) - call checkvalf(np,xyzh,dvdx(3,:),dvxdz,2.5e-15,nfailed(m+3), 'dvxdz',checkmask) - call checkvalf(np,xyzh,dvdx(4,:),dvydx,1.e-3,nfailed(m+4), 'dvydx',checkmask) - call checkvalf(np,xyzh,dvdx(5,:),dvydy,2.5e-15,nfailed(m+5), 'dvydy',checkmask) - call checkvalf(np,xyzh,dvdx(6,:),dvydz,1.e-3,nfailed(m+6), 'dvydz',checkmask) - call checkvalf(np,xyzh,dvdx(7,:),dvzdx,2.5e-15,nfailed(m+7), 'dvzdx',checkmask) - call checkvalf(np,xyzh,dvdx(8,:),dvzdy,1.5e-3,nfailed(m+8), 'dvzdy',checkmask) - call checkvalf(np,xyzh,dvdx(9,:),dvzdz,2.5e-15,nfailed(m+9),'dvzdz',checkmask) + call checkvalf(np,xyzh,dvdx(1,:),dvxdx,1.7e-3,nfailed(m+1), 'dvxdx',mask) + call checkvalf(np,xyzh,dvdx(2,:),dvxdy,2.5e-15,nfailed(m+2),'dvxdy',mask) + call checkvalf(np,xyzh,dvdx(3,:),dvxdz,2.5e-15,nfailed(m+3),'dvxdz',mask) + call checkvalf(np,xyzh,dvdx(4,:),dvydx,1.e-3,nfailed(m+4), 'dvydx',mask) + call checkvalf(np,xyzh,dvdx(5,:),dvydy,2.5e-15,nfailed(m+5),'dvydy',mask) + call checkvalf(np,xyzh,dvdx(6,:),dvydz,1.e-3,nfailed(m+6), 'dvydz',mask) + call checkvalf(np,xyzh,dvdx(7,:),dvzdx,2.5e-15,nfailed(m+7),'dvzdx',mask) + call checkvalf(np,xyzh,dvdx(8,:),dvzdy,1.5e-3,nfailed(m+8), 'dvzdy',mask) + call checkvalf(np,xyzh,dvdx(9,:),dvzdz,2.5e-15,nfailed(m+9),'dvzdz',mask) endif - call checkvalf(np,xyzh,fxyzu(1,:),forceviscx,4.e-2,nfailed(m+10),'viscous force(x)',checkmask) - call checkvalf(np,xyzh,fxyzu(2,:),forceviscy,3.e-2,nfailed(m+11),'viscous force(y)',checkmask) - call checkvalf(np,xyzh,fxyzu(3,:),forceviscz,3.1e-2,nfailed(m+12),'viscous force(z)',checkmask) + call checkvalf(np,xyzh,fxyzu(1,:),forceviscx,4.e-2,nfailed(m+10),'viscous force(x)',mask) + call checkvalf(np,xyzh,fxyzu(2,:),forceviscy,3.e-2,nfailed(m+11),'viscous force(y)',mask) + call checkvalf(np,xyzh,fxyzu(3,:),forceviscz,3.1e-2,nfailed(m+12),'viscous force(z)',mask) ! !--also check that the number of neighbours is correct ! -#ifdef PERIODIC - if (id==master) then + if (id==master .and. periodic) then call get_neighbour_stats(trialmean,actualmean,maxtrial,maxactual,nrhocalc,nactual) realneigh = 4./3.*pi*(hfact*radkern)**3 if (testall) then @@ -428,7 +416,6 @@ subroutine test_derivs(ntests,npass,string) call checkval(nactual,nexact,0,nfailed(18),'total nneigh') endif endif -#endif ! !--check that \sum m (du/dt + v.dv/dt) = 0. ! only applies if all particles active - with individual timesteps @@ -465,23 +452,23 @@ subroutine test_derivs(ntests,npass,string) if (use_dust) use_dustfrac=.true. if (use_dustfrac) then if (id==master) write(*,"(/,a)") '--> testing dust evolution terms' -#ifdef DUST - idrag = 2 - gamma = 5./3. - !--Warning, K_code is not well defined when using multiple dust grains - ! and ONLY makes sense IFF all dust grains are identical (although - ! potentially binned with unequal densities). - ! K_code and K_k are related via: K_k = eps_k/eps*K_code) - K_code = 10. - grainsize = 0.01 - graindens = 3. - ndustsmall = maxdustsmall - ndustlarge = 0 - ndusttypes = ndustsmall + ndustlarge - !need to set units if testing with physical drag - !call set_units(dist=au,mass=solarm,G=1.d0) - call init_drag(nfailed(1)) -#endif + if (use_dust) then + idrag = 2 + gamma = 5./3. + !--Warning, K_code is not well defined when using multiple dust grains + ! and ONLY makes sense IFF all dust grains are identical (although + ! potentially binned with unequal densities). + ! K_code and K_k are related via: K_k = eps_k/eps*K_code) + K_code = 10. + grainsize = 0.01 + graindens = 3. + ndustsmall = maxdustsmall + ndustlarge = 0 + ndusttypes = ndustsmall + ndustlarge + !need to set units if testing with physical drag + !call set_units(dist=au,mass=solarm,G=1.d0) + call init_drag(nfailed(1)) + endif polyk = 0. call reset_mhd_to_zero call reset_dissipation_to_zero @@ -494,17 +481,18 @@ subroutine test_derivs(ntests,npass,string) enddo call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) nfailed(:) = 0; m = 0 call check_hydro(np,nfailed,m) do j=1,1 !ndustsmall !--Only need one because all dust species are identical -#ifdef DUST - grainsizek = grainsize(j) - graindensk = graindens(j) -#endif - call checkvalf(np,xyzh,ddustevol(j,:),ddustevol_func,4.e-5,nfailed(m+1),'deps/dt') - if (maxvxyzu>=4) call checkvalf(np,xyzh,fxyzu(iu,:),dudtdust_func,1.e-3,nfailed(m+2),'du/dt') - call checkvalf(np,xyzh,deltav(1,j,:),deltavx_func,1.01e-3,nfailed(m+3),'deltavx') + if (use_dust) then + grainsizek = grainsize(j) + graindensk = graindens(j) + endif + call checkvalf(np,xyzh,ddustevol(j,:),ddustevol_func,4.e-5,nfailed(m+1),'deps/dt',mask) + if (maxvxyzu>=4) call checkvalf(np,xyzh,fxyzu(iu,:),dudtdust_func,1.e-3,nfailed(m+2),'du/dt',mask) + call checkvalf(np,xyzh,deltav(1,j,:),deltavx_func,1.01e-3,nfailed(m+3),'deltavx',mask) enddo call update_test_scores(ntests,nfailed,npass) @@ -558,10 +546,8 @@ subroutine test_derivs(ntests,npass,string) ! testmhd: if (testmhdderivs .or. testall) then if (.not.testall) call get_derivs_global() ! obtain smoothing lengths -#ifdef IND_TIMESTEPS - do itest=nint(log10(real(nptot))),0,-2 - nactive = 10**itest -#endif + do itest=nstart,nend,nstep + if (ind_timesteps) nactive = 10**itest polyk = 0. call reset_mhd_to_zero call reset_dissipation_to_zero @@ -580,36 +566,36 @@ subroutine test_derivs(ntests,npass,string) enddo call set_active(npart,nactive/nprocs,igas) call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) + ! !--check that various quantities come out as they should do ! nfailed(:) = 0 - call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)') + call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)',mask) - call checkvalf(np,xyzh,divBsymm(:),divBfunc,2.e-3,nfailed(2),'divB (symm)') - call checkvalf(np,xyzh,dBevol(1,:),dBxdt,2.e-3,nfailed(3),'dBx/dt') - call checkvalf(np,xyzh,dBevol(2,:),dBydt,2.e-3,nfailed(4),'dBy/dt') - call checkvalf(np,xyzh,dBevol(3,:),dBzdt,2.e-2,nfailed(5),'dBz/dt') + call checkvalf(np,xyzh,divBsymm(:),divBfunc,2.e-3,nfailed(2),'divB (symm)',mask) + call checkvalf(np,xyzh,dBevol(1,:),dBxdt,2.e-3,nfailed(3),'dBx/dt',mask) + call checkvalf(np,xyzh,dBevol(2,:),dBydt,2.e-3,nfailed(4),'dBy/dt',mask) + call checkvalf(np,xyzh,dBevol(3,:),dBzdt,2.e-2,nfailed(5),'dBz/dt',mask) - call checkvalf(np,xyzh,fxyzu(1,:),forcemhdx,2.5e-2,nfailed(9),'mhd force(x)') - call checkvalf(np,xyzh,fxyzu(2,:),forcemhdy,2.5e-2,nfailed(10),'mhd force(y)') - call checkvalf(np,xyzh,fxyzu(3,:),forcemhdz,2.5e-2,nfailed(11),'mhd force(z)') + call checkvalf(np,xyzh,fxyzu(1,:),forcemhdx,2.5e-2,nfailed(9),'mhd force(x)',mask) + call checkvalf(np,xyzh,fxyzu(2,:),forcemhdy,2.5e-2,nfailed(10),'mhd force(y)',mask) + call checkvalf(np,xyzh,fxyzu(3,:),forcemhdz,2.5e-2,nfailed(11),'mhd force(z)',mask) if (ndivcurlB >= 1) then - call checkvalf(np,xyzh,divcurlB(idivB,:),divBfunc,1.e-3,nfailed(12),'div B (diff)') + call checkvalf(np,xyzh,divcurlB(idivB,:),divBfunc,1.e-3,nfailed(12),'div B (diff)',mask) endif if (ndivcurlB >= 4) then - call checkvalf(np,xyzh,divcurlB(icurlBx,:),curlBfuncx,1.e-3,nfailed(13),'curlB(x)') - call checkvalf(np,xyzh,divcurlB(icurlBy,:),curlBfuncy,1.e-3,nfailed(14),'curlB(y)') - call checkvalf(np,xyzh,divcurlB(icurlBz,:),curlBfuncz,1.e-3,nfailed(15),'curlB(z)') + call checkvalf(np,xyzh,divcurlB(icurlBx,:),curlBfuncx,1.e-3,nfailed(13),'curlB(x)',mask) + call checkvalf(np,xyzh,divcurlB(icurlBy,:),curlBfuncy,1.e-3,nfailed(14),'curlB(y)',mask) + call checkvalf(np,xyzh,divcurlB(icurlBz,:),curlBfuncz,1.e-3,nfailed(15),'curlB(z)',mask) endif call update_test_scores(ntests,nfailed,npass) endif -#ifdef IND_TIMESTEPS - call reset_allactive() + if (ind_timesteps) call reset_allactive() enddo - do itest=nint(log10(real(nptot))),0,-2 - nactive = 10**itest -#endif + do itest=nstart,nend,nstep + if (ind_timesteps) nactive = 10**itest if (mhd) then if (id==master) then write(*,"(/,a)") '--> testing artificial resistivity terms' @@ -628,7 +614,7 @@ subroutine test_derivs(ntests,npass,string) enddo call set_active(npart,nactive,igas) call get_derivs_global() - call rcut_checkmask(rcut,xyzh,npart,checkmask) + call rcut_mask(rcut,xyzh,npart,mask) ! !--check that various quantities come out as they should do ! @@ -637,9 +623,9 @@ subroutine test_derivs(ntests,npass,string) !--resistivity test is very approximate ! To do a proper test, multiply by h/rij in densityforce ! - call checkvalf(np,xyzh,dBevol(1,:),dBxdtresist,3.7e-2,nfailed(1),'dBx/dt (resist)',checkmask) - call checkvalf(np,xyzh,dBevol(2,:),dBydtresist,3.4e-2,nfailed(2),'dBy/dt (resist)',checkmask) - call checkvalf(np,xyzh,dBevol(3,:),dBzdtresist,2.2e-1,nfailed(3),'dBz/dt (resist)',checkmask) + call checkvalf(np,xyzh,dBevol(1,:),dBxdtresist,3.7e-2,nfailed(1),'dBx/dt (resist)',mask) + call checkvalf(np,xyzh,dBevol(2,:),dBydtresist,3.4e-2,nfailed(2),'dBy/dt (resist)',mask) + call checkvalf(np,xyzh,dBevol(3,:),dBzdtresist,2.2e-1,nfailed(3),'dBz/dt (resist)',mask) call update_test_scores(ntests,nfailed,npass) ! !--check that \sum m (du/dt + B/rho.dB/dt) = 0. @@ -663,14 +649,14 @@ subroutine test_derivs(ntests,npass,string) ieos = ieosprev endif -#ifdef IND_TIMESTEPS - call reset_allactive() + if (ind_timesteps) call reset_allactive() enddo - tolh_old = tolh - tolh = 1.e-7 - do itest=nint(log10(real(nptot))),0,-2 - nactive = 10**itest -#endif + if (ind_timesteps) then + tolh_old = tolh + tolh = 1.e-7 + endif + do itest=nstart,nend,nstep + if (ind_timesteps) nactive = 10**itest if (mhd) then if (id==master) then write(*,"(/,a)") '--> testing div B cleaning terms' @@ -686,15 +672,17 @@ subroutine test_derivs(ntests,npass,string) call set_magnetic_field call set_active(npart,nactive,igas) call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) + ! !--check that various quantities come out as they should do ! nfailed(:) = 0 - call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)') - call checkvalf(np,xyzh,divBsymm(:),divBfunc,1.e-3,nfailed(2),'divB') - call checkvalf(np,xyzh,dBevol(1,:),dpsidx,8.5e-4,nfailed(3),'gradpsi_x') - call checkvalf(np,xyzh,dBevol(2,:),dpsidy,9.3e-4,nfailed(4),'gradpsi_y') - call checkvalf(np,xyzh,dBevol(3,:),dpsidz,2.e-3,nfailed(5),'gradpsi_z') + call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)',mask) + call checkvalf(np,xyzh,divBsymm(:),divBfunc,1.e-3,nfailed(2),'divB',mask) + call checkvalf(np,xyzh,dBevol(1,:),dpsidx,8.5e-4,nfailed(3),'gradpsi_x',mask) + call checkvalf(np,xyzh,dBevol(2,:),dpsidy,9.3e-4,nfailed(4),'gradpsi_y',mask) + call checkvalf(np,xyzh,dBevol(3,:),dpsidz,2.e-3,nfailed(5),'gradpsi_z',mask) !--can't do dpsi/dt check because we use vsigdtc = max over neighbours !call checkvalf(np,xyzh,dBevol(4,:),dpsidt,6.e-3,nfailed(6),'dpsi/dt') call update_test_scores(ntests,nfailed,npass) @@ -702,13 +690,11 @@ subroutine test_derivs(ntests,npass,string) !--restore ieos ieos = ieosprev endif -#ifdef IND_TIMESTEPS - call reset_allactive() + if (ind_timesteps) call reset_allactive() enddo tolh = tolh_old - do itest=nint(log10(real(nptot))),0,-2 - nactive = 10**itest -#endif + do itest=nstart,nend,nstep + if (ind_timesteps) nactive = 10**itest if (mhd .and. use_ambi .and. testambipolar) then if (id==master) then write(*,"(/,a)") '--> testing Ambipolar diffusion terms' @@ -727,24 +713,22 @@ subroutine test_derivs(ntests,npass,string) enddo call set_active(npart,nactive,igas) call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) ! !--check that various quantities come out as they should do ! nfailed(:) = 0 - call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)') - call checkvalf(np,xyzh,dBevol(1,:),dBambix,8.5e-4,nfailed(2),'dBambi_x') - call checkvalf(np,xyzh,dBevol(2,:),dBambiy,8.5e-4,nfailed(3),'dBambi_y') - call checkvalf(np,xyzh,dBevol(3,:),dBambiz,2.e-3,nfailed(4),'dBambi_z') + call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)',mask) + call checkvalf(np,xyzh,dBevol(1,:),dBambix,8.5e-4,nfailed(2),'dBambi_x',mask) + call checkvalf(np,xyzh,dBevol(2,:),dBambiy,8.5e-4,nfailed(3),'dBambi_y',mask) + call checkvalf(np,xyzh,dBevol(3,:),dBambiz,2.e-3,nfailed(4),'dBambi_z',mask) call update_test_scores(ntests,nfailed,npass) !--restore ieos ieos = ieosprev endif - -#ifdef IND_TIMESTEPS - call reset_allactive() + if (ind_timesteps) call reset_allactive() enddo -#endif endif testmhd @@ -813,8 +797,7 @@ subroutine test_derivs(ntests,npass,string) ! !--also check that the number of neighbours is correct ! -#ifdef PERIODIC - if (id==master .and. index(kernelname,'cubic') > 0) then + if (id==master .and. periodic .and. index(kernelname,'cubic') > 0) then call get_neighbour_stats(trialmean,actualmean,maxtrial,maxactual,nrhocalc,nactual) realneigh = 57.466651861721814 call checkval(actualmean,realneigh,1.e-17,nfailed(m+1),'mean nneigh') @@ -827,48 +810,46 @@ subroutine test_derivs(ntests,npass,string) nexact = 37263216 call checkval(nactual,nexact,0,nfailed(m+3),'total nneigh') endif -#endif call update_test_scores(ntests,nfailed,npass) -#ifdef IND_TIMESTEPS - tallactive = tused - do itest=1,nint(log10(real(nparttest))) - nactive = 10**itest - if (nactive > nparttest) nactive = nparttest - if (id==master) write(*,"(/,a,i6,a)") '--> testing Hydro derivs in setup with density contrast (nactive=',nactive,') ' + if (ind_timesteps) then + tallactive = tused + do itest=1,nint(log10(real(nparttest))) + nactive = 10**itest + if (nactive > nparttest) nactive = nparttest + if (id==master) write(*,"(/,a,i6,a)") '--> testing Hydro derivs in setup with density contrast (nactive=',nactive,') ' - call set_active(npart,nactive,igas) - call get_derivs_global(tused) - if (id==master) then - fracactive = nactive/real(npart) - speedup = tused/tallactive - write(*,"(1x,'(',3(a,f9.5,'%'),')')") & + call set_active(npart,nactive,igas) + call get_derivs_global(tused) + if (id==master) then + fracactive = nactive/real(npart) + speedup = tused/tallactive + write(*,"(1x,'(',3(a,f9.5,'%'),')')") & 'moved ',100.*fracactive,' of particles in ',100.*speedup, & ' of time, efficiency = ',100.*fracactive/speedup - endif - ! - !--check hydro quantities come out as they should do - ! - nfailed(:) = 0; m=5 - call checkval(nparttest,xyzh(4,:),hblob,4.e-4,nfailed(1),'h (density)') - call checkvalf(nparttest,xyzh,divcurlv(idivv,:),divvfunc,1.e-3,nfailed(2),'divv') - if (ndivcurlv >= 4) then - call checkvalf(nparttest,xyzh,divcurlv(icurlvxi,:),curlvfuncx,1.5e-3,nfailed(3),'curlv(x)') - call checkvalf(nparttest,xyzh,divcurlv(icurlvyi,:),curlvfuncy,1.e-3,nfailed(4),'curlv(y)') - call checkvalf(nparttest,xyzh,divcurlv(icurlvzi,:),curlvfuncz,1.e-3,nfailed(5),'curlv(z)') - endif - if (maxvxyzu==4) call check_fxyzu_nomask(nparttest,nfailed,m) - call update_test_scores(ntests,nfailed,npass) - enddo -#endif + endif + ! + !--check hydro quantities come out as they should do + ! + nfailed(:) = 0; m=5 + call checkval(nparttest,xyzh(4,:),hblob,4.e-4,nfailed(1),'h (density)') + call checkvalf(nparttest,xyzh,divcurlv(idivv,:),divvfunc,1.e-3,nfailed(2),'divv') + if (ndivcurlv >= 4) then + call checkvalf(nparttest,xyzh,divcurlv(icurlvxi,:),curlvfuncx,1.5e-3,nfailed(3),'curlv(x)') + call checkvalf(nparttest,xyzh,divcurlv(icurlvyi,:),curlvfuncy,1.e-3,nfailed(4),'curlv(y)') + call checkvalf(nparttest,xyzh,divcurlv(icurlvzi,:),curlvfuncz,1.e-3,nfailed(5),'curlv(z)') + endif + if (maxvxyzu==4) call check_fxyzu_nomask(nparttest,nfailed,m) + call update_test_scores(ntests,nfailed,npass) + enddo + endif endif testdenscontrast ! !--test force evaluation for individual timesteps when particles have very different smoothing lengths/ranges ! - testinddts: if (testindtimesteps .or. testall) then -#ifdef IND_TIMESTEPS + testinddts: if (ind_timesteps .and. (testindtimesteps .or. testall)) then if (id==master) write(*,"(/,a,i6,a)") '--> testing force evaluation with ind_timesteps' polyk = 0. tolh = 1.e-9 @@ -945,14 +926,12 @@ subroutine test_derivs(ntests,npass,string) endif if (allocated(fxyzstore)) deallocate(fxyzstore) if (allocated(dBdtstore)) deallocate(dBdtstore) -#endif endif testinddts if (id==master) write(*,"(/,a)") '<-- DERIVS TEST COMPLETE' contains -#ifdef IND_TIMESTEPS subroutine reset_allactive ! !--reset all particles to active for subsequent tests @@ -963,22 +942,21 @@ subroutine reset_allactive nactive = npart end subroutine reset_allactive -#endif subroutine set_active(npart,nactive,itype) integer, intent(in) :: npart, nactive, itype ! ! set iphase for mixed active/inactive ! -#ifdef IND_TIMESTEPS - do i=1,npart - if (i <= nactive) then - iphase(i) = isetphase(itype,iactive=.true.) - else - iphase(i) = isetphase(itype,iactive=.false.) - endif - enddo -#endif + if (ind_timesteps) then + do i=1,npart + if (i <= nactive) then + iphase(i) = isetphase(itype,iactive=.true.) + else + iphase(i) = isetphase(itype,iactive=.false.) + endif + enddo + endif end subroutine set_active !-------------------------------------- @@ -1090,14 +1068,14 @@ subroutine check_hydro(n,nfailed,j) integer, intent(in) :: n integer, intent(inout) :: nfailed(:),j - call checkval(n,xyzh(4,1:np),hzero,3.e-4,nfailed(j+1),'h (density)',checkmask) - call checkvalf(n,xyzh,divcurlv(1,1:np),divvfunc,1.e-3,nfailed(j+2),'divv',checkmask) + call checkval(n,xyzh(4,1:np),hzero,3.e-4,nfailed(j+1),'h (density)',mask) + call checkvalf(n,xyzh,divcurlv(1,1:np),divvfunc,1.e-3,nfailed(j+2),'divv',mask) if (ndivcurlv >= 4) then - call checkvalf(n,xyzh,divcurlv(icurlvxi,1:np),curlvfuncx,1.5e-3,nfailed(j+3),'curlv(x)',checkmask) - call checkvalf(n,xyzh,divcurlv(icurlvyi,1:n),curlvfuncy,1.e-3,nfailed(j+4),'curlv(y)',checkmask) - call checkvalf(n,xyzh,divcurlv(icurlvzi,1:n),curlvfuncz,1.e-3,nfailed(j+5),'curlv(z)',checkmask) + call checkvalf(n,xyzh,divcurlv(icurlvxi,1:np),curlvfuncx,1.5e-3,nfailed(j+3),'curlv(x)',mask) + call checkvalf(n,xyzh,divcurlv(icurlvyi,1:n),curlvfuncy,1.e-3,nfailed(j+4),'curlv(y)',mask) + call checkvalf(n,xyzh,divcurlv(icurlvzi,1:n),curlvfuncz,1.e-3,nfailed(j+5),'curlv(z)',mask) endif - if (testgradh) call checkval(n,gradh(1,1:n),1.01948,1.e-5,nfailed(j+6),'gradh',checkmask) + if (testgradh) call checkval(n,gradh(1,1:n),1.01948,1.e-5,nfailed(j+6),'gradh',mask) j = j + 6 end subroutine check_hydro @@ -1112,15 +1090,15 @@ subroutine check_fxyzu(n,nfailed,j) integer, intent(in) :: n integer, intent(inout) :: nfailed(:),j - call checkvalf(n,xyzh,fxyzu(1,:),forcefuncx,1.e-3,nfailed(j+1),'force(x)',checkmask) - call checkvalf(n,xyzh,fxyzu(2,:),forcefuncy,1.e-3,nfailed(j+2),'force(y)',checkmask) - call checkvalf(n,xyzh,fxyzu(3,:),forcefuncz,1.e-3,nfailed(j+3),'force(z)',checkmask) + call checkvalf(n,xyzh,fxyzu(1,:),forcefuncx,1.e-3,nfailed(j+1),'force(x)',mask) + call checkvalf(n,xyzh,fxyzu(2,:),forcefuncy,1.e-3,nfailed(j+2),'force(y)',mask) + call checkvalf(n,xyzh,fxyzu(3,:),forcefuncz,1.e-3,nfailed(j+3),'force(z)',mask) if (ien_type == ien_entropy .or. ieos /= 2) then - call checkval(n,fxyzu(iu,:),0.,epsilon(fxyzu),nfailed(j+4),'den/dt',checkmask) + call checkval(n,fxyzu(iu,:),0.,epsilon(fxyzu),nfailed(j+4),'den/dt',mask) else allocate(dummy(n)) dummy(1:n) = fxyzu(iu,1:n)/((gamma-1.)*vxyzu(iu,1:n)) - call checkvalf(np,xyzh,dummy(1:n),dudtfunc,1.e-3,nfailed(j+4),'du/dt',checkmask) + call checkvalf(np,xyzh,dummy(1:n),dudtfunc,1.e-3,nfailed(j+4),'du/dt',mask) deallocate(dummy) endif j = j + 4 @@ -2499,19 +2477,14 @@ end function del2dustfrac real function ddustevol_func(xyzhi) use eos, only:gamma - use part, only:ndusttypes -#ifdef DUST + use part, only:use_dust,ndusttypes,rhoh use dust, only:get_ts,idrag,K_code -#endif - use part, only:rhoh real, intent(in) :: xyzhi(4) real :: dustfraci,uui,pri,tsi real :: gradu(3),gradeps(3),gradsumeps(3),gradp(3),gradts(3),gradepsts(3) real :: rhoi,rhogasi,rhodusti,spsoundi,del2P,du_dot_de,si real :: dustfracisum,del2dustfracsum -#ifdef DUST integer :: iregime -#endif rhoi = rhoh(xyzhi(4),massoftype(1)) dustfraci = dustfrac_func(xyzhi) @@ -2535,16 +2508,16 @@ real function ddustevol_func(xyzhi) del2P = (gamma-1.)*rhoi*((1. - dustfracisum)*del2u(xyzhi) - 2.*du_dot_de - uui*del2dustfracsum) tsi = 0. -#ifdef DUST - call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) - ! - ! grad(ts) = grad((1-eps)*eps*rho/K_code) - ! = rho/K_code*(1-2*eps)*grad(eps) ! note the absence of eps_k - ! - gradts(:) = rhoi/K_code(1)*(1. - 2.*dustfracisum)*gradsumeps(:) -#else - gradts(:) = 0. -#endif + if (use_dust) then + call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) + ! + ! grad(ts) = grad((1-eps)*eps*rho/K_code) + ! = rho/K_code*(1-2*eps)*grad(eps) ! note the absence of eps_k + ! + gradts(:) = rhoi/K_code(1)*(1. - 2.*dustfracisum)*gradsumeps(:) + else + gradts(:) = 0. + endif ! ! deps_k/dt = -1/rho \nabla.(eps_k ts (grad P)) ! note the presence of eps_k ! = -1/rho [eps_k ts \del^2 P + grad(eps_k ts).grad P] @@ -2572,19 +2545,14 @@ end function ddustevol_func real function dudtdust_func(xyzhi) use eos, only:gamma - use part, only:ndusttypes -#ifdef DUST + use part, only:use_dust,ndusttypes,rhoh use dust, only:get_ts,idrag -#endif - use part, only:rhoh real, intent(in) :: xyzhi(4) real :: dustfraci,uui,pri,tsi real :: gradp(3),gradu(3),gradeps(3),gradsumeps(3) real :: rhoi,rhogasi,rhodusti,spsoundi real :: dustfracisum -#ifdef DUST integer :: iregime -#endif rhoi = rhoh(xyzhi(4),massoftype(1)) dustfraci = dustfrac_func(xyzhi) @@ -2604,10 +2572,10 @@ real function dudtdust_func(xyzhi) gradp(:) = (gamma-1.)*(rhogasi*gradu - rhoi*uui*gradsumeps) tsi = 0. -#ifdef DUST - call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) - if (iregime /= 0) stop 'iregime /= 0' -#endif + if (use_dust) then + call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) + if (iregime /= 0) stop 'iregime /= 0' + endif ! this is equation (13) of Price & Laibe (2015) except ! that the sign on the second term is wrong in that paper ! (it is correct in Laibe & Price 2014a,b) @@ -2618,17 +2586,13 @@ end function dudtdust_func real function deltavx_func(xyzhi) use eos, only:gamma - use part, only:ndusttypes -#ifdef DUST + use part, only:ndusttypes,use_dust use dust, only:get_ts,idrag -#endif use part, only:rhoh real, intent(in) :: xyzhi(4) real :: rhoi,dustfraci,rhogasi,rhodusti,uui,pri,spsoundi,tsi,gradp real :: dustfracisum,gradsumeps,gradu -#ifdef DUST integer :: iregime -#endif rhoi = rhoh(xyzhi(4),massoftype(1)) dustfraci = dustfrac_func(xyzhi) @@ -2641,26 +2605,24 @@ real function deltavx_func(xyzhi) pri = (gamma-1.)*rhogasi*uui spsoundi = gamma*pri/rhogasi tsi = 0. -#ifdef DUST - call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) -#endif + if (use_dust) call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) gradp = (gamma-1.)*(rhogasi*gradu - rhoi*uui*gradsumeps) deltavx_func = tsi*gradp/rhogasi end function deltavx_func -subroutine rcut_checkmask(rcut,xyzh,npart,checkmask) +subroutine rcut_mask(rcut,xyzh,npart,mask) use part, only:isdead_or_accreted real, intent(in) :: rcut real, intent(in) :: xyzh(:,:) integer, intent(in) :: npart - logical, intent(out) :: checkmask(:) + logical, intent(out) :: mask(:) real :: rcut2,xi,yi,zi,hi,r2 integer :: i,ncheck ncheck = 0 rcut2 = rcut*rcut - checkmask(:) = .false. + mask(:) = .false. do i=1,npart xi = xyzh(1,i) yi = xyzh(2,i) @@ -2668,11 +2630,11 @@ subroutine rcut_checkmask(rcut,xyzh,npart,checkmask) hi = xyzh(4,i) r2 = xi*xi + yi*yi + zi*zi if (.not.isdead_or_accreted(hi) .and. r2 < rcut2) then - checkmask(i) = .true. + mask(i) = .true. ncheck = ncheck + 1 endif enddo -end subroutine rcut_checkmask +end subroutine rcut_mask end module testderivs From bacaad6413ede16e341562cfa7f08adc14a9a4b4 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 18 Apr 2024 21:28:18 +1000 Subject: [PATCH 442/814] (test_derivs) fix bug if compiled with ISOTHERMAL=yes --- src/tests/test_derivs.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/tests/test_derivs.F90 b/src/tests/test_derivs.F90 index 8f69b00ab..2510be0c2 100644 --- a/src/tests/test_derivs.F90 +++ b/src/tests/test_derivs.F90 @@ -188,6 +188,7 @@ subroutine test_derivs(ntests,npass,string) if (id==master) write(*,"(/,a)") '--> testing Hydro derivatives ' call set_velocity_and_energy call reset_mhd_to_zero + if (maxvxyzu < 4) polyk = 3. ! !--calculate derivatives ! @@ -216,8 +217,6 @@ subroutine test_derivs(ntests,npass,string) ! !--check that the timestep bin has been set ! - - print*,' COUNT=',count(ibin(1:npart) > 0) if (ind_timesteps) call checkval(all(ibin(1:npart) > 0),.true.,nfailed(15),'ibin > 0') call update_test_scores(ntests,nfailed,npass) From 881bafe74ff4db1dba3700402517fc543a40c348 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 18 Apr 2024 14:03:41 +0200 Subject: [PATCH 443/814] (moddump_sink) add option to delete sink --- src/utils/moddump_sink.f90 | 68 ++++++++++++++++++++++---------------- 1 file changed, 40 insertions(+), 28 deletions(-) diff --git a/src/utils/moddump_sink.f90 b/src/utils/moddump_sink.f90 index 444a45e22..ae4e3b4e6 100644 --- a/src/utils/moddump_sink.f90 +++ b/src/utils/moddump_sink.f90 @@ -30,7 +30,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) real, intent(inout) :: xyzh(:,:),vxyzu(:,:),massoftype(:) integer :: i,isinkpart real :: racc,hsoft,mass,mass_old,newx,Lnuc_cgs - logical :: iresetCM + logical :: reset_CM,delete_sink print*,'Sink particles in dump:' do i=1,nptmass @@ -54,39 +54,51 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call prompt('Enter the sink particle number to modify (0 to exit):',isinkpart,0,nptmass) if (isinkpart <= 0) exit - mass = xyzmh_ptmass(4,isinkpart) - mass_old = mass - call prompt('Enter new mass for the sink:',mass,0.) - print*,'Mass changed to ',mass - xyzmh_ptmass(4,isinkpart) = mass + call prompt('Delete sink?',delete_sink,.false.) + if (delete_sink) then + if (isinkpart==nptmass) then + xyzmh_ptmass(:,isinkpart) = 0. + vxyz_ptmass(:,isinkpart) = 0. + else + xyzmh_ptmass(:,isinkpart:nptmass-1) = xyzmh_ptmass(:,isinkpart+1:nptmass) + vxyz_ptmass(:,isinkpart:nptmass-1) = vxyz_ptmass(:,isinkpart+1:nptmass) + endif + nptmass = nptmass - 1 + else + mass = xyzmh_ptmass(4,isinkpart) + mass_old = mass + call prompt('Enter new mass for the sink:',mass,0.) + print*,'Mass changed to ',mass + xyzmh_ptmass(4,isinkpart) = mass - racc = xyzmh_ptmass(ihacc,isinkpart) - ! rescaling accretion radius for updated mass - racc = racc * (mass/mass_old)**(1./3) - call prompt('Enter new accretion radius for the sink:',racc,0.) - print*,'Accretion radius changed to ',racc - xyzmh_ptmass(ihacc,isinkpart) = racc + racc = xyzmh_ptmass(ihacc,isinkpart) + ! rescaling accretion radius for updated mass + racc = racc * (mass/mass_old)**(1./3) + call prompt('Enter new accretion radius for the sink:',racc,0.) + print*,'Accretion radius changed to ',racc + xyzmh_ptmass(ihacc,isinkpart) = racc - hsoft = xyzmh_ptmass(ihsoft,isinkpart) - call prompt('Enter new softening length for the sink:',hsoft,0.) - print*,'Softening length changed to ',hsoft - xyzmh_ptmass(ihsoft,isinkpart) = hsoft + hsoft = xyzmh_ptmass(ihsoft,isinkpart) + call prompt('Enter new softening length for the sink:',hsoft,0.) + print*,'Softening length changed to ',hsoft + xyzmh_ptmass(ihsoft,isinkpart) = hsoft - newx = xyzmh_ptmass(1,isinkpart) - call prompt('Enter new x-coordinate for the sink in code units:',newx,0.) - xyzmh_ptmass(1,isinkpart) = newx - print*,'x-coordinate changed to ',xyzmh_ptmass(1,isinkpart) + newx = xyzmh_ptmass(1,isinkpart) + call prompt('Enter new x-coordinate for the sink in code units:',newx,0.) + xyzmh_ptmass(1,isinkpart) = newx + print*,'x-coordinate changed to ',xyzmh_ptmass(1,isinkpart) - Lnuc = xyzmh_ptmass(ilum,isinkpart) - Lnuc_cgs = Lnuc * unit_energ / utime - call prompt('Enter new sink heating luminosity in erg/s:',Lnuc_cgs,0.) - xyzmh_ptmass(ilum,isinkpart) = Lnuc_cgs / unit_energ * utime - print*,'Luminosity [erg/s] changed to ',xyzmh_ptmass(ilum,isinkpart) * unit_energ / utime + Lnuc = xyzmh_ptmass(ilum,isinkpart) + Lnuc_cgs = Lnuc * unit_energ / utime + call prompt('Enter new sink heating luminosity in erg/s:',Lnuc_cgs,0.) + xyzmh_ptmass(ilum,isinkpart) = Lnuc_cgs / unit_energ * utime + print*,'Luminosity [erg/s] changed to ',xyzmh_ptmass(ilum,isinkpart) * unit_energ / utime + endif enddo - iresetCM = .false. - call prompt('Reset centre of mass?',iresetCM) - if (iresetCM) call reset_centreofmass(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) + reset_CM = .false. + call prompt('Reset centre of mass?',reset_CM) + if (reset_CM) call reset_centreofmass(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) return end subroutine modify_dump From d273c5f764b431acb99c71ef763057b0364a20ca Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 18 Apr 2024 14:16:17 +0200 Subject: [PATCH 444/814] (moddump-sink) increase precision of sink info printing --- src/utils/moddump_sink.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/moddump_sink.f90 b/src/utils/moddump_sink.f90 index ae4e3b4e6..01c4c3506 100644 --- a/src/utils/moddump_sink.f90 +++ b/src/utils/moddump_sink.f90 @@ -35,7 +35,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) print*,'Sink particles in dump:' do i=1,nptmass print "(a,1x,i4,a)",'Sink',i,':' - print "(7(a5,1x,a,1x,f13.7,/))",& + print "(7(a5,1x,a,1x,es24.16e3,/))",& 'x','=',xyzmh_ptmass(1,i),& 'y','=',xyzmh_ptmass(2,i),& 'z','=',xyzmh_ptmass(3,i),& From fc8662538db1bd8fd397995bdc5c6b959f953e00 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 19 Apr 2024 09:39:02 +1000 Subject: [PATCH 445/814] (test_derivs) test failure fixed; further minor cleanups --- src/tests/test_derivs.F90 | 268 ++++++++++++++++++-------------------- 1 file changed, 129 insertions(+), 139 deletions(-) diff --git a/src/tests/test_derivs.F90 b/src/tests/test_derivs.F90 index 2510be0c2..271f8ccec 100644 --- a/src/tests/test_derivs.F90 +++ b/src/tests/test_derivs.F90 @@ -185,7 +185,7 @@ subroutine test_derivs(ntests,npass,string) !--calculate pure hydro derivatives with velocity and ! pressure distributions (no viscosity) ! - if (id==master) write(*,"(/,a)") '--> testing Hydro derivatives ' + if (id==master) write(*,"(/,a)") '--> testing Hydro derivatives (derivshydro)' call set_velocity_and_energy call reset_mhd_to_zero if (maxvxyzu < 4) polyk = 3. @@ -284,12 +284,12 @@ subroutine test_derivs(ntests,npass,string) ! if (id==master) then #ifdef DISC_VISCOSITY - write(*,"(/,a)") '--> testing artificial viscosity terms (disc viscosity)' + write(*,"(/,a)") '--> testing artificial viscosity terms w/disc viscosity (derivsav)' #else if (maxalpha==maxp) then - write(*,"(/,a)") '--> testing artificial viscosity terms (individual alpha)' + write(*,"(/,a)") '--> testing artificial viscosity terms w/individual alpha (derivsav)' else - write(*,"(/,a)") '--> testing artificial viscosity terms (constant alpha)' + write(*,"(/,a)") '--> testing artificial viscosity terms w/constant alpha (derivsav)' endif #endif if (nactive /= npart) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' @@ -323,7 +323,7 @@ subroutine test_derivs(ntests,npass,string) ! testcdswitch: if (testcullendehnen .or. testall) then if (maxalpha==maxp .and. nalpha > 1) then - if (id==master) write(*,"(/,a)") '--> testing ddivv/dt in Cullen & Dehnen switch' + if (id==master) write(*,"(/,a)") '--> testing ddivv/dt in Cullen & Dehnen switch (derivscd)' call set_velocity_only do i=1,npart @@ -365,9 +365,9 @@ subroutine test_derivs(ntests,npass,string) ! if (id==master) then if (maxdvdx==maxp) then - write(*,"(/,a)") '--> testing physical viscosity terms (two first derivatives)' + write(*,"(/,a)") '--> testing physical viscosity terms w/two first derivatives (derivsvisc)' else - write(*,"(/,a)") '--> testing physical viscosity terms (direct second derivatives)' + write(*,"(/,a)") '--> testing physical viscosity terms w/direct second derivatives (derivsvisc)' endif endif polyk = 0. @@ -450,7 +450,7 @@ subroutine test_derivs(ntests,npass,string) ! if (use_dust) use_dustfrac=.true. if (use_dustfrac) then - if (id==master) write(*,"(/,a)") '--> testing dust evolution terms' + if (id==master) write(*,"(/,a)") '--> testing dust evolution terms (derivsdust)' if (use_dust) then idrag = 2 gamma = 5./3. @@ -543,160 +543,151 @@ subroutine test_derivs(ntests,npass,string) ! !--calculate derivatives with MHD forces ON, zero pressure ! - testmhd: if (testmhdderivs .or. testall) then + testmhd: if ((testmhdderivs .or. testall) .and. mhd) then if (.not.testall) call get_derivs_global() ! obtain smoothing lengths do itest=nstart,nend,nstep if (ind_timesteps) nactive = 10**itest polyk = 0. call reset_mhd_to_zero call reset_dissipation_to_zero - if (mhd) then - if (id==master) then - write(*,"(/,a)") '--> testing MHD derivatives (using B/rho directly)' - if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' - endif - Bextx = 2.0e-1 - Bexty = 3.0e-1 - Bextz = 0.5 - call set_velocity_only - call set_magnetic_field - do i=1,npart - Bevol(4,i) = 0. - enddo - call set_active(npart,nactive/nprocs,igas) - call get_derivs_global() - call rcut_mask(rcut,xyzh,npart,mask) - - ! - !--check that various quantities come out as they should do - ! - nfailed(:) = 0 - call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)',mask) - - call checkvalf(np,xyzh,divBsymm(:),divBfunc,2.e-3,nfailed(2),'divB (symm)',mask) - call checkvalf(np,xyzh,dBevol(1,:),dBxdt,2.e-3,nfailed(3),'dBx/dt',mask) - call checkvalf(np,xyzh,dBevol(2,:),dBydt,2.e-3,nfailed(4),'dBy/dt',mask) - call checkvalf(np,xyzh,dBevol(3,:),dBzdt,2.e-2,nfailed(5),'dBz/dt',mask) + if (id==master) then + write(*,"(/,a)") '--> testing MHD derivatives (derivsmhd)' + if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' + endif + Bextx = 2.0e-1 + Bexty = 3.0e-1 + Bextz = 0.5 + call set_velocity_only + call set_magnetic_field + do i=1,npart + Bevol(4,i) = 0. + enddo + call set_active(npart,nactive/nprocs,igas) + call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) - call checkvalf(np,xyzh,fxyzu(1,:),forcemhdx,2.5e-2,nfailed(9),'mhd force(x)',mask) - call checkvalf(np,xyzh,fxyzu(2,:),forcemhdy,2.5e-2,nfailed(10),'mhd force(y)',mask) - call checkvalf(np,xyzh,fxyzu(3,:),forcemhdz,2.5e-2,nfailed(11),'mhd force(z)',mask) - if (ndivcurlB >= 1) then - call checkvalf(np,xyzh,divcurlB(idivB,:),divBfunc,1.e-3,nfailed(12),'div B (diff)',mask) - endif - if (ndivcurlB >= 4) then - call checkvalf(np,xyzh,divcurlB(icurlBx,:),curlBfuncx,1.e-3,nfailed(13),'curlB(x)',mask) - call checkvalf(np,xyzh,divcurlB(icurlBy,:),curlBfuncy,1.e-3,nfailed(14),'curlB(y)',mask) - call checkvalf(np,xyzh,divcurlB(icurlBz,:),curlBfuncz,1.e-3,nfailed(15),'curlB(z)',mask) - endif - call update_test_scores(ntests,nfailed,npass) + ! + !--check that various quantities come out as they should do + ! + nfailed(:) = 0 + call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)',mask) + + call checkvalf(np,xyzh,divBsymm(:),divBfunc,2.e-3,nfailed(2),'divB (symm)',mask) + call checkvalf(np,xyzh,dBevol(1,:),dBxdt,2.e-3,nfailed(3),'dBx/dt',mask) + call checkvalf(np,xyzh,dBevol(2,:),dBydt,2.e-3,nfailed(4),'dBy/dt',mask) + call checkvalf(np,xyzh,dBevol(3,:),dBzdt,2.e-2,nfailed(5),'dBz/dt',mask) + + call checkvalf(np,xyzh,fxyzu(1,:),forcemhdx,2.5e-2,nfailed(9),'mhd force(x)',mask) + call checkvalf(np,xyzh,fxyzu(2,:),forcemhdy,2.5e-2,nfailed(10),'mhd force(y)',mask) + call checkvalf(np,xyzh,fxyzu(3,:),forcemhdz,2.5e-2,nfailed(11),'mhd force(z)',mask) + if (ndivcurlB >= 1) then + call checkvalf(np,xyzh,divcurlB(idivB,:),divBfunc,1.e-3,nfailed(12),'div B (diff)',mask) + endif + if (ndivcurlB >= 4) then + call checkvalf(np,xyzh,divcurlB(icurlBx,:),curlBfuncx,1.e-3,nfailed(13),'curlB(x)',mask) + call checkvalf(np,xyzh,divcurlB(icurlBy,:),curlBfuncy,1.e-3,nfailed(14),'curlB(y)',mask) + call checkvalf(np,xyzh,divcurlB(icurlBz,:),curlBfuncz,1.e-3,nfailed(15),'curlB(z)',mask) endif + call update_test_scores(ntests,nfailed,npass) if (ind_timesteps) call reset_allactive() enddo do itest=nstart,nend,nstep if (ind_timesteps) nactive = 10**itest - if (mhd) then - if (id==master) then - write(*,"(/,a)") '--> testing artificial resistivity terms' - if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' - endif - call reset_mhd_to_zero - call reset_dissipation_to_zero - alphaB = 0.214 - polyk = 0. - ieosprev = ieos - ieos = 1 ! isothermal eos, so that the PdV term is zero - call set_magnetic_field + if (id==master) then + write(*,"(/,a)") '--> testing artificial resistivity terms (derivsmhd)' + if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' + endif + call reset_mhd_to_zero + call reset_dissipation_to_zero + alphaB = 0.214 + polyk = 0. + ieosprev = ieos + ieos = 1 ! isothermal eos, so that the PdV term is zero + call set_magnetic_field + do i=1,npart + vxyzu(:,i) = 0. ! v=0 for this test + Bevol(4,i) = 0. ! psi=0 for this test + enddo + call set_active(npart,nactive,igas) + call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) + ! + !--check that various quantities come out as they should do + ! + nfailed(:) = 0 + ! + !--resistivity test is very approximate + ! To do a proper test, multiply by h/rij in densityforce + ! + call checkvalf(np,xyzh,dBevol(1,:),dBxdtresist,3.7e-2,nfailed(1),'dBx/dt (resist)',mask) + call checkvalf(np,xyzh,dBevol(2,:),dBydtresist,3.4e-2,nfailed(2),'dBy/dt (resist)',mask) + call checkvalf(np,xyzh,dBevol(3,:),dBzdtresist,2.2e-1,nfailed(3),'dBz/dt (resist)',mask) + call update_test_scores(ntests,nfailed,npass) + ! + !--check that \sum m (du/dt + B/rho.dB/dt) = 0. + ! only applies if all particles active - with individual timesteps + ! we just hope that du/dt has not changed all that much on non-active particles + ! + if (maxvxyzu==4 .and. nactive==npart) then + deint = 0. + demag = 0. do i=1,npart - vxyzu(:,i) = 0. ! v=0 for this test - Bevol(4,i) = 0. ! psi=0 for this test + rho1i = 1./rhoh(xyzh(4,i),massoftype(1)) + deint = deint + fxyzu(iu,i) + demag = demag + dot_product(Bevol(1:3,i),dBevol(1:3,i))*rho1i enddo - call set_active(npart,nactive,igas) - call get_derivs_global() - call rcut_mask(rcut,xyzh,npart,mask) - ! - !--check that various quantities come out as they should do - ! nfailed(:) = 0 - ! - !--resistivity test is very approximate - ! To do a proper test, multiply by h/rij in densityforce - ! - call checkvalf(np,xyzh,dBevol(1,:),dBxdtresist,3.7e-2,nfailed(1),'dBx/dt (resist)',mask) - call checkvalf(np,xyzh,dBevol(2,:),dBydtresist,3.4e-2,nfailed(2),'dBy/dt (resist)',mask) - call checkvalf(np,xyzh,dBevol(3,:),dBzdtresist,2.2e-1,nfailed(3),'dBz/dt (resist)',mask) - call update_test_scores(ntests,nfailed,npass) - ! - !--check that \sum m (du/dt + B/rho.dB/dt) = 0. - ! only applies if all particles active - with individual timesteps - ! we just hope that du/dt has not changed all that much on non-active particles - ! - if (maxvxyzu==4 .and. nactive==npart) then - deint = 0. - demag = 0. - do i=1,npart - rho1i = 1./rhoh(xyzh(4,i),massoftype(1)) - deint = deint + fxyzu(iu,i) - demag = demag + dot_product(Bevol(1:3,i),dBevol(1:3,i))*rho1i - enddo - nfailed(:) = 0 - call checkval(deint + demag,0.,2.7e-3,nfailed(1),'\sum du/dt + B.dB/dt = 0') - call update_test_scores(ntests,nfailed(1:1),npass) - endif - - !--restore ieos - ieos = ieosprev - + call checkval(deint + demag,0.,2.7e-3,nfailed(1),'\sum du/dt + B.dB/dt = 0') + call update_test_scores(ntests,nfailed(1:1),npass) endif + + !--restore ieos + ieos = ieosprev if (ind_timesteps) call reset_allactive() enddo - if (ind_timesteps) then - tolh_old = tolh - tolh = 1.e-7 - endif + tolh_old = tolh + if (ind_timesteps) tolh = 1.e-7 do itest=nstart,nend,nstep if (ind_timesteps) nactive = 10**itest - if (mhd) then - if (id==master) then - write(*,"(/,a)") '--> testing div B cleaning terms' - if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' - endif - call reset_mhd_to_zero - call reset_dissipation_to_zero - psidecayfac = 0.8 - polyk = 2. - ieosprev = ieos - ieos = 1 ! isothermal eos - call set_velocity_only - call set_magnetic_field - call set_active(npart,nactive,igas) - call get_derivs_global() - call rcut_mask(rcut,xyzh,npart,mask) + if (id==master) then + write(*,"(/,a)") '--> testing div B cleaning terms (derivsmhd)' + if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' + endif + call reset_mhd_to_zero + call reset_dissipation_to_zero + psidecayfac = 0.8 + polyk = 2. + ieosprev = ieos + ieos = 1 ! isothermal eos + call set_velocity_only + call set_magnetic_field + call set_active(npart,nactive,igas) + call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) - ! - !--check that various quantities come out as they should do - ! - nfailed(:) = 0 - call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)',mask) - call checkvalf(np,xyzh,divBsymm(:),divBfunc,1.e-3,nfailed(2),'divB',mask) - call checkvalf(np,xyzh,dBevol(1,:),dpsidx,8.5e-4,nfailed(3),'gradpsi_x',mask) - call checkvalf(np,xyzh,dBevol(2,:),dpsidy,9.3e-4,nfailed(4),'gradpsi_y',mask) - call checkvalf(np,xyzh,dBevol(3,:),dpsidz,2.e-3,nfailed(5),'gradpsi_z',mask) - !--can't do dpsi/dt check because we use vsigdtc = max over neighbours - !call checkvalf(np,xyzh,dBevol(4,:),dpsidt,6.e-3,nfailed(6),'dpsi/dt') - call update_test_scores(ntests,nfailed,npass) + ! + !--check that various quantities come out as they should do + ! + nfailed(:) = 0 + call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)',mask) + call checkvalf(np,xyzh,divBsymm(:),divBfunc,1.e-3,nfailed(2),'divB',mask) + call checkvalf(np,xyzh,dBevol(1,:),dpsidx,8.5e-4,nfailed(3),'gradpsi_x',mask) + call checkvalf(np,xyzh,dBevol(2,:),dpsidy,9.3e-4,nfailed(4),'gradpsi_y',mask) + call checkvalf(np,xyzh,dBevol(3,:),dpsidz,2.e-3,nfailed(5),'gradpsi_z',mask) + !--can't do dpsi/dt check because we use vsigdtc = max over neighbours + !call checkvalf(np,xyzh,dBevol(4,:),dpsidt,6.e-3,nfailed(6),'dpsi/dt') + call update_test_scores(ntests,nfailed,npass) - !--restore ieos - ieos = ieosprev - endif + !--restore ieos + ieos = ieosprev if (ind_timesteps) call reset_allactive() enddo tolh = tolh_old do itest=nstart,nend,nstep if (ind_timesteps) nactive = 10**itest - if (mhd .and. use_ambi .and. testambipolar) then + if (use_ambi .and. testambipolar) then if (id==master) then - write(*,"(/,a)") '--> testing Ambipolar diffusion terms' + write(*,"(/,a)") '--> testing Ambipolar diffusion term (derivsambi)' if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' endif call reset_mhd_to_zero @@ -728,7 +719,8 @@ subroutine test_derivs(ntests,npass,string) endif if (ind_timesteps) call reset_allactive() enddo - + else + if (id==master) write(*,"(/,a)") '--> SKIPPING mhd terms (need -DMHD)' endif testmhd ! @@ -739,7 +731,7 @@ subroutine test_derivs(ntests,npass,string) ! and the 'test' particles cannot be identified using the current method ! testdenscontrast: if ((testdensitycontrast .or. testall) .and. (nprocs == 1)) then - if (id==master) write(*,"(/,a)") '--> testing Hydro derivs in setup with density contrast ' + if (id==master) write(*,"(/,a)") '--> testing Hydro derivs in setup with density contrast (derivscontrast)' npart = 0 psep = dxbound/50. @@ -804,8 +796,6 @@ subroutine test_derivs(ntests,npass,string) ! !-- this test does not always give the same results: depends on how the tree is built ! - ! nexact = 1382952 ! got this from a reference calculation - ! call checkval(nrhocalc,nexact,0,nfailed(12),'n density calcs') nexact = 37263216 call checkval(nactual,nexact,0,nfailed(m+3),'total nneigh') endif @@ -849,7 +839,7 @@ subroutine test_derivs(ntests,npass,string) !--test force evaluation for individual timesteps when particles have very different smoothing lengths/ranges ! testinddts: if (ind_timesteps .and. (testindtimesteps .or. testall)) then - if (id==master) write(*,"(/,a,i6,a)") '--> testing force evaluation with ind_timesteps' + if (id==master) write(*,"(/,a,i6,a)") '--> testing force evaluation with ind_timesteps (derivsind)' polyk = 0. tolh = 1.e-9 call reset_mhd_to_zero From e07a0521e05ced80523fe0f6425d13d1190679e1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 19 Apr 2024 09:49:36 +1000 Subject: [PATCH 446/814] fix latest merge... --- src/main/sdar_group.f90 | 4 ++-- src/main/substepping.F90 | 1 - src/setup/setup_starcluster.f90 | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 8f7261af8..039c710f3 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -327,7 +327,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ endif enddo - print*,step_count_int,tcoord,tnext,ds_init + !print*,step_count_int,tcoord,tnext,ds_init deallocate(bdata) @@ -585,7 +585,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id r2 = dx**2+dy**2+dz**2 r = sqrt(r2) mj = xyzmh_ptmass(4,j) - gravf = mj*(1./r2*r) + gravf = mj*(1./(r2*r)) gtki = gtki + mj*(1./r) fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + dx*gravf fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + dy*gravf diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 9740a3337..54234da06 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -564,7 +564,6 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx use sdar_group, only:group_identify,evolve_groups use options, only:iexternalforce use externalforces, only:is_velocity_dependent - use ptmass, only:ck,dk real, intent(in) :: dtsph,time integer, intent(in) :: npart,nptmass,ntypes real, intent(inout) :: dtextforce diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index fcadfe5b9..2d3f43e06 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -132,7 +132,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! setup initial sphere of particles to prevent initialisation problems ! psep = 1.0 - call set_sphere('cubic',id,master,0.,10.0,psep,hfact,npart,xyzh) + call set_sphere('cubic',id,master,0.,0.01,psep,hfact,npart,xyzh) vxyzu(4,:) = 5.317e-4 npartoftype(igas) = npart From a0eb6b611c09dd7b7927313303f08c59b7b19d64 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 19 Apr 2024 10:07:59 +1000 Subject: [PATCH 447/814] (stats) added total ifdef count to stats script [skip ci] --- scripts/stats.sh | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/scripts/stats.sh b/scripts/stats.sh index 4ee99e17e..070486499 100755 --- a/scripts/stats.sh +++ b/scripts/stats.sh @@ -42,6 +42,11 @@ count_unique_matches() n=`cd $phantomdir; grep "$1" src/*/*.*90 | cut -d':' -f 2 | sort -u | wc -l`; echo "$n"; } +count_files_ending_in() +{ + n=`cd $phantomdir; ls src/*/*$1 | wc -l`; + echo "$n"; +} get_subroutine_count() { nsub=$(count_matches 'end subroutine'); @@ -126,13 +131,21 @@ get_build_status_from_git_tags() nauthors=$(get_author_count); ncode="$(get_lines_of_code)"; nifdef="$(count_unique_matches '#ifdef')"; +nifdefall="$(count_matches '#ifdef')"; +nfiles="$(count_files_ending_in '.*90')"; +nf90="$(count_files_ending_in '.f90')"; +nF90="$(count_files_ending_in '.F90')"; subcount="$(get_subroutine_count)"; nsetup="$(get_setup_count)"; nsystem="$(get_system_count)"; echo "Lines of code: main setup tests utils"; echo " $ncode"; echo "Number of modules, subroutines, functions: $subcount"; -echo "Number of #ifdef statements : $nifdef"; +echo "Number of source files (.f90, .F90): $nfiles"; +echo "Number of .f90 files : $nf90"; +echo "Number of .F90 files : $nF90"; +echo "Number of unique #ifdef statements : $nifdef"; +echo "Number of total #ifdef statements : $nifdefall"; echo "Number of authors : $nauthors"; echo "Number of SETUP= options : $nsetup"; echo "Number of SYSTEM= options : $nsystem"; From 493dfa90f2cfc5cc941ec8308e5b414ec7b4cc6d Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 19 Apr 2024 14:56:22 +1000 Subject: [PATCH 448/814] split init int for sub --- src/main/sdar_group.f90 | 173 +++++++++++++++++++++++++++------------- 1 file changed, 116 insertions(+), 57 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 039c710f3..ef482c39b 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -238,7 +238,13 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ismultiple = gsize > 2 - call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,start_id,end_id,ismultiple,ds_init) + if(ismultiple) then + call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,start_id,end_id,ds_init) + else + prim = group_info(igarg,start_id) + sec = group_info(igarg,end_id) + call initial_int_bin(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,prim,sec,ds_init) + endif allocate(bdata(gsize*6)) @@ -261,7 +267,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ endif t_old = tcoord W_old = W - if (gsize>2) then + if (ismultiple) then do i=1,ck_size call drift_TTL (tcoord,W,ds(switch)*cks(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) time_table(i) = tcoord @@ -558,19 +564,19 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id real, intent(out) :: om integer, intent(in) :: s_id,e_id real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,r - real :: gravf,gtki + real :: gravf,gtki,gravfi(3),gtgradi(3) integer :: i,j,k,l om = 0. do k=s_id,e_id i = group_info(igarg,k) - fxyz_ptmass(1,i) = 0. - fxyz_ptmass(2,i) = 0. - fxyz_ptmass(3,i) = 0. - gtgrad(1,i) = 0. - gtgrad(2,i) = 0. - gtgrad(3,i) = 0. + gravfi(1) = 0. + gravfi(2) = 0. + gravfi(3) = 0. + gtgradi(1) = 0. + gtgradi(2) = 0. + gtgradi(3) = 0. gtki = 0. xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) @@ -587,13 +593,20 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id mj = xyzmh_ptmass(4,j) gravf = mj*(1./(r2*r)) gtki = gtki + mj*(1./r) - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + dx*gravf - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + dy*gravf - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + dz*gravf - gtgrad(1,i) = gtgrad(1,i) + dx*gravf*mi - gtgrad(2,i) = gtgrad(2,i) + dy*gravf*mi - gtgrad(3,i) = gtgrad(3,i) + dz*gravf*mi + gravfi(1) = gravfi(1) + dx*gravf + gravfi(2) = gravfi(2) + dy*gravf + gravfi(3) = gravfi(3) + dz*gravf + gtgradi(1) = gtgradi(1) + dx*gravf*mi + gtgradi(2) = gtgradi(2) + dy*gravf*mi + gtgradi(3) = gtgradi(3) + dz*gravf*mi enddo + fxyz_ptmass(1,i) = gravfi(1) + fxyz_ptmass(2,i) = gravfi(2) + fxyz_ptmass(3,i) = gravfi(3) + gtgrad(1,i) = gtgradi(1) + gtgrad(2,i) = gtgradi(2) + gtgrad(3,i) = gtgradi(3) + om = om + gtki*mi enddo @@ -607,7 +620,7 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) integer, intent(in) :: i,j real, intent(out) :: om real :: dx,dy,dz,r2,r,ddr3,mi,mj - real :: gravfi,gtki,gravfj,gtkj + real :: gravfi,gtki,gravfj mi = xyzmh_ptmass(4,i) mj = xyzmh_ptmass(4,j) @@ -620,7 +633,6 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) gravfi = mj*ddr3 gravfj = mi*ddr3 gtki = mj*(1./r) - gtkj = mi*(1./r) fxyz_ptmass(1,i) = -dx*gravfi fxyz_ptmass(2,i) = -dy*gravfi @@ -640,24 +652,24 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) end subroutine get_force_TTL_bin -subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e_id,ismultiple,ds_init) +subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e_id,ds_init) use utils_kepler, only :extract_a_dot,extract_a,Espec use part, only:igarg real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:) integer,intent(in) :: group_info(:,:) real, intent(out) :: om,ds_init - logical, intent(in) :: ismultiple integer, intent(in) :: s_id,e_id - real :: mi,mj,mu,xi,yi,zi,dx,dy,dz,r,r2 - real :: vxi,vyi,vzi,v2,vi,dvx,dvy,dvz,v,rdotv,axi,ayi,azi,acc,gravfi - real :: gravf,gtki - real :: Edot,E,semi,semidot + real :: mi,mj,xi,yi,zi,dx,dy,dz,r,r2 + real :: vxi,vyi,vzi,v,dvx,dvy,dvz,rdotv,axi,ayi,azi,acc,gravrdotv + real :: gravf,gravfi(3),gtki + real :: Edot,E integer :: k,l,i,j Edot = 0. E = 0. om = 0. + gravrdotv = 0. do k=s_id,e_id i = group_info(igarg,k) @@ -670,9 +682,12 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e vxi = vxyz_ptmass(1,i) vyi = vxyz_ptmass(2,i) vzi = vxyz_ptmass(3,i) - fxyz_ptmass(1,i) = 0. - fxyz_ptmass(2,i) = 0. - fxyz_ptmass(3,i) = 0. + axi = fxyz_ptmass(1,i) + ayi = fxyz_ptmass(2,i) + azi = fxyz_ptmass(3,i) + gravfi(1) = 0. + gravfi(2) = 0. + gravfi(3) = 0. do l=s_id,e_id if (k==l) cycle j = group_info(igarg,l) @@ -685,44 +700,88 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e r2 = dx**2+dy**2+dz**2 r = sqrt(r2) mj = xyzmh_ptmass(4,j) - gravf = xyzmh_ptmass(4,j)*(1./r2*r) + gravf = mj*(1./(r2*r)) gtki = gtki + mj*(1./r) - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + dx*gravf - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + dy*gravf - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + dz*gravf - if (ismultiple) then - rdotv = dx*dvx + dy*dvy + dz*dvz - gravfi = gravfi + gravf*rdotv - else - v2 = dvx**2 + dvy**2 + dvz**2 - v = sqrt(v2) - endif - + gravfi(1) = gravfi(1) + dx*gravf + gravfi(2) = gravfi(2) + dy*gravf + gravfi(3) = gravfi(3) + dz*gravf + rdotv = dx*dvx + dy*dvy + dz*dvz + gravrdotv = gravrdotv + gravf*rdotv enddo om = om + gtki*mi - axi = fxyz_ptmass(1,i) - ayi = fxyz_ptmass(2,i) - azi = fxyz_ptmass(3,i) + axi = axi + gravfi(1) + ayi = ayi + gravfi(2) + azi = azi + gravfi(3) acc = sqrt(axi**2 + ayi**2 + azi**2) - if (ismultiple) then - vi = sqrt(vxi**2 + vyi**2 + vzi**2) - Edot = Edot + mi*(vi*acc - gravfi) - E = E + 0.5*mi*vi**2 - gtki - else - mu = mi*mj - call extract_a_dot(r2,r,mu,v2,v,acc,semidot) - call extract_a(r,mu,v2,semi) - endif + v = sqrt(vxi**2 + vyi**2 + vzi**2) + Edot = Edot + mi*(v*acc - gravrdotv) + E = E + 0.5*mi*v**2 - gtki enddo - om = om*0.5 - - if (ismultiple) then - ds_init = eta_pert * abs(E/Edot) - else - ds_init = eta_pert * abs(semi/semidot) - endif + ds_init = eta_pert * abs(E/Edot) + om = om*0.5 end subroutine initial_int +subroutine initial_int_bin(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,i,j,ds_init) + use utils_kepler, only :extract_a_dot,extract_a,Espec + use part, only:igarg + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(inout) :: fxyz_ptmass(:,:) + integer,intent(in) :: group_info(:,:) + real, intent(out) :: om,ds_init + integer, intent(in) :: i,j + real :: mi,mj,mu,dx,dy,dz,r,r2,ddr3 + real :: v,v2,dvx,dvy,dvz + real :: dax,day,daz,acc + real :: gravfi,gravfj,gtki + real :: semi,semidot + + om = 0. + + + + mi = xyzmh_ptmass(4,i) + mj = xyzmh_ptmass(4,j) + dx = xyzmh_ptmass(1,i) - xyzmh_ptmass(1,j) + dy = xyzmh_ptmass(2,i) - xyzmh_ptmass(2,j) + dz = xyzmh_ptmass(3,i) - xyzmh_ptmass(3,j) + dvx = vxyz_ptmass(1,i) - vxyz_ptmass(1,j) + dvy = vxyz_ptmass(2,i) - vxyz_ptmass(2,j) + dvz = vxyz_ptmass(3,i) - vxyz_ptmass(3,j) + + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) + v2 = dvx**2 + dvy**2 + dvz**2 + v = sqrt(v2) + + ddr3 = (1./(r2*r)) + gravfi = mj*ddr3 + gravfj = mi*ddr3 + gtki = mj*(1./r) + + fxyz_ptmass(1,i) = fxyz_ptmass(1,i) - dx*gravfi + fxyz_ptmass(2,i) = fxyz_ptmass(2,i) - dy*gravfi + fxyz_ptmass(3,i) = fxyz_ptmass(3,i) - dz*gravfi + fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + dx*gravfj + fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + dy*gravfj + fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + dz*gravfj + + dax = fxyz_ptmass(1,i) - fxyz_ptmass(1,j) + day = fxyz_ptmass(2,i) - fxyz_ptmass(2,j) + daz = fxyz_ptmass(3,i) - fxyz_ptmass(3,j) + + acc = sqrt(dax**2 + day**2 + daz**2) + mu = mi*mj + + call extract_a_dot(r2,r,mu,v2,v,acc,semidot) + call extract_a(r,mu,v2,semi) + + ds_init = eta_pert * abs(semi/semidot) + om = gtki*mi + + print*,abs(semidot/semi),5.e-5/(r2*acc/(mi+mj)),ds_init + +end subroutine initial_int_bin + end module sdar_group From 33a30a00ca95526e8725f9032b06ad459c337f4f Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 19 Apr 2024 15:10:11 +1000 Subject: [PATCH 449/814] (cons2prim,energies) unused variable warnings fixed with OPENMP=no --- src/main/cons2prim.f90 | 6 +++--- src/main/energies.F90 | 8 ++++---- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 9c1130f8e..671b43322 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -123,20 +123,20 @@ subroutine cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) use part, only:isdead_or_accreted,massoftype,igas,rhoh,igasP,ics,ien_type,& itemp,igamma use io, only:fatal - use eos, only:ieos,gamma,done_init_eos,init_eos,get_spsound + 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,pondens,spsound,tempi,gammai + real :: p_guess,rhoi,tempi,gammai 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,gamma,eos_vars,ien_type) & -!$omp private(i,ierr,spsound,pondens,p_guess,rhoi,tempi,gammai) +!$omp private(i,ierr,p_guess,rhoi,tempi,gammai) 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 diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 27684ce97..0fc102122 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -96,11 +96,11 @@ subroutine compute_energies(t) real, intent(in) :: t integer :: iregime,idusttype,ierr real :: ev_data_thread(4,0:inumev) - real :: xi,yi,zi,hi,vxi,vyi,vzi,v2i,vi1,Bxi,Byi,Bzi,Bi,B2i,rhoi,angx,angy,angz + real :: xi,yi,zi,hi,vxi,vyi,vzi,v2i,Bxi,Byi,Bzi,Bi,B2i,rhoi,angx,angy,angz real :: xmomacc,ymomacc,zmomacc,angaccx,angaccy,angaccz,xcom,ycom,zcom,dm real :: epoti,pmassi,dnptot,dnpgas,tsi real :: xmomall,ymomall,zmomall,angxall,angyall,angzall,rho1i,vsigi - real :: ponrhoi,spsoundi,spsound2i,va2cs2,rho1cs2,dumx,dumy,dumz,gammai + real :: ponrhoi,spsoundi,dumx,dumy,dumz,gammai real :: divBi,hdivBonBi,alphai,valfven2i,betai real :: n_total,n_total1,n_ion,shearparam_art,shearparam_phys,ratio_phys_to_av real :: gasfrac,rhogasi,dustfracisum,dustfraci(maxdusttypes),dust_to_gas(maxdusttypes) @@ -175,8 +175,8 @@ subroutine compute_energies(t) !$omp shared(iev_etaa,iev_vel,iev_vhall,iev_vion,iev_n) & !$omp shared(iev_dtg,iev_ts,iev_macc,iev_totlum,iev_erot,iev_viscrat) & !$omp shared(eos_vars,grainsize,graindens,ndustsmall,metrics) & -!$omp private(i,j,xi,yi,zi,hi,rhoi,vxi,vyi,vzi,Bxi,Byi,Bzi,Bi,B2i,epoti,vsigi,v2i,vi1) & -!$omp private(ponrhoi,spsoundi,gammai,spsound2i,va2cs2,rho1cs2,ethermi,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & +!$omp private(i,j,xi,yi,zi,hi,rhoi,vxi,vyi,vzi,Bxi,Byi,Bzi,Bi,B2i,epoti,vsigi,v2i) & +!$omp private(ponrhoi,spsoundi,gammai,ethermi,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & !$omp private(rho1i,shearparam_art,shearparam_phys,ratio_phys_to_av,betai) & !$omp private(gasfrac,rhogasi,dustfracisum,dustfraci,dust_to_gas,n_total,n_total1,n_ion) & !$omp private(etaohm,etahall,etaambi,vhalli,vhall,vioni,vion,data_out) & From 6cfd0ccd081a00abe5b9f59e3fa421e94e56374e Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 19 Apr 2024 15:17:12 +1000 Subject: [PATCH 450/814] (test_ptmass) added further checks of accreting many particles at once, also ability to run specific tests in ptmass testsuite --- src/tests/test_ptmass.f90 | 160 ++++++++++++++++++++++++-------------- src/tests/testsuite.F90 | 3 +- 2 files changed, 104 insertions(+), 59 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index f6e05b3f2..284269a06 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -27,24 +27,41 @@ module testptmass contains -subroutine test_ptmass(ntests,npass) +subroutine test_ptmass(ntests,npass,string) use io, only:id,master,iskfile use eos, only:polyk,gamma use part, only:nptmass use options, only:iexternalforce,alpha use ptmass, only:use_fourthorder,set_integration_precision + character(len=*), intent(in) :: string character(len=20) :: filename integer, intent(inout) :: ntests,npass integer :: itmp,ierr,itest logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening,do_test_merger + logical :: testall if (id==master) write(*,"(/,a,/)") '--> TESTING PTMASS MODULE' - do_test_binary = .true. - do_test_accretion = .true. - do_test_createsink = .true. - do_test_softening = .true. - do_test_merger = .true. + do_test_binary = .false. + do_test_accretion = .false. + do_test_createsink = .false. + do_test_softening = .false. + do_test_merger = .false. + testall = .false. + select case(trim(string)) + case('ptmassbinary') + do_test_binary = .true. + case('ptmassaccrete') + do_test_accretion = .true. + case('ptmasscreatesink') + do_test_createsink = .true. + case('ptmasssoftening') + do_test_softening = .true. + case('ptmassmerger') + do_test_merger = .true. + case default + testall = .true. + end select ! !--general settings ! @@ -62,24 +79,28 @@ subroutine test_ptmass(ntests,npass) ! ! Tests of a sink particle binary ! - if (do_test_binary) call test_binary(ntests,npass) + if (do_test_binary .or. testall) call test_binary(ntests,npass) ! ! Test of softening between sinks ! - if (do_test_softening) call test_softening(ntests,npass) + if (do_test_softening .or. testall) call test_softening(ntests,npass) ! ! Test sink particle mergers ! - if (do_test_merger) call test_merger(ntests,npass) + if (do_test_merger .or. testall) call test_merger(ntests,npass) enddo ! ! Tests of accrete_particle routine ! - if (do_test_accretion) call test_accretion(ntests,npass) + if (do_test_accretion .or. testall) then + do itest=1,2 + call test_accretion(ntests,npass,itest) + enddo + endif ! ! Test sink particle creation ! - if (do_test_createsink) call test_createsink(ntests,npass) + if (do_test_createsink .or. testall) call test_createsink(ntests,npass) !reset stuff and clean up temporary files itmp = 201 @@ -210,7 +231,7 @@ subroutine test_binary(ntests,npass) ! add a circumbinary gas disc around it nparttot = 1000 call set_disc(id,master,nparttot=nparttot,npart=npart,rmin=rin,rmax=rout,p_index=1.0,q_index=0.75,& - HoverR=0.1,disc_mass=0.01*m1,star_mass=m1+m2,gamma=gamma,& + HoverR=0.1,disc_mass=0.1*m1,star_mass=m1+m2,gamma=gamma,& particle_mass=massoftype(igas),hfact=hfact,xyzh=xyzh,vxyzu=vxyzu,& polyk=polyk,verbose=.false.) npartoftype(igas) = npart @@ -484,29 +505,35 @@ end subroutine test_softening ! Test accretion of gas particles onto sink particles !+ !----------------------------------------------------------------------- -subroutine test_accretion(ntests,npass) +subroutine test_accretion(ntests,npass,itest) use io, only:id,master use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,massoftype, & npart,npartoftype,xyzh,vxyzu,fxyzu,igas,ihacc,& - isdead_or_accreted,set_particle_type,ndptmass + isdead_or_accreted,set_particle_type,ndptmass,hfact use ptmass, only:ptmass_accrete,update_ptmass use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi use testutils, only:checkval,update_test_scores + use kernel, only:hfact_default + use eos, only:polyk + use setdisc, only:set_disc integer, intent(inout) :: ntests,npass - integer :: i,nfailed(11) + integer, intent(in) :: itest + integer :: i,nfailed(11),np_disc integer(kind=1) :: ibin_wakei + character(len=20) :: string logical :: accreted - real :: dr,t + real :: t real :: dptmass(ndptmass,1) real :: dptmass_thread(ndptmass,1) - real :: xyzm_ptmass_old(4,1),vxyz_ptmass_old(3,1) real :: angmomin,etotin,totmomin xyzmh_ptmass(:,:) = 0. vxyz_ptmass(:,:) = 0. - if (id==master) write(*,"(/,a)") '--> testing accretion onto sink particles' + string = 'of two particles' + if (itest==2) string = 'of a whole disc' + if (id==master) write(*,"(/,a)") '--> testing accretion '//trim(string)//' onto sink particles' nptmass = 1 !--setup 1 point mass at (-5,-5,-5) xyzmh_ptmass(1:3,1) = 1. @@ -514,23 +541,35 @@ subroutine test_accretion(ntests,npass) xyzmh_ptmass(ihacc,1) = 20. ! accretion radius vxyz_ptmass(1:3,1) = -40. fxyz_ptmass(1:3,1) = 40. - massoftype(1) = 10. - !--setup 1 SPH particle at (5,5,5) - if (id==master) then - call set_particle_type(1,igas) - npartoftype(igas) = 1 - npart = 1 - xyzh(1:3,1) = 5. - xyzh(4,1) = 0.01 - vxyzu(1:3,1) = 80. - fxyzu(1:3,1) = 20. + hfact = hfact_default + + if (itest==1) then + !--setup 2 SPH particles at (5,5,5) + if (id==master) then + call set_particle_type(1,igas) + call set_particle_type(2,igas) + npartoftype(igas) = 2 + npart = 2 + xyzh(1:3,1:2) = 5. + xyzh(4,1:2) = 0.01 + vxyzu(1:3,1) = [40.,40.,-10.] + vxyzu(1:3,2) = [120.,120.,-30.] + fxyzu(1:3,1:2) = 20. + massoftype(1) = 5. + else + npartoftype(igas) = 0 + npart = 0 + endif else - npartoftype(igas) = 0 - npart = 0 + ! eat a large portion of a disc + np_disc = 1000 + call set_disc(id,master,nparttot=np_disc,npart=npart,rmin=1.,rmax=2.*xyzmh_ptmass(ihacc,1),p_index=1.0,q_index=0.75,& + HoverR=0.1,disc_mass=0.5*xyzmh_ptmass(4,1),star_mass=xyzmh_ptmass(4,1),gamma=1.,& + particle_mass=massoftype(igas),hfact=hfact,xyzh=xyzh,vxyzu=vxyzu,& + polyk=polyk,verbose=.false.) + npartoftype(igas) = npart endif - xyzm_ptmass_old = xyzmh_ptmass(1:4,1:nptmass) - vxyz_ptmass_old = vxyz_ptmass (1:3,1:nptmass) - dr = sqrt(dot_product(xyzh(1:3,1) - xyzmh_ptmass(1:3,1),xyzh(1:3,1) - xyzmh_ptmass(1:3,1))) + !--perform a test of the accretion of the SPH particle by the point mass nfailed(:) = 0 !--check energies before accretion event @@ -546,10 +585,12 @@ subroutine test_accretion(ntests,npass) dptmass_thread(:,1:nptmass) = 0. !$omp do do i=1,npart - call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxyzu(1,i),fxyzu(2,i),fxyzu(3,i), & - igas,massoftype(igas),xyzmh_ptmass,vxyz_ptmass, & - accreted,dptmass_thread,t,1.0,ibin_wakei,ibin_wakei) + if (.not.isdead_or_accreted(xyzh(4,i))) then + call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& + vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxyzu(1,i),fxyzu(2,i),fxyzu(3,i), & + igas,massoftype(igas),xyzmh_ptmass,vxyz_ptmass, & + accreted,dptmass_thread,t,1.0,ibin_wakei,ibin_wakei) + endif enddo !$omp enddo !$omp critical(dptmassadd) @@ -565,30 +606,33 @@ subroutine test_accretion(ntests,npass) call bcast_mpi(vxyz_ptmass(:,1:nptmass)) call bcast_mpi(fxyz_ptmass(:,1:nptmass)) - if (id==master) then - call checkval(accreted,.true.,nfailed(1),'accretion flag') - !--check that h has been changed to indicate particle has been accreted - call checkval(isdead_or_accreted(xyzh(4,1)),.true.,nfailed(2),'isdead_or_accreted flag') + if (itest==1) then + if (id==master) then + call checkval(accreted,.true.,nfailed(1),'accretion flag') + !--check that h has been changed to indicate particle has been accreted + call checkval(isdead_or_accreted(xyzh(4,1)),.true.,nfailed(2),'isdead_or_accreted flag(1)') + call checkval(isdead_or_accreted(xyzh(4,2)),.true.,nfailed(2),'isdead_or_accreted flag(2)') + endif + call checkval(xyzmh_ptmass(1,1),3.,tiny(0.),nfailed(3),'x(ptmass) after accretion') + call checkval(xyzmh_ptmass(2,1),3.,tiny(0.),nfailed(4),'y(ptmass) after accretion') + call checkval(xyzmh_ptmass(3,1),3.,tiny(0.),nfailed(5),'z(ptmass) after accretion') + call checkval(vxyz_ptmass(1,1),20.,tiny(0.),nfailed(6),'vx(ptmass) after accretion') + call checkval(vxyz_ptmass(2,1),20.,tiny(0.),nfailed(7),'vy(ptmass) after accretion') + call checkval(vxyz_ptmass(3,1),-30.,tiny(0.),nfailed(8),'vz(ptmass) after accretion') + call checkval(fxyz_ptmass(1,1),30.,tiny(0.),nfailed(9), 'fx(ptmass) after accretion') + call checkval(fxyz_ptmass(2,1),30.,tiny(0.),nfailed(10),'fy(ptmass) after accretion') + call checkval(fxyz_ptmass(3,1),30.,tiny(0.),nfailed(11),'fz(ptmass) after accretion') + + call update_test_scores(ntests,nfailed(1:2),npass) + call update_test_scores(ntests,nfailed(3:5),npass) + call update_test_scores(ntests,nfailed(6:8),npass) + call update_test_scores(ntests,nfailed(9:11),npass) endif - call checkval(xyzmh_ptmass(1,1),3.,tiny(0.),nfailed(3),'x(ptmass) after accretion') - call checkval(xyzmh_ptmass(2,1),3.,tiny(0.),nfailed(4),'y(ptmass) after accretion') - call checkval(xyzmh_ptmass(3,1),3.,tiny(0.),nfailed(5),'z(ptmass) after accretion') - call checkval(vxyz_ptmass(1,1),20.,tiny(0.),nfailed(6),'vx(ptmass) after accretion') - call checkval(vxyz_ptmass(2,1),20.,tiny(0.),nfailed(7),'vy(ptmass) after accretion') - call checkval(vxyz_ptmass(3,1),20.,tiny(0.),nfailed(8),'vz(ptmass) after accretion') - call checkval(fxyz_ptmass(1,1),30.,tiny(0.),nfailed(9), 'fx(ptmass) after accretion') - call checkval(fxyz_ptmass(2,1),30.,tiny(0.),nfailed(10),'fy(ptmass) after accretion') - call checkval(fxyz_ptmass(3,1),30.,tiny(0.),nfailed(11),'fz(ptmass) after accretion') - - call update_test_scores(ntests,nfailed(1:2),npass) - call update_test_scores(ntests,nfailed(3:5),npass) - call update_test_scores(ntests,nfailed(6:8),npass) - call update_test_scores(ntests,nfailed(9:11),npass) - - !--compute energies after accretion event + + !--compute conserved quantities after accretion event nfailed(:) = 0 call compute_energies(t) - call checkval(angtot,angmomin,1.e-10,nfailed(3),'angular momentum') + call checkval(angtot,angmomin,1.e-14,nfailed(3),'angular momentum') call checkval(totmom,totmomin,epsilon(0.),nfailed(2),'linear momentum') !call checkval(etot,etotin,1.e-6,'total energy',nfailed(1)) call update_test_scores(ntests,nfailed(3:3),npass) diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index 180e2708b..c7773d141 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -156,6 +156,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) if (index(string,'damp') /= 0) dodamp = .true. if (index(string,'wind') /= 0) dowind = .true. if (index(string,'iorig') /= 0) doiorig = .true. + if (index(string,'ptmass') /= 0) doptmass = .true. doany = any((/doderivs,dogravity,dodust,dogrowth,donimhd,dorwdump,& doptmass,docooling,dogeom,dogr,dosmol,doradiation,& @@ -327,7 +328,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) !--test of ptmass module ! if (doptmass.or.testall) then - call test_ptmass(ntests,npass) + call test_ptmass(ntests,npass,string) call set_default_options_testsuite(iverbose) ! restore defaults endif From b4151dcd809440ce71f2800b679f9d2eba3faa56 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 19 Apr 2024 15:24:31 +1000 Subject: [PATCH 451/814] bug fix with previous warning fix --- src/main/cons2prim.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 671b43322..18d054644 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -135,7 +135,7 @@ subroutine cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) !$omp parallel do default (none) & !$omp shared(xyzh,metrics,vxyzu,dens,pxyzu,npart,massoftype) & -!$omp shared(ieos,gamma,eos_vars,ien_type) & +!$omp shared(ieos,eos_vars,ien_type) & !$omp private(i,ierr,p_guess,rhoi,tempi,gammai) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then From 22dd6ac855cc0ccebec79acb7c76dc26bf029d8a Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Sun, 21 Apr 2024 10:36:52 +0200 Subject: [PATCH 452/814] (dust_nucleation) fix calculation of gamma --- src/main/dust_formation.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index e594658ca..5598f85fb 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.f90 @@ -405,7 +405,7 @@ subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) pH2 = KH2*pH**2 mu = (1.+4.*eps(iHe))/(.5+eps(iHe)+0.5*pH/pH_tot) x = 2.*(1.+4.*eps(iHe))/mu - gamma = (3.*x+4.-3.*eps(iHe))/(x+4.+eps(iHe)) + gamma = (3.*x+4.+4.*eps(iHe))/(x+4.+4.*eps(iHe)) converged = (abs(T-T_old)/T_old) < tol if (i == 1) then mu_old = mu From 9a7b4927415b78623527123db2316ae15ed7777d Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 22 Apr 2024 10:18:28 +1000 Subject: [PATCH 453/814] (test_ptmass) revert change to disc mass causing test failures --- src/tests/test_ptmass.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 284269a06..96769a701 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -231,7 +231,7 @@ subroutine test_binary(ntests,npass) ! add a circumbinary gas disc around it nparttot = 1000 call set_disc(id,master,nparttot=nparttot,npart=npart,rmin=rin,rmax=rout,p_index=1.0,q_index=0.75,& - HoverR=0.1,disc_mass=0.1*m1,star_mass=m1+m2,gamma=gamma,& + HoverR=0.1,disc_mass=0.01*m1,star_mass=m1+m2,gamma=gamma,& particle_mass=massoftype(igas),hfact=hfact,xyzh=xyzh,vxyzu=vxyzu,& polyk=polyk,verbose=.false.) npartoftype(igas) = npart From fb3f55011bc7d9e9591a3af162a9d09b28ccd59f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 22 Apr 2024 14:10:25 +1000 Subject: [PATCH 454/814] fix angular momentum non conservation issue... --- src/main/ptmass.F90 | 2 +- src/main/substepping.F90 | 37 +++++++++++++++++++++----------- src/tests/test_ptmass.f90 | 45 ++++++++++++++++++++++++--------------- 3 files changed, 53 insertions(+), 31 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e6c179def..798c52ed1 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -97,7 +97,7 @@ module ptmass ! just means that with the default setting of C_force the orbits are accurate real, parameter :: dtfacphilf = 0.05 real, parameter :: dtfacphi2lf = dtfacphilf**2 - real, parameter :: dtfacphifsi = 0.05 + real, parameter :: dtfacphifsi = 0.15 real, parameter :: dtfacphi2fsi = dtfacphifsi**2 real :: dtfacphi = dtfacphifsi diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 36eb261c3..643885c06 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -441,7 +441,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & real, intent(inout) :: dptmass(:,:),fsink_old(:,:) integer(kind=1), intent(in) :: nbinmax integer(kind=1), intent(inout) :: ibin_wake(:) - logical :: extf_vdep_flag,done,last_step + logical :: extf_vdep_flag,done,last_step,accreted integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step real :: dtextforce_min @@ -486,10 +486,9 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & if (use_fourthorder) then !! FSI 4th order scheme - ! FSFI extrapolation method (Omelyan 2006) + ! FSI extrapolation method (Omelyan 2006) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) - + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) @@ -498,13 +497,21 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + 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(3),force_count,extf_vdep_flag) + endif else !! standard leapfrog scheme ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + 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) + endif endif @@ -589,7 +596,7 @@ end subroutine drift !---------------------------------------------------------------- subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & - fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas use ptmass, only:f_acc,ptmass_accrete,pt_write_sinkev,update_ptmass,ptmass_kick use externalforces, only:accrete_particles @@ -608,8 +615,9 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, real, optional, intent(in) :: timei integer(kind=1), optional, intent(inout) :: ibin_wake(:) integer(kind=1), optional, intent(in) :: nbinmax + logical , optional, intent(inout) :: accreted integer(kind=1) :: ibin_wakei - logical :: is_accretion,accreted + logical :: is_accretion integer :: i,itype,nfaili integer :: naccreted,nfail,nlive real :: dkdt,pmassi,fxi,fyi,fzi,accretedmass @@ -733,11 +741,13 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, ! ! reduction of sink particle changes across MPI ! + accreted = .false. if (nptmass > 0) then call reduce_in_place_mpi('+',dptmass(:,1:nptmass)) naccreted = int(reduceall_mpi('+',naccreted)) nfail = int(reduceall_mpi('+',nfail)) + if (naccreted > 0) accreted = .true. if (id==master) call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) @@ -907,8 +917,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (nptmass>0) then 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) + 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) @@ -926,8 +936,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dtextforcenew,dtf,dkdt,fextx,fexty,fextz, & extf_vdep_flag,iexternalforce) endif - -! + ! ! damping ! if (idamp > 0) then @@ -970,7 +979,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (fonrmax > 0.) then dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) endif - if (iverbose >= 3 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas + if (iverbose >= 2 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas dtextforcenew = min(dtextforcenew,dtsinkgas) endif @@ -981,6 +990,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, end subroutine get_force + + !----------------------------------------------------------------------------------- !+ ! Update of abundances and internal energy using cooling method (see cooling module) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 96769a701..a9ebdb07c 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -150,7 +150,7 @@ subroutine test_binary(ntests,npass) integer :: i,ierr,itest,nfailed(3),nsteps,nerr,nwarn,norbits integer :: merge_ij(2),merge_n,nparttot,nfailgw(2),ncheckgw(2) integer, parameter :: nbinary_tests = 5 - real :: m1,m2,a,ecc,hacc1,hacc2,dt,dtext,t,dtnew,tolen,hp_exact,hx_exact + real :: m1,m2,a,ecc,hacc1,hacc2,dt,dtext,t,dtnew,tolen,tolmom,tolang,hp_exact,hx_exact real :: angmomin,etotin,totmomin,dum,dum2,omega,errmax,dtsinksink,fac,errgw(2) real :: angle,rin,rout real :: fxyz_sinksink(4,2),dsdt_sinksink(3,2) ! we only use 2 sink particles in the tests here @@ -168,6 +168,8 @@ subroutine test_binary(ntests,npass) ipdv_heating = 0 ishock_heating = 0 + tolv = 1e-2 + binary_tests: do itest = 1,nbinary_tests select case(itest) case(4) @@ -221,6 +223,7 @@ subroutine test_binary(ntests,npass) hacc1 = 0.35 hacc2 = 0.35 C_force = 0.25 + if (itest==3) C_force = 0.25 omega = sqrt((m1+m2)/a**3) t = 0. call set_units(mass=1.d0,dist=1.d0,G=1.d0) @@ -255,7 +258,7 @@ subroutine test_binary(ntests,npass) call checkval(nerr,0,0,nfailed(1),'no errors during disc setup') call update_test_scores(ntests,nfailed,npass) - tolv = 1.e3 + tolv = 1.e-2 iverbose = 0 ieos = 3 fac = 1./get_G_on_dc4() @@ -324,7 +327,7 @@ subroutine test_binary(ntests,npass) if (itest==2 .or. itest==3 .or. itest==5) then norbits = 10 else - norbits = 100 + norbits = 10 endif if (id==master) print*,'steps/orbit = ',nsteps,' norbits = ',norbits,' dt = ',dt nsteps = nsteps*norbits @@ -335,58 +338,66 @@ subroutine test_binary(ntests,npass) if (id==master) call getused(t1) call init_step(npart,t,dtmax) do i=1,nsteps - t = t + dt dtext = dt if (id==master .and. iverbose > 2) write(*,*) ' t = ',t,' dt = ',dt call step(npart,npart,t,dt,dtext,dtnew) call compute_energies(t) errmax = max(errmax,abs(etot - etotin)) + !if (itest==3) print*,t,abs(angtot-angmomin)/angmomin ! ! Check the gravitational wave strain if the binary is circular. ! There is a phase error that grows with time, so only check the first 10 orbits ! if (calc_gravitwaves .and. abs(ecc) < epsilon(ecc) .and. itest==1 .and. t < 20.*pi/omega) then - call get_strain_from_circular_binary(t,m1,m2,a,0.,hx_exact,hp_exact) + call get_strain_from_circular_binary(t+dt,m1,m2,a,0.,hx_exact,hp_exact) call checkvalbuf(10.+hx(1)*fac,10.+hx_exact*fac,tolgw,& 'gw strain (x)',nfailgw(1),ncheckgw(1),errgw(1)) call checkvalbuf(10.+hp(1)*fac,10.+hp_exact*fac,tolgw,& 'gw strain (+)',nfailgw(2),ncheckgw(2),errgw(2)) endif + t = t + dt enddo call compute_energies(t) if (id==master) call printused(t1) nfailed(:) = 0 + tolmom = 5.e-15 + tolang = 1.e-14 select case(itest) + case(5) + tolen = 9.e-1 + case(4) + tolmom = 1.e-14 + tolen = 1.6e-2 case(3) if (ind_timesteps) then - call checkval(angtot,angmomin,2.1e-6,nfailed(3),'angular momentum') - call checkval(totmom,totmomin,5.e-6,nfailed(2),'linear momentum') - else - call checkval(angtot,angmomin,1.2e-6,nfailed(3),'angular momentum') - call checkval(totmom,totmomin,4.e-14,nfailed(2),'linear momentum') + tolang = 2.1e-6 endif tolen = 1.2e-2 + if (use_fourthorder) then + tolen = 5.5e-4 + endif case(2) - call checkval(angtot,angmomin,4.e-7,nfailed(3),'angular momentum') - call checkval(totmom,totmomin,6.e-14,nfailed(2),'linear momentum') tolen = 2.e-3 if (gravity) tolen = 3.1e-3 + + if (use_fourthorder) then + tolen = 5.5e-4 + tolang = 2.e-11 + endif case default if (calc_gravitwaves .and. itest==1) then call checkvalbuf_end('grav. wave strain (x)',ncheckgw(1),nfailgw(1),errgw(1),tolgw) call checkvalbuf_end('grav. wave strain (+)',ncheckgw(2),nfailgw(2),errgw(2),tolgw) call update_test_scores(ntests,nfailgw(1:2),npass) endif - call checkval(angtot,angmomin,4.e-13,nfailed(3),'angular momentum') - call checkval(totmom,totmomin,epsilon(0.),nfailed(2),'linear momentum') tolen = 3.e-8 - if (itest==4) tolen = 1.6e-2 ! etot is small compared to ekin - if (itest==5) tolen = 9.e-1 end select ! !--check energy conservation ! - call checkval(etotin+errmax,etotin,tolen,nfailed(1),'total energy') + call checkval(angtot,angmomin,tolang,nfailed(1),'angular momentum') + call checkval(totmom,totmomin,tolmom,nfailed(2),'linear momentum') + call checkval(etotin+errmax,etotin,tolen,nfailed(3),'total energy') do i=1,3 call update_test_scores(ntests,nfailed(i:i),npass) enddo From 99c8f03038b90f20eb0c94f3348fa58d8498834b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 22 Apr 2024 14:15:19 +1000 Subject: [PATCH 455/814] added missing routine to quintic module --- src/main/kernel_quintic.f90 | 31 ++++++++++++++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) diff --git a/src/main/kernel_quintic.f90 b/src/main/kernel_quintic.f90 index 1c8a0d5fb..4e9dd282e 100644 --- a/src/main/kernel_quintic.f90 +++ b/src/main/kernel_quintic.f90 @@ -17,7 +17,7 @@ module kernel ! ! :Dependencies: physcon ! -! :Generated: 2024-04-08 15:20:46.747398 +! :Generated: 2024-04-22 14:12:57.936556 ! !-------------------------------------------------------------------------- use physcon, only:pi @@ -155,6 +155,35 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4, q6, q8 + + if (q < 1.) then + gsoft = q2*q*(-175.*q2*q + 480.*q2 - 672.)/840. + elseif (q < 2.) then + q4 = q2*q2 + q6 = q4*q2 + q8 = q6*q2 + gsoft = (175.*q8 - 1440.*q6*q + 4200.*q6 - 4704.*q4*q + 1050.*q4 - & + 15.)/(1680.*q2) + elseif (q < 3.) then + q4 = q2*q2 + q6 = q4*q2 + q8 = q6*q2 + gsoft = (-35.*q8 + 480.*q6*q - 2520.*q6 + 6048.*q4*q - 5670.*q4 + & + 1521.)/(1680.*q2) + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations From 0838eb218c6f3832f814b7b67c9ee452c851a6f4 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 22 Apr 2024 15:56:48 +1000 Subject: [PATCH 456/814] #457 adjust tolerances for test ptmass --- src/tests/test_ptmass.f90 | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index a9ebdb07c..e144e9043 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -327,7 +327,7 @@ subroutine test_binary(ntests,npass) if (itest==2 .or. itest==3 .or. itest==5) then norbits = 10 else - norbits = 10 + norbits = 100 endif if (id==master) print*,'steps/orbit = ',nsteps,' norbits = ',norbits,' dt = ',dt nsteps = nsteps*norbits @@ -360,8 +360,8 @@ subroutine test_binary(ntests,npass) call compute_energies(t) if (id==master) call printused(t1) nfailed(:) = 0 - tolmom = 5.e-15 - tolang = 1.e-14 + tolmom = 2.e-14 + tolang = 2.e-14 select case(itest) case(5) tolen = 9.e-1 @@ -369,19 +369,13 @@ subroutine test_binary(ntests,npass) tolmom = 1.e-14 tolen = 1.6e-2 case(3) - if (ind_timesteps) then - tolang = 2.1e-6 - endif + tolang = 2.1e-6 tolen = 1.2e-2 - if (use_fourthorder) then - tolen = 5.5e-4 - endif case(2) - tolen = 2.e-3 + tolen = 1.2e-3 if (gravity) tolen = 3.1e-3 if (use_fourthorder) then - tolen = 5.5e-4 tolang = 2.e-11 endif case default From c4045eb8826305cececd7c9d51294d98dd1c05a8 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 22 Apr 2024 16:09:12 +1000 Subject: [PATCH 457/814] fix bad tolerance wihout ind timestep --- src/tests/test_ptmass.f90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index e144e9043..58b003d1f 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -369,7 +369,11 @@ subroutine test_binary(ntests,npass) tolmom = 1.e-14 tolen = 1.6e-2 case(3) - tolang = 2.1e-6 + if (ind_timesteps) then + tolang = 2.1e-6 + else + tolang = 2.e-10 + endif tolen = 1.2e-2 case(2) tolen = 1.2e-3 From 5d380f64825d6097b3988c5a41a49f92e4d0ac03 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 22 Apr 2024 16:13:06 +1000 Subject: [PATCH 458/814] (test_ptmass) added ptmassfsi to run the FSI integrator only; also fix weird build failure with ifort on Mac --- build/Makefile | 3 ++- src/tests/test_ptmass.f90 | 25 +++++++++++++++++-------- 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/build/Makefile b/build/Makefile index 86b4fa780..2f9e2e75e 100644 --- a/build/Makefile +++ b/build/Makefile @@ -679,6 +679,7 @@ else SRCTESTMPI = 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 \ test_nonidealmhd.F90 directsum.f90 test_gravity.f90 \ @@ -689,7 +690,7 @@ SRCTESTS=utils_testsuite.f90 ${TEST_FASTMATH} test_kernel.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 \ ${SRCTESTMPI} test_sedov.F90 test_poly.f90 test_radiation.F90 \ - testsuite.F90 phantomtest.f90 + testsuite.F90 setup_params.f90 phantomtest.f90 ifeq (X$(SRCTEST), X) SRCTEST=${SRCTESTS} diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index a9ebdb07c..460660ed7 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -36,7 +36,7 @@ subroutine test_ptmass(ntests,npass,string) character(len=*), intent(in) :: string character(len=20) :: filename integer, intent(inout) :: ntests,npass - integer :: itmp,ierr,itest + integer :: itmp,ierr,itest,istart logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening,do_test_merger logical :: testall @@ -48,6 +48,7 @@ subroutine test_ptmass(ntests,npass,string) do_test_softening = .false. do_test_merger = .false. testall = .false. + istart = 1 select case(trim(string)) case('ptmassbinary') do_test_binary = .true. @@ -59,6 +60,11 @@ subroutine test_ptmass(ntests,npass,string) do_test_softening = .true. case('ptmassmerger') do_test_merger = .true. + case('ptmassfsi') + istart = 2 + do_test_binary = .true. + do_test_softening = .true. + do_test_merger = .true. case default testall = .true. end select @@ -70,7 +76,7 @@ subroutine test_ptmass(ntests,npass,string) iexternalforce = 0 alpha = 0.01 use_fourthorder = .false. - do itest=1,2 + do itest=istart,2 ! ! select order of integration ! @@ -156,6 +162,7 @@ subroutine test_binary(ntests,npass) real :: fxyz_sinksink(4,2),dsdt_sinksink(3,2) ! we only use 2 sink particles in the tests here real(kind=4) :: t1 character(len=20) :: dumpfile + character(len=40) :: string real, parameter :: tolgw = 1.2e-2 ! !--no gas particles @@ -171,32 +178,34 @@ subroutine test_binary(ntests,npass) tolv = 1e-2 binary_tests: do itest = 1,nbinary_tests + string = '' + if (use_fourthorder) string = ' with Forward Symplectic Integrator' select case(itest) case(4) if (use_fourthorder) then if (id==master) write(*,"(/,a)") '--> skipping integration of binary orbit with oblateness with FSI' cycle binary_tests else - if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit with oblateness' + if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit with oblateness'//trim(string) endif case(2,3,5) if (periodic) then if (id==master) write(*,"(/,a)") '--> skipping circumbinary disc test (-DPERIODIC is set)' cycle binary_tests - elseif(use_fourthorder .and. itest==5) then + elseif (use_fourthorder .and. itest==5) then if (id==master) write(*,"(/,a)") '--> skipping circumbinary disc around oblate star test with FSI' cycle binary_tests else if (itest==5) then - if (id==master) write(*,"(/,a)") '--> testing integration of disc around oblate star' + if (id==master) write(*,"(/,a)") '--> testing integration of disc around oblate star'//trim(string) elseif (itest==3) then - if (id==master) write(*,"(/,a)") '--> testing integration of disc around eccentric binary' + if (id==master) write(*,"(/,a)") '--> testing integration of disc around eccentric binary'//trim(string) else - if (id==master) write(*,"(/,a)") '--> testing integration of circumbinary disc' + if (id==master) write(*,"(/,a)") '--> testing integration of circumbinary disc'//trim(string) endif endif case default - if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit' + if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit'//trim(string) end select ! !--setup sink-sink binary (no gas particles) From f5242a77120841b9d694cf3c6c1645084e927c87 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 22 Apr 2024 16:24:27 +1000 Subject: [PATCH 459/814] fix tolerances 2 --- src/tests/test_ptmass.f90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index abf1f52d5..05114e2b3 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -381,7 +381,7 @@ subroutine test_binary(ntests,npass) if (ind_timesteps) then tolang = 2.1e-6 else - tolang = 2.e-10 + tolang = 6.e-10 endif tolen = 1.2e-2 case(2) @@ -397,7 +397,11 @@ subroutine test_binary(ntests,npass) call checkvalbuf_end('grav. wave strain (+)',ncheckgw(2),nfailgw(2),errgw(2),tolgw) call update_test_scores(ntests,nfailgw(1:2),npass) endif - tolen = 3.e-8 + if (use_fourthorder) then + tolen = 3.e-8 + else + tolen = 1.e-13 + endif end select ! !--check energy conservation From 426221a9a97a082481c313efcdc4c2fcf3b56054 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 22 Apr 2024 16:28:24 +1000 Subject: [PATCH 460/814] fix tolerances v3 --- src/tests/test_ptmass.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 05114e2b3..15392eb73 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -398,9 +398,9 @@ subroutine test_binary(ntests,npass) call update_test_scores(ntests,nfailgw(1:2),npass) endif if (use_fourthorder) then - tolen = 3.e-8 - else tolen = 1.e-13 + else + tolen = 3.e-8 endif end select ! From 5e68b149a4e41017bc828f35967c0eaf9dc2d7c7 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 22 Apr 2024 16:43:08 +0200 Subject: [PATCH 461/814] (moddump_removeparticles) tweak prompt message --- src/utils/moddump_removeparticles_radius.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/moddump_removeparticles_radius.f90 b/src/utils/moddump_removeparticles_radius.f90 index d9bbd3e94..65bad1b90 100644 --- a/src/utils/moddump_removeparticles_radius.f90 +++ b/src/utils/moddump_removeparticles_radius.f90 @@ -42,13 +42,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)) From dc41fc51ec0d25d1df4080d8a0461f583fc9a908 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 23 Apr 2024 12:22:56 +1000 Subject: [PATCH 462/814] accounting for epot from subgroups --- src/main/energies.F90 | 14 +- src/main/sdar_group.f90 | 286 ++++++++++++++++----------------------- src/main/substepping.F90 | 4 +- 3 files changed, 130 insertions(+), 174 deletions(-) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 27684ce97..9af4f5a66 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -70,7 +70,7 @@ subroutine compute_energies(t) isdead_or_accreted,epot_sinksink,imacc,ispinx,ispiny,& ispinz,mhd,gravity,poten,dustfrac,eos_vars,itemp,igasP,ics,& nden_nimhd,eta_nimhd,iion,ndustsmall,graindens,grainsize,& - iamdust,ndusttypes,rad,iradxi + iamdust,ndusttypes,rad,iradxi,gtgrad,group_info,n_group use part, only:pxyzu,fxyzu,fext use gravwaveutils, only:calculate_strain,calc_gravitwaves use centreofmass, only:get_centreofmass_accel @@ -80,7 +80,8 @@ subroutine compute_energies(t) use externalforces, only:externalforce,externalforce_vdependent,was_accreted,accradius1 use options, only:iexternalforce,calc_erot,alpha,ieos,use_dustfrac use mpiutils, only:reduceall_mpi - use ptmass, only:get_accel_sink_gas + use ptmass, only:get_accel_sink_gas,use_regnbody + use sdar_group, only:get_pot_subsys use viscosity, only:irealvisc,shearfunc use nicil, only:nicil_update_nimhd,nicil_get_halldrift,nicil_get_ambidrift, & use_ohm,use_hall,use_ambi,n_data_out,n_warn,eta_constant @@ -600,7 +601,14 @@ subroutine compute_energies(t) emag = reduceall_mpi('+',emag) epot = reduceall_mpi('+',epot) erad = reduceall_mpi('+',erad) - if (nptmass > 1) epot = epot + epot_sinksink + if (nptmass > 1) then + if (use_regnbody) then + call get_pot_subsys(n_group,nptmass,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + endif + epot = epot + epot_sinksink + endif + + etot = ekin + etherm + emag + epot + erad diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index ef482c39b..81c015365 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -11,6 +11,7 @@ module sdar_group implicit none public :: group_identify public :: evolve_groups + public :: get_pot_subsys ! parameters for group identification real, parameter :: eta_pert = 20 real, parameter :: time_error = 2.5e-14 @@ -239,13 +240,14 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ismultiple = gsize > 2 if(ismultiple) then - call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,start_id,end_id,ds_init) + call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,W,start_id,end_id,ds_init=ds_init) else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) - call initial_int_bin(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,prim,sec,ds_init) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,W,prim,sec,ds_init=ds_init) endif + allocate(bdata(gsize*6)) step_count_int = 0 @@ -556,15 +558,17 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t end subroutine oneStep_bin -subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id) +subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id,potonly,ds_init) use part, only: igarg - real, intent(in) :: xyzmh_ptmass(:,:) - real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) - integer,intent(in) :: group_info(:,:) - real, intent(out) :: om - integer, intent(in) :: s_id,e_id - real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,r - real :: gravf,gtki,gravfi(3),gtgradi(3) + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: group_info(:,:) + real, intent(out) :: om + integer, intent(in) :: s_id,e_id + logical, optional, intent(in) :: potonly + real, optional, intent(out) :: ds_init + real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3 + real :: gravf,gtki,gravfi(3),gtgradi(3),f2 integer :: i,j,k,l om = 0. @@ -589,38 +593,53 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) r2 = dx**2+dy**2+dz**2 - r = sqrt(r2) + ddr = 1./sqrt(r2) mj = xyzmh_ptmass(4,j) - gravf = mj*(1./(r2*r)) - gtki = gtki + mj*(1./r) - gravfi(1) = gravfi(1) + dx*gravf - gravfi(2) = gravfi(2) + dy*gravf - gravfi(3) = gravfi(3) + dz*gravf - gtgradi(1) = gtgradi(1) + dx*gravf*mi - gtgradi(2) = gtgradi(2) + dy*gravf*mi - gtgradi(3) = gtgradi(3) + dz*gravf*mi + gtki = gtki + mj*ddr + if (.not.present(potonly)) then + ddr3 = ddr*ddr*ddr + gravf = mj*(1./ddr3) + gravfi(1) = gravfi(1) + dx*gravf + gravfi(2) = gravfi(2) + dy*gravf + gravfi(3) = gravfi(3) + dz*gravf + gtgradi(1) = gtgradi(1) + dx*gravf*mi + gtgradi(2) = gtgradi(2) + dy*gravf*mi + gtgradi(3) = gtgradi(3) + dz*gravf*mi + endif enddo - fxyz_ptmass(1,i) = gravfi(1) - fxyz_ptmass(2,i) = gravfi(2) - fxyz_ptmass(3,i) = gravfi(3) - gtgrad(1,i) = gtgradi(1) - gtgrad(2,i) = gtgradi(2) - gtgrad(3,i) = gtgradi(3) + fxyz_ptmass(4,i) = -gtki + if (.not.present(potonly)) then + fxyz_ptmass(1,i) = gravfi(1) + fxyz_ptmass(2,i) = gravfi(2) + fxyz_ptmass(3,i) = gravfi(3) + gtgrad(1,i) = gtgradi(1) + gtgrad(2,i) = gtgradi(2) + gtgrad(3,i) = gtgradi(3) + endif + if (present(ds_init)) then + f2 = gravfi(1)**2+gravfi(2)**2+gravfi(3)**2 + if (f2 > 0.) then + ds_init = min(ds_init,0.00002*sqrt(abs(gtki)/f2)) + endif + endif om = om + gtki*mi enddo om = om*0.5 + if(present(ds_init)) ds_init = ds_init/om end subroutine get_force_TTL -subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) +subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j,potonly,ds_init) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: i,j real, intent(out) :: om - real :: dx,dy,dz,r2,r,ddr3,mi,mj - real :: gravfi,gtki,gravfj + logical, optional, intent(in) :: potonly + real, optional, intent(out) :: ds_init + real :: dx,dy,dz,r2,ddr,ddr3,mi,mj,dsi,dsj + real :: gravfi,gravfj,gtki,gtkj,fxi,fyi,fzi,fxj,fyj,fzj,f2i,f2j mi = xyzmh_ptmass(4,i) mj = xyzmh_ptmass(4,j) @@ -628,160 +647,89 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) dy = xyzmh_ptmass(2,i) - xyzmh_ptmass(2,j) dz = xyzmh_ptmass(3,i) - xyzmh_ptmass(3,j) r2 = dx**2+dy**2+dz**2 - r = sqrt(r2) - ddr3 = (1./(r2*r)) + ddr = 1./sqrt(r2) + ddr3 = ddr*ddr*ddr gravfi = mj*ddr3 gravfj = mi*ddr3 - gtki = mj*(1./r) - - fxyz_ptmass(1,i) = -dx*gravfi - fxyz_ptmass(2,i) = -dy*gravfi - fxyz_ptmass(3,i) = -dz*gravfi - fxyz_ptmass(1,j) = dx*gravfj - fxyz_ptmass(2,j) = dy*gravfj - fxyz_ptmass(3,j) = dz*gravfj - - gtgrad(1,i) = -dx*gravfi*mi - gtgrad(2,i) = -dy*gravfi*mi - gtgrad(3,i) = -dz*gravfi*mi - gtgrad(1,j) = dx*gravfj*mj - gtgrad(2,j) = dy*gravfj*mj - gtgrad(3,j) = dz*gravfj*mj + gtki = mj*ddr + gtkj = mi*ddr + + + fxyz_ptmass(4,i) = -gtki + fxyz_ptmass(4,j) = -gtkj + if(.not.present(potonly)) then + fxi = -dx*gravfi + fyi = -dy*gravfi + fzi = -dz*gravfi + fxj = dx*gravfj + fyj = dy*gravfj + fzj = dz*gravfj + fxyz_ptmass(1,i) = fxi + fxyz_ptmass(2,i) = fyi + fxyz_ptmass(3,i) = fzi + fxyz_ptmass(1,j) = fxj + fxyz_ptmass(2,j) = fyj + fxyz_ptmass(3,j) = fzj + gtgrad(1,i) = -dx*gravfi*mi + gtgrad(2,i) = -dy*gravfi*mi + gtgrad(3,i) = -dz*gravfi*mi + gtgrad(1,j) = dx*gravfj*mj + gtgrad(2,j) = dy*gravfj*mj + gtgrad(3,j) = dz*gravfj*mj + endif om = gtki*mi -end subroutine get_force_TTL_bin - -subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e_id,ds_init) - use utils_kepler, only :extract_a_dot,extract_a,Espec - use part, only:igarg - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - real, intent(inout) :: fxyz_ptmass(:,:) - integer,intent(in) :: group_info(:,:) - real, intent(out) :: om,ds_init - integer, intent(in) :: s_id,e_id - real :: mi,mj,xi,yi,zi,dx,dy,dz,r,r2 - real :: vxi,vyi,vzi,v,dvx,dvy,dvz,rdotv,axi,ayi,azi,acc,gravrdotv - real :: gravf,gravfi(3),gtki - real :: Edot,E - integer :: k,l,i,j - - Edot = 0. - E = 0. - om = 0. - gravrdotv = 0. - - do k=s_id,e_id - i = group_info(igarg,k) - gtki = 0. - gravfi = 0. - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) - mi = xyzmh_ptmass(4,i) - vxi = vxyz_ptmass(1,i) - vyi = vxyz_ptmass(2,i) - vzi = vxyz_ptmass(3,i) - axi = fxyz_ptmass(1,i) - ayi = fxyz_ptmass(2,i) - azi = fxyz_ptmass(3,i) - gravfi(1) = 0. - gravfi(2) = 0. - gravfi(3) = 0. - do l=s_id,e_id - if (k==l) cycle - j = group_info(igarg,l) - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - dvx = vxi - vxyz_ptmass(1,j) - dvy = vyi - vxyz_ptmass(2,j) - dvz = vzi - vxyz_ptmass(3,j) - r2 = dx**2+dy**2+dz**2 - r = sqrt(r2) - mj = xyzmh_ptmass(4,j) - gravf = mj*(1./(r2*r)) - gtki = gtki + mj*(1./r) - gravfi(1) = gravfi(1) + dx*gravf - gravfi(2) = gravfi(2) + dy*gravf - gravfi(3) = gravfi(3) + dz*gravf - rdotv = dx*dvx + dy*dvy + dz*dvz - gravrdotv = gravrdotv + gravf*rdotv - enddo - om = om + gtki*mi - axi = axi + gravfi(1) - ayi = ayi + gravfi(2) - azi = azi + gravfi(3) - acc = sqrt(axi**2 + ayi**2 + azi**2) - v = sqrt(vxi**2 + vyi**2 + vzi**2) - Edot = Edot + mi*(v*acc - gravrdotv) - E = E + 0.5*mi*v**2 - gtki - enddo - - ds_init = eta_pert * abs(E/Edot) - om = om*0.5 - -end subroutine initial_int - -subroutine initial_int_bin(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,i,j,ds_init) - use utils_kepler, only :extract_a_dot,extract_a,Espec - use part, only:igarg - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - real, intent(inout) :: fxyz_ptmass(:,:) - integer,intent(in) :: group_info(:,:) - real, intent(out) :: om,ds_init - integer, intent(in) :: i,j - real :: mi,mj,mu,dx,dy,dz,r,r2,ddr3 - real :: v,v2,dvx,dvy,dvz - real :: dax,day,daz,acc - real :: gravfi,gravfj,gtki - real :: semi,semidot - - om = 0. - - - - mi = xyzmh_ptmass(4,i) - mj = xyzmh_ptmass(4,j) - dx = xyzmh_ptmass(1,i) - xyzmh_ptmass(1,j) - dy = xyzmh_ptmass(2,i) - xyzmh_ptmass(2,j) - dz = xyzmh_ptmass(3,i) - xyzmh_ptmass(3,j) - dvx = vxyz_ptmass(1,i) - vxyz_ptmass(1,j) - dvy = vxyz_ptmass(2,i) - vxyz_ptmass(2,j) - dvz = vxyz_ptmass(3,i) - vxyz_ptmass(3,j) + if (present(ds_init) .and. .not.present(potonly)) then + f2i = fxi**2+fyi**2+fzi**2 + f2j = fxj**2+fyj**2+fzj**2 + dsi = sqrt(abs(gtki)/f2i) + dsj = sqrt(abs(gtkj)/f2j) + ds_init = 0.000125*min(dsi,dsj)*om + endif - r2 = dx**2+dy**2+dz**2 - r = sqrt(r2) - v2 = dvx**2 + dvy**2 + dvz**2 - v = sqrt(v2) - ddr3 = (1./(r2*r)) - gravfi = mj*ddr3 - gravfj = mi*ddr3 - gtki = mj*(1./r) +end subroutine get_force_TTL_bin - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) - dx*gravfi - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) - dy*gravfi - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) - dz*gravfi - fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + dx*gravfj - fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + dy*gravfj - fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + dz*gravfj - dax = fxyz_ptmass(1,i) - fxyz_ptmass(1,j) - day = fxyz_ptmass(2,i) - fxyz_ptmass(2,j) - daz = fxyz_ptmass(3,i) - fxyz_ptmass(3,j) +subroutine get_pot_subsys(n_group,nptmass,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + use part, only: igarg,igcum + use io, only: id,master + integer, intent(in) :: n_group,nptmass + real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: group_info(:,:) + real, intent(inout) :: epot_sinksink + integer :: i,start_id,end_id,gsize,prim,sec + real :: phitot + phitot = 0. + if (n_group>0) then + if(id==master) then + !$omp parallel do default(none)& + !$omp shared(xyzmh_ptmass,fxyz_ptmass)& + !$omp shared(group_info,gtgrad)& + !$omp private(i,start_id,end_id,gsize,prim,sec)& + !$omp reduction(+:phitot) + do i=1,n_group + start_id = group_info(igcum,i) + 1 + end_id = group_info(igcum,i+1) + gsize = (end_id - start_id) + 1 + if (gsize>2) then + call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,phitot,start_id,end_id,.true.) + else + prim = group_info(igarg,start_id) + sec = group_info(igarg,end_id) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phitot,prim,sec,.true.) + endif + enddo + !$omp end parallel do + endif + endif - acc = sqrt(dax**2 + day**2 + daz**2) - mu = mi*mj + epot_sinksink = epot_sinksink - phitot - call extract_a_dot(r2,r,mu,v2,v,acc,semidot) - call extract_a(r,mu,v2,semi) - ds_init = eta_pert * abs(semi/semidot) - om = gtki*mi - print*,abs(semidot/semi),5.e-5/(r2*acc/(mi+mj)),ds_init +end subroutine get_pot_subsys -end subroutine initial_int_bin end module sdar_group diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 54234da06..956b91db4 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -558,10 +558,10 @@ end subroutine substep !---------------------------------------------------------------- subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & dsdt_ptmass,dptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) - use part, only:isdead_or_accreted,igas,massoftype,fxyz_ptmass_sinksink + use part, only:isdead_or_accreted,igas,massoftype,fxyz_ptmass_sinksink,epot_sinksink use io, only:iverbose,id,master,iprint,warning,fatal use io_summary, only:summary_variable,iosumextr,iosumextt - use sdar_group, only:group_identify,evolve_groups + use sdar_group, only:group_identify,evolve_groups,get_pot_subsys use options, only:iexternalforce use externalforces, only:is_velocity_dependent real, intent(in) :: dtsph,time From ddb148fe9a65fbeef261d180ad97db79caa9a6b1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 23 Apr 2024 14:13:39 +1000 Subject: [PATCH 463/814] fix substep with sub --- src/main/substepping.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 3e723361a..eaea883dd 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -557,6 +557,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx use sdar_group, only:group_identify,evolve_groups,get_pot_subsys use options, only:iexternalforce use externalforces, only:is_velocity_dependent + use ptmass, only:dk,ck real, intent(in) :: dtsph,time integer, intent(in) :: npart,nptmass,ntypes real, intent(inout) :: dtextforce @@ -569,7 +570,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx integer(kind=1), intent(in) :: nbinmax integer(kind=1), intent(inout) :: ibin_wake(:) integer, intent(inout) :: n_ingroup,n_group,n_sing - logical :: extf_vdep_flag,done,last_step + logical :: extf_vdep_flag,done,last_step,accreted integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step real :: dtextforce_min,pmassi @@ -610,7 +611,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) fsink_old = fxyz_ptmass call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) @@ -621,10 +622,10 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass, & - dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt dtextforce_min = min(dtextforce_min,dtextforce) @@ -999,7 +1000,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real :: fextx,fexty,fextz,xi,yi,zi,pmassi,damp_fac real :: fonrmaxi,phii,dtphi2i real :: dkdt,extrapfac - logical :: extrap,last + logical :: extrap,last,wsub if(present(fsink_old)) then fsink_old = fxyz_ptmass From b755a8c1621f56b10df7b2fc5f1471644460a5ee Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 23 Apr 2024 15:13:38 +1000 Subject: [PATCH 464/814] (ptmass) bug fix running one sink particle in an external potential --- src/main/ptmass.F90 | 4 ++-- src/main/substepping.F90 | 13 +++++-------- 2 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 798c52ed1..abcbe5d7c 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -333,7 +333,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin phitot = 0. merge_n = 0 merge_ij = 0 - if (nptmass <= 1) return + 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 extrap = .true. @@ -520,7 +520,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin ! so that with the default C_force of ~0.25 we get a few ! hundred steps per orbit ! - if (f2 > 0. .and. nptmass > 1) then + if (f2 > 0. .and. (nptmass > 1 .or. (nptmass > 0 .and. iexternalforce > 0))) then dtsinksink = min(dtsinksink,dtfacphi*sqrt(abs(phii)/f2)) endif enddo diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 643885c06..cbe098eeb 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -817,7 +817,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real :: dkdt,extrapfac logical :: extrap,last - if(present(fsink_old)) then + if (present(fsink_old)) then fsink_old = fxyz_ptmass extrap = .true. else @@ -845,7 +845,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! !-- Sink-sink interactions (loop over ptmass in get_accel_sink_sink) ! - if (nptmass>0) then + if (nptmass > 0) then if (id==master) then if (extrap) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& @@ -914,8 +914,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, yi = xyzh(2,i) zi = xyzh(3,i) endif - if (nptmass>0) then - if(extrap) then + if (nptmass > 0) then + 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) @@ -975,7 +975,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, endif if (last) then - if(nptmass>0) then + if (nptmass > 0) then if (fonrmax > 0.) then dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) endif @@ -989,9 +989,6 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, end subroutine get_force - - - !----------------------------------------------------------------------------------- !+ ! Update of abundances and internal energy using cooling method (see cooling module) From 008248c562de93cacd43ab62eb84162c6834d9d9 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 23 Apr 2024 18:26:58 +1000 Subject: [PATCH 465/814] (chinchen) bug fix with Chinese coin problem; now works correctly if mass1 /= 1 --- src/main/extern_binary.f90 | 7 +++++++ src/main/ptmass.F90 | 2 +- src/setup/setup_chinchen.f90 | 5 +++-- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/src/main/extern_binary.f90 b/src/main/extern_binary.f90 index d22725666..3a3c83e96 100644 --- a/src/main/extern_binary.f90 +++ b/src/main/extern_binary.f90 @@ -234,6 +234,7 @@ subroutine write_options_externbinary(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit + call write_inopt(mass1,'mass1','m1 of central binary system (if iexternalforce=binary)',iunit) call write_inopt(mass2,'mass2','m2 of central binary system (if iexternalforce=binary)',iunit) call write_inopt(accradius1,'accradius1','accretion radius of primary',iunit) call write_inopt(accradius2,'accradius2','accretion radius of secondary (if iexternalforce=binary)',iunit) @@ -259,6 +260,12 @@ subroutine read_options_externbinary(name,valstring,imatch,igotall,ierr) imatch = .true. igotall = .false. select case(trim(name)) + case('mass1') + read(valstring,*,iostat=ierr) mass1 + ngot = ngot + 1 + if (mass1 < 0.) then + call fatal(where,'invalid setting for m1 (<0)') + endif case('mass2') read(valstring,*,iostat=ierr) mass2 ngot = ngot + 1 diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index abcbe5d7c..ce41e6adf 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -520,7 +520,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin ! so that with the default C_force of ~0.25 we get a few ! hundred steps per orbit ! - if (f2 > 0. .and. (nptmass > 1 .or. (nptmass > 0 .and. iexternalforce > 0))) then + if (f2 > 0. .and. (nptmass > 1 .or. iexternalforce > 0)) then dtsinksink = min(dtsinksink,dtfacphi*sqrt(abs(phii)/f2)) endif enddo diff --git a/src/setup/setup_chinchen.f90 b/src/setup/setup_chinchen.f90 index 708700567..66c97168a 100644 --- a/src/setup/setup_chinchen.f90 +++ b/src/setup/setup_chinchen.f90 @@ -34,7 +34,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use physcon, only:solarm,au,pi use options, only:iexternalforce use externalforces, only:iext_binary - use extern_binary, only:mass2 + use extern_binary, only:mass2,mass1 use io, only:master use timestep, only:dtmax integer, intent(in) :: id @@ -79,7 +79,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, vxyz_ptmass(1,1) = 0.489765446 iexternalforce = iext_binary - mass2 = m1 + mass1 = 0.5 + mass2 = mass1 dtmax = 0.1*(9.*pi) end subroutine setpart From 9fe0315de18b339535046423fd1bb9e169cc428f Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 23 Apr 2024 22:20:06 +1000 Subject: [PATCH 466/814] (chinchen) added chinese coin problem to test suite --- src/main/substepping.F90 | 45 +++++++--------- src/tests/test_ptmass.f90 | 107 ++++++++++++++++++++++++++++++++++---- src/tests/testsuite.F90 | 2 +- 3 files changed, 118 insertions(+), 36 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index cbe098eeb..1e9b1de90 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -425,8 +425,8 @@ end subroutine substep_sph !+ !---------------------------------------------------------------- subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & - fsink_old,nbinmax,ibin_wake) + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & + fsink_old,nbinmax,ibin_wake) use io, only:iverbose,id,master,iprint,fatal use options, only:iexternalforce use part, only:fxyz_ptmass_sinksink @@ -456,7 +456,6 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & last_step = .true. endif - timei = time time_par = time extf_vdep_flag = is_velocity_dependent(iexternalforce) @@ -515,7 +514,6 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & endif - dtextforce_min = min(dtextforce_min,dtextforce) if (last_step) then @@ -530,8 +528,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & enddo substeps if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + if (iverbose >=1 .and. id==master) then + write(iprint,"(a,i6,a,f9.2,a,es10.3,a,es10.3)") & ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph endif call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) @@ -771,16 +769,15 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, end subroutine kick - !---------------------------------------------------------------- - !+ - ! force routine for the whole system. First is computed the - ! sink/sink interaction and extf on sink, then comes forces - ! on gas. sink/gas, extf and dampening. Finally there is an - ! update of abundances and temp depending on cooling method - ! during the last force calculation of the substep. - !+ - !---------------------------------------------------------------- - +!---------------------------------------------------------------- +!+ +! force routine for the whole system. First is computed the +! sink/sink interaction and extf on sink, then comes forces +! on gas. sink/gas, extf and dampening. Finally there is an +! update of abundances and temp depending on cooling method +! during the last force calculation of the substep. +!+ +!---------------------------------------------------------------- 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,fsink_old) @@ -835,15 +832,13 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, fonrmax = 0 last = (force_count == n_force_order) -! -! update time-dependent external forces -! + ! + ! update time-dependent external forces + ! call calc_damp(timei, damp_fac) - call update_externalforce(iexternalforce,timei,dmdt) - ! - !-- Sink-sink interactions (loop over ptmass in get_accel_sink_sink) + ! Sink-sink interactions (loop over ptmass in get_accel_sink_sink) ! if (nptmass > 0) then if (id==master) then @@ -859,11 +854,11 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, endif else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) if (merge_n > 0) then call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) fxyz_ptmass_sinksink=fxyz_ptmass dsdt_ptmass_sinksink=dsdt_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf @@ -979,7 +974,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (fonrmax > 0.) then dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) endif - if (iverbose >= 2 ) write(iprint,*) nsubsteps,'dt,(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas + if (iverbose >= 2) write(iprint,*) nsubsteps,'dt(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas dtextforcenew = min(dtextforcenew,dtsinkgas) endif diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 15392eb73..f8a5cf2df 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -35,9 +35,11 @@ subroutine test_ptmass(ntests,npass,string) use ptmass, only:use_fourthorder,set_integration_precision character(len=*), intent(in) :: string character(len=20) :: filename + character(len=40) :: stringf integer, intent(inout) :: ntests,npass integer :: itmp,ierr,itest,istart - logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening,do_test_merger + logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening + logical :: do_test_chinese_coin,do_test_merger logical :: testall if (id==master) write(*,"(/,a,/)") '--> TESTING PTMASS MODULE' @@ -47,6 +49,7 @@ subroutine test_ptmass(ntests,npass,string) do_test_createsink = .false. do_test_softening = .false. do_test_merger = .false. + do_test_chinese_coin = .false. testall = .false. istart = 1 select case(trim(string)) @@ -60,7 +63,9 @@ subroutine test_ptmass(ntests,npass,string) do_test_softening = .true. case('ptmassmerger') do_test_merger = .true. - case('ptmassfsi') + case('ptmasschinchen','ptmasscoin','chinchen','coin','chinesecoin') + do_test_chinese_coin = .true. + case('ptmassfsi','fsi') istart = 2 do_test_binary = .true. do_test_softening = .true. @@ -75,22 +80,31 @@ subroutine test_ptmass(ntests,npass,string) gamma = 1. iexternalforce = 0 alpha = 0.01 - use_fourthorder = .false. do itest=istart,2 ! ! select order of integration ! - if (itest == 2) use_fourthorder = .true. + if (itest == 2) then + use_fourthorder = .true. + stringf = ' with Forward Symplectic Integrator' + else + use_fourthorder = .false. + stringf = ' with Leapfrog Integrator' + endif call set_integration_precision ! ! Tests of a sink particle binary ! - if (do_test_binary .or. testall) call test_binary(ntests,npass) + if (do_test_binary .or. testall) call test_binary(ntests,npass,stringf) ! ! Test of softening between sinks ! if (do_test_softening .or. testall) call test_softening(ntests,npass) ! + ! Test of Chinese Coin problem + ! + if (do_test_chinese_coin .or. testall) call test_chinese_coin(ntests,npass,stringf) + ! ! Test sink particle mergers ! if (do_test_merger .or. testall) call test_merger(ntests,npass) @@ -128,7 +142,7 @@ end subroutine test_ptmass ! Unit tests of a sink particle binary orbit !+ !----------------------------------------------------------------------- -subroutine test_binary(ntests,npass) +subroutine test_binary(ntests,npass,string) use dim, only:periodic,gravity,ind_timesteps use io, only:id,master,iverbose use physcon, only:pi,deg_to_rad @@ -152,7 +166,8 @@ subroutine test_binary(ntests,npass) use deriv, only:get_derivs_global use timing, only:getused,printused use options, only:ipdv_heating,ishock_heating - integer, intent(inout) :: ntests,npass + integer, intent(inout) :: ntests,npass + character(len=*), intent(in) :: string integer :: i,ierr,itest,nfailed(3),nsteps,nerr,nwarn,norbits integer :: merge_ij(2),merge_n,nparttot,nfailgw(2),ncheckgw(2) integer, parameter :: nbinary_tests = 5 @@ -162,7 +177,6 @@ subroutine test_binary(ntests,npass) real :: fxyz_sinksink(4,2),dsdt_sinksink(3,2) ! we only use 2 sink particles in the tests here real(kind=4) :: t1 character(len=20) :: dumpfile - character(len=40) :: string real, parameter :: tolgw = 1.2e-2 ! !--no gas particles @@ -178,8 +192,6 @@ subroutine test_binary(ntests,npass) tolv = 1e-2 binary_tests: do itest = 1,nbinary_tests - string = '' - if (use_fourthorder) string = ' with Forward Symplectic Integrator' select case(itest) case(4) if (use_fourthorder) then @@ -522,6 +534,81 @@ subroutine test_softening(ntests,npass) end subroutine test_softening +!----------------------------------------------------------------------- +!+ +! Test Chinese Coin problem from Chin & Chen (2005) +!+ +!----------------------------------------------------------------------- +subroutine test_chinese_coin(ntests,npass,string) + use io, only:id,master,iverbose + use part, only:xyzmh_ptmass,vxyz_ptmass,ihacc,nptmass,npart,npartoftype,fxyz_ptmass,dsdt_ptmass + use extern_binary, only:mass1,mass2 + use options, only:iexternalforce + use externalforces, only:iext_binary + use physcon, only:pi + use step_lf_global, only:step + use ptmass, only:use_fourthorder,get_accel_sink_sink + integer, intent(inout) :: ntests,npass + character(len=*), intent(in) :: string + character(len=10) :: tag + integer :: nfailed(3),merge_ij(1),merge_n,norbit + real :: t,dtorb,dtnew,dtext,tmax,epot_sinksink,y0,v0 + real :: tol_per_orbit_y,tol_per_orbit_v + + if (id==master) write(*,"(/,a)") '--> testing Chinese coin problem'//trim(string) + + ! no gas + npart = 0 + npartoftype = 0 + + ! add a single sink particle + y0 = 0.0580752367; v0 = 0.489765446 + nptmass = 1 + xyzmh_ptmass = 0. + xyzmh_ptmass(2,1) = y0 + xyzmh_ptmass(4,1) = 1.0 + xyzmh_ptmass(ihacc,1) = 0.1 + vxyz_ptmass = 0. + vxyz_ptmass(1,1) = v0 + + ! external binary + iexternalforce = iext_binary + mass1 = 0.5 + mass2 = mass1 + dtorb = 9.*pi + tmax = 3.*dtorb + + t = 0. + dtext = 1.e-15 + iverbose = 1 + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtext,iexternalforce,t,merge_ij,merge_n,dsdt_ptmass) + + dtext = 1.e-15 ! take small first step + norbit = 0 + nfailed(:) = 0 + tol_per_orbit_y = 2.5e-2 + tol_per_orbit_v = 1.15e-2 + if (use_fourthorder) then + tol_per_orbit_y = 1.1e-3 + tol_per_orbit_v = 3.35e-4 + endif + do while (t < tmax) + ! do a whole orbit but with the substepping handling how many steps per orbit + call step(npart,npart,t,dtorb,dtext,dtnew) + t = t + dtorb + norbit = norbit + 1 + + write(tag,"(a,i1,a)") '(orbit ',norbit,')' + call checkval(xyzmh_ptmass(2,1),y0,norbit*tol_per_orbit_y,nfailed(1),'y pos of sink '//trim(tag)) + call checkval(vxyz_ptmass(1,1),v0,norbit*tol_per_orbit_v,nfailed(2),'x vel of sink '//trim(tag)) + enddo + + call update_test_scores(ntests,nfailed(1:2),npass) + iverbose = 0 ! reset verbosity + +end subroutine test_chinese_coin + !----------------------------------------------------------------------- !+ ! Test accretion of gas particles onto sink particles diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index c7773d141..d3bf32d13 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -171,7 +171,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) dokdtree = .true. case('step') dostep = .true. - case('ptmass','sink') + case('ptmass','sink','fsi','chinchen','coin') doptmass = .true. case('gnewton') dognewton = .true. From e50a80df819c76f21b670adcbbbc018a52a7244d Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 23 Apr 2024 22:32:45 +1000 Subject: [PATCH 467/814] (test_ptmass) reset iexternalforce=0 after finishing test --- src/tests/test_ptmass.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index f8a5cf2df..fb35f7517 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -606,6 +606,7 @@ subroutine test_chinese_coin(ntests,npass,string) call update_test_scores(ntests,nfailed(1:2),npass) iverbose = 0 ! reset verbosity + iexternalforce = 0 end subroutine test_chinese_coin From a18cc75dc05ef898d204ba46e7587c9d45d573db Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 24 Apr 2024 09:00:40 +1000 Subject: [PATCH 468/814] (chinchen) bug fix in Chinese coin test with DEBUG=yes --- src/main/ptmass.F90 | 4 +++- src/main/substepping.F90 | 4 ++-- src/tests/test_ptmass.f90 | 17 +++++++++-------- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index ce41e6adf..e111dd4dc 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1632,7 +1632,8 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_i end subroutine merge_sinks subroutine set_integration_precision - if(use_fourthorder) then + + if (use_fourthorder) then n_force_order = 3 ck = ck4 dk = dk4 @@ -1645,6 +1646,7 @@ subroutine set_integration_precision dtfacphi = dtfacphilf dtfacphi2 = dtfacphi2lf endif + end subroutine set_integration_precision !----------------------------------------------------------------------- diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 1e9b1de90..f7d5ce219 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -529,8 +529,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & if (nsubsteps > 1) then if (iverbose >=1 .and. id==master) then - write(iprint,"(a,i6,a,f9.2,a,es10.3,a,es10.3)") & -' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + write(iprint,"(a,i6,3(a,es10.3))") ' using ',nsubsteps,' substeps '//& + '(dthydro/dtextf =',dtsph/dtextforce_min,'), dt =',dtextforce_min,' dtsph =',dtsph endif call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index fb35f7517..3d811374f 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -28,11 +28,11 @@ module testptmass contains subroutine test_ptmass(ntests,npass,string) - use io, only:id,master,iskfile - use eos, only:polyk,gamma - use part, only:nptmass - use options, only:iexternalforce,alpha - use ptmass, only:use_fourthorder,set_integration_precision + use io, only:id,master,iskfile + use eos, only:polyk,gamma + use part, only:nptmass + use options, only:iexternalforce,alpha + use ptmass, only:use_fourthorder,set_integration_precision character(len=*), intent(in) :: string character(len=20) :: filename character(len=40) :: stringf @@ -89,7 +89,7 @@ subroutine test_ptmass(ntests,npass,string) stringf = ' with Forward Symplectic Integrator' else use_fourthorder = .false. - stringf = ' with Leapfrog Integrator' + stringf = ' with Leapfrog integrator' endif call set_integration_precision ! @@ -544,7 +544,7 @@ subroutine test_chinese_coin(ntests,npass,string) use part, only:xyzmh_ptmass,vxyz_ptmass,ihacc,nptmass,npart,npartoftype,fxyz_ptmass,dsdt_ptmass use extern_binary, only:mass1,mass2 use options, only:iexternalforce - use externalforces, only:iext_binary + use externalforces, only:iext_binary,update_externalforce use physcon, only:pi use step_lf_global, only:step use ptmass, only:use_fourthorder,get_accel_sink_sink @@ -555,7 +555,7 @@ subroutine test_chinese_coin(ntests,npass,string) real :: t,dtorb,dtnew,dtext,tmax,epot_sinksink,y0,v0 real :: tol_per_orbit_y,tol_per_orbit_v - if (id==master) write(*,"(/,a)") '--> testing Chinese coin problem'//trim(string) + if (id==master) write(*,"(/,a)") '--> testing Chinese coin problem'//trim(string)//' (coin)' ! no gas npart = 0 @@ -581,6 +581,7 @@ subroutine test_chinese_coin(ntests,npass,string) t = 0. dtext = 1.e-15 iverbose = 1 + call update_externalforce(iexternalforce,t,0.) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtext,iexternalforce,t,merge_ij,merge_n,dsdt_ptmass) From 359e3b2681799f4f3a90b988dd5d4fe9ad4eedbc Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 24 Apr 2024 09:08:04 +1000 Subject: [PATCH 469/814] [header-bot] updated file headers --- src/main/checksetup.f90 | 2 +- src/main/extern_binary.f90 | 1 + src/main/kernel_WendlandC2.f90 | 3 --- src/main/kernel_WendlandC4.f90 | 3 --- src/main/kernel_WendlandC6.f90 | 3 --- src/main/kernel_quartic.f90 | 3 --- src/main/kernel_quintic.f90 | 3 --- src/main/step_leapfrog.F90 | 9 ++++----- src/main/substepping.F90 | 11 +++++------ src/setup/setup_starcluster.f90 | 8 ++++---- src/tests/test_eos.f90 | 2 +- src/tests/test_gr.f90 | 4 ++-- src/tests/test_ptmass.f90 | 7 ++++--- 13 files changed, 22 insertions(+), 37 deletions(-) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index eec4f19f0..39ac95b9b 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -16,7 +16,7 @@ module checksetup ! ! :Dependencies: boundary, boundary_dyn, centreofmass, dim, dust, eos, ! externalforces, io, metric_tools, nicil, options, part, physcon, -! ptmass_radiation, sortutils, timestep, units, utils_gr +! ptmass, ptmass_radiation, sortutils, timestep, units, utils_gr ! implicit none public :: check_setup diff --git a/src/main/extern_binary.f90 b/src/main/extern_binary.f90 index 3a3c83e96..1602453fc 100644 --- a/src/main/extern_binary.f90 +++ b/src/main/extern_binary.f90 @@ -19,6 +19,7 @@ module extern_binary ! - accradius2 : *accretion radius of secondary (if iexternalforce=binary)* ! - eps_soft1 : *Plummer softening of primary* ! - eps_soft2 : *Plummer softening of secondary* +! - mass1 : *m1 of central binary system (if iexternalforce=binary)* ! - mass2 : *m2 of central binary system (if iexternalforce=binary)* ! - ramp : *ramp up mass of secondary over first 5 orbits?* ! diff --git a/src/main/kernel_WendlandC2.f90 b/src/main/kernel_WendlandC2.f90 index 3500fbfa3..4dd74aa6f 100644 --- a/src/main/kernel_WendlandC2.f90 +++ b/src/main/kernel_WendlandC2.f90 @@ -17,9 +17,6 @@ module kernel ! ! :Dependencies: physcon ! -! :Generated: 2024-04-08 15:21:28.635699 -! -!-------------------------------------------------------------------------- use physcon, only:pi implicit none character(len=17), public :: kernelname = 'Wendland 2/3D C^2' diff --git a/src/main/kernel_WendlandC4.f90 b/src/main/kernel_WendlandC4.f90 index 0b83140f6..6a0ded877 100644 --- a/src/main/kernel_WendlandC4.f90 +++ b/src/main/kernel_WendlandC4.f90 @@ -17,9 +17,6 @@ module kernel ! ! :Dependencies: physcon ! -! :Generated: 2024-04-08 15:21:39.886138 -! -!-------------------------------------------------------------------------- use physcon, only:pi implicit none character(len=17), public :: kernelname = 'Wendland 2/3D C^4' diff --git a/src/main/kernel_WendlandC6.f90 b/src/main/kernel_WendlandC6.f90 index 16bc239fb..c6e54af66 100644 --- a/src/main/kernel_WendlandC6.f90 +++ b/src/main/kernel_WendlandC6.f90 @@ -17,9 +17,6 @@ module kernel ! ! :Dependencies: physcon ! -! :Generated: 2024-04-08 15:21:50.637883 -! -!-------------------------------------------------------------------------- use physcon, only:pi implicit none character(len=17), public :: kernelname = 'Wendland 2/3D C^6' diff --git a/src/main/kernel_quartic.f90 b/src/main/kernel_quartic.f90 index 32708fc27..de96a3432 100644 --- a/src/main/kernel_quartic.f90 +++ b/src/main/kernel_quartic.f90 @@ -17,9 +17,6 @@ module kernel ! ! :Dependencies: physcon ! -! :Generated: 2024-04-08 15:20:17.993158 -! -!-------------------------------------------------------------------------- use physcon, only:pi implicit none character(len=11), public :: kernelname = 'M_5 quartic' diff --git a/src/main/kernel_quintic.f90 b/src/main/kernel_quintic.f90 index 4e9dd282e..82e735192 100644 --- a/src/main/kernel_quintic.f90 +++ b/src/main/kernel_quintic.f90 @@ -17,9 +17,6 @@ module kernel ! ! :Dependencies: physcon ! -! :Generated: 2024-04-22 14:12:57.936556 -! -!-------------------------------------------------------------------------- use physcon, only:pi implicit none character(len=11), public :: kernelname = 'M_6 quintic' diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 724315733..84f4ada36 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -22,11 +22,10 @@ module step_lf_global ! ! :Runtime parameters: None ! -! :Dependencies: boundary_dyn, chem, cons2prim, cons2primsolver, cooling, -! cooling_ism, damping, deriv, dim, dust_formation, eos, extern_gr, -! externalforces, growth, io, io_summary, krome_interface, metric_tools, -! mpiutils, options, part, porosity, ptmass, ptmass_radiation, timestep, -! timestep_ind, timestep_sts, timing, units +! :Dependencies: boundary_dyn, cons2prim, cons2primsolver, cooling, +! damping, deriv, dim, eos, extern_gr, growth, io, io_summary, +! metric_tools, mpiutils, options, part, porosity, substepping, timestep, +! timestep_ind, timestep_sts, timing ! use dim, only:maxp,maxvxyzu,do_radiation,ind_timesteps use part, only:vpred,Bpred,dustpred,ppred diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index f7d5ce219..7febaf87b 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -21,15 +21,14 @@ module substepping ! Tuckerman, Berne & Martyna (1992), J. Chem. Phys. 97, 1990-2001 ! Rantala + (2020) (2023),Chin (2007a) ! -! :Owner: Yann BERNARD +! :Owner: Yrisch ! ! :Runtime parameters: None ! -! :Dependencies: boundary_dyn, chem, cons2prim, cons2primsolver, cooling, -! cooling_ism, damping, deriv, dim, dust_formation, eos, extern_gr, -! externalforces, growth, io, io_summary, krome_interface, metric_tools, -! mpiutils, options, part, ptmass, ptmass_radiation, timestep, -! timestep_ind, timestep_sts, timing, units +! :Dependencies: chem, cons2primsolver, cooling, cooling_ism, damping, dim, +! dust_formation, eos, extern_gr, externalforces, io, io_summary, +! krome_interface, metric_tools, mpiutils, options, part, ptmass, +! ptmass_radiation, timestep, timestep_sts ! implicit none diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index 4e691d16a..455156ddb 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.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/ ! !--------------------------------------------------------------------------! @@ -11,15 +11,15 @@ module setup ! ! :References: Paumard et al. (2006) ! -! :Owner: Daniel Price +! :Owner: Yrisch ! ! :Runtime parameters: ! - datafile : *filename for star data (m,x,y,z,vx,vy,vz)* -! - h_sink : *sink particle radii in arcsec at 8kpc* +! - h_sink : *sink particle radii in parsec* ! - m_gas : *gas mass resolution in solar masses* ! ! :Dependencies: datafiles, dim, eos, infile_utils, io, part, physcon, -! prompting, spherical, timestep, units +! prompting, ptmass, spherical, timestep, units ! implicit none public :: setpart diff --git a/src/tests/test_eos.f90 b/src/tests/test_eos.f90 index e984131f8..44f09afe8 100644 --- a/src/tests/test_eos.f90 +++ b/src/tests/test_eos.f90 @@ -10,7 +10,7 @@ module testeos ! ! :References: None ! -! :Owner: Daniel Price +! :Owner: Terrence Tricco ! ! :Runtime parameters: None ! diff --git a/src/tests/test_gr.f90 b/src/tests/test_gr.f90 index c429752e2..905a15a0d 100644 --- a/src/tests/test_gr.f90 +++ b/src/tests/test_gr.f90 @@ -15,8 +15,8 @@ module testgr ! :Runtime parameters: None ! ! :Dependencies: cons2prim, cons2primsolver, eos, extern_gr, inverse4x4, -! io, metric, metric_tools, part, physcon, step_lf_global, testutils, -! units, utils_gr, vectorutils +! io, metric, metric_tools, part, physcon, substepping, testutils, units, +! utils_gr, vectorutils ! use testutils, only:checkval,checkvalbuf,checkvalbuf_end,update_test_scores implicit none diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 3d811374f..b5b73b2fb 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -15,9 +15,10 @@ module testptmass ! :Runtime parameters: None ! ! :Dependencies: boundary, checksetup, deriv, dim, energies, eos, -! gravwaveutils, io, kdtree, kernel, mpiutils, options, part, physcon, -! ptmass, random, setbinary, setdisc, spherical, step_lf_global, -! stretchmap, testutils, timestep, timing, units +! extern_binary, externalforces, gravwaveutils, io, kdtree, kernel, +! mpiutils, options, part, physcon, ptmass, random, setbinary, setdisc, +! spherical, step_lf_global, stretchmap, testutils, timestep, timing, +! units ! use testutils, only:checkval,update_test_scores implicit none From 404ba9c7c558c364c04561de0280222e54530aaa Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 24 Apr 2024 09:08:24 +1000 Subject: [PATCH 470/814] [author-bot] updated AUTHORS file --- AUTHORS | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/AUTHORS b/AUTHORS index 4b972f1d7..b139408e6 100644 --- a/AUTHORS +++ b/AUTHORS @@ -24,48 +24,49 @@ Christophe Pinte Terrence Tricco Stephane Michoulier Simone Ceppi +Yrisch Spencer Magnall -Caitlyn Hardiman Enrico Ragusa +Caitlyn Hardiman Sergei Biriukov Cristiano Longarini Giovanni Dipierro Roberto Iaconi -Hauke Worpel Amena Faruqi +Hauke Worpel Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi -Sahl Rowther Simon Glover +Sahl Rowther Thomas Reichardt Jean-François Gonzalez Christopher Russell -Alessia Franchini Alex Pettitt +Alessia Franchini Jolien Malfait Phantom benchmark bot -Kieran Hirsh Nicole Rodrigues -David Trevascus -Nicolás Cuello +Kieran Hirsh Farzana Meru +Nicolás Cuello +David Trevascus Mike Lau -Chris Nixon Miguel Gonzalez-Bolivar +Chris Nixon Orsola De Marco Maxime Lombart Joe Fisher -Zachary Pellow -Benoit Commercon Giulia Ballabio +Benoit Commercon +Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> -MICHOULIER Stephane Steven Rieder -Jeremy Smallwood -Cox, Samuel -Jorge Cuadra -Stéven Toupin Taj Jankovič Chunliang Mu +MICHOULIER Stephane +Jorge Cuadra +Cox, Samuel +Jeremy Smallwood +Stéven Toupin From 31db10889796c8849f93175125400927565c31c6 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 24 Apr 2024 09:08:44 +1000 Subject: [PATCH 471/814] [format-bot] end if -> endif; end do -> enddo; if( -> if ( --- src/main/ptmass.F90 | 6 +++--- src/main/substepping.F90 | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e111dd4dc..9d536862e 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -187,7 +187,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, f2 = 0. do j=1,nptmass - if (extrap)then + if (extrap) then dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fsink_old(1,j)) dy = yi - (xyzmh_ptmass(2,j) + extrapfac*fsink_old(2,j)) dz = zi - (xyzmh_ptmass(3,j) + extrapfac*fsink_old(3,j)) @@ -368,7 +368,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) do i=1,nptmass - if (extrap)then + if (extrap) then xi = xyzmh_ptmass(1,i) + extrapfac*fsink_old(1,i) yi = xyzmh_ptmass(2,i) + extrapfac*fsink_old(2,i) zi = xyzmh_ptmass(3,i) + extrapfac*fsink_old(3,i) @@ -391,7 +391,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dsz = 0. do j=1,nptmass if (i==j) cycle - if (extrap)then + if (extrap) then dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fsink_old(1,j)) dy = yi - (xyzmh_ptmass(2,j) + extrapfac*fsink_old(2,j)) dz = zi - (xyzmh_ptmass(3,j) + extrapfac*fsink_old(3,j)) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 7febaf87b..a3f9cd3f5 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -632,7 +632,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, ! Kick sink particles if (nptmass>0) then - if(id==master) then + if (id==master) then call ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass) endif call bcast_mpi(vxyz_ptmass(:,1:nptmass)) @@ -963,7 +963,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (nptmass > 0) then call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) - if(id==master .and. extf_vdep_flag) then + if (id==master .and. extf_vdep_flag) then call ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) endif endif From ecac7954b741ff2b6bb8107162159113518cfc45 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 24 Apr 2024 09:41:18 +1000 Subject: [PATCH 472/814] (bots) added a few more shout and format corrections to format-bot --- scripts/bots.sh | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/scripts/bots.sh b/scripts/bots.sh index 46fe18b8f..f47288cec 100755 --- a/scripts/bots.sh +++ b/scripts/bots.sh @@ -207,6 +207,8 @@ for edittype in $bots_to_run; do 'shout' ) sed -e 's/SQRT(/sqrt(/g' \ -e 's/NINT(/nint(/g' \ + -e 's/REAL(/real(/g' \ + -e 's/DBLE(/dble(/g' \ -e 's/ STOP/ stop/g' \ -e 's/ATAN/atan/g' \ -e 's/ACOS(/acos(/g' \ @@ -216,6 +218,17 @@ for edittype in $bots_to_run; do -e 's/EXP(/exp(/g' \ -e 's/LOG(/log(/g' \ -e 's/READ(/read(/g' \ + -e 's/OPEN(/open(/g' \ + -e 's/OPEN (/open(/g' \ + -e 's/CLOSE(/close(/g' \ + -e 's/CLOSE (/close(/g' \ + -e 's/INDEX(/index(/g' \ + -e 's/ANY(/any(/g' \ + -e 's/, STATUS=/,status=/g' \ + -e 's/,STATUS=/,status=/g' \ + -e 's/, FORM=/,form=/g' \ + -e 's/,FORM=/,form=/g' \ + -e 's/TRIM(/trim(/g' \ -e 's/IF (/if (/g' \ -e 's/) THEN/) then/g' \ -e 's/ENDDO/enddo/g' \ @@ -267,6 +280,22 @@ for edittype in $bots_to_run; do sed -e 's/end if/endif/g' \ -e 's/end do/enddo/g' \ -e 's/else if/elseif/g' \ + -e 's/open (/open(/g' \ + -e 's/, file = /,file=/g' \ + -e 's/, file=/,file=/g' \ + -e 's/, status = /,status=/g' \ + -e 's/, status=/,status=/g' \ + -e 's/, iostat = /,iostat=/g' \ + -e 's/, iostat=/,iostat=/g' \ + -e 's/, access = /,access=/g' \ + -e 's/, access=/,access=/g' \ + -e 's/, form = /,form=/g' \ + -e 's/, form=/,form=/g' \ + -e 's/, action = /,action=/g' \ + -e 's/, action=/,action=/g' \ + -e 's/, iomsg = /,iomsg=/g' \ + -e 's/, iomsg=/,iomsg=/g' \ + -e 's/(unit =/,(unit=/g' \ -e 's/if(/if (/g' \ -e 's/)then/) then/g' $file > $out;; 'header' ) From 8ff1bfa19d5fddad47a13b4a75cc6cef3a7c2bcd Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 24 Apr 2024 09:42:34 +1000 Subject: [PATCH 473/814] [format-bot] F77-style SHOUTING removed --- src/main/cooling_molecular.f90 | 4 ++-- src/main/extern_spiral.f90 | 14 ++++++------ src/setup/setup_galdisc.f90 | 20 ++++++++--------- src/utils/analysis_CoM.f90 | 2 +- src/utils/analysis_GalMerger.f90 | 2 +- src/utils/analysis_NSmerger.f90 | 6 ++--- src/utils/analysis_bzrms.f90 | 6 ++--- src/utils/analysis_clumpfind.F90 | 8 +++---- .../analysis_collidingcloudevolution.f90 | 2 +- .../analysis_collidingcloudhistograms.f90 | 12 +++++----- src/utils/analysis_disc_stresses.f90 | 4 ++-- src/utils/analysis_getneighbours.f90 | 4 ++-- src/utils/analysis_kepler.f90 | 2 +- src/utils/analysis_polytropes.f90 | 6 ++--- src/utils/analysis_protostar_environ.F90 | 22 +++++++++---------- src/utils/analysis_raytracer.f90 | 12 +++++----- src/utils/analysis_sphere.f90 | 2 +- .../analysis_velocitydispersion_vs_scale.f90 | 4 ++-- src/utils/analysis_velocityshear.f90 | 16 +++++++------- src/utils/analysis_write_kdtree.F90 | 8 +++---- src/utils/powerspectrums.f90 | 2 +- src/utils/utils_getneighbours.F90 | 12 +++++----- 22 files changed, 85 insertions(+), 85 deletions(-) diff --git a/src/main/cooling_molecular.f90 b/src/main/cooling_molecular.f90 index 48055b2c9..e1bde99b2 100644 --- a/src/main/cooling_molecular.f90 +++ b/src/main/cooling_molecular.f90 @@ -210,7 +210,7 @@ subroutine loadCoolingTable(data_array) iunit = 1 filename = find_phantom_datafile('radcool_all.dat','cooling') - OPEN(unit=iunit, file=trim(filename), STATUS="OLD", ACTION="read", & + open(unit=iunit, file=trim(filename),status="OLD", ACTION="read", & iostat=istat, IOMSG=imsg) ! Begin loading in data @@ -275,7 +275,7 @@ subroutine loadCDTable(data_array) iunit = 1 filename = find_phantom_datafile('table_cd.dat','cooling') - open(unit=iunit, file=filename, STATUS="OLD", iostat=istat, IOMSG=imsg) + open(unit=iunit, file=filename,status="OLD", iostat=istat, IOMSG=imsg) ! Begin loading in data openif: if (istat == 0) then diff --git a/src/main/extern_spiral.f90 b/src/main/extern_spiral.f90 index ddeb68966..c0b419f89 100644 --- a/src/main/extern_spiral.f90 +++ b/src/main/extern_spiral.f90 @@ -377,20 +377,20 @@ subroutine initialise_spiral(ierr) spiralsum(jj)=0.0d0 !-Loop over spheroids do j=1,Nt - Rspheroids(jj,j) = Ri+(DBLE(j)-1.d0)*d_0 + Rspheroids(jj,j) = Ri+(dble(j)-1.d0)*d_0 shapefn(jj,j) = (cotalpha/Nshape) * & - log(1.d0+(Rspheroids(jj,j)/Rsarms)**Nshape) + jj*2.0d0*pi/DBLE(NNi) + log(1.d0+(Rspheroids(jj,j)/Rsarms)**Nshape) + jj*2.0d0*pi/dble(NNi) !print*,jj,j,Rspheroids(jj,j),shapefn(jj,j) select case(iarms) case(2,4) !--For a linear density drop off from galactic centre: den0(jj,j) = (Rf-Rspheroids(jj,j))*3.d0*Mspiral & - / (DBLE(NNi)*pi*a_0*a_0*c_0) + / (dble(NNi)*pi*a_0*a_0*c_0) spiralsum(jj) = spiralsum(jj) + (Rf-Rspheroids(jj,j)) case(3) !--For a log density drop off from galactic centre: den0(jj,j) = exp((Ri-Rspheroids(jj,j))/Rl)*3.d0*Mspiral & - / (DBLE(NNi)*pi*a_0*a_0*c_0) + / (dble(NNi)*pi*a_0*a_0*c_0) spiralsum(jj) = spiralsum(jj) + exp((Ri-Rspheroids(jj,j))/Rl) end select enddo @@ -420,9 +420,9 @@ subroutine initialise_spiral(ierr) case(1) potfilename = 'pot3D.bin' if (id==master) print*,'Reading in potential from an external file (BINARY): ',potfilename - open (unit =1, file = TRIM(potfilename), status='old', form='UNFORMATTED', access='SEQUENTIAL', iostat=ios) + open (unit =1, file = trim(potfilename), status='old', form='UNFORMATTED', access='SEQUENTIAL', iostat=ios) if (ios /= 0 .and. id==master) then - print*, 'Error opening file:', TRIM(potfilename) + print*, 'Error opening file:', trim(potfilename) endif !Read in the grid lengths if they exist in the header. read(1) potlenz,potlenx,potleny @@ -1281,7 +1281,7 @@ subroutine Wang_bar(ri,phii,thetai,pot) allocate(PlmA(l+1)) call legendre_associated(l,m,cos(thetai),PlmA) Plm=PlmA(l+1) - thisphi = Anlm(i) * (s**REAL(l))/((1.+s)**(2.*REAL(l)+1.)) * Gnl * Plm * cos(REAL(m)*(phii)) + thisphi = Anlm(i) * (s**real(l))/((1.+s)**(2.*real(l)+1.)) * Gnl * Plm * cos(real(m)*(phii)) AlmnSum = AlmnSum + thisphi deallocate(GnlA,PlmA) diff --git a/src/setup/setup_galdisc.f90 b/src/setup/setup_galdisc.f90 index e6dbcd55b..37e1ac6c2 100644 --- a/src/setup/setup_galdisc.f90 +++ b/src/setup/setup_galdisc.f90 @@ -175,7 +175,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, totvolH = 4./3.*pi*(5.0*rcyl)**3 !halo galsetupic = 'galsetic.txt' - OPEN(21,file=galsetupic,form='formatted') + open(21,file=galsetupic,form='formatted') do i=1,5 if (i==1) then read(21,*)sometext,npartoftype(igas) @@ -208,7 +208,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Gas loop totmassG=0. if (yn_gas==1) then - OPEN(24,file='asciifile_G',form='formatted') + open(24,file='asciifile_G',form='formatted') i=1 over_npartG: do while(i <= npartoftype(igas)) read(24,*)xis,yis,zis,mis,vxis,vyis,vzis,phaseis @@ -227,7 +227,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif i=i+1 enddo over_npartG - CLOSE(24) + close(24) massoftype(igas) = totmassG/real( npartoftype(igas)) rhozero3 = totmassG/totvol h3 = hfact*(massoftype(igas) /rhozero3)**(1./3.) @@ -245,7 +245,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Disc loop totmassD=0. if (yn_star==1) then - OPEN(22,file='asciifile_D',form='formatted') + open(22,file='asciifile_D',form='formatted') i= npartoftype(igas) + 1 over_npartS: do while(i <= npartoftype(igas) + npartoftype(istar)) read(22,*)xis,yis,zis,mis,vxis,vyis,vzis,phaseis @@ -264,7 +264,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif i=i+1 enddo over_npartS - CLOSE(22) + close(22) massoftype(istar) = totmassD/real( npartoftype(istar)) rhozero1 = totmassD/totvol h1 = hfact*(massoftype(istar)/rhozero1)**(1./3.) @@ -282,7 +282,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Bulge loop totmassB=0. if (yn_bulge==1) then - OPEN(23,file='asciifile_B',form='formatted') + open(23,file='asciifile_B',form='formatted') i=npartoftype(istar)+npartoftype(igas) + 1 over_npartB: do while(i <=npartoftype(igas)+npartoftype(istar)+npartoftype(ibulge)) read(23,*)xis,yis,zis,mis,vxis,vyis,vzis,phaseis @@ -301,7 +301,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif i=i+1 enddo over_npartB - CLOSE(23) + close(23) massoftype(ibulge) = totmassB/real( npartoftype(ibulge)) rhozero2 = totmassB/totvolB h2 = hfact*(massoftype(ibulge)/rhozero2)**(1./3.) @@ -319,7 +319,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Halo loop totmassH=0. if (yn_halo==1) then - OPEN(23,file='asciifile_H',form='formatted') + open(23,file='asciifile_H',form='formatted') i=npartoftype(ibulge)+npartoftype(istar)+npartoftype(igas) + 1 over_npartH: do while(i <=npartoftype(igas)+npartoftype(istar)+npartoftype(ibulge)+npartoftype(idarkmatter)) read(23,*)xis,yis,zis,mis,vxis,vyis,vzis,phaseis @@ -338,7 +338,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif i=i+1 enddo over_npartH - CLOSE(23) + close(23) massoftype(idarkmatter) = totmassH/real( npartoftype(idarkmatter)) rhozero4 = totmassH/totvolH h4 = hfact*(massoftype(idarkmatter)/rhozero4)**(1./3.) @@ -422,7 +422,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, h1 = hfact*(massoftype(1)/rhozero)**(1./3.) - if (TRIM(partdist)=='o') then + if (trim(partdist)=='o') then !--Loop for pseudo-random placement (from observed distribution) print "(a)",' Realistic gas distribution requires location of CDF(r) files:' itot=0 diff --git a/src/utils/analysis_CoM.f90 b/src/utils/analysis_CoM.f90 index 199caa247..b50fa4f5c 100644 --- a/src/utils/analysis_CoM.f90 +++ b/src/utils/analysis_CoM.f90 @@ -40,7 +40,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! ! Open file (appendif exists) ! - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_com.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_com.dat' inquire(file=fileout,exist=iexist) if ( .not.iexist .or. firstcall ) then firstcall = .false. diff --git a/src/utils/analysis_GalMerger.f90 b/src/utils/analysis_GalMerger.f90 index 4dc4d3352..6f4e0c1fb 100644 --- a/src/utils/analysis_GalMerger.f90 +++ b/src/utils/analysis_GalMerger.f90 @@ -47,7 +47,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) character(len=200) :: fileout ! !--Open file (appendif exists) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_stellarCoM.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_stellarCoM.dat' inquire(file=fileout,exist=iexist) if ( .not.iexist .or. firstcall ) then firstcall = .false. diff --git a/src/utils/analysis_NSmerger.f90 b/src/utils/analysis_NSmerger.f90 index 053402dff..c96e57d0d 100644 --- a/src/utils/analysis_NSmerger.f90 +++ b/src/utils/analysis_NSmerger.f90 @@ -127,7 +127,7 @@ subroutine trace_com(dumpfile,xyzh,vxyzu,time,npart,iunit) real :: rad ! !--Open file (appendif exists) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_orbit.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_orbit.dat' inquire(file=fileout,exist=iexist) if ( firstcall .or. .not.iexist ) then open(iunit,file=fileout,status='replace') @@ -280,7 +280,7 @@ subroutine calculate_I(dumpfile,xyzh,time,npart,iunit,particlemass) real :: principle(3),evectors(3,3),ellipticity(2) ! !--Open file (appendif exists) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_inertia.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_inertia.dat' inquire(file=fileout,exist=iexist) if ( firstcall .or. .not.iexist ) then open(iunit,file=fileout,status='replace') @@ -358,7 +358,7 @@ subroutine calculate_midplane_profile(dumpfile,xyzh,vxyzu,npart,iunit,particlema if (.not.opened_full_dump)return ! !--Open file - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_rotataxesprofile'//trim(dumpfile(INDEX(dumpfile,'_'):))//'.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_rotataxesprofile'//trim(dumpfile(index(dumpfile,'_'):))//'.dat' open(iunit,file=fileout,status='replace') write(iunit,"('#',10(1x,'[',i2.2,1x,a11,']',2x))") & 1,'outer bin rad',& diff --git a/src/utils/analysis_bzrms.f90 b/src/utils/analysis_bzrms.f90 index e5b6443e2..d8425a483 100644 --- a/src/utils/analysis_bzrms.f90 +++ b/src/utils/analysis_bzrms.f90 @@ -51,7 +51,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) logical :: iexist ! !--Open file (appendif exists) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_bzrms.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_bzrms.dat' inquire(file=fileout,exist=iexist) if ( .not.iexist .or. firstcall ) then firstcall = .false. @@ -83,7 +83,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif ! !--Read the setup file to get the values of interest - filename=trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'.setup' + filename=trim(dumpfile(1:index(dumpfile,'_')-1))//'.setup' inquire(file=filename,exist=iexist) if (iexist) then call read_setupfile(filename,mhd) @@ -95,7 +95,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif ! !--Get coefficient values from the .in file - filename=trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'.in' + filename=trim(dumpfile(1:index(dumpfile,'_')-1))//'.in' inquire(file=filename,exist=iexist) C_AD = 0.0 C_HE = 0.0 diff --git a/src/utils/analysis_clumpfind.F90 b/src/utils/analysis_clumpfind.F90 index 697a4e1c1..0d889e5bb 100644 --- a/src/utils/analysis_clumpfind.F90 +++ b/src/utils/analysis_clumpfind.F90 @@ -121,11 +121,11 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! Check if a neighbour file is present - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh) then - print*, 'Neighbour file ', TRIM(neighbourfile), ' found' + print*, 'Neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart) else ! If there is no neighbour file, generate the list @@ -146,7 +146,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) allocate(dpoten(npart)) ! Holding array for potential (real*8) - dpoten = DBLE(poten) + dpoten = dble(poten) ! Add potential contribution from all sinks first @@ -219,7 +219,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) over_parts: do l = 1,npart - percent = 100.0*REAL(l)/REAL(npart) + percent = 100.0*real(l)/real(npart) if (percent > percentcount) then write(*,'(I3," % complete")') int(percentcount) diff --git a/src/utils/analysis_collidingcloudevolution.f90 b/src/utils/analysis_collidingcloudevolution.f90 index 52cfdec52..110cd4842 100644 --- a/src/utils/analysis_collidingcloudevolution.f90 +++ b/src/utils/analysis_collidingcloudevolution.f90 @@ -44,7 +44,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! ! Initialise values & Open file ! - write(fileout,'(2a)') trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_MassEvolution.dat' + write(fileout,'(2a)') trim(dumpfile(1:index(dumpfile,'_')-1)),'_MassEvolution.dat' if ( firstcall ) then firstcall = .false. dthresh_cgs(1) = 1.0d-23 diff --git a/src/utils/analysis_collidingcloudhistograms.f90 b/src/utils/analysis_collidingcloudhistograms.f90 index c17daaddb..11345d4ce 100644 --- a/src/utils/analysis_collidingcloudhistograms.f90 +++ b/src/utils/analysis_collidingcloudhistograms.f90 @@ -63,8 +63,8 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! ! Initialise values & Open file ! - fileoutSV = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_SinkVel.dat' - fileoutSA = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_SinkAverages.dat' + fileoutSV = trim(dumpfile(1:index(dumpfile,'_')-1))//'_SinkVel.dat' + fileoutSA = trim(dumpfile(1:index(dumpfile,'_')-1))//'_SinkAverages.dat' inquire(file=fileoutSV,exist=iexist) if ( .not.iexist .or. firstcall ) then firstcall = .false. @@ -117,7 +117,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) 7,'vy', & 8,'vz' do k = 1,nres - write(fileoutSH,'(2a,I3.3,a)') trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_SinkHisto',nbins(k),'.dat' + write(fileoutSH,'(2a,I3.3,a)') trim(dumpfile(1:index(dumpfile,'_')-1)),'_SinkHisto',nbins(k),'.dat' open(iunit+(2*k+1),file=fileoutSH,status='replace') write(iunit+(2*k+1),"('#',10(1x,'[',i2.2,1x,a11,']',2x))") & 1,'idump', & @@ -130,7 +130,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) 8,'N velx', & 9,'N vely', & 10,'N velz' - write(fileoutGH,'(2a,I3.3,a)') trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_GasHisto',nbins(k),'.dat' + write(fileoutGH,'(2a,I3.3,a)') trim(dumpfile(1:index(dumpfile,'_')-1)),'_GasHisto',nbins(k),'.dat' open(iunit+(2*k+2),file=fileoutGH,status='replace') write(iunit+(2*k+2),"('#',10(1x,'[',i2.2,1x,a11,']',2x))") & 1,'idump', & @@ -162,8 +162,8 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) open(iunit ,file=fileoutSV,position='append') open(iunit+20,file=fileoutSA,position='append') do k = 1,nres - write(fileoutSH,'(2a,I3.3,a)') trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_SinkHisto',nbins(k),'.dat' - write(fileoutGH,'(2a,I3.3,a)') trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_GasHisto',nbins(k),'.dat' + write(fileoutSH,'(2a,I3.3,a)') trim(dumpfile(1:index(dumpfile,'_')-1)),'_SinkHisto',nbins(k),'.dat' + write(fileoutGH,'(2a,I3.3,a)') trim(dumpfile(1:index(dumpfile,'_')-1)),'_GasHisto',nbins(k),'.dat' open(iunit+(2*k+1),file=fileoutSH,position='append') open(iunit+(2*k+2),file=fileoutGH,position='append') enddo diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index f6ffe0648..80ce222ac 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -184,11 +184,11 @@ subroutine calc_gravitational_forces(dumpfile,npart,xyzh,vxyzu) ! Construct neighbour lists for derivative calculations - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh.eqv..true.) then - print*, 'Neighbour file ', TRIM(neighbourfile), ' found' + print*, 'Neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart) else diff --git a/src/utils/analysis_getneighbours.f90 b/src/utils/analysis_getneighbours.f90 index fb20606c7..f5fffe2a0 100644 --- a/src/utils/analysis_getneighbours.f90 +++ b/src/utils/analysis_getneighbours.f90 @@ -44,10 +44,10 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! Output neighbour lists to file !************************************** - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) call write_neighbours(neighbourfile, npart) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + print*, 'Neighbour finding complete for file ', trim(dumpfile) end subroutine do_analysis !-------------------------------------------------------------------------- diff --git a/src/utils/analysis_kepler.f90 b/src/utils/analysis_kepler.f90 index e6e63d942..4708f1ad4 100644 --- a/src/utils/analysis_kepler.f90 +++ b/src/utils/analysis_kepler.f90 @@ -673,7 +673,7 @@ subroutine assign_atomic_mass_and_number(comp_label,A_array,Z_array) real,allocatable :: A_array(:), Z_array(:) integer :: size_to_allocate, i - if ( ANY( comp_label=="nt1" ) ) then + if ( any( comp_label=="nt1" ) ) then size_to_allocate = size(comp_label(:))-1 else diff --git a/src/utils/analysis_polytropes.f90 b/src/utils/analysis_polytropes.f90 index bd0c57df8..c112085a3 100644 --- a/src/utils/analysis_polytropes.f90 +++ b/src/utils/analysis_polytropes.f90 @@ -61,7 +61,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) character(len=200) :: fileout ! !--from .setup, determine if binary or not - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'.setup' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'.setup' inquire(file=fileout,exist=iexist) if ( iexist ) then write(*,'(2a)') "reading setup file: ",trim(fileout) @@ -78,7 +78,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) if ( binary ) then ! !--Open file (appendif exists) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_centres.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_centres.dat' inquire(file=fileout,exist=iexist) if ( .not.iexist .or. firstcall ) then open(iunit,file=fileout,status='replace') @@ -252,7 +252,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! !--print period tracking to file (overwriting anything in existance) if ( binary ) then - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_period.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_period.dat' fileout=trim(fileout) open(iunit,file=fileout) write(iunit,"('#',4(1x,'[',i2.2,1x,a11,']',2x))") & diff --git a/src/utils/analysis_protostar_environ.F90 b/src/utils/analysis_protostar_environ.F90 index 6ac1dcd41..895d04933 100644 --- a/src/utils/analysis_protostar_environ.F90 +++ b/src/utils/analysis_protostar_environ.F90 @@ -294,7 +294,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) + (xyzmh_ptmass(2,isink)-xyzmh_ptmass(2,j))**2 & + (xyzmh_ptmass(3,isink)-xyzmh_ptmass(3,j))**2 if (rtmp2 < rmerge2) then - write(filelog,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'.log' + write(filelog,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'.log' inquire(file=filelog,exist=iexist) if ( firstlog .or. .not.iexist ) then firstlog = .false. @@ -315,13 +315,13 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) write(rval, '(I3.3)') rthreshAU write(csink,'(I3.3)') isink if (isink==0) then - write(fileout1,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_discRM.dat' - write(fileout2,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_discRMnx.dat' - write(fileout3,'(5a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_vol',rval,'RM.dat' + write(fileout1,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_discRM.dat' + write(fileout2,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_discRMnx.dat' + write(fileout3,'(5a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_vol',rval,'RM.dat' else - write(fileout1,'(5a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_S',csink,'discRM.dat' - write(fileout2,'(5a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_S',csink,'discRMnx.dat' - write(fileout3,'(7a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_S',csink,'vol',rval,'RM.dat' + write(fileout1,'(5a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_S',csink,'discRM.dat' + write(fileout2,'(5a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_S',csink,'discRMnx.dat' + write(fileout3,'(7a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_S',csink,'vol',rval,'RM.dat' endif if ( no_file(isink) ) then open(iunit,file=fileout1,status='replace') @@ -473,7 +473,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! Print the globally averaged eta-values, for particles with rho > rho_crit if (calc_eta) then - write(fileout6,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_eta.dat' + write(fileout6,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_eta.dat' if ( no_file(maxptmass+1) ) then open(eunit,file=fileout6,status='replace') call write_header_file6(eunit) @@ -504,9 +504,9 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) call get_mu(npart,nptmass,nmu_global,rmu_global,mu_global,mass_mu_global,B_mu_global, & xyzh,xyzmh_ptmass,Bxyz,particlemass) - write(fileout7,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_mu.dat' - write(fileout8,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_mu_mass.dat' - write(fileout9,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_mu_B.dat' + write(fileout7,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_mu.dat' + write(fileout8,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_mu_mass.dat' + write(fileout9,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_mu_B.dat' if ( no_file(maxptmass+1) ) then open(eunit,file=fileout7,status='replace') call write_header_file7(eunit) diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index 2a8305c9e..4f0f840cd 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.f90 @@ -229,10 +229,10 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) if (analyses == 2 .and. method==1) then ! get neighbours if (SPH) then - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh) then - print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' + print*, 'SPH neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart2) else ! If there is no neighbour file, generate the list @@ -243,7 +243,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) totalTime = (finish-start)/1000. print*,'Time = ',totalTime,' seconds.' call write_neighbours(neighbourfile, npart2) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + print*, 'Neighbour finding complete for file ', trim(dumpfile) endif else allocate(neighb(npart2+2,100)) @@ -266,10 +266,10 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! INWARD INTEGRATION ANALYSIS if (method == 1) then - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh) then - print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' + print*, 'SPH neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart2) else ! If there is no neighbour file, generate the list @@ -280,7 +280,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) totalTime = (finish-start)/1000. print*,'Time = ',totalTime,' seconds.' call write_neighbours(neighbourfile, npart2) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + print*, 'Neighbour finding complete for file ', trim(dumpfile) endif print*,'' print*, 'Start calculating optical depth inward SPH' diff --git a/src/utils/analysis_sphere.f90 b/src/utils/analysis_sphere.f90 index 837a5257a..a74eab303 100644 --- a/src/utils/analysis_sphere.f90 +++ b/src/utils/analysis_sphere.f90 @@ -222,7 +222,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) enddo close(iunit) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_AM.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_AM.dat' inquire(file=fileout,exist=iexist) if ( .not.iexist .or. firstcall ) then firstcall = .false. diff --git a/src/utils/analysis_velocitydispersion_vs_scale.f90 b/src/utils/analysis_velocitydispersion_vs_scale.f90 index 7bd2daa9d..628f147fa 100644 --- a/src/utils/analysis_velocitydispersion_vs_scale.f90 +++ b/src/utils/analysis_velocitydispersion_vs_scale.f90 @@ -96,11 +96,11 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) ! Check if a neighbour file is present - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh.eqv..true.) then - print*, 'Neighbour file ', TRIM(neighbourfile), ' found' + print*, 'Neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart) else diff --git a/src/utils/analysis_velocityshear.f90 b/src/utils/analysis_velocityshear.f90 index 16637d2d6..134e91990 100644 --- a/src/utils/analysis_velocityshear.f90 +++ b/src/utils/analysis_velocityshear.f90 @@ -70,11 +70,11 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! Check if a neighbour file is present - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh.eqv..true.) then - print*, 'Neighbour file ', TRIM(neighbourfile), ' found' + print*, 'Neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart) else @@ -158,8 +158,8 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) write(fmtstring, "('(I',I1,')')") ndigits write(numstring, fmtstring) num - valuefile = 'eig0'//TRIM(numstring) - vectorfile = 'evc0'//TRIM(numstring) + valuefile = 'eig0'//trim(numstring) + vectorfile = 'evc0'//trim(numstring) call write_eigenfiles(valuefile,vectorfile, iwrite) @@ -516,8 +516,8 @@ subroutine write_eigenfiles(valuefile,vectorfile, ngas) ! Write eigenvalues to file - print*, 'Writing eigenvalues to file ', TRIM(valuefile) - open(27,file=TRIM(valuefile), status='unknown',form='unformatted') + print*, 'Writing eigenvalues to file ', trim(valuefile) + open(27,file=trim(valuefile), status='unknown',form='unformatted') write(27) ngas write(27) (eigenpart(i),i=1,ngas) write(27) (xbin(i), i=1,ngas) @@ -529,8 +529,8 @@ subroutine write_eigenfiles(valuefile,vectorfile, ngas) close(27) ! Now write the eigenvectors to file - print*, 'Writing eigenvectors to file ', TRIM(vectorfile) - open(27,file=TRIM(vectorfile),status='unknown', form='unformatted') + print*, 'Writing eigenvectors to file ', trim(vectorfile) + open(27,file=trim(vectorfile),status='unknown', form='unformatted') write(27) ngas write(27) (eigenpart(i),i=1,ngas) write(27) (eigenvectors(1,1:3,i),i=1,ngas) diff --git a/src/utils/analysis_write_kdtree.F90 b/src/utils/analysis_write_kdtree.F90 index a185c915d..58e2cdcc9 100644 --- a/src/utils/analysis_write_kdtree.F90 +++ b/src/utils/analysis_write_kdtree.F90 @@ -78,8 +78,8 @@ subroutine write_kdtree_file(dumpfile) character(100) :: treefile integer :: icell - treefile = 'kdtree_'//TRIM(dumpfile) - print'(a,a)', 'Writing kdtree to binary file ', TRIM(treefile) + treefile = 'kdtree_'//trim(dumpfile) + print'(a,a)', 'Writing kdtree to binary file ', trim(treefile) ! Write tag indicating if this is from a run with or without gravity #ifdef GRAVITY @@ -131,8 +131,8 @@ subroutine read_kdtree_file(dumpfile) character(7) :: filetag character(100) :: treefile - treefile = 'kdtree_'//TRIM(dumpfile) - print'(a,a)', 'Reading kdtree from binary file ', TRIM(treefile) + treefile = 'kdtree_'//trim(dumpfile) + print'(a,a)', 'Reading kdtree from binary file ', trim(treefile) open(10,file=treefile, form='unformatted') ! Read header diff --git a/src/utils/powerspectrums.f90 b/src/utils/powerspectrums.f90 index 0ffd56515..de772a8b6 100644 --- a/src/utils/powerspectrums.f90 +++ b/src/utils/powerspectrums.f90 @@ -89,7 +89,7 @@ subroutine power_fourier(npts,x,dat,omega,power) sum1 = sum1 + dat(i)*cos(-omega*x(i)) sum2 = sum2 + dat(i)*sin(-omega*x(i)) enddo - power= sqrt(sum1**2 + sum2**2)/REAL(npts) + power= sqrt(sum1**2 + sum2**2)/real(npts) return end subroutine power_fourier diff --git a/src/utils/utils_getneighbours.F90 b/src/utils/utils_getneighbours.F90 index 0e889d282..41fedb45f 100644 --- a/src/utils/utils_getneighbours.F90 +++ b/src/utils/utils_getneighbours.F90 @@ -183,9 +183,9 @@ subroutine generate_neighbour_lists(xyzh,vxyzu,npart,dumpfile,write_neighbour_li ! 3. Output neighbour lists to file (if requested; these files can become very big) !************************************** if (write_neighbour_list) then - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) call write_neighbours(neighbourfile, npart) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + print*, 'Neighbour finding complete for file ', trim(dumpfile) endif deallocate(dumxyzh) @@ -214,7 +214,7 @@ subroutine neighbours_stats(npart) stop endif - meanneigh = sum(neighcount)/REAL(npart) + meanneigh = sum(neighcount)/real(npart) sdneigh = 0.0 !$omp parallel default(none) & @@ -228,7 +228,7 @@ subroutine neighbours_stats(npart) !$omp enddo !$omp end parallel - sdneigh = sqrt(sdneigh/REAL(npart)) + sdneigh = sqrt(sdneigh/real(npart)) print*, 'Mean neighbour number is ', meanneigh print*, 'Standard Deviation: ', sdneigh @@ -250,7 +250,7 @@ subroutine read_neighbours(neighbourfile,npart) neighcount(:) = 0 neighb(:,:) = 0 - print*, 'Reading neighbour file ', TRIM(neighbourfile) + print*, 'Reading neighbour file ', trim(neighbourfile) open(2, file= neighbourfile, form = 'UNFORMATTED') read(2) neighcheck, tolcheck, meanneigh,sdneigh,neighcrit if (neighcheck/=neighmax) print*, 'WARNING: mismatch in neighmax: ', neighmax, neighcheck @@ -287,7 +287,7 @@ subroutine write_neighbours(neighbourfile,npart) real, parameter :: tolerance = 2.0e0 ! A dummy parameter used to keep file format similar to other codes (Probably delete later) neigh_overload = .false. - neighbourfile = TRIM(neighbourfile) + neighbourfile = trim(neighbourfile) print*, 'Writing neighbours to file ', neighbourfile open (2, file=neighbourfile, form='unformatted') From cd95d98f61296b4f23ebd08a13d5fa21674c1711 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 24 Apr 2024 09:44:47 +1000 Subject: [PATCH 474/814] [format-bot] end if -> endif; end do -> enddo; if( -> if ( --- src/main/cooling_molecular.f90 | 12 +- src/main/eos_mesa_microphysics.f90 | 8 +- src/main/extern_densprofile.f90 | 6 +- src/main/extern_spiral.f90 | 2 +- src/main/forcing.F90 | 4 +- src/main/readwrite_dumps_fortran.f90 | 4 +- src/main/utils_dumpfiles.f90 | 122 +++++++++--------- src/main/utils_filenames.f90 | 2 +- src/setup/readwrite_kepler.f90 | 6 +- src/setup/readwrite_mesa.f90 | 2 +- src/setup/set_hierarchical.f90 | 12 +- src/setup/set_hierarchical_utils.f90 | 10 +- src/tests/test_eos_stratified.f90 | 10 +- src/utils/analysis_angmom.f90 | 4 +- src/utils/analysis_angmomvec.f90 | 4 +- src/utils/analysis_average_orb_en.f90 | 4 +- src/utils/analysis_clumpfind.F90 | 14 +- src/utils/analysis_clumpfindWB23.F90 | 2 +- src/utils/analysis_common_envelope.f90 | 74 +++++------ src/utils/analysis_disc_stresses.f90 | 4 +- src/utils/analysis_gws.f90 | 12 +- src/utils/analysis_kepler.f90 | 10 +- src/utils/analysis_prdrag.f90 | 6 +- src/utils/analysis_raytracer.f90 | 74 +++++------ .../analysis_velocitydispersion_vs_scale.f90 | 4 +- src/utils/analysis_velocityshear.f90 | 4 +- src/utils/analysis_write_kdtree.F90 | 4 +- src/utils/io_structurefn.f90 | 2 +- src/utils/moddump_growthtomultigrain.f90 | 2 +- src/utils/utils_getneighbours.F90 | 4 +- src/utils/utils_gravwave.f90 | 4 +- 31 files changed, 216 insertions(+), 216 deletions(-) diff --git a/src/main/cooling_molecular.f90 b/src/main/cooling_molecular.f90 index e1bde99b2..e953a3175 100644 --- a/src/main/cooling_molecular.f90 +++ b/src/main/cooling_molecular.f90 @@ -210,7 +210,7 @@ subroutine loadCoolingTable(data_array) iunit = 1 filename = find_phantom_datafile('radcool_all.dat','cooling') - open(unit=iunit, file=trim(filename),status="OLD", ACTION="read", & + open(unit=iunit,file=trim(filename),status="OLD", ACTION="read", & iostat=istat, IOMSG=imsg) ! Begin loading in data @@ -218,13 +218,13 @@ subroutine loadCoolingTable(data_array) !!! Skip header rewind(unit=iunit) do o = 1, headerLines - read(iunit, *, iostat=istat, IOMSG = imsg) + read(iunit, *,iostat=istat, IOMSG = imsg) enddo ! Read data skipheaderif: if ((istat == 0)) then readdo: do - read(iunit, *, iostat=istat) i, j, k, T, n_H, N_coolant, lambda_CO, lambda_H2O, lambda_HCN + read(iunit, *,iostat=istat) i, j, k, T, n_H, N_coolant, lambda_CO, lambda_H2O, lambda_HCN if (istat /= 0) exit data_array(i, j, k, :) = [T, n_H, N_coolant, lambda_CO, lambda_H2O, lambda_HCN] @@ -275,20 +275,20 @@ subroutine loadCDTable(data_array) iunit = 1 filename = find_phantom_datafile('table_cd.dat','cooling') - open(unit=iunit, file=filename,status="OLD", iostat=istat, IOMSG=imsg) + open(unit=iunit,file=filename,status="OLD",iostat=istat, IOMSG=imsg) ! Begin loading in data openif: if (istat == 0) then !!! Skip header rewind(unit=iunit) do o = 1, headerLines - read(iunit, *, iostat=istat, IOMSG = imsg) + read(iunit, *,iostat=istat, IOMSG = imsg) enddo !!! Read data skipheaderif: if ((istat == 0)) then readdo: do - read(iunit, *, iostat=istat) i, j, k, l, r_part, widthLine, m_exp, r_sep, N_H + read(iunit, *,iostat=istat) i, j, k, l, r_part, widthLine, m_exp, r_sep, N_H if (istat /= 0) exit data_array(i, j, k, l, :) = [r_part, widthLine, m_exp, r_sep, N_H] diff --git a/src/main/eos_mesa_microphysics.f90 b/src/main/eos_mesa_microphysics.f90 index aa9268c13..903fef912 100644 --- a/src/main/eos_mesa_microphysics.f90 +++ b/src/main/eos_mesa_microphysics.f90 @@ -69,7 +69,7 @@ subroutine get_opacity_constants_mesa opacs_file = find_phantom_datafile(filename,'eos/mesa') ! Read the constants from the header of the opacity file - open(newunit=fnum, file=trim(opacs_file), status='old', action='read', form='unformatted') + open(newunit=fnum,file=trim(opacs_file),status='old',action='read',form='unformatted') read(fnum) mesa_opacs_nz,mesa_opacs_nx,mesa_opacs_nr,mesa_opacs_nt close(fnum) @@ -102,7 +102,7 @@ subroutine read_opacity_mesa(x,z) filename = trim(mesa_opacs_dir)//'opacs'//trim(mesa_opacs_suffix)//'.bindata' ! filename = trim(mesa_opacs_dir)//'/'//'opacs'//trim(mesa_opacs_suffix)//'.bindata' opacs_file = find_phantom_datafile(filename,'eos/mesa') - open(unit=fnum, file=trim(opacs_file), status='old', action='read', form='unformatted') + open(unit=fnum,file=trim(opacs_file),status='old',action='read',form='unformatted') read(fnum) mesa_opacs_nz,mesa_opacs_nx,mesa_opacs_nr,mesa_opacs_nt ! Read in the size of the table and the data @@ -308,7 +308,7 @@ subroutine get_eos_constants_mesa(ierr) filename = find_phantom_datafile(filename,'eos/mesa') ! Read constants from the header of first EoS tables - open(unit=fnum, file=trim(filename), status='old', action='read', form='unformatted',iostat=ierr) + open(unit=fnum,file=trim(filename),status='old',action='read',form='unformatted',iostat=ierr) if (ierr /= 0) return read(fnum) mesa_eos_ne, mesa_eos_nv, mesa_eos_nvar2 close(fnum) @@ -364,7 +364,7 @@ subroutine read_eos_mesa(x,z,ierr) ! Read in the size of the tables and the data ! i and j hold the Z and X values respectively ! k, l and m hold the values of V, Eint and the data respectively - open(unit=fnum, file=trim(filename), status='old', action='read', form='unformatted') + open(unit=fnum,file=trim(filename),status='old',action='read',form='unformatted') read(fnum) mesa_eos_ne, mesa_eos_nv, mesa_eos_nvar2 read(fnum)(mesa_eos_logVs(k),k=1,mesa_eos_nv) read(fnum)(mesa_eos_logEs(l),l=1,mesa_eos_ne) diff --git a/src/main/extern_densprofile.f90 b/src/main/extern_densprofile.f90 index 407e50fae..d8fc59c21 100644 --- a/src/main/extern_densprofile.f90 +++ b/src/main/extern_densprofile.f90 @@ -137,13 +137,13 @@ subroutine read_rhotab(filename, rsize, rtab, rhotab, nread, polyk, gamma, rhoc, endif ! First line: # K gamma rhoc - read(iunit, *, iostat=ierr) hash,polyk, 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) - read(iunit,*, iostat=ierr) hash,nread + read(iunit,*,iostat=ierr) hash,nread if (ierr /= 0) then call error('extern_densityprofile','Error reading second line of header from '//trim(filename)) return @@ -155,7 +155,7 @@ subroutine read_rhotab(filename, rsize, rtab, rhotab, nread, polyk, gamma, rhoc, endif ! Loop over 'n' lines: r and density separated by space do i = 1,nread - read(iunit,*, iostat=ierr) rtab(i), rhotab(i) + read(iunit,*,iostat=ierr) rtab(i), rhotab(i) if (ierr /= 0) then call error('extern_densityprofile','Error reading data from '//trim(filename)) return diff --git a/src/main/extern_spiral.f90 b/src/main/extern_spiral.f90 index c0b419f89..c2d97b0f2 100644 --- a/src/main/extern_spiral.f90 +++ b/src/main/extern_spiral.f90 @@ -420,7 +420,7 @@ subroutine initialise_spiral(ierr) case(1) potfilename = 'pot3D.bin' if (id==master) print*,'Reading in potential from an external file (BINARY): ',potfilename - open (unit =1, file = trim(potfilename), status='old', form='UNFORMATTED', access='SEQUENTIAL', iostat=ios) + open,(unit=1,file=trim(potfilename),status='old',form='UNFORMATTED',access='SEQUENTIAL',iostat=ios) if (ios /= 0 .and. id==master) then print*, 'Error opening file:', trim(potfilename) endif diff --git a/src/main/forcing.F90 b/src/main/forcing.F90 index 878e88f86..a0db37a7a 100644 --- a/src/main/forcing.F90 +++ b/src/main/forcing.F90 @@ -1076,8 +1076,8 @@ subroutine read_stirring_data_from_file(infile, time, timeinfile) my_file = find_phantom_datafile(infile,'forcing') - open (unit=42, file=my_file, iostat=ierr, status='old', action='read', & - access='sequential', form='unformatted') + open(unit=42,file=my_file,iostat=ierr,status='old',action='read', & + access='sequential',form='unformatted') ! header contains number of times and number of modes, end time, autocorrelation time, ... if (ierr==0) then if (Debug) write (*,'(A)') 'reading header...' diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 433b06909..742bad087 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -169,7 +169,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ! repeated nblocks times (once for each MPI process) ! nblockarrays = narraylengths*nblocks - write (idump, iostat=ierr) nblockarrays + write (idump,iostat=ierr) nblockarrays endif masterthread @@ -414,7 +414,7 @@ subroutine write_smalldump_fortran(t,dumpfile) !--arrays: number of array lengths ! nblockarrays = narraylengths*nblocks - write (idump, iostat=ierr) nblockarrays + write (idump,iostat=ierr) nblockarrays if (ierr /= 0) call error('write_smalldump','error writing nblockarrays') endif masterthread diff --git a/src/main/utils_dumpfiles.f90 b/src/main/utils_dumpfiles.f90 index 875c843d0..aef612992 100644 --- a/src/main/utils_dumpfiles.f90 +++ b/src/main/utils_dumpfiles.f90 @@ -1168,9 +1168,9 @@ subroutine open_dumpfile_r(iunit,filename,fileid,ierr,singleprec,requiretags,tag !--read output file ! if (r4) then - read (iunit, iostat=ierr1) int1i,r1s,int2i,iversion_file,int3i + read (iunit,iostat=ierr1) int1i,r1s,int2i,iversion_file,int3i else - read (iunit, iostat=ierr1) int1i,r1i,int2i,iversion_file,int3i + read (iunit,iostat=ierr1) int1i,r1i,int2i,iversion_file,int3i endif if (int1i /= int1 .and. int1i /= int1o) then ierr = ierr_endian @@ -1187,7 +1187,7 @@ subroutine open_dumpfile_r(iunit,filename,fileid,ierr,singleprec,requiretags,tag ierr = ierr_version endif - read (iunit, iostat=ierr1) fileid + read (iunit,iostat=ierr1) fileid if (int2i /= int2 .and. int2i /= int2o) then ierr = ierr_realsize @@ -1271,7 +1271,7 @@ subroutine read_header(iunit,hdr,ierr,singleprec,tagged) if (present(tagged)) tags = tagged do i=1,ndatatypes - read (iunit, iostat=ierr) n + read (iunit,iostat=ierr) n if (n < 0) n = 0 hdr%nums(i) = n select case(i) @@ -1279,64 +1279,64 @@ subroutine read_header(iunit,hdr,ierr,singleprec,tagged) allocate(hdr%inttags(n),hdr%intvals(n),stat=ierr) if (n > 0) then hdr%inttags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%inttags - read(iunit, iostat=ierr) hdr%intvals + if (tags) read(iunit,iostat=ierr) hdr%inttags + read(iunit,iostat=ierr) hdr%intvals endif case(i_int1) allocate(hdr%int1tags(n),hdr%int1vals(n),stat=ierr) if (n > 0) then hdr%int1tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%int1tags - read(iunit, iostat=ierr) hdr%int1vals + if (tags) read(iunit,iostat=ierr) hdr%int1tags + read(iunit,iostat=ierr) hdr%int1vals endif case(i_int2) allocate(hdr%int2tags(n),hdr%int2vals(n),stat=ierr) if (n > 0) then hdr%int2tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%int2tags - read(iunit, iostat=ierr) hdr%int2vals + if (tags) read(iunit,iostat=ierr) hdr%int2tags + read(iunit,iostat=ierr) hdr%int2vals endif case(i_int4) allocate(hdr%int4tags(n),hdr%int4vals(n),stat=ierr) if (n > 0) then hdr%int4tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%int4tags - read(iunit, iostat=ierr) hdr%int4vals + if (tags) read(iunit,iostat=ierr) hdr%int4tags + read(iunit,iostat=ierr) hdr%int4vals endif case(i_int8) allocate(hdr%int8tags(n),hdr%int8vals(n),stat=ierr) if (n > 0) then hdr%int8tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%int8tags - read(iunit, iostat=ierr) hdr%int8vals + if (tags) read(iunit,iostat=ierr) hdr%int8tags + read(iunit,iostat=ierr) hdr%int8vals endif case(i_real) allocate(hdr%realtags(n),hdr%realvals(n),stat=ierr) if (n > 0) then hdr%realtags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%realtags + if (tags) read(iunit,iostat=ierr) hdr%realtags if (convert_prec .and. kind(0.) /= 4) then allocate(dumr4(n),stat=ierr) - read(iunit, iostat=ierr) dumr4 + read(iunit,iostat=ierr) dumr4 hdr%realvals(1:n) = real(dumr4(1:n)) deallocate(dumr4) else - read(iunit, iostat=ierr) hdr%realvals + read(iunit,iostat=ierr) hdr%realvals endif endif case(i_real4) allocate(hdr%real4tags(n),hdr%real4vals(n),stat=ierr) if (n > 0) then hdr%real4tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%real4tags - read(iunit, iostat=ierr) hdr%real4vals + if (tags) read(iunit,iostat=ierr) hdr%real4tags + read(iunit,iostat=ierr) hdr%real4vals endif case(i_real8) allocate(hdr%real8tags(n),hdr%real8vals(n),stat=ierr) if (n > 0) then hdr%real8tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%real8tags - read(iunit, iostat=ierr) hdr%real8vals + if (tags) read(iunit,iostat=ierr) hdr%real8tags + read(iunit,iostat=ierr) hdr%real8vals endif end select enddo @@ -1628,11 +1628,11 @@ end function func if (ipass==1) then nums(i_int1,ib) = nums(i_int1,ib) + 1 elseif (ipass==2) then - write(iunit, iostat=ierr) tag(my_tag) + write(iunit,iostat=ierr) tag(my_tag) if (present(func)) then - write(iunit, iostat=ierr) (func(iarr(i)),i=1,len) + write(iunit,iostat=ierr) (func(iarr(i)),i=1,len) else - write(iunit, iostat=ierr) iarr(1:len) + write(iunit,iostat=ierr) iarr(1:len) endif endif endif @@ -1667,11 +1667,11 @@ end function func if (ipass==1) then nums(i_int4,ib) = nums(i_int4,ib) + 1 elseif (ipass==2) then - write(iunit, iostat=ierr) tag(my_tag) + write(iunit,iostat=ierr) tag(my_tag) if (present(func)) then - write(iunit, iostat=ierr) (func(iarr(i)),i=1,len) + write(iunit,iostat=ierr) (func(iarr(i)),i=1,len) else - write(iunit, iostat=ierr) iarr(1:len) + write(iunit,iostat=ierr) iarr(1:len) endif endif endif @@ -1706,11 +1706,11 @@ end function func if (ipass==1) then nums(i_int8,ib) = nums(i_int8,ib) + 1 elseif (ipass==2) then - write(iunit, iostat=ierr) tag(my_tag) + write(iunit,iostat=ierr) tag(my_tag) if (present(func)) then - write(iunit, iostat=ierr) (func(iarr(i)),i=1,len) + write(iunit,iostat=ierr) (func(iarr(i)),i=1,len) else - write(iunit, iostat=ierr) iarr(1:len) + write(iunit,iostat=ierr) iarr(1:len) endif endif endif @@ -1752,11 +1752,11 @@ end function func if (ipass==1) then nums(imatch,ib) = nums(imatch,ib) + 1 elseif (ipass==2) then - write(iunit, iostat=ierr) tag(my_tag) + write(iunit,iostat=ierr) tag(my_tag) if (present(func)) then - write(iunit, iostat=ierr) (func(arr(i)),i=1,len) + write(iunit,iostat=ierr) (func(arr(i)),i=1,len) else - write(iunit, iostat=ierr) arr(1:len) + write(iunit,iostat=ierr) arr(1:len) endif endif endif @@ -1808,14 +1808,14 @@ end function func if (ipass==1) then nums(imatch,ib) = nums(imatch,ib) + 1 elseif (ipass==2) then - write(iunit, iostat=ierr) tag(my_tag) + write(iunit,iostat=ierr) tag(my_tag) if (present(func)) then - write(iunit, iostat=ierr) (func(arr(i)),i=1,len) + write(iunit,iostat=ierr) (func(arr(i)),i=1,len) else if (imatch==i_real4 .or. use_singleprec) then - write(iunit, iostat=ierr) (real(arr(i),kind=4),i=1,len) + write(iunit,iostat=ierr) (real(arr(i),kind=4),i=1,len) else - write(iunit, iostat=ierr) arr(1:len) + write(iunit,iostat=ierr) arr(1:len) endif endif endif @@ -1861,8 +1861,8 @@ subroutine write_array_real4arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,n nums(imatch,ib) = nums(imatch,ib) + (iend - istart) + 1 elseif (ipass==2) then do j=istart,iend - write(iunit, iostat=ierr) tag(my_tag(j)) - write(iunit, iostat=ierr) (arr(j,i),i=1,len2) + write(iunit,iostat=ierr) tag(my_tag(j)) + write(iunit,iostat=ierr) (arr(j,i),i=1,len2) enddo endif endif @@ -1916,12 +1916,12 @@ subroutine write_array_real8arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,n nums(imatch,ib) = nums(imatch,ib) + (iend - istart) + 1 elseif (ipass==2) then do j=istart,iend - write(iunit, iostat=ierr) tag(my_tag(j)) + write(iunit,iostat=ierr) tag(my_tag(j)) if (imatch==i_real4 .or. use_singleprec) then !print*, "done ", my_tag(j), " | ", tag(my_tag(j)) - write(iunit, iostat=ierr) (real(arr(j,i),kind=4),i=1,len2) + write(iunit,iostat=ierr) (real(arr(j,i),kind=4),i=1,len2) else - write(iunit, iostat=ierr) (arr(j,i),i=1,len2) + write(iunit,iostat=ierr) (arr(j,i),i=1,len2) endif enddo endif @@ -1943,7 +1943,7 @@ subroutine write_block_header(nblocks,number,nums,iunit,ierr) integer :: iblock do iblock=1,nblocks - write(iunit, iostat=ierr) number(iblock), nums(1:ndatatypes,iblock) + write(iunit,iostat=ierr) number(iblock), nums(1:ndatatypes,iblock) enddo end subroutine write_block_header @@ -1964,7 +1964,7 @@ subroutine read_block_header(nblocks,number,nums,iunit,ierr) number(:) = 0 nums(:,:) = 0 do iblock=1,nblocks - read(iunit, iostat=ierr) number(iblock), nums(1:ndatatypes,iblock) + read(iunit,iostat=ierr) number(iblock), nums(1:ndatatypes,iblock) enddo end subroutine read_block_header @@ -2399,7 +2399,7 @@ subroutine open_dumpfile_rh(iunit,filename,nblocks,narraylengths,ierr,singleprec if (ierr /= 0) return enddo - read (iunit, iostat=ierr) number + read (iunit,iostat=ierr) number if (ierr /= 0) return narraylengths = number/nblocks @@ -2445,17 +2445,17 @@ subroutine read_array_from_file_r8(iunit,filename,tag,array,ierr,use_block) !print*,' data type ',i,' arrays = ',nums(i,j) do k=1,nums(i,j) if (i==i_real) then - read(iunit, iostat=ierr) mytag + read(iunit,iostat=ierr) mytag if (trim(mytag)==trim(tag)) then - read(iunit, iostat=ierr) array(1:min(int(number8(j)),size(array))) + read(iunit,iostat=ierr) array(1:min(int(number8(j)),size(array))) print*,'->',mytag else print*,' ',mytag - read(iunit, iostat=ierr) + read(iunit,iostat=ierr) endif else - read(iunit, iostat=ierr) mytag ! tag - read(iunit, iostat=ierr) ! array + read(iunit,iostat=ierr) mytag ! tag + read(iunit,iostat=ierr) ! array endif enddo enddo @@ -2506,17 +2506,17 @@ subroutine read_array_from_file_r4(iunit,filename,tag,array,ierr,use_block) !print*,' data type ',i,' arrays = ',nums(i,j) do k=1,nums(i,j) if (i==i_real4) then - read(iunit, iostat=ierr) mytag + read(iunit,iostat=ierr) mytag if (trim(mytag)==trim(tag)) then - read(iunit, iostat=ierr) array(1:min(int(number8(j)),size(array))) + read(iunit,iostat=ierr) array(1:min(int(number8(j)),size(array))) print*,'->',mytag else print*,' ',mytag - read(iunit, iostat=ierr) + read(iunit,iostat=ierr) endif else - read(iunit, iostat=ierr) mytag ! tag - read(iunit, iostat=ierr) ! array + read(iunit,iostat=ierr) mytag ! tag + read(iunit,iostat=ierr) ! array endif enddo enddo @@ -2571,25 +2571,25 @@ subroutine print_arrays_in_file(iunit,filename) if (nread >= int(number8(j))) str = ']' do i=1,ndatatypes do k=1,nums(i,j) - read(iunit, iostat=ierr) mytag + read(iunit,iostat=ierr) mytag select case(i) case(i_int1) - read(iunit, iostat=ierr) i1(1:nread) + read(iunit,iostat=ierr) i1(1:nread) print*,mytag,datatype_label(i),' [',i1(1:nread),str case(i_real) if (singleprec) then - read(iunit, iostat=ierr) x4(1:nread) + read(iunit,iostat=ierr) x4(1:nread) print*,mytag,datatype_label(i),' [',x4(1:nread),str else - read(iunit, iostat=ierr) x(1:nread) + read(iunit,iostat=ierr) x(1:nread) print*,mytag,datatype_label(i),' [',x(1:nread),str endif case(i_real4) - read(iunit, iostat=ierr) x4(1:nread) + read(iunit,iostat=ierr) x4(1:nread) print*,mytag,datatype_label(i),' [',x4(1:nread),str case default print*,mytag,datatype_label(i) - read(iunit, iostat=ierr) ! skip actual array + read(iunit,iostat=ierr) ! skip actual array end select enddo enddo diff --git a/src/main/utils_filenames.f90 b/src/main/utils_filenames.f90 index 2c2c22ee5..108eb2a52 100644 --- a/src/main/utils_filenames.f90 +++ b/src/main/utils_filenames.f90 @@ -216,7 +216,7 @@ function get_nlines(string,skip_comments,n_columns,n_headerlines) result(n) integer, optional, intent(out) :: n_columns integer, optional, intent(out) :: n_headerlines - open(newunit=iunit, file=string,status='old',iostat=ierr) + open(newunit=iunit,file=string,status='old',iostat=ierr) do_skip = .false. if (present(skip_comments)) do_skip = skip_comments diff --git a/src/setup/readwrite_kepler.f90 b/src/setup/readwrite_kepler.f90 index 21d138b8b..41f73b86f 100644 --- a/src/setup/readwrite_kepler.f90 +++ b/src/setup/readwrite_kepler.f90 @@ -100,11 +100,11 @@ subroutine read_kepler_file(filepath,ng_max,n_rows,rtab,rhotab,ptab,temperature, !--This is used as a test for saving composition. ! ierr = 0 - open(newunit=iu, file=trim(fullfilepath)) + open(newunit=iu,file=trim(fullfilepath)) !The row with the information about column headings is at nheaderlines-1. !we skip the first nheaderlines-2 rows and then read the nheaderlines-1 to find the substrings call skip_header(iu,nheaderlines-2,ierr) - read(iu, '(a)', iostat=ierr) line + read(iu, '(a)',iostat=ierr) line !read the column labels and store them in an array. allocate(all_label(n_cols)) @@ -125,7 +125,7 @@ subroutine read_kepler_file(filepath,ng_max,n_rows,rtab,rhotab,ptab,temperature, ! !--Read the file again and save the data in stardata tensor. ! - open(newunit=iu, file=trim(fullfilepath)) + open(newunit=iu,file=trim(fullfilepath)) call skip_header(iu,nheaderlines,ierr) do k=1,n_rows read(iu,*,iostat=ierr) stardata(k,:) diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index a053eb985..d69a8ff72 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.f90 @@ -230,7 +230,7 @@ subroutine write_mesa(outputpath,m,pres,temp,r,rho,ene,Xfrac,Yfrac,csound,mu) optionalcols(:,noptionalcols) = csound endif - open(newunit=iu, file = outputpath, status = 'replace') + open(newunit=iu,file=outputpath,status='replace') do i = 1,noptionalcols+ncols-1 write(iu,'(a24,2x)',advance="no") trim(headers(i)) enddo diff --git a/src/setup/set_hierarchical.f90 b/src/setup/set_hierarchical.f90 index 22dad2a68..ebf4a7bfd 100644 --- a/src/setup/set_hierarchical.f90 +++ b/src/setup/set_hierarchical.f90 @@ -495,10 +495,10 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & inquire(file=trim(filename), exist=iexist) if (present(subst) .and. subst>10) then if (iexist) then - open(1, file = trim(filename), status = 'old') + open(1,file=trim(filename),status='old') lines=0 do - read(1, *, iostat=io) data(lines+1,:) + read(1, *,iostat=io) data(lines+1,:) if (io/=0) exit lines = lines + 1 enddo @@ -510,14 +510,14 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & else if (iexist) then print "(1x,a)",'WARNING: set_multiple: deleting an existing HIERARCHY file.' - open(1, file=trim(filename), status='old') - close(1, status='delete') + open(1,file=trim(filename),status='old') + close(1,status='delete') endif mtot = m1 + m2 period = sqrt(4.*pi**2*semimajoraxis**3/mtot) - open(1, file = trim(filename), status = 'new') + open(1,file=trim(filename),status='new') if (present(incl)) then if (present(posang_ascnode) .and. present(arg_peri)) then write(1,*) 1, 11, m1, m2, semimajoraxis, eccentricity, period, incl, arg_peri, posang_ascnode @@ -716,7 +716,7 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & vxyz_ptmass(:,i2) = vxyz_ptmass(:,i2)+v_subst ! Write updated HIERARCHY file with the two new stars and the substituted one - open(1, file = trim(filename), status = 'old') + open(1,file=trim(filename),status='old') do i=1,lines write(1,*) int(data(i,1)), int(data(i,2)), data(i,3:) enddo diff --git a/src/setup/set_hierarchical_utils.f90 b/src/setup/set_hierarchical_utils.f90 index 50aa1866e..6921d5daa 100644 --- a/src/setup/set_hierarchical_utils.f90 +++ b/src/setup/set_hierarchical_utils.f90 @@ -247,10 +247,10 @@ subroutine load_hierarchy_file(prefix, data, lines, ierr) inquire(file=trim(filename), exist=iexist) if (iexist) then - open(2, file = trim(filename), status = 'old') + open(2,file=trim(filename),status='old') lines=0 do - read(2, *, iostat=io) data(lines+1,:) + read(2, *,iostat=io) data(lines+1,:) if (io/=0) exit lines = lines + 1 enddo @@ -301,7 +301,7 @@ subroutine update_hierarchy_file(prefix, hs, data, lines, hier_prefix, i1, i2, i endif if (lines > 0) then - open(newunit=iu, file = trim(filename), status = 'old') + open(newunit=iu,file=trim(filename),status='old') do i=1,lines write(iu,*) int(data(i,1)), int(data(i,2)), data(i,3:) enddo @@ -309,7 +309,7 @@ subroutine update_hierarchy_file(prefix, hs, data, lines, hier_prefix, i1, i2, i inquire(file=trim(filename), exist=iexist) if (iexist) print "(1x,a)",'WARNING: set_multiple: deleting an existing HIERARCHY file.' - open(newunit=iu, file = trim(filename), status = 'replace') + open(newunit=iu,file=trim(filename),status='replace') endif write(iu,*) i1, trim(hier_prefix)//"1", mprimary, msecondary, semimajoraxis, eccentricity, & period, incl, arg_peri, posang_ascnode @@ -462,7 +462,7 @@ subroutine find_hierarchy_index(level, int_sinks, inner_sinks_num, prefix) character(len=10) :: label = ' ' - read(level, *, iostat=io) h_index + read(level, *,iostat=io) h_index call load_hierarchy_file(prefix, data, lines, ierr) diff --git a/src/tests/test_eos_stratified.f90 b/src/tests/test_eos_stratified.f90 index f8aaf1936..20ecf3f4f 100644 --- a/src/tests/test_eos_stratified.f90 +++ b/src/tests/test_eos_stratified.f90 @@ -296,11 +296,11 @@ subroutine map_stratified_temps(ntests, npass) call eosinfo(ieos,stdout) - open(1, file='HD1632996_temps.txt', status = 'replace') - open(2, file='IMLup_temps.txt', status = 'replace') - open(3, file='GMAur_temps.txt', status = 'replace') - open(4, file='AS209_temps.txt', status = 'replace') - open(5, file='MWC480_temps.txt', status = 'replace') + open(1,file='HD1632996_temps.txt',status='replace') + open(2,file='IMLup_temps.txt',status='replace') + open(3,file='GMAur_temps.txt',status='replace') + open(4,file='AS209_temps.txt',status='replace') + open(5,file='MWC480_temps.txt',status='replace') do i=1,n call get_disc_params(i,gmw,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk,polyk2, & diff --git a/src/utils/analysis_angmom.f90 b/src/utils/analysis_angmom.f90 index f27a87c2c..ce25dbc04 100644 --- a/src/utils/analysis_angmom.f90 +++ b/src/utils/analysis_angmom.f90 @@ -88,7 +88,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) ! Write angular momentum information if (first) then first = .false. - open(newunit=iu, file='angmom.ev',status='replace') + open(newunit=iu,file='angmom.ev',status='replace') write(iu,"('#',5(1x,'[',i2.2,1x,a11,']',2x))") & 1,'time',& 2,'L_{gas}', & @@ -96,7 +96,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) 4,'L_{spin}', & 5,'L_{total}' else - open(newunit=iu, file='angmom.ev',position='append') + open(newunit=iu,file='angmom.ev',position='append') endif write(iu,'(6(es18.10,1X))') time*utime/years,Ltot_mag*unit_angmom,Lsink_mag*unit_angmom,& Lspin_mag*unit_angmom,L_total_mag*unit_angmom diff --git a/src/utils/analysis_angmomvec.f90 b/src/utils/analysis_angmomvec.f90 index 31c6d6c3d..eac98cd34 100644 --- a/src/utils/analysis_angmomvec.f90 +++ b/src/utils/analysis_angmomvec.f90 @@ -42,7 +42,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) ! Write angular momentum vector information if (first) then first = .false. - open(unit=iu, file='angmomvec.ev',status='replace') + open(unit=iu,file='angmomvec.ev',status='replace') write(iu,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & 1,'time',& 2,'Lx', & @@ -51,7 +51,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) 5,'inc', & 6,'rot' else - open(unit=iu, file='angmomvec.ev',position='append') + open(unit=iu,file='angmomvec.ev',position='append') endif write(iu,'(6(es18.10,1X))') time,Lhat,inc,rot close(iu) diff --git a/src/utils/analysis_average_orb_en.f90 b/src/utils/analysis_average_orb_en.f90 index f9c99a3af..c1c99003e 100644 --- a/src/utils/analysis_average_orb_en.f90 +++ b/src/utils/analysis_average_orb_en.f90 @@ -41,14 +41,14 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) if (first) then first = .false. - open(unit=iu, file='orbitalenergy.ev',status='replace') + open(unit=iu,file='orbitalenergy.ev',status='replace') write(iu,"('#',4(1x,'[',i2.2,1x,a11,']',2x))") & 1,'time',& 2,'ekin',& 3,'epot',& 4,'etot' else - open(unit=iu, file='orbitalenergy.ev',position='append') + open(unit=iu,file='orbitalenergy.ev',position='append') endif write(iu,'(4(es18.10,1X))') time,ekin_av,epot_av,e_av close(iu) diff --git a/src/utils/analysis_clumpfind.F90 b/src/utils/analysis_clumpfind.F90 index 0d889e5bb..809036724 100644 --- a/src/utils/analysis_clumpfind.F90 +++ b/src/utils/analysis_clumpfind.F90 @@ -377,7 +377,7 @@ subroutine read_analysis_options(dumpfile) if (inputexist) then print '(a,a,a)', "File ",inputfile, " found: reading analysis options" - open(10,file=inputfile, form='formatted') + open(10,file=inputfile,form='formatted') read(10,*) boundchoice read(10,*) sinkchoice read(10,*) skipchoice @@ -413,7 +413,7 @@ subroutine read_analysis_options(dumpfile) if (skipsmalldumps) skipchoice = 'y' ! Write choices to new inputfile - open(10,file=inputfile, status='new', form='formatted') + open(10,file=inputfile,status='new',form='formatted') write(10,*) boundchoice, " Test clumps for gravitational boundness?" write(10,*) sinkchoice, " Include sinks' contribution to potential?" write(10,*) skipchoice, " Skip small dumps (velocity data missing)?" @@ -465,7 +465,7 @@ subroutine amend_options_file(dumpfile) character(len=*),intent(in) :: dumpfile ! Open the options file, and wind forward to the line of interest - open(10,file='clumpfind.options', form='formatted') + open(10,file='clumpfind.options',form='formatted') read(10,*) read(10,*) read(10,*) @@ -979,7 +979,7 @@ subroutine write_clump_data(nclump,deletedclumps,npart,time,dumpfile,tag) clumpfile = trim(tag)//"_clumpcat_"//trim(dumpfile) - open(10,file=clumpfile, status='unknown') + open(10,file=clumpfile,status='unknown') write(10,*) nclump-deletedclumps, time do iclump=1,nclump @@ -1006,7 +1006,7 @@ subroutine write_clump_data(nclump,deletedclumps,npart,time,dumpfile,tag) if (member(i) > 0) member(i) = clump(member(i))%ID enddo - open(10,file=clumpfile, form='unformatted') + open(10,file=clumpfile,form='unformatted') write(10) (member(i), i=1,npart) close(10) @@ -1033,7 +1033,7 @@ subroutine read_oldclump_data(noldclump,npart,oldtime,olddumpfile,tag) clumpfile = trim(tag)//"_clumpcat_"//trim(olddumpfile) - open(10,file=clumpfile, status='unknown') + open(10,file=clumpfile,status='unknown') read(10,*) noldclump, oldtime allocate(oldclump(noldclump)) @@ -1054,7 +1054,7 @@ subroutine read_oldclump_data(noldclump,npart,oldtime,olddumpfile,tag) allocate(oldmember(npart)) - open(10,file=clumpfile, form='unformatted') + open(10,file=clumpfile,form='unformatted') read(10) (oldmember(i), i=1,npart) close(10) diff --git a/src/utils/analysis_clumpfindWB23.F90 b/src/utils/analysis_clumpfindWB23.F90 index da430b9ff..00e59de56 100644 --- a/src/utils/analysis_clumpfindWB23.F90 +++ b/src/utils/analysis_clumpfindWB23.F90 @@ -687,7 +687,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) !--Write results to file (both all the clumps at the current time, and to the file for each clump) write(filename,'(2a)') trim(dumpfile),'clumps' - open (unit=iunit,file=trim(filename)) + open(unit=iunit,file=trim(filename)) write(iunit,'(a,I6,a,Es18.6)') '#Nclumps = ',nclump,'; Time = ',time write(iunit,"('#',24(1x,'[',i2.2,1x,a11,']',2x))") & 1,'clump ID', & diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 86ee7cb4f..4956e561c 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -570,12 +570,12 @@ subroutine planet_mass_distribution(time,num,npart,xyzh) write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" if (num == 0) then - open(newunit=iu, file=trim(adjustl(filename)), status='replace') + open(newunit=iu,file=trim(adjustl(filename)),status='replace') write(headerline, "(a,i5,a,f5.2,a,f5.2)") "# Planet mass distribution, nbins = ", nbins,", min a = ", mina, ", max a = ", maxa write(iu, "(a)") headerline close(unit=iu) endif - open(newunit=iu, file=trim(adjustl(filename)), position='append') + open(newunit=iu,file=trim(adjustl(filename)), position='append') write(iu,data_formatter) time,hist_var(:) close(unit=iu) @@ -1629,7 +1629,7 @@ subroutine eos_surfaces enddo enddo - open(unit=1000, file='mesa_eos_pressure.out', status='replace') + open(unit=1000,file='mesa_eos_pressure.out',status='replace') !Write data to file do i=1,1000 @@ -1638,7 +1638,7 @@ subroutine eos_surfaces close(unit=1000) - open(unit=1002, file='mesa_eos_gamma.out', status='replace') + open(unit=1002,file='mesa_eos_gamma.out',status='replace') !Write data to file do i=1,1000 @@ -1647,7 +1647,7 @@ subroutine eos_surfaces close(unit=1002) - open(unit=1001, file='mesa_eos_kappa.out', status='replace') + open(unit=1001,file='mesa_eos_kappa.out',status='replace') !Write data to file do i=1,1000 @@ -1801,12 +1801,12 @@ subroutine tau_profile(time,num,npart,particlemass,xyzh) write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" if (num == 0) then unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(filename)), status='replace') + open(unit=unitnum,file=trim(adjustl(filename)),status='replace') write(unitnum, "(a)") '# Optical depth profile' close(unit=unitnum) endif unitnum=1002 - open(unit=unitnum, file=trim(adjustl(filename)), position='append') + open(unit=unitnum,file=trim(adjustl(filename)), position='append') write(unitnum,data_formatter) time,tau_r close(unit=unitnum) deallocate(rad_part,kappa_part,rho_part) @@ -1872,12 +1872,12 @@ subroutine tconv_profile(time,num,npart,particlemass,xyzh,vxyzu) write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" if (num == 0) then unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(filename)), status='replace') + open(unit=unitnum,file=trim(adjustl(filename)),status='replace') write(unitnum, "(a)") '# Sound crossing time profile' close(unit=unitnum) endif unitnum=1002 - open(unit=unitnum, file=trim(adjustl(filename)), position='append') + open(unit=unitnum,file=trim(adjustl(filename)), position='append') write(unitnum,data_formatter) time,tconv close(unit=unitnum) @@ -2027,11 +2027,11 @@ subroutine energy_hist(time,npart,particlemass,xyzh,vxyzu) call histogram_setup(coord(:,i),quant,hist,npart,Emax(i),Emin(i),nbins,.false.,ilogbins) if (dump_number == 0) then unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(filename(i))), status='replace') + open(unit=unitnum,file=trim(adjustl(filename(i))),status='replace') close(unit=unitnum) endif unitnum=1001+i - open(unit=unitnum, file=trim(adjustl(filename(i))), status='old', position='append') + open(unit=unitnum,file=trim(adjustl(filename(i))),status='old', position='append') write(unitnum,data_formatter) time,hist close(unit=unitnum) enddo @@ -2189,12 +2189,12 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) call histogram_setup(coord,quant(:,i),hist,npart,maxcoord,mincoord,nbins,.true.,ilogbins) if (dump_number == 0) then unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(filename(i))), status='replace') + open(unit=unitnum,file=trim(adjustl(filename(i))),status='replace') write(unitnum, "(a)") trim(headerline(i)) close(unit=unitnum) endif unitnum=1001+i - open(unit=unitnum, file=trim(adjustl(filename(i))), status='old', position='append') + open(unit=unitnum,file=trim(adjustl(filename(i))),status='old', position='append') write(unitnum,data_formatter) time,hist close(unit=unitnum) enddo @@ -2266,12 +2266,12 @@ subroutine rotation_profile(time,num,npart,xyzh,vxyzu) write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" if (num == 0) then unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(grid_file(i))), status='replace') + open(unit=unitnum,file=trim(adjustl(grid_file(i))),status='replace') write(unitnum, "(a)") '# z-component of angular velocity' close(unit=unitnum) endif unitnum=1001+i - open(unit=unitnum, file=trim(adjustl(grid_file(i))), position='append') + open(unit=unitnum,file=trim(adjustl(grid_file(i))), position='append') write(unitnum,data_formatter) time,hist_var(:) close(unit=unitnum) enddo @@ -2320,11 +2320,11 @@ subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) file_name2 = "vel_unbound.ev" if (dump_number == 0) then - open(newunit=iu1, file=file_name1, status='replace') - open(newunit=iu2, file=file_name2, status='replace') + open(newunit=iu1,file=file_name1,status='replace') + open(newunit=iu2,file=file_name2,status='replace') else - open(newunit=iu1, file=file_name1, position='append') - open(newunit=iu2, file=file_name2, position='append') + open(newunit=iu1,file=file_name1, position='append') + open(newunit=iu2,file=file_name2, position='append') endif write(iu1,data_formatter) time,vbound @@ -2387,11 +2387,11 @@ subroutine velocity_profile(time,num,npart,particlemass,xyzh,vxyzu) call histogram_setup(rad_part,dist_part,hist,count,rmax,rmin,nbins,.true.,.false.) write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" if (num == 0) then - open(newunit=iu, file=trim(adjustl(file_name)), status='replace') + open(newunit=iu,file=trim(adjustl(file_name)),status='replace') write(iu, "(a)") '# Azimuthal velocity profile' close(unit=iu) endif - open(newunit=iu, file=trim(adjustl(file_name)), position='append') + open(newunit=iu,file=trim(adjustl(file_name)), position='append') write(iu,data_formatter) time,hist close(unit=iu) deallocate(hist,dist_part,rad_part) @@ -2449,11 +2449,11 @@ subroutine angular_momentum_profile(time,num,npart,particlemass,xyzh,vxyzu) call histogram_setup(rad_part,dist_part,hist,count,rmax,rmin,nbins,.true.,.false.) write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" if (num == 0) then - open(newunit=iu, file=trim(adjustl(file_name)), status='replace') + open(newunit=iu,file=trim(adjustl(file_name)),status='replace') write(iu, "(a)") '# z-angular momentum profile' close(unit=iu) endif - open(newunit=iu, file=trim(adjustl(file_name)), position='append') + open(newunit=iu,file=trim(adjustl(file_name)), position='append') write(iu,data_formatter) time,hist close(unit=iu) @@ -2497,11 +2497,11 @@ subroutine vkep_profile(time,num,npart,particlemass,xyzh,vxyzu) call histogram_setup(rad_part,dist_part,hist,npart,rmax,rmin,nbins,.true.,.false.) write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" if (num == 0) then - open(newunit=iu, file=trim(adjustl(file_name)), status='replace') + open(newunit=iu,file=trim(adjustl(file_name)),status='replace') write(iu, "(a)") '# Keplerian velocity profile' close(unit=iu) endif - open(newunit=iu, file=trim(adjustl(file_name)), position='append') + open(newunit=iu,file=trim(adjustl(file_name)), position='append') write(iu,data_formatter) time,hist close(unit=iu) deallocate(hist,dist_part,rad_part) @@ -2546,7 +2546,7 @@ subroutine planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) ! Write to file file_name = trim(dumpfile)//".planetpart" - open(newunit=iu, file=file_name, status='replace') + open(newunit=iu,file=file_name,status='replace') ! Record R and z cylindrical coordinates w.r.t. planet_com do i = 1,nplanet @@ -2664,14 +2664,14 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) if (num == 0) then ! Write header line unitnum = 1000 - open(unit=unitnum, file=trim(adjustl(grid_file(i))), status='replace') + open(unit=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(unit=unitnum,file=trim(adjustl(grid_file(i))), position='append') write(unitnum,"()") write(unitnum,data_formatter) time,hist_var(:) @@ -2897,26 +2897,26 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) write(logical_format, "(a,I5,a)") "(es18.10e3,", npart, "(1x,L))" ! Time column plus npart columns if (num == 0) then ! Write header line - open(unit=1000, file="H_state.ev", status='replace') + open(unit=1000,file="H_state.ev",status='replace') write(1000, "(a)") '# Ion fraction statistics' close(unit=1000) - open(unit=1001, file="He_state.ev", status='replace') + open(unit=1001,file="He_state.ev",status='replace') write(1001, "(a)") '# Ion fraction statistics' close(unit=1001) - open(unit=1002, file="isbound.ev", status='replace') + open(unit=1002,file="isbound.ev",status='replace') write(1002, "(a)") '# Ion fraction statistics' close(unit=1002) endif - open(unit=1000, file="H_state.ev", position='append') + open(unit=1000,file="H_state.ev", position='append') write(1000,data_formatter) time,H_state(:) close(unit=1000) - open(unit=1000, file="He_state.ev", position='append') + open(unit=1000,file="He_state.ev", position='append') write(1000,data_formatter) time,He_state(:) close(unit=1000) - open(unit=1000, file="isbound.ev", position='append') + open(unit=1000,file="isbound.ev", position='append') write(1000,logical_format) time,isbound(:) close(unit=1000) @@ -4314,7 +4314,7 @@ subroutine write_file(name_in, dir_in, cols, data_in, npart, ncols, num) write(file_name, "(2a,i5.5,a)") trim(name_in), "_", num, ".ev" - open(unit=unitnum, file='./'//dir_in//'/'//file_name, status='replace') + open(unit=unitnum,file='./'//dir_in//'/'//file_name,status='replace') write(column_formatter, "(a,I2.2,a)") "('#',2x,", ncols, "('[',a15,']',3x))" write(data_formatter, "(a,I2.2,a)") "(", ncols, "(2x,es19.11e3))" @@ -4354,7 +4354,7 @@ subroutine write_time_file(name_in, cols, time, data_in, ncols, num) if (num == 0) then unitnum = 1000 - open(unit=unitnum, file=file_name, status='replace') + open(unit=unitnum,file=file_name,status='replace') do i=1,ncols write(columns(i), "(I2,a)") i+1, cols(i) enddo @@ -4366,7 +4366,7 @@ subroutine write_time_file(name_in, cols, time, data_in, ncols, num) unitnum=1001+num - open(unit=unitnum, file=file_name, position='append') + open(unit=unitnum,file=file_name, position='append') write(unitnum,data_formatter) time, data_in(:ncols) diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index 80ce222ac..006fa7d65 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -119,7 +119,7 @@ subroutine read_analysis_options print '(a,a,a)', "Parameter file ",inputfile, " found: reading analysis options" - open(10,file=inputfile, form='formatted') + open(10,file=inputfile,form='formatted') read(10,*) nbins read(10,*) rin read(10,*) rout @@ -135,7 +135,7 @@ subroutine read_analysis_options ! Write choices to new inputfile - open(10,file=inputfile, status='new', form='formatted') + open(10,file=inputfile,status='new',form='formatted') write(10,*) nbins, " Number of radial bins" write(10,*) rin, " Inner Disc Radius" write(10,*) rout, " Outer Disc Radius" diff --git a/src/utils/analysis_gws.f90 b/src/utils/analysis_gws.f90 index 9be0e4330..70b12ab2b 100644 --- a/src/utils/analysis_gws.f90 +++ b/src/utils/analysis_gws.f90 @@ -87,7 +87,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunitone) ! Write a file where I append all the values of the strain wrt time if (first) then first = .false. - open(unit=iu, file='strain.gw',status='replace') + open(unit=iu,file='strain.gw',status='replace') write(iu,"('#',9(1x,'[',i2.2,1x,a11,']',2x))") & 1, 'time', & 2, 'hx_0', & @@ -99,7 +99,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunitone) 8, 'hx_{90}', & 9, 'hx_{90}' else - open(unit=iu, file='strain.gw',position='append') + open(unit=iu,file='strain.gw',position='append') endif print*, 'time', time @@ -125,7 +125,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunitone) ! Write a file where I append all the values of the strain wrt time if (firstdump) then firstdump = .false. - open(unit=iuu, file='quadrupole.txt',status='replace') + open(unit=iuu,file='quadrupole.txt',status='replace') write(iuu,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & 1, 'q11', & 2, 'q12', & @@ -134,14 +134,14 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunitone) 5, 'q23', & 6, 'q33' else - open(unit=iuu, file='quadrupole.txt',position='append') + open(unit=iuu,file='quadrupole.txt',position='append') endif write(iuu,'(6(es18.10,1X))') q(1), q(2), q(3), q(4), q(5), q(6) if (firstdumpa) then firstdumpa = .false. - open(unit=iuuu, file='second_time_quadrupole.txt',status='replace') + open(unit=iuuu,file='second_time_quadrupole.txt',status='replace') write(iuuu,"('#',7(1x,'[',i2.2,1x,a11,']',2x))") & 1, 'time',& 2, 'ddq_xy(1,1)', & @@ -151,7 +151,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunitone) 6, 'ddq_xy(2,3)', & 7, 'ddq_xy(3,3)' else - open(unit=iuuu, file='second_time_quadrupole.txt',position='append') + open(unit=iuuu,file='second_time_quadrupole.txt',position='append') endif write(iuuu,'(7(es18.10,1X))') time,ddq_xy(1,1),ddq_xy(1,2),ddq_xy(1,3),ddq_xy(2,2),ddq_xy(2,3),ddq_xy(3,3) diff --git a/src/utils/analysis_kepler.f90 b/src/utils/analysis_kepler.f90 index 4708f1ad4..e057510cb 100644 --- a/src/utils/analysis_kepler.f90 +++ b/src/utils/analysis_kepler.f90 @@ -641,16 +641,16 @@ subroutine composition_array(interpolate_comp,columns_compo,comp_label) !Save composition read from file. allocate(interpolate_comp(columns_compo,n_rows)) - open(12, file=filename) + open(12,file=filename) ierr = 0 !get column labels and send them back. - read(12, '(a)', iostat=ierr) line + read(12, '(a)',iostat=ierr) line allocate(comp_label(columns_compo)) call get_column_labels(line,n_labels,comp_label) close(12) print*,"comp_label ",comp_label - open(13, file=filename) + open(13,file=filename) call skip_header(13,nheader,ierr) do k = 1, n_rows read(13,*,iostat=ierr) interpolate_comp(:,k) @@ -814,14 +814,14 @@ subroutine write_dump_info(fileno,density,temperature,mass,xpos,rad,distance,pos ! open the file for appending or creating if (file_exists) then - open(unit=file_id, file=filename, status='old', position="append", action="write", iostat=status) + open(unit=file_id,file=filename,status='old', position="append",action="write",iostat=status) if (status /= 0) then write(*,*) 'Error opening file: ', filename stop endif else - open(unit=file_id, file=filename, status='new', action='write', iostat=status) + open(unit=file_id,file=filename,status='new',action='write',iostat=status) if (status /= 0) then write(*,*) 'Error creating file: ', filename stop diff --git a/src/utils/analysis_prdrag.f90 b/src/utils/analysis_prdrag.f90 index 14160df8a..8372c5c23 100644 --- a/src/utils/analysis_prdrag.f90 +++ b/src/utils/analysis_prdrag.f90 @@ -48,7 +48,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) real :: r1, r2 print*,' Hello Hauke, time in file = ',time - open( unit=106, file='radial.out', status='replace', iostat=ierr) + open( unit=106,file='radial.out',status='replace', iostat=ierr) if ( ierr /= 0 ) stop 'error opening radial.out' call make_beta_grids( xyzh, particlemass, npart ) @@ -67,7 +67,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) enddo close( 106 ) - open( unit=106, file='radialinterp.out', status='replace', iostat=ierr) + open( unit=106,file='radialinterp.out',status='replace', iostat=ierr) if ( ierr /= 0 ) stop 'error opening radialinterp.out' write(106,*), "#r_rad rbin theta thetabin r_cyl z rho tau beta" @@ -93,7 +93,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) close(106) - open( unit=106, file='applied.out', status='replace', iostat=ierr) + open( unit=106,file='applied.out',status='replace', iostat=ierr) if ( ierr /= 0 ) stop 'error opening applied.out' write(106,*), "#x y z r_cyl beta r_bin th_bin" diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index 4f0f840cd..f70a7589a 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.f90 @@ -254,7 +254,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) else call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') endif - open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + open(newunit=iu4,file='neighbors_tess.txt',status='old',action='read') do i=1, npart2+2 read(iu4,*) neighb(i,:) enddo @@ -295,11 +295,11 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='times_inwards_'//dumpfile//'.txt',status='replace',action='write') write(iu4, *) timeTau close(iu4) totalTime = timeTau - open(newunit=iu2, file='taus_inwards_SPH_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_inwards_SPH_'//dumpfile//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -313,7 +313,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) else call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') endif - open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + open(newunit=iu4,file='neighbors_tess.txt',status='old',action='read') do i=1, npart2+2 read(iu4,*) neighb(i,:) enddo @@ -331,18 +331,18 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_inwards_'//dumpfile//'.txt',position='append',status='old',action='write') write(iu4, *) timeTau close(iu4) totalTime = timeTau - open(newunit=iu2, file='taus_inwards_Del_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_inwards_Del_'//dumpfile//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo ! OUTWARD INTEGRATION realTIME ANALYSIS elseif (method == 2) then - open(newunit=iu4, file='times_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='times_'//dumpfile//'.txt',status='replace',action='write') close(iu4) totalTime=0 @@ -361,11 +361,11 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_'//dumpfile//'.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_'//dumpfile//'.txt',position='append',status='old',action='write') write(iu4, *) timeTau close(iu4) totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_'//trim(jstring)//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -376,7 +376,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS elseif (method == 3) then - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='times_interpolation_'//dumpfile//'.txt',status='replace',action='write') close(iu4) totalTime=0 @@ -395,12 +395,12 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_interpolation_'//dumpfile//'.txt',position='append',status='old',action='write') write(iu4, *) timeTau close(iu4) totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & - status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & + status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -411,7 +411,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS elseif (method == 4) then - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='times_interpolation_'//dumpfile//'.txt',status='replace',action='write') close(iu4) totalTime=0 @@ -434,14 +434,14 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) print*,'Time = ',timeTau,' seconds.' times(k+1) = timeTau totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & - status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & + status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo close(iu2) enddo - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_interpolation_'//dumpfile//'.txt',position='append',status='old',action='write') write(iu4, *) times(1:7) close(iu4) enddo @@ -450,7 +450,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) !ADAPTIVE (OUTWARD) INTEGRATION ANALYSIS elseif (method == 5) then - open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='times_adapt_'//dumpfile//'.txt',status='replace',action='write') close(iu4) totalTime=0 @@ -475,14 +475,14 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) print*,'Time = ',timeTau,' seconds.' times(k-minOrder+1) = timeTau totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & - '_'//trim(kstring)//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & + '_'//trim(kstring)//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo close(iu2) enddo - open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_adapt_'//dumpfile//'.txt',position='append',status='old',action='write') write(iu4, *) times(1:maxOrder-minOrder+1) close(iu4) enddo @@ -493,7 +493,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) elseif (method == 6) then order = 5 print*,'Start doing scaling analysis with order =',order - open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt', status='replace', action='write') + open(newunit=iu4,file='times_'//dumpfile//'_scaling.txt',status='replace',action='write') close(iu4) do i=1, omp_get_max_threads() call omp_set_num_threads(i) @@ -511,7 +511,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'nthread = ',omp_get_max_threads(),': Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_'//dumpfile//'_scaling.txt',position='append',status='old',action='write') write(iu4, *) omp_get_max_threads(), timeTau close(iu4) enddo @@ -531,14 +531,14 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu1, file='npart_wind.txt',position='append', action='write') + open(newunit=iu1,file='npart_wind.txt',position='append',action='write') write(iu1, *) npart2 close(iu1) - open(newunit=iu4, file='times_wind.txt',position='append', action='write') + open(newunit=iu4,file='times_wind.txt',position='append',action='write') write(iu4, *) timeTau close(iu4) totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -562,9 +562,9 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' if (SPH) then - open(newunit=iu2, file='taus_'//dumpfile//'_inwards.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_inwards.txt',status='replace',action='write') else - open(newunit=iu2, file='taus_'//dumpfile//'_tess_inwards.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_tess_inwards.txt',status='replace',action='write') endif do i=1, size(tau) write(iu2, *) tau(i) @@ -584,7 +584,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_'//trim(jstring)//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -603,7 +603,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_'//trim(jstring)//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -623,8 +623,8 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & - '_'//trim(kstring)//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & + '_'//trim(kstring)//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -646,7 +646,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='taus_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='taus_'//dumpfile//'.txt',status='replace',action='write') do i=1, size(tau) write(iu4, *) tau(i) enddo @@ -660,7 +660,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) enddo ! allocate(neighb(npart2+2,100)) ! neighb = 0 - ! open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + ! open(newunit=iu4,file='neighbors_tess.txt',status='old',action='read') ! do i=1, npart2+2 ! read(iu4,*) neighb(i,:) ! enddo @@ -674,20 +674,20 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_raypolation_7.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_raypolation_7.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo close(iu2) elseif (analyses == 5) then - open(newunit=iu1, file='points_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu1,file='points_'//dumpfile//'.txt',status='replace',action='write') do i=1, npart2+2 write(iu1, *) xyzh2(1:3,i) enddo close(iu1) - open(newunit=iu3, file='rho_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu3,file='rho_'//dumpfile//'.txt',status='replace',action='write') do i=1,npart2 rho(i) = rhoh(xyzh2(4,i), particlemass) write(iu3, *) rho(i) diff --git a/src/utils/analysis_velocitydispersion_vs_scale.f90 b/src/utils/analysis_velocitydispersion_vs_scale.f90 index 628f147fa..ec46ee0b6 100644 --- a/src/utils/analysis_velocitydispersion_vs_scale.f90 +++ b/src/utils/analysis_velocitydispersion_vs_scale.f90 @@ -358,7 +358,7 @@ subroutine read_analysis_options print '(a,a,a)', "Parameter file ",inputfile, " found: reading analysis options" - open(10,file=inputfile, form='formatted') + open(10,file=inputfile,form='formatted') read(10,*) nscale read(10,*) rscalemin read(10,*) rscalemax @@ -376,7 +376,7 @@ subroutine read_analysis_options ! Write choices to new inputfile - open(10,file=inputfile, status='new', form='formatted') + open(10,file=inputfile,status='new',form='formatted') write(10,*) nscale, " Number of scale evaluations" write(10,*) rscalemin, " Minimum scale (code units)" write(10,*) rscalemax, " Maximum scale (code units)" diff --git a/src/utils/analysis_velocityshear.f90 b/src/utils/analysis_velocityshear.f90 index 134e91990..da5209758 100644 --- a/src/utils/analysis_velocityshear.f90 +++ b/src/utils/analysis_velocityshear.f90 @@ -517,7 +517,7 @@ subroutine write_eigenfiles(valuefile,vectorfile, ngas) ! Write eigenvalues to file print*, 'Writing eigenvalues to file ', trim(valuefile) - open(27,file=trim(valuefile), status='unknown',form='unformatted') + open(27,file=trim(valuefile),status='unknown',form='unformatted') write(27) ngas write(27) (eigenpart(i),i=1,ngas) write(27) (xbin(i), i=1,ngas) @@ -530,7 +530,7 @@ subroutine write_eigenfiles(valuefile,vectorfile, ngas) ! Now write the eigenvectors to file print*, 'Writing eigenvectors to file ', trim(vectorfile) - open(27,file=trim(vectorfile),status='unknown', form='unformatted') + open(27,file=trim(vectorfile),status='unknown',form='unformatted') write(27) ngas write(27) (eigenpart(i),i=1,ngas) write(27) (eigenvectors(1,1:3,i),i=1,ngas) diff --git a/src/utils/analysis_write_kdtree.F90 b/src/utils/analysis_write_kdtree.F90 index 58e2cdcc9..f27f4d623 100644 --- a/src/utils/analysis_write_kdtree.F90 +++ b/src/utils/analysis_write_kdtree.F90 @@ -90,7 +90,7 @@ subroutine write_kdtree_file(dumpfile) print '(a,a,I7)', 'This file does not contains masses: ', filetag, ncells #endif - open(10,file=treefile, form='unformatted') + open(10,file=treefile,form='unformatted') ! Write header data write(10) filetag, ncells @@ -134,7 +134,7 @@ subroutine read_kdtree_file(dumpfile) treefile = 'kdtree_'//trim(dumpfile) print'(a,a)', 'Reading kdtree from binary file ', trim(treefile) - open(10,file=treefile, form='unformatted') + open(10,file=treefile,form='unformatted') ! Read header read(10) filetag, ncells diff --git a/src/utils/io_structurefn.f90 b/src/utils/io_structurefn.f90 index ca736c360..00af14e20 100644 --- a/src/utils/io_structurefn.f90 +++ b/src/utils/io_structurefn.f90 @@ -242,7 +242,7 @@ subroutine openw_sf (file,origin,n_lag,lag,n_order,n_rho_power) real, intent(in) :: lag(n_lag) namelist /structurefn/n_lag,n_order,n_rho_power,origin ! - open (power_unit,file=trim(file),status='unknown',form='formatted') ! open unit + open(power_unit,file=trim(file),status='unknown',form='formatted') ! open unit write (power_unit,structurefn) ! dimensions info write (power_unit,'(1x,8g15.7)') lag ! lag vector end subroutine openw_sf diff --git a/src/utils/moddump_growthtomultigrain.f90 b/src/utils/moddump_growthtomultigrain.f90 index 0c5e599df..bcc8ab7c4 100644 --- a/src/utils/moddump_growthtomultigrain.f90 +++ b/src/utils/moddump_growthtomultigrain.f90 @@ -62,7 +62,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call prompt('Enter number of bins per dex',bins_per_dex,1) else !- file created by phantom/scripts/growthtomcfost.py module - open (unit=420, file=infile) + open(unit=420,file=infile) read(420,*) force_smax, smax_user, bins_per_dex close(unit=420) endif diff --git a/src/utils/utils_getneighbours.F90 b/src/utils/utils_getneighbours.F90 index 41fedb45f..d63d33e1c 100644 --- a/src/utils/utils_getneighbours.F90 +++ b/src/utils/utils_getneighbours.F90 @@ -251,7 +251,7 @@ subroutine read_neighbours(neighbourfile,npart) neighb(:,:) = 0 print*, 'Reading neighbour file ', trim(neighbourfile) - open(2, file= neighbourfile, form = 'UNFORMATTED') + open(2,file= neighbourfile, form = 'UNFORMATTED') read(2) neighcheck, tolcheck, meanneigh,sdneigh,neighcrit if (neighcheck/=neighmax) print*, 'WARNING: mismatch in neighmax: ', neighmax, neighcheck read(2) (neighcount(i), i=1,npart) @@ -290,7 +290,7 @@ subroutine write_neighbours(neighbourfile,npart) neighbourfile = trim(neighbourfile) print*, 'Writing neighbours to file ', neighbourfile - open (2, file=neighbourfile, form='unformatted') + open(2,file=neighbourfile,form='unformatted') write(2) neighmax, tolerance, meanneigh,sdneigh,neighcrit write(2) (neighcount(i), i=1,npart) do i=1,npart diff --git a/src/utils/utils_gravwave.f90 b/src/utils/utils_gravwave.f90 index 225f091b6..5f568aaad 100644 --- a/src/utils/utils_gravwave.f90 +++ b/src/utils/utils_gravwave.f90 @@ -272,7 +272,7 @@ subroutine write_rotated_strain_components(time,ddq_xy) ! Write a file where I append all the values of the strain wrt time if (firstdump) then firstdump = .false. - open(newunit=iuu, file='quadrupole_plane_xy.txt',status='replace') + open(newunit=iuu,file='quadrupole_plane_xy.txt',status='replace') write(iuu,"('#',7(1x,'[',i2.2,1x,a11,']',2x))") & 1, 'time', & 2, 'ddm11', & @@ -282,7 +282,7 @@ subroutine write_rotated_strain_components(time,ddq_xy) 6, 'ddm23', & 7, 'ddm33' else - open(newunit=iuu, file='quadrupole_plane_xy.txt',position='append') + open(newunit=iuu,file='quadrupole_plane_xy.txt',position='append') endif write(iuu,'(7(es18.10,1X))') time, ddq_xy(1,1),ddq_xy(1,2),ddq_xy(1,3),& ddq_xy(2,2),ddq_xy(2,3),ddq_xy(3,3) From 9b4966af920f0da5558ee04221ae9632ab4fbe50 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 24 Apr 2024 09:57:21 +1000 Subject: [PATCH 475/814] (bots) bug fix in format bot --- scripts/bots.sh | 2 +- src/main/extern_spiral.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/bots.sh b/scripts/bots.sh index f47288cec..4fbc6d2f6 100755 --- a/scripts/bots.sh +++ b/scripts/bots.sh @@ -295,7 +295,7 @@ for edittype in $bots_to_run; do -e 's/, action=/,action=/g' \ -e 's/, iomsg = /,iomsg=/g' \ -e 's/, iomsg=/,iomsg=/g' \ - -e 's/(unit =/,(unit=/g' \ + -e 's/(unit =/(unit=/g' \ -e 's/if(/if (/g' \ -e 's/)then/) then/g' $file > $out;; 'header' ) diff --git a/src/main/extern_spiral.f90 b/src/main/extern_spiral.f90 index c2d97b0f2..f27a06d9f 100644 --- a/src/main/extern_spiral.f90 +++ b/src/main/extern_spiral.f90 @@ -420,7 +420,7 @@ subroutine initialise_spiral(ierr) case(1) potfilename = 'pot3D.bin' if (id==master) print*,'Reading in potential from an external file (BINARY): ',potfilename - open,(unit=1,file=trim(potfilename),status='old',form='UNFORMATTED',access='SEQUENTIAL',iostat=ios) + open(unit=1,file=trim(potfilename),status='old',form='UNFORMATTED',access='SEQUENTIAL',iostat=ios) if (ios /= 0 .and. id==master) then print*, 'Error opening file:', trim(potfilename) endif From fde336c27951fd5a896fc8730d812cfb5a5bf3b0 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 10:59:12 +1000 Subject: [PATCH 476/814] fix bad reduction in the group potential calculation --- src/main/sdar_group.f90 | 11 ++++++----- src/main/substepping.F90 | 5 +++-- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 81c015365..9f04da39a 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -16,7 +16,7 @@ module sdar_group real, parameter :: eta_pert = 20 real, parameter :: time_error = 2.5e-14 real, parameter :: max_step = 100000000 - real, parameter, public :: r_neigh = 0.0001 + real, parameter, public :: r_neigh = 0.001 real, public :: t_crit = 1.e-9 real, public :: C_bin = 0.02 real, public :: r_search = 100.*r_neigh @@ -700,26 +700,27 @@ subroutine get_pot_subsys(n_group,nptmass,group_info,xyzmh_ptmass,fxyz_ptmass,gt integer, intent(in) :: group_info(:,:) real, intent(inout) :: epot_sinksink integer :: i,start_id,end_id,gsize,prim,sec - real :: phitot + real :: phitot,phigroup phitot = 0. if (n_group>0) then if(id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,fxyz_ptmass)& !$omp shared(group_info,gtgrad)& - !$omp private(i,start_id,end_id,gsize,prim,sec)& + !$omp private(i,start_id,end_id,gsize,prim,sec,phigroup)& !$omp reduction(+:phitot) do i=1,n_group start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) gsize = (end_id - start_id) + 1 if (gsize>2) then - call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,phitot,start_id,end_id,.true.) + call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,phigroup,start_id,end_id,.true.) else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) - call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phitot,prim,sec,.true.) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phigroup,prim,sec,.true.) endif + phitot = phitot + phigroup enddo !$omp end parallel do endif diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index eaea883dd..4a98f3bf7 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -604,12 +604,13 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx ! Group all the ptmass in the system in multiple small group for regularization ! call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - !call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - ! vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) + call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) fsink_old = fxyz_ptmass From 8d6fcb131433825c3ac4594a1b93869fc20319e0 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 24 Apr 2024 11:41:16 +1000 Subject: [PATCH 477/814] (test_ptmass) adjust tolerance for swallowing disc test --- src/tests/test_ptmass.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index b5b73b2fb..7272f1276 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -745,7 +745,7 @@ subroutine test_accretion(ntests,npass,itest) nfailed(:) = 0 call compute_energies(t) call checkval(angtot,angmomin,1.e-14,nfailed(3),'angular momentum') - call checkval(totmom,totmomin,epsilon(0.),nfailed(2),'linear momentum') + call checkval(totmom,totmomin,2.*epsilon(0.),nfailed(2),'linear momentum') !call checkval(etot,etotin,1.e-6,'total energy',nfailed(1)) call update_test_scores(ntests,nfailed(3:3),npass) call update_test_scores(ntests,nfailed(2:2),npass) From be2f7d8afe7f87c9e452e04fa7d01f942791cc6c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 24 Apr 2024 11:51:11 +1000 Subject: [PATCH 478/814] (licence) fix #473 [skip ci] --- LICENCE | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/LICENCE b/LICENCE index 0562f6af7..ab1e73561 100644 --- a/LICENCE +++ b/LICENCE @@ -1,22 +1,19 @@ !------------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code ! -! Copyright (c) 2007-2019 Daniel Price and contributors (see AUTHORS file) ! +! Copyright (c) 2007-2024 Daniel Price and contributors (see AUTHORS file) ! !------------------------------------------------------------------------------! ! ! Phantom is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version, supplemented by the -! following two conditions under section 7c of GPLv3: +! following condition under section 7c of GPLv3: ! -! 1) The Phantom code paper should be cited in scientific -! publications using the code (Price et al. 2018; PASA 35, e031) -! -! 2) Any redistribution of substantial fractions of the code as a -! different project should preserve the word "Phantom" in the name -! of the code (in addition to the GPLv3 condition that this copyright -! notice be retained both here and in the source file headers) to -! prohibit misrepresentation of a redistribution as entirely new work +! * Any redistribution of substantial fractions of the code as a +! different project should preserve the word "Phantom" in the name +! of the code (in addition to the GPLv3 condition that this copyright +! notice be retained both here and in the source file headers) to +! prohibit misrepresentation of a redistribution as entirely new work ! ! Phantom is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of From 5e0243f6672f4dac5cf90da7212948e5d85b9c15 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 12:26:09 +1000 Subject: [PATCH 479/814] merge two substep subroutines and clean gradf routine --- src/main/ptmass.F90 | 246 ------------------------------ src/main/step_leapfrog.F90 | 17 +-- src/main/substepping.F90 | 303 +++++++++++-------------------------- 3 files changed, 91 insertions(+), 475 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 8385e0308..40bccb14d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -46,7 +46,6 @@ module ptmass public :: init_ptmass, finish_ptmass public :: pt_write_sinkev, pt_close_sinkev public :: get_accel_sink_gas, get_accel_sink_sink - public :: get_gradf_sink_gas, get_gradf_sink_sink public :: merge_sinks public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured @@ -551,251 +550,6 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin end subroutine get_accel_sink_sink -!---------------------------------------------------------------- -!+ -! get gradient correction of the force for FSI integrator (sink-gas) -!+ -!---------------------------------------------------------------- -subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & - pmassi,fxyz_ptmass,fsink_old) - use kernel, only:kernel_softening,kernel_grad_soft,radkern - integer, intent(in) :: nptmass - real, intent(in) :: xi,yi,zi,hi,dt - real, intent(inout) :: fxi,fyi,fzi - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(in) :: pmassi - real, intent(inout) :: fxyz_ptmass(4,nptmass) - real, intent(in) :: fsink_old(4,nptmass) - real :: gtmpxi,gtmpyi,gtmpzi - real :: dx,dy,dz,rr2,ddr,dr3,g11,g12,g21,g22,pmassj - real :: dfx,dfy,dfz,drdotdf - real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft,gpref - integer :: j - - gtmpxi = 0. ! use temporary summation variable - gtmpyi = 0. ! (better for round-off, plus we need this bit of - gtmpzi = 0. - - do j=1,nptmass - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - dfx = fxi - fsink_old(1,j) - dfy = fyi - fsink_old(2,j) - dfz = fzi - fsink_old(3,j) - pmassj = xyzmh_ptmass(4,j) - hsoft = xyzmh_ptmass(ihsoft,j) - if (hsoft > 0.0) hsoft = max(hsoft,hi) - if (pmassj < 0.0) cycle - - rr2 = dx*dx + dy*dy + dz*dz + epsilon(rr2) - drdotdf = dx*dfx + dy*dfy + dz*dfz + epsilon(drdotdf) - ddr = 1./sqrt(rr2) - if (rr2 < (radkern*hsoft)**2) then - ! - ! if the sink particle is given a softening length, soften the - ! force and potential if r < radkern*hsoft - ! - hsoft1 = 1.0/hsoft - hsoft21= hsoft1**2 - q2i = rr2*hsoft21 - qi = sqrt(q2i) - call kernel_softening(q2i,qi,psoft,fsoft) - - gpref = ((dt**2)/24.)*hsoft21 - - ! first grad term of gas due to point mass particle - g11 = pmassj*fsoft*ddr - - ! first grad term of sink from gas - g21 = pmassi*fsoft*ddr - - call kernel_grad_soft(q2i,qi,gsoft) - - dr3 = ddr*ddr*ddr - - ! Second grad term of gas due to point mass particle - g12 = pmassj*gsoft*dr3*drdotdf - - ! Second grad term of sink from gas - g22 = pmassi*gsoft*dr3*drdotdf - - gtmpxi = gtmpxi - gpref*(dfx*g11+dx*g12) - gtmpyi = gtmpyi - gpref*(dfy*g11+dy*g12) - gtmpzi = gtmpzi - gpref*(dfz*g11+dz*g12) - - - else - ! no softening on the sink-gas interaction - dr3 = ddr*ddr*ddr - - gpref = ((dt**2)/24.) - - ! first grad term of gas due to point mass particle - g11 = pmassj*dr3 - - ! first grad term of sink from gas - g21 = pmassi*dr3 - - ! first grad term of gas due to point mass particle - g12 = -3.*pmassj*dr3*ddr*ddr*drdotdf - - ! first grad term of sink from gas - g22 = -3.*pmassi*dr3*ddr*ddr*drdotdf - - - gtmpxi = gtmpxi - gpref*(dfx*g11+dx*g12) - gtmpyi = gtmpyi - gpref*(dfy*g11+dy*g12) - gtmpzi = gtmpzi - gpref*(dfz*g11+dz*g12) - endif - - ! backreaction of gas onto sink - fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + gpref*(dfx*g21 + dx*g22) - fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + gpref*(dfy*g21 + dy*g22) - fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + gpref*(dfz*g21 + dz*g22) - enddo - ! - ! add temporary sums to existing force on gas particle - ! - fxi = fxi + gtmpxi - fyi = fyi + gtmpyi - fzi = fzi + gtmpzi - -end subroutine get_gradf_sink_gas - -!---------------------------------------------------------------- -!+ -! get gradient correction of the force for FSI integrator (sink-gas) -!+ -!---------------------------------------------------------------- -subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) - use kernel, only:kernel_softening,kernel_grad_soft,radkern - use part, only:igarg,igid - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(inout) :: fxyz_ptmass(4,nptmass) - real, intent(in) :: fsink_old(4,nptmass) - real, intent(in) :: dt - integer, optional, intent(in) :: group_info(:,:) - real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,gxi,gyi,gzi - real :: ddr,dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,dr3,g1,g2 - real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft - real :: gpref - integer :: i,j,k,l,gidi,gidj - logical :: subsys - - if (present(group_info)) then - subsys = .true. - else - subsys=.false. - endif - - if (nptmass <= 1) return - if (h_soft_sinksink > 0.) then - hsoft1 = 1.0/h_soft_sinksink - hsoft21= hsoft1**2 - else - hsoft1 = 0. ! to avoid compiler warnings - hsoft21 = 0. - endif - ! - !--compute N^2 gradf on point mass particles due to each other - ! - !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) & - !$omp shared(h_soft_sinksink,hsoft21,dt,subsys) & - !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & - !$omp private(gidi,gidj) & - !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & - !$omp private(fxi,fyi,fzi,gxi,gyi,gzi,gpref) & - !$omp private(q2i,qi,psoft,fsoft,gsoft) - do k=1,nptmass - if (subsys) then - i = group_info(igarg,k) - gidi = group_info(igid,k) - else - i = k - endif - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) - pmassi = xyzmh_ptmass(4,i) - if (pmassi < 0.) cycle - fxi = fsink_old(1,i) - fyi = fsink_old(2,i) - fzi = fsink_old(3,i) - gxi = 0. - gyi = 0. - gzi = 0. - do l=1,nptmass - if (subsys) then - j = group_info(igarg,l) - gidj = group_info(igid,l) - if (gidi==gidj) cycle - else - j = l - endif - if (i==j) cycle - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - dfx = fxi - fsink_old(1,j) - dfy = fyi - fsink_old(2,j) - dfz = fzi - fsink_old(3,j) - pmassj = xyzmh_ptmass(4,j) - if (pmassj < 0.) cycle - - rr2 = dx*dx + dy*dy + dz*dz + epsilon(rr2) - drdotdf = dx*dfx + dy*dfy + dz*dfz - ddr = 1./sqrt(rr2) - - gpref = pmassj*((dt**2)/24.) - - if (rr2 < (radkern*h_soft_sinksink)**2) then - ! - ! if the sink particle is given a softening length, soften the - ! force and potential if r < radkern*h_soft_sinksink - ! - q2i = rr2*hsoft21 - qi = sqrt(q2i) - call kernel_softening(q2i,qi,psoft,fsoft) ! Note: psoft < 0 - - - ! gradf part 1 of sink1 from sink2 - g1 = fsoft*hsoft21*ddr - - call kernel_grad_soft(q2i,qi,gsoft) - - dr3 = ddr*ddr*ddr - - ! gradf part 2 of sink1 from sink2 - g2 = gsoft*hsoft21*dr3*drdotdf - gxi = gxi - gpref*(dfx*g1 + dx*g2) - gyi = gyi - gpref*(dfy*g1 + dy*g2) - gzi = gzi - gpref*(dfz*g1 + dz*g2) - - else - ! no softening on the sink-sink interaction - dr3 = ddr*ddr*ddr - - ! gradf part 1 of sink1 from sink2 - g1 = dr3 - ! gradf part 2 of sink1 from sink2 - g2 = -3.*dr3*ddr*ddr*drdotdf - gxi = gxi - gpref*(dfx*g1 + dx*g2) - gyi = gyi - gpref*(dfy*g1 + dy*g2) - gzi = gzi - gpref*(dfz*g1 + dz*g2) - endif - enddo - ! - !--store sink-sink forces (only) - ! - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + gxi - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + gyi - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + gzi - enddo -!$omp end parallel do -end subroutine get_gradf_sink_sink !---------------------------------------------------------------- !+ ! Update position of sink particles if they cross the periodic boundary diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index efb70bb49..f57331408 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -126,9 +126,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate - use ptmass, only:use_regnbody use substepping, only:substep,substep_gr, & - substep_sph_gr,substep_sph,step_extern_subsys + substep_sph_gr,substep_sph integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -250,15 +249,11 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif else if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then - if (use_regnbody) then - call step_extern_subsys(dtextforce,dtsph,t,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass,fsink_old,nbinmax,ibin_wake, & - gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) - else - call substep(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& - fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& - dptmass,fsink_old,nbinmax,ibin_wake) - endif + + call substep(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& + dptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info, & + nmatrix,n_group,n_ingroup,n_sing) else call substep_sph(dtsph,npart,xyzh,vxyzu) endif diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 4a98f3bf7..42b2deaaf 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -34,7 +34,6 @@ module substepping implicit none - public :: step_extern_subsys public :: substep_gr public :: substep_sph public :: substep_sph_gr @@ -427,22 +426,26 @@ end subroutine substep_sph !+ !---------------------------------------------------------------- subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & - fsink_old,nbinmax,ibin_wake) + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & + fsink_old,nbinmax,ibin_wake,gtgrad,group_info,nmatrix, & + n_group,n_ingroup,n_sing) use io, only:iverbose,id,master,iprint,fatal use options, only:iexternalforce use part, only:fxyz_ptmass_sinksink use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent - use ptmass, only:use_fourthorder,ck,dk + use ptmass, only:use_fourthorder,use_regnbody,ck,dk + use sdar_group, only:group_identify,evolve_groups integer, intent(in) :: npart,ntypes,nptmass + integer, intent(inout) :: n_group,n_ingroup,n_sing + integer, intent(inout) :: group_info(:,:) real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, intent(inout) :: dptmass(:,:),fsink_old(:,:) + real, intent(inout) :: dptmass(:,:),fsink_old(:,:),gtgrad(:,:) integer(kind=1), intent(in) :: nbinmax - integer(kind=1), intent(inout) :: ibin_wake(:) + integer(kind=1), intent(inout) :: ibin_wake(:),nmatrix(nptmass,nptmass) logical :: extf_vdep_flag,done,last_step,accreted integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step @@ -481,28 +484,57 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + if (use_regnbody) then + call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) + else + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag) + endif if (use_fourthorder) then !! FSI 4th order scheme ! FSI extrapolation method (Omelyan 2006) - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + if (use_regnbody) then + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old,group_info) - call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,group_info=group_info) + else + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + ! the last kick phase of the scheme will perform the accretion loop after velocity update + endif - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) - ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) - if (accreted) then + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,group_info=group_info) + elseif (accreted) then + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) endif else !! standard leapfrog scheme @@ -542,122 +574,6 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & end subroutine substep - - !---------------------------------------------------------------- - !+ - ! This is the equivalent of the routine below with no cooling - ! and external forces except ptmass with subsystems algorithms.. - !+ - !---------------------------------------------------------------- -subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & - dsdt_ptmass,dptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) - use part, only:isdead_or_accreted,igas,massoftype,fxyz_ptmass_sinksink,epot_sinksink - use io, only:iverbose,id,master,iprint,warning,fatal - use io_summary, only:summary_variable,iosumextr,iosumextt - use sdar_group, only:group_identify,evolve_groups,get_pot_subsys - use options, only:iexternalforce - use externalforces, only:is_velocity_dependent - use ptmass, only:dk,ck - real, intent(in) :: dtsph,time - integer, intent(in) :: npart,nptmass,ntypes - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass) - real, intent(inout) :: dptmass(:,:) - real, intent(inout) :: fsink_old(4,nptmass),dsdt_ptmass(3,nptmass),gtgrad(3,nptmass) - integer, intent(inout) :: group_info(3,nptmass) - integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) - integer(kind=1), intent(in) :: nbinmax - integer(kind=1), intent(inout) :: ibin_wake(:) - integer, intent(inout) :: n_ingroup,n_group,n_sing - logical :: extf_vdep_flag,done,last_step,accreted - integer :: force_count,nsubsteps - real :: timei,time_par,dt,t_end_step - real :: dtextforce_min,pmassi - - ! - ! determine whether or not to use substepping - ! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - - timei = time - time_par = time - extf_vdep_flag = is_velocity_dependent(iexternalforce) - pmassi = massoftype(igas) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - - substeps: do while (timei <= t_end_step .and. .not.done) - timei = timei + dt - if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) - force_count = 0 - nsubsteps = nsubsteps + 1 - ! - ! Group all the ptmass in the system in multiple small group for regularization - ! - call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - - call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - - call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - - call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) - - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) - fsink_old = fxyz_ptmass - call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) - - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - - call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - - call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) - - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) - - call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass, & - dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) - if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt - - dtextforce_min = min(dtextforce_min,dtextforce) - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - enddo substeps - - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - - -end subroutine step_extern_subsys - - - - !---------------------------------------------------------------- !+ ! drift routine for the whole system (part and ptmass) @@ -711,7 +627,6 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx end subroutine drift - !---------------------------------------------------------------- !+ ! kick routine for the whole system (part and ptmass) @@ -894,68 +809,6 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, end subroutine kick - !---------------------------------------------------------------- - !+ - ! grad routine for the 4th order scheme (FSI) - !+ - !---------------------------------------------------------------- - - -subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) - use dim, only:maxptmass - use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink,use_regnbody - use mpiutils, only:reduce_in_place_mpi - use io, only:id,master - integer, intent(in) :: nptmass,npart - integer, intent(inout) :: force_count - real, intent(inout) :: xyzh(:,:),fext(3,npart) - real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) - real, intent(in) :: fsink_old(4,nptmass) - real, intent(inout) :: dt - real, intent(in) :: pmassi - integer, optional, intent(in) :: group_info(:,:) - real :: fextx,fexty,fextz - integer :: i - - force_count = force_count + 1 - - if (nptmass>0) then - if(id==master) then - if(use_regnbody) then - call get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) - else - call get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old) - endif - else - fxyz_ptmass(:,:) = 0. - endif - endif - - !$omp parallel default(none) & - !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,dt,pmassi,fsink_old) & - !$omp private(fextx,fexty,fextz) & - !$omp reduction(+:fxyz_ptmass) - !$omp do - do i=1,npart - fextx = fext(1,i) - fexty = fext(2,i) - fextz = fext(3,i) - call get_gradf_sink_gas(nptmass,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - xyzmh_ptmass,fextx,fexty,fextz,pmassi,fxyz_ptmass,fsink_old) - fext(1,i) = fext(1,i)+ fextx - fext(2,i) = fext(2,i)+ fexty - fext(3,i) = fext(3,i)+ fextz - enddo - !$omp enddo - !$omp end parallel - - if (nptmass > 0) then - call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - !call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) - endif - -end subroutine get_gradf_4th - !---------------------------------------------------------------- !+ ! force routine for the whole system. First is computed the @@ -1012,7 +865,6 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if(present(group_info)) then wsub = .true. - extrap = .false. endif @@ -1040,35 +892,50 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (nptmass>0) then if (id==master) then if (extrap) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + if(wsub) then + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & + extrapfac,fsink_old,group_info) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & + extrapfac,fsink_old,group_info) + endif + else + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n, & dsdt_ptmass,extrapfac,fsink_old) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n, & dsdt_ptmass,extrapfac,fsink_old) + endif endif - elseif (wsub) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + else + if(wsub) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - endif - else - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + endif + else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + endif endif endif else From 2b0a377bcf9197d68f7be2f5736d9ca21f6bef35 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 12:35:35 +1000 Subject: [PATCH 480/814] add a check in checksetup for regularization --- src/main/checksetup.f90 | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index eec4f19f0..3999a05dc 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -433,6 +433,10 @@ subroutine check_setup(nerror,nwarn,restart) !--check Forward symplectic integration method imcompatiblity ! call check_vdep_extf (nwarn,iexternalforce) +! +!--check Regularization imcompatibility +! + call check_regnbody (nerror) if (.not.h2chemistry .and. maxvxyzu >= 4 .and. icooling == 3 .and. iexternalforce/=iext_corotate .and. nptmass==0) then if (dot_product(xcom,xcom) > 1.e-2) then @@ -1028,4 +1032,14 @@ subroutine check_vdep_extf(nwarn,iexternalforce) end subroutine check_vdep_extf +subroutine check_regnbody (nerror) + use ptmass, only:use_regnbody,use_fourthorder + integer, intent(inout) :: nerror + if (.not.(use_fourthorder .and. use_regnbody)) then + print "(/,a,/)","Error: TTL integration and regularization tools are not available without FSI. Turn off TTL..." + nerror = nerror + 1 + endif +end subroutine check_regnbody + + end module checksetup From f5b5b97de66dfcf5af6d95b0cadb21fce3205d01 Mon Sep 17 00:00:00 2001 From: Hugh Griffiths Date: Wed, 24 Apr 2024 13:23:49 +1000 Subject: [PATCH 481/814] removing hdivB timestep constraint as did not work --- src/main/checkconserved.f90 | 41 +++++++++++----------- src/main/energies.F90 | 7 ++-- src/main/evolve.F90 | 4 +-- src/main/force.F90 | 60 ++++++++++++--------------------- src/main/options.f90 | 4 +-- src/main/readwrite_infile.F90 | 10 +----- src/setup/setup_sphereinbox.f90 | 3 +- 7 files changed, 52 insertions(+), 77 deletions(-) diff --git a/src/main/checkconserved.f90 b/src/main/checkconserved.f90 index e47e96955..a5538d537 100644 --- a/src/main/checkconserved.f90 +++ b/src/main/checkconserved.f90 @@ -95,7 +95,6 @@ subroutine check_conservation_error(val,ref,tol,label,decrease) character(len=*), intent(in) :: label logical, intent(in), optional :: decrease real :: err - character(len=20) :: string if (abs(ref) > 1.e-3) then err = (val - ref)/abs(ref) @@ -113,12 +112,7 @@ subroutine check_conservation_error(val,ref,tol,label,decrease) call error('evolve',trim(label)//' is not being conserved due to corotating frame',var='err',val=err) else call error('evolve','Large error in '//trim(label)//' conservation ',var='err',val=err) - call get_environment_variable('I_WILL_NOT_PUBLISH_CRAP',string) - if (.not. (trim(string)=='yes')) then - print "(2(/,a))",' You can ignore this error and continue by setting the ',& - ' environment variable I_WILL_NOT_PUBLISH_CRAP=yes to continue' - call fatal('evolve',' Conservation errors too large to continue simulation') - endif + call do_not_publish_crap('evolve','Conservation errors too large to continue simulation') endif else if (iverbose >= 2) print "(a,es10.3)",trim(label)//' error is ',err @@ -133,24 +127,31 @@ end subroutine check_conservation_error ! so is related to the checks performed here !+ !---------------------------------------------------------------- -subroutine check_magnetic_stability(hdivBB_xa) - use options, only:hdivbbmax_max +subroutine check_magnetic_stability(hdivBonB_ave,hdivBonB_max) use io, only:fatal - real, intent(in) :: hdivBB_xa(:) + real, intent(in) :: hdivBonB_ave,hdivBonB_max - if (hdivbbmax_max < 1.1) then - ! In this regime, we assume the user has not modified this value, - ! either by choice or by being unaware of this. This warning will - ! appear in this case. - if (hdivBB_xa(1) > 100 .or. hdivBB_xa(2) > 0.1) then - ! Tricco, Price & Bate (2016) suggest the average should remain lower than 0.01, - ! but we will increase it here due to the nature of the exiting the code - ! The suggestion of 512 was empirically determined in Dobbs & Wurster (2021) - call fatal('evolve','h|divb|/b is too large; recommend hdivbbmax_max = 512; set >1.2 to suppress this message.') - endif + if (hdivBonB_max > 100 .or. hdivBonB_ave > 0.1) then + ! Tricco, Price & Bate (2016) suggest the average should remain lower than 0.01, + ! but we will increase it here due to the nature of the exiting the code + ! The suggestion of 512 was empirically determined in Dobbs & Wurster (2021) + call do_not_publish_crap('evolve','h|divb|/b is too large; recommend to increase the overcleanfac') endif end subroutine check_magnetic_stability +subroutine do_not_publish_crap(subr,msg) + use io, only:fatal + character(len=*), intent(in) :: subr,msg + character(len=20) :: string + + call get_environment_variable('I_WILL_NOT_PUBLISH_CRAP',string) + if (.not. (trim(string)=='yes')) then + print "(2(/,a))",' You can ignore this error and continue by setting the ',& + ' environment variable I_WILL_NOT_PUBLISH_CRAP=yes to continue' + call fatal(subr,msg) + endif + +end subroutine do_not_publish_crap !---------------------------------------------------------------- end module checkconserved diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 0fc102122..d71e70db1 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -26,7 +26,8 @@ module energies implicit none logical, public :: gas_only,track_mass,track_lum - real, public :: ekin,etherm,emag,epot,etot,totmom,angtot,mtot,xyzcom(3),hdivBB_xa(2) + real, public :: ekin,etherm,emag,epot,etot,totmom,angtot,mtot,xyzcom(3) + real, public :: hdivBonB_ave,hdivBonB_max real, public :: vrms,rmsmach,accretedmass,mdust(maxdusttypes),mgas real, public :: xmom,ymom,zmom real, public :: totlum @@ -730,8 +731,8 @@ subroutine compute_energies(t) endif if (mhd) then - hdivBB_xa(1) = ev_data(iev_max,iev_hdivB) - hdivBB_xa(2) = ev_data(iev_ave,iev_hdivB) + hdivBonB_max = ev_data(iev_max,iev_hdivB) + hdivBonB_ave = ev_data(iev_ave,iev_hdivB) endif if (maxp==maxp_hard) then diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 53b9d7928..c96f339c1 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -37,7 +37,7 @@ 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,hdivBB_xa + use energies, only:etot,totmom,angtot,mdust,np_cs_eq_0,np_e_eq_0,hdivBonB_ave,hdivBonB_max use checkconserved, only:etot_in,angtot_in,totmom_in,mdust_in,& init_conservation_checks,check_conservation_error,& check_magnetic_stability @@ -396,7 +396,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) call check_conservation_error(mdust(j),mdust_in(j),1.e-1,'dust mass',decrease=.true.) enddo endif - if (mhd) call check_magnetic_stability(hdivBB_xa) + if (mhd) call check_magnetic_stability(hdivBonB_ave,hdivBonB_max) 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 7586fc82a..00e00fbff 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -150,27 +150,26 @@ module forces idBevolyi = 10, & idBevolzi = 11, & idivBdiffi = 12, & - ihdivBBmax = 13, & !--dust array indexing - ifdragxi = 14, & - ifdragyi = 15, & - ifdragzi = 16, & - iddustevoli = 17, & - iddustevoliend = 17 + (maxdustsmall-1), & - idudtdusti = 18 + (maxdustsmall-1), & - idudtdustiend = 18 + 2*(maxdustsmall-1), & - ideltavxi = 19 + 2*(maxdustsmall-1), & - ideltavxiend = 19 + 3*(maxdustsmall-1), & - ideltavyi = 20 + 3*(maxdustsmall-1), & - ideltavyiend = 20 + 4*(maxdustsmall-1), & - ideltavzi = 21 + 4*(maxdustsmall-1), & - ideltavziend = 21 + 5*(maxdustsmall-1), & - idvix = 22 + 5*(maxdustsmall-1), & - idviy = 23 + 5*(maxdustsmall-1), & - idviz = 24 + 5*(maxdustsmall-1), & - idensgasi = 25 + 5*(maxdustsmall-1), & - icsi = 26 + 5*(maxdustsmall-1), & - idradi = 26 + 5*(maxdustsmall-1) + 1 + ifdragxi = 13, & + ifdragyi = 14, & + ifdragzi = 15, & + iddustevoli = 16, & + iddustevoliend = 16 + (maxdustsmall-1), & + idudtdusti = 17 + (maxdustsmall-1), & + idudtdustiend = 17 + 2*(maxdustsmall-1), & + ideltavxi = 18 + 2*(maxdustsmall-1), & + ideltavxiend = 18 + 3*(maxdustsmall-1), & + ideltavyi = 19 + 3*(maxdustsmall-1), & + ideltavyiend = 19 + 4*(maxdustsmall-1), & + ideltavzi = 20 + 4*(maxdustsmall-1), & + ideltavziend = 20 + 5*(maxdustsmall-1), & + idvix = 21 + 5*(maxdustsmall-1), & + idviy = 22 + 5*(maxdustsmall-1), & + idviz = 23 + 5*(maxdustsmall-1), & + idensgasi = 24 + 5*(maxdustsmall-1), & + icsi = 25 + 5*(maxdustsmall-1), & + idradi = 25 + 5*(maxdustsmall-1) + 1 private @@ -1621,7 +1620,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g else Bj1 = 0.0 endif - fsum(ihdivBBmax) = max( hj*abs(divcurlB(1,j))*Bj1, fsum(ihdivBBmax)) ! ! non-ideal MHD terms ! @@ -2522,7 +2520,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv use dim, only:mhd,mhd_nonideal,lightcurve,use_dust,maxdvdx,use_dustgrowth,gr,use_krome,& store_dust_temperature,do_nucleation,update_muGamma,h2chemistry use eos, only:ieos,iopacity_type - use options, only:alpha,ipdv_heating,ishock_heating,psidecayfac,overcleanfac,hdivbbmax_max, & + 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,& @@ -2598,7 +2596,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv real :: Bxyzi(3),curlBi(3),dvdxi(9),straini(6) real :: xi,yi,zi,B2i,f2i,divBsymmi,betai,frac_divB,divBi,vcleani real :: pri,spsoundi,drhodti,divvi,shearvisc,fac,pdv_work - real :: psii,dtau,hdivbbmax + real :: psii,dtau real :: eni,dudtnonideal real :: dustfraci(maxdusttypes),dustfracisum real :: tstopi(maxdusttypes),tseff,dtdustdenom @@ -2965,21 +2963,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv ! new cleaning evolving d/dt (psi/c_h) dBevol(4,i) = -vcleani*fsum(idivBdiffi)*rho1i - psii*dtau - 0.5*psii*divvi - ! timestep from cleaning - ! 1. the factor of 10 in hdivbbmax is empirical from checking how much - ! spurious B-fields are decreased in colliding flows - ! 2. if overcleaning is on (i.e. hdivbbmax > 1.0), then factor of 2 is - ! from empirical tests to ensure that overcleaning with individual - ! timesteps is stable - if (B2i > 0.) then - hdivbbmax = hi*abs(divBi)/sqrt(B2i) - else - hdivbbmax = 0.0 - endif - hdivbbmax = max( overcleanfac, 10.*hdivbbmax, 10.*fsum(ihdivBBmax) ) - hdivbbmax = min( hdivbbmax, hdivbbmax_max ) - if (hdivbbmax > 1.0) hdivbbmax = 2.0*hdivbbmax - dtclean = C_cour*hi/(hdivbbmax * vwavei + tiny(0.)) + dtclean = C_cour*hi/(vcleani + tiny(0.)) endif endif diff --git a/src/main/options.f90 b/src/main/options.f90 index 115e1e91e..f49271fca 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -36,7 +36,7 @@ module options real, public :: alpha,alphau,beta real, public :: alphamax - real, public :: alphaB, psidecayfac, overcleanfac, hdivbbmax_max + real, public :: alphaB, psidecayfac, overcleanfac integer, public :: ishock_heating,ipdv_heating,icooling,iresistive_heating integer, public :: ireconav @@ -134,8 +134,6 @@ subroutine set_default_options alphaB = 1.0 psidecayfac = 1.0 ! psi decay factor (MHD only) overcleanfac = 1.0 ! factor to increase signal velocity for (only) time steps and psi cleaning - hdivbbmax_max = 1.0 ! if > overcleanfac, then use B/(h*|div B|) as a coefficient for dtclean; - ! ! this is the max value allowed; test suggest =512 for magnetised colliding flows beta = 2.0 ! beta viscosity term avdecayconst = 0.1 ! decay time constant for viscosity switches diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index c7aec5707..122b7a0a0 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -34,7 +34,6 @@ module readwrite_infile ! - dtwallmax : *maximum wall time between dumps (hhh:mm, 000:00=ignore)* ! - dumpfile : *dump file to start from* ! - flux_limiter : *limit radiation flux* -! - hdivbbmax_max : *max factor to decrease cleaning timestep propto B/(h|divB|)* ! - hfact : *h in units of particle spacing [h = hfact(m/rho)^(1/3)]* ! - ien_type : *energy variable (0=auto, 1=entropy, 2=energy, 3=entropy_s)* ! - implicit_radiation : *use implicit integration (Whitehouse, Bate & Monaghan 2005)* @@ -76,7 +75,7 @@ module readwrite_infile use options, only:nfulldump,nmaxdumps,twallmax,iexternalforce,tolh, & alpha,alphau,alphaB,beta,avdecayconst,damp,rkill, & ipdv_heating,ishock_heating,iresistive_heating,ireconav, & - icooling,psidecayfac,overcleanfac,hdivbbmax_max,alphamax,calc_erot,rhofinal_cgs, & + icooling,psidecayfac,overcleanfac,alphamax,calc_erot,rhofinal_cgs, & use_mcfost,use_Voronoi_limits_file,Voronoi_limits_file,use_mcfost_stellar_parameters,& exchange_radiation_energy,limit_radiation_flux,iopacity_type,mcfost_computes_Lacc,& mcfost_uses_PdV,implicit_radiation,mcfost_keep_part,ISM, mcfost_dust_subl @@ -202,7 +201,6 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) call write_inopt(alphaB,'alphaB','shock resistivity parameter',iwritein) call write_inopt(psidecayfac,'psidecayfac','div B diffusion parameter',iwritein) call write_inopt(overcleanfac,'overcleanfac','factor to increase cleaning speed (decreases time step)',iwritein) - call write_inopt(hdivbbmax_max,'hdivbbmax_max','max factor to decrease cleaning timestep propto B/(h|divB|)',iwritein) endif call write_inopt(beta,'beta','beta viscosity',iwritein) if (maxalpha==maxp .and. maxp > 0) then @@ -481,8 +479,6 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) read(valstring,*,iostat=ierr) psidecayfac case('overcleanfac') read(valstring,*,iostat=ierr) overcleanfac - case('hdivbbmax_max') - read(valstring,*,iostat=ierr) hdivbbmax_max case('beta') read(valstring,*,iostat=ierr) beta case('ireconav') @@ -684,10 +680,6 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (psidecayfac < 0.) call fatal(label,'stupid value for psidecayfac') if (psidecayfac > 2.) call warn(label,'psidecayfac set outside recommended range (0.1-2.0)') if (overcleanfac < 1.0) call warn(label,'overcleanfac less than 1') - if (hdivbbmax_max < overcleanfac) then - call warn(label,'Resetting hdivbbmax_max = overcleanfac') - hdivbbmax_max = overcleanfac - endif endif if (beta < 0.) call fatal(label,'beta < 0') if (beta > 4.) call warn(label,'very high beta viscosity set') diff --git a/src/setup/setup_sphereinbox.f90 b/src/setup/setup_sphereinbox.f90 index 98a4a9156..f75b6e85f 100644 --- a/src/setup/setup_sphereinbox.f90 +++ b/src/setup/setup_sphereinbox.f90 @@ -110,7 +110,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact_ 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,icooling + use options, only:nfulldump,rhofinal_cgs,use_dustfrac,icooling use kernel, only:hfact_default use mpidomain, only:i_belong use ptmass, only:icreate_sinks,r_crit,h_acc,h_soft_sinksink @@ -664,7 +664,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact_ icreate_sinks = icreate_sinks_setup r_crit = r_crit_setup h_acc = h_acc_setup - hdivbbmax_max = 1. !512. ! reset defaults based upon options if (density_contrast > 1.) dtmax_dratio = 1.258 if (density_contrast < 1.+epsilon(density_contrast) .and. maxvxyzu>=4) then From d94c77128f9ed2494310a847c4c3ddb15b8e3fd1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 14:28:55 +1000 Subject: [PATCH 482/814] fix unused var and gtgrad deallocation --- src/main/energies.F90 | 2 +- src/main/part.F90 | 1 + src/main/sdar_group.f90 | 36 +++++++++++++++++++++++------------- 3 files changed, 25 insertions(+), 14 deletions(-) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 3cf29993d..b1907c602 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -603,7 +603,7 @@ subroutine compute_energies(t) erad = reduceall_mpi('+',erad) if (nptmass > 1) then if (use_regnbody) then - call get_pot_subsys(n_group,nptmass,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + call get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) endif epot = epot + epot_sinksink endif diff --git a/src/main/part.F90 b/src/main/part.F90 index f9c026ddd..5b5ae5f18 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -579,6 +579,7 @@ subroutine deallocate_part if (allocated(ibin_sts)) deallocate(ibin_sts) if (allocated(group_info)) deallocate(group_info) if (allocated(nmatrix)) deallocate(nmatrix) + if (allocated(gtgrad)) deallocate(gtgrad) end subroutine deallocate_part diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 9f04da39a..59b0cc04c 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -199,7 +199,7 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz if(id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& - !$omp shared(tnext,time,group_info,gtgrad)& + !$omp shared(tnext,time,group_info,gtgrad,n_group)& !$omp private(i,start_id,end_id,gsize) do i=1,n_group start_id = group_info(igcum,i) + 1 @@ -263,9 +263,9 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ do while (.true.) if (backup_flag) then - call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,bdata) + call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bdata) else - call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) + call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) endif t_old = tcoord W_old = W @@ -386,9 +386,9 @@ end subroutine new_ds_sync_sup -subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,bdata) +subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bdata) use part, only: igarg - real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer,intent(in) :: group_info(:,:) real, intent(out) ::bdata(:) integer,intent(in) :: start_id,end_id @@ -408,9 +408,9 @@ subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ end subroutine backup_data -subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) +subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) use part, only: igarg - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer,intent(in) :: group_info(:,:) real, intent(out) :: tcoord,W real, intent(in) :: t_old,W_old @@ -567,10 +567,20 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id integer, intent(in) :: s_id,e_id logical, optional, intent(in) :: potonly real, optional, intent(out) :: ds_init - real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3 + real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3,dt_init real :: gravf,gtki,gravfi(3),gtgradi(3),f2 integer :: i,j,k,l + logical :: init om = 0. + dt_init = 0. + + + if(present(ds_init)) then + init = .true. + ds_init = 0. + else + init = .false. + endif do k=s_id,e_id @@ -617,17 +627,17 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id gtgrad(3,i) = gtgradi(3) endif - if (present(ds_init)) then + if (init) then f2 = gravfi(1)**2+gravfi(2)**2+gravfi(3)**2 if (f2 > 0.) then - ds_init = min(ds_init,0.00002*sqrt(abs(gtki)/f2)) + dt_init = min(dt_init,0.00002*sqrt(abs(gtki)/f2)) endif endif om = om + gtki*mi enddo om = om*0.5 - if(present(ds_init)) ds_init = ds_init/om + if(init) ds_init = dt_init/om end subroutine get_force_TTL @@ -692,10 +702,10 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j,potonly,ds_i end subroutine get_force_TTL_bin -subroutine get_pot_subsys(n_group,nptmass,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) +subroutine get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) use part, only: igarg,igcum use io, only: id,master - integer, intent(in) :: n_group,nptmass + integer, intent(in) :: n_group real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) real, intent(inout) :: epot_sinksink From e9e8481b522b856d77e9587540e46b8155b0c106 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 14:32:52 +1000 Subject: [PATCH 483/814] wrong size of gas sphere in starcluster setup --- src/setup/setup_starcluster.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index 35c099017..0c5d3c385 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -132,7 +132,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! setup initial sphere of particles to prevent initialisation problems ! psep = 1.0 - call set_sphere('cubic',id,master,0.,0.01,psep,hfact,npart,xyzh) + call set_sphere('cubic',id,master,0.,10.,psep,hfact,npart,xyzh) vxyzu(4,:) = 5.317e-4 npartoftype(igas) = npart From 136e2a348a9e4d2c46f4fe8848b549d20a482019 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 14:38:56 +1000 Subject: [PATCH 484/814] fix checksetup regularization --- src/main/checksetup.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 3999a05dc..cf6d00364 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -1035,7 +1035,7 @@ end subroutine check_vdep_extf subroutine check_regnbody (nerror) use ptmass, only:use_regnbody,use_fourthorder integer, intent(inout) :: nerror - if (.not.(use_fourthorder .and. use_regnbody)) then + if (use_regnbody .and. .not.(use_fourthorder)) then print "(/,a,/)","Error: TTL integration and regularization tools are not available without FSI. Turn off TTL..." nerror = nerror + 1 endif From 721402c60ca30e6fe0fac22fb0e734fd158e0178 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 16:11:25 +1000 Subject: [PATCH 485/814] fix ifort comp error --- src/main/sdar_group.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 59b0cc04c..7132ffd32 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -716,7 +716,7 @@ subroutine get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epo if(id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,fxyz_ptmass)& - !$omp shared(group_info,gtgrad)& + !$omp shared(group_info,gtgrad,n_group)& !$omp private(i,start_id,end_id,gsize,prim,sec,phigroup)& !$omp reduction(+:phitot) do i=1,n_group From ea0452261c0a2631442d6e7e6d772977719d8167 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 17:09:22 +1000 Subject: [PATCH 486/814] Change name sdar_group to subgroup for clarity --- build/Makefile | 2 +- src/main/energies.F90 | 2 +- src/main/initial.F90 | 2 +- src/main/{sdar_group.f90 => subgroup.f90} | 6 +++--- src/main/substepping.F90 | 5 +---- src/main/{utils_sdar.f90 => utils_subgroup.f90} | 4 ++-- 6 files changed, 9 insertions(+), 12 deletions(-) rename src/main/{sdar_group.f90 => subgroup.f90} (99%) rename src/main/{utils_sdar.f90 => utils_subgroup.f90} (95%) diff --git a/build/Makefile b/build/Makefile index 39dc74d0b..400e5c684 100644 --- a/build/Makefile +++ b/build/Makefile @@ -535,7 +535,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} \ - utils_sdar.f90 utils_kepler.f90 sdar_group.f90\ + utils_subgroup.f90 utils_kepler.f90 subgroup.f90\ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ diff --git a/src/main/energies.F90 b/src/main/energies.F90 index b1907c602..80d0480b6 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -81,7 +81,7 @@ subroutine compute_energies(t) use options, only:iexternalforce,calc_erot,alpha,ieos,use_dustfrac use mpiutils, only:reduceall_mpi use ptmass, only:get_accel_sink_gas,use_regnbody - use sdar_group, only:get_pot_subsys + use subgroup, only:get_pot_subsys use viscosity, only:irealvisc,shearfunc use nicil, only:nicil_update_nimhd,nicil_get_halldrift,nicil_get_ambidrift, & use_ohm,use_hall,use_ambi,n_data_out,n_warn,eta_constant diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 126010b75..f009025d2 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -212,7 +212,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use fileutils, only:make_tags_unique use damping, only:idamp - use sdar_group, only:group_identify + use subgroup, only:group_identify character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile logical, intent(in), optional :: noread diff --git a/src/main/sdar_group.f90 b/src/main/subgroup.f90 similarity index 99% rename from src/main/sdar_group.f90 rename to src/main/subgroup.f90 index 7132ffd32..c2c0ed649 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/subgroup.f90 @@ -1,4 +1,4 @@ -module sdar_group +module subgroup ! ! this module contains everything to identify ! and integrate regularized groups... @@ -7,7 +7,7 @@ module sdar_group ! ! :Owner: Yann BERNARD ! - use utils_sdar + use utils_subgroup implicit none public :: group_identify public :: evolve_groups @@ -743,4 +743,4 @@ subroutine get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epo end subroutine get_pot_subsys -end module sdar_group +end module subgroup diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 26e66f970..5f8368823 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -434,7 +434,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent use ptmass, only:use_fourthorder,use_regnbody,ck,dk - use sdar_group, only:group_identify,evolve_groups + use subgroup, only:group_identify,evolve_groups integer, intent(in) :: npart,ntypes,nptmass integer, intent(inout) :: n_group,n_ingroup,n_sing integer, intent(inout) :: group_info(:,:) @@ -534,9 +534,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) endif - else !! standard leapfrog scheme - ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) @@ -544,7 +542,6 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag) endif - endif dtextforce_min = min(dtextforce_min,dtextforce) diff --git a/src/main/utils_sdar.f90 b/src/main/utils_subgroup.f90 similarity index 95% rename from src/main/utils_sdar.f90 rename to src/main/utils_subgroup.f90 index 7b0ce4401..ffbecf1a1 100644 --- a/src/main/utils_sdar.f90 +++ b/src/main/utils_subgroup.f90 @@ -1,4 +1,4 @@ -module utils_sdar +module utils_subgroup implicit none integer, parameter :: ck_size = 8 real,dimension(8),parameter :: cks=(/0.3922568052387800,0.5100434119184585,-0.4710533854097566,& @@ -15,4 +15,4 @@ module utils_sdar contains -end module utils_sdar +end module utils_subgroup From 270c1703ed31e90c84b2306e45967f4ea4f408d8 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 18:05:02 +1000 Subject: [PATCH 487/814] fix wrong value in if statement (forgotten merge conflict) --- src/main/substepping.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 5f8368823..c99964510 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -795,7 +795,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, call summary_accrete_fail(nfail) call summary_accrete(nptmass) ! only write to .ev during substeps if no gas particles present - if (npart==-1) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & + if (npart==0) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & fxyz_ptmass,fxyz_ptmass_sinksink) endif endif From 5a8505bb305288ca01285326751156f5ac2d130b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 25 Apr 2024 13:53:09 +1000 Subject: [PATCH 488/814] first subs for star formation prescription --- src/main/config.F90 | 2 +- src/main/part.F90 | 16 ++++--- src/main/ptmass.F90 | 103 ++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 110 insertions(+), 11 deletions(-) diff --git a/src/main/config.F90 b/src/main/config.F90 index 5acb64234..b91496625 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -42,7 +42,7 @@ module dim #else integer, parameter :: maxptmass = 1000 #endif - integer, parameter :: nsinkproperties = 19 + integer, parameter :: nsinkproperties = 20 ! storage of thermal energy or not #ifdef ISOTHERMAL diff --git a/src/main/part.F90 b/src/main/part.F90 index 362587bc2..8a3ee0f8a 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -204,19 +204,21 @@ module part integer, parameter :: i_mlast = 17 ! accreted mass of last time integer, parameter :: imassenc = 18 ! mass enclosed in sink softening radius integer, parameter :: iJ2 = 19 ! 2nd gravity moment due to oblateness + integer, parameter :: itbirth = 20 integer, parameter :: ndptmass = 13 ! number of properties to conserve after a accretion phase or merge - real, allocatable :: xyzmh_ptmass(:,:) - real, allocatable :: vxyz_ptmass(:,:) - real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:),fsink_old(:,:) - real, allocatable :: dsdt_ptmass(:,:),dsdt_ptmass_sinksink(:,:) - real, allocatable :: dptmass(:,:) + integer, allocatable :: linklist_ptmass(:) + real, allocatable :: xyzmh_ptmass(:,:) + real, allocatable :: vxyz_ptmass(:,:) + real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:),fsink_old(:,:) + real, allocatable :: dsdt_ptmass(:,:),dsdt_ptmass_sinksink(:,:) + real, allocatable :: dptmass(:,:) integer :: nptmass = 0 ! zero by default real :: epot_sinksink character(len=*), parameter :: xyzmh_ptmass_label(nsinkproperties) = & (/'x ','y ','z ','m ','h ',& 'hsoft ','maccreted','spinx ','spiny ','spinz ',& 'tlast ','lum ','Teff ','Reff ','mdotloss ',& - 'mdotav ','mprev ','massenc ','J2 '/) + 'mdotav ','mprev ','massenc ','J2 ','tbirth '/) character(len=*), parameter :: vxyz_ptmass_label(3) = (/'vx','vy','vz'/) ! !--self-gravity @@ -435,6 +437,7 @@ subroutine allocate_part call allocate_array('fxyz_ptmass_sinksink', fxyz_ptmass_sinksink, 4, maxptmass) call allocate_array('fsink_old', fsink_old, 4, maxptmass) call allocate_array('dptmass', dptmass, ndptmass,maxptmass) + call allocate_array('linklist_ptmass', linklist_ptmass, maxptmass) call allocate_array('dsdt_ptmass', dsdt_ptmass, 3, maxptmass) call allocate_array('dsdt_ptmass_sinksink', dsdt_ptmass_sinksink, 3, maxptmass) call allocate_array('poten', poten, maxgrav) @@ -523,6 +526,7 @@ subroutine deallocate_part if (allocated(fxyz_ptmass_sinksink)) deallocate(fxyz_ptmass_sinksink) if (allocated(fsink_old)) deallocate(fsink_old) if (allocated(dptmass)) deallocate(dptmass) + if (allocated(linklist_ptmass)) deallocate(linklist_ptmass) if (allocated(dsdt_ptmass)) deallocate(dsdt_ptmass) if (allocated(dsdt_ptmass_sinksink)) deallocate(dsdt_ptmass_sinksink) if (allocated(poten)) deallocate(poten) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 9d536862e..6ca4b2138 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -59,10 +59,12 @@ module ptmass ! settings affecting routines in module (read from/written to input file) integer, public :: icreate_sinks = 0 + integer, public :: icreate_stars = 0 real, public :: rho_crit_cgs = 1.e-10 real, public :: r_crit = 5.e-3 real, public :: h_acc = 1.e-3 real, public :: f_acc = 0.8 + real, public :: tmax_acc = 0.0 real, public :: h_soft_sinkgas = 0.0 real, public :: h_soft_sinksink = 0.0 real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch @@ -711,7 +713,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & dptmass,time,facc,nbinmax,ibin_wakei,nfaili) !$ use omputils, only:ipart_omp_lock - use part, only: ihacc + use part, only: ihacc,itbirth use kernel, only: radkern2 use io, only: iprint,iverbose,fatal use io_summary, only: iosum_ptmass,maxisink,print_acc @@ -729,7 +731,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & real :: dx,dy,dz,r2,dvx,dvy,dvz,v2,hacc logical, parameter :: iofailreason=.false. integer :: j - real :: mpt,drdv,angmom2,angmomh2,epart,dxj,dyj,dzj,dvxj,dvyj,dvzj,rj2,vj2,epartj + real :: mpt,age,drdv,angmom2,angmomh2,epart,dxj,dyj,dzj,dvxj,dvyj,dvzj,rj2,vj2,epartj logical :: mostbound !$ external :: omp_set_lock,omp_unset_lock @@ -747,7 +749,9 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & sinkloop : do i=is,nptmass hacc = xyzmh_ptmass(ihacc,i) mpt = xyzmh_ptmass(4,i) + age = xyzmh_ptmass(itbirth,i) if (mpt < 0.) cycle + if (age > tmax_acc) cycle dx = xi - xyzmh_ptmass(1,i) dy = yi - xyzmh_ptmass(2,i) dz = zi - xyzmh_ptmass(3,i) @@ -956,7 +960,7 @@ end subroutine update_ptmass !------------------------------------------------------------------------- subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) - use part, only:ihacc,ihsoft,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & + use part, only:ihacc,ihsoft,itbirth,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP,igamma,ndptmass use dim, only:maxp,maxneigh,maxvxyzu,maxptmass,ind_timesteps use kdtree, only:getneigh @@ -1461,6 +1465,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote xyzmh_ptmass(4,n) = 0. ! zero mass xyzmh_ptmass(ihacc,n) = h_acc xyzmh_ptmass(ihsoft,n) = h_soft_sinkgas + xyzmh_ptmass(itbirth,n) = time vxyz_ptmass(:,n) = 0. ! zero velocity, get this by accreting itypej = igas ! default particle type to be accreted pmassj = massoftype(igas) ! default particle mass to be accreted @@ -1496,6 +1501,8 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote fxyz_ptmass_sinksink(:,nptmass) = 0.0 call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) + if (icreate_stars > 0) call ptmass_create_stars(nptmass,xyzmh_ptmass,time) + if (id==id_rhomax) then write(iprint,"(a,i3,a,4(es10.3,1x),a,i6,a,es10.3)") ' created ptmass #',nptmass,& ' at (x,y,z,t)=(',xyzmh_ptmass(1:3,nptmass),time,') by accreting ',nacc,' particles: M=',xyzmh_ptmass(4,nptmass) @@ -1526,6 +1533,57 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote end subroutine ptmass_create +subroutine ptmass_create_seed(nptmass,xyzmh_ptmass,linklist_ptmass,time) + use part, only:itbirth + integer, intent(inout) :: nptmass + integer, intent(in) :: linklist_ptmass(:) + real, intent(inout) :: xyzmh_ptmass(:,:) + real, intent(in) :: time + integer :: i, nseed +! +!-- Draw the number of star seeds in the core +! + nseed = floor(5*rand()) + do i=1,nseed + nptmass = nptmass + 1 + xyzmh_ptmass(itbirth,nptmass) = time + xyzmh_ptmass(4,nptmass) = -1. + if (i==nseed)then + linklist_ptmass(nptmass) = -1 !! null pointer + else + linklist_ptmass(nptmass) = nptmass + 1 !! link this new seed to the next one + endif + enddo +end subroutine ptmass_create_seed + +subroutine ptmass_create_star(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) + use part, only:itbirth + integer, intent(in) :: nptmass + integer, intent(in) :: linklist_ptmass(:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(in) :: time + integer :: i,k,nseed + real :: tbirthi,mi + + do i=1,nptmass + mi = xyzmh_ptmass(4,i) + tbirthi = xyzmh_ptmass(itbirth,i) + if (mi<0.) cycle + if (time>tbirthi+tmax_acc) then + call ptmass_size_lklist(i,n,linklist_ptmass) + + !! do some clever stuff to divide the mass + k=i + do while(k>0) + !! do some clever stuff + k = linklist_ptmass(k) + enddo + endif + enddo + + +end subroutine ptmass_create_star + !----------------------------------------------------------------------- !+ ! Merge sinks @@ -1555,7 +1613,7 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_i integer, intent(in) :: nptmass,merge_ij(nptmass) real, intent(inout) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: vxyz_ptmass(3,nptmass),fxyz_ptmass(4,nptmass) - integer :: i,j + integer :: i,j,k real :: rr2,xi,yi,zi,mi,vxi,vyi,vzi,xj,yj,zj,mj,vxj,vyj,vzj,Epot,Ekin real :: mij,mij1 logical :: lmerge @@ -1566,6 +1624,13 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_i j = merge_ij(i) if (merge_ij(j) == i .and. xyzmh_ptmass(4,j) > 0.) then lmerge = .false. + agei = xyzmh_ptmass(itbirth,i) + agej = xyzmh_ptmass(itbirth,j) + if (agej maxeos) call fatal(label,'equation of state choice out of range') - if (ieos == 5) then + if (ieos == 5 .or. ieos == 17) then store_dust_temperature = .true. update_muGamma = .true. endif diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index c7aec5707..741212439 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -217,7 +217,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) ! thermodynamics ! call write_options_eos(iwritein) - if (maxvxyzu >= 4 .and. (ieos==2 .or. ieos==5 .or. ieos==10 .or. ieos==15 .or. ieos==12 .or. ieos==16) ) then + if (maxvxyzu >= 4 .and. (ieos==2 .or. ieos==5 .or. ieos==10 .or. ieos==15 .or. ieos==12 .or. ieos==16 .or. ieos==17) ) then call write_inopt(ipdv_heating,'ipdv_heating','heating from PdV work (0=off, 1=on)',iwritein) call write_inopt(ishock_heating,'ishock_heating','shock heating (0=off, 1=on)',iwritein) if (mhd) then @@ -693,14 +693,14 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (beta > 4.) call warn(label,'very high beta viscosity set') #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 /= 20)) & + ieos /=11 .and. ieos /=12 .and. ieos /= 15 .and. ieos /= 16 .and. ieos /= 17 .and. ieos /= 20)) & 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') if (shearparam < 0.) call fatal(label,'stupid value for shear parameter (< 0)') if (irealvisc==2 .and. shearparam > 1) call error(label,'alpha > 1 for shakura-sunyaev viscosity') if (iverbose > 99 .or. iverbose < -9) call fatal(label,'invalid verboseness setting (two digits only)') - if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5)) call fatal(label,'cooling requires adiabatic eos (ieos=2)') + if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos == 17)) call fatal(label,'cooling requires adiabatic eos (ieos=2)') if (icooling > 0 .and. (ipdv_heating <= 0 .or. ishock_heating <= 0)) & call fatal(label,'cooling requires shock and work contributions') if (((isink_radiation == 1 .or. isink_radiation == 3 ) .and. idust_opacity == 0 ) & diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index a211f5dd9..12a99ed21 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -1087,7 +1087,7 @@ end subroutine step_extern_sph subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time,nptmass, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome,itau_alloc,& - do_nucleation,update_muGamma,h2chemistry + do_nucleation,update_muGamma,h2chemistry,update_muGamma use io, only:iverbose,id,master,iprint,warning,fatal use externalforces, only:externalforce,accrete_particles,update_externalforce, & update_vdependent_extforce_leapfrog,is_velocity_dependent @@ -1344,6 +1344,8 @@ subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time, call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) eos_vars(imu,i) = nucleation(idmu,i) eos_vars(igamma,i) = nucleation(idgamma,i) + elseif (update_muGamma) then + call calc_muGamma(rhoi, dust_temp(i),eos_vars(imu,i),eos_vars(igamma,i), pH, pH_tot) endif ! ! COOLING diff --git a/src/main/wind.F90 b/src/main/wind.F90 index 259e21e5c..3bb364228 100644 --- a/src/main/wind.F90 +++ b/src/main/wind.F90 @@ -207,8 +207,7 @@ subroutine wind_step(state) use cooling_solver, only:calc_cooling_rate use options, only:icooling use units, only:unit_ergg,unit_density - use dim, only:itau_alloc - use eos, only:ieos + use dim, only:itau_alloc,update_muGamma type(wind_state), intent(inout) :: state real :: rvT(3), dt_next, v_old, dlnQ_dlnT, Q_code, pH, pH_tot @@ -241,9 +240,9 @@ subroutine wind_step(state) state%gamma = state%JKmuS(idgamma) state%kappa = calc_kappa_dust(state%JKmuS(idK3), state%Tdust, state%rho) state%JKmuS(idalpha) = state%alpha_Edd+alpha_rad - elseif (idust_opacity == 1) then - state%kappa = calc_kappa_bowen(state%Tdust) - if (ieos == 5) call calc_muGamma(state%rho, state%Tg,state%mu, state%gamma, pH, pH_tot) + else + if (idust_opacity == 1) state%kappa = calc_kappa_bowen(state%Tdust) + if (update_muGamma) call calc_muGamma(state%rho, state%Tg,state%mu, state%gamma, pH, pH_tot) endif if (itau_alloc == 1) then @@ -345,13 +344,12 @@ subroutine wind_step(state) use ptmass_radiation, only:alpha_rad,iget_tdust,tdust_exp, isink_radiation use physcon, only:pi,Rg use dust_formation, only:evolve_chem,calc_kappa_dust,calc_kappa_bowen,& - calc_Eddington_factor,idust_opacity, calc_mugamma + calc_Eddington_factor,idust_opacity, calc_muGamma use part, only:idK3,idmu,idgamma,idsat,idkappa use cooling_solver, only:calc_cooling_rate use options, only:icooling use units, only:unit_ergg,unit_density - use dim, only:itau_alloc - use eos, only:ieos + use dim, only:itau_alloc,update_muGamma type(wind_state), intent(inout) :: state real :: rvT(3), dt_next, v_old, dlnQ_dlnT, Q_code, pH,pH_tot @@ -365,9 +363,9 @@ subroutine wind_step(state) state%mu = state%JKmuS(idmu) state%gamma = state%JKmuS(idgamma) state%kappa = calc_kappa_dust(state%JKmuS(idK3), state%Tdust, state%rho) - elseif (idust_opacity == 1) then - state%kappa = calc_kappa_bowen(state%Tdust) - if (ieos == 5 ) call calc_muGamma(state%rho, state%Tg,state%mu, state%gamma, pH, pH_tot) + else + if (idust_opacity == 1) state%kappa = calc_kappa_bowen(state%Tdust) + if (update_muGamma) call calc_muGamma(state%rho, state%Tg,state%mu, state%gamma, pH, pH_tot) endif if (itau_alloc == 1) then diff --git a/src/main/wind_equations.f90 b/src/main/wind_equations.f90 index ac0a78922..b6397f2a5 100644 --- a/src/main/wind_equations.f90 +++ b/src/main/wind_equations.f90 @@ -290,6 +290,7 @@ end subroutine RK4_step_dr subroutine calc_dvT_dr(r, v, T0, Rstar_cgs, Mdot_cgs, mu0, gamma0, alpha, dalpha_dr, Q, dQ_dr, dv_dr, dT_dr, numerator, denominator) !all quantities in cgs use physcon, only:Gg,Rg,pi + use dim, only:update_muGamma use options, only:icooling,ieos use dust_formation, only:calc_muGamma,idust_opacity real, intent(in) :: r, v, T0, mu0, gamma0, alpha, dalpha_dr, Q, dQ_dr, Rstar_cgs, Mdot_cgs @@ -304,8 +305,8 @@ subroutine calc_dvT_dr(r, v, T0, Rstar_cgs, Mdot_cgs, mu0, gamma0, alpha, dalpha gamma = gamma0 if (idust_opacity == 2) then rho_cgs = Mdot_cgs/(4.*pi*r**2*v) - call calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) endif + if (update_muGamma .or. idust_opacity == 2) call calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) !Temperature law if (ieos == 6) then From 0729d0707ff9c190e35885346ad088dc20f778f8 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Thu, 25 Apr 2024 14:23:55 +0200 Subject: [PATCH 490/814] (ieos=17) bug fixes : uindeclared variables, missing ieos == 17 tests, ... --- src/main/checksetup.f90 | 4 ++-- src/main/energies.F90 | 2 +- src/main/ptmass.F90 | 2 +- src/main/readwrite_infile.F90 | 3 ++- src/main/wind_equations.f90 | 4 ++-- src/setup/set_hierarchical.f90 | 36 ++++++++++++++++++++-------------- 6 files changed, 29 insertions(+), 22 deletions(-) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index a14201b96..a0990b7c2 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -105,7 +105,7 @@ subroutine check_setup(nerror,nwarn,restart) nerror = nerror + 1 endif else - if (polyk < tiny(0.) .and. ieos /= 2 .and. ieos /= 5) then + if (polyk < tiny(0.) .and. ieos /= 2 .and. ieos /= 5 .and. ieos /= 17) then print*,'WARNING! polyk = ',polyk,' in setup, speed of sound will be zero in equation of state' nwarn = nwarn + 1 endif @@ -239,7 +239,7 @@ subroutine check_setup(nerror,nwarn,restart) nerror = nerror + 1 endif else - if (abs(gamma-1.) > tiny(gamma) .and. (ieos /= 2 .and. ieos /= 5 .and. ieos /=9)) then + if (abs(gamma-1.) > tiny(gamma) .and. (ieos /= 2 .and. ieos /= 5 .and. ieos /=9 .and. ieos /= 17)) then print*,'*** ERROR: using isothermal EOS, but gamma = ',gamma gamma = 1. print*,'*** Resetting gamma to 1, gamma = ',gamma diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 27684ce97..e5b7958a8 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -363,7 +363,7 @@ subroutine compute_energies(t) if (vxyzu(iu,i) < tiny(vxyzu(iu,i))) np_e_eq_0 = np_e_eq_0 + 1 if (spsoundi < tiny(spsoundi) .and. vxyzu(iu,i) > 0. ) np_cs_eq_0 = np_cs_eq_0 + 1 else - if ((ieos==2 .or. ieos == 5) .and. gammai > 1.001) then + if ((ieos==2 .or. ieos == 5 .or. ieos == 17) .and. gammai > 1.001) then !--thermal energy using polytropic equation of state etherm = etherm + pmassi*ponrhoi/(gammai-1.)*gasfrac elseif (ieos==9) then diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 8cf6a0088..7d1e989d9 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1167,7 +1167,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote if (maxvxyzu >= 4) then etherm = etherm + pmassj*vxyzu(4,j) else - if (ieos==2 .and. gamma > 1.001) then + if ((ieos==2 .or. ieos==17) .and. gamma > 1.001) then etherm = etherm + pmassj*(eos_vars(igasP,j)/rhoj)/(gamma - 1.) elseif (ieos==5 .and. gamma > 1.001) then etherm = etherm + pmassj*(eos_vars(igasP,j)/rhoj)/(eos_vars(igamma,j) - 1.) diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 741212439..9ba43f4fe 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -700,7 +700,8 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (shearparam < 0.) call fatal(label,'stupid value for shear parameter (< 0)') if (irealvisc==2 .and. shearparam > 1) call error(label,'alpha > 1 for shakura-sunyaev viscosity') if (iverbose > 99 .or. iverbose < -9) call fatal(label,'invalid verboseness setting (two digits only)') - if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos == 17)) call fatal(label,'cooling requires adiabatic eos (ieos=2)') + if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos == 17)) & + call fatal(label,'cooling requires adiabatic eos (ieos=2)') if (icooling > 0 .and. (ipdv_heating <= 0 .or. ishock_heating <= 0)) & call fatal(label,'cooling requires shock and work contributions') if (((isink_radiation == 1 .or. isink_radiation == 3 ) .and. idust_opacity == 0 ) & diff --git a/src/main/wind_equations.f90 b/src/main/wind_equations.f90 index b6397f2a5..589e9edd8 100644 --- a/src/main/wind_equations.f90 +++ b/src/main/wind_equations.f90 @@ -303,10 +303,10 @@ subroutine calc_dvT_dr(r, v, T0, Rstar_cgs, Mdot_cgs, mu0, gamma0, alpha, dalpha T = T0 mu = mu0 gamma = gamma0 - if (idust_opacity == 2) then + if (update_muGamma .or. idust_opacity == 2) then rho_cgs = Mdot_cgs/(4.*pi*r**2*v) + call calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) endif - if (update_muGamma .or. idust_opacity == 2) call calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) !Temperature law if (ieos == 6) then diff --git a/src/setup/set_hierarchical.f90 b/src/setup/set_hierarchical.f90 index 22dad2a68..018028077 100644 --- a/src/setup/set_hierarchical.f90 +++ b/src/setup/set_hierarchical.f90 @@ -493,19 +493,21 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & !--- Load/Create HIERARCHY file: xyzmh_ptmass index | hierarchical index | star mass | companion star mass | semi-major axis | eccentricity | period | inclination | argument of pericenter | ascending node longitude inquire(file=trim(filename), exist=iexist) - if (present(subst) .and. subst>10) then - if (iexist) then - open(1, file = trim(filename), status = 'old') - lines=0 - do - read(1, *, iostat=io) data(lines+1,:) - if (io/=0) exit - lines = lines + 1 - enddo - close(1) - else - print "(1x,a)",'ERROR: set_multiple: there is no HIERARCHY file, cannot perform subtitution.' - ierr = ierr_HIER2 + if (present(subst)) then + if (subst>10) then + if (iexist) then + open(1, file = trim(filename), status = 'old') + lines=0 + do + read(1, *, iostat=io) data(lines+1,:) + if (io/=0) exit + lines = lines + 1 + enddo + close(1) + else + print "(1x,a)",'ERROR: set_multiple: there is no HIERARCHY file, cannot perform subtitution.' + ierr = ierr_HIER2 + endif endif else if (iexist) then @@ -535,7 +537,8 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & subst_index = 0 !--- Checks to avoid bad substitutions - if (present(subst) .and. subst>10) then + if (present(subst)) then + if (subst>10) then write(hier_prefix, *) subst io=0 mtot = 0. @@ -604,6 +607,7 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & !nptmass = nptmass + 1 period = sqrt(4.*pi**2*semimajoraxis**3/mtot) + endif else mprimary = m1 msecondary = m2 @@ -620,7 +624,8 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & f=f,accretion_radius1=accretion_radius1,accretion_radius2=accretion_radius2, & xyzmh_ptmass=xyzmh_ptmass,vxyz_ptmass=vxyz_ptmass,nptmass=nptmass, ierr=ierr) - if (present(subst) .and. subst>10) then + if (present(subst)) then + if (subst>10) then !--- lower nptmass, copy one of the new sinks to the subst star nptmass = nptmass-1 i1 = subst_index @@ -725,6 +730,7 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & write(1,*) i2, trim(hier_prefix)//"2", msecondary, mprimary, semimajoraxis, eccentricity, & period, incl, arg_peri, posang_ascnode close(1) + endif endif end subroutine set_multiple From 48c58b47f7a437decdf1f6312aa7d7755679fee7 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Thu, 25 Apr 2024 21:59:59 +0200 Subject: [PATCH 491/814] (calc_muGamma) fix error in calculation of T --- src/main/dust_formation.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index 347eb5b89..f32754011 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.f90 @@ -413,7 +413,7 @@ subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) mu_old = mu gamma_old = gamma else - T = 2.*T_old*mu/mu_old/(gamma_old-1.)*(x-eps(iHe))/(x+4.-eps(iHe)) + T = T_old*mu/mu_old/(gamma_old-1.)*2.*x/(x+4.+4.*eps(iHe)) if (i>=itermax .and. .not.converged) then if (isolve==0) then isolve = isolve+1 From 7ed2a6aac08e63c0a170c95b8863fe7358455f18 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 26 Apr 2024 14:37:02 +1000 Subject: [PATCH 492/814] finish star formation prescription using sink w/ hacc --- build/Makefile | 2 +- src/main/evolve.F90 | 8 +- src/main/ptmass.F90 | 158 +++++++++++++++++++++++------------- src/main/step_leapfrog.F90 | 6 +- src/main/substepping.F90 | 20 +++-- src/main/utils_sampling.f90 | 59 ++++++++++++++ src/setup/setup_cluster.f90 | 3 +- src/tests/test_ptmass.f90 | 4 +- 8 files changed, 184 insertions(+), 76 deletions(-) create mode 100644 src/main/utils_sampling.f90 diff --git a/build/Makefile b/build/Makefile index 2f9e2e75e..1f4698b25 100644 --- a/build/Makefile +++ b/build/Makefile @@ -535,7 +535,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} \ - quitdump.f90 ptmass.F90 \ + quitdump.f90 utils_sampling.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ mf_write.f90 evolve.F90 utils_orbits.f90 utils_linalg.f90 \ diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 53b9d7928..793f57cf7 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -89,10 +89,11 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) #endif 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,& + linklist_ptmass use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & - set_integration_precision + set_integration_precision,icreate_stars,ptmass_create_stars use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries @@ -276,7 +277,8 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! creation of new sink particles ! call ptmass_create(nptmass,npart,ipart_rhomax,xyzh,vxyzu,fxyzu,fext,divcurlv,& - poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) + poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklist_ptmass,dptmass,time) + if (icreate_stars > 0) call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) endif ! ! Strang splitting: implicit update for half step diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 6ca4b2138..104a0262a 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -49,7 +49,7 @@ module ptmass public :: merge_sinks public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured - public :: ptmass_accrete, ptmass_create + public :: ptmass_accrete, ptmass_create,ptmass_create_stars public :: write_options_ptmass, read_options_ptmass public :: update_ptmass public :: calculate_mdot @@ -959,7 +959,7 @@ end subroutine update_ptmass !+ !------------------------------------------------------------------------- subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& - massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) + massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklist_ptmass,dptmass,time) use part, only:ihacc,ihsoft,itbirth,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP,igamma,ndptmass use dim, only:maxp,maxneigh,maxvxyzu,maxptmass,ind_timesteps @@ -987,6 +987,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote real(4), intent(in) :: divcurlv(:,:),poten(:) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:),dptmass(ndptmass,nptmass+1) + integer, intent(inout) :: linklist_ptmass(:) real, intent(in) :: time integer(kind=1) :: iphasei,ibin_wakei,ibin_itest integer :: nneigh @@ -1501,7 +1502,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote fxyz_ptmass_sinksink(:,nptmass) = 0.0 call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) - if (icreate_stars > 0) call ptmass_create_stars(nptmass,xyzmh_ptmass,time) + if (icreate_stars > 0) call ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) if (id==id_rhomax) then write(iprint,"(a,i3,a,4(es10.3,1x),a,i6,a,es10.3)") ' created ptmass #',nptmass,& @@ -1533,10 +1534,10 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote end subroutine ptmass_create -subroutine ptmass_create_seed(nptmass,xyzmh_ptmass,linklist_ptmass,time) - use part, only:itbirth +subroutine ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) + use part, only:itbirth,ihacc integer, intent(inout) :: nptmass - integer, intent(in) :: linklist_ptmass(:) + integer, intent(inout) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: time integer :: i, nseed @@ -1548,41 +1549,81 @@ subroutine ptmass_create_seed(nptmass,xyzmh_ptmass,linklist_ptmass,time) nptmass = nptmass + 1 xyzmh_ptmass(itbirth,nptmass) = time xyzmh_ptmass(4,nptmass) = -1. + xyzmh_ptmass(ihacc,nptmass) = -1. if (i==nseed)then linklist_ptmass(nptmass) = -1 !! null pointer else linklist_ptmass(nptmass) = nptmass + 1 !! link this new seed to the next one endif enddo -end subroutine ptmass_create_seed - -subroutine ptmass_create_star(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) - use part, only:itbirth +end subroutine ptmass_create_seeds + +subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) + use physcon, only:solarm,pi + use eos, only:polyk + use units, only:umass + use part, only:itbirth,ihacc + use utils_sampling, only:divide_unit_seg integer, intent(in) :: nptmass integer, intent(in) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(in) :: time - integer :: i,k,nseed - real :: tbirthi,mi + real, allocatable :: masses(:) + real :: xi(3),vi(3) + integer :: i,k,n + real :: tbirthi,mi,hacci,minmass,minmonmi + real :: xk,yk,zk,dk,cs do i=1,nptmass mi = xyzmh_ptmass(4,i) + hacci = xyzmh_ptmass(ihacc,i) tbirthi = xyzmh_ptmass(itbirth,i) if (mi<0.) cycle - if (time>tbirthi+tmax_acc) then + if (time>tbirthi+tmax_acc .and. hacci>0. ) then + !! save xcom and vcom before placing stars + xi(1) = xyzmh_ptmass(1,i) + xi(2) = xyzmh_ptmass(2,i) + xi(3) = xyzmh_ptmass(3,i) + vi(1) = vxyz_ptmass(1,i) + vi(2) = vxyz_ptmass(2,i) + vi(3) = vxyz_ptmass(3,i) + + !! masses sampling method call ptmass_size_lklist(i,n,linklist_ptmass) + allocate(masses(n)) + minmass = (0.08*solarm)/umass + minmonmi = minmass/mi + call divide_unit_seg(masses,minmonmi,n) + masses = masses*mi - !! do some clever stuff to divide the mass k=i do while(k>0) !! do some clever stuff + dk = huge(mi) + do while (dk>1.) + xk = rand() + yk = rand() + zk = rand() + dk = xk**2+yk**2+zk**2 + enddo + cs = sqrt(polyk) + xyzmh_ptmass(ihacc,i) = -1. + xyzmh_ptmass(4,i) = masses(n) + xyzmh_ptmass(1,k) = xi(1) + xk*hacci + xyzmh_ptmass(2,k) = xi(2) + yk*hacci + xyzmh_ptmass(3,k) = xi(3) + zk*hacci + vxyz_ptmass(1,k) = vi(1) + cs*(-2.*log10(rand()))*cos(2*pi**rand()) + vxyz_ptmass(2,k) = vi(2) + cs*(-2.*log10(rand()))*cos(2*pi**rand()) + vxyz_ptmass(3,k) = vi(3) + cs*(-2.*log10(rand()))*cos(2*pi**rand()) k = linklist_ptmass(k) + n = n - 1 enddo + deallocate(masses) endif enddo -end subroutine ptmass_create_star +end subroutine ptmass_create_stars !----------------------------------------------------------------------- !+ @@ -1607,15 +1648,17 @@ end subroutine ptmass_create_star ! negative mass. !+ !----------------------------------------------------------------------- -subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) +subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklist_ptmass,merge_ij) use io, only:iprint,warning,iverbose,id,master + use part, only:itbirth real, intent(in) :: time integer, intent(in) :: nptmass,merge_ij(nptmass) + integer, intent(inout) :: linklist_ptmass(nptmass) real, intent(inout) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: vxyz_ptmass(3,nptmass),fxyz_ptmass(4,nptmass) - integer :: i,j,k + integer :: i,j,k,l real :: rr2,xi,yi,zi,mi,vxi,vyi,vzi,xj,yj,zj,mj,vxj,vyj,vzj,Epot,Ekin - real :: mij,mij1 + real :: mij,mij1,tbirthi,tbirthj logical :: lmerge character(len=15) :: typ @@ -1624,24 +1667,25 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_i j = merge_ij(i) if (merge_ij(j) == i .and. xyzmh_ptmass(4,j) > 0.) then lmerge = .false. - agei = xyzmh_ptmass(itbirth,i) - agej = xyzmh_ptmass(itbirth,j) - if (agej0) then ! Connect linked list of the merged sink to the survivor - call ptmass_end_lklist(i,k,linklist_ptmass) - linklist_ptmass(k) = j + call ptmass_end_lklist(k,l,linklist_ptmass) + linklist_ptmass(l) = j endif ! print success - write(iprint,"(/,1x,3a,I8,a,I8,a,F10.4)") 'merge_sinks: ',typ,' merged sinks ',i,' & ',j,' at time = ',time + write(iprint,"(/,1x,3a,I8,a,I8,a,F10.4)") 'merge_sinks: ',typ,' merged sinks ',k,' & ',j,' at time = ',time elseif (id==master .and. iverbose>=1) then write(iprint,"(/,1x,a,I8,a,I8,a,F10.4)") & - 'merge_sinks: failed to conditionally merge sinks ',i,' & ',j,' at time = ',time + 'merge_sinks: failed to conditionally merge sinks ',k,' & ',j,' at time = ',time endif elseif (xyzmh_ptmass(4,j) > 0. .and. id==master .and. iverbose>=1) then write(iprint,"(/,1x,a,I8,a,I8,a,F10.4)") & - 'merge_sinks: There is a mismatch in sink indicies and relative proximity for ',i,' & ',j,' at time = ',time + 'merge_sinks: There is a mismatch in sink indicies and relative proximity for ',k,' & ',j,' at time = ',time endif endif enddo @@ -1702,7 +1746,7 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_i end subroutine merge_sinks subroutine ptmass_end_lklist(i,k,linklist_ptmass) - integer, intent(in) :: linklist_ptmass + integer, intent(in) :: linklist_ptmass(:) integer, intent(in) :: i integer, intent(out) :: k integer :: l @@ -1714,7 +1758,7 @@ subroutine ptmass_end_lklist(i,k,linklist_ptmass) end subroutine ptmass_end_lklist subroutine ptmass_size_lklist(i,n,linklist_ptmass) - integer, intent(in) :: linklist_ptmass + integer, intent(in) :: linklist_ptmass(:) integer, intent(in) :: i integer, intent(out) :: n integer :: l diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 84f4ada36..af316a14b 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -104,7 +104,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use timestep, only:dterr,bignumber,tolv use mpiutils, only:reduceall_mpi use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & - dsdt_ptmass,fsink_old,ibin_wake,dptmass + dsdt_ptmass,fsink_old,ibin_wake,dptmass,linklist_ptmass use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax @@ -248,8 +248,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) 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,fsink_old,nbinmax,ibin_wake) + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& + dptmass,linklist_ptmass,fsink_old,nbinmax,ibin_wake) else call substep_sph(dtsph,npart,xyzh,vxyzu) endif diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index a3f9cd3f5..407513e79 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -425,7 +425,7 @@ end subroutine substep_sph !---------------------------------------------------------------- subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & - fsink_old,nbinmax,ibin_wake) + linklist_ptmass,fsink_old,nbinmax,ibin_wake) use io, only:iverbose,id,master,iprint,fatal use options, only:iexternalforce use part, only:fxyz_ptmass_sinksink @@ -440,6 +440,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & real, intent(inout) :: dptmass(:,:),fsink_old(:,:) integer(kind=1), intent(in) :: nbinmax integer(kind=1), intent(inout) :: ibin_wake(:) + integer , intent(inout) :: linklist_ptmass(:) logical :: extf_vdep_flag,done,last_step,accreted integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step @@ -480,25 +481,25 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & 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) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass) if (use_fourthorder) then !! FSI 4th order scheme ! FSI extrapolation method (Omelyan 2006) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,fsink_old) call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass) ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) if (accreted) then call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass) endif else !! standard leapfrog scheme @@ -508,7 +509,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) 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) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass) endif endif @@ -779,7 +780,7 @@ 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,fsink_old) + force_count,extf_vdep_flag,linklist_ptmass,fsink_old) use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & @@ -797,6 +798,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation integer, intent(in) :: nptmass,npart,nsubsteps,ntypes integer, intent(inout) :: force_count + integer, intent(inout) :: linklist_ptmass(:) real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) real, intent(inout) :: dtextforce @@ -846,7 +848,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dtf,iexternalforce,timei,merge_ij,merge_n, & dsdt_ptmass,extrapfac,fsink_old) if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call 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) @@ -855,7 +857,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call 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) fxyz_ptmass_sinksink=fxyz_ptmass diff --git a/src/main/utils_sampling.f90 b/src/main/utils_sampling.f90 new file mode 100644 index 000000000..b959ba76a --- /dev/null +++ b/src/main/utils_sampling.f90 @@ -0,0 +1,59 @@ +!--------------------------------------------------------------------------! +! 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 utils_sampling +! +! Contains simple routine to sample variable using specific distributions +! +! :References: None +! +! :Owner: Yann Bernard +! +! :Runtime parameters: None +! +! :Dependencies: None +! + implicit none + public :: divide_unit_seg + +contains + +subroutine divide_unit_seg(lengths,mindist,nlengths) + integer, intent(in) :: nlengths + real, intent(inout) :: lengths(nlengths) + real, intent(in) :: mindist + integer :: i,j + logical :: far + real :: points(nlengths+1),tmp,dist + points(nlengths+1) = 1. + points(1) = 0. + tmp = 0. + + do i=2,nlengths + far = .false. + dist = huge(tmp) + do while (far) + tmp = rand() + dist = min(abs(points(1)-tmp),dist) + dist = min(abs(points(nlengths+1)-tmp),dist) + do j=2,i-1 + dist = min(abs(points(j)-tmp),dist) + enddo + far = mindist Date: Fri, 26 Apr 2024 16:46:04 +1000 Subject: [PATCH 493/814] update cluster setup --- src/main/physcon.f90 | 1 + src/setup/setup_cluster.f90 | 9 +++++---- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/main/physcon.f90 b/src/main/physcon.f90 index 2577d5fd6..414ba9d14 100644 --- a/src/main/physcon.f90 +++ b/src/main/physcon.f90 @@ -92,6 +92,7 @@ module physcon real(kind=8), parameter :: hours = 3.6d3 real(kind=8), parameter :: days = 8.64d4 real(kind=8), parameter :: years = 3.1556926d7 + real(kind=8), parameter :: myr = 3.1556926d13 ! !--Energy conversion ! diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 0960f4587..35de91eb3 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -45,7 +45,7 @@ module setup ! !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) - use physcon, only:pi,solarm,pc,years,kboltz,mass_proton_cgs,au + use physcon, only:pi,solarm,pc,years,kboltz,mass_proton_cgs,au,myr use velfield, only:set_velfield_from_cubes use setup_params, only:rmax,rhozero,npart_total use spherical, only:set_sphere @@ -55,7 +55,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use setvfield, only:normalise_vfield use timestep, only:dtmax,tmax use centreofmass, only:reset_centreofmass - use ptmass, only:h_acc,r_crit,rho_crit_cgs,icreate_sinks,icreate_stars + use ptmass, only:h_acc,r_crit,rho_crit_cgs,icreate_sinks,icreate_stars,tmax_acc use datafiles, only:find_phantom_datafile use eos, only:ieos,gmw use kernel, only:hfact_default @@ -77,7 +77,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, character(len=16) :: lattice character(len=120) :: filex,filey,filez,filein,fileset logical :: inexists,setexists - logical :: BBB03 = .true. ! use the BB03 defaults, else that of a YMC (S. Jaffa) + logical :: BBB03 = .false. ! use the BB03 defaults, else that of a YMC (S. Jaffa) !--Ensure this is pure hydro if (mhd) call fatal('setup_cluster','This setup is not consistent with MHD.') @@ -141,6 +141,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, t_ff = sqrt(3.*pi/(32.*rhozero)) ! free-fall time (the characteristic timescale) epotgrav = 3./5.*totmass**2/rmax ! Gravitational potential energy lattice = 'random' + icreate_stars = 1 + tmax_acc = (0.5*myr)/utime !--Set positions call set_sphere(trim(lattice),id,master,0.,rmax,psep,hfact,npart,xyzh,nptot=npart_total, & @@ -177,7 +179,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, h_acc = Rsink_au*au/udist r_crit = 2.*h_acc icreate_sinks = 1 - icreate_stars = 0 rho_crit_cgs = 1.d-10 ieos = ieos_in gmw = mu ! for consistency; gmw will never actually be used From 851fb890710e0bc14b68f90d6c96b65604b1780e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 09:55:48 +1000 Subject: [PATCH 494/814] fix wrong condition during accretion --- src/main/ptmass.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 104a0262a..774348361 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -751,7 +751,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & mpt = xyzmh_ptmass(4,i) age = xyzmh_ptmass(itbirth,i) if (mpt < 0.) cycle - if (age > tmax_acc) cycle + if (age + tmax_acc < time ) cycle dx = xi - xyzmh_ptmass(1,i) dy = yi - xyzmh_ptmass(2,i) dz = zi - xyzmh_ptmass(3,i) From 49e80df15b6b128bfd0d9c49646058a00385334b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 10:10:05 +1000 Subject: [PATCH 495/814] fix uninitialised variable in kick loop ( must also be fixed in the master repo) --- src/main/substepping.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index c99964510..c226fa977 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -706,6 +706,11 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. + fxi = 0. + fyi = 0. + fzi = 0. + pmassi = 0. + itype = 0 !$omp parallel default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & From de3b8e41b6d497f690140948a603dfe021311239 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 10:43:59 +1000 Subject: [PATCH 496/814] fix uninitialised part2 --- src/main/substepping.F90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index c226fa977..c99964510 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -706,11 +706,6 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. - fxi = 0. - fyi = 0. - fzi = 0. - pmassi = 0. - itype = 0 !$omp parallel default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & From 10341b3d4865f5d3bd9668c40265238ee5403c84 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 11:10:30 +1000 Subject: [PATCH 497/814] fix uninitialiased variable part 3 --- src/main/substepping.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index c99964510..58652a2a8 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -706,6 +706,11 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. + fxi = 0. + fyi = 0. + fzi = 0. + itype = iphase(igas) + pmassi = massoftype(igas) !$omp parallel default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & From 5f66895f1aac0b2e93737609a84b270317a071a1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 12:32:44 +1000 Subject: [PATCH 498/814] fix uninitialised part 4 --- src/main/substepping.F90 | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 58652a2a8..e6936340f 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -662,6 +662,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, itype = iphase(igas) pmassi = massoftype(igas) + accreted = .false. dkdt = dki*dt @@ -706,21 +707,17 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. - fxi = 0. - fyi = 0. - fzi = 0. - itype = iphase(igas) - pmassi = massoftype(igas) !$omp parallel default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & !$omp shared(iexternalforce) & !$omp shared(nbinmax,ibin_wake) & - !$omp reduction(+:dptmass) & !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & !$omp firstprivate(itype,pmassi,ibin_wakei) & - !$omp reduction(+:accretedmass,nfail,naccreted,nlive) + !$omp reduction(+:dptmass) & + !$omp reduction(+:accretedmass) & + !$omp reduction(+:nfail,naccreted,nlive) !$omp do accreteloop: do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then From 3646f1114b4fb867fb807d97c7b88fa5697db557 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 12:40:25 +1000 Subject: [PATCH 499/814] fix uninitialised part 5.... --- src/main/substepping.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index e6936340f..ca40e3e92 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -662,7 +662,6 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, itype = iphase(igas) pmassi = massoftype(igas) - accreted = .false. dkdt = dki*dt From 55f23d5a3add6517a53624fdc20479497feadebd Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 30 Apr 2024 13:21:34 +0200 Subject: [PATCH 500/814] (CE-analysis) add radiation energy to thermal energy when using radiation --- src/main/ionization.f90 | 7 ++- src/utils/analysis_common_envelope.f90 | 69 ++++++++++++-------------- 2 files changed, 38 insertions(+), 38 deletions(-) diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index ebc536639..88f155561 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -338,13 +338,15 @@ end subroutine get_erec_components ! gas particle. Inputs and outputs in code units !+ !---------------------------------------------------------------- -subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,gamma,ethi) - use part, only:rhoh +subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,gamma,ethi,radprop) + use dim, only:do_radiation + use part, only:rhoh,iradxi use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp use physcon, only:radconst,Rg use units, only:unit_density,unit_pressure,unit_ergg,unit_pressure integer, intent(in) :: ieos real, intent(in) :: particlemass,presi,tempi,xyzh(4),vxyzu(4),gamma + real, intent(in), optional :: radprop real, intent(out) :: ethi real :: hi,densi_cgs,mui @@ -357,6 +359,7 @@ subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,gamma,et ethi = particlemass * ethi / unit_ergg case default ! assuming internal energy = thermal energy ethi = particlemass * vxyzu(4) + if (do_radiation) ethi = ethi + particlemass*radprop(iradxi) end select end subroutine calc_thermal_energy diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 629645cb2..4386063b3 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -20,24 +20,26 @@ module analysis ! sortutils, table_utils, units, vectorutils ! - use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,poten,ihsoft,ihacc,& - rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted - use units, only:print_units,umass,utime,udist,unit_ergg,unit_density,& - unit_pressure,unit_velocity,unit_Bfield,unit_energ - use physcon, only:gg,pi,c,Rg - use io, only:fatal - use prompting, only:prompt - use centreofmass, only:get_centreofmass, reset_centreofmass - use energies, only:compute_energies,ekin,etherm,epot,etot - use ptmass, only:get_accel_sink_gas,get_accel_sink_sink - use kernel, only:kernel_softening,radkern,wkern,cnormk - use eos, only:equationofstate,ieos,init_eos,X_in,Z_in,gmw,get_spsound,done_init_eos - use eos_gasradrec,only:irecomb - use eos_mesa, only:get_eos_kappa_mesa,get_eos_pressure_temp_mesa,& - get_eos_various_mesa,get_eos_pressure_temp_gamma1_mesa - use setbinary, only:Rochelobe_estimate,L1_point - use sortutils, only:set_r2func_origin,r2func_origin,indexxfunc - use table_utils, only:logspace + use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,poten,ihsoft,ihacc,& + rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted + use dim, only:do_radiation + use units, only:print_units,umass,utime,udist,unit_ergg,unit_density,& + unit_pressure,unit_velocity,unit_Bfield,unit_energ + use physcon, only:gg,pi,c,Rg + use io, only:fatal + use prompting, only:prompt + use centreofmass, only:get_centreofmass, reset_centreofmass + use energies, only:compute_energies,ekin,etherm,epot,etot + use ptmass, only:get_accel_sink_gas,get_accel_sink_sink + use kernel, only:kernel_softening,radkern,wkern,cnormk + use ionization_mod,only:calc_thermal_energy + use eos, only:equationofstate,ieos,init_eos,X_in,Z_in,gmw,get_spsound,done_init_eos + use eos_gasradrec, only:irecomb + use eos_mesa, only:get_eos_kappa_mesa,get_eos_pressure_temp_mesa,& + get_eos_various_mesa,get_eos_pressure_temp_gamma1_mesa + use setbinary, only:Rochelobe_estimate,L1_point + use sortutils, only:set_r2func_origin,r2func_origin,indexxfunc + use table_utils, only:logspace implicit none character(len=20), parameter, public :: analysistype = 'common_envelope' integer :: analysis_to_perform @@ -623,9 +625,8 @@ end subroutine m_vs_t !+ !---------------------------------------------------------------- subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp + use part, only:eos_vars,itemp,radprop use ptmass, only:get_accel_sink_gas - use ionization_mod, only:calc_thermal_energy use vectorutils, only:cross_product3D integer, intent(in) :: npart real, intent(in) :: time,particlemass @@ -702,7 +703,7 @@ subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) tempi = eos_vars(itemp,i) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call cross_product3D(xyzh(1:3,i), particlemass * vxyzu(1:3,i), rcrossmv) ! Angular momentum w.r.t. CoM - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi,radprop) etoti = ekini + epoti + ethi ! Overwrite etoti outputted by calc_gas_energies to use ethi instead of einti else ! Output 0 for quantities pertaining to accreted particles @@ -1382,7 +1383,7 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) use eos_mesa, only:get_eos_kappa_mesa use mesa_microphysics, only:getvalue_mesa use sortutils, only:set_r2func_origin,r2func_origin,indexxfunc - use ionization_mod, only:calc_thermal_energy,ionisation_fraction + use ionization_mod, only:ionisation_fraction use dust_formation, only:psat_C,eps,set_abundances,mass_per_H, chemical_equilibrium_light, calc_nucleation!, Scrit !use dim, only:nElements integer, intent(in) :: npart @@ -1663,7 +1664,7 @@ subroutine track_particle(time,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp use eos, only:entropy use mesa_microphysics, only:getvalue_mesa - use ionization_mod, only:calc_thermal_energy,ionisation_fraction + use ionization_mod, only:ionisation_fraction real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) integer, parameter :: nparttotrack=10,ncols=17 @@ -1888,7 +1889,7 @@ end subroutine tconv_profile !---------------------------------------------------------------- subroutine recombination_tau(time,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy,ionisation_fraction + use ionization_mod, only:ionisation_fraction integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -1979,7 +1980,6 @@ end subroutine recombination_tau !---------------------------------------------------------------- subroutine energy_hist(time,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2044,7 +2044,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp use eos, only:entropy use mesa_microphysics, only:getvalue_mesa - use ionization_mod, only:calc_thermal_energy,ionisation_fraction + use ionization_mod, only:ionisation_fraction integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2288,7 +2288,6 @@ end subroutine rotation_profile !---------------------------------------------------------------- subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy real, intent(in) :: time,particlemass integer, intent(in) :: npart,num real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2571,7 +2570,6 @@ end subroutine planet_profile !+ !---------------------------------------------------------------- subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) - use ionization_mod, only:calc_thermal_energy integer, intent(in) :: npart,num real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2690,7 +2688,7 @@ end subroutine unbound_profiles !+ !---------------------------------------------------------------- subroutine unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) - use ionization_mod, only:calc_thermal_energy,get_xion,ionisation_fraction + use ionization_mod, only:get_xion,ionisation_fraction integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2766,7 +2764,7 @@ end subroutine unbound_ionfrac !---------------------------------------------------------------- subroutine unbound_temp(time,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy,get_xion + use ionization_mod, only:get_xion integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2840,7 +2838,7 @@ end subroutine unbound_temp !---------------------------------------------------------------- subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy,ionisation_fraction + use ionization_mod, only:ionisation_fraction integer, intent(in) :: npart,num real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -3038,7 +3036,6 @@ end subroutine sink_properties subroutine env_binding_ene(npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy integer, intent(in) :: npart real, intent(in) :: particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -3724,7 +3721,6 @@ end subroutine print_dump_numbers subroutine analyse_disk(num,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp use extern_corotate, only:get_companion_force - use ionization_mod, only:calc_thermal_energy use vectorutils, only:cross_product3D integer, intent(in) :: num,npart real, intent(in) :: particlemass @@ -3855,14 +3851,14 @@ end subroutine get_gas_omega ! and internal energy of a gas particle. !+ !---------------------------------------------------------------- -subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phii,epoti,ekini,einti,etoti) +subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,radprop,xyzmh_ptmass,phii,epoti,ekini,einti,etoti) ! Warning: Do not sum epoti or etoti as it is to obtain a total energy; this would not give the correct ! total energy due to complications related to double-counting. use ptmass, only:get_accel_sink_gas - use part, only:nptmass + use part, only:nptmass,iradxi real, intent(in) :: particlemass real(4), intent(in) :: poten - real, dimension(4), intent(in) :: xyzh,vxyzu + real, intent(in) :: xyzh(:),vxyzu(:),radprop(:) real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass real, intent(out) :: phii,epoti,ekini,einti,etoti real :: fxi,fyi,fzi @@ -3874,6 +3870,7 @@ subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phii,epo epoti = 2.*poten + particlemass * phii ! For individual particles, need to multiply 2 to poten to get \sum_j G*mi*mj/r ekini = particlemass * 0.5 * dot_product(vxyzu(1:3),vxyzu(1:3)) einti = particlemass * vxyzu(4) + if (do_radiation) einti = einti + particlemass * radprop(iradxi) etoti = epoti + ekini + einti end subroutine calc_gas_energies From 11de37ef28b80213ee893a6e15681c9a9d00ad89 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 30 Apr 2024 13:36:51 +0200 Subject: [PATCH 501/814] (CE-analysis) add radprop to calc_gas_energy --- src/main/ionization.f90 | 2 +- src/utils/analysis_common_envelope.f90 | 44 ++++++++++++++------------ 2 files changed, 24 insertions(+), 22 deletions(-) diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index 88f155561..a2b914c5b 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -346,7 +346,7 @@ subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,gamma,et use units, only:unit_density,unit_pressure,unit_ergg,unit_pressure integer, intent(in) :: ieos real, intent(in) :: particlemass,presi,tempi,xyzh(4),vxyzu(4),gamma - real, intent(in), optional :: radprop + real, intent(in), optional :: radprop(:) real, intent(out) :: ethi real :: hi,densi_cgs,mui diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 4386063b3..5a1018278 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -21,7 +21,8 @@ module analysis ! use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,poten,ihsoft,ihacc,& - rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted + rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted,& + radprop use dim, only:do_radiation use units, only:print_units,umass,utime,udist,unit_ergg,unit_density,& unit_pressure,unit_velocity,unit_Bfield,unit_energ @@ -281,7 +282,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) xyz_a(1:3) = xyzh(1:3,i) - com_xyz(1:3) vxyz_a(1:3) = vxyzu(1:3,i) - com_vxyz(1:3) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) histogram_data(1:3,i) = xyzh(1:3,i) histogram_data(4,i) = distance(xyz_a(1:3)) histogram_data(5,i) = epoti + ekini @@ -697,13 +698,13 @@ subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) do i = 1,npart if (.not. isdead_or_accreted(xyzh(4,i))) then - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,dum1,dum2,dum3,phii) rhopart = rhoh(xyzh(4,i), particlemass) tempi = eos_vars(itemp,i) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call cross_product3D(xyzh(1:3,i), particlemass * vxyzu(1:3,i), rcrossmv) ! Angular momentum w.r.t. CoM - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi,radprop) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi,radprop(:,i)) etoti = ekini + epoti + ethi ! Overwrite etoti outputted by calc_gas_energies to use ethi instead of einti else ! Output 0 for quantities pertaining to accreted particles @@ -859,7 +860,7 @@ subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) jz = rcrossmv(3) encomp(ijz_tot) = encomp(ijz_tot) + jz - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) encomp(ipot_ps) = encomp(ipot_ps) + particlemass * phii @@ -1105,7 +1106,7 @@ subroutine roche_lobe_values(time,npart,particlemass,xyzh,vxyzu) call orbit_com(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,com_xyz,com_vxyz) do i=1,npart - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) sep1 = separation(xyzmh_ptmass(1:3,1),xyzh(1:3,i)) sep2 = separation(xyzmh_ptmass(1:3,2),xyzh(1:3,i)) @@ -1281,7 +1282,7 @@ subroutine star_stabilisation_suite(time,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) totvol = totvol + particlemass / rhopart ! Sum "volume" of all particles virialpart = virialpart + particlemass * ( dot_product(fxyzu(1:3,i),xyzh(1:3,i)) + dot_product(vxyzu(1:3,i),vxyzu(1:3,i)) ) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) totekin = totekin + ekini totepot = totepot + 0.5*epoti ! Factor of 1/2 to correct for double counting if (rhopart > rho_surface) then @@ -1519,7 +1520,7 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) case(1,9) ! Total energy (kin + pot + therm) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum1) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum1) if (quantities_to_calculate(k)==1) then call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) quant(k,i) = (ekini + epoti + ethi) / particlemass ! Specific energy @@ -1727,7 +1728,7 @@ subroutine track_particle(time,particlemass,xyzh,vxyzu) endif ! MESA ENTROPY ! Si = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) etoti = ekini + epoti + ethi call ionisation_fraction(rhopart*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) @@ -1927,7 +1928,7 @@ subroutine recombination_tau(time,npart,particlemass,xyzh,vxyzu) call get_eos_kappa_mesa(rho_part(i)*unit_density,eos_vars(itemp,i),kappa,kappat,kappar) kappa_part(i) = kappa ! In cgs units call ionisation_fraction(rho_part(i)*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) ! Calculate total energy + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) ! Calculate total energy call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rho_part(i),eos_vars(itemp,i),gamma,ethi) etoti = ekini + epoti + ethi if ((xh0 > recomb_th) .and. (.not. prev_recombined(i)) .and. (etoti < 0.)) then ! Recombination event and particle is still bound @@ -2006,7 +2007,7 @@ subroutine energy_hist(time,npart,particlemass,xyzh,vxyzu) do i=1,npart rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) if (ieos==10 .or. ieos==20) then call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) else @@ -2153,7 +2154,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) select case (iquantity) case(1) ! Energy - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) quant(i,1) = ekini + epoti + ethi case(2) ! Entropy @@ -2169,7 +2170,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) quant(i,1) = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,ierr=ierr) endif case(3) ! Bernoulli energy (per unit mass) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) quant(i,1) = 0.5*dot_product(vxyzu(1:3,i),vxyzu(1:3,i)) + ponrhoi + vxyzu(4,i) + epoti/particlemass ! 1/2 v^2 + P/rho + phi case(4) ! Ion fraction call ionisation_fraction(rhopart*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) @@ -2301,7 +2302,7 @@ subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) do i = 1,npart rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) vr(i) = dot_product(xyzh(1:3,i),vxyzu(1:3,i)) / sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) @@ -2609,7 +2610,7 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) if (.not. isdead_or_accreted(xyzh(4,i))) then rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) etoti = ekini + epoti + ethi @@ -2717,7 +2718,7 @@ subroutine unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) do i=1,npart rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) etoti = ekini + epoti + ethi @@ -2787,7 +2788,7 @@ subroutine unbound_temp(time,npart,particlemass,xyzh,vxyzu) do i=1,npart rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),eos_vars(itemp,i),vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) etoti = ekini + epoti + ethi @@ -2857,7 +2858,7 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) ! Calculate total energy rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) etoti = ekini + epoti + ethi @@ -3102,7 +3103,7 @@ subroutine bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) call compute_energies(time) do i=1,npart - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) rhopart = rhoh(xyzh(4,i), particlemass) @@ -3447,7 +3448,7 @@ subroutine J_E_plane(num,npart,particlemass,xyzh,vxyzu) call get_centreofmass(com_xyz,com_vxyz,npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) do i=1,npart - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,dum1,dum2,dum3,dum4,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,dum1,dum2,dum3,dum4,etoti) data(1,i) = etoti call cross_product3D(xyzh(1:3,i)-xyzmh_ptmass(1:3,1), vxyzu(1:3,i)-vxyz_ptmass(1:3,1), angmom_core) data(5:7,i) = angmom_core @@ -3996,7 +3997,8 @@ subroutine stellar_profile(time,ncols,particlemass,npart,xyzh,vxyzu,profile,simp kappa = 1. endif - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),& + xyzmh_ptmass,phii,epoti,ekini,einti,etoti) call ionisation_fraction(rhopart*unit_density,temp,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) From c24c077b1d317b680e7bda61a321496a4ed166ff Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 30 Apr 2024 13:46:08 +0200 Subject: [PATCH 502/814] (CE-analysis) get rid of gammas in calc_therm_energy --- src/utils/analysis_common_envelope.f90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index ff567ae41..7edc51774 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -704,7 +704,7 @@ subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) tempi = eos_vars(itemp,i) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call cross_product3D(xyzh(1:3,i), particlemass * vxyzu(1:3,i), rcrossmv) ! Angular momentum w.r.t. CoM - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi,radprop(:,i)) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi,radprop(:,i)) etoti = ekini + epoti + ethi ! Overwrite etoti outputted by calc_gas_energies to use ethi instead of einti else ! Output 0 for quantities pertaining to accreted particles @@ -1734,7 +1734,7 @@ subroutine track_particle(time,particlemass,xyzh,vxyzu) ! MESA ENTROPY ! Si = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi call ionisation_fraction(rhopart*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) @@ -1934,7 +1934,7 @@ subroutine recombination_tau(time,npart,particlemass,xyzh,vxyzu) kappa_part(i) = kappa ! In cgs units call ionisation_fraction(rho_part(i)*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) ! Calculate total energy - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rho_part(i),eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rho_part(i),eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi if ((xh0 > recomb_th) .and. (.not. prev_recombined(i)) .and. (etoti < 0.)) then ! Recombination event and particle is still bound j=j+1 @@ -2160,7 +2160,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) select case (iquantity) case(1) ! Energy call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) quant(i,1) = ekini + epoti + ethi case(2) ! Entropy if ((ieos==10) .and. (ientropy==2)) then @@ -2308,7 +2308,7 @@ subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) vr(i) = dot_product(xyzh(1:3,i),vxyzu(1:3,i)) / sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) if (ekini+epoti > 0.) then @@ -2616,7 +2616,7 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) etoti = ekini + epoti + ethi ! Ekin + Epot + Eth > 0 @@ -2724,7 +2724,7 @@ subroutine unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) etoti = ekini + epoti + ethi if ((etoti > 0.) .and. (.not. prev_unbound(i))) then @@ -2794,7 +2794,7 @@ subroutine unbound_temp(time,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),eos_vars(itemp,i),vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi if ((etoti > 0.) .and. (.not. prev_unbound(i))) then @@ -2864,7 +2864,7 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi call get_eos_pressure_temp_mesa(rhopart*unit_density,vxyzu(4,i)*unit_ergg,pressure,temperature) ! This should depend on ieos From f4449442d9ea3fe10364fcae98cb2ad0987a7047 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 1 May 2024 16:16:24 +0100 Subject: [PATCH 503/814] Fixing bugs in ModLom cooling --- src/main/cooling_stamatellos.f90 | 138 +++++++++++++------- src/main/dens.F90 | 2 +- src/main/eos_stamatellos.f90 | 17 ++- src/main/force.F90 | 47 ++++++- src/setup/density_profiles.f90 | 2 +- src/setup/libsetup.f90 | 2 +- src/setup/phantomsetup.F90 | 26 ++-- src/setup/readwrite_kepler.f90 | 2 +- src/setup/readwrite_mesa.f90 | 181 +++++++++++++++------------ src/setup/relax_star.f90 | 32 ++--- src/setup/set_Bfield.f90 | 2 +- src/setup/set_binary.f90 | 173 +++++++++++++++++-------- src/setup/set_cubic_core.f90 | 2 +- src/setup/set_disc.F90 | 6 +- src/setup/set_dust.f90 | 2 +- src/setup/set_dust_options.f90 | 2 +- src/setup/set_fixedentropycore.f90 | 2 +- src/setup/set_flyby.f90 | 4 +- src/setup/set_hierarchical.f90 | 34 +++-- src/setup/set_hierarchical_utils.f90 | 2 +- src/setup/set_planets.f90 | 2 +- src/setup/set_shock.f90 | 2 +- src/setup/set_slab.f90 | 2 +- src/setup/set_softened_core.f90 | 2 +- src/setup/set_sphere.f90 | 2 +- src/setup/set_star_utils.f90 | 15 ++- src/setup/set_unifdis.f90 | 2 +- src/setup/set_units.f90 | 2 +- src/setup/set_vfield.f90 | 2 +- src/setup/setup_BHL.f90 | 2 +- src/setup/setup_alfvenwave.f90 | 2 +- src/setup/setup_asteroidwind.f90 | 2 +- src/setup/setup_blob.f90 | 2 +- src/setup/setup_bondiinject.f90 | 2 +- src/setup/setup_chinchen.f90 | 2 +- src/setup/setup_cluster.f90 | 2 +- src/setup/setup_collidingclouds.f90 | 50 +++----- src/setup/setup_common.f90 | 2 +- src/setup/setup_disc.f90 | 6 +- src/setup/setup_dustsettle.f90 | 2 +- src/setup/setup_dustybox.f90 | 2 +- src/setup/setup_dustysedov.f90 | 2 +- src/setup/setup_empty.f90 | 2 +- src/setup/setup_firehose.f90 | 2 +- src/setup/setup_galaxies.f90 | 2 +- src/setup/setup_galcen_stars.f90 | 2 +- src/setup/setup_galdisc.f90 | 12 +- src/setup/setup_grdisc.F90 | 2 +- src/setup/setup_grtde.f90 | 2 +- src/setup/setup_gwdisc.f90 | 2 +- src/setup/setup_hierarchical.f90 | 2 +- src/setup/setup_jadvect.f90 | 2 +- src/setup/setup_kh.f90 | 2 +- src/setup/setup_mhdblast.f90 | 2 +- src/setup/setup_mhdrotor.f90 | 2 +- src/setup/setup_mhdsine.f90 | 2 +- src/setup/setup_mhdvortex.f90 | 2 +- src/setup/setup_mhdwave.f90 | 2 +- src/setup/setup_nsdisc.f90 | 4 +- src/setup/setup_orstang.f90 | 2 +- src/setup/setup_params.f90 | 2 +- src/setup/setup_planetdisc.f90 | 2 +- src/setup/setup_prtest.f90 | 28 ++--- src/setup/setup_quebec.f90 | 2 +- src/setup/setup_radiativebox.f90 | 2 +- src/setup/setup_sedov.f90 | 2 +- src/setup/setup_solarsystem.f90 | 2 +- src/setup/setup_sphereinbox.f90 | 4 +- src/setup/setup_srblast.f90 | 2 +- src/setup/setup_srpolytrope.f90 | 2 +- src/setup/setup_star.f90 | 2 +- src/setup/setup_taylorgreen.f90 | 2 +- src/setup/setup_testparticles.f90 | 24 ++-- src/setup/setup_tokamak.f90 | 2 +- src/setup/setup_torus.f90 | 2 +- src/setup/setup_turb.f90 | 2 +- src/setup/setup_unifdis.f90 | 35 ++++-- src/setup/setup_wave.f90 | 11 +- src/setup/setup_wavedamp.f90 | 48 ++++--- src/setup/setup_wddisc.f90 | 2 +- src/setup/stretchmap.f90 | 2 +- src/setup/velfield_fromcubes.f90 | 2 +- 82 files changed, 607 insertions(+), 410 deletions(-) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index 52705cc45..53988e395 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.bitbucket.io/ ! !--------------------------------------------------------------------------! module cooling_stamatellos ! @@ -20,9 +20,10 @@ module cooling_stamatellos ! implicit none - real, public :: Lstar ! in units of L_sun + real, public :: Lstar=0.0 ! 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 @@ -30,12 +31,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 - 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 (nptmass == 1) then isink_star = 1 @@ -50,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 ! @@ -58,32 +63,27 @@ 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 + 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 integer,intent(in) :: i real,intent(out) :: dudti_cool real :: coldensi,kappaBari,kappaParti,ri2 - real :: gmwi,Tmini4,Ti,dudt_rad,Teqi,du_tot - real :: tcool,ueqi,umini,tthermi,poti,presi,du_FLDi + real :: gmwi,Tmini4,Ti,dudt_rad,Teqi,Hstam,HLom,du_tot + real :: cs2,Om2,Hmod2 + real :: opac,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi poti = Gpot_cool(i) du_FLDi = duFLD(i) -! Tfloor is from input parameters and is background heating -! Stellar heating - if (isink_star > 0 .and. Lstar > 0.d0) then + 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 - ri2 = ri2 *udist*udist -! Tfloor + stellar heating - Tmini4 = Tfloor**4d0 + (Lstar*solarl/(16d0*pi*steboltz*ri2)) - else - Tmini4 = Tfloor**4d0 + + (yi-xyzmh_ptmass(2,isink_star))**2d0 & + + (zi-xyzmh_ptmass(3,isink_star))**2d0 endif ! get opacities & Ti for ui @@ -92,30 +92,67 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) presi = kb_on_mh*rhoi*unit_density*Ti/gmwi ! cgs presi = presi/unit_pressure !code units + 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) +! 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 - coldensi = coldensi * umass/udist/udist ! physical units +! 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) + !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 - dudt_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/tcool/unit_ergg*utime! code units +! 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 -! calculate Teqi + 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 @@ -123,36 +160,35 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) else Teqi = Teqi**(1.0/4.0) endif - + teqi_store(i) = Teqi 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 - - - !if (Ti > 6d0) print *, "eq temps:", Teqi,Ti ! calculate thermalization timescale and -! internal energy update -> put in form where it'll work as dudtcool +! internal energy update -> in form where it'll work as dudtcool if ((du_tot) == 0.d0) then tthermi = 0d0 else 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 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 *, "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 @@ -169,43 +205,51 @@ 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)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 - 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 > 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') 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 (od_method /= 1 .and. od_method /= 2) then - call warning('cooling_stamatellos','optical depth method unknown') - endif - 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 daece1767..60d90ed93 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 060633d6a..d97e0227a 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.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/ ! !--------------------------------------------------------------------------! @@ -22,12 +22,13 @@ module eos_stamatellos 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(:) character(len=25), public :: eos_file= 'myeos.dat' !default name of tabulated EOS file - logical,parameter,public :: doFLD = .True. + logical,public :: doFLD = .True., floor_energy = .False. integer,public :: iunitst=19 integer,save :: nx,ny ! dimensions of optable read in public :: read_optab,getopac_opdep,init_S07cool,getintenerg_opdep,finish_S07cool public :: get_k_fld + contains subroutine init_S07cool() @@ -38,9 +39,16 @@ subroutine init_S07cool() allocate(duFLD(npart)) allocate(lambda_fld(npart)) 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) 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() @@ -50,6 +58,9 @@ 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) + if (allocated(opac_store)) deallocate(opac_store) close(iunitst) end subroutine finish_S07cool diff --git a/src/main/force.F90 b/src/main/force.F90 index 3d7b3fc33..b542aafef 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -903,7 +903,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g use part, only:rhoh,dvdx use nicil, only:nimhd_get_jcbcb,nimhd_get_dBdt use eos, only:ieos,eos_is_non_ideal - use eos_stamatellos, only:gradP_cool,Gpot_cool + use eos_stamatellos, only:gradP_cool,Gpot_cool,duFLD,doFLD,getopac_opdep,get_k_fld #ifdef GRAVITY use kernel, only:kernel_softening use ptmass, only:ptmass_not_obscured @@ -928,6 +928,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g use metric_tools,only:imet_minkowski,imetric 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(:) @@ -1023,8 +1024,8 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g real :: bigv2j,alphagrj,enthi,enthj real :: dlorentzv,lorentzj,lorentzi_star,lorentzj_star,projbigvi,projbigvj real :: bigvj(1:3),velj(3),metricj(0:3,0:3,2),projbigvstari,projbigvstarj - real :: radPj,fgravxi,fgravyi,fgravzi - real :: gradpx,gradpy,gradpz,gradP_cooli,gradP_coolj + real :: radPj,fgravxi,fgravyi,fgravzi,kfldi,kfldj,Ti,Tj,diffterm,gmwi + real :: gradpx,gradpy,gradpz,gradP_cooli=0d0,gradP_coolj=0d0 ! unpack xi = xpartveci(ixi) @@ -1187,9 +1188,20 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g if (icooling == 9) then gradP_cool(i) = 0d0 Gpot_cool(i) = 0d0 + if (doFLD) then + duFLD(i) = 0d0 + kfldi = 0d0 + kfldj = 0d0 + endif gradpx = 0d0 gradpy = 0d0 gradpz = 0d0 + diffterm = 0d0 + Ti=0 + Tj=0 + if (doFLD .and. dt > 0d0) then + call get_k_fld(rhoi,eni,i,kfldi,Ti) + endif endif loop_over_neighbours2: do n = 1,nneigh @@ -1588,6 +1600,25 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g gradP_coolj = 0d0 if (usej) then gradp_coolj = pmassj*prj*rho1j*rho1j*grkernj + if (doFLD .and. dt > 0.) then + call get_k_fld(rhoj,enj,j,kfldj,Tj) + if (rhoj == 0d0) then + diffterm = 0d0 + print *, "setting diffterm = 0", i, j, rhoj + elseif ((kfldj + kfldi) == 0.) then + diffterm = 0d0 + else + diffterm = 4d0*pmassj/rhoi/rhoj + diffterm = diffterm * kfldi * kfldj / (kfldi+kfldj) + diffterm = diffterm * (Ti - Tj) / rij2 + diffterm = diffterm*cnormk*grkerni*(runix*dx + runiy*dy + runiz*dz) + endif + duFLD(i) = duFLD(i) + diffterm + if (isnan(duFLD(i))) then + print *, "kfldi, kfldj, Ti,Tj,diffterm", kfldi,kfldj, Ti,Tj,diffterm + call fatal('force','duFLD is nan') + endif + endif endif endif @@ -1717,6 +1748,10 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g fsum(idendtdissi) = fsum(idendtdissi) + dendissterm endif + if (icooling == 9) then + Gpot_cool(i) = Gpot_cool(i) + pmassj*phii + endif + !--add contribution to particle i's force if (mhd) then !--div B in symmetric form (for source term subtraction) @@ -2123,7 +2158,6 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, use timestep_ind, only:get_dt use nicil, only:nimhd_get_jcbcb use radiation_utils, only:get_rad_R - use eos_stamatellos, only:Gpot_cool type(cellforce), intent(inout) :: cell integer(kind=1), intent(in) :: iphase(:) real, intent(in) :: xyzh(:,:) @@ -2584,6 +2618,7 @@ 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 integer, intent(in) :: icall type(cellforce), intent(inout) :: cell real, intent(inout) :: fxyzu(:,:) @@ -2782,7 +2817,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv !--add self-contribution call kernel_softening(0.,0.,potensoft0,dum) epoti = 0.5*pmassi*(fsum(ipot) + pmassi*potensoft0*hi1) - if (icooling==9 .and. iamgasi) Gpot_cool(i) = Gpot_cool(i) + pmassi*potensoft0*hi1 + if ((icooling==9) .and. iamgasi) Gpot_cool(i) = Gpot_cool(i) + pmassi*potensoft0*hi1 ! !--add contribution from distant nodes, expand these in Taylor series about node centre ! use xcen directly, -1 is placeholder @@ -2792,7 +2827,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv fsum(ifxi) = fsum(ifxi) + fxi fsum(ifyi) = fsum(ifyi) + fyi fsum(ifzi) = fsum(ifzi) + fzi - if (icooling==9 .and. iamgasi) Gpot_cool(i) = Gpot_cool(i) + poti ! add contribution from distant nodes + if ((icooling==9) .and. iamgasi) Gpot_cool(i) = Gpot_cool(i) + poti ! add contribution from distant nodes if (gr .and. ien_type == ien_etotal) then fsum(idudtdissi) = fsum(idudtdissi) + vxi*fxi + vyi*fyi + vzi*fzi endif diff --git a/src/setup/density_profiles.f90 b/src/setup/density_profiles.f90 index f8506a172..b06e9b2f1 100644 --- a/src/setup/density_profiles.f90 +++ b/src/setup/density_profiles.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module rho_profile ! diff --git a/src/setup/libsetup.f90 b/src/setup/libsetup.f90 index 8089288f9..fc36e5e26 100644 --- a/src/setup/libsetup.f90 +++ b/src/setup/libsetup.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module libsetup ! diff --git a/src/setup/phantomsetup.F90 b/src/setup/phantomsetup.F90 index 6b27c6037..e24b9669a 100644 --- a/src/setup/phantomsetup.F90 +++ b/src/setup/phantomsetup.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantomsetup ! @@ -20,13 +20,13 @@ program phantomsetup ! setup_params, systemutils, timestep, units ! use memory, only:allocate_memory,deallocate_memory - use dim, only:tagline,maxp,maxvxyzu,mpi,& + use dim, only:tagline,maxvxyzu,mpi,& ndivcurlv,ndivcurlB,maxp_hard use part, only:xyzh,massoftype,hfact,vxyzu,npart,npartoftype, & - Bxyz,Bextx,Bexty,Bextz,rhoh,iphase,maxphase,& + Bxyz,Bextx,Bexty,Bextz,rhoh,& isetphase,igas,iamtype,labeltype,mhd,init_part use setBfield, only:set_Bfield - use eos, only:polyk,gamma,en_from_utherm + use eos, only:polyk,gamma use io, only:set_io_unit_numbers,id,master,nprocs,iwritein,fatal,warning use readwrite_dumps, only:init_readwrite_dumps,write_fulldump use readwrite_infile,only:write_infile,read_infile @@ -47,12 +47,11 @@ program phantomsetup use krome_interface, only:write_KromeSetupFile #endif implicit none - integer :: nargs,i,nprocsfake,nerr,nwarn,myid,myid1 + integer :: nargs,nprocsfake,nerr,nwarn,myid,myid1 integer(kind=8) :: ntotal,n_alloc integer, parameter :: lenprefix = 120 character(len=lenprefix) :: fileprefix character(len=lenprefix+10) :: dumpfile,infile,evfile,logfile - real :: pmassi logical :: iexist nprocs = 1 ! for MPI, this is not initialised until init_mpi, but an initialised value is required for init_part @@ -135,20 +134,9 @@ program phantomsetup !--perform sanity checks on the output of setpart routine ! call check_setup(nerr,nwarn) + if (nwarn > 0) call warning('initial','warnings during particle setup',var='warnings',ival=nwarn) if (nerr > 0) call fatal('initial','errors in particle setup',var='errors',ival=nerr) -! -!--setup defines thermal energy: if we are using the entropy then -! we need to convert this into the entropy variable before writing the dump file -! (the dump file write converts back to utherm) -! - if (maxvxyzu==4) then - pmassi = massoftype(igas) - do i=1,npart - if (maxphase==maxp) pmassi = massoftype(iamtype(iphase(i))) - vxyzu(maxvxyzu,i) = en_from_utherm(vxyzu(:,i),rhoh(xyzh(4,i),pmassi),gamma) - enddo - endif if (nprocsfake > 1) then ntotal = npart_total @@ -159,7 +147,7 @@ program phantomsetup ! if code is run in relativistic units (c=1) if (c_is_unity()) calc_gravitwaves = .true. - if (id==master) call print_units() + if (id==master .and. nerr==0 .and. nwarn==0) call print_units() ! !--dumpfile name should end in .tmp unless density has been calculated ! (never true using phantomsetup) diff --git a/src/setup/readwrite_kepler.f90 b/src/setup/readwrite_kepler.f90 index 89b04b013..21d138b8b 100644 --- a/src/setup/readwrite_kepler.f90 +++ b/src/setup/readwrite_kepler.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module readwrite_kepler ! diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index 372de7fc7..a053eb985 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module readwrite_mesa ! @@ -31,23 +31,22 @@ module readwrite_mesa !----------------------------------------------------------------------- subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar,ierr,cgsunits) use physcon, only:solarm,solarr - use fileutils, only:get_nlines,get_ncolumns,string_delete,lcase + use fileutils, only:get_nlines,get_ncolumns,string_delete,lcase,read_column_labels use datafiles, only:find_phantom_datafile use units, only:udist,umass,unit_density,unit_pressure,unit_ergg - integer :: lines,rows,i,ncols,nheaderlines,iu character(len=*), intent(in) :: filepath - logical, intent(in), optional :: cgsunits integer, intent(out) :: ierr - character(len=10000) :: dumc + real, intent(in) :: X_in,Z_in + real, allocatable,dimension(:),intent(out) :: rho,r,pres,m,ene,temp,Xfrac,Yfrac + real, intent(out) :: Mstar + logical, intent(in), optional :: cgsunits + integer :: lines,i,ncols,nheaderlines,nlabels + integer :: idir,iu character(len=120) :: fullfilepath - character(len=24),allocatable :: header(:),dum(:) + character(len=24),allocatable :: header(:) logical :: iexist,usecgs,ismesafile,got_column real,allocatable,dimension(:,:) :: dat - real, intent(in) :: X_in,Z_in - real,allocatable,dimension(:),intent(out) :: rho,r,pres,m,ene,temp,Xfrac,Yfrac - real, intent(out) :: Mstar - rows = 0 usecgs = .false. if (present(cgsunits)) usecgs = cgsunits ! @@ -63,93 +62,119 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, lines = get_nlines(fullfilepath) ! total number of lines in file print "(1x,a)",trim(fullfilepath) - open(newunit=iu,file=fullfilepath,status='old') + open(newunit=iu,file=fullfilepath,status='old',iostat=ierr) + if (ierr /= 0) then + print "(a,/)",' ERROR opening file '//trim(fullfilepath) + return + endif + call get_ncolumns(iu,ncols,nheaderlines) if (nheaderlines == 6) then ! Assume file is a MESA profile, and so it has 6 header lines, and (row=3, col=2) = number of zones - read(iu,'()') - read(iu,'()') - read(iu,*) lines,lines - read(iu,'()') - read(iu,'()') + read(iu,'()',iostat=ierr) + read(iu,'()',iostat=ierr) + read(iu,*,iostat=ierr) lines,lines + read(iu,'()',iostat=ierr) + read(iu,'()',iostat=ierr) + if (ierr /= 0) then + print "(a,/)",' ERROR reading MESA file header' + return + endif ismesafile = .true. else ismesafile = .false. lines = lines - nheaderlines do i = 1,nheaderlines-1 - read(iu,'()') + read(iu,'()',iostat=ierr) enddo + if (ierr /= 0) then + print "(a,/)",' ERROR reading file header [not MESA format]' + return + endif endif if (lines <= 0) then ! file not found ierr = 1 return endif - read(iu,'(a)') dumc! counting rows - call string_delete(dumc,'[') - call string_delete(dumc,']') - allocate(dum(500)) ; dum = 'aaa' - read(dumc,*,end=101) dum -101 continue - do i = 1,500 - if (dum(i)=='aaa') then - rows = i-1 - exit - endif - enddo - allocate(header(rows),dat(lines,rows)) - header(1:rows) = dum(1:rows) - deallocate(dum) - do i = 1,lines - read(iu,*) dat(lines-i+1,1:rows) - enddo + ! extract column labels from the file header + allocate(header(ncols),dat(lines,ncols)) + 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)) + temp(lines),Xfrac(lines),Yfrac(lines)) - close(iu) - ! Set mass fractions to fixed inputs if not in file - Xfrac = X_in - Yfrac = 1. - X_in - Z_in - do i = 1,rows - if (header(i)(1:1) == '#' .and. .not. trim(lcase(header(i)))=='#mass') then - print '("Detected wrong header entry : ",A," in file ",A)',trim(lcase(header(i))),trim(fullfilepath) - ierr = 2 + over_directions: do idir=1,2 ! try backwards, then forwards + if (idir==1) then + ! read MESA file backwards, from surface to centre + do i = 1,lines + read(iu,*,iostat=ierr) dat(lines-i+1,1:ncols) + enddo + else + ! read file forwards, from centre to surface + do i = 1,lines + read(iu,*,iostat=ierr) dat(i,1:ncols) + enddo + endif + if (ierr /= 0) then + print "(a,/)",' ERROR reading data from file: reached end of file?' return endif - got_column = .true. - select case(trim(lcase(header(i)))) - case('mass_grams') - m = dat(1:lines,i) - case('mass','#mass') - m = dat(1:lines,i) - if (ismesafile) m = m * solarm ! If reading MESA profile, 'mass' is in units of Msun - case('rho','density') - rho = dat(1:lines,i) - case('logrho') - rho = 10**(dat(1:lines,i)) - case('energy','e_int','e_internal') - ene = dat(1:lines,i) - case('radius_cm') - r = dat(1:lines,i) - case('radius') - r = dat(1:lines,i) - if (ismesafile) r = r * solarr - case('logr') - r = (10**dat(1:lines,i)) * solarr - case('pressure') - pres = dat(1:lines,i) - case('temperature') - temp = dat(1:lines,i) - case('x_mass_fraction_h','xfrac') - Xfrac = dat(1:lines,i) - case('y_mass_fraction_he','yfrac') - Yfrac = dat(1:lines,i) - case default - got_column = .false. - end select - if (got_column) print "(1x,i0,': ',a)",i,trim(header(i)) - enddo - print "(a)" + + ! Set mass fractions to fixed inputs if not in file + Xfrac = X_in + Yfrac = 1. - X_in - Z_in + do i = 1,ncols + if (header(i)(1:1) == '#' .and. .not. trim(lcase(header(i)))=='#mass') then + print '("Detected wrong header entry : ",a," in file ",a)',trim(lcase(header(i))),trim(fullfilepath) + ierr = 2 + return + endif + got_column = .true. + select case(trim(lcase(header(i)))) + case('mass_grams') + m = dat(1:lines,i) + 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('rho','density') + rho = dat(1:lines,i) + case('logrho') + rho = 10**(dat(1:lines,i)) + case('energy','e_int','e_internal') + ene = dat(1:lines,i) + case('radius_cm') + r = dat(1:lines,i) + case('radius','r') + r = dat(1:lines,i) + if (ismesafile .or. maxval(r) < 1e-10*solarr) r = r * solarr + case('logr') + r = (10**dat(1:lines,i)) * solarr + case('pressure','p') + pres = dat(1:lines,i) + case('temperature','t') + temp = dat(1:lines,i) + case('x_mass_fraction_h','xfrac') + Xfrac = dat(1:lines,i) + case('y_mass_fraction_he','yfrac') + Yfrac = dat(1:lines,i) + case default + got_column = .false. + end select + if (got_column .and. idir==1) print "(1x,i0,': ',a)",i,trim(header(i)) + enddo + if (idir==1) print "(a)" + + ! quit the loop over directions if the radius increases + if (idir==1 .and. r(2) > r(1)) exit over_directions + + ! otherwise rewind and re-skip header + rewind(iu) + do i=1,nheaderlines + read(iu,*,iostat=ierr) + enddo + enddo over_directions + close(iu) if (.not. usecgs) then m = m / umass diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index 62b062c93..a4bb589ec 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module relaxstar ! @@ -15,7 +15,6 @@ module relaxstar ! ! :Runtime parameters: ! - maxits : *maximum number of relaxation iterations* -! - tol_dens : *% error in density to stop relaxation* ! - tol_ekin : *tolerance on ekin/epot to stop relaxation* ! ! :Dependencies: checksetup, damping, deriv, dim, dump_utils, energies, @@ -27,7 +26,6 @@ module relaxstar public :: relax_star,write_options_relax,read_options_relax real, private :: tol_ekin = 1.e-7 ! criteria for being converged - real, private :: tol_dens = 1. ! allow 1% RMS error in density integer, private :: maxits = 1000 real, private :: gammaprev,hfactprev,mass1prev @@ -177,9 +175,9 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np ierr = ierr_unbound return endif - if (id==master) print "(/,3(a,1pg11.3),/,a,0pf6.2,a,es11.3,a,i4)",& + 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), & - ' WILL stop WHEN: dens error < ',tol_dens,'% AND Ekin/Epot < ',tol_ekin,' OR Iter=',maxits + ' WILL stop when Ekin/Epot < ',tol_ekin,' OR Iter=',maxits if (write_files) then if (.not.restart) call write_fulldump(t,filename) @@ -215,18 +213,22 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np ! compute energies and check for convergence ! call compute_energies(t) - converged = (ekin > 0. .and. ekin/abs(epot) < tol_ekin .and. rmserr < 0.01*tol_dens) + converged = (ekin > 0. .and. ekin/abs(epot) < tol_ekin) !.and. rmserr < 0.01*tol_dens) ! ! print information to screen ! if (use_step) then - if (id==master) print "(a,es10.3,a,2pf6.2,2(a,1pg11.3))",& - ' Relaxing star: t/dyn:',t/tdyn,', dens error:',rmserr,'%, R*:',rmax, & - ' Ekin/Epot:',ekin/abs(epot) + if (id==master .and. mod(nits,10)==0 .or. nits==1) then + print "(a,es10.3,a,2pf6.2,2(a,1pg11.3))",& + ' Relaxing star: t/dyn:',t/tdyn,', dens error:',rmserr,'%, R*:',rmax, & + ' Ekin/Epot:',ekin/abs(epot) + endif else - if (id==master) print "(a,i4,a,i4,a,2pf6.2,2(a,1pg11.3))",& - ' Relaxing star: Iter',nits,'/',maxits, & - ', dens error:',rmserr,'%, R*:',rmax,' Ekin/Epot:',ekin/abs(epot) + if (id==master .and. mod(nits,10)==0 .or. nits==1) then + print "(a,i4,a,i4,a,2pf6.2,2(a,1pg11.3))",& + ' Relaxing star: Iter',nits,'/',maxits, & + ', dens error:',rmserr,'%, R*:',rmax,' Ekin/Epot:',ekin/abs(epot) + endif endif ! ! additional diagnostic output, mainly for debugging/checking @@ -439,7 +441,7 @@ subroutine check_for_existing_file(filename,npart,mgas,xyzh,vxyzu,restart,ierr) real, intent(inout) :: xyzh(:,:),vxyzu(:,:) logical, intent(out) :: restart integer, intent(out) :: ierr - logical :: iexist,tagged + logical :: iexist character(len=len(filename)) :: restart_file,filetmp character(len=lenid) :: fileid type(dump_h) :: hdr @@ -464,7 +466,7 @@ subroutine check_for_existing_file(filename,npart,mgas,xyzh,vxyzu,restart,ierr) print "(/,1x,a)",'>> RESTARTING relaxation from '//trim(restart_file) call open_dumpfile_r(idump,restart_file,fileid,ierr) - call read_header(idump,hdr,tagged,ierr) + call read_header(idump,hdr,ierr) close(idump) if (ierr /= 0) then print "(a)",' ERROR: could not read file header' @@ -545,7 +547,6 @@ subroutine write_options_relax(iunit) integer, intent(in) :: iunit call write_inopt(tol_ekin,'tol_ekin','tolerance on ekin/epot to stop relaxation',iunit) - call write_inopt(tol_dens,'tol_dens','% error in density to stop relaxation',iunit) call write_inopt(maxits,'maxits','maximum number of relaxation iterations',iunit) end subroutine write_options_relax @@ -561,7 +562,6 @@ subroutine read_options_relax(db,nerr) integer, intent(inout) :: nerr call read_inopt(tol_ekin,'tol_ekin',db,errcount=nerr) - call read_inopt(tol_dens,'tol_dens',db,errcount=nerr) call read_inopt(maxits,'maxits',db,errcount=nerr) end subroutine read_options_relax diff --git a/src/setup/set_Bfield.f90 b/src/setup/set_Bfield.f90 index 08dfe4093..489904342 100644 --- a/src/setup/set_Bfield.f90 +++ b/src/setup/set_Bfield.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setBfield ! diff --git a/src/setup/set_binary.f90 b/src/setup/set_binary.f90 index 2120c228c..e1208a837 100644 --- a/src/setup/set_binary.f90 +++ b/src/setup/set_binary.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setbinary ! @@ -47,16 +47,31 @@ module setbinary contains -!---------------------------------------------------------------- +!------------------------------------------------------------------------------ !+ -! setup for a binary +! setup for a binary orbit +! +! INPUT: +! m1 - mass of object 1 +! m2 - mass of object 2 +! semimajoraxis - semimajor axis (e/=1) or pericentre distance (e=1) +! eccentricity - eccentricity +! accretion_radius1 - accretion radius for point mass 1 +! accretion_radius2 - accretion radius for point mass 2 +! [optional] posang_ascnode - position angle of the ascending node (Omega, deg) +! [optional] arg_peri - argument of periapsis (w, deg) +! [optional] incl - orbital inclination (i, deg) +! [optional] f - true anomaly (nu, deg) +! [optional] mean_anomaly - mean anomaly (M, deg; replaces true anomaly) +! +! OUTPUT: cartesian positions and velocities for both objects !+ -!---------------------------------------------------------------- +!------------------------------------------------------------------------------ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & accretion_radius1,accretion_radius2, & xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,omega_corotate,& posang_ascnode,arg_peri,incl,f,mean_anomaly,verbose) - use binaryutils, only:get_E,get_E_from_mean_anomaly + use binaryutils, only:get_E,get_E_from_mean_anomaly,get_E_from_true_anomaly real, intent(in) :: m1,m2 real, intent(in) :: semimajoraxis,eccentricity real, intent(in) :: accretion_radius1,accretion_radius2 @@ -67,10 +82,12 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & real, intent(out), optional :: omega_corotate logical, intent(in), optional :: verbose integer :: i1,i2,i - real :: mtot,dx(3),dv(3),Rochelobe1,Rochelobe2,period,bigM + real :: mtot,dx(3),dv(3),Rochelobe1,Rochelobe2,period,bigM,rperi,rapo real :: x1(3),x2(3),v1(3),v2(3),omega0,cosi,sini,xangle,reducedmass,angmbin - real :: a,E,E_dot,P(3),Q(3),omega,big_omega,inc,ecc,tperi,term1,term2,theta + real :: a,E,E_dot,P(3),Q(3),omega,big_omega,inc,ecc,tperi + real :: term1,term2,term3,term4,theta,theta_max,energy logical :: do_verbose + character(len=12) :: orbit_type ierr = 0 do_verbose = .true. @@ -82,12 +99,67 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & ! masses mtot = m1 + m2 - - Rochelobe1 = Rochelobe_estimate(m2,m1,semimajoraxis) - Rochelobe2 = Rochelobe_estimate(m1,m2,semimajoraxis) - period = sqrt(4.*pi**2*semimajoraxis**3/mtot) reducedmass = m1*m2/mtot - angmbin = reducedmass*sqrt(mtot*semimajoraxis*(1. - eccentricity**2)) + + ! check for stupid parameter choices + if (m1 <= 0.) then + print "(1x,a)",'ERROR: set_binary: primary mass <= 0' + ierr = ierr_m1 + endif + if (m2 < 0.) then + print "(1x,a)",'ERROR: set_binary: secondary mass < 0' + ierr = ierr_m2 + endif + if (abs(semimajoraxis) <= tiny(0.)) then + print "(1x,a)",'ERROR: set_binary: semi-major axis = 0' + ierr = ierr_semi + endif + if (semimajoraxis < 0. .and. eccentricity <= 1.) then + print "(1x,a)",'ERROR: set_binary: using a < 0 requires e > 1' + ierr = ierr_semi + endif + if (eccentricity < 0.) then + print "(1x,a)",'ERROR: set_binary: eccentricity must be positive' + ierr = ierr_ecc + endif + if (eccentricity > 1. .and. present(f)) then + theta = f*pi/180. + theta_max = acos(-1./eccentricity) + if (abs(theta) > theta_max) then + print "(1x,2(a,f8.2))",'ERROR: max true anomaly for e = ',eccentricity, & + ' is |nu| < ',theta_max*180./pi + ierr = ierr_ecc + endif + endif + ! exit routine if cannot continue + if (ierr /= 0) return + + ! set parameters that depend on the orbit type + if (eccentricity < 1.) then + a = abs(semimajoraxis) + rperi = a*(1. - eccentricity) + rapo = semimajoraxis*(1. + eccentricity) + period = sqrt(4.*pi**2*a**3/mtot) + angmbin = reducedmass*sqrt(mtot*a*(1. - eccentricity**2)) + energy = -mtot/(2.*a) + elseif (eccentricity > 1.) then + a = -abs(semimajoraxis) + rperi = a*(1. - eccentricity) + rapo = huge(rapo) + period = huge(period) + angmbin = reducedmass*sqrt(mtot*a*(1. - eccentricity**2)) + energy = -mtot/(2.*a) + else + a = huge(a) + rperi = abs(semimajoraxis) ! for parabolic orbit we must give the pericentre distance + rapo = huge(rapo) + period = huge(period) + angmbin = reducedmass*sqrt(2.*mtot*rperi) + energy = 0. + endif + + Rochelobe1 = Rochelobe_estimate(m2,m1,rperi) + Rochelobe2 = Rochelobe_estimate(m1,m2,rperi) if (do_verbose) then print "(/,2x,a)",'---------- binary parameters ----------- ' @@ -96,45 +168,23 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & 'secondary mass :',m2, & 'mass ratio m2/m1 :',m2/m1, & 'reduced mass :',reducedmass, & - 'semi-major axis :',semimajoraxis, & + 'semi-major axis :',a, & 'period :',period, & 'eccentricity :',eccentricity, & - 'pericentre :',semimajoraxis*(1. - eccentricity), & - 'apocentre :',semimajoraxis*(1. + eccentricity) + 'pericentre :',rperi, & + 'apocentre :',rapo endif if (accretion_radius1 > Rochelobe1) then - print "(1x,a)",'WARNING: set_binary: accretion radius of primary > Roche lobe' + print "(1x,a)",'WARNING: set_binary: accretion radius of primary > Roche lobe at periastron' endif if (accretion_radius2 > Rochelobe2) then - print "(1x,a)",'WARNING: set_binary: accretion radius of secondary > Roche lobe' - endif -! -!--check for stupid parameter choices -! - if (m1 <= 0.) then - print "(1x,a)",'ERROR: set_binary: primary mass <= 0' - ierr = ierr_m1 + print "(1x,a)",'WARNING: set_binary: accretion radius of secondary > Roche lobe at periastron' endif - if (m2 < 0.) then - print "(1x,a)",'ERROR: set_binary: secondary mass <= 0' - ierr = ierr_m2 - endif - if (semimajoraxis <= 0.) then - print "(1x,a)",'ERROR: set_binary: semi-major axis <= 0' - ierr = ierr_semi - endif - if (eccentricity > 1. .or. eccentricity < 0.) then - print "(1x,a)",'ERROR: set_binary: eccentricity must be between 0 and 1' - ierr = ierr_ecc - endif - ! exit routine if cannot continue - if (ierr /= 0) return dx = 0. dv = 0. if (present(posang_ascnode) .and. present(arg_peri) .and. present(incl)) then ! Campbell elements - a = semimajoraxis ecc = eccentricity omega = arg_peri*pi/180. ! our conventions here are Omega is measured East of North @@ -142,10 +192,10 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & inc = incl*pi/180. if (present(f)) then - ! get eccentric anomaly from true anomaly + ! get eccentric, parabolic or hyperbolic anomaly from true anomaly ! (https://en.wikipedia.org/wiki/Eccentric_anomaly#From_the_true_anomaly) theta = f*pi/180. - E = atan2(sqrt(1. - ecc**2)*sin(theta),(ecc + cos(theta))) + E = get_E_from_true_anomaly(theta,ecc) elseif (present(mean_anomaly)) then ! get eccentric anomaly from mean anomaly by solving Kepler equation bigM = mean_anomaly*pi/180. @@ -166,17 +216,36 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & Q(2) = -sin(omega)*sin(big_omega) + cos(omega)*cos(inc)*cos(big_omega) Q(3) = sin(inc)*cos(omega) - term1 = cos(E)-eccentricity - term2 = sqrt(1.-(eccentricity*eccentricity))*sin(E) - E_dot = sqrt((m1 + m2)/(a**3))/(1.-eccentricity*cos(E)) + if (eccentricity < 1.) then ! eccentric + orbit_type = 'Eccentric' + term1 = a*(cos(E)-ecc) + term2 = a*(sqrt(1. - ecc*ecc)*sin(E)) + E_dot = sqrt((m1 + m2)/(a**3))/(1.-ecc*cos(E)) + term3 = a*(-sin(E)*E_dot) + term4 = a*(sqrt(1.- ecc*ecc)*cos(E)*E_dot) + elseif (eccentricity > 1.) then ! hyperbolic + orbit_type = 'Hyperbolic' + term1 = a*(cosh(E)-ecc) + term2 = -a*(sqrt(ecc*ecc - 1.)*sinh(E)) + E_dot = sqrt((m1 + m2)/(abs(a)**3))/(ecc*cosh(E)-1.) + term3 = a*(sinh(E)*E_dot) + term4 = -a*(sqrt(ecc*ecc - 1.)*cosh(E)*E_dot) + else ! parabolic + orbit_type = 'Parabolic' + term1 = rperi*(1. - E*E) + term2 = rperi*(2.*E) + E_dot = sqrt(2.*(m1 + m2)/(rperi**3))/(1. + E*E) + term3 = -E*(rperi*E_dot) + term4 = rperi*E_dot + endif if (do_verbose) then print "(4(2x,a,1pg14.6,/),2x,a,1pg14.6)", & - 'Eccentric anomaly:',E, & + trim(orbit_type)//' anomaly:',E, & 'E_dot :',E_dot, & 'inclination (i, deg):',incl, & 'angle asc. node (O, deg):',posang_ascnode, & - 'arg. pericentre (w, deg):',arg_peri + 'arg. periapsis (w, deg):',arg_peri if (present(f)) print "(2x,a,1pg14.6)", & 'true anomaly (f, deg):',f if (present(mean_anomaly)) print "(2x,a,1pg14.6)", & @@ -185,10 +254,10 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & ! Rotating everything ! Set the positions for the primary and the central secondary - dx(:) = a*(term1*P(:) + term2*Q(:)) ! + xyzmh_ptmass(1,1) + dx(:) = term1*P(:) + term2*Q(:) ! Set the velocities - dv(:) = -a*sin(E)*E_dot*P(:) + a*sqrt(1.-(ecc*ecc))*cos(E)*E_dot*Q(:) + dv(:) = term3*P(:) + term4*Q(:) else ! set binary at apastron @@ -201,14 +270,16 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & x2 = dx*m1/mtot ! velocities - v1 = -dv*m2/mtot !(/0.,-m2/mtot*vmag,0./) - v2 = dv*m1/mtot !(/0.,m1/mtot*vmag,0./) + v1 = -dv*m2/mtot + v2 = dv*m1/mtot omega0 = v2(2)/x2(1) ! print info about positions and velocities if (do_verbose) then - print "(7(2x,a,1pg14.6,/),2x,a,1pg14.6)", & + print "(9(2x,a,1pg14.6,/),2x,a,1pg14.6)", & + 'energy (mtot/2a) :',energy,& + 'energy (KE+PE) :',-mtot/sqrt(dot_product(dx,dx)) + 0.5*dot_product(dv,dv),& 'angular momentum :',angmbin, & 'mean ang. speed :',omega0, & 'Omega_0 (prim) :',v2(2)/x2(1), & diff --git a/src/setup/set_cubic_core.f90 b/src/setup/set_cubic_core.f90 index e5687e455..0daa194be 100644 --- a/src/setup/set_cubic_core.f90 +++ b/src/setup/set_cubic_core.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setcubiccore ! diff --git a/src/setup/set_disc.F90 b/src/setup/set_disc.F90 index 2234d3692..505713346 100644 --- a/src/setup/set_disc.F90 +++ b/src/setup/set_disc.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setdisc ! @@ -74,8 +74,8 @@ subroutine set_disc(id,master,mixture,nparttot,npart,npart_start,rmin,rmax, & particle_type,particle_mass,hfact,xyzh,vxyzu,polyk, & position_angle,inclination,ismooth,alpha,rwarp,warp_smoothl, & bh_spin,bh_spin_angle,rref,enc_mass,r_grid,writefile,ierr,prefix,verbose) - use io, only:stdout - use part, only:maxp,idust,maxtypes + use io, only:stdout + use part, only:maxp,idust,maxtypes use centreofmass, only:get_total_angular_momentum integer, intent(in) :: id,master integer, optional, intent(in) :: nparttot diff --git a/src/setup/set_dust.f90 b/src/setup/set_dust.f90 index f8b2088d4..346b1ae8b 100644 --- a/src/setup/set_dust.f90 +++ b/src/setup/set_dust.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module set_dust ! diff --git a/src/setup/set_dust_options.f90 b/src/setup/set_dust_options.f90 index 94fca2f77..c97bbf0ca 100644 --- a/src/setup/set_dust_options.f90 +++ b/src/setup/set_dust_options.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module set_dust_options ! diff --git a/src/setup/set_fixedentropycore.f90 b/src/setup/set_fixedentropycore.f90 index dba3393f7..5466782fd 100644 --- a/src/setup/set_fixedentropycore.f90 +++ b/src/setup/set_fixedentropycore.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setfixedentropycore ! diff --git a/src/setup/set_flyby.f90 b/src/setup/set_flyby.f90 index cd69fa817..783ae37a9 100644 --- a/src/setup/set_flyby.f90 +++ b/src/setup/set_flyby.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setflyby ! @@ -191,7 +191,7 @@ function get_T_flyby(m1,m2,dma,n0) result(T) xi = -2*sqrt(n0-1.0)*dma yi = dma*(1.0-(xi/p)**2) - !--graviational parameter + !--gravitational parameter G = 1.0 ! we assume code units where G=1 mu = G*(m1+m2) diff --git a/src/setup/set_hierarchical.f90 b/src/setup/set_hierarchical.f90 index 32a01cc64..22dad2a68 100644 --- a/src/setup/set_hierarchical.f90 +++ b/src/setup/set_hierarchical.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module sethierarchical ! @@ -19,7 +19,8 @@ module sethierarchical ! ! :Owner: Simone Ceppi ! -! :Runtime parameters: None +! :Runtime parameters: +! - hierarchy : *string definining the hierarchy (e.g. 111,112,121,1221,1222)* ! ! :Dependencies: infile_utils, setbinary, sethier_utils ! @@ -110,24 +111,35 @@ subroutine write_hierarchical_setupfile(iunit) integer :: i write(iunit,"(/,a)") '# options for hierarchical system' - call write_inopt(hierarchy, 'hierarchy','', iunit) + call write_inopt(hierarchy, 'hierarchy','string definining the hierarchy (e.g. 111,112,121,1221,1222)', iunit) hs%labels = process_hierarchy(hierarchy) write(iunit,"(/,a)") '# sink properties' do i=1,hs%labels%sink_num - call write_inopt(hs%sinks(i)%mass, trim(hs%labels%sink(i))//'_mass','', iunit) - call write_inopt(hs%sinks(i)%accr, trim(hs%labels%sink(i))//'_accr','', iunit) + call write_inopt(hs%sinks(i)%mass, trim(hs%labels%sink(i))//'_mass',& + 'mass of object '//trim(hs%labels%sink(i)), iunit) + enddo + do i=1,hs%labels%sink_num + call write_inopt(hs%sinks(i)%accr, trim(hs%labels%sink(i))//'_accr',& + 'accretion radius for object '//trim(hs%labels%sink(i)), iunit) enddo write(iunit,"(/,a)") '# orbit properties' do i=1,hs%labels%hl_num - call write_inopt(hs%levels(i)%a, trim(hs%labels%hl(i))//'_a','',iunit) - call write_inopt(hs%levels(i)%e, trim(hs%labels%hl(i))//'_e','',iunit) - call write_inopt(hs%levels(i)%inc, trim(hs%labels%hl(i))//'_i','',iunit) - call write_inopt(hs%levels(i)%O, trim(hs%labels%hl(i))//'_O','',iunit) - call write_inopt(hs%levels(i)%w, trim(hs%labels%hl(i))//'_w','',iunit) - call write_inopt(hs%levels(i)%f, trim(hs%labels%hl(i))//'_f','',iunit) + write(iunit,"(a)") '# binary '//trim(hs%labels%hl(i)) + call write_inopt(hs%levels(i)%a, trim(hs%labels%hl(i))//'_a',& + 'semi-major axis for binary '//trim(hs%labels%hl(i)),iunit) + call write_inopt(hs%levels(i)%e, trim(hs%labels%hl(i))//'_e',& + 'eccentricity for binary '//trim(hs%labels%hl(i)),iunit) + call write_inopt(hs%levels(i)%inc, trim(hs%labels%hl(i))//'_i',& + 'i [deg] inclination for binary '//trim(hs%labels%hl(i)),iunit) + call write_inopt(hs%levels(i)%O, trim(hs%labels%hl(i))//'_O',& + 'Omega [deg] PA of ascending node for binary '//trim(hs%labels%hl(i)),iunit) + call write_inopt(hs%levels(i)%w, trim(hs%labels%hl(i))//'_w',& + 'w [deg] argument of periapsis for binary '//trim(hs%labels%hl(i)),iunit) + call write_inopt(hs%levels(i)%f, trim(hs%labels%hl(i))//'_f',& + 'f [deg] true anomaly for binary '//trim(hs%labels%hl(i)),iunit) enddo end subroutine write_hierarchical_setupfile diff --git a/src/setup/set_hierarchical_utils.f90 b/src/setup/set_hierarchical_utils.f90 index 875744c4a..50aa1866e 100644 --- a/src/setup/set_hierarchical_utils.f90 +++ b/src/setup/set_hierarchical_utils.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module sethier_utils ! diff --git a/src/setup/set_planets.f90 b/src/setup/set_planets.f90 index d1486e074..8abcb545c 100644 --- a/src/setup/set_planets.f90 +++ b/src/setup/set_planets.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setplanets ! diff --git a/src/setup/set_shock.f90 b/src/setup/set_shock.f90 index 1c17bbb52..e0623f797 100644 --- a/src/setup/set_shock.f90 +++ b/src/setup/set_shock.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setshock ! diff --git a/src/setup/set_slab.f90 b/src/setup/set_slab.f90 index 8601631cc..61c00f7ce 100644 --- a/src/setup/set_slab.f90 +++ b/src/setup/set_slab.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module slab ! diff --git a/src/setup/set_softened_core.f90 b/src/setup/set_softened_core.f90 index 93f2f83aa..a7d546658 100644 --- a/src/setup/set_softened_core.f90 +++ b/src/setup/set_softened_core.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setsoftenedcore ! diff --git a/src/setup/set_sphere.f90 b/src/setup/set_sphere.f90 index 23ffd0297..e3358f9fd 100644 --- a/src/setup/set_sphere.f90 +++ b/src/setup/set_sphere.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module spherical ! diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index de23febf0..73a5d7017 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setstar_utils ! @@ -304,11 +304,13 @@ end subroutine set_star_density ! Add a sink particle as a stellar core !+ !----------------------------------------------------------------------- -subroutine set_stellar_core(nptmass,xyzmh_ptmass,vxyz_ptmass,ihsoft,mcore,hsoft,ierr) +subroutine set_stellar_core(nptmass,xyzmh_ptmass,vxyz_ptmass,ihsoft,mcore,& + hsoft,ilum,lcore,ierr) integer, intent(out) :: nptmass,ierr real, intent(out) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - real, intent(in) :: mcore,hsoft - integer :: n,ihsoft + real, intent(in) :: mcore,hsoft,lcore + integer, intent(in) :: ihsoft,ilum + integer :: n ierr = 0 ! Check for sensible values @@ -320,12 +322,17 @@ subroutine set_stellar_core(nptmass,xyzmh_ptmass,vxyz_ptmass,ihsoft,mcore,hsoft, ierr = 2 return endif + if (lcore < 0.) then + ierr = 3 + return + endif nptmass = 1 n = nptmass xyzmh_ptmass(:,n) = 0. ! zero all quantities by default xyzmh_ptmass(4,n) = mcore xyzmh_ptmass(ihsoft,n) = hsoft + xyzmh_ptmass(ilum,n) = lcore vxyz_ptmass(:,n) = 0. end subroutine set_stellar_core diff --git a/src/setup/set_unifdis.f90 b/src/setup/set_unifdis.f90 index c7ff9e663..b4dece1de 100644 --- a/src/setup/set_unifdis.f90 +++ b/src/setup/set_unifdis.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module unifdis ! diff --git a/src/setup/set_units.f90 b/src/setup/set_units.f90 index 41f600e51..5c6de9e7e 100644 --- a/src/setup/set_units.f90 +++ b/src/setup/set_units.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setunits ! diff --git a/src/setup/set_vfield.f90 b/src/setup/set_vfield.f90 index 17e56305c..68d2d03e3 100644 --- a/src/setup/set_vfield.f90 +++ b/src/setup/set_vfield.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setvfield ! diff --git a/src/setup/setup_BHL.f90 b/src/setup/setup_BHL.f90 index b8c4b0aff..560081f1b 100644 --- a/src/setup/setup_BHL.f90 +++ b/src/setup/setup_BHL.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_alfvenwave.f90 b/src/setup/setup_alfvenwave.f90 index e53eaf40f..8bc9e10f9 100644 --- a/src/setup/setup_alfvenwave.f90 +++ b/src/setup/setup_alfvenwave.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index e8445fdcd..8ccc75fb8 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_blob.f90 b/src/setup/setup_blob.f90 index 7e52dcc6e..d569cfb5b 100644 --- a/src/setup/setup_blob.f90 +++ b/src/setup/setup_blob.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_bondiinject.f90 b/src/setup/setup_bondiinject.f90 index 7089b359c..cd39849b1 100644 --- a/src/setup/setup_bondiinject.f90 +++ b/src/setup/setup_bondiinject.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_chinchen.f90 b/src/setup/setup_chinchen.f90 index e5cd24024..708700567 100644 --- a/src/setup/setup_chinchen.f90 +++ b/src/setup/setup_chinchen.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index ea18bc5c3..cd3e60944 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_collidingclouds.f90 b/src/setup/setup_collidingclouds.f90 index 03ded6bea..ff9553b42 100644 --- a/src/setup/setup_collidingclouds.f90 +++ b/src/setup/setup_collidingclouds.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! @@ -50,7 +50,6 @@ module setup real :: cs_cloud(Ncloud_max) real :: rms_mach(Ncloud_max),density_contrast,T_bkg,plasmaB,Bzero,angB(3) real :: r_crit_setup,h_acc_setup,h_soft_sinksink_setup,rho_crit_cgs_setup - real(kind=8) :: udist,umass logical :: input_plasmaB character(len= 1), parameter :: labelx(4) = (/'x','y','z','r'/) @@ -70,7 +69,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use boundary, only:set_boundary,xmin,xmax,ymin,ymax,zmin,zmax,dxbound,dybound,dzbound use boundary_dyn, only:width_bkg,rho_thresh_bdy,rho_bkg_ini,dxyz,vbdyx,vbdyy,vbdyz,in_domain,irho_bkg_ini use prompting, only:prompt - use units, only:set_units,select_unit,utime,unit_density,unit_Bfield,unit_velocity + use units, only:set_units,select_unit,utime,unit_density,unit_Bfield,unit_velocity,umass,udist use eos, only:polyk2,gmw use part, only:Bxyz,Bextx,Bexty,Bextz,igas,idust,set_particle_type,periodic use timestep, only:dtmax,tmax @@ -81,7 +80,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use mpidomain, only:i_belong use ptmass, only:icreate_sinks,r_crit,h_acc,h_soft_sinksink,rho_crit_cgs use cooling, only:Tfloor - use setunits, only:dist_unit,mass_unit + use setunits, only:dist_unit,mass_unit,set_units_interactive integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -109,7 +108,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, logical :: iexist,in_cloud,make_sinks logical :: moving_bkg = .true. ! For each component, will set the background velocity to that of the clouds, if the clouds are the same character(len=120) :: filex,filey,filez - character(len=100) :: filename,cwd + character(len=100) :: filename character(len= 40) :: fmt,lattice character(len= 10) :: h_acc_char ! @@ -129,19 +128,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, input_plasmaB = .false. make_sinks = .true. dynamic_bdy = .true. + dist_unit = 'pc' + mass_unit = 'solarm' - call getcwd(cwd) - print*, index(cwd,'gpfs1/scratch/astro/jhw5') - 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 + filex = find_phantom_datafile(filevx,'velfield') + filey = find_phantom_datafile(filevy,'velfield') + filez = find_phantom_datafile(filevz,'velfield') ! !--Read setup file, else prep prompt user for inputs ! @@ -156,36 +148,19 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, if (id==master) call write_setupfile(filename) stop endif - do i = 1,Ncloud - v2max = max(v2max,v_cloud(1,i)**2 + v_cloud(2,i)**2 +v_cloud(3,i)**2) - enddo elseif (id==master) then print "(a,/)",trim(filename)//' not found: using interactive setup' - dist_unit = 'pc' - 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) + call set_units_interactive() ! ! prompt user for settings ! Ncloud = 2 npmax = int(2.0/3.0*size(xyzh(1,:)))/(2*Ncloud) ! approx max number allowed in sphere given size(xyzh(1,:)) np = npmax - np = 30000 + np = 10000 v_cloud = 0.0 ! velocity in km/s r_cloud(1,:) = 50.0 ! semi-major-axis (x) in pc r_cloud(2,:) = 12.5 ! semi-minor-axis (y) in pc @@ -343,6 +318,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! !--general parameters of the cloud ! + do i = 1,Ncloud + v2max = max(v2max,v_cloud(1,i)**2 + v_cloud(2,i)**2 +v_cloud(3,i)**2) + enddo v_cloud = v_cloud/(unit_velocity*1.d-5) ! from km/s -> code units v2max = v2max /(unit_velocity*1.d-5)**2 ! from km/s -> code units vol_cloud = 4./3.*pi*r_cloud(1,:)*r_cloud(2,:)*r_cloud(3,:) diff --git a/src/setup/setup_common.f90 b/src/setup/setup_common.f90 index e12fe98f4..9a51767e0 100644 --- a/src/setup/setup_common.f90 +++ b/src/setup/setup_common.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 423594c6d..590f8a2b4 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! @@ -420,7 +420,7 @@ subroutine set_default_options()!id) !--gas disc R_in = 1. R_out = 150. - R_ref = 1. + R_ref = 10. R_c = 150. R_warp = 0. H_warp = 0. @@ -2211,7 +2211,7 @@ subroutine setup_interactive(id) !--gas disc R_in = accr1 - R_ref = R_in + R_ref = min(10.*R_in,R_out) R_c = R_out disc_mfac = 1. if (ndiscs > 1) qindex = 0. diff --git a/src/setup/setup_dustsettle.f90 b/src/setup/setup_dustsettle.f90 index d0eea0842..5a58e68c5 100644 --- a/src/setup/setup_dustsettle.f90 +++ b/src/setup/setup_dustsettle.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_dustybox.f90 b/src/setup/setup_dustybox.f90 index 28ddbfcc3..00d9bae08 100644 --- a/src/setup/setup_dustybox.f90 +++ b/src/setup/setup_dustybox.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_dustysedov.f90 b/src/setup/setup_dustysedov.f90 index 39985f0f2..918becd15 100644 --- a/src/setup/setup_dustysedov.f90 +++ b/src/setup/setup_dustysedov.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_empty.f90 b/src/setup/setup_empty.f90 index 5e93904fa..22c3a0893 100644 --- a/src/setup/setup_empty.f90 +++ b/src/setup/setup_empty.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_firehose.f90 b/src/setup/setup_firehose.f90 index f77c04039..c6256bcf0 100644 --- a/src/setup/setup_firehose.f90 +++ b/src/setup/setup_firehose.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_galaxies.f90 b/src/setup/setup_galaxies.f90 index 3a1986f79..ea8d68924 100644 --- a/src/setup/setup_galaxies.f90 +++ b/src/setup/setup_galaxies.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_galcen_stars.f90 b/src/setup/setup_galcen_stars.f90 index c76dc906e..b7d08a395 100644 --- a/src/setup/setup_galcen_stars.f90 +++ b/src/setup/setup_galcen_stars.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_galdisc.f90 b/src/setup/setup_galdisc.f90 index d0e62c0f4..e6dbcd55b 100644 --- a/src/setup/setup_galdisc.f90 +++ b/src/setup/setup_galdisc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! @@ -14,7 +14,7 @@ module setup ! ! :Runtime parameters: None ! -! :Dependencies: datafiles, dim, extern_spiral, externalforces, io, +! :Dependencies: datafiles, dim, extern_spiral, externalforces, io, kernel, ! mpiutils, options, part, physcon, prompting, random, set_dust, ! setup_params, units ! @@ -62,6 +62,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use io, only:fatal use prompting, only:prompt use set_dust, only:set_dustfrac + use kernel, only:hfact_default integer, intent(in) :: id integer, intent(out) :: npart integer, intent(out) :: npartoftype(:) @@ -100,7 +101,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--initialising units and flags ! ! set code units - call set_units(dist=100.*pc,mass=1.d05*solarm,G=1.) + call set_units(dist=100.*pc,mass=1.d5*solarm,G=1.d0) ! !--set input file options !--maxvxyzu(3-4) and therefore ieos(1-2) are set in dim_galdisc @@ -108,7 +109,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, icooling = 0 !1=cooling on, 0=off nfulldump = 1 - hfact = 1.2 + hfact = hfact_default ! !-------------------------Setting-energies------------------------- @@ -403,7 +404,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, print "(a,i10)",' random seed = ',iseed print "(3(a,f10.3),a)",' galactic disc setup... rmin = ',rcylin,' rmax = ',rcyl,' in units of ',udist/kpc,' kpc' xi = ran2(iseed) - npart = maxp + npart = min(maxp,500000) call prompt('Enter number of particles ',npart,1,maxp) call bcast_mpi(npart) if (npart > maxp) call fatal('setup','npart > maxp; use ./phantomsetup --maxp=10000000') @@ -576,7 +577,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, enddo endif - return end subroutine setpart !/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index dbd5baae0..e6fa50dc4 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index bf8a674bd..a6d04d9ef 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_gwdisc.f90 b/src/setup/setup_gwdisc.f90 index a44065c5b..6f74be36a 100644 --- a/src/setup/setup_gwdisc.f90 +++ b/src/setup/setup_gwdisc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_hierarchical.f90 b/src/setup/setup_hierarchical.f90 index a8d9f1178..cad18867d 100644 --- a/src/setup/setup_hierarchical.f90 +++ b/src/setup/setup_hierarchical.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_jadvect.f90 b/src/setup/setup_jadvect.f90 index 276198ad1..15b8fc00e 100644 --- a/src/setup/setup_jadvect.f90 +++ b/src/setup/setup_jadvect.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_kh.f90 b/src/setup/setup_kh.f90 index 51a39488e..5e847d5f8 100644 --- a/src/setup/setup_kh.f90 +++ b/src/setup/setup_kh.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_mhdblast.f90 b/src/setup/setup_mhdblast.f90 index abae51c2d..12189204f 100644 --- a/src/setup/setup_mhdblast.f90 +++ b/src/setup/setup_mhdblast.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_mhdrotor.f90 b/src/setup/setup_mhdrotor.f90 index d746a5556..25f1d5402 100644 --- a/src/setup/setup_mhdrotor.f90 +++ b/src/setup/setup_mhdrotor.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_mhdsine.f90 b/src/setup/setup_mhdsine.f90 index a5bfcf7d4..0c1fa5b0a 100644 --- a/src/setup/setup_mhdsine.f90 +++ b/src/setup/setup_mhdsine.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_mhdvortex.f90 b/src/setup/setup_mhdvortex.f90 index 4814ff8db..8ea65ad98 100644 --- a/src/setup/setup_mhdvortex.f90 +++ b/src/setup/setup_mhdvortex.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_mhdwave.f90 b/src/setup/setup_mhdwave.f90 index fab049d64..db858458b 100644 --- a/src/setup/setup_mhdwave.f90 +++ b/src/setup/setup_mhdwave.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_nsdisc.f90 b/src/setup/setup_nsdisc.f90 index fdbbc576f..bb9577f02 100644 --- a/src/setup/setup_nsdisc.f90 +++ b/src/setup/setup_nsdisc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! @@ -52,7 +52,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, udist_km = 1.e5/udist ! code units are cm gamma = 1.0 - npart = size(xyzh(1,:)) + npart = 1e5 npartoftype(1) = npart hfact = 1.2 time = 0. diff --git a/src/setup/setup_orstang.f90 b/src/setup/setup_orstang.f90 index b8453a703..04645cf0b 100644 --- a/src/setup/setup_orstang.f90 +++ b/src/setup/setup_orstang.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_params.f90 b/src/setup/setup_params.f90 index cbacb8066..9be2eadb7 100644 --- a/src/setup/setup_params.f90 +++ b/src/setup/setup_params.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup_params ! diff --git a/src/setup/setup_planetdisc.f90 b/src/setup/setup_planetdisc.f90 index c606ebc72..8e8ecb444 100644 --- a/src/setup/setup_planetdisc.f90 +++ b/src/setup/setup_planetdisc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_prtest.f90 b/src/setup/setup_prtest.f90 index 8988df726..4ad6b335a 100644 --- a/src/setup/setup_prtest.f90 +++ b/src/setup/setup_prtest.f90 @@ -2,20 +2,20 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! -! this module does setup +! test of Poynting-Robertson drag, as per Figure 18 of Price et al. (2018) ! -! :References: None +! :References: Price et al. (2018), PASA 35, e031 ! ! :Owner: Daniel Price ! ! :Runtime parameters: None ! -! :Dependencies: externalforces, io, options, physcon, setup_params, -! spherical, units +! :Dependencies: externalforces, io, kernel, options, physcon, +! setup_params, spherical, units ! implicit none public :: setpart @@ -36,8 +36,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use externalforces,only:mass1,iext_prdrag use spherical, only:set_sphere use units, only:set_units - use physcon, only:km - real, parameter :: pi = 3.1415926536 + use physcon, only:km,pi + use kernel, only:hfact_default integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -48,23 +48,22 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, character(len=20), intent(in) :: fileprefix real, intent(out) :: vxyzu(:,:) real :: totmass,totvol,psep,rmax,rmin,xyz_orig(3) - real :: r, vphi, phi + real :: r,vphi,phi integer :: i,np,nx,maxvxyzu - call set_units(dist=10.*km,c=1.) + call set_units(dist=10.*km,c=1.d0) ! !--general parameters ! time = 0. - hfact = 1.2 + hfact = hfact_default gamma = 1. rmin = 0. rmax = 0.05 - ! !--setup particles ! - np = 100 !size(xyzh(1,:)) + np = 100 maxvxyzu = size(vxyzu(:,1)) totvol = 4./3.*pi*rmax**3 nx = int(np**(1./3.)) @@ -76,7 +75,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, npart = 0 npart_total = 0 - xyz_orig(:) = (/0.,100.,0./) + xyz_orig(:) = (/0.,200.,0./) call set_sphere('closepacked',id,master,rmin,rmax,psep,hfact,npart,xyzh, & nptot=npart_total,xyz_origin=xyz_orig) @@ -108,7 +107,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call warning('setup_prtest','maxvxyzu should not be 4, so set temp=0 for you') endif enddo - ! ! --- set input defaults for nonviscous particles in prdrag ! @@ -117,8 +115,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, alpha=0. beta=0. - end subroutine setpart end module setup - diff --git a/src/setup/setup_quebec.f90 b/src/setup/setup_quebec.f90 index c3d852cbd..0ce9bde95 100644 --- a/src/setup/setup_quebec.f90 +++ b/src/setup/setup_quebec.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_radiativebox.f90 b/src/setup/setup_radiativebox.f90 index 6a6e40df2..b30ea361b 100644 --- a/src/setup/setup_radiativebox.f90 +++ b/src/setup/setup_radiativebox.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_sedov.f90 b/src/setup/setup_sedov.f90 index 2532e070e..49884983f 100644 --- a/src/setup/setup_sedov.f90 +++ b/src/setup/setup_sedov.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_solarsystem.f90 b/src/setup/setup_solarsystem.f90 index f10f8a090..5b06d37af 100644 --- a/src/setup/setup_solarsystem.f90 +++ b/src/setup/setup_solarsystem.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_sphereinbox.f90 b/src/setup/setup_sphereinbox.f90 index 00d27d28c..98a4a9156 100644 --- a/src/setup/setup_sphereinbox.f90 +++ b/src/setup/setup_sphereinbox.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! @@ -658,7 +658,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact_ if (.not. iexist) then ! default values tmax = 1.21*t_ff ! = 10.75 for default settings (Wurster, Price & Bate 2016) - ieos = 8 + if (maxvxyzu < 4) ieos = 8 nfulldump = 1 calc_erot = .true. icreate_sinks = icreate_sinks_setup diff --git a/src/setup/setup_srblast.f90 b/src/setup/setup_srblast.f90 index 03aa4c39c..79e38118b 100644 --- a/src/setup/setup_srblast.f90 +++ b/src/setup/setup_srblast.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_srpolytrope.f90 b/src/setup/setup_srpolytrope.f90 index 4e22d9180..f387060b3 100644 --- a/src/setup/setup_srpolytrope.f90 +++ b/src/setup/setup_srpolytrope.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index a18aeb5ac..e6fa4a8eb 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_taylorgreen.f90 b/src/setup/setup_taylorgreen.f90 index 3a9743f84..32f7ae24d 100644 --- a/src/setup/setup_taylorgreen.f90 +++ b/src/setup/setup_taylorgreen.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_testparticles.f90 b/src/setup/setup_testparticles.f90 index 93a914925..edbd8ab47 100644 --- a/src/setup/setup_testparticles.f90 +++ b/src/setup/setup_testparticles.f90 @@ -2,11 +2,11 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! -! None +! setup for test particles ! ! :References: None ! @@ -41,12 +41,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use options, only:iexternalforce,alpha,alphamax,alphau,beta,nfulldump use units, only:set_units use physcon, only:solarm -#ifdef GR - use externalforces, only:iext_gr - use metric, only:a -#else use externalforces, only:iext_star -#endif + use metric, only:a use eos, only:ieos use physcon, only:pi use prompting, only:prompt @@ -70,7 +66,11 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! general parameters ! time = 0. - gamma = 1. + if (gr) then + gamma = 5./3. ! GR cannot have gamma=1 + else + gamma = 1. + endif polyk = 0. npart = 10 ieos = 11 @@ -192,12 +192,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, vxyzu(1:3,i) = rtan*vcirc enddo -#ifdef GR - iexternalforce = iext_gr - a = spin -#else - iexternalforce = iext_star -#endif + a = spin + if (.not.gr) iexternalforce = iext_star end subroutine setpart diff --git a/src/setup/setup_tokamak.f90 b/src/setup/setup_tokamak.f90 index a095fa798..6fe6d3ebb 100644 --- a/src/setup/setup_tokamak.f90 +++ b/src/setup/setup_tokamak.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_torus.f90 b/src/setup/setup_torus.f90 index 3393e2b91..ed8b9470f 100644 --- a/src/setup/setup_torus.f90 +++ b/src/setup/setup_torus.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_turb.f90 b/src/setup/setup_turb.f90 index 5b02c8734..6910265f4 100644 --- a/src/setup/setup_turb.f90 +++ b/src/setup/setup_turb.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/setup_unifdis.f90 b/src/setup/setup_unifdis.f90 index 9a43b16a9..45b2c1abe 100644 --- a/src/setup/setup_unifdis.f90 +++ b/src/setup/setup_unifdis.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! @@ -27,8 +27,8 @@ module setup ! - zmin : *zmin boundary* ! ! :Dependencies: boundary, cooling, cooling_ism, dim, eos, infile_utils, -! io, mpidomain, options, part, physcon, prompting, set_dust, setunits, -! setup_params, timestep, unifdis, units +! io, mpidomain, options, part, physcon, prompting, radiation_utils, +! set_dust, setunits, setup_params, timestep, unifdis, units ! use dim, only:use_dust,mhd,gr use options, only:use_dustfrac @@ -55,12 +55,13 @@ module setup !+ !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) - use dim, only:maxvxyzu,h2chemistry + use dim, only:maxvxyzu,h2chemistry,use_dustgrowth,do_radiation use setup_params, only:npart_total,ihavesetupB use io, only:master use unifdis, only:set_unifdis,latticetype,get_xyzmin_xyzmax_exact use boundary, only:xmin,ymin,zmin,xmax,ymax,zmax,dxbound,dybound,dzbound,set_boundary - use part, only:Bxyz,periodic,abundance,igas,iHI,dustfrac,ndustsmall,ndusttypes,grainsize,graindens + use part, only:Bxyz,periodic,abundance,igas,iHI,dustfrac,ndustsmall,& + ndusttypes,grainsize,graindens,dustprop,rad use physcon, only:pi,mass_proton_cgs,kboltz,years,pc,solarm,micron use set_dust, only:set_dustfrac use setunits, only:dist_unit,mass_unit @@ -71,6 +72,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use timestep, only:dtmax,tmax,C_cour,C_force,C_cool,tolv use cooling, only:Tfloor use cooling_ism, only:abundc,abundo,abundsi,abunde,dust_to_gas_ratio,iphoto + use radiation_utils, only:set_radiation_and_gas_temperature_equal integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -226,6 +228,13 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, enddo endif + if (use_dustgrowth) then + do i=1,npart + dustprop(1,i) = grainsize(1) + dustprop(2,i) = graindens(1) + enddo + endif + if (h2chemistry) then do i=1,npart abundance(:,i) = 0. @@ -241,6 +250,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ihavesetupB = .true. endif + if (do_radiation) then + call set_radiation_and_gas_temperature_equal(npart,xyzh,vxyzu,massoftype,rad) + endif + end subroutine setpart !------------------------------------------------------------------------ @@ -292,9 +305,9 @@ subroutine setup_interactive() end subroutine setup_interactive !------------------------------------------------------------------------ -! -! write setup file -! +!+ +! write setup file +!+ !------------------------------------------------------------------------ subroutine write_setupfile(filename) use infile_utils, only:write_inopt @@ -336,9 +349,9 @@ subroutine write_setupfile(filename) end subroutine write_setupfile !------------------------------------------------------------------------ -! -! read setup file -! +!+ +! read setup file +!+ !------------------------------------------------------------------------ subroutine read_setupfile(filename,ierr) use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db diff --git a/src/setup/setup_wave.f90 b/src/setup/setup_wave.f90 index 3ff919caf..3a0816ee0 100644 --- a/src/setup/setup_wave.f90 +++ b/src/setup/setup_wave.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! @@ -35,7 +35,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use unifdis, only:set_unifdis,rho_func use boundary, only:set_boundary,xmin,ymin,zmin,xmax,ymax,zmax,dxbound,dybound,dzbound use mpiutils, only:bcast_mpi - use part, only:labeltype,set_particle_type,igas,idust,dustfrac,periodic + use part, only:labeltype,set_particle_type,igas,idust,dustfrac,periodic,ndustsmall,ndustlarge,ndusttypes use physcon, only:pi use kernel, only:radkern use dim, only:maxvxyzu,use_dust,maxp @@ -73,6 +73,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, 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 <<<' @@ -92,11 +94,16 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call prompt('Enter constant drag coefficient',K_code(1),0.) if (use_dustfrac) then massfac = 1. + dtg + ndustsmall = 1 else ntypes = 2 + ndustlarge = 1 endif endif endif + call bcast_mpi(ndustsmall) + call bcast_mpi(ndustlarge) + ndusttypes = ndustsmall + ndustlarge call bcast_mpi(npartx) ! ! boundaries diff --git a/src/setup/setup_wavedamp.f90 b/src/setup/setup_wavedamp.f90 index d31770e24..8b6901518 100644 --- a/src/setup/setup_wavedamp.f90 +++ b/src/setup/setup_wavedamp.f90 @@ -2,14 +2,16 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! ! This module initialises the wave damping test, as per ! Choi et al. 2009 (has been generalised for additional studies) ! -! :References: None +! :References: +! Wurster, Price & Ayliffe (2014), MNRAS 444, 1104 (Section 4.1) +! Wurster, Price & Bate (2016), MNRAS 457, 1037 ! ! :Owner: Daniel Price ! @@ -25,7 +27,7 @@ module setup ! - nx : *Particles in the x-direction* ! - ohmtest : *Testing Ohmic resistivity* ! - polyk : *Initial polyk* -! - realvals : *Using physical values (F: arbitrary values)* +! - realvals : *Using physical units (F: arbitrary units)* ! - rect : *Using rectangular cp grid (F: cubic cp grid)* ! - rhoin : *Initial density* ! - viscoff : *Using no viscosity (F: using viscosity* @@ -35,21 +37,20 @@ module setup ! nicil, options, part, physcon, prompting, setup_params, timestep, ! unifdis, units ! - use part, only:mhd - use nicil, only:use_ohm,use_hall,use_ambi - use nicil, only:eta_constant,eta_const_type,C_OR,C_HE,C_AD,icnstphys,icnstsemi,icnst - use nicil, only:n_e_cnst,rho_i_cnst,rho_n_cnst,gamma_AD,alpha_AD,hall_lt_zero - ! + use part, only:mhd + use nicil, only:use_ohm,use_hall,use_ambi + use nicil, only:eta_constant,eta_const_type,C_OR,C_HE,C_AD,icnstphys,icnstsemi,icnst + use nicil, only:n_e_cnst,rho_i_cnst,rho_n_cnst,gamma_AD,alpha_AD,hall_lt_zero implicit none integer, private :: nx real, private :: kwave,amplitude,polykin,rhoin0,Bxin0 logical, private :: realvals,geo_cp,rect logical, private :: isowave,kx_kxy,vx_vz,viscoff,ambitest,halltest,ohmtest - ! + public :: setpart - ! + private - ! + contains !---------------------------------------------------------------- !+ @@ -114,9 +115,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Prompt the user for relevant input to create .setup if file does not already exist ! setupname=trim(fileprefix)//'.setup' - print "(/,1x,63('-'),1(/,a),/,1x,63('-'),/)", ' Wave-damping test.' + print "(/,1x,63('-'),1(/,a),/,1x,63('-'),/)", ' Wave damping test.' inquire(file=setupname,exist=jexist) if (jexist) call read_setupfile(setupname,ierr) + if ( (ierr /= 0 .or. .not.iexist .or. .not.jexist) .and. id==master) then ! Set defaults realvals = .false. @@ -360,7 +362,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, write(*,*) "setup: total volume = ",dxbound*dybound*dzbound end subroutine setpart -!----------------------------------------------------------------------- + +!------------------------------------------------------------------------ +!+ +! write options to .setup file +!+ +!------------------------------------------------------------------------ subroutine write_setupfile(filename) use infile_utils, only: write_inopt character(len=*), intent(in) :: filename @@ -368,13 +375,15 @@ subroutine write_setupfile(filename) print "(a)",' writing setup options file '//trim(filename) open(unit=iunit,file=filename,status='replace',form='formatted') - write(iunit,"(a)") '# input file for wave-dampening setup routines' + write(iunit,"(a)") '# input file for wave damping setup routines' + write(iunit,"(/,a)") '# units and orientation' - call write_inopt(realvals,'realvals','Using physical values (F: arbitrary values)',iunit) + call write_inopt(realvals,'realvals','Using physical units (F: arbitrary units)',iunit) if (mhd) call write_inopt(isowave,'isowave','Modelling a sound wave (F: Alfven wave)',iunit) call write_inopt(kx_kxy,'kx_kxy','Using wavenumber in x only (F: initialise in x,y)',iunit) call write_inopt(vx_vz,'vx_vz','Using velocity in x (F: initialise in z)',iunit) call write_inopt(viscoff,'viscoff','Using no viscosity (F: using viscosity',iunit) + write(iunit,"(/,a)") '# Grid setup' call write_inopt(geo_cp,'geo_cp','Using close-packed grid (F: cubic).',iunit) if (geo_cp) call write_inopt(rect,'rect','Using rectangular cp grid (F: cubic cp grid)',iunit) @@ -384,6 +393,7 @@ subroutine write_setupfile(filename) if (mhd .and. .not. isowave) call write_inopt(Bxin0,'Bxin','Initial x-magnetic field',iunit) call write_inopt(amplitude,'amplitude','Initial wave amplitude',iunit) call write_inopt(kwave,'kwave','Wavenumber (k/pi)',iunit) + write(iunit,"(/,a)") '# Test problem and values' if (mhd) then call write_inopt(ambitest,'ambitest','Testing ambipolar diffusion',iunit) @@ -393,7 +403,12 @@ subroutine write_setupfile(filename) close(iunit) end subroutine write_setupfile -!----------------------------------------------------------------------- + +!------------------------------------------------------------------------ +!+ +! read options from .setup file +!+ +!------------------------------------------------------------------------ subroutine read_setupfile(filename,ierr) use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db character(len=*), intent(in) :: filename @@ -424,7 +439,6 @@ subroutine read_setupfile(filename,ierr) call read_inopt(ohmtest, 'ohmtest', db,ierr) if (ohmtest) use_ohm = .true. endif - call close_db(db) end subroutine read_setupfile diff --git a/src/setup/setup_wddisc.f90 b/src/setup/setup_wddisc.f90 index 8077ec24b..39d9101a1 100644 --- a/src/setup/setup_wddisc.f90 +++ b/src/setup/setup_wddisc.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module setup ! diff --git a/src/setup/stretchmap.f90 b/src/setup/stretchmap.f90 index b2ea9a42f..cea129eca 100644 --- a/src/setup/stretchmap.f90 +++ b/src/setup/stretchmap.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module stretchmap ! diff --git a/src/setup/velfield_fromcubes.f90 b/src/setup/velfield_fromcubes.f90 index d16396d9f..9145c4c04 100644 --- a/src/setup/velfield_fromcubes.f90 +++ b/src/setup/velfield_fromcubes.f90 @@ -2,7 +2,7 @@ ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module velfield ! From 2fcb4f666815f4b13f3d05bba8f5d3268e370fd4 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 1 May 2024 20:50:22 +0100 Subject: [PATCH 504/814] partial update to main repo --- src/main/checkconserved.f90 | 41 +- src/main/checksetup.f90 | 31 +- src/main/config.F90 | 1 - src/main/cons2prim.f90 | 4 +- src/main/{cooling.F90 => cooling.f90} | 0 src/main/cooling_koyamainutsuka.f90 | 2 + src/main/cooling_molecular.f90 | 12 +- src/main/dtype_kdtree.F90 | 2 + src/main/dust_formation.f90 | 2 +- src/main/energies.F90 | 15 +- src/main/eos.f90 | 1560 +++++++++++++++++++++++++ src/main/tmunu2grid.f90 | 190 +-- src/main/utils_dumpfiles.f90 | 279 +++-- src/main/utils_filenames.f90 | 2 +- src/main/utils_omp.F90 | 14 +- 15 files changed, 1846 insertions(+), 309 deletions(-) rename src/main/{cooling.F90 => cooling.f90} (100%) create mode 100644 src/main/eos.f90 diff --git a/src/main/checkconserved.f90 b/src/main/checkconserved.f90 index e47e96955..a5538d537 100644 --- a/src/main/checkconserved.f90 +++ b/src/main/checkconserved.f90 @@ -95,7 +95,6 @@ subroutine check_conservation_error(val,ref,tol,label,decrease) character(len=*), intent(in) :: label logical, intent(in), optional :: decrease real :: err - character(len=20) :: string if (abs(ref) > 1.e-3) then err = (val - ref)/abs(ref) @@ -113,12 +112,7 @@ subroutine check_conservation_error(val,ref,tol,label,decrease) call error('evolve',trim(label)//' is not being conserved due to corotating frame',var='err',val=err) else call error('evolve','Large error in '//trim(label)//' conservation ',var='err',val=err) - call get_environment_variable('I_WILL_NOT_PUBLISH_CRAP',string) - if (.not. (trim(string)=='yes')) then - print "(2(/,a))",' You can ignore this error and continue by setting the ',& - ' environment variable I_WILL_NOT_PUBLISH_CRAP=yes to continue' - call fatal('evolve',' Conservation errors too large to continue simulation') - endif + call do_not_publish_crap('evolve','Conservation errors too large to continue simulation') endif else if (iverbose >= 2) print "(a,es10.3)",trim(label)//' error is ',err @@ -133,24 +127,31 @@ end subroutine check_conservation_error ! so is related to the checks performed here !+ !---------------------------------------------------------------- -subroutine check_magnetic_stability(hdivBB_xa) - use options, only:hdivbbmax_max +subroutine check_magnetic_stability(hdivBonB_ave,hdivBonB_max) use io, only:fatal - real, intent(in) :: hdivBB_xa(:) + real, intent(in) :: hdivBonB_ave,hdivBonB_max - if (hdivbbmax_max < 1.1) then - ! In this regime, we assume the user has not modified this value, - ! either by choice or by being unaware of this. This warning will - ! appear in this case. - if (hdivBB_xa(1) > 100 .or. hdivBB_xa(2) > 0.1) then - ! Tricco, Price & Bate (2016) suggest the average should remain lower than 0.01, - ! but we will increase it here due to the nature of the exiting the code - ! The suggestion of 512 was empirically determined in Dobbs & Wurster (2021) - call fatal('evolve','h|divb|/b is too large; recommend hdivbbmax_max = 512; set >1.2 to suppress this message.') - endif + if (hdivBonB_max > 100 .or. hdivBonB_ave > 0.1) then + ! Tricco, Price & Bate (2016) suggest the average should remain lower than 0.01, + ! but we will increase it here due to the nature of the exiting the code + ! The suggestion of 512 was empirically determined in Dobbs & Wurster (2021) + call do_not_publish_crap('evolve','h|divb|/b is too large; recommend to increase the overcleanfac') endif end subroutine check_magnetic_stability +subroutine do_not_publish_crap(subr,msg) + use io, only:fatal + character(len=*), intent(in) :: subr,msg + character(len=20) :: string + + call get_environment_variable('I_WILL_NOT_PUBLISH_CRAP',string) + if (.not. (trim(string)=='yes')) then + print "(2(/,a))",' You can ignore this error and continue by setting the ',& + ' environment variable I_WILL_NOT_PUBLISH_CRAP=yes to continue' + call fatal(subr,msg) + endif + +end subroutine do_not_publish_crap !---------------------------------------------------------------- end module checkconserved diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index a14201b96..39ac95b9b 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -16,7 +16,7 @@ module checksetup ! ! :Dependencies: boundary, boundary_dyn, centreofmass, dim, dust, eos, ! externalforces, io, metric_tools, nicil, options, part, physcon, -! ptmass_radiation, sortutils, timestep, units, utils_gr +! ptmass, ptmass_radiation, sortutils, timestep, units, utils_gr ! implicit none public :: check_setup @@ -429,6 +429,10 @@ subroutine check_setup(nerror,nwarn,restart) !--check centre of mass ! call get_centreofmass(xcom,vcom,npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) +! +!--check Forward symplectic integration method imcompatiblity +! + call check_vdep_extf (nwarn,iexternalforce) if (.not.h2chemistry .and. maxvxyzu >= 4 .and. icooling == 3 .and. iexternalforce/=iext_corotate .and. nptmass==0) then if (dot_product(xcom,xcom) > 1.e-2) then @@ -522,11 +526,15 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) use part, only:nptmass,xyzmh_ptmass,ihacc,ihsoft,gr,iTeff,sinks_have_luminosity,& ilum,iJ2,ispinx,ispinz,iReff use ptmass_radiation, only:isink_radiation + use ptmass, only:use_fourthorder integer, intent(inout) :: nerror,nwarn real, intent(in) :: hmin integer :: i,j,n real :: dx(3) real :: r,hsink,hsoft,J2 + logical :: isoblate + + isoblate = .false. if (gr .and. nptmass > 0) then print*,' ERROR: nptmass = ',nptmass, ' should be = 0 for GR' @@ -615,6 +623,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) ! in order to specify the rotation direction ! if (J2 > 0.) then + isoblate = .true. if (dot_product(xyzmh_ptmass(ispinx:ispinz,i),xyzmh_ptmass(ispinx:ispinz,i)) < tiny(0.)) then nerror = nerror + 1 print*,'ERROR! non-zero J2 requires non-zero spin on sink particle ',i @@ -625,6 +634,13 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) endif endif enddo + + if (isoblate .and. use_fourthorder) then + nwarn = nwarn + 1 + print*, 'WARNING: Substepping integration switched back to leapfrog due to oblateness' + use_fourthorder = .false. + endif + ! ! check that radiation properties are sensible ! @@ -999,4 +1015,17 @@ subroutine check_setup_radiation(npart,nerror,nwarn,radprop,rad) end subroutine check_setup_radiation +subroutine check_vdep_extf(nwarn,iexternalforce) + use externalforces, only: is_velocity_dependent + use ptmass, only : use_fourthorder + integer, intent(inout) :: nwarn + integer, intent(in) :: iexternalforce + if (is_velocity_dependent(iexternalforce) .and. use_fourthorder) then + print "(/,a,/)","Warning: velocity dependant external forces are not compatible with FSI switch back to Leapfrog..." + nwarn = nwarn + 1 + use_fourthorder = .false. + endif + +end subroutine check_vdep_extf + end module checksetup diff --git a/src/main/config.F90 b/src/main/config.F90 index 069005dd4..5acb64234 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -121,7 +121,6 @@ module dim #else logical, parameter :: do_radiation = .false. #endif - ! rhosum integer, parameter :: maxrhosum = 39 + & maxdustlarge - 1 + & diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 9c1130f8e..261b5a24f 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -123,7 +123,7 @@ subroutine cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) use part, only:isdead_or_accreted,massoftype,igas,rhoh,igasP,ics,ien_type,& itemp,igamma use io, only:fatal - use eos, only:ieos,gamma,done_init_eos,init_eos,get_spsound + 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(:) @@ -135,7 +135,7 @@ subroutine cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) !$omp parallel do default (none) & !$omp shared(xyzh,metrics,vxyzu,dens,pxyzu,npart,massoftype) & -!$omp shared(ieos,gamma,eos_vars,ien_type) & +!$omp shared(ieos,eos_vars,ien_type) & !$omp private(i,ierr,spsound,pondens,p_guess,rhoi,tempi,gammai) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then diff --git a/src/main/cooling.F90 b/src/main/cooling.f90 similarity index 100% rename from src/main/cooling.F90 rename to src/main/cooling.f90 diff --git a/src/main/cooling_koyamainutsuka.f90 b/src/main/cooling_koyamainutsuka.f90 index eee002b73..2548d180c 100644 --- a/src/main/cooling_koyamainutsuka.f90 +++ b/src/main/cooling_koyamainutsuka.f90 @@ -45,6 +45,7 @@ subroutine init_cooling_KI02(ierr) use units, only:utime,umass,udist integer, intent(out) :: ierr + ierr = 0 LambdaKI_coef = GammaKI_cgs*umass*utime**3/(mass_proton_cgs**2 * udist**5) GammaKI = GammaKI_cgs*utime**3/(mass_proton_cgs*udist**2) call init_hv4table(ierr) @@ -229,6 +230,7 @@ subroutine read_options_cooling_KI02(name,valstring,imatch,igotall,ierr) imatch = .true. igotall = .true. ! nothing to read + ierr = 0 end subroutine read_options_cooling_KI02 diff --git a/src/main/cooling_molecular.f90 b/src/main/cooling_molecular.f90 index 48055b2c9..e953a3175 100644 --- a/src/main/cooling_molecular.f90 +++ b/src/main/cooling_molecular.f90 @@ -210,7 +210,7 @@ subroutine loadCoolingTable(data_array) iunit = 1 filename = find_phantom_datafile('radcool_all.dat','cooling') - OPEN(unit=iunit, file=trim(filename), STATUS="OLD", ACTION="read", & + open(unit=iunit,file=trim(filename),status="OLD", ACTION="read", & iostat=istat, IOMSG=imsg) ! Begin loading in data @@ -218,13 +218,13 @@ subroutine loadCoolingTable(data_array) !!! Skip header rewind(unit=iunit) do o = 1, headerLines - read(iunit, *, iostat=istat, IOMSG = imsg) + read(iunit, *,iostat=istat, IOMSG = imsg) enddo ! Read data skipheaderif: if ((istat == 0)) then readdo: do - read(iunit, *, iostat=istat) i, j, k, T, n_H, N_coolant, lambda_CO, lambda_H2O, lambda_HCN + read(iunit, *,iostat=istat) i, j, k, T, n_H, N_coolant, lambda_CO, lambda_H2O, lambda_HCN if (istat /= 0) exit data_array(i, j, k, :) = [T, n_H, N_coolant, lambda_CO, lambda_H2O, lambda_HCN] @@ -275,20 +275,20 @@ subroutine loadCDTable(data_array) iunit = 1 filename = find_phantom_datafile('table_cd.dat','cooling') - open(unit=iunit, file=filename, STATUS="OLD", iostat=istat, IOMSG=imsg) + open(unit=iunit,file=filename,status="OLD",iostat=istat, IOMSG=imsg) ! Begin loading in data openif: if (istat == 0) then !!! Skip header rewind(unit=iunit) do o = 1, headerLines - read(iunit, *, iostat=istat, IOMSG = imsg) + read(iunit, *,iostat=istat, IOMSG = imsg) enddo !!! Read data skipheaderif: if ((istat == 0)) then readdo: do - read(iunit, *, iostat=istat) i, j, k, l, r_part, widthLine, m_exp, r_sep, N_H + read(iunit, *,iostat=istat) i, j, k, l, r_part, widthLine, m_exp, r_sep, N_H if (istat /= 0) exit data_array(i, j, k, l, :) = [r_part, widthLine, m_exp, r_sep, N_H] diff --git a/src/main/dtype_kdtree.F90 b/src/main/dtype_kdtree.F90 index 6cf50144f..fcb1a04f5 100644 --- a/src/main/dtype_kdtree.F90 +++ b/src/main/dtype_kdtree.F90 @@ -51,9 +51,11 @@ module dtypekdtree real :: xcen(ndimtree) real :: size real :: hmax + real :: dum ! avoid ifort warning: align on 4-byte boundary integer :: leftchild integer :: rightchild integer :: parent + integer :: idum ! avoid ifort warning: align on 4-byte boundary #ifdef GRAVITY real :: mass real :: quads(6) diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index e594658ca..5598f85fb 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.f90 @@ -405,7 +405,7 @@ subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) pH2 = KH2*pH**2 mu = (1.+4.*eps(iHe))/(.5+eps(iHe)+0.5*pH/pH_tot) x = 2.*(1.+4.*eps(iHe))/mu - gamma = (3.*x+4.-3.*eps(iHe))/(x+4.+eps(iHe)) + gamma = (3.*x+4.+4.*eps(iHe))/(x+4.+4.*eps(iHe)) converged = (abs(T-T_old)/T_old) < tol if (i == 1) then mu_old = mu diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 27684ce97..d71e70db1 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -26,7 +26,8 @@ module energies implicit none logical, public :: gas_only,track_mass,track_lum - real, public :: ekin,etherm,emag,epot,etot,totmom,angtot,mtot,xyzcom(3),hdivBB_xa(2) + real, public :: ekin,etherm,emag,epot,etot,totmom,angtot,mtot,xyzcom(3) + real, public :: hdivBonB_ave,hdivBonB_max real, public :: vrms,rmsmach,accretedmass,mdust(maxdusttypes),mgas real, public :: xmom,ymom,zmom real, public :: totlum @@ -96,11 +97,11 @@ subroutine compute_energies(t) real, intent(in) :: t integer :: iregime,idusttype,ierr real :: ev_data_thread(4,0:inumev) - real :: xi,yi,zi,hi,vxi,vyi,vzi,v2i,vi1,Bxi,Byi,Bzi,Bi,B2i,rhoi,angx,angy,angz + real :: xi,yi,zi,hi,vxi,vyi,vzi,v2i,Bxi,Byi,Bzi,Bi,B2i,rhoi,angx,angy,angz real :: xmomacc,ymomacc,zmomacc,angaccx,angaccy,angaccz,xcom,ycom,zcom,dm real :: epoti,pmassi,dnptot,dnpgas,tsi real :: xmomall,ymomall,zmomall,angxall,angyall,angzall,rho1i,vsigi - real :: ponrhoi,spsoundi,spsound2i,va2cs2,rho1cs2,dumx,dumy,dumz,gammai + real :: ponrhoi,spsoundi,dumx,dumy,dumz,gammai real :: divBi,hdivBonBi,alphai,valfven2i,betai real :: n_total,n_total1,n_ion,shearparam_art,shearparam_phys,ratio_phys_to_av real :: gasfrac,rhogasi,dustfracisum,dustfraci(maxdusttypes),dust_to_gas(maxdusttypes) @@ -175,8 +176,8 @@ subroutine compute_energies(t) !$omp shared(iev_etaa,iev_vel,iev_vhall,iev_vion,iev_n) & !$omp shared(iev_dtg,iev_ts,iev_macc,iev_totlum,iev_erot,iev_viscrat) & !$omp shared(eos_vars,grainsize,graindens,ndustsmall,metrics) & -!$omp private(i,j,xi,yi,zi,hi,rhoi,vxi,vyi,vzi,Bxi,Byi,Bzi,Bi,B2i,epoti,vsigi,v2i,vi1) & -!$omp private(ponrhoi,spsoundi,gammai,spsound2i,va2cs2,rho1cs2,ethermi,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & +!$omp private(i,j,xi,yi,zi,hi,rhoi,vxi,vyi,vzi,Bxi,Byi,Bzi,Bi,B2i,epoti,vsigi,v2i) & +!$omp private(ponrhoi,spsoundi,gammai,ethermi,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & !$omp private(rho1i,shearparam_art,shearparam_phys,ratio_phys_to_av,betai) & !$omp private(gasfrac,rhogasi,dustfracisum,dustfraci,dust_to_gas,n_total,n_total1,n_ion) & !$omp private(etaohm,etahall,etaambi,vhalli,vhall,vioni,vion,data_out) & @@ -730,8 +731,8 @@ subroutine compute_energies(t) endif if (mhd) then - hdivBB_xa(1) = ev_data(iev_max,iev_hdivB) - hdivBB_xa(2) = ev_data(iev_ave,iev_hdivB) + hdivBonB_max = ev_data(iev_max,iev_hdivB) + hdivBonB_ave = ev_data(iev_ave,iev_hdivB) endif if (maxp==maxp_hard) then diff --git a/src/main/eos.f90 b/src/main/eos.f90 new file mode 100644 index 000000000..b68bf45b6 --- /dev/null +++ b/src/main/eos.f90 @@ -0,0 +1,1560 @@ +!--------------------------------------------------------------------------! +! 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 eos +! +! This module contains stuff to do with the equation of state +! Current options: +! 1 = isothermal eos +! 2 = adiabatic/polytropic eos +! 3 = eos for a locally isothermal disc as in Lodato & Pringle (2007) +! 4 = GR isothermal +! 5 = polytropic EOS with vary mu and gamma depending on H2 formation +! 6 = eos for a locally isothermal disc as in Lodato & Pringle (2007), +! centered on a sink particle +! 7 = z-dependent locally isothermal eos +! 8 = Barotropic eos +! 9 = Piecewise polytrope +! 10 = MESA EoS +! 11 = isothermal eos with zero pressure +! 12 = ideal gas with radiation pressure +! 13 = locally isothermal prescription from Farris et al. (2014) generalised for generic hierarchical systems +! 14 = locally isothermal prescription from Farris et al. (2014) for binary system +! 15 = Helmholtz free energy eos +! 16 = Shen eos +! 20 = Ideal gas + radiation + various forms of recombination energy from HORMONE (Hirai et al., 2020) +! 21 = read tabulated eos (for use with icooling == 9) +! +! :References: +! Lodato & Pringle (2007) +! Hirai et al. (2020) +! +! :Owner: Daniel Price +! +! :Runtime parameters: +! - X : *H mass fraction (ignored if variable composition)* +! - Z : *metallicity (ignored if variable composition)* +! - ieos : *eqn of state (1=isoth;2=adiab;3=locally iso;8=barotropic)* +! - metallicity : *metallicity* +! - mu : *mean molecular weight* +! +! :Dependencies: dim, dump_utils, eos_barotropic, eos_gasradrec, +! eos_helmholtz, eos_idealplusrad, eos_mesa, eos_piecewise, eos_shen, +! eos_stratified, infile_utils, io, mesa_microphysics, part, physcon, +! units +! + use part, only:ien_etotal,ien_entropy,ien_type + use dim, only:gr + implicit none + integer, parameter, public :: maxeos = 21 + real, public :: polyk, polyk2, gamma + real, public :: qfacdisc = 0.75, qfacdisc2 = 0.75 + logical, public :: extract_eos_from_hdr = .false. + integer, public :: isink = 0. + + public :: equationofstate,setpolyk,eosinfo,get_mean_molecular_weight + public :: get_TempPresCs,get_spsound,get_temperature,get_pressure,get_cv + public :: eos_is_non_ideal,eos_outputs_mu,eos_outputs_gasP + public :: get_local_u_internal,get_temperature_from_u + public :: calc_rec_ene,calc_temp_and_ene,entropy,get_rho_from_p_s,get_u_from_rhoT + public :: calc_rho_from_PT,get_entropy,get_p_from_rho_s + public :: init_eos,finish_eos,write_options_eos,read_options_eos + public :: write_headeropts_eos, read_headeropts_eos + + private + + integer, public :: ieos = 1 + integer, public :: iopacity_type = 0 ! used for radiation + real, public :: gmw = 2.381 ! default mean molecular weight + real, public :: X_in = 0.74 ! default metallicities + real, public :: Z_in = 0.02 ! default metallicities + logical, public :: use_var_comp = .false. ! use variable composition + real, public :: temperature_coef + + logical, public :: done_init_eos = .false. + ! + ! error codes for calls to init_eos + ! + integer, public, parameter :: & + ierr_file_not_found = 1, & + ierr_option_conflict = 2, & + ierr_units_not_set = 3, & + ierr_isink_not_set = 4 + +! +! Default temperature prescription for vertical stratification (0=MAPS, 1=Dartois) +! + integer, public:: istrat = 0. +! +! 2D temperature structure fit parameters for HD 163296 +! + real, public :: z0 = 1. + real, public :: alpha_z = 3.01 + real, public :: beta_z = 0.42 + +contains + +!---------------------------------------------------------------- +!+ +! subroutine returns pressure/density as a function of density +! (and position in the case of the isothermal disc) +!+ +!---------------------------------------------------------------- +subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gamma_local,mu_local,Xlocal,Zlocal) + use io, only:fatal,error,warning + use part, only:xyzmh_ptmass, nptmass + use units, only:unit_density,unit_pressure,unit_ergg,unit_velocity + use physcon, only:Rg,radconst + use eos_mesa, only:get_eos_pressure_temp_gamma1_mesa,get_eos_1overmu_mesa + use eos_helmholtz, only:eos_helmholtz_pres_sound + use eos_shen, only:eos_shen_NL3 + use eos_idealplusrad + use eos_gasradrec, only:equationofstate_gasradrec + use eos_stratified, only:get_eos_stratified + use eos_barotropic, only:get_eos_barotropic + use eos_piecewise, only:get_eos_piecewise + use eos_stamatellos + integer, intent(in) :: eos_type + real, intent(in) :: rhoi,xi,yi,zi + real, intent(out) :: ponrhoi,spsoundi + real, intent(inout) :: tempi + real, intent(in), optional :: eni + real, intent(inout), optional :: mu_local,gamma_local + real, intent(in) , optional :: Xlocal,Zlocal + integer :: ierr, i + real :: r1,r2 + real :: mass_r, mass ! defined for generalised Farris prescription + real :: gammai,temperaturei,mui,imui,X_i,Z_i + real :: cgsrhoi,cgseni,cgspresi,presi,gam1,cgsspsoundi + real :: uthermconst,kappaBar,kappaPart,gmwi + real :: enthi,pondensi + ! + ! Check to see if equation of state is compatible with GR cons2prim routines + ! + if (gr .and. .not.any((/2,4,11,12/)==eos_type)) then + ponrhoi = 0.; spsoundi = 0. ! avoid compiler warning + call fatal('eos','GR currently only works for ieos=2,12 or 11',& + var='eos_type',val=real(eos_type)) + endif + + gammai = gamma + mui = gmw + X_i = X_in + Z_i = Z_in + if (present(gamma_local)) gammai = gamma_local + if (present(mu_local)) mui = mu_local + if (present(Xlocal)) X_i = Xlocal + if (present(Zlocal)) Z_i = Zlocal + + select case(eos_type) + case(1) +! +!--Isothermal eos +! +! :math:`P = c_s^2 \rho` +! +! where :math:`c_s^2 \equiv K` is a constant stored in the dump file header +! + ponrhoi = polyk + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + + case(2,5) +! +!--Adiabatic equation of state (code default) +! +! :math:`P = (\gamma - 1) \rho u` +! +! if the code is compiled with ISOTHERMAL=yes, ieos=2 gives a polytropic eos: +! +! :math:`P = K \rho^\gamma` +! +! where K is a global constant specified in the dump header +! + if (gammai < tiny(gammai)) call fatal('eos','gamma not set for adiabatic eos',var='gamma',val=gammai) + + if (gr) then + if (.not. present(eni)) call fatal('eos','GR call to equationofstate requires thermal energy as input!') + if (eni < 0.) call fatal('eos','utherm < 0',var='u',val=eni) + if (gammai <= 1.) then + spsoundi = 0.; ponrhoi = 0. ! avoid compiler warning + call fatal('eos','GR not compatible with isothermal equation of state, yet...',var='gamma',val=gammai) + elseif (gammai > 1.0001) then + pondensi = (gammai-1.)*eni ! eni is the thermal energy + enthi = 1. + eni + pondensi ! enthalpy + spsoundi = sqrt(gammai*pondensi/enthi) + ponrhoi = pondensi ! With GR this routine actually outputs pondensi (i.e. pressure on primitive density, not conserved.) + endif + else + if (present(eni)) then + if (eni < 0.) then + !write(iprint,'(a,Es18.4,a,4Es18.4)')'Warning: eos: u = ',eni,' < 0 at {x,y,z,rho} = ',xi,yi,zi,rhoi + call fatal('eos','utherm < 0',var='u',val=eni) + endif + if (gammai > 1.0001) then + ponrhoi = (gammai-1.)*eni ! use this if en is thermal energy + else + ponrhoi = 2./3.*eni ! en is thermal energy and gamma = 1 + endif + else + ponrhoi = polyk*rhoi**(gammai-1.) + endif + spsoundi = sqrt(gammai*ponrhoi) + endif + + tempi = temperature_coef*mui*ponrhoi + + case(3) +! +!--Locally isothermal disc as in Lodato & Pringle (2007) where +! +! :math:`P = c_s^2 (r) \rho` +! +! sound speed (temperature) is prescribed as a function of radius using: +! +! :math:`c_s = c_{s,0} r^{-q}` where :math:`r = \sqrt{x^2 + y^2 + z^2}` +! + ponrhoi = polyk*(xi**2 + yi**2 + zi**2)**(-qfacdisc) ! polyk is cs^2, so this is (R^2)^(-q) + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + + case(4) +! +!--Isothermal equation of state for GR, enforcing cs = constant +! +! .. WARNING:: this is experimental: use with caution +! + uthermconst = polyk + ponrhoi = (gammai-1.)*uthermconst + spsoundi = sqrt(ponrhoi/(1.+uthermconst)) + tempi = temperature_coef*mui*ponrhoi + + case(6) +! +!--Locally isothermal disc centred on sink particle +! +! As in ieos=3 but in this version radius is taken with respect to a designated +! sink particle (by default the first sink particle in the simulation) +! + ponrhoi = polyk*((xi-xyzmh_ptmass(1,isink))**2 + (yi-xyzmh_ptmass(2,isink))**2 + & + (zi-xyzmh_ptmass(3,isink))**2)**(-qfacdisc) ! polyk is cs^2, so this is (R^2)^(-q) + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + + case(7) +! +!--Vertically stratified equation of state +! +! sound speed is prescribed as a function of (cylindrical) radius R and +! height z above the x-y plane +! +! .. WARNING:: should not be used for misaligned discs +! + call get_eos_stratified(istrat,xi,yi,zi,polyk,polyk2,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,ponrhoi,spsoundi) + tempi = temperature_coef*mui*ponrhoi + + case(8) +! +!--Barotropic equation of state +! +! :math:`P = K \rho^\gamma` +! +! where the value of gamma (and K) are a prescribed function of density +! + call get_eos_barotropic(rhoi,polyk,polyk2,ponrhoi,spsoundi,gammai) + tempi = temperature_coef*mui*ponrhoi + + case(9) +! +!--Piecewise Polytropic equation of state +! +! :math:`P = K \rho^\gamma` +! +! where the value of gamma (and K) are a prescribed function of density. +! Similar to ieos=8 but with different defaults and slightly different +! functional form +! + call get_eos_piecewise(rhoi,ponrhoi,spsoundi,gammai) + tempi = temperature_coef*mui*ponrhoi + + case(10) +! +!--MESA equation of state +! +! a tabulated equation of state including gas, radiation pressure +! and ionisation/dissociation. MESA is a stellar evolution code, so +! this equation of state is designed for matter inside stars +! + cgsrhoi = rhoi * unit_density + cgseni = eni * unit_ergg + call get_eos_pressure_temp_gamma1_mesa(cgsrhoi,cgseni,cgspresi,temperaturei,gam1,ierr) + presi = cgspresi / unit_pressure + + ponrhoi = presi / rhoi + spsoundi = sqrt(gam1*ponrhoi) + tempi = temperaturei + if (present(gamma_local)) gamma_local = gam1 ! gamma is an output + if (present(mu_local)) mu_local = 1./get_eos_1overmu_mesa(cgsrhoi,cgseni) + if (ierr /= 0) call warning('eos_mesa','extrapolating off tables') + + case(11) +! +!--Isothermal equation of state with pressure and temperature equal to zero +! +! :math:`P = 0` +! +! useful for simulating test particle dynamics using SPH particles +! + ponrhoi = 0. + spsoundi = sqrt(polyk) + tempi = 0. + + case(12) +! +!--Ideal gas plus radiation pressure +! +! :math:`P = (\gamma - 1) \rho u` +! +! but solved by first solving the quartic equation: +! +! :math:`u = \frac32 \frac{k_b T}{\mu m_H} + \frac{a T^4}{\rho}` +! +! for temperature (given u), then solving for pressure using +! +! :math:`P = \frac{k_b T}{\mu m_H} + \frac13 a T^4` +! +! hence in this equation of state gamma (and temperature) are an output +! + temperaturei = tempi ! Required as initial guess + cgsrhoi = rhoi * unit_density + cgseni = eni * unit_ergg + call get_idealplusrad_temp(cgsrhoi,cgseni,mui,temperaturei,ierr) + call get_idealplusrad_pres(cgsrhoi,temperaturei,mui,cgspresi) + call get_idealplusrad_spsoundi(cgsrhoi,cgspresi,cgseni,spsoundi,gammai) + if (present(gamma_local)) gamma_local = gammai ! gamma is an output + spsoundi = spsoundi / unit_velocity + presi = cgspresi / unit_pressure + ponrhoi = presi / rhoi + tempi = temperaturei + if (ierr /= 0) call warning('eos_idealplusrad','temperature iteration did not converge') + + + case(13) +! +!--Locally isothermal eos for generic hierarchical system +! +! Assuming all sink particles are stars. +! Generalisation of Farris et al. (2014; for binaries) to N stars. +! For two sink particles this is identical to ieos=14 +! + mass_r = 0 + mass = 0 + + do i=1,nptmass + mass_r = mass_r+xyzmh_ptmass(4,i)/sqrt((xi-xyzmh_ptmass(1,i))**2 + (yi-xyzmh_ptmass(2,i))**2 + (zi-xyzmh_ptmass(3,i))**2) + mass = mass + xyzmh_ptmass(4,i) + enddo + ponrhoi=polyk*(mass_r)**(2*qfacdisc)/mass**(2*qfacdisc) + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + + + case(14) +! +!--Locally isothermal eos from Farris et al. (2014) for binary system +! +! uses the locations of the first two sink particles +! + r1 = sqrt((xi-xyzmh_ptmass(1,1))**2+(yi-xyzmh_ptmass(2,1))**2 + (zi-xyzmh_ptmass(3,1))**2) + r2 = sqrt((xi-xyzmh_ptmass(1,2))**2+(yi-xyzmh_ptmass(2,2))**2 + (zi-xyzmh_ptmass(3,2))**2) + ponrhoi=polyk*(xyzmh_ptmass(4,1)/r1+xyzmh_ptmass(4,2)/r2)**(2*qfacdisc)/(xyzmh_ptmass(4,1)+xyzmh_ptmass(4,2))**(2*qfacdisc) + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + + case(15) +! +!--Helmholtz equation of state (computed live, not tabulated) +! +! .. WARNING:: not widely tested in phantom, better to use ieos=10 +! + call eos_helmholtz_pres_sound(tempi, rhoi, ponrhoi, spsoundi, eni) + + case(16) +! +!--Shen (2012) equation of state for neutron stars +! +! this equation of state requires evolving temperature as the energy variable +! +! .. WARNING:: not tested: use with caution +! + if (present(eni)) then + cgsrhoi = rhoi * unit_density + !note eni is actually tempi + call eos_shen_NL3(cgsrhoi,eni,0.05,cgspresi,cgsspsoundi) + spsoundi=cgsspsoundi / unit_velocity + presi = cgspresi / unit_pressure + ponrhoi = presi / rhoi + tempi = eni + call warning('eos','Not sure if this is correct now that temperature is always passed into eos') + else + spsoundi = 0.; presi = 0.; ponrhoi = 0.; tempi = 0. ! to avoid compiler warnings + call fatal('eos','tried to call NL3 eos without passing temperature') + endif + + case(20) +! +!--Gas + radiation + various forms of recombination +! +! from HORMONE, Hirai+2020, as used in Lau+2022b +! + cgsrhoi = rhoi * unit_density + cgseni = eni * unit_ergg + imui = 1./mui + if (tempi > 0.) then + temperaturei = tempi + else + temperaturei = min(0.67 * cgseni * mui / Rg, (cgseni*cgsrhoi/radconst)**0.25) + endif + call equationofstate_gasradrec(cgsrhoi,cgseni*cgsrhoi,temperaturei,imui,X_i,1.-X_i-Z_i,cgspresi,cgsspsoundi,gammai) + ponrhoi = real(cgspresi / (unit_pressure * rhoi)) + spsoundi = real(cgsspsoundi / unit_velocity) + tempi = temperaturei + if (present(mu_local)) mu_local = 1./imui + if (present(gamma_local)) gamma_local = gammai + + case(21) +! +!--interpolate tabulated eos from Stamatellos+(2007). For use with icooling=9 +! + if (eni < 0.) then + call fatal('eos (stamatellos)','utherm < 0',var='u',val=eni) + endif + cgsrhoi = rhoi * unit_density + cgseni = eni * unit_ergg + call getopac_opdep(cgseni,cgsrhoi,kappaBar,kappaPart,tempi,mui) + cgspresi = kb_on_mh*cgsrhoi*tempi/mui + presi = cgspresi/unit_pressure + ponrhoi = presi/rhoi + gammai = 1.d0 + presi/(eni*rhoi) + !if (gammai < 1.d0 .or. gammai > 2.d0) then + ! print *, gammai, tempi, mui,cgseni,cgsrhoi,cgspresi + !endif + spsoundi = sqrt(gammai*ponrhoi) + + + case default + spsoundi = 0. ! avoids compiler warnings + ponrhoi = 0. + tempi = 0. + call fatal('eos','unknown equation of state') + end select + +end subroutine equationofstate + +!----------------------------------------------------------------------- +!+ +! initialise equation of state (read tables etc.) +!+ +!----------------------------------------------------------------------- +subroutine init_eos(eos_type,ierr) + use units, only:unit_velocity + use physcon, only:Rg + use io, only:error,warning,fatal + use eos_mesa, only:init_eos_mesa + use eos_helmholtz, only:eos_helmholtz_init + use eos_piecewise, only:init_eos_piecewise + use eos_barotropic, only:init_eos_barotropic + use eos_shen, only:init_eos_shen_NL3 + use eos_gasradrec, only:init_eos_gasradrec + use eos_stamatellos,only:read_optab,init_S07cool,eos_file + use dim, only:maxvxyzu,do_radiation + integer, intent(in) :: eos_type + integer, intent(out) :: ierr + integer :: ierr_mesakapp + + ierr = 0 + ! + !--Set coefficient to convert P/rho into temperature + ! calculation will be in cgs; the mean molecular weight, gmw, will be + ! included in the function call rather than here + ! c_s^2 = gamma*P/rho = gamma*kT/(gmw*m_p) -> T = P/rho * (gmw*m_p)/k + ! + temperature_coef = unit_velocity**2 / Rg + + select case(eos_type) + case(6) + ! + !--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 + endif + + case(8) + ! + ! barotropic equation of state + ! + call init_eos_barotropic(polyk,polyk2,ierr) + + case(9) + ! + ! piecewise polytropic equation of state (similar to barotropic) + ! + call init_eos_piecewise(ierr) + + case(10) + ! + !--MESA EoS initialisation + ! + write(*,'(1x,a,f7.5,a,f7.5)') 'Initialising MESA EoS with X = ',X_in,', Z = ',Z_in + call init_eos_mesa(X_in,Z_in,ierr) + if (do_radiation .and. ierr==0) then + call error('eos','ieos=10, cannot use eos with radiation, will double count radiation pressure') + ierr=ierr_option_conflict !return error if using radiation and mesa EOS, shouldn't use mesa eos, as it will double count rad pres + endif + + case(12) + ! + ! ideal plus radiation + ! + write(*,'(1x,a,f7.5)') 'Using ideal plus radiation EoS with mu = ',gmw + if (do_radiation) then + call error('eos','ieos=12, cannot use eos with radiation, will double count radiation pressure') + ierr = ierr_option_conflict + endif + + case(15) + + call eos_helmholtz_init(ierr) + + case(16) + + call init_eos_shen_NL3(ierr) + + case(20) + + call init_eos_gasradrec(ierr) + if (.not. use_var_comp) then + write(*,'(a,f7.5,a,f7.5)') 'Assuming fixed composition X = ',X_in,', Z = ',Z_in + endif + if (do_radiation) then + call error('eos','ieos=20, cannot use eos with radiation, will double count radiation pressure') + ierr = ierr_option_conflict + endif + + case(21) + + call read_optab(eos_file,ierr) + if (ierr > 0) call fatal('init_eos','Failed to read EOS file') + call init_S07cool + + end select + done_init_eos = .true. + + if (do_radiation .and. iopacity_type==1) then + write(*,'(1x,a,f7.5,a,f7.5)') 'Using radiation with MESA opacities. Initialising MESA EoS with X = ',X_in,', Z = ',Z_in + call init_eos_mesa(X_in,Z_in,ierr_mesakapp) + ierr = max(ierr,ierr_mesakapp) + endif + +end subroutine init_eos + +!----------------------------------------------------------------------- +!+ +! finish equation of state +!+ +!----------------------------------------------------------------------- +subroutine finish_eos(eos_type,ierr) + use eos_mesa, only: finish_eos_mesa + use eos_stamatellos, only: finish_S07cool + + integer, intent(in) :: eos_type + integer, intent(out) :: ierr + + ierr = 0 + + select case(eos_type) + case(10) + ! + !--MESA EoS deallocation + ! + call finish_eos_mesa + + case(21) + ! Stamatellos deallocation + call finish_S07cool + + end select + done_init_eos=.false. + +end subroutine finish_eos + +!----------------------------------------------------------------------- +!+ +! Calculate gas temperature, sound speed, and pressure. +! This will be required for various analysis routines if eos_vars +! is not saved in the dump files +!+ +!----------------------------------------------------------------------- +subroutine get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi,spsoundi,gammai,mui,Xi,Zi) + use dim, only:maxvxyzu + integer, intent(in) :: eos_type + real, intent(in) :: vxyzui(:),xyzi(:),rhoi + real, intent(inout) :: tempi + real, intent(out), optional :: presi,spsoundi + real, intent(inout), optional :: gammai,mui + real, intent(in), optional :: Xi,Zi + real :: csi,ponrhoi,mu,X,Z + logical :: use_gamma + + mu = gmw + X = X_in + Z = Z_in + if (present(mui)) mu = mui + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + use_gamma = .false. + if (present(gammai)) then + if (gammai > 0.) use_gamma = .true. + endif + + if (maxvxyzu==4) then + 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) + else + call equationofstate(eos_type,ponrhoi,csi,rhoi,xyzi(1),xyzi(2),xyzi(3),tempi,vxyzui(4),& + mu_local=mu,Xlocal=X,Zlocal=Z) + endif + else + call equationofstate(eos_type,ponrhoi,csi,rhoi,xyzi(1),xyzi(2),xyzi(3),tempi,mu_local=mu) + endif + + if (present(presi)) presi = ponrhoi*rhoi + if (present(spsoundi)) spsoundi = csi + if (present(mui)) mui = mu + if (present(gammai)) gammai = gamma + +end subroutine get_TempPresCs + +!----------------------------------------------------------------------- +!+ +! Wrapper function to calculate sound speed +!+ +!----------------------------------------------------------------------- +real function get_spsound(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) + integer, intent(in) :: eos_type + real, intent(in) :: xyzi(:),rhoi + real, intent(in) :: vxyzui(:) + real, intent(in), optional :: Xi,Zi + real, intent(inout), optional :: gammai,mui + real :: spsoundi,tempi,gam,mu,X,Z + + !set defaults for variables not passed in + mu = gmw + X = X_in + Z = Z_in + tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess + gam = -1. ! to indicate gamma is not being passed in + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + if (present(gammai)) gam = gammai + if (present(mui)) mu = mui + + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,spsoundi=spsoundi,gammai=gam,mui=mu,Xi=X,Zi=Z) + + get_spsound = spsoundi + + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + +end function get_spsound + +!----------------------------------------------------------------------- +!+ +! Wrapper function to calculate temperature +!+ +!----------------------------------------------------------------------- +real function get_temperature(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) + integer, intent(in) :: eos_type + real, intent(in) :: xyzi(:),rhoi + real, intent(in) :: vxyzui(:) + real, intent(in), optional :: Xi,Zi + real, intent(inout),optional :: gammai,mui + real :: tempi,gam,mu,X,Z + + !set defaults for variables not passed in + mu = gmw + X = X_in + Z = Z_in + tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess + gam = -1. ! to indicate gamma is not being passed in + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + if (present(gammai)) gam = gammai + if (present(mui)) mu = mui + + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,gammai=gam,mui=mu,Xi=X,Zi=Z) + + get_temperature = tempi + + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + +end function get_temperature + + +!----------------------------------------------------------------------- +!+ +! Wrapper function to calculate temperature +!+ +!----------------------------------------------------------------------- +real function get_temperature_from_u(eos_type,xpi,ypi,zpi,rhoi,ui,gammai,mui,Xi,Zi) + integer, intent(in) :: eos_type + real, intent(in) :: xpi,ypi,zpi,rhoi + real, intent(in) :: ui + real, intent(in), optional :: Xi,Zi + real, intent(inout),optional :: gammai,mui + real :: tempi,gam,mu,X,Z + real :: vxyzui(4),xyzi(3) + + !set defaults for variables not passed in + mu = gmw + X = X_in + Z = Z_in + tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess + gam = -1. ! to indicate gamma is not being passed in + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + if (present(gammai)) gam = gammai + if (present(mui)) mu = mui + + vxyzui = (/0.,0.,0.,ui/) + xyzi = (/xpi,ypi,zpi/) + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,gammai=gam,mui=mu,Xi=X,Zi=Z) + + get_temperature_from_u = tempi + + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + + +end function get_temperature_from_u +!----------------------------------------------------------------------- +!+ +! Wrapper function to calculate pressure +!+ +!----------------------------------------------------------------------- +real function get_pressure(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) + integer, intent(in) :: eos_type + real, intent(in) :: xyzi(:),rhoi,vxyzui(:) + real, intent(in), optional :: Xi,Zi + real, intent(inout),optional :: gammai,mui + real :: presi,tempi,gam,mu,X,Z + + !set defaults for variables not passed in + mu = gmw + X = X_in + Z = Z_in + tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess + gam = -1. ! to indicate gamma is not being passed in + if (present(mui)) mu = mui + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + if (present(gammai)) gam = gammai + if (present(mui)) mu = mui + + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi=presi,gammai=gam,mui=mu,Xi=X,Zi=Z) + + get_pressure = presi + + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + +end function get_pressure + +!----------------------------------------------------------------------- +!+ +! query function to return the internal energy for calculations with a +! local mean molecular weight and local adiabatic index +!+ +!----------------------------------------------------------------------- +real function get_local_u_internal(gammai, gmwi, gas_temp_local) + real, intent(in) :: gammai, gmwi, gas_temp_local + real :: ponrhoi + + ponrhoi = gas_temp_local/(gmwi*temperature_coef) + get_local_u_internal = ponrhoi/(gammai-1.) + +end function get_local_u_internal + +!----------------------------------------------------------------------- +!+ +! get u from rho, T +!+ +!----------------------------------------------------------------------- +real function get_u_from_rhoT(rho,temp,eos_type,uguess) result(u) + use eos_mesa, only:get_eos_u_from_rhoT_mesa + integer, intent(in) :: eos_type + real, intent(in) :: rho,temp + real, intent(in), optional :: uguess + + select case (eos_type) + case(10) ! MESA EoS + if (present(uguess)) then + call get_eos_u_from_rhoT_mesa(rho,temp,u,uguess) + else + call get_eos_u_from_rhoT_mesa(rho,temp,u) + endif + + case default + u = temp/(gmw*temperature_coef*(gamma-1.)) + end select + +end function get_u_from_rhoT + +!----------------------------------------------------------------------- +!+ +! Get recombination energy (per unit mass) assumming complete +! ionisation +!+ +!----------------------------------------------------------------------- +subroutine calc_rec_ene(XX,YY,e_rec) + real, intent(in) :: XX, YY + real, intent(out) :: e_rec + real :: e_H2,e_HI,e_HeI,e_HeII + real, parameter :: e_ion_H2 = 1.312e13, & ! ionisation energies in erg/mol + e_ion_HI = 4.36e12, & + e_ion_HeI = 2.3723e13, & + e_ion_HeII = 5.2505e13 + + ! XX : Hydrogen mass fraction + ! YY : Helium mass fraction + ! e_rec : Total ionisation energy due to H2, HI, HeI, and HeII + + e_H2 = 0.5 * XX * e_ion_H2 + e_HI = XX * e_ion_HI + e_HeI = 0.25 * YY * e_ion_HeI + e_HeII = 0.25 * YY * e_ion_HeII + e_rec = e_H2 + e_HI + e_HeI + e_HeII + +end subroutine calc_rec_ene + +!----------------------------------------------------------------------- +!+ +! Calculate temperature and specific internal energy from +! pressure and density. Inputs and outputs are in cgs units. +! +! Note on composition: +! For ieos=2, 5 and 12, mu_local is an input, X & Z are not used +! For ieos=10, mu_local is not used +! For ieos=20, mu_local is not used but available as an output +!+ +!----------------------------------------------------------------------- +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 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 + integer, intent(in) :: eos_type + real, intent(in) :: rho,pres + real, intent(inout) :: ene,temp + real, intent(in), optional :: guesseint,X_local,Z_local + real, intent(inout), optional :: mu_local + integer, intent(out) :: ierr + real :: mu,X,Z + + ierr = 0 + mu = gmw + X = X_in + Z = Z_in + if (present(mu_local)) mu = mu_local + if (present(X_local)) X = X_local + if (present(Z_local)) Z = Z_local + select case(eos_type) + case(2,5) ! Ideal gas + temp = pres / (rho * kb_on_mh) * mu + ene = pres / ( (gamma-1.) * rho) + case(12) ! Ideal gas + radiation + call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) + call get_idealplusrad_enfromtemp(rho,temp,mu,ene) + case(10) ! MESA EoS + call get_eos_eT_from_rhop_mesa(rho,pres,ene,temp,guesseint) + case(20) ! Ideal gas + radiation + recombination (from HORMONE, Hirai et al., 2020) + call calc_uT_from_rhoP_gasradrec(rho,pres,X,1.-X-Z,temp,ene,mu,ierr) + if (present(mu_local)) mu_local = mu + case default + ierr = 1 + end select + +end subroutine calc_temp_and_ene + +!----------------------------------------------------------------------- +!+ +! Calculate density from pressure and temperature. Inputs and outputs +! are in cgs units. +! +! Note on composition: +! For ieos=2 and 12, mu_local is an input, X & Z are not used +! For ieos=10, mu_local is not used +! For ieos=20, mu_local is not used but available as an output +!+ +!----------------------------------------------------------------------- +subroutine calc_rho_from_PT(eos_type,pres,temp,rho,ierr,mu_local,X_local,Z_local) + use physcon, only:kb_on_mh + 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 + integer, intent(in) :: eos_type + real, intent(in) :: pres,temp + real, intent(inout) :: rho + real, intent(in), optional :: X_local,Z_local + real, intent(inout), optional :: mu_local + integer, intent(out) :: ierr + real :: mu,X,Z + + ierr = 0 + mu = gmw + X = X_in + Z = Z_in + if (present(mu_local)) mu = mu_local + if (present(X_local)) X = X_local + if (present(Z_local)) Z = Z_local + select case(eos_type) + case(2) ! Ideal gas + rho = pres / (temp * kb_on_mh) * mu + case(12) ! Ideal gas + radiation + call get_idealplusrad_rhofrompresT(pres,temp,mu,rho) + case default + ierr = 1 + end select + +end subroutine calc_rho_from_PT + +!----------------------------------------------------------------------- +!+ +! Calculates specific entropy (gas + radiation + recombination) +! up to an additive integration constant, from density and pressure. +!+ +!----------------------------------------------------------------------- +function entropy(rho,pres,mu_in,ientropy,eint_in,ierr) + use io, only:fatal,warning + use physcon, only:radconst,kb_on_mh + 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 + integer, intent(in) :: ientropy + integer, intent(out), optional :: ierr + real :: mu,entropy,logentropy,temp,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) + + ! check temp + if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') + + case(2) ! Include both gas and radiation entropy (up to additive constants) + temp = pres * mu / (rho * kb_on_mh) ! Guess for temp + 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) + + ! check temp + if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') + + 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') + + if (present(eint_in)) then + eint = eint_in + else + call get_eos_eT_from_rhop_mesa(rho,pres,eint,temp) + endif + + ! Get entropy from rho and eint from MESA tables + if (present(ierr)) then + call getvalue_mesa(rho,eint,9,logentropy,ierr) + else + call getvalue_mesa(rho,eint,9,logentropy) + endif + entropy = 10.**logentropy + + case default + entropy = 0. + call fatal('eos','Unknown ientropy (can only be 1, 2, or 3)') + end select + +end function entropy + +real function get_entropy(rho,pres,mu_in,ieos) + use units, only:unit_density,unit_pressure,unit_ergg + use physcon, only:kboltz + integer, intent(in) :: ieos + real, intent(in) :: rho,pres,mu_in + real :: cgsrho,cgspres,cgss + + cgsrho = rho * unit_density + cgspres = pres * unit_pressure + select case (ieos) + case (12) + cgss = entropy(cgsrho,cgspres,mu_in,2) + case (10, 20) + cgss = entropy(cgsrho,cgspres,mu_in,3) + case default + cgss = entropy(cgsrho,cgspres,mu_in,1) + end select + cgss = cgss/kboltz ! s/kb + get_entropy = cgss/unit_ergg + +end function get_entropy + +!----------------------------------------------------------------------- +!+ +! Calculate density given pressure and entropy using Newton-Raphson +! method +!+ +!----------------------------------------------------------------------- +subroutine get_rho_from_p_s(pres,S,rho,mu,rhoguess,ientropy) + real, intent(in) :: pres,S,mu,rhoguess + real, intent(inout) :: rho + real :: srho,srho_plus_dsrho,S_plus_dS,dSdsrho + real(kind=8) :: corr + real, parameter :: eoserr=1e-9,dfac=1e-12 + integer, intent(in) :: ientropy + + ! We apply the Newton-Raphson method directly to rho^1/2 ("srho") instead + ! of rho since S(rho) cannot take a negative argument. + srho = sqrt(rhoguess) ! Initial guess + corr = huge(corr); + do while (abs(corr) > eoserr*abs(srho)) + ! First calculate dS/dsrho + srho_plus_dsrho = srho * (1. + dfac) + S_plus_dS = entropy(srho_plus_dsrho**2,pres,mu,ientropy) + dSdsrho = (S_plus_dS - entropy(srho**2,pres,mu,ientropy)) / (srho_plus_dsrho - srho) + corr = ( entropy(srho**2,pres,mu,ientropy) - S ) / dSdsrho + srho = srho - corr + enddo + rho = srho**2 + +end subroutine get_rho_from_p_s + +!----------------------------------------------------------------------- +!+ +! Calculate temperature given density and entropy using Newton-Raphson +! method +!+ +!----------------------------------------------------------------------- +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 io, only:fatal + use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_pres + use units, only:unit_density,unit_pressure,unit_ergg + real, intent(in) :: S,mu,rho + real, intent(inout) :: temp + real, intent(out) :: P + integer, intent(in) :: ieos + real :: corr,df,f,temp_new,cgsrho,cgsp,cgss + real, parameter :: eoserr=1e-12 + integer :: niter + integer, parameter :: nitermax = 1000 + + ! change to cgs unit + cgsrho = rho*unit_density + cgss = s*unit_ergg + + niter = 0 + select case (ieos) + case (2,5) + temp = (cgsrho * exp(mu*cgss*mass_proton_cgs))**(2./3.) + cgsP = cgsrho*kb_on_mh*temp / mu + case (12) + corr = huge(corr) + do while (abs(corr) > eoserr .and. niter < nitermax) + f = 1. / (mu*mass_proton_cgs) * log(temp**1.5/cgsrho) + 4.*radconst*temp**3 / (3.*cgsrho*kboltz) - cgss + df = 1.5 / (mu*temp*mass_proton_cgs) + 4.*radconst*temp**2 / (cgsrho*kboltz) + corr = f/df + temp_new = temp - corr + if (temp_new > 1.2 * temp) then + temp = 1.2 * temp + elseif (temp_new < 0.8 * temp) then + temp = 0.8 * temp + else + temp = temp_new + endif + niter = niter + 1 + enddo + call get_idealplusrad_pres(cgsrho,temp,mu,cgsP) + case default + cgsP = 0. + call fatal('eos','[get_p_from_rho_s] only implemented for eos 2 and 12') + end select + + ! check temp + if (temp > huge(0.)) call fatal('entropy','entropy too large gives infinte temperature, & + &reducing entropy factor C_ent for one dump') + + ! change back to code unit + P = cgsP / unit_pressure + +end subroutine get_p_from_rho_s + +!----------------------------------------------------------------------- +!+ +! Calculate mean molecular weight from X and Z, assuming complete +! ionisation +!+ +!----------------------------------------------------------------------- +real function get_mean_molecular_weight(XX,ZZ) result(mu) + real, intent(in) :: XX,ZZ + real :: YY + + YY = 1.-XX-ZZ + mu = 1./(2.*XX + 0.75*YY + 0.5*ZZ) + +end function get_mean_molecular_weight + +!--------------------------------------------------------- +!+ +! return cv from rho, u in code units +!+ +!--------------------------------------------------------- +real function get_cv(rho,u,cv_type) result(cv) + use mesa_microphysics, only:getvalue_mesa + use units, only:unit_ergg,unit_density + use physcon, only:Rg + real, intent(in) :: rho,u + integer, intent(in) :: cv_type + real :: rho_cgs,u_cgs,temp + + select case (cv_type) + + case(1) ! MESA EoS + rho_cgs = rho*unit_density + u_cgs = u*unit_ergg + call getvalue_mesa(rho_cgs,u_cgs,4,temp) + cv = u_cgs/temp / unit_ergg + case default ! constant cv + cv = Rg/((gamma-1.)*gmw*unit_ergg) + end select + +end function get_cv + +!----------------------------------------------------------------------- +!+ +! subroutine sets polyk based on utherm/positions +! read from an sphNG dump file +!+ +!----------------------------------------------------------------------- +subroutine setpolyk(eos_type,iprint,utherm,xyzhi,npart) + use part, only:xyzmh_ptmass + use io, only:id,master + integer, intent(in) :: eos_type,iprint + real, intent(in) :: utherm(:) + real, intent(in) :: xyzhi(:,:) + integer, intent(in) :: npart + integer :: ipart + real :: r2,polykalt + + !-- pick a random particle from which to extract polyk + ipart = npart/2 + + select case(eos_type) + case(1,8) +! +!--isothermal eos +! + polykalt = 2./3.*utherm(ipart) + !--check all other utherms identical + if (any(utherm(1:npart) /= utherm(ipart)) .and. id==master) then + write(iprint,*) 'WARNING! different utherms but run is isothermal' + endif + + case(2,5) +! +!--adiabatic/polytropic eos +! this routine is ONLY called if utherm is NOT stored, so polyk matters +! + if (id==master) write(iprint,*) 'Using polytropic equation of state, gamma = ',gamma + polykalt = 2./3.*utherm(ipart) + if (gamma <= 1.00000001) then + stop 'silly to use gamma==1 without using isothermal eos' + endif + + case(3) +! +!--locally isothermal disc as in Lodato & Pringle (2007) +! cs = cs_0*R^(-q) -- polyk is cs^2, so this is (R^2)^(-q) +! + r2 = xyzhi(1,ipart)*xyzhi(1,ipart) + xyzhi(2,ipart)*xyzhi(2,ipart) & + + xyzhi(3,ipart)*xyzhi(3,ipart) + polykalt = 2./3.*utherm(ipart)*r2**qfacdisc + + case(6) +! +!--locally isothermal disc as in Lodato & Pringle (2007), centered on specified sink particle +! cs = cs_0*R^(-q) -- polyk is cs^2, so this is (R^2)^(-q) +! + r2 = (xyzhi(1,ipart)-xyzmh_ptmass(1,isink))**2 + & + (xyzhi(2,ipart)-xyzmh_ptmass(2,isink))**2 + & + (xyzhi(3,ipart)-xyzmh_ptmass(3,isink))**2 + + polykalt = 2./3.*utherm(ipart)*r2**qfacdisc + case default +! +!--don't die in this routine as it can be called from readdump +! (ie. not necessarily as part of a run) +! + if (id==master) write(iprint,*) ' WARNING! unknown equation of state in setpolyk' + polykalt = polyk + + end select + + if (diff(polykalt,polyk) .and. id==master) then + write(iprint,*) 'WARNING! polyk set using RK2 in dump differs from that set using thermal energy' + write(iprint,*) 'using polyk = ',polykalt, ' (from RK2 = ',polyk,')' + endif + polyk = polykalt +! +!--warn if polyk is zero, die if negative +! + if (polyk < 0.) then + write(iprint,*) 'ERROR: polyk < 0 in setting equation of state' + stop + elseif (polyk < tiny(polyk) .and. id==master) then + write(iprint,*) 'WARNING: polyk = 0 in equation of state' + endif + +end subroutine setpolyk +!----------------------------------------------------------------------- +!+ +! small utility returns whether two real numbers differ +!+ +!----------------------------------------------------------------------- +logical pure function diff(r1,r2) + real, intent(in) :: r1,r2 + + diff = abs(r1-r2) > tiny(r1) + +end function diff + +!----------------------------------------------------------------------- +!+ +! Query function to return whether an EoS is non-ideal +! Mainly used to decide whether it is necessary to write +! things like pressure and temperature in the dump file or not +!+ +!----------------------------------------------------------------------- +logical function eos_is_non_ideal(ieos) + integer, intent(in) :: ieos + + select case(ieos) + case(10,12,15,20) + eos_is_non_ideal = .true. + case default + eos_is_non_ideal = .false. + end select + +end function eos_is_non_ideal + +!----------------------------------------------------------------------- +!+ +! Query function to return whether an EoS outputs mean molecular weight +!+ +!----------------------------------------------------------------------- +logical function eos_outputs_mu(ieos) + integer, intent(in) :: ieos + + select case(ieos) + case(20) + eos_outputs_mu = .true. + case default + eos_outputs_mu = .false. + end select + +end function eos_outputs_mu + +!----------------------------------------------------------------------- +!+ +! Query function to whether to print pressure to dump file +!+ +!----------------------------------------------------------------------- +logical function eos_outputs_gasP(ieos) + integer, intent(in) :: ieos + + select case(ieos) + case(8,9,10,15) + eos_outputs_gasP = .true. + case default + eos_outputs_gasP = .false. + end select + +end function eos_outputs_gasP + +!----------------------------------------------------------------------- +!+ +! prints equation of state info in the run header +!+ +!----------------------------------------------------------------------- +subroutine eosinfo(eos_type,iprint) + use dim, only:maxvxyzu + use io, only:fatal,id,master + use eos_helmholtz, only:eos_helmholtz_eosinfo + use eos_barotropic, only:eos_info_barotropic + use eos_piecewise, only:eos_info_piecewise + use eos_gasradrec, only:eos_info_gasradrec + integer, intent(in) :: eos_type,iprint + + if (id/=master) return + + select case(eos_type) + case(1,11) + if (1.0d-5 < polyk .and. polyk < 1.0d3) then + write(iprint,"(/,a,f10.6)") ' Isothermal equation of state: cs^2 = ',polyk + else + write(iprint,"(/,a,Es13.6)") ' Isothermal equation of state: cs^2 = ',polyk + endif + if (eos_type==11) write(iprint,*) ' (ZERO PRESSURE) ' + case(2) + if (maxvxyzu >= 4) then + write(iprint,"(/,a,f10.6,a,f10.6)") ' Adiabatic equation of state: P = (gamma-1)*rho*u, gamma = ',& + gamma,' gmw = ',gmw + else + write(iprint,"(/,a,f10.6,a,f10.6,a,f10.6)") ' Polytropic equation of state: P = ',polyk,'*rho^',gamma,' gmw = ',gmw + endif + case(3) + write(iprint,"(/,a,f10.6,a,f10.6)") ' Locally isothermal eq of state (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc + case(5) + if (maxvxyzu >= 4) then + write(iprint,"(' Adiabatic equation of state: P = (gamma-1)*rho*u, where gamma & mu depend on the formation of H2')") + else + stop '[stop eos] eos = 5 cannot assume isothermal conditions' + endif + case(6) + write(iprint,"(/,a,i2,a,f10.6,a,f10.6)") ' Locally (on sink ',isink, & + ') isothermal eos (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc + case(8) + call eos_info_barotropic(polyk,polyk2,iprint) + case(9) + call eos_info_piecewise(iprint) + case(10) + write(iprint,"(/,a,f10.6,a,f10.6,a,f10.6,a)") ' MESA EoS: X = ',X_in,' Z = ',Z_in,' (1-X-Z = ',1.-X_in-Z_in,')' + case(12) + write(iprint,"(/,a,f10.6,a,f10.6)") ' Gas + radiation equation of state: gmw = ',gmw,' gamma = ',gamma + case(15) + call eos_helmholtz_eosinfo(iprint) + case(20) + call eos_info_gasradrec(iprint) + if (use_var_comp) then + write(*,'(1x,a,i1,a)') 'Using variable composition' + else + write(*,'(1x,a,f10.6,a,f10.6)') 'Using fixed composition X = ',X_in,", Z = ",Z_in + endif + end select + write(iprint,*) + +end subroutine eosinfo + +!----------------------------------------------------------------------- +!+ +! write relevant options to the header of the dump file +!+ +!----------------------------------------------------------------------- +subroutine write_headeropts_eos(ieos,hdr,ierr) + use dump_utils, only:dump_h,add_to_rheader,add_to_iheader + integer, intent(in) :: ieos + type(dump_h), intent(inout) :: hdr + integer, intent(out) :: ierr + + call add_to_iheader(isink,'isink',hdr,ierr) + call add_to_rheader(gamma,'gamma',hdr,ierr) + call add_to_rheader(1.5*polyk,'RK2',hdr,ierr) + call add_to_rheader(polyk2,'polyk2',hdr,ierr) + call add_to_rheader(qfacdisc,'qfacdisc',hdr,ierr) + call add_to_rheader(qfacdisc2,'qfacdisc2',hdr,ierr) + + if (ieos==7) then + call add_to_iheader(istrat,'istrat',hdr,ierr) + call add_to_rheader(alpha_z,'alpha_z',hdr,ierr) + call add_to_rheader(beta_z,'beta_z',hdr,ierr) + call add_to_rheader(z0,'z0',hdr,ierr) + endif + +end subroutine write_headeropts_eos + +!----------------------------------------------------------------------- +!+ +! read relevant options from the header of the dump file +!+ +!----------------------------------------------------------------------- +subroutine read_headeropts_eos(ieos,hdr,ierr) + use dump_utils, only:dump_h, extract + use io, only:iprint,id,master + use dim, only:use_krome,maxvxyzu + integer, intent(in) :: ieos + type(dump_h), intent(in) :: hdr + integer, intent(out) :: ierr + real :: RK2 + + + call extract('gamma',gamma,hdr,ierr) + call extract('RK2',rk2,hdr,ierr) + polyk = 2./3.*rk2 + if (id==master) then + if (maxvxyzu >= 4) then + if (use_krome) then + write(iprint,*) 'KROME eos: initial gamma = 1.666667' + else + write(iprint,*) 'adiabatic eos: gamma = ',gamma + endif + else + write(iprint,*) 'setting isothermal sound speed^2 (polyk) = ',polyk,' gamma = ',gamma + if (polyk <= tiny(polyk)) write(iprint,*) 'WARNING! sound speed zero in dump!, polyk = ',polyk + endif + endif + call extract('polyk2',polyk2,hdr,ierr) + call extract('qfacdisc',qfacdisc,hdr,ierr) + call extract('qfacdisc2',qfacdisc2,hdr,ierr) + call extract('isink',isink,hdr,ierr) + + if (abs(gamma-1.) > tiny(gamma) .and. maxvxyzu < 4) then + write(*,*) 'WARNING! compiled for isothermal equation of state but gamma /= 1, gamma=',gamma + endif + + ierr = 0 + if (ieos==3 .or. ieos==6 .or. ieos==7) then + if (qfacdisc <= tiny(qfacdisc)) then + if (id==master) write(iprint,*) 'ERROR: qfacdisc <= 0' + ierr = 2 + else + if (id==master) write(iprint,*) 'qfacdisc = ',qfacdisc + endif + endif + + if (ieos==7) then + call extract('istrat',istrat,hdr,ierr) + call extract('alpha_z',alpha_z,hdr,ierr) + call extract('beta_z', beta_z, hdr,ierr) + call extract('z0',z0,hdr,ierr) + if (abs(qfacdisc2) <= tiny(qfacdisc2)) then + if (id==master) write(iprint,*) 'ERROR: qfacdisc2 == 0' + ierr = 2 + else + if (id==master) write(iprint,*) 'qfacdisc2 = ',qfacdisc2 + endif + endif + +end subroutine read_headeropts_eos + +!----------------------------------------------------------------------- +!+ +! writes equation of state options to the input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_eos(iunit) + use dim, only:use_krome + use infile_utils, only:write_inopt + use eos_helmholtz, only:eos_helmholtz_write_inopt + use eos_barotropic, only:write_options_eos_barotropic + use eos_piecewise, only:write_options_eos_piecewise + use eos_gasradrec, only:write_options_eos_gasradrec + integer, intent(in) :: iunit + + write(iunit,"(/,a)") '# options controlling equation of state' + call write_inopt(ieos,'ieos','eqn of state (1=isoth;2=adiab;3=locally iso;8=barotropic)',iunit) + + if (.not.use_krome .or. .not.eos_outputs_mu(ieos)) then + call write_inopt(gmw,'mu','mean molecular weight',iunit) + endif + + select case(ieos) + case(8) + call write_options_eos_barotropic(iunit) + case(9) + call write_options_eos_piecewise(iunit) + case(10) + call write_inopt(X_in,'X','hydrogen mass fraction',iunit) + call write_inopt(Z_in,'Z','metallicity',iunit) + case(15) ! helmholtz eos + call eos_helmholtz_write_inopt(iunit) + case(20) + call write_options_eos_gasradrec(iunit) + if (.not. use_var_comp) then + call write_inopt(X_in,'X','H mass fraction (ignored if variable composition)',iunit) + call write_inopt(Z_in,'Z','metallicity (ignored if variable composition)',iunit) + endif + end select + +end subroutine write_options_eos + +!----------------------------------------------------------------------- +!+ +! reads equation of state options from the input file +!+ +!----------------------------------------------------------------------- +subroutine read_options_eos(name,valstring,imatch,igotall,ierr) + use dim, only:store_dust_temperature,update_muGamma + use io, only:fatal + use eos_barotropic, only:read_options_eos_barotropic + use eos_piecewise, only:read_options_eos_piecewise + use eos_gasradrec, only:read_options_eos_gasradrec + 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_eos' + logical :: igotall_barotropic,igotall_piecewise,igotall_gasradrec + + imatch = .true. + igotall_barotropic = .true. + igotall_piecewise = .true. + igotall_gasradrec = .true. + + select case(trim(name)) + case('ieos') + read(valstring,*,iostat=ierr) ieos + ngot = ngot + 1 + if (ieos <= 0 .or. ieos > maxeos) call fatal(label,'equation of state choice out of range') + if (ieos == 5) then + store_dust_temperature = .true. + update_muGamma = .true. + endif + if (ieos == 21) update_muGamma = .true. + case('mu') + read(valstring,*,iostat=ierr) gmw + ! not compulsory to read in + if (gmw <= 0.) call fatal(label,'mu <= 0') + case('X') + read(valstring,*,iostat=ierr) X_in + if (X_in <= 0. .or. X_in >= 1.) call fatal(label,'X must be between 0 and 1') + ngot = ngot + 1 + case('Z') + read(valstring,*,iostat=ierr) Z_in + if (Z_in <= 0. .or. Z_in > 1.) call fatal(label,'Z must be between 0 and 1') + ngot = ngot + 1 + case default + imatch = .false. + end select + if (.not.imatch .and. ieos== 8) call read_options_eos_barotropic(name,valstring,imatch,igotall_barotropic,ierr) + if (.not.imatch .and. ieos== 9) call read_options_eos_piecewise( name,valstring,imatch,igotall_piecewise, ierr) + if (.not.imatch .and. ieos==20) call read_options_eos_gasradrec( name,valstring,imatch,igotall_gasradrec, ierr) + + !--make sure we have got all compulsory options (otherwise, rewrite input file) + igotall = (ngot >= 1) .and. igotall_piecewise .and. igotall_barotropic .and. igotall_gasradrec + +end subroutine read_options_eos + + +!----------------------------------------------------------------------- + +end module eos diff --git a/src/main/tmunu2grid.f90 b/src/main/tmunu2grid.f90 index 5d41bbe10..754f63a6d 100644 --- a/src/main/tmunu2grid.f90 +++ b/src/main/tmunu2grid.f90 @@ -19,7 +19,7 @@ module tmunu2grid implicit none contains -subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) +subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus) use einsteintk_utils, only: dxgrid, gridorigin,gridsize,tmunugrid,rhostargrid use interpolations3D, only: interpolate3D,interpolate3D_vecexact use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax @@ -27,10 +27,8 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) integer, intent(in) :: npart real, intent(in) :: vxyzu(:,:), tmunus(:,:,:) real, intent(inout) :: xyzh(:,:) - logical, intent(in), optional :: calc_cfac real :: weight,h,rho,pmass real :: weights(npart) - real, save :: cfac real :: xmininterp(3) integer :: ngrid(3) real,allocatable :: datsmooth(:,:,:,:), dat(:,:) @@ -58,24 +56,17 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) ! Get density rho = rhoh(h,pmass) call get_weight(pmass,h,rho,weight) - ! Correct for Kernel Bias, find correction factor - ! Wrap this into it's own subroutine - if (present(calc_cfac)) then - if (calc_cfac) call get_cfac(cfac,rho) - endif weights = weight itype = 1 - !call get_cfac(cfac,rho) - !print*, "Weighting for particle smoothing is: ", weight - !weight = 1. + ! For now we can set this to the origin, but it might need to be ! set to the grid origin of the CCTK_grid since we have boundary points ! TODO This should also be the proper phantom values and not a magic number !xmin(:) = gridorigin(:) - 0.5*dxgrid(:) ! We move the origin back by 0.5*dx to make a pseudo cell-centered grid - xmininterp(1) = xmin -dxgrid(1) !- 0.5*dxgrid(1) - xmininterp(2) = ymin -dxgrid(2) !- 0.5*dxgrid(2) - xmininterp(3) = zmin-dxgrid(3) !- 0.5*dxgrid(3) + xmininterp(1) = xmin - dxgrid(1) !- 0.5*dxgrid(1) + xmininterp(2) = ymin - dxgrid(2) !- 0.5*dxgrid(2) + xmininterp(3) = zmin - dxgrid(3) !- 0.5*dxgrid(3) call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) @@ -97,10 +88,7 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) periodicy = .true. periodicz = .true. - - ! tt component - tmunugrid = 0. datsmooth = 0. @@ -119,7 +107,6 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) enddo enddo enddo -!stop ilendat = 16 call interpolate3D_vecexact(xyzh,weights,dat,ilendat,itype,npart,& @@ -139,113 +126,6 @@ subroutine get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac) !print*, datsmooth((i-1)*4 + j, 10,10,10) enddo enddo -!stop -! do k=1,4 -! do j=1,4 -! do i=1,4 -! print*, "Lock index is: ", (k-1)*16+ (j-1)*4 + i -! enddo -! enddo -! enddo - -! tmunugrid(0,0,:,:,:) = datsmooth(1,:,:,:) - - ! TODO Unroll this loop for speed + using symmetries - ! Possiblly cleanup the messy indexing -! do k=1,4 -! do j=1,4 -! do i=1, npart -! dat(i) = tmunus(k,j,i) -! enddo - -! ! Get the position of the first grid cell x,y,z -! ! Call to interpolate 3D -! ! COMMENTED OUT AS NOT USED BY NEW INTERPOLATE ROUTINE -! ! call interpolate3D(xyzh,weight,npart, & -! ! xmininterp,tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper), & -! ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) - -! !print*, "Interpolated grid values are: ", datsmooth(4:38,4:38,4:38) -! !stop -! ! NEW INTERPOLATION ROUTINE -! call interpolate3D(xyzh,weights,dat,itype,npart,& -! xmininterp(1),xmininterp(2),xmininterp(3), & -! tmunugrid(k-1,j-1,ilower:iupper,jlower:jupper,klower:kupper),& -! ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& -! normalise,periodicx,periodicy,periodicz) -! enddo -! enddo - - ! RHOSTARGRID CALCULATION IS NOW HANDLED BY AN EXTERNAL ROUTINE - ! THIS IS COMMENTED OUT IN CASE I BREAK EVERYTHING AND NEED TO GO BACK - ! Get the conserved density on the particles - ! dat = 0. - ! do i=1, npart - ! ! Get the smoothing length - ! h = xyzh(4,i) - ! ! Get pmass - ! pmass = massoftype(igas) - ! rho = rhoh(h,pmass) - ! dat(i) = rho - ! enddo - - ! Commented out as not used by new interpolate routine - ! call interpolate3D(xyzh,weight,npart, & - ! xmininterp,rhostargrid(ilower:iupper,jlower:jupper,klower:kupper), & - ! nnodes,dxgrid,.true.,dat,ngrid,vertexcen) - - - ! Calculate the total mass on the grid - !totalmassgrid = 0. - ! do i=ilower,iupper - ! do j=jlower,jupper - ! do k=klower, kupper - ! totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) - - ! enddo - ! enddo - ! enddo - ! Explicitly set pressure to be 0 - ! Need to do this in the phantom setup file later - ! tmunugrid(1,0:3,:,:,:) = 0. - ! tmunugrid(2,0:3,:,:,:) = 0. - ! tmunugrid(3,0:3,:,:,:) = 0. - !tmunugrid(0,0,:,:,:) = tmunus(1,1,1) - ! Correction for kernel bias code - ! Hardcoded values for the cubic spline computed using - ! a constant density flrw universe. - ! Ideally this should be in a more general form - ! cfac = totalmass/totalmassgrid - ! ! Output total mass on grid, total mass on particles - ! ! and the residuals - ! !cfac = 0.99917535781746514D0 - ! tmunugrid = tmunugrid*cfac - ! if (iteration==0) then - ! write(666,*) "iteration ", "Mass(Grid) ", "Mass(Particles) ", "Mass(Grid-Particles)" - ! endif - ! write(666,*) iteration, totalmassgrid, totalmass, abs(totalmassgrid-totalmass) - ! close(unit=666) - ! iteration = iteration + 1 - - ! New rho/smoothing length calc based on correction?? - ! not sure that this is a valid thing to do - ! do i=1, npart - ! rho = rhoh(xyzh(i,4),pmass) - ! rho = rho*cfac - ! xyzh(i,4) = hfact*(pmass/rho)**(1./3.) - - ! enddo - - ! Correct rhostargrid using cfac - !rhostargrid = cfac*rhostargrid - - ! Calculate rho(prim), P and e on the grid - ! Apply kernel correction to primatives?? - ! Then calculate a stress energy tensor per grid and fill tmunu - ! A good consistency check would be to do it both ways and compare values - - ! Primative density - end subroutine get_tmunugrid_all @@ -257,38 +137,6 @@ subroutine get_weight(pmass,h,rhoi,weight) end subroutine get_weight -subroutine get_dat(tmunus,dat) - real, intent(in) :: tmunus - real, intent(out) :: dat - -end subroutine get_dat - - ! subroutine get_primdens(dens,dat) - ! real, intent(in) :: dens - ! real, intent(out) :: dat - ! integer :: i, npart - - ! ! Get the primative density on the particles - ! dat = 0. - ! do i=1, npart - ! dat(i) = dens(i) - ! enddo - - ! end subroutine get_primdens - - ! subroutine get_4velocity(vxyzu,dat) - ! real, intent(in) :: vxyzu(:,:) - ! real, intent(out) :: dat(:,:) - ! integer :: i,npart - - ! ! Get the primative density on the particles - ! dat = 0. - ! do i=1, npart - ! dat(:,i) = vxyzu(1:3,i) - ! enddo - - ! end subroutine get_4velocity - subroutine get_particle_domain(gridorigin,xmin,xmax,dxgrid,ilower,iupper) real, intent(in) :: gridorigin, xmin,xmax, dxgrid integer, intent(out) :: ilower, iupper @@ -301,23 +149,12 @@ subroutine get_particle_domain(gridorigin,xmin,xmax,dxgrid,ilower,iupper) ! domain but the upper is not; can't have both? end subroutine get_particle_domain -subroutine get_cfac(cfac,rho) - real, intent(in) :: rho - real, intent(out) :: cfac - real :: rhoexact - rhoexact = 13.294563008157013D0 - cfac = rhoexact/rho - -end subroutine get_cfac - subroutine interpolate_to_grid(gridarray,dat) use einsteintk_utils, only: dxgrid, gridorigin use interpolations3D, only: interpolate3D use boundary, only: xmin,ymin,zmin,xmax,ymax,zmax use part, only:npart,xyzh,massoftype,igas,rhoh real :: weight,h,rho,pmass - !real, save :: cfac - !integer, save :: iteration = 0 real :: xmininterp(3) integer :: ngrid(3) integer :: nnodes,i, ilower, iupper, jlower, jupper, klower, kupper @@ -329,7 +166,6 @@ subroutine interpolate_to_grid(gridarray,dat) real, intent(in) :: dat(:) ! The particle data to interpolate to grid real, allocatable :: interparray(:,:,:) - xmininterp(1) = xmin - dxgrid(1)!- 0.5*dxgrid(1) xmininterp(2) = ymin - dxgrid(2) !- 0.5*dxgrid(2) xmininterp(3) = zmin - dxgrid(3) !- 0.5*dxgrid(3) @@ -355,8 +191,6 @@ subroutine interpolate_to_grid(gridarray,dat) periodicy = .true. periodicz = .true. - - do i=1, npart h = xyzh(4,i) ! Get pmass @@ -372,26 +206,21 @@ subroutine interpolate_to_grid(gridarray,dat) ! nnodes,dxgrid,normalise,dat,ngrid,vertexcen) call interpolate3D(xyzh,weights,dat,itype,npart,& xmininterp(1),xmininterp(2),xmininterp(3), & - !interparray, & gridarray(ilower:iupper,jlower:jupper,klower:kupper),& ngrid(1),ngrid(2),ngrid(3),dxgrid(1),dxgrid(2),dxgrid(3),& normalise,periodicx,periodicy,periodicz) - - - end subroutine interpolate_to_grid subroutine check_conserved_dens(rhostargrid,cfac) use part, only:npart,massoftype,igas use einsteintk_utils, only: dxgrid, gridorigin use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax - real, intent(in) :: rhostargrid(:,:,:) - real(kind=16), intent(out) :: cfac + real, intent(in) :: rhostargrid(:,:,:) + real, intent(out) :: cfac real :: totalmassgrid,totalmasspart integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper - call get_particle_domain(gridorigin(1),xmin,xmax,dxgrid(1),ilower,iupper) call get_particle_domain(gridorigin(2),ymin,ymax,dxgrid(2),jlower,jupper) call get_particle_domain(gridorigin(3),zmin,zmax,dxgrid(3),klower,kupper) @@ -401,7 +230,6 @@ subroutine check_conserved_dens(rhostargrid,cfac) do j=jlower,jupper do k=klower, kupper totalmassgrid = totalmassgrid + dxgrid(1)*dxgrid(2)*dxgrid(3)*rhostargrid(i,j,k) - enddo enddo enddo @@ -422,8 +250,8 @@ subroutine check_conserved_p(pgrid,cfac) use part, only:npart,massoftype,igas use einsteintk_utils, only: dxgrid, gridorigin use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax - real, intent(in) :: pgrid(:,:,:) - real(kind=16), intent(out) :: cfac + real, intent(in) :: pgrid(:,:,:) + real, intent(out) :: cfac real :: totalmomentumgrid,totalmomentumpart integer :: i,j,k,ilower,iupper,jlower,jupper,klower,kupper diff --git a/src/main/utils_dumpfiles.f90 b/src/main/utils_dumpfiles.f90 index 7691ea5c7..aef612992 100644 --- a/src/main/utils_dumpfiles.f90 +++ b/src/main/utils_dumpfiles.f90 @@ -24,7 +24,7 @@ module dump_utils public :: open_dumpfile_w, open_dumpfile_r, get_error_text public :: tag,check_tag,match_tag public :: skipblock,skip_arrays,skip_headerblock - public :: get_dumpname + public :: get_dumpname,get_dump_size public :: add_to_header,add_to_rheader,add_to_iheader public :: num_in_header,reset_header,extract public :: read_array_from_file @@ -100,6 +100,7 @@ module dump_utils public :: write_header, read_header public :: allocate_header, free_header public :: print_header + public :: get_blocklimits ! generic interface to extract quantities from header interface extract @@ -174,6 +175,23 @@ function get_dumpname(filename,id) end function get_dumpname +!-------------------------------------------------------------------- +!+ +! extract dump size (full or small) from the fileid string +!+ +!-------------------------------------------------------------------- +subroutine get_dump_size(fileid,smalldump) + character(len=lenid), intent(in) :: fileid + logical, intent(out) :: smalldump + ! + if (fileid(1:1)=='S') then + smalldump = .true. + else + smalldump = .false. + endif + +end subroutine get_dump_size + !-------------------------------------------------------------------- !+ ! small utility to skip an entire block in a file @@ -1150,9 +1168,9 @@ subroutine open_dumpfile_r(iunit,filename,fileid,ierr,singleprec,requiretags,tag !--read output file ! if (r4) then - read (iunit, iostat=ierr1) int1i,r1s,int2i,iversion_file,int3i + read (iunit,iostat=ierr1) int1i,r1s,int2i,iversion_file,int3i else - read (iunit, iostat=ierr1) int1i,r1i,int2i,iversion_file,int3i + read (iunit,iostat=ierr1) int1i,r1i,int2i,iversion_file,int3i endif if (int1i /= int1 .and. int1i /= int1o) then ierr = ierr_endian @@ -1169,7 +1187,7 @@ subroutine open_dumpfile_r(iunit,filename,fileid,ierr,singleprec,requiretags,tag ierr = ierr_version endif - read (iunit, iostat=ierr1) fileid + read (iunit,iostat=ierr1) fileid if (int2i /= int2 .and. int2i /= int2o) then ierr = ierr_realsize @@ -1253,7 +1271,7 @@ subroutine read_header(iunit,hdr,ierr,singleprec,tagged) if (present(tagged)) tags = tagged do i=1,ndatatypes - read (iunit, iostat=ierr) n + read (iunit,iostat=ierr) n if (n < 0) n = 0 hdr%nums(i) = n select case(i) @@ -1261,64 +1279,64 @@ subroutine read_header(iunit,hdr,ierr,singleprec,tagged) allocate(hdr%inttags(n),hdr%intvals(n),stat=ierr) if (n > 0) then hdr%inttags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%inttags - read(iunit, iostat=ierr) hdr%intvals + if (tags) read(iunit,iostat=ierr) hdr%inttags + read(iunit,iostat=ierr) hdr%intvals endif case(i_int1) allocate(hdr%int1tags(n),hdr%int1vals(n),stat=ierr) if (n > 0) then hdr%int1tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%int1tags - read(iunit, iostat=ierr) hdr%int1vals + if (tags) read(iunit,iostat=ierr) hdr%int1tags + read(iunit,iostat=ierr) hdr%int1vals endif case(i_int2) allocate(hdr%int2tags(n),hdr%int2vals(n),stat=ierr) if (n > 0) then hdr%int2tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%int2tags - read(iunit, iostat=ierr) hdr%int2vals + if (tags) read(iunit,iostat=ierr) hdr%int2tags + read(iunit,iostat=ierr) hdr%int2vals endif case(i_int4) allocate(hdr%int4tags(n),hdr%int4vals(n),stat=ierr) if (n > 0) then hdr%int4tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%int4tags - read(iunit, iostat=ierr) hdr%int4vals + if (tags) read(iunit,iostat=ierr) hdr%int4tags + read(iunit,iostat=ierr) hdr%int4vals endif case(i_int8) allocate(hdr%int8tags(n),hdr%int8vals(n),stat=ierr) if (n > 0) then hdr%int8tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%int8tags - read(iunit, iostat=ierr) hdr%int8vals + if (tags) read(iunit,iostat=ierr) hdr%int8tags + read(iunit,iostat=ierr) hdr%int8vals endif case(i_real) allocate(hdr%realtags(n),hdr%realvals(n),stat=ierr) if (n > 0) then hdr%realtags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%realtags + if (tags) read(iunit,iostat=ierr) hdr%realtags if (convert_prec .and. kind(0.) /= 4) then allocate(dumr4(n),stat=ierr) - read(iunit, iostat=ierr) dumr4 + read(iunit,iostat=ierr) dumr4 hdr%realvals(1:n) = real(dumr4(1:n)) deallocate(dumr4) else - read(iunit, iostat=ierr) hdr%realvals + read(iunit,iostat=ierr) hdr%realvals endif endif case(i_real4) allocate(hdr%real4tags(n),hdr%real4vals(n),stat=ierr) if (n > 0) then hdr%real4tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%real4tags - read(iunit, iostat=ierr) hdr%real4vals + if (tags) read(iunit,iostat=ierr) hdr%real4tags + read(iunit,iostat=ierr) hdr%real4vals endif case(i_real8) allocate(hdr%real8tags(n),hdr%real8vals(n),stat=ierr) if (n > 0) then hdr%real8tags(:) = '' - if (tags) read(iunit, iostat=ierr) hdr%real8tags - read(iunit, iostat=ierr) hdr%real8vals + if (tags) read(iunit,iostat=ierr) hdr%real8tags + read(iunit,iostat=ierr) hdr%real8vals endif end select enddo @@ -1588,12 +1606,12 @@ end subroutine write_header ! Write int*1 array to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_int1(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,ierr,func) +subroutine write_array_int1(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,nerr,func) integer(kind=1), intent(in) :: iarr(:) character(len=*), intent(in) :: my_tag integer, intent(in) :: ib,len,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr !procedure(integer(kind=1)), pointer, optional :: func interface integer(kind=1) pure function func(x) @@ -1602,7 +1620,7 @@ end function func end interface optional :: func !integer(kind=1), optional :: func - integer :: i + integer :: i,ierr ierr = 0 ! check if kind matches @@ -1610,14 +1628,15 @@ end function func if (ipass==1) then nums(i_int1,ib) = nums(i_int1,ib) + 1 elseif (ipass==2) then - write(iunit, iostat=ierr) tag(my_tag) + write(iunit,iostat=ierr) tag(my_tag) if (present(func)) then - write(iunit, iostat=ierr) (func(iarr(i)),i=1,len) + write(iunit,iostat=ierr) (func(iarr(i)),i=1,len) else - write(iunit, iostat=ierr) iarr(1:len) + write(iunit,iostat=ierr) iarr(1:len) endif endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_int1 @@ -1626,12 +1645,12 @@ end subroutine write_array_int1 ! Write int*4 array to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_int4(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,ierr,func) +subroutine write_array_int4(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,nerr,func) integer(kind=4), intent(in) :: iarr(:) character(len=*), intent(in) :: my_tag integer, intent(in) :: ib,len,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr !procedure(integer(kind=1)), pointer, optional :: func interface integer(kind=4) pure function func(x) @@ -1640,7 +1659,7 @@ end function func end interface optional :: func !integer(kind=1), optional :: func - integer :: i + integer :: i,ierr ierr = 0 ! check if kind matches @@ -1648,14 +1667,15 @@ end function func if (ipass==1) then nums(i_int4,ib) = nums(i_int4,ib) + 1 elseif (ipass==2) then - write(iunit, iostat=ierr) tag(my_tag) + write(iunit,iostat=ierr) tag(my_tag) if (present(func)) then - write(iunit, iostat=ierr) (func(iarr(i)),i=1,len) + write(iunit,iostat=ierr) (func(iarr(i)),i=1,len) else - write(iunit, iostat=ierr) iarr(1:len) + write(iunit,iostat=ierr) iarr(1:len) endif endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_int4 @@ -1664,12 +1684,12 @@ end subroutine write_array_int4 ! Write int*4 array to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_int8(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,ierr,func) +subroutine write_array_int8(ib,iarr,my_tag,len,ikind,ipass,iunit,nums,nerr,func) integer(kind=8), intent(in) :: iarr(:) character(len=*), intent(in) :: my_tag integer, intent(in) :: ib,len,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr !procedure(integer(kind=1)), pointer, optional :: func interface integer(kind=8) pure function func(x) @@ -1678,7 +1698,7 @@ end function func end interface optional :: func !integer(kind=1), optional :: func - integer :: i + integer :: i,ierr ierr = 0 ! check if kind matches @@ -1686,14 +1706,15 @@ end function func if (ipass==1) then nums(i_int8,ib) = nums(i_int8,ib) + 1 elseif (ipass==2) then - write(iunit, iostat=ierr) tag(my_tag) + write(iunit,iostat=ierr) tag(my_tag) if (present(func)) then - write(iunit, iostat=ierr) (func(iarr(i)),i=1,len) + write(iunit,iostat=ierr) (func(iarr(i)),i=1,len) else - write(iunit, iostat=ierr) iarr(1:len) + write(iunit,iostat=ierr) iarr(1:len) endif endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_int8 @@ -1702,12 +1723,12 @@ end subroutine write_array_int8 ! Write real*4 array to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_real4(ib,arr,my_tag,len,ikind,ipass,iunit,nums,ierr,func,use_kind,singleprec) +subroutine write_array_real4(ib,arr,my_tag,len,ikind,ipass,iunit,nums,nerr,func,use_kind,singleprec) real(kind=4), intent(in) :: arr(:) character(len=*), intent(in) :: my_tag integer, intent(in) :: ib,len,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr interface real(kind=4) pure function func(x) real(kind=4), intent(in) :: x @@ -1717,7 +1738,7 @@ end function func !real(kind=4), optional :: func integer, intent(in), optional :: use_kind logical, intent(in), optional :: singleprec - integer :: i,imatch + integer :: i,imatch,ierr ierr = 0 ! use default real if it matches, unless kind is specified @@ -1731,14 +1752,15 @@ end function func if (ipass==1) then nums(imatch,ib) = nums(imatch,ib) + 1 elseif (ipass==2) then - write(iunit, iostat=ierr) tag(my_tag) + write(iunit,iostat=ierr) tag(my_tag) if (present(func)) then - write(iunit, iostat=ierr) (func(arr(i)),i=1,len) + write(iunit,iostat=ierr) (func(arr(i)),i=1,len) else - write(iunit, iostat=ierr) arr(1:len) + write(iunit,iostat=ierr) arr(1:len) endif endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_real4 @@ -1747,12 +1769,12 @@ end subroutine write_array_real4 ! Write real*4 array to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_real8(ib,arr,my_tag,len,ikind,ipass,iunit,nums,ierr,func,use_kind,singleprec) +subroutine write_array_real8(ib,arr,my_tag,len,ikind,ipass,iunit,nums,nerr,func,use_kind,singleprec) real(kind=8), intent(in) :: arr(:) character(len=*), intent(in) :: my_tag integer, intent(in) :: ib,len,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr interface real(kind=8) pure function func(x) real(kind=8), intent(in) :: x @@ -1762,7 +1784,7 @@ end function func !real(kind=8), optional :: func integer, intent(in), optional :: use_kind logical, intent(in), optional :: singleprec - integer :: i,imatch + integer :: i,imatch,ierr logical :: use_singleprec ierr = 0 @@ -1786,18 +1808,19 @@ end function func if (ipass==1) then nums(imatch,ib) = nums(imatch,ib) + 1 elseif (ipass==2) then - write(iunit, iostat=ierr) tag(my_tag) + write(iunit,iostat=ierr) tag(my_tag) if (present(func)) then - write(iunit, iostat=ierr) (func(arr(i)),i=1,len) + write(iunit,iostat=ierr) (func(arr(i)),i=1,len) else if (imatch==i_real4 .or. use_singleprec) then - write(iunit, iostat=ierr) (real(arr(i),kind=4),i=1,len) + write(iunit,iostat=ierr) (real(arr(i),kind=4),i=1,len) else - write(iunit, iostat=ierr) arr(1:len) + write(iunit,iostat=ierr) arr(1:len) endif endif endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_real8 @@ -1807,15 +1830,15 @@ end subroutine write_array_real8 ! to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_real4arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,ierr,use_kind,index,singleprec) +subroutine write_array_real4arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,nerr,use_kind,index,singleprec) real(kind=4), intent(in) :: arr(:,:) character(len=*), intent(in) :: my_tag(:) integer, intent(in) :: ib,len1,len2,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr integer, intent(in), optional :: use_kind,index logical, intent(in), optional :: singleprec - integer :: j,i,imatch,istart,iend + integer :: j,i,imatch,istart,iend,ierr ierr = 0 ! use default real if it matches, unless kind is specified @@ -1838,11 +1861,12 @@ subroutine write_array_real4arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,i nums(imatch,ib) = nums(imatch,ib) + (iend - istart) + 1 elseif (ipass==2) then do j=istart,iend - write(iunit, iostat=ierr) tag(my_tag(j)) - write(iunit, iostat=ierr) (arr(j,i),i=1,len2) + write(iunit,iostat=ierr) tag(my_tag(j)) + write(iunit,iostat=ierr) (arr(j,i),i=1,len2) enddo endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_real4arr @@ -1852,15 +1876,15 @@ end subroutine write_array_real4arr ! to block header (ipass=1) or to file (ipass=2) !+ !--------------------------------------------------------------------- -subroutine write_array_real8arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,ierr,use_kind,index,singleprec) +subroutine write_array_real8arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,nerr,use_kind,index,singleprec) real(kind=8), intent(in) :: arr(:,:) character(len=*), intent(in) :: my_tag(:) integer, intent(in) :: ib,len1,len2,ikind,ipass,iunit integer, intent(inout) :: nums(:,:) - integer, intent(out) :: ierr + integer, intent(inout) :: nerr integer, intent(in), optional :: use_kind,index logical, intent(in), optional :: singleprec - integer :: j,i,imatch,istart,iend + integer :: j,i,imatch,istart,iend,ierr logical :: use_singleprec ierr = 0 @@ -1892,16 +1916,17 @@ subroutine write_array_real8arr(ib,arr,my_tag,len1,len2,ikind,ipass,iunit,nums,i nums(imatch,ib) = nums(imatch,ib) + (iend - istart) + 1 elseif (ipass==2) then do j=istart,iend - write(iunit, iostat=ierr) tag(my_tag(j)) + write(iunit,iostat=ierr) tag(my_tag(j)) if (imatch==i_real4 .or. use_singleprec) then !print*, "done ", my_tag(j), " | ", tag(my_tag(j)) - write(iunit, iostat=ierr) (real(arr(j,i),kind=4),i=1,len2) + write(iunit,iostat=ierr) (real(arr(j,i),kind=4),i=1,len2) else - write(iunit, iostat=ierr) (arr(j,i),i=1,len2) + write(iunit,iostat=ierr) (arr(j,i),i=1,len2) endif enddo endif endif + if (ierr /= 0) nerr = nerr + 1 end subroutine write_array_real8arr @@ -1918,7 +1943,7 @@ subroutine write_block_header(nblocks,number,nums,iunit,ierr) integer :: iblock do iblock=1,nblocks - write(iunit, iostat=ierr) number(iblock), nums(1:ndatatypes,iblock) + write(iunit,iostat=ierr) number(iblock), nums(1:ndatatypes,iblock) enddo end subroutine write_block_header @@ -1939,11 +1964,99 @@ subroutine read_block_header(nblocks,number,nums,iunit,ierr) number(:) = 0 nums(:,:) = 0 do iblock=1,nblocks - read(iunit, iostat=ierr) number(iblock), nums(1:ndatatypes,iblock) + read(iunit,iostat=ierr) number(iblock), nums(1:ndatatypes,iblock) enddo end subroutine read_block_header +!-------------------------------------------------------------------- +!+ +! utility to determine whether to read a particular block +! in the dump file, in whole or in part. +! Allows limited changes to number of threads. +!+ +!-------------------------------------------------------------------- +subroutine get_blocklimits(npartblock,nblocks,nthreads,id,iblock,noffset,npartread,ierr) + integer(kind=8), intent(in) :: npartblock + integer, intent(in) :: nblocks,nthreads,id,iblock + integer, intent(out) :: noffset,npartread,ierr + integer :: nblocksperthread,nthreadsperblock + character(len=15), parameter :: tag = 'get_blocklimits' +! +!--check for errors in input +! + ierr = 0 + if (npartblock < 0) then + write(*,*) 'get_blocklimits: block in dump file has npartinblock < 0' + ierr = 1 + elseif (npartblock > huge(npartread)) then + write(*,*) 'get_blocklimits: number of particles in block exceeds 32 bit limit' + ierr = 2 + endif + if (ierr /= 0) return +! +!--usual situation: nblocks = nprocessors +! read whole block if id = iblock +! + if (nblocks==nthreads) then + if (id==iblock-1) then + !--read whole block + npartread = int(npartblock) + noffset = 0 + else + !--do not read block + npartread = 0 + noffset = 0 + endif + + elseif (nblocks > nthreads .and. mod(nblocks,nthreads)==0) then +! +!--if more blocks than processes and nblocks exactly divisible by nthreads, +! then just read more than one block per thread +! + nblocksperthread = nblocks/nthreads + if (id==(iblock-1)/nblocksperthread) then + npartread = int(npartblock) + noffset = 0 + else + npartread = 0 + noffset = 0 + endif + + elseif (nthreads > nblocks .and. mod(nthreads,nblocks)==0) then +! +!--if more threads than blocks, and exactly divisible, read fractions of blocks only +! + nthreadsperblock = nthreads/nblocks + if (id/nthreadsperblock==iblock-1) then + npartread = int((npartblock-1)/nthreadsperblock) + 1 + noffset = mod(id,nthreadsperblock)*npartread + + if (mod(id,nthreadsperblock)==nthreadsperblock-1) then + !--last thread has remainder for non-exactly divisible numbers of particles + npartread = int(npartblock) - (nthreadsperblock-1)*npartread + !--die if we would need to load balance between more than the last processor. + if (npartread < 0) then + print*,' npart to read from last block =',npartread + print*,trim(tag)//' error assigning npart to last thread' + ierr = 3 + return + endif + endif + else + npartread = 0 + noffset = 0 + endif + else + noffset = 0 + npartread = 0 + ierr = 4 + print*,' ERROR: rearrangement of ',nblocks,' blocks to ',nthreads,' threads not implemented' + return + endif + +end subroutine get_blocklimits + !-------------------------------------------------------------------- !+ ! Routine for extracting int*1 array from main block in dump files @@ -2286,7 +2399,7 @@ subroutine open_dumpfile_rh(iunit,filename,nblocks,narraylengths,ierr,singleprec if (ierr /= 0) return enddo - read (iunit, iostat=ierr) number + read (iunit,iostat=ierr) number if (ierr /= 0) return narraylengths = number/nblocks @@ -2332,17 +2445,17 @@ subroutine read_array_from_file_r8(iunit,filename,tag,array,ierr,use_block) !print*,' data type ',i,' arrays = ',nums(i,j) do k=1,nums(i,j) if (i==i_real) then - read(iunit, iostat=ierr) mytag + read(iunit,iostat=ierr) mytag if (trim(mytag)==trim(tag)) then - read(iunit, iostat=ierr) array(1:min(int(number8(j)),size(array))) + read(iunit,iostat=ierr) array(1:min(int(number8(j)),size(array))) print*,'->',mytag else print*,' ',mytag - read(iunit, iostat=ierr) + read(iunit,iostat=ierr) endif else - read(iunit, iostat=ierr) mytag ! tag - read(iunit, iostat=ierr) ! array + read(iunit,iostat=ierr) mytag ! tag + read(iunit,iostat=ierr) ! array endif enddo enddo @@ -2393,17 +2506,17 @@ subroutine read_array_from_file_r4(iunit,filename,tag,array,ierr,use_block) !print*,' data type ',i,' arrays = ',nums(i,j) do k=1,nums(i,j) if (i==i_real4) then - read(iunit, iostat=ierr) mytag + read(iunit,iostat=ierr) mytag if (trim(mytag)==trim(tag)) then - read(iunit, iostat=ierr) array(1:min(int(number8(j)),size(array))) + read(iunit,iostat=ierr) array(1:min(int(number8(j)),size(array))) print*,'->',mytag else print*,' ',mytag - read(iunit, iostat=ierr) + read(iunit,iostat=ierr) endif else - read(iunit, iostat=ierr) mytag ! tag - read(iunit, iostat=ierr) ! array + read(iunit,iostat=ierr) mytag ! tag + read(iunit,iostat=ierr) ! array endif enddo enddo @@ -2458,25 +2571,25 @@ subroutine print_arrays_in_file(iunit,filename) if (nread >= int(number8(j))) str = ']' do i=1,ndatatypes do k=1,nums(i,j) - read(iunit, iostat=ierr) mytag + read(iunit,iostat=ierr) mytag select case(i) case(i_int1) - read(iunit, iostat=ierr) i1(1:nread) + read(iunit,iostat=ierr) i1(1:nread) print*,mytag,datatype_label(i),' [',i1(1:nread),str case(i_real) if (singleprec) then - read(iunit, iostat=ierr) x4(1:nread) + read(iunit,iostat=ierr) x4(1:nread) print*,mytag,datatype_label(i),' [',x4(1:nread),str else - read(iunit, iostat=ierr) x(1:nread) + read(iunit,iostat=ierr) x(1:nread) print*,mytag,datatype_label(i),' [',x(1:nread),str endif case(i_real4) - read(iunit, iostat=ierr) x4(1:nread) + read(iunit,iostat=ierr) x4(1:nread) print*,mytag,datatype_label(i),' [',x4(1:nread),str case default print*,mytag,datatype_label(i) - read(iunit, iostat=ierr) ! skip actual array + read(iunit,iostat=ierr) ! skip actual array end select enddo enddo diff --git a/src/main/utils_filenames.f90 b/src/main/utils_filenames.f90 index 2c2c22ee5..108eb2a52 100644 --- a/src/main/utils_filenames.f90 +++ b/src/main/utils_filenames.f90 @@ -216,7 +216,7 @@ function get_nlines(string,skip_comments,n_columns,n_headerlines) result(n) integer, optional, intent(out) :: n_columns integer, optional, intent(out) :: n_headerlines - open(newunit=iunit, file=string,status='old',iostat=ierr) + open(newunit=iunit,file=string,status='old',iostat=ierr) do_skip = .false. if (present(skip_comments)) do_skip = skip_comments diff --git a/src/main/utils_omp.F90 b/src/main/utils_omp.F90 index 07b462298..eca6876fc 100644 --- a/src/main/utils_omp.F90 +++ b/src/main/utils_omp.F90 @@ -33,7 +33,7 @@ module omputils !---------------------------------------------------------------- subroutine info_omp #ifdef _OPENMP - integer omp_get_num_threads + integer, external :: omp_get_num_threads !$omp parallel !$omp master @@ -57,7 +57,8 @@ end subroutine info_omp subroutine init_omp #ifdef _OPENMP !$ integer :: i - integer :: omp_get_num_threads +!$ external :: omp_init_lock + integer, external :: omp_get_num_threads !$ do i = 0, nlocks !$ call omp_init_lock(ipart_omp_lock(i)) @@ -83,8 +84,8 @@ subroutine limits_omp (n1,n2,i1,i2) integer, intent(in) :: n1,n2 integer, intent(out) :: i1,i2 #ifdef _OPENMP - integer :: omp_get_num_threads, omp_get_thread_num - logical :: omp_in_parallel + integer, external :: omp_get_num_threads, omp_get_thread_num + logical, external :: omp_in_parallel if (omp_in_parallel()) then i1 = n1 + ((omp_get_thread_num() )*n2)/omp_get_num_threads() @@ -112,7 +113,8 @@ subroutine limits_omp_work (n1,n2,i1,i2,work,mask,iskip) integer, intent(in) :: mask(n2) #ifdef _OPENMP - integer :: omp_get_num_threads, omp_get_thread_num, num_threads,id + integer, external :: omp_get_num_threads, omp_get_thread_num + integer :: num_threads,id real :: chunk,my_chunk integer :: my_thread,i @@ -158,7 +160,7 @@ end subroutine limits_omp_work integer function omp_thread_num() #ifdef _OPENMP - integer :: omp_get_thread_num + integer, external :: omp_get_thread_num omp_thread_num = omp_get_thread_num() #else omp_thread_num = 0 From 2ea5679d74cbe7a63454fc0765dfc0f6e1b94911 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 2 May 2024 10:40:07 +0100 Subject: [PATCH 505/814] Further updates from Upstream --- .github/workflows/build.yml | 2 +- .github/workflows/krome.yml | 2 +- .github/workflows/mpi.yml | 2 +- .github/workflows/test.yml | 2 +- AUTHORS | 31 +- LICENCE | 17 +- build/Makefile | 7 +- build/Makefile_setups | 16 +- data/starcluster/README | 1 + docs/developer-guide/vscode.rst | 10 +- docs/external-utilities/mcfost.rst | 80 +- docs/images/vscode-findent-flags.png | Bin 44635 -> 96394 bytes docs/images/vscode-format-on-save.png | Bin 0 -> 41262 bytes scripts/bots.sh | 29 + scripts/kernels.py | 96 +- scripts/stats.sh | 22 +- src/main/eos.F90 | 1617 ----------------- src/main/eos.f90 | 1560 ---------------- src/utils/analysis_getneighbours.f90 | 4 +- src/utils/analysis_gws.f90 | 12 +- src/utils/analysis_kepler.f90 | 12 +- src/utils/analysis_protostar_environ.F90 | 22 +- src/utils/analysis_raytracer.f90 | 86 +- src/utils/analysis_sphere.f90 | 2 +- .../analysis_velocitydispersion_vs_scale.f90 | 8 +- src/utils/einsteintk_wrapper.f90 | 132 +- src/utils/interpolate3D.f90 | 4 +- src/utils/io_structurefn.f90 | 2 +- src/utils/moddump_growthtomultigrain.f90 | 2 +- src/utils/moddump_removeparticles_radius.f90 | 4 +- src/utils/moddump_sink.f90 | 70 +- src/utils/powerspectrums.f90 | 2 +- src/utils/prompting.f90 | 4 +- src/utils/struct_part.f90 | 269 +++ src/utils/utils_getneighbours.F90 | 16 +- src/utils/utils_gravwave.f90 | 4 +- src/utils/utils_raytracer_all.f90 | 1199 ++++++++++++ 37 files changed, 1857 insertions(+), 3491 deletions(-) create mode 100644 data/starcluster/README create mode 100644 docs/images/vscode-format-on-save.png delete mode 100644 src/main/eos.F90 delete mode 100644 src/main/eos.f90 create mode 100644 src/utils/struct_part.f90 create mode 100644 src/utils/utils_raytracer_all.f90 diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 2acd7ba98..dccaebd65 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -35,7 +35,7 @@ jobs: nbatch: ${{ steps.set-sequence.outputs.nbatch }} steps: - name: Check out repo - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Generate sequence of batch numbers for normal tests, or run sequentially for scheduled tests id: set-sequence run: | diff --git a/.github/workflows/krome.yml b/.github/workflows/krome.yml index 25204531a..51302f869 100644 --- a/.github/workflows/krome.yml +++ b/.github/workflows/krome.yml @@ -32,7 +32,7 @@ jobs: compiler: ${{ matrix.toolchain.compiler }} - name: "Clone phantom" - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: "Clone krome" run: git clone https://bitbucket.org/tgrassi/krome.git krome diff --git a/.github/workflows/mpi.yml b/.github/workflows/mpi.yml index 46099c9f2..1eb06909e 100644 --- a/.github/workflows/mpi.yml +++ b/.github/workflows/mpi.yml @@ -53,7 +53,7 @@ jobs: sudo apt-get --yes install gfortran openmpi-bin openmpi-common libopenmpi-dev # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - name: Compile with MPI run: make SETUP=${{ matrix.input[0] }} MPI=yes DEBUG=${{ matrix.debug }} OPENMP=${{ matrix.openmp }} phantomtest diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 8526cebfd..d78ab7eb4 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -87,7 +87,7 @@ jobs: printenv >> $GITHUB_ENV - name: "Clone phantom" - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: "Compile phantom" run: make SETUP=${{ matrix.input[0] }} DEBUG=${{ matrix.debug }} phantomtest diff --git a/AUTHORS b/AUTHORS index 4b972f1d7..b139408e6 100644 --- a/AUTHORS +++ b/AUTHORS @@ -24,48 +24,49 @@ Christophe Pinte Terrence Tricco Stephane Michoulier Simone Ceppi +Yrisch Spencer Magnall -Caitlyn Hardiman Enrico Ragusa +Caitlyn Hardiman Sergei Biriukov Cristiano Longarini Giovanni Dipierro Roberto Iaconi -Hauke Worpel Amena Faruqi +Hauke Worpel Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi -Sahl Rowther Simon Glover +Sahl Rowther Thomas Reichardt Jean-François Gonzalez Christopher Russell -Alessia Franchini Alex Pettitt +Alessia Franchini Jolien Malfait Phantom benchmark bot -Kieran Hirsh Nicole Rodrigues -David Trevascus -Nicolás Cuello +Kieran Hirsh Farzana Meru +Nicolás Cuello +David Trevascus Mike Lau -Chris Nixon Miguel Gonzalez-Bolivar +Chris Nixon Orsola De Marco Maxime Lombart Joe Fisher -Zachary Pellow -Benoit Commercon Giulia Ballabio +Benoit Commercon +Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> -MICHOULIER Stephane Steven Rieder -Jeremy Smallwood -Cox, Samuel -Jorge Cuadra -Stéven Toupin Taj Jankovič Chunliang Mu +MICHOULIER Stephane +Jorge Cuadra +Cox, Samuel +Jeremy Smallwood +Stéven Toupin diff --git a/LICENCE b/LICENCE index 0562f6af7..ab1e73561 100644 --- a/LICENCE +++ b/LICENCE @@ -1,22 +1,19 @@ !------------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code ! -! Copyright (c) 2007-2019 Daniel Price and contributors (see AUTHORS file) ! +! Copyright (c) 2007-2024 Daniel Price and contributors (see AUTHORS file) ! !------------------------------------------------------------------------------! ! ! Phantom is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version, supplemented by the -! following two conditions under section 7c of GPLv3: +! following condition under section 7c of GPLv3: ! -! 1) The Phantom code paper should be cited in scientific -! publications using the code (Price et al. 2018; PASA 35, e031) -! -! 2) Any redistribution of substantial fractions of the code as a -! different project should preserve the word "Phantom" in the name -! of the code (in addition to the GPLv3 condition that this copyright -! notice be retained both here and in the source file headers) to -! prohibit misrepresentation of a redistribution as entirely new work +! * Any redistribution of substantial fractions of the code as a +! different project should preserve the word "Phantom" in the name +! of the code (in addition to the GPLv3 condition that this copyright +! notice be retained both here and in the source file headers) to +! prohibit misrepresentation of a redistribution as entirely new work ! ! Phantom is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/build/Makefile b/build/Makefile index 0ca66f007..e248ee4b9 100644 --- a/build/Makefile +++ b/build/Makefile @@ -465,7 +465,7 @@ SRCPOTS= extern_gr.F90 \ extern_spiral.f90 \ extern_lensethirring.f90 \ extern_gnewton.f90 \ - lumin_nsdisc.f90 extern_prdrag.f90 \ + extern_prdrag.f90 \ extern_Bfield.f90 \ extern_densprofile.f90 \ extern_staticsine.f90 \ @@ -538,7 +538,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} \ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ - utils_shuffleparticles.F90 evwrite.f90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.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 @@ -680,6 +680,7 @@ else SRCTESTMPI = 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 \ test_nonidealmhd.F90 directsum.f90 test_gravity.f90 \ @@ -690,7 +691,7 @@ SRCTESTS=utils_testsuite.f90 ${TEST_FASTMATH} test_kernel.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 \ ${SRCTESTMPI} test_sedov.F90 test_poly.f90 test_radiation.F90 \ - testsuite.F90 phantomtest.f90 + testsuite.F90 setup_params.f90 phantomtest.f90 ifeq (X$(SRCTEST), X) SRCTEST=${SRCTESTS} diff --git a/build/Makefile_setups b/build/Makefile_setups index 85ccc0e0e..55347ffb0 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -256,7 +256,6 @@ ifeq ($(SETUP), gwdisc) DISC_VISCOSITY=yes SETUPFILE= setup_gwdisc.f90 ANALYSIS= analysis_disc.f90 - MAXP=2000000 IND_TIMESTEPS=yes ISOTHERMAL=yes MULTIRUNFILE= multirun.f90 @@ -266,7 +265,6 @@ endif ifeq ($(SETUP), nshwdisc) # disc around a neutron star - FPPFLAGS= -DPRDRAG SETUPFILE= setup_nsdisc.f90 ANALYSIS= analysis_disc.f90 MODFILE= moddump_changemass.f90 @@ -290,7 +288,6 @@ ifeq ($(SETUP), binarydiscMFlow) SETUPFILE= setup_disc.f90 ANALYSIS= analysis_disc_MFlow.f90 # ANALYSIS= analysis_binarydisc.f90 - MAXP=1000000 ISOTHERMAL=yes CURLV=yes LIVE_ANALYSIS=no @@ -345,6 +342,12 @@ ifeq ($(SETUP), galcen) KNOWN_SETUP=yes endif +ifeq ($(SETUP), starcluster) +# Cluster of stars (ptmass) + SETUPFILE= setup_starcluster.f90 + KNOWN_SETUP=yes +endif + #--- Bondi accretion/wind --------------------------- ifeq ($(SETUP), bondi) # Bondi accretion flow @@ -473,7 +476,6 @@ ifeq ($(SETUP), srshock) GR=yes METRIC=minkowski KNOWN_SETUP=yes - MAXP=900000 CONST_AV=yes endif @@ -481,7 +483,6 @@ ifeq ($(SETUP), testparticles) # test particles SETUPFILE= setup_testparticles.f90 KNOWN_SETUP=yes - MAXP=500000 ANALYSIS= analysis_1particle.f90 endif @@ -491,7 +492,6 @@ ifeq ($(SETUP), gr_testparticles) GR=yes METRIC=kerr KNOWN_SETUP=yes - MAXP=1000 ANALYSIS= analysis_1particle.f90 endif @@ -591,7 +591,6 @@ ifeq ($(SETUP), sedov) SETUPFILE= setup_sedov.f90 IND_TIMESTEPS=yes KNOWN_SETUP=yes - MAXP=2100000 endif ifeq ($(SETUP), srblast) @@ -688,7 +687,6 @@ ifeq ($(SETUP), mhdblast) PERIODIC=yes MHD=yes KNOWN_SETUP=yes - MAXP=3000000 endif ifeq ($(SETUP), mhdwave) @@ -697,7 +695,6 @@ ifeq ($(SETUP), mhdwave) PERIODIC=yes MHD=yes KNOWN_SETUP=yes - MAXP=3000000 endif ifeq ($(SETUP), cluster) @@ -710,7 +707,6 @@ ifeq ($(SETUP), cluster) IND_TIMESTEPS=yes KNOWN_SETUP=yes MAXPTMASS=1000 - MAXP=3500000 endif ifeq ($(SETUP), binary) diff --git a/data/starcluster/README b/data/starcluster/README new file mode 100644 index 000000000..fd80156c9 --- /dev/null +++ b/data/starcluster/README @@ -0,0 +1 @@ +file with mass position and velocity... (should have 7 column per ptmass) \ No newline at end of file diff --git a/docs/developer-guide/vscode.rst b/docs/developer-guide/vscode.rst index 2e32d871a..1922b1068 100644 --- a/docs/developer-guide/vscode.rst +++ b/docs/developer-guide/vscode.rst @@ -2,14 +2,16 @@ Coding Phantom in VSCode or Cursor AI ===================================== In VSCode or Cursor there are several helpful settings when editing Phantom source files. After installing a modern Fortran extension, to enforce the indentation conventions in Phantom you should use `findent `_ as in the indentation engine: +and pass it the same options as used in `the bots script `_: -.. image:: ../images/vscode-findent.png +.. image:: ../images/vscode-findent-flags.png :width: 800 - :alt: findent option in VSCode + :alt: findent flags in VSCode -and pass it the same options as used in `the bots script `_: +and yes, you do have to type each flag in a separate box. Then it is useful to select the "format on save" option in Settings->Text Editor->Formatting: -.. image:: ../images/vscode-findent-flags.png +.. image:: ../images/vscode-format-on-save.png :width: 800 :alt: findent flags in VSCode +Thanks to Yann Bernard for getting this working! \ No newline at end of file diff --git a/docs/external-utilities/mcfost.rst b/docs/external-utilities/mcfost.rst index 4b6cbf11e..b153f85e1 100644 --- a/docs/external-utilities/mcfost.rst +++ b/docs/external-utilities/mcfost.rst @@ -121,10 +121,12 @@ You first need to compile libmcfost: cd mcfost/src make all -then simply set MCFOST=yes when compiling PHANTOM. +then simply set MCFOST=yes when compiling PHANTOM. + + +Compiling and running Phantom+MCFOST on Ozstar +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Using Phantom+MCFOST on Ozstar -------------------------------- There is a copy of mcfost and libmcfost.a compiled in /fred/oz015/cpinte/mcfost To compile phantom with mcfost on ozstar using this pre-compiled version, you will need:: @@ -142,8 +144,8 @@ To run the code with MCFOST you will need:: You will also need a disc.para file -Using Phantom+MCFOST on Mac OS with mcfost installed using homebrew --------------------------------------------------------------------------- +Compiling and running Phantom+MCFOST on Mac OS with mcfost installed using homebrew +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A simple way to install mcfost from source on Mac OS is to use the homebrew package:: brew tap danieljprice/all @@ -174,3 +176,71 @@ To run the code with MCFOST you will need to create a directory where MCFOST uti You will also need a disc.para file + +Runtime options for phantom+MCFOST +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +First, when using MCFOST, you should NOT let the temperature evolve between MCFOST calls, hence +the following options should be switched off when MCFOST is activated:: + + ipdv_heating = 0 ! heating from PdV work (0=off, 1=on) + ishock_heating = 0 ! shock heating (0=off, 1=on) + +This is because we assume radiative equilibrium at all times, so the temperature is set by the +balance between heating and cooling, and this is computed by MCFOST, not phantom. The temperature +is updated every dtmax. + +After compiling phantom+MCFOST as above, you should also find several new options appearing in the .in file:: + + use_mcfost = T ! use the mcfost library + +use this option to switch the call to MCFOST on or off. Beware that the code is compiled with energy +STORED, so running with use_mcfost = F will revert to an ADIABATIC equation of state, but where u=const +on particles if ipdv_heating and ishoc_heating are off (this is not the same as the locally isothermal +equation of state used in normal simulations of discs). + +:: + + use_mcfost_stars = F ! Fix the stellar parameters to mcfost values or update using sink mass + +either use the stellar spectra in the MCFOST .para file, or look up spectra based on Siess+2000 isochrones +based on the mass of each sink particle. You should manually set the stellar parameters in the .para file +if you are trying to model a known source (e.g. HD 142527). + +:: + + mcfost_computes_Lacc = F ! Should mcfost compute the accretion luminosity + +Accretion luminosity adds an additional radiation source based assuming mass accreted by each sink particle +is converted into radiation on the stellar surface. This is emitted as a blackbody with temperature set by dividing +the accretion luminosity by 4*pi*R^2, where R is the stellar radius (set in the .para file). + +:: + + mcfost_uses_PdV = T ! Should mcfost use the PdV work and shock heating? + +The only source of photons in MCFOST by default is from stars (ie. sink particles). If you want to include heating +from shocks and PdV work, you should set this to T. This will add the pdV work and shock heating as source terms +in the Monte Carlo radiative transfer. Recall that when using MCFOST we are assuming radiative equilibrium at +all times, so the temperature is set by the balance between heating and cooling. See Figure A1 in +`Borchert et al. 2022b `__ for an example of the effect +of PdV work and shock heating on the temperature structure of a disc. Typically it is small. + +:: + + mcfost_keep_part = 0.999 ! Fraction of particles to keep for MCFOST + +MCFOST throws away very distant particles by default when constructing the Voronoi mesh. Set this to 1.0 to keep all particles. + +:: + + ISM = 0 ! ISM heating : 0 -> no ISM radiation field, 1 -> ProDiMo, 2 -> Bate & Keto + +include additional source of UV from the background interstellar medium, so there is some low temperature even if +no sink particles are present in the simulation + +:: + + mcfost_dust_subl = F ! Should mcfost do dust sublimation (experimental!) + +attempts to remove dust in regions where the temperature exceeds the sublimation temperature (1500K). This is experimental. diff --git a/docs/images/vscode-findent-flags.png b/docs/images/vscode-findent-flags.png index 39595e0c32f67c6ac9de3859b932566b47b35ede..19dc44f180418c3c41c6364b31c853d04f63ba4c 100644 GIT binary patch literal 96394 zcmX_o2RxPi`~OWU*(+oxA;cjen~=RTvdP|iQwrH3WUr9y>`q8RR+5lSCo3!2`+w>A z{{GMFyq>4mc}~ZD-=ELty58#&p{{z55RV2AK@dU(c^ORv!GS+wbKzpce=x1e`3S;< zD9A`@`(&(4dYe+*OG6#~7P_O5_~PCjYZffBJC{(Y=c6wP)NKd{)bX@X?Rf2e@n3KD zuU{7P_s%@0`qIXYQbU^Q`BSp)J2Cus!n4*+PHb+KB;j;WpR*rXXXL*vHgsPM`}b1N z8@vI#S|lXLUz!9bgozk^nFL3Q1m~Dtoud8iig(4u)3y7OU*jlM22sc(CfpFF#nuL% z{9xo9f_uPC9p?K(<=?xw2VP&pClUDn|6UAq)QIH2FOvEihf9F`_b$`oJ)8^3e{Yj) zUBia&`0w)vq^+OKH`<)qj<1qMC@CuP)2x1emSy(x=qTjMEh|DoLf@vW@W~qI4-1>R zrF!&aWPJSmJ}o-l|NCh<3SteGk|usjL(iT)8yovQiEhc*bF#BL_&djW9=mk|bFad< z?0xtFIeFr6slKy7x`>E~kLXF{lcxi zeaY#9w8Fw;<6{rjbIqo0+9QXQl0~ifuJl>CySoqWy5jxs`hSWxAWS!J8Wm`k45d{x zkKNPw-r$Xohqt+je-zZB>b*IIjnH-O2Z+aY-qrZNysgJYS@6vXMcwQuh9mXq(G}GYnUuQG`@4TI`E3wp20@A z8)cc}zht+}>}^CD8H z)krIBsjBrtulA;DU1(zuVIqt0IM_;f{d%!Iig9`U?4Kt0b0`9f(QyHvyv>FFG-a!j zp>HFC%~m*4)M5LvzEabA{gWn?|K0pz#pIKzOVm=&N2?c7Qc^_dc1&k$YzJ@CtbTej z`0d-RTh*3)S5$84l*~;u@>P#g1PHRqrKAYT7HbdiJEEc=a3xn+4=nxUr-|vaT3xic zh&*R$G;L)LWtL$f8(k$z?D9F-iVz_vy%A|=Z(m&A{H3Y1v~+KdC-^cf=ZhEo{QM~U zVZ%nlsmaNL!FGToT1Fj&{dc0<%%~z{+S_kYM1I{| z=#i7#G7Qx$c9?p9K0rKpcP;bk)$YALpC_#-e*T%weFUM2sjIA%FVG~%S#tT2o<{R~ zd08(xCMv4GFVmdw3XhR+f6Rz=Um7g~gRxOyjFOrr$9-AZL6;06uN4wmjojSsj~|)K z1fp4diNf>C$_nc0(hf}>9FD#h4;~!&`G^L|$WVklsNtu+CIgh77ktyhWRb>#fCJ7tNI&0rnMg}L+9C;-9C^9zoWai24iWe=y z#IN1xib?M6F7#i>_hMTw$(0NJiJa;tj$rY z$K~jF^MAz(_n_532Mdwi7ZDzVD;ylW)zibXA7G3~Y7EqT{>+{~FyrzgKi_jAUPD8J z=lvfyJw2a$_wM=b!}iqFARioYHe1c`58EEJZR>p*z4YCa`^}t@5TpR(DTN{rD=IDjn^WE2($f zb==6PjHJ!(dVhWtdiYae7jf6kBk%6R2Uf%;Pf;p2Ntf@7wyQ=l2uo{*NdOd(rl z+~jp~6zWvJ{57{CEbKy5l=Z6uOVRybb@TJAQSH6k(j|mY9XL5fCI<&6Cnf?UnjikJ z2*mH?Xg#vCD=#W6w6?S?8Tx&4B2LhDi|_3(xAr8?%gpiYK0jXEkk!!Oy>{(@Slp+m zq=X##Iz7GH%^94Xl$5XjRF7-^{rek1EvG-KuKDk-VI%wk0-~o!N=r+riCG>tHkEmK z@6qVZt))cd(YtrFrzh*DxdS#B4EY)>@+>;~L8Du(HpeX*!gJ>W4X?JL1f9OW-~7Tj z=_H7l4!x=6<$d?%OYHRNNxe?VdBhYI?J#wuEiIj=S^Une;O(o2h0>&HnVJ6kZg;|F z_4P-^vnvYb<{R8?Yt2$qM;YRFKRiB$WjE8Wdv`F_a(WmnBik+`E1Rx-dvek!G;~l} zS{gyFU#}*?aYY-MSFvz&H&<6*6BfQ8_5Am5d!g9=j630ZNAL}k_0EEAsF)Z+o|dEf zhzNzjLKO+G6^PI9o2iueTTb zk(kR&37q6l^iP(jtAd{^sEzKw`r9%*@83YNH{<46dkf?(5@Zr(EO zJ^Qh7XGegJ4MD`S>+|z7X^+n#{4_U1m>x@-?yNMn8oSJ0y_zfNEU>e?J3p_gATR%> zwDcukfh0!~{OH*9d;&yXSvf(mfMSj+s-07(^a7H@{?kJkL9SfUhh;KE>)hAoH!6y1 zM{)7;4lHce)lBq$`Ev6{>gecbd`8AkFZ9KW7coD7`icfINpey|&h_YG0gBi=7DpuQ z?EFy3;_`B6e(=ACmcy8Iksd)2Xqg0G6BDzT?;T}RV^C63BF4vec4{6S86g)9W5P{U zj%0eKQ!-g;hAA`0k<|#xZ8vw-ei6$gpVCt>LVQu;Hb4I-LKn8~-d^J>b5B1%;aGBl zwy*p#X4E}Xwn+>GZM*~pwofe|4=z#D(Y-Ei4BGpHg&I|qjhY0{r=cj6c&l3%=_p{1?REWRr(4GRj(>gK+=ACRTT zl_lsb&4 zyJmb93*i?OJU=okMe@iDN9E#$3kU7y3QQzS3Yx5mqYgT2u%luzi5?d_BcK3VT3KC* z3H$pu%D5st4|{X|CN4fc`tCJ)qQimw@WaDHEJPr^w!VJBYv6pieaBqSWg{bc3)Psz z0CA@m)02~y{4_s*{sf#=^FW1(L@4-V;*(#7YSHxif7Q$KWyQs{3B`Odu}K6;?D{c2 zo|u-FmXVRC%~4@gV&~}Sg*I|)bbvyIF!?o2ne!TOu}0!i$8!A2bvkiWLJ25msIxTbW4La;BT6T_pY{(E!3!KmMmdts;~NhyV!=cdt{ z!FEDoVgdf|Dy2nbW$jkgmqMBI2lO;tBP{hPWZm62^Yii=sM{O_c6WCR3Jd$7e)Llr zzV{I)!Tmlm(wE(03jNus9$i$FUbqw%=2tOtEna@rYaIGyqaWX`YR`9iMT5R6ng2t` zK|Tynpb#P7zk4C)3wU{j)2#gb(VdQu&LcLqjkbJ!c*Mlh?>xsxtBV{34nxl4L+KxL zs9PQ>**cglFOLlg$@}*0`eS5hdRow;W2L5MOQD_&ABR1vy>uw7?$9W8eI#In7jhjU(obYVk`&JLkR#tP3kB?i_k5|8S+Y2}u zD$#Y)Qk(uDdHUi;sQqwhqC5-KEMMRA1qD%e?8UN6|}>G>Qqrs;QJ-RH;VG6m40DW)zzCf-MbPB>}n4N)x7xyhNq|3 z?*2zUf^RaYBBp#-oF`s$-$eSPVg%wvG;twWzMH3Fl2CW=f^8@o{C=bBL*j$0r+pjwFu6 zE+NsQ?N?KiXz#G6PhS;TJ4`f$rtct#jh!99-rgoJy8qFvlJJQ3pBLQ=|NOyyVph}K z{N*7ZHUdXao!!CF@s4+Sw1{MZCfcyPurTcL`l(9rK)9ao&ej38QKEXJ;JI|PGf`d)&-p!m|Cnmh#XjmQ=_HK4Ix2{en zyT1oj(`N-pSvdG)<%49)UKww{a24gjX`mtG|Cc zI6399ch9+bdU~2t&wIQp)#;g;nVIWJ*;yIAtUTw9HsVMcv#LHXh!nEpb-LD%8|mv0 zOip?(qrBDB1Vfk@;>NA2i3kaeTY@|nzVtVWy*!VdE6HTztI zOpGS<4#|6|$CYP0w(6x8p#F&InI4zf%dTnqi)}9P@{1cjA=lQ|&&6V-bN_e|p6EQ4 zzA8n+ox(|i8<64$TSeh76b0|niy=AV@$#>PGh@-bSf_bsOdzh|o*42dhY{su5g9Qj zm%jl;YRznf_*?Xq>R)dApZ>Odi^T|?tW-;6-nK6vvfJOo5SJS^9wDl4v^k2@cv2hw zV%2}=+jSs0TYJ`Rm-#b7j_5T9480=tv9|7vp}oxzw=nevTF+SpCnQ{5SrK*px#(?= z*)?yEyl+=)W$t_Lp1-4G%!q#+eakvv9G!B*Yb3bkCM{mucGq=Zt3NH(s{-yi*`U#O zlPfImwLD7)N|~J^^yyRamvw+w9e-3Ra3n=@7TL~!im-^&Mk?Lr(tiD-$RBXoTAZE9 zc%6`-4|Ml9C|G~AI9)KE!3qB=Zb*=WDWDkQ7l+^1YU@Kmby%^xFyhs1%^FR3R> z_1&fKCXq#K4GC4u)om5%RUprz#-;NPTABwj~{gnTU4DvFDZt*fcQIrnI3 zu&6(~oZPXwacSGN5cvv~=kVqylD%+EcRw6?w| zD4XT4#600+w9`%st!AakSY_dG|59{<>+t&qy@gV*RdxRYVU`#Nhp@OfmTVQE3MkvAcF!f5v`dESg}Hk_e|8gcP*I7& z3zcS$hodt)YnG&#l$t8Wmj}qG3q_!iP+YtOthJ-#U|=A=icOY8rU-5;rh3$&tgNp! zhVPeKqhdh^ib9H{N{@~_zxqKLf+Q)%VDu`#T2Cz==5*ONRl%t6dnF>Zc z9PGx%eX@vG<>kYsCal4KA|*3S9&VEYKI>nqS<|!oj|Z zFkQdCy&w@>R$YzJZ8?~$?iWukuAUw?g@nS?`T4@PZwKv1%17+lPy_|+Z|ds&I%A3Hi7rZ!XceiN z)HxJr7Jqb&HhU?_gedt61&Gl@|NosAK%|mYY}dv zcOOvEGR&jz_q+Zn8_Wc4*pD9#E(v)oewb=P=jB@jZKh90wv!=`47r2nQx^!rh8P34 zrto>*v!sOQut(-CzPWEt$!!?0_*FMM_#{G)YqY_2Fi%!VK0$_rg#?#?Xy& z1{m^c+HHGY0txr|?-_U86%s~9M$UK=_02O_ispEoBkTpZuSq9zJWwoc4z|eB3a5h(iK)XPWXvOE(vp&5%wF~{T*EbF zB6;=dRhbcb7Fc#m$89}!iZa7SVOUo|qGq3sqo&EUm}k!>;BjSSh!V8DH|A;kYF;ID z{krGjPImM04kH?k#=$;mh$Y9lvXU>)qQh~YUuDyWCDQ!PoyHqCikahoENuSu5q&Hv zcA~n$f9I^`fgHw^_XcRp58n>ZdH*0p#<*Fwj9+k z#{`@DZZ#Jt1s)68jW!fZ7lu1jhWRq?Q{V!IHl3Ia8Rmhp+U1gx3X#k++)PNDrOt65 zL0YESlDa8*f(RzkR6h(=+71ra)DVQXNs&B+-skLpg^HVN^1Uyo_YFFta2aOOsCG5c zs`Ik(P5!&;FHD%@ee z>DiATdg3N1r@Hba^!VE#~rZv(6L0k1A3B+LU_($9RSXUpYQ9tZ}@p& zXh>hjYixZNm=^nu8+QZ*f&i$mx16f}xdxFA*05U~K8#V`A4q+M{Z3F>AO;vSvb6-6BOhyU}Y#JEg1s?%U78DJjKX8`-6LiWR z0Jd6Qb~b$HVdmn3ASk{(6A-oJS-{B<4Q_Vu@mciZ#K#DMV&Jv2Vv9V#Uos3BBUL#o zBSX``z{pVaZm~8mf%~Qv25JyXmq9}%zo@ABieP9S^{&BVjQ2sf@SQvRKyL8D9uS2e zSND4{;eI?%4Jhz){1a%;3JN#yDY+7Q=71{$jBa+#XWg4SL;WINpO&}lYWS5{Ox6kR zYMjuEh;RCc0+CfxRwl!f6%!K!(Q*6m7*yYb%1W0^Zk=4*f#q;8Kmx^E+RXu^su^-y ztEx_cey`ZlNq_57jRy;6Bcb;+xI9!#uX;7C}>B7;5va|%9 zumYrnf`WpiWNuQt(BtF4!`*e>^gh6>F9phku3qJp2=4yzzEJX!xXX-Eld*HP{<@L? z4G#EDgn-!=uU=D_vWP3gZ6?6Mmdkhb@p+w-gUD*2CwIoDPddQ)I#XFr_OpZK5`NX# zw!>l(2mSgSfA?@_m8ki<&Bul<+WPUpeYgD|?!KZ~{Sv3I-u%Yfefw`SQ^b<<^76Vh zel+JDU-hbe04k;p|Cnj{(ag*TAmZqE!mf1v-QDw9(lT;#ULG}Z%Su{WnB|Joeu)!I z%WLi5x+cfr_0uPJb#*)Gg_|8lyJwUl^P=V2{`^rlo}vh0GU6U-4n#K=8bf1Rt(TbD zJP+N`;@qRQaN?ltp()oPz{YXneiaoJ^;K2k;^G=bQA5k&AT~}846sr}Qt}uplDtwZ zxPZ`!`Ry$ZvYi2eJ`XyP!i^40&qanLX#tIQK-32Y<4#Tb~ z-gFfs{`0*G+9Di@hPfh`ZJ31PDbdNMn(4z#!@%NFjNef3iZ=a8Jzl^UIro7`EsLt&xe_i)Z3 z6(gJQHOn0x7uGC;PAJyGBO@b?(9J+$`O^Rfrxn7v05^gBOza0!Ptr7Tdp2Hzhf5=_Yp}a zCs5xL3YUh5hb12+D_V|}-=F*SOQGP~)>d?tkvK@QBR9^f+SCUG31Q$1GwYc8LX3kw zK{RN{@vIXwD|d=K0#V#)u~_|SbXhJu2JZfLLQDvc28B^WWexZS%B+~peH-VdhvN?@ z0)$Ituytvm)%GV{DD$sT>)9^;* zA654NYz2*X1J}!`GCkvZsXcQ?+Z86XB9_DE`F?}e z(s4sv&_+)6wvHN>F^0`0q~1cX{=yyO#}fdI34ot+w7-pAHOn z4Af7ir>D=BR@oyr6n zTe=U66p6RKk6^=jW$0Iye50TsLYV{rF!?S9moMmRbl#%iT9mTJ3u6gUr=01bq4p#Y zp)QmtDl1FFC3~%qKUrr7CRak(i7KtCnw|8XwsUey6ZSml58A<}pl6gbrxw^KCf()i zKAxDI>=U#5QEjb@Do|k|0|f3rML`S_MjFLgH76bVsxIh0PZuv=W7$&&ls7pE@T4HvGWc7growCLc~1c%w(bEG*DWO;2Z}rS_9nyN(im) zBdQd*$w)cRnq!ESmX_9o2Vv^$hBY=-Bg;E}P2g0_ZtQXOTu2OA!*?RQLeQqnnh*9% zPdXVDmBbDLq84F(Vj}##LBcT7`~hk%Wkp3*6%|1mLd=?4@U<{A8X6jNa}ViUo3^kR z@Ofu9d_Yujm?8}`Ea?I;W`*;XlfqZBnrRFmCR+RCoC+?$CpP;9QWg$XSzH~c}0c)YHjv(g}@p12e&lm z-uKj7MR|GVAkE|9NB#Z#mlS6<*|M~(jA%_!q5UQ*M?b)I$xA5q11UZad^QTmORXNioCX1Fpi{oZ#IyhI0q<)$GmFGeKLzqrir-PO@ePx+98V(nmnwpF&?!iH- zHEY>xw+DE2#$G|h7iFkdX4NhJe)cXEPnQ3Bled$1q(T*!|DTzlMnfG``3faxc3ILbp$6t2g`iu=*3 zT1VFeZ9)jHR0x9XCb;2AeGT+Lv#bseCufRCEU&F$KWcZSYeR*Z{r+vYyRx5PkiFp5 zb@ke{Yk-a#Z*yu;%*h2M&aY)l1lN_9Cl{W>k&-X?wzl?VYKj3t{CmnMPulw@vdQ~F zCu=_XTWxZBPz%rtLlkuyy|njBjPc6A`czYO^T~y_uhe0)LRiS+%F5o+rdq>jc71v{ zsyyJ^&a~n~Yb@kmES;T0sWo*P3&4c2(NTsBqwei5%i9^ko*!-aE4iZb*z5DlMwZ3E zWmsIa0ply)fDIe77NE9rO&1u5*XmfK|8B}ce|FjHhMM5hEbr;#!7{@DN@QmH08p4- z^0vPhq*x_9Iji=kjAIh9|u`!yw_hFbgp<;lVb5KW8rgK<1jz~#pvPUxG zetc{CP5))9#VvYWkN<8tGZ$f3%_2M;L z>4b+eGOs3`Zl(7bUaEic<0a*ZZ$p3P))&WS9{PJEGF+7R?sYQZ@(Bq&tk&Q$!vpyTC4j{C}an^yZ=rfueCI4fo2#T8>=cDf1neJTTec^%6&}= zl=pa=m<}6$B7&{BGCbKTgP5bJ9-x>AlitnxYgkl&k1a3ZULa$S3=IqWJQoR$K*dPU z?P$x?s>x1NbSLIKHdf2DL?Ocq76lwBF$V9-=lxVN_d4ZSer9DcM77hspZ6ZMJOfd* zt;meitkB8vO)=8TmopO+!NgU~7Pl2hS5!**v09gwW>+ynOP-&8+uqA^ZVqkon=~Zn z-b5IoTB%{<1z8P<$x zHm}|Kvy3Qi2RS~6*Zw^5wTt! zBlJQar$E+VeM$f~q?zqP+aj&=dt+_>o40SPaHkv|fB*Amrq=%cxpT+FXj{0ZFf zqIw&Dy>w=5G!qm1T~Wu8QdG1uX>c)HS>0S3RMO_y{`3TbXK$^lm}s+awloajlKspSy~2r6zL%uYj~kCpEI``8~KZDv%NvvsszZKw)X zR+>a`?pZeD*-na*#m-C&?5#L1QKoP6dJ|ap`o(YUow84Mao3H#Z@la zq+OWlC&q%r<*k0vqMHT7D2sTMF zsq5?W3P_t$gFcMihKkH{fl?U&UANA$|JS_gtU%*K{b6(7L>AwJEd@lvI(vvJ(3zQZ>tbJ&`;C7ow|84L3?*04sAy@{G1-1Yd;xzI4Jo2fNO?0!@ z{edHO{YwZjuydsCfYu6zF{rO>SFc_|m?)K!ZyEp|J0l;k=^;+JDR~Zw{99jF_iKR) z?jtG1WXrD!c?5Xj+O>Rw3s2h2;vypEVxuDln)ZHj+SS(8*3Q8~^QC(1toVk8f`@gA zUT>b;^d-f)s*t5z_`0;z#-S9_QaoH42T(`A1-g58a}W$9sEE zA-M%$$-(YTi_7eL9a;g%k!55|td3^~pB{U6^i`-REC1TuS1qzIH8nL?#e()iU}PJ4cCoSaCB;|`h>yP)Ns8dMS_rkEHSb??Yj^M!WsZ} zuuWk11}%Nt-<|UJ?|u<-nNug9{a|N2*rU-9A{Q9$u^+wcwGTFbMpZlw4J9Vn$`o>q zX8L@`eZKwEqJZPr16|$2PKjm>*aYAbsupeTww#ttpAy~*13Cx0Er&7pVkWi+MovXe z4vtx}V!_h-db_KrnAly`M8VrhN-RHT%s|E6SRzAY5Bm$PNY%5weRdrzawJ@7_fowYIiGM(Mdc%LEpP%fdzuP?2e! zkFu1Cc&Q1->%>Y1+rz@|d3bxrI6|87gX@G{Ef~7WE3&9f3E{|9kr&PW&LJs)_;m3YNkr@^oKOh>XxvFV^dE5wu;v_R!L5tKZZ4 z?=0pp#y}WnFQEC|yRnZSi^2RnJoK*}tAylMvSssu-Fos(H8;Qm%t_ty3E>zSv)S+P zF$B`Xq&V?CbD+DIP z9)&1r&s)U;#RAPZe8eWrY_y_ibt+fHyb5&n*k}T1e(gyOhF<_VfQbeE=|orx@(A3& z*w_l)4Z(C3%Bbu7+BXur8jVov#>&yLEM2p+tuuSgWo2{3!9I7HNCGVW{O<%w&9q(w zWr3gnJH!-0I1uvNasfgmm*3=D?dtNUUvTVF$aBT(2vYl?+HZTz^iE_Rze<#hi3EF& zEo%dc2)Khnf~9_XADQSBW@BP39?&Z@Gcy(f3+&;s^-`F34TBl8t$K-#rN|r)f?8dj zz;w9?P0R%;5&#GSDz7UlQtU;go*PE=FSrZ0Fyv@a2##a9xYIUY&Q-@nD#uq_2M74e zMu-E){r+z;%Kl46*}VZ?Q36Spj5`oNX#|U|x!GyOE%~wJBlPX5@88w$dtTRzH4|$4 z3i>1YvWF0zQ$4<{MkY6rtcKI6Z-M3=FW0MyT{y_=H}Cia#4fbCv`kNb;|qE=Jum>m z?+eAG2W4{%6gbnG#oA{)8@1A#I%t^b))?SW*sNH9jp%VDA2z$A1U00%DC2Ij;9|=T zI8R(7_+J4>km&=~EpI_#VK7gVbl0&kj#zszJm5Xm0@A ztK_824%du+DrMm}R@7FerXSXKiwZ2cOqvyowL3c5;13+);#Yl?y}hY=-a>qDZjP!^ zxIgP=8!DQ~h1-<6$DFsmz8-kF^VHGSROLz_fT1jdWjuiu z&}<4pJLFMTmQ%%udv^I~Hd<06s7wIje5srfF){x8b1lb3!3QG-TJ(B|9)+wz!uyt@ zGsXk2AZmt>o0it`2RndH2yI(3SvZc4{lz* zJjb2lZk`E{{yGcGuer-`M|QuzFR>`R8KS8lr_Z>BLVcAG7AB*mtq(lJ2hOqW*94j| z7e|^f>gxy?AbeLk@B94vJPRi;Rk_)BGZEV2n>X*^0>r%6j^4iqjRhQsgX18GpiNDI zL)BzEm=fk&^&5ZZl#Glrck8kKbsed%Cg^Z-7&IvS{re42MnBOkFc;M(gzJlo zH=qIgE*0oPiVE^v`pNBQbu2?X@aJ%rAx6TSpGN#(@m%tG2(~_dPLf7s*lY-q&&bF^ zx1s6xqYci}YuQH+@0yuufRK#n5wyj~VH(}78%vK};iA3QPu!NiSqf*a6&GcVzMZ>4 zA?uRif}R9?CgJ-R2l-%Cz4l{c;8wqbnxdlb->xG4UG^BgVaMu0X&Ba|z8S9gzz$mu1zW3lk$G3tW$R8f| z-ZF6V_WHNVk!{b0$|0=F?hXn{Lp! z1u5z>ft9~=e20sYvMYAB!Fx3 zGXcgfE=PP~P23o(8w-xRW&n`2cYp zrvXOUke|N_BK_sdDGkKJbg{X)R}sC$E`A{)l-Gsx|HY1QATafhlDe?5M}o8*W+uwe zPrnAv>wI5&i+MXuBwmK7Z)w3CYflKMEHSi#x$HYXqsBX(Dx%K(_J(xfC!IYH-Kz9f zJcP@1dR|3{;fBB+(RGS3>;`5ZiYzV3FuO95y!1%JI!ge9oiy$K{Oq72NGyg$A%Vr0 zc)3xGSueT37TmGJfM)c5#h=!h`O0{f2n;dX-Pu`l>W+oY{o|7=&V0$QyR#a^$Xb>p z)805#fRzAe-0zAcs36O9xs9a55h)?_r?|Dt3ecU z8A7oTLWWe9*Ifp_w8G4@lxXk|!pA|M84U5h?%pK9-P+kPrIsUks?2(iZEy7wo$Pef8fnzeDoz1AIC|X)tV!9uK zYd7QNKRJ3`a)oZ*HtXZ@wmOILCF6rw`jqc`l?GT+-j;o7o-mJq!Lv=f19`ck>>v+k z&yMzXwaf<-qoc<6J?9=D_s73@@!n|?1Kp8{WQKJ^!b2!F!?dL7}HV``hrauoG39 z^Ha>;>e{irwCw1OG5MGmW>VA7w?Ec0q?utMOP9Le*Zk4CoOz9Pq^VXwLWT44<{O$Y z!>siURxyPH;u#)U2M0qdE25r|2&@nAEj`zdN-0zfUt!-JXw~rd^~@eTwwdc75qf9p z2V1<8$5ZpMf*cbWX=)-3CGAx3@&GH{}$hJrdSN%t*eAvV*9!0A)BBp!;u6r zS%^CdD8-oBlne#*ds1FjF?i>p51|gI!54RwB?JV-nVCPDR~^j~x70tlNj(3`o0S3& z%=MuqbIAQ(IEO%*|A$473agfp(Ik-HHpkh!uXOAg{2lf|v_c_!RSHT7e z?@}P2KfQnHk~%cIN?RA_AN6722kxD?Pc&nMe2XVNUR^r`)F^IZ%1^WA zVgcEVL>60qFG2qA$FhT@GTge)+RecU@=^;rOk~21VeNg$=O?;mdNmefSKDDq4H`RN zY6gn}tX0(&94U?@#gZXDfmjgA&T7etTSFKe&jg&v*cKsC28ehG(Rro!c^yWT@}??V zjQfhPM}~!Qkm59MdZN!ku2=gFL6}B%zhEJuXpGz~Vd0OLnQ>tZ1|sT}51AR_sL06d z_)1%?PM3a~M+>{xZ;KF%MZT@#!6#7ogR5YbXIJ^a?!mW=c?s;!p%V)3+mF78#_ z2~*U>+FN-R&0KXGRJ7_*D4T+2!M7g{Iz@x7;abWEYQq_MK1MR1hYqF^Q-swi2$L@L z4zJs5nz%VEz6nir6bp;n8H)B-;+_=~5WKB@)oyRHID(Om_nlqZ1$k`RuW@m7C<=X) zm~s9KL+3>a@7i=TJjO-x7-bR2^qGARz^y?`8S_IvA<>Ckn;yP)cuXt?r>6&I6T| z0Z0Q;1-PJFq2qS<1B9fLICa}UeKM#1g4&ufJuNp9f!t6smp;H>xBk~1rgZEQ{p`>I79k?nf-OAqz7)BO>bEe0X8=*m8!wPT1LVQ+hP0l@9 znLM0}p{jZK1F$ShQV1$8~ zQCxEH@mctelM^NgQ#hvrHtD01b4Zy z0r9j3?(i^tc(s`zkcg-q&f~3 ztRJK@z~~`%x|j-J+;3YL@{W1zDz`vELwl{#(XCuWKF|F%Ir^y!a}iZl&97}Be>+lc z1X-NnB@g5gNG*cX0Yxn>yMitIJRwY=J%35PmC{dD$@Rx?5=PEo6i-~hCt-1A-=y zB|*8GMq98e2{d90!Lhj@g(#TfhU~F@-*=2>x#PVS0)vkbo5qoXslx5$ z5hA)D3vPF?kbcokLoctX4NUmvUp%nxBJ&_t3R|$axbaJ1Ad5n|el^?_M_i``bzxIe z-@>7nzTCz@?uF{*k3&w0L+23GOCtm!kVQhi*84>=Ka0ytts0pfuD$N^f~6Aa+dB#- zqG<%k*c5aiGOxgl`$3(8X{I;HDcRE2FTjzE^a?Z8e({I+O-G^>VgzO9m5UpKVOOcP z=#OPW+B&GDzwTcA7ZHq%Q}fvwU4YqXIwEwtd3@JHm|%e9Z~a+5%E+ipogK!Y-5Qy% zU+-J;XfWh%nO@&$IERIYkl?Cwr}QjuV}Iy=__neVm85tcsnp}*PKnBU4MJPJgKs3- z7kp&Jf;2Ek)!74%w@>9Xv~zI@@$pUGKD?tc2w7=%3b}io4xnV2z3fTp=@bCXAg;6T zxJY#{dVKYlQ`^G)JQS7pFbkNf%$=gdt=pS%$Dmldd81?5syd<*6CN5mz)#MYZCX8A zsuKm7Lj^uAuIR$0m(-c9C`FAE2wtnCXRWNSW3nzhlgWd?Ik}p{hL0$C;%<#cNxCPh z`2#PN<%$MxBq_o=y-*y2Ko7C(z8Hhx?&<51ZS@U2m zT^jBWc>3Y7Ij`<(ITF*_2ViDQuLGqUZ9d-rH~qTk*7!ov(soIcj!pdNk5OdaL%vj< z5*XVf#IeaAkk@#jLt7WHuSnMk2?ETvpR*W;*`!lZCx*ehXL!yHh6N#o*=X2$-GdZI zLz_Rde*v=dvCDjsdE@mh&r?#I`DwT)tJT>Rm6U?Ppz&YGl$d-!N=-xaW+*Hsa|vd% z!HiuixvHR zUlf)|%&nzr!ifXSedBtkCp~lDmbZmsVeJZf*`hmJo>6$pi^R0ZABl#B$uzjLI&w7hv}1#;f&4xbKRB{vJl^f$_Xry znjoL6M>SOw*U7yom<|U^lQfQn7mKl8SX7iuHxw5OKUznyC*+Q76&dNeol&q~-UF&D z9~Vd+jq<4~cKrgdfC_2W-q`q!p&Hl3yx8DXOpoj(W@%eUMV~R(#9|7hlU+r+fm~&WRMm0 zs>L<93Ole5oqc_{a!8jNCwSl1@Az=gn_B zAD=yl7m#1Ma+xXx#eJ5dTW{Lcv0eHG;dJl`0-@M#90o$ytLjXKIeqZ|q4^UK5xpub z6g$}~1pf~%bZvBVyU#R)3GAtN9!t_DCKc`GIwz;_J3@T4M^aIL+}AUw&~o2iNBgal z$v&H^YV9DZv+bxFiOp1bOUst-@D{z_+?Uv&&cOENU5aTmA+^IG`n5FnCC}V2{@*Zm zwREdKFxZg#Aqf+T3AMfs(bRYDJ&oR0p90r?`~5xqo|0tq2)X9@OgA^d?+5^%3ZYTI zrjxI^$1vPVL@e0!=cAHvCQvY#yKT4T2ExEBJEEIluMbi$E4_EaaudW1394T#G-PNh%q)yD2 z?r#0s->INKG);XSFiZV>FT_$qUmwyo#cONa=)i~by?1c065NHD>GkVu00m(dBxtWK z7^3DN=}c5%Hcw7YK7PD{PsN=j;OOV>uI0KhJ0lWw} zJluEt_WiT@^d%RelZD`*y9q42{DQBGi>uJ+@rRKw#REGa+D{@4CWv`eLw?&g7(csj zkNHW~J5Qb7S7*_=&>2US-Zy{Se)yiOEc7d2T`IojgJnCI?Ekr1%xP)_Xnbl>8=@!+;ySEO%Ou3xC$XTd8;{Sv9+Bs6au zy%=mg-kmEXu{5kPX89F?^FGSxnl3hit%h3uJ9sT1$WGDf;iFgQ13o%vqMIIDSl`6W zRc~^b`?&Roq@aiV&jGe(#D~B;%SJ^BqIFEyxfMqQ7bz}9=xdqR+I9JlbC5{iaJ{-Q zAY3b*VLI%8{6gmQt$Q|M_e3vm2bLtivcFGOrr3S$PeCvq^K&g^-Kp zU#=>PphzmKru&mMHR$;8p73ogt|3~tnbbE!8|&#>sYX8Xfoi<_K5_UP#*a(7%kabW zG$S+2AssJhnMz*6Z*wUkMpXHm|A2;;f0OmMC$=N$BUk#D)<*5qXs#<5_bTvF5nRd1 z2?Y6LOvhm=$up?@*|#^R9d~0Z8X{)>^g%GJj(!L+3RD8K!q#@lcXP=Kdn3|<_7fyY zP)%b|=w#zI%gV$&ylWxy1~mXC7D0veg&f~q$EF;~2ns4VRr9ohX^HSd*xS!;-MY22$aZ1H z3o3lv4^DE%VjM_I#3>Dn_$|N0c>2Xls z9USgLM>0L_JJ(PFuV|o>OmOx10^~A^UL1Z^r$`IfiWixcgAQd2ZHziscLy1wmE*Yl zRMg$b;6K(XB@2to%F1$BY`vaT2mHQ0J$0h!ar&bc*3Ys zDxf|(Ihm{R1O8bYEy&pZl81Af z-JJ#I_e^xH3_^8|7c?~mH}2+oZ%*~ck0@IEMC%P(psfo`sGmXv7`{*i`ugl&! zb?n%eQKz8Ww;`WUh~K!Tt{y-$HaU4c^Gv3CPD5=i#Z+S2s6xEBrLFC5UiQno*d?1| z#B;j>%e$UU<2}JUgDvpJ;-q$&UT@e9m!)l-bRpFLbM3cJ;Xm_Uo96FxR8i=9fBazTiNWOT)fbII^Rw>DzU2Zr{Ovl|daYbn zf@QksgSZCOdt?sgvPg_BHLI1Xv-Q$bkB7xPMupk zae-iW1$zPmfm4*tEiJX((+>UvBF@6-3K*FScj)8oPa$=NSkO&9?Hr!NdAINU{pL|7 zM(X<}Y!bdMaLK~>L=m{<)`fIzYMGe?>iMytRG;Z}i*LC5Qa^o~J2EoTp~T4K!@-FR z1I_3YF3*%W{YC6cyW17N4Z~|ai4BDz{oQ2$)}1Bt9+XwIL}*#Kxh*006^PT}-2Z!J z3$J+GGNpo!@Gc_f$&)7qek+TqF&(EN0yhMInuvEyy+xtc@w`i6(nt1&FjMVzU5cPd z=CqvdVH~`#1A>okyg6*J{&mgL#?Rpsoppl~4oY6CBBdN58glG_0V%P2*cU}fzD8N) zaDAKY4??slN}8v_&K?*%%F91#9Bv)o!y7ZVw&K`sb{y3az#EEj0yj~yV2}eV%+Kn! zOTml1-#F5++}gHejcsQ5wJ5ohdqawk3MzcJR-d{H0sypk${F9r_w2f@jD?U_d0N_u zZ7x}AnVpl7^#=fT(SC30)%_nCR@uqPqQb(*_;T2Ue~4ly3J3JaSF+5)!H*|do&OZE zn%7>Y(k$f3OljZPc>OzPGWyw84x^Frk3NMB-a8bF-iZCGo}%^jJ7xzBYX0Q|hte!3 zUrn9wc|TZ~A2a8_U-_bB>|@ifehmqGZ(N`_!WHyxHkM)!9f2*-GX9SXtJN{CH@3Bd zi{#G^lM&5_n~nv3jYvH4=!(>;qM(8o4Sy9ssVon@0%d?#IVQ4oCIUsBVvAfpSR2kv z!eY!*k2wiVu~s(r=*Bf0!b~Y$yM)AeFQ4)ZKf@llF_VAPJ0QHFG?Q7sQSCjyYVWs- zar1o*ujop%USErltsR(~>5B~xirx^bdAxOhcdHP06otj(Yqf#fv#me$AEgjI)8j{z zcm8b}4a%0%j`I$=j?dV{CT4GsMn8?r+)n1}zU;4eQg2BkTJJH-R`ha zRP>Tyaz$3R-bM9$6sdl~oPdV>*4Or9gKRL{T2NL|_|u6d%>FpvL}rI=xnAj_W`^p} z(kj>8w_%UdFjs&s?YD6FMT(I$rzdiG@@g6O)%Z6{= zN#X2=;u;3ebpYFf*dZzvIMjZ~pT^@we~z&SZSH2Kudl z%CFzQYwGGcPd?^2)KNSOpYRud|BSA$SWvYK)H{CobxV|Yg$6?>{tgi z_mVUHYW1(7;kT2E_Xg*euW*YLv+v`m{z`e`-K*T`=E&1@-ekMjozh-pCYQ%N8=05g z8g9&8;#N8DW}`rsIP*s~*L-i9bEegyu?fbIh_)NYZVMJ_AE|0pEb_Ic-cE33B$Zfs z_L~Z(nr${kR)xa3%b)zN6_N~q#r;W@>G1<^?4wU!oH6?xdo=Qn>*OEH`sfBQFEU%# zf6{HHwpv!yg^(}I&%e=8WVuSiz|hv|IhrUKCXL0Sw6yg;t`v97Q9eIDBa@-p+M-&v zI;D+y2t`uj=9&a(K{;BEZ(mH(yIvV|62{UUV*$Rb>t$~KmNU>{}^8=TNz@EiV~{pFTcg; zC94q)1-OQnmzSmGfXF3;sGQR4)yyNhf_*2GaM52+;#-p?} z>BnXtdp;crgd4I@R}kLN%G{$Q&#N*P$$h6iaTSl!JG3oR&5C?WQvG1T_bi*D_*LG( z;CTOsH!@YZGgQqAsXRre7#n%&osZhf3fRr`m1Fr|XYyM!-wbQh*hh~KTS&_my7Ro2yTQavh+I07>wDS3HCn{^lKI-rum%7Fs1^Cd^)hAH& z)ctaO_FC*xe#;Efgu(ef@@h|7Nz4s80^>i8MC7*%E6L z_oXMN;U&M#Tyd!T4y)fPf{yc_tBX0kFG}wZ>Sq^TseGtVd3LKEb=O-FdICR}u!x8q z6ZGmZeSfrvG&)N&|7jx~Mh297bX_^Q6`FZMF&vXiE$@*iI2Ud&#hsa%Df<9oLeza) z*;9&zZ?m&oN1a}@j!A_^W1;8IrpoQ?v!M!e{P*wfGE|iVv&&xM^?7IE7cAUMZYUUZ z?AWm#>J*D%U{>m#sfxs-%YM+QBfcEloF6^?{yj9=pF%?FDptD_F@*DFUFxB&vCmL- zDT|NA;vu~`sd+Sp&-cmrcAy(pE2(`7TqZqU?s`}=0Nc1$c69tz?(^rXtyv^Q*0yur z&Fhreze~!-=BX0r2YcMSv-LN-Y<*X2(i8Pg&#u=F?n+W}DtpEjn(A%xA^PdlxW|uC zZ=*W?sC%>0U#enb!HTbJ-n&Gnsk3u^G(Em}$EHy(IlJJwj>gs`=&g7{9qMP zyXV(Y3L@uzUj2>Y3v7^4GIgFfCRU z*=%+^=XoU$549Ijb-6W!vxrDF$(3~U|F(~Lnc=-`l-@92;nb<1Oj*Uhmo{z8OAmmU4Ic=GN)rj`K{(4;w#6%);Rt9bdreC$igvKq$V-eBR+4kRxZ# zthZNeBw}PWV(y4pTJtE+NwL#{g60BJ_e!q=wn4O3R)(5t^S^?EUo-voX&$K-Z&Fjw z18)J785oF<>JNb7u;tcFxM;i#STuWBBz&A&U)+EqjDeZ?G@yl;Opr)HUn`7j+C&_1 zTkLIbkGX&UQGER7`t%&v-Ji!U(U-pOGw_v{pBRXcI7CMW5p)b(%_wqp6yxMKpl5Aq zQDqi(>KkbaXlfez_3M%T#&31NhP=cjpzvm+5j?Ah<=U3Y)@~m7q)DFo#KzTXzK!gh zoTV4)jfpw3SNXKxx{Vq~h(*T6{<1rV!2q<}SFY?6`aJOd_MaKMX8h)iCUaWiwrwf^ zAKo;HweBrmgd&xcm2ixs<}ebUe?Ujb_HJ3n-h4jqwUbhOv*6 z>&0%lh2`bt*uNf*gt5lU&F#rfC0b%YK*08ZQ|#*rr3GJJ>_$|W`G~)-aFcL?8)fpQa8p5rHwb{hj*xitju)B9zSXh3P%!M-Qkma;b zF0Jm_KG5j9k%%c5T1)H?>gu?Xk_@k3j{+k>@#Hhk7ca&{g(iM6zNa}zmk}8f!XBUg zW>ot2GqmafDI0_{H!LY5E*Ne%_19$O;W<6FOI2twaBMIq>#4)g+v zrcI=36ylrOOhZGz(G5w~b8PW{N2#?EBg1gn;fZGJIs8J!^eS^o@3D+ll+Jhx78Zy0 zZ5Fdg=sk&wI(<{C|8!#(H1!7bXCXcYrYQ0ew|HW$te|vo#^I_nahDBmGPezw3LV-b zrTjVW#g}B!xrd?O8iky$?N3pYQy#b^u`=e>?zfM;q~(ZVtan{+Xqm z;k7n<91dapLra7Pytll22i1g>vBO}_r;O~EFS9Z-6fZ-ta^(j7AB<&qH{B<$nLj42 z%XN5#;toRs{Fz@K#hI+^b5-urx5q+h-aPR4TCo%Q+`IlmlLTnZ5yFB@MN(kq#*Y3Vl(9%vxm!DwJ=R{{8!tI@Nv(a$Ms}O5Ev#w0WY( z8-lL`;I=$-3qA@!!-=;2dSZ44fO;lK_!@e7 z8F_gfCPK%&gz}<7lqa@qtrt?&7LKC{jSUS~t~M%h{?hj;@y1E8g-qhuv9qFG9}+f3 zn~z^j5I#SZRW(q$;e9eFi7PIWCsa!~h<6*I>(ju|c+{R&466>xRWYCC7XQ>8N!Na0 zyhp3>QJG-kg%}M^4W-yu);8QyO){DE5}Fr&$J9oH3>Go z>M}NhibwFq3OgB$ev>KLQYom=-lm2LH9$SNy&rNa;wj(EU%n)$usOiW3b+C8tz0T; z?13I09zQzy($dm;l_}qaFHy-!u6}ry13U3FF%hb2Odrp$6KO!7p-D z^su~CGf%|3KS2pyN@Rgw|7-Bhd+S}j*0SyPPL75dyS16PD=F`|9&=@n36Aamp3$E% zE6sAN$hA{3N}uYDMj(wc*M}=+M_1RLNhrBqC)kxWXWKAvemb4cV_8VK<0WednVpaU zh-y7dqsJvyAiRWOa0PA3TZnA#WksDxMA?Bs7vQ@eCYgW2-jJ_&qvQ4D>6b1G-DYQN zY&vFid83SY9&q@sk8e75TBMjcW@+%?6Y*<`{#}uVTQNK*lzaBP(RpdF{?1;MgF`i^ z{X~>paFt=cCRC%vB71H29t|=C1UiQy=|s#47)@k3@;WCmlf;xFy%~jU?ot+g(5RCK z1dqxYGSb%G-rjpdRN4BdfkGFx$yNig4@^}513#q>U(<-K8+E!D@6GYBZqIgXG=DnG zo+l=KHQ*mx@CcE#EQ%l%gw)jb3WIYi$5c2JRCMaDQC*w?6w3VZ*x1;wDeC>ZQl(QC z;96X(q+o|%M9m5!=MwIRyKW0`aDYK3lAvfKeY#K!M%s7Ys}%lU%?lvAuL=30xLas< ztSra3(fM7szfCW}ZZrn|TIYIA|kOAI_Q z1woz9j~<~X*L(Ng5DpHGmg%K!GAed%qUB(Tjqg#;aKfAE)FMuLo@eo@6w?`3UHZTvcoUJk}MIqjXTt?V=uc&@$EyY(z7tJGeueYtz!1n8w3Ys079j{V;D#z z^K<8Fy}$V%2g}^MRrY7S{=QsrN-+{Sb53U>$^CJ5(HGd@V*WPl~&(lR7y!w~qQ)rY0 z>&v(g{(gUHzd*=;zO|F!MYjJ|bGCkGsUrtb;b#SKfFTAZ*nfJNLD%RWFkwPaK!M)>2#Bs-i?oPK)=| zyg(qX%aVC)dRm=3io9}s#9W5LUOyE_%%Bo)J;Pojr*qObUtekUQRO}()E!?x$Ur}` zw7L!%;h=-wY7E{l-FWqV$+WAN%~}r7GoD@>4ItF6VRtAYC6o~}|tA2uPnWj#uEcfpzMp`^%kU|!1{9# zU9asl4LtLV!U=|G<_FqTO9p=b-lgZWvcsX|2}fP7Z~PXr&CHyQnI9F;_RZUFE?!A# zDt4WovVSN94DJZ(afj+m>4fpB`Dj+U8Iq3W58=!a+LL+)f!9;<<2% z)d^Q7jtGBA7GfNUfwJ>Vd&BJ7?3p<<>9^d$#h&V>xsz2unS z0VTHE+4)RV)B&^vq2Xs^q7ql?%Oq;OP835vgyr@ z@kL4;d!LGFN5{kfR?T%67l6)E*Y?7Flw^csFW!3UYs7 z{q~XPn${25uaZF$+n%L)wOKHz``Oj5>81X2FPlfx<>NfSk+6ZF83XFlwR^*I$1k`Q zkAj{hNKY)T$mgj?J?Opo{diZH_(hrs(LAr&pQbwA=0S!yATQ+_01(!%*f^i6T)lA8 ztxPXWdJgN#k_rLr3wDxkk&?pgR80NUtK#Ju=y^Erf`(!#dnYoU2I(LSltF+(^~UQx zw~CXeg&_@iKYw5;B*M!Izb{Q;O4VGj~+P!kSXWGI@AfR!f)MXm2EoVp#))- z@)F)P6rc@Xz9`7b-UAwKZiS9lkm=m3oL6>3*y}fqFLW&=SqSsx^cA-Ibho!NB2~q< z2Um*72M-P&IM8stdq{B;0K9GxOij&?e*0WUGuaRnAZW;a)Ct$By;5fA0oaiIu@?U4M>;r4_=X{*8kE5gQ zfB&+#@oK$y2%xqj#n-$6QtNs=JG(RI?e9woioIQ3Fm$m~RtL;mP>+RjJ5r_8V$kkfQ**ZD|YF-yYBA z=27M|p}R2hJYoE#J7kjid3pG7Q8Np}kS652kqjLVEUl5IamYr|VMLKq{mtjk{A(bV zFgQmn38+>(uuey3&B-hN-juW*IQTeZ(LdZ)&*YF_7Qpp!{uOuJ>x& zP0Y>h20l`keCgdy$FKq1*HuYLRkvabH#bg+3aC%6tEsI`+WH!5F0QRO#MBo$3_k2K z_6$_I)?^(bsjRQR6yfV-P)Mb&rba>jez2YuzUN{lteL*5>rZx6_)cFB>q54II(=uq z9n7JOltEx7jBg_dC-^LkEf{b5sa?PB19>triSx`E3_ao0;}WVf1$^T~&Kf^}xn<0IbCR4j)}JI&vpVhMx|%Rod$$DPaN`ntC$!&v`+?j;~6#{PX|_WM-ZKd%*nh zi_FZyWRoDna2Bz*=$vm8LufF�HxbiSWjxPQZqGdjMG#f3_OklY=b-vsg{)cD`R+ zyyESM>%Dkl44a#B#=OT3NgC9f^qpJ(Q>vvU0^@j2(aG64Tip;j z#BOG4^CPsM{_BjCRhTuLK701;ks}XJd_Bm@io5zwe~Rq{%1b+TN4bfz1RF!3q<`ip zH_lIlqjbp6yWCHHo*+_TKyL<-6Hooq^D22}4IX!sN$fy_-=8H(ArJcTadBsy$L666 zlUGn^AK!zkUgghb3U-!=ngi{u+U}3jEK0k>X$0crNvP4i6%za|Kb3=xAEogf{md1` zoum|K82g=x@qp>j!R^!c1|7DkcRxwXuo@?SXkuVJm}n5yJ3cx-?me8a$?Qp6EJJ6O zf2fK-*x1SX8^mSDtM~yn&QR48?~+{AE8!kuVya2>@n}H8Px0|TIsvC9ti+ml>ODl& z&)%{o@%IS?KO2i5}1oF(_tmmAGXRK@>6og+4yB~!I zCJG7*9iBFKlZzRh0@yiXgfR6RDl&I=t^H!*3!sV<%v%lOur@npr(;V%iM^x#+t@bdOp zGD}lf2>zI#muISBqN)iS-g%6|$lBU58_Zq!Y)F;fN_Af!A)@AVyzwz*u|0oZi0Chy z^GEOw13EnQJ%28qX#vv3E73d7RD}7KyLg_nm z%JIp`smV!citDP6hKCOR`t@tQS)xow*#SEXQ;0tIh6u(U^fuNM1xm>ifnA`6Qi|kvtVN56-7nl zgqT}f(+fF+y11L&gr6R32GZ#vV5)Vovc+Hr_Q|BL_S5Gt5oM&MQA+~najSj&d#>?# z;owUKM!vTYyyukvX$HF$%9B8vpnhDAI$wK#y#5iB4M`l@u9DqD4ch!SzK90iZxx=^3z;VYZhU+SH+5#zP#-y`P?gjNJp zgy2*705V-{vn!%zomAu`UuYNkvod#}zdx+g9hzu8}Ab+xs5^b@^x zbk=b5z~uG}WmU)I5#zCIuaquQ{(VjNLMhT3x^5zUtEdQZLXS_-k2wkN^fxzuK5SM^ zq~O~B2`Z2`Z?tSCavIE->FL=nf3sws8Xv!T^X7L{nBY8heG*iF*3o`n9!4LyhM}JT zNe3tk%&VxWsMrGEl$L_B+d29Adln7~Vo)Fo8yxy1MKQYY2NqwjCvx-G#unHQUh%|@ zw{J!>RoNnc4{*r~^EzU46c_t+GLq5U+lN+uw|{vVo2i`NY*>NH zu(G!9D6)-cAJ5g`!PN{YJd(-imVf_ttn7wXF1|raSGO8;X42P;-TQme113fN(soS4 zyZRvmu}^<>VApN(%DI)d?eTrl_36hi3((B;cE8r!5o8EiNX>wISx>HUf-Pl@J!O^6 zn{v`}t!sF$@`&%>N93nn^8EV^{#6{n(s%wda&1UoMZ32A`-Z@B_@T-+5MBmA#Xb-s z>1wBiD4*pvWBQMiE>(R(gz}vvu><+Ja4SKETn(?X%5nU~kGBm`N4@TxR2&XVYau6e zk@61Zx1iWK7}{-9R6pn+tO4Y$J^4kl#Keaum)^$?z~2fuI@OmDXN@3*#o8){uYx z{P|!isj|(DPRgpTF{)~#*`Pg*tLq!c#VSflnzAW4M0(_&S#Bunf_97>-*2u!v#^yaK zlmXD|Bqcjf5e^Dsdh^OUS%~EChWHzTL8MX)V|VYhSsCD8dcA^4zq?pyDu)0~)~6qZ zjX{C*Tgf(IHmE3ch^mys5fp_*#*eIBS&(~ElrzvM_+j8;d%?426 z`E-WAVSL}(W`+#DF6zox;4_DYx|Zl*aQOG2_mMfUZX#k)me-eo0?bn%zG}cyV;?Cii75h0r!mRZ zz3wBS&}<@pEolQ4E~m-hqQ#W|T@Iw)oYscoK8kwX@rB zY!u-A>W{4h{~;-dq(kT)^q9eq{8;mZTE=d9kkBY5y%x5Rzm&5HkllS~@Ge+O9%ncgr zk4;Vec(b6Af8Na8oQ6HnP(w`(KF#r}swzzglBAneRUfT@kb|T{bSuad!942xd3TSp zTQvjt@q=4mzrJ$qS%N=Cb7E%zJNSi^Rk9C&soPke)=%N&K781yEsHeF zMf)kBLxe<%{yl#n&3k)FcKIBkJCdM$rYNRkv;j8ikPNH$1ez`kRGh~ONN+%toRw83 zk|>bhxqEjgKtuJ;qvyS`!pA+kZF~>n>mb^#tIIfbDi=8q0AH9}SbXGXVmA?xax3cr zbrGM4(dHYHGV$u!9%(OMPJIX&@TtgoZtema*U6KkqoY4PwnHhZLlr#Gd{sznb1hU; z^E|2*+nkDx^jzvDuM_$i-YDjNZ6W$2yTKtE!Ei?SZ`dj>F>>d)6K=a1B`tk!~ z{bY+b1qIJ=uB@IB7dPyFvj=U_aHBfYc?aZpdi{-8%D^uFQ>X1_LaET+&}xA=>)|iV zFaRK6vDj(!_h|EOP#N04D$y}ARyYj07HA<7sIDnR=JQZ2PCSI2k-TB>>YQC-delhA z_5oUs{Is;Zq9UQ=$8-KOc+oiAS>}1;`t?D8&C}r>eERg7#<_ux+?1s?FF&=AJzHS=Ym&8bwE)psodeai(3j3m4!3ne&?r{9r8;NIrv(^ig%aK6rD=N~TJtIvamnZgAy#jPi z2!*l~g|mwbe7KIdx}sIbmeBgF)x}Cx7_hO={PE*)skZ`dUvIvB+gsGRzBb2)#qNVT z6W@(F*6llX&=BEdse2%!=QVo(KgNY=0z=t6?OpGRde`?7YE2v>Widd&KEr=ETqmW< z8G_4Jo}QiM-k!&rQ!HkdTnBBaQ9)oBO1$wYEkHDu~T~;Lbk}o4DhS-yUV1MZRB-64?SF zdx9NN1VUC!djgdZ=i*k(1)9;ZV+Xeo_)DzMcEWP)FHzcUlc9QdfIgx|g>yeF!C4c^ zT3>4KU=xj;ozT_m>CIO-lpk=&$V^t=&dyfg;^M-{wQ`-Bnz|6RqlCJ;`uPM!=x19k zwY8@kR>%nD*Db9wdwn+(ST|<$G36^?D)Yq$bu+Pd8lfgDW3A&DjD<6IhBKW%_x&b$ zUy@w~Ia0|YI4&dHS1e$7|AB^sp;GV}RoOEMF;p#1cESvH+Yp`F33YLIcPU;vBHHy5 z0#c5(cnrmYrnJvWdjBK-Q>3H&UZI?B4u%xRDBT}d(I}LcUr{$r-t1# zTW#&k_Ho=}^~=}nZxh)`Yelh(eTO4QSac2%Z2TCvR;|l7Q(oTAFCRpM)Di?$V6S-T z($>l-1iAQM>Va1PS}~5jCw2df{H(4ozD<4$*H?ae|M(8;*L}xqiXIx$Pj$NTec3~p zxv8qHy*?CgOR{-G>f$pSs*fv8mR?zS@^g$XS5f{XJw8iV`iN5nn@~(pqU4wl9lEZf z(r{ALV;-0Kixlt_R99C!y8eIW#uyg`ot)kG?I8)7+_o(T# zMi#aQDmge<;u6#@1XzjXlt%2L=OB$)8Zr$^`#AQ=ybr-=-1_E6O zjrH9Jcfg$m82}^~ov%+~826TS7t_|6`?vrRGMzgH?04UOk1h|5%^xrEz^_9MtVaSN zio`654Q>|C=(_dI&v6fO0|J4&xcvM5?Vu1QP9P4JXMZBHEH~a$^eJ+LppLZ?iW4v6 zJbLt|ot*(9h*=^K=Lbeoh81mNOWqVAG14m%!kdNZF#NpNh~E{=BuUo^Hs#RkUpnadqbn- zU+PPk%3VE*AkG(W*PzY9EqrWkCDdhlgL@eXW2XUhI1~h<;{^)f)T2#dg+h8{@hO5) zE)d2*552{GCe73xc0EUj-^5E*J)YAiZ3^sV@7UvhZp z0Xo)Q$>iJ&IYO5$ygt^}z%nk3q?~}9f{qUXvqO!*9mf^{zjrcv5r-CIO^83CI^7;% z2+shfOmG;2L*VP#dDM3H+OiYzhpDNir0Fdz zd%MZEq?~H8WEQvo*&(^u+uI9MLxEPe|F+Q2Lmj9AvvP9Ew2vcZhu|kNEWV4tdDm+^ zTL_uviII_ofPg~AX;*()052%tc|2W5&j-7otK#2_QO;y#b!BDg1k%*!L1utq_V@^* zt@G+v86{jxP}D$*qM2)i?1e{bYg`oUP$#UeVx^dZ4qK>x1);kDR+{Cn!0^Kt2+syU z{JU;H&^}+hQ=Xb~DhpX+kYU=*$VvO?>nAE_FfcI@DbO0DyzB5V4d~mNnl`HGI-v>0qRVcuh_rqG9V78lcQxxfQ`Nw%>;vcs=OEsE z9M4EgM4M=2F+Dn(#K~Q}iLM(A?m>!3j+NEk3go#sdX$l|FM6cVlKL0BipqbDu@z)^ z$x@+VANdQl!UjIn-XVR^5ag&nc=T$Vz!?z{b)IN`$^nU*>bp;b;s+FzUZsZFD#JiK2|fXxwhPF#cV;MZIfCLfUVFVwK6p z^Z@D-VU?klBrCqT#6vo#Y+2DHF9%Jf?EfzpP>%WzoB{X zsr}#f&2I;@`1gM!HMHd-h@SZSHA8djf4=hzructq$R7rnYBB}$vEeT=P*&M71&6p2 zmXA#}3;aj$Dh1AbX_b_e-57lS85zOgC)TdJ5J~O%f4BU{$fT}8gqxuXh(w*uZUR9R zigV}EZmMA8|NVc08;1ij21(DwZu;Ubfqzfx|8)rPzb}KGzFnd4^!p$*KrBL~yg z*byR;96d&6=H~AfNt|QhLezgB)o;gpZ`JKi*!E-7)A)qzJ2dWvInabJ85Hy8qZ_*qu@O%?Mi-xdGumrXRpyRxSQ~atM)3ZZby*WrXV}IU>6@5?*{XGkp3R%OlU%(WI)4&#bNNMtTDGiAEVo zNrtc_QI_6Or$^Dzs@D^!Sx%iek^bBqcCek~wNq2!s8&&lyEd)SImd)X_5FK!topW)JxG=<)CwToD@8=;YC=fM0Zddse;#_ePPbn^l@o4? zs~XX9r&7!@RLsi41y}KEBhZS{@NE*4un{3~@SjFStph_d2O2G96*k=M*_{AYUu>o% z0<0|pU*Gxj5bFLLW?&N6=V7n~_|unK$!eJ}kn3Sf1RE3v_N=~J0~5#Z^`+j7 z%uMe;qh~}}HZdeg=oUB1{|?U^k)C*`b5D^_wwk_{mcvY+c(z&*05<{bzcSL*pl{9z z4vv57#QXyyuZk*H+PN?3Th|9wb)@P%>w& zAp>&e1}=FtzgNAD+ZWwz1Xlk29gM|xoFl~E>Adotm4(Gf^P|b#`}Koeds!l4o<6mg ziT`&v-f=9uY$tT(dok7Q3A*3e0R<8Z6BEQpjA!58fAD~TmUiLS!>d5W^p2YSn*rM8 zbn6HB!MSL;K=QS_7{V9S@q29_a>lUu(#qD%{b?T}>9FCoa`L84ZUN-z?(x7EuRb3~d=Pm;`6)5X2Se&m>D!W$j2B~Th0XI0@%PsE==v=7 z_W0zMlt6rn=W)Z#Y_o4iFThq^yNuP#EpJpZLs*Nt;g452XhArVkJGFyxiepIlSVBA zh5w$k-;R&o`w39Hl5$ONw)yz_vJ#)aecLtYfX@GKqeR6lY+i(d#>R#j)1j7(eIWkZ z6dehaebDu0A%A1Tr>y5fb3y0i;mf~~O$IqNX{{0!lbGK*39dk83a01GqQ$-ac5H#< zTMSVmRfnFe2?uqGh}hr;Gu^yjw1HnoMn=kt|4u`3b}+{_nLn90+a+}_{74{uP)TYw zW?_&yC011_pe+^id<}_%rQnbBrykPTZPq<&r#_Sa8~n5AEM231*KL^6S@cFdz*V+WYq)`*{XoLiMmaXqBoyFCifsF9)60z^pyf_*foT zrRekdM1*-Bc4I(I`m*UQf_UlQ_xx=|jvx&G{d!l-_CMeK|Ct#7@6F=>!#(fs z3f{bN$cz7X^<%MoTW9m`02tX7xcus^J_4Tg?Lu2G7`_Sjq;;_-SCo|GP-uooA3M1& zVw7A$qJ$L3UdZ|%#l)b+3jA7N(R_(`k0R;q+qbAKV?Rs(ePqAj9-LDn3qc@pTg7;a zvSh2dPIo#QUlpBA0A&6FN0DvsYxlXDuJ;i5(&@Qje1;1%gpMbpT>`(xojzJpvJG7) zO6`X~O#U6#sdNHc?O*R*UZc--H9dAn6olCMG8OkrYl#>nj@) zp2N&6)y}+Yr%!i!PXB0q;o5Svh0qj#ikY$N%9C@s#>dM;BzogLA9iu{Dy;rwjOp_W z3p+(GZ~M`Son}loQ%~L7b9!$5lv_5%t(|>@#T7B1HS;fT9e;e`9Tpotsl$t65h1!@ zvYtIFH!}%8OUrVw#2QuA zE0nDSLY(|T3Vbw>&z1ijvVsG#)G?TmRj1Xjo{{*^$>&MgJMe{k@j!+wpqUS zrPI`K!O`HRywc_hMEI3bny?D}@L?HlBL;>s0)b;M zs^iThCC>M=UqklQ$X%gB(LXelhTHLGy2SdSD7n+|3c|YD($W~-|Mu`+SSW;73E9^w z4h{l|eEjs3%*>P8MdkY_mdWs777Js}7}VhfRvT&ZM9o{e?J1?uBfR^A@_{%4q1|@RG{nGs67&2 zXCmk8n}~m3i9Z@8r^~AjPRETz?;p+03ikj+T|hIA{ngj&kWFJI$$ziq`}f(!PTP$u z64WFi3yw`~(Vf+6WU;j57ts+FA;u?C7ARwT7`4!3A=4AUd)TcXOTI_EgQ>uI!iChk zG!%gZLV)3eN(0mp7!&2R$45th8FUCS7e&tX9NfS*uzw1G=tm$m24hIAJ*YN6cn7DoU9Ric@0yfh_J95xgAcz z2x!Fa7hCs*KLqsB94AjENFKH*yhiYQwa>-m8S0&NOtZ-eh&>sLlsW5IqVrQtRTW7O zgLB)!$mOK$!kFXlNl@ZFC9{p~FcCDTA2X?XIXN$1s&ZeC5L@I3u7V02cjtZk_5u9P zs}8H4IOdlrDMzGJ*w-lH8xA2C>bv#&`g*0oea>gf8C1b#g@u|N4={s)c@aj*Q>U6p z`$^zG58Wnm@$kUu2?LSVr^kzg?DD5xooJ8G$XW+8Br@>i+r|rWBH-LR44@b#zaO}wKn4rgxM31LGRSZS-Ob7Wt)~OEuW=64?4rx)gPKkG0fc$e>fx)PRQkXF|wL(41+n~2)*aLo1`r5=*W@6-ghRT>;HZA<=R~liyZrR z-L5nU+DvIaMDTm|jN_*bh88L+Tf>9DJXv{feU=QM+Gg{^>1{KWJ31K{8Ic-TKS)W3 zd`K`j+{zFJjyLV{qk^JwJ0`TyhpBe`r4>AUxG#oRw?Knu=gyFdKdrXtN(&7tiSLVH zN$JiuRFuC5C=fb>(>D}pr>Y4As$dlj4N2=o(21a>!w-Uj{$P-`L-^2^f1g2$U*i2f zqGWJJcZs}r`Ft#WI$l-sL@!~&&!=mRPVFSpj%CpJ+R#0(AjV-NCCq5MZDcU?8?74&Vtm3}l34NBu=K|X>WHkJE z9?YtzqUK`1{zu_|=%27yOdDw%U0wok8fC+jqv@^(}Ni+EPrHvitnhm(}&$^ zqIct;SxCNbyF32|9mZ>nln>Jt69nmxO*^|{^->ii1DooPPG?;2%gY!Z$z9je6TeMF zE{(aBRY_@g0O^7%_UqO)0{2n29`A1M2*)b~z&pQ}r{w5rRSUe*7fvW4|o zPh8dE+r#!MXY+fTJ(Gm}&t>e;%muY11GQ4`LIozuf`he{%)8zV$=9jM-xmfw*1sN4 zoOlu)J=J#c+M_y?2eKSF?ILH=d)BM+8-1=Gj$@x(!lrMko3(fG-Lx=V#NVwE#LgQ7 zZ5UmihBf6SUEZShaWVotEZ_5Y&&}=bvWaOjN8Z`KP5*Mtq;GaDLr?oyjb+z1q{TQ+ zb&ZBGvLXi%ACMi?J^(A&ri4sPbm0$8`C}=!uiJ1DL|Le-Wc6}t5DKEBd^pmk;}zE# z=jitF?h;2Cs5Es)38c@)JMT1tj!62`*|$H;^2-<6;(`10($ZpxZ!pY1Pl|_jUHLs& zu{Ici{!DFR!M2~1X$L9X<57(Mr~3MoCUd#ePXn{^^7pQ!3hWKp|FZ9A^=^2rVIII` zo+h~ENEpVKTh6^pB@zl zB+P1AZg(UPD`b-YzVI+EPHaFp7KzK8EuDHhP)CUU89A7%@vW;%Ht_kI-rCQfkq6Qq zb2=_d^_^1;@KqVlQuJw#}rBgN+ zi+uZL-6kjB=&z5_3DJFlsQR__QCe5Sp0_JXWPTUe?w8hjKO;Or_Fa1V4gvnhLe<~J_l3@YuGw(f+r zibc#LwqdBad#bK(C*d7FXyx9CfWMrL&sGbqAN=w9rj@!nQv0N7oV>iOG45q&50O7M zzHmvh@cQ)wdO4nLS(FT6R0J6Kwi56t5fVL3y}fj_NzybpNZLF@A3y#AKn&Q zHG5s>NNrJo5@$ze=jlQd0|UQWS#M9fbFizk@87lJRmr?G#rW&bEo!QsCVT>{&&u#b z1G1W=M9*uI+kxv%RsSyX!^yazAlS#r!2!{IT_eNe@m1!6dn>HcPDs z_YBRUM0uk^Pr03RgI$Qg(YV>UakkLJ+S;l8Wkgyu?x`rpZdiusNfcYP%LE=L&?XNf z97AQBf2D!0?oD0Y$%3IQwQ&Fl)1n2>wh5hW3+9848vmq=6d0s+Tx|o(I7VeYwc`uYQq|8@ zX}4ENVza2AaI~pPglT!&XQ@}^%9@XF@ef!JmzUij$xX%?p@G+=pm1O|3b5A8SK@CE zxS^g@R(^nfhne}jlezD;CZ-adDJNlMOryj~PDX09im|b`m6fAj&&2YwByUV-Z*ON? zo7{)ZZKOnvf&wStMPg1&xU7zhyi!a@t|U2O|Ni|*(%3ued*(5iw`W~lT_a_mp~u^G zdkf*t9VIMEN+7|*K@m`{@3*Tpd7!~_h?yA`VfY=TPV3hj8$I9%*4D}vbvF0*YF~G5 zwJtx{2rcvQ-~mXmAISbfz*<^b5G0!1QNoD+?0>IGAVAEW(XzejS(RZ$ouFQs$Kd+X zruf3Mrcoy{0t)j(lxE7x$}+*>@@ZMRrB5pj!o$K~h=AO(RyG@*)K?{aP0fp+&-=4s zTN@Xr37^=&EV7x8RCQFI)|Dx%;hB@J%eIKiMg+I$MzwSwmB ziVBS5oc#78f%2$fsA&3E+_Ocfg#BKA#7i$ZgJ&h?GqN74g8>BS;ZKQWc_o|f!dx#!5M z%htipr~LBrTD{h#Pw_~iH@K-u9~H3#)>F2+Ha1dztXSe;mB8i}P^xV9LPSWbx3AA_ zYoi;WD(8tzjB%~4#sv~|ax|Ik_<$>{IwsrNc4}X&2ks5yf`;xLLsl9-L`dfR2oI;! z&eBPp?YUprVRbx41%cctKa53^@*y5i*E%C8NUYRMn!a!OwtB~j$eA~pMXt@5wUyK7 z9YShMXhRfmQ0xtqcXM-Vczjm)_Aeam@PP2^y%*!-Lrx_YB_$=R5EWpG-zHqJ@&)u6 zd3*aB$}FP8(9!5wO2de4_q+mfDE+G_MZb4;uD70_DSR(Xm|?ed)3v=Lhf)sXh}5ji;;ju zUVLt${m-H~&1hv|2??Tmh%=_xZNXHHv%yU0pQm)fpPtW;A2s$CJJ&`Z+f70cO4t~Q z^FgQNIVKVJk57GleJwScM;lMVR5XU}+qk#|caKsa^rA^gM@R@fx>ApxJQ;E-Ui_De z^MOo`gn%a!d0CQo|8kv7$hYaHV2}5O-07aC8u0MQpHyW8GzhM$uY%jg;5?)*0Gjky9?VSZ#EztrsH988O+Edr7%cRNnPPY8f=P#Hi7<5Ga<> zJeSd9ErsIgnCkna0&KmU5^}mg6_t!f58^bQ#f)DuWCO-GMIZe6{6i>X+>i)NM z@^iv(I9CYH{jvW6 zcDUI)0CEIb3*mpw$t*vAt^g(vls{BX8R(Gah#xaE^A?i&<=CUwHp?;S%2x8nesz=T z$E4b1-Z0W|^E8zdeTj%K=xELuYP93PE>iQjo}MnGaoBNc$sa=F>cK1>MAbUu-cL(2 zMOC2+2b4C9%*>CKUjPLV(keBnd4=$l=H@%88qaiI351)8BynYV9W4VviqRfR(&u>`a0hOzdePPYz4Q z*O=h#xRetKD>I-q46%38EU{?N(k8x5jvAObq4$KAISL8wFc)>(h@|j?Zd(|Q)zvW& zIlND1wJOTQ)RdMC`P%B4c-nv_sPB_{kes~!dH64DNa}C*2qia+v`$Ee)%;ml`)SvS@`};sZo)i=q@-;$i?Xqi z5O8Yh=_NWyEdoTS{i1|f$!E1X?ijl;viZ2^aWG{9dV$&Qa99meKJZ~A#u|Yqf$HT^ z^`MCG_lnKsB+*0Y?ZLI+gFZEqZ02^E~HDZ z|Ji%|xN~(2%43?F)uWZAq@}%`cf^*JZN$fS%?@=8zODE-sVYi$N8+f@_WBRgS}Ig} zBg^0CmCmbR@-rzd$Vd2mEwtO_Uk!i1g{>{1r_Jt`evK@h!CP^>*Z5+;8t{#sXPIV| z55u40A8onuLiarGJRrCMGPTfpY;4ZVV6ugGzcAlCJxsv_CYWE9<^1JhYZIBfCtUt@ zb&ad?du=Nvqum`x5V@a=i_5r+ZB|x3NI^iNc6R;3J1d9h(7R=`zFbk-hgADAtB%7I zfmVgRGXKW?(dgDXv6!;?X8<{epXTv0E2RyJL7SR@OY7IdPW0+=G#AyG%_r*@$YJUB zC)FXaKJcIneGZ?)plXGTtU_H#_;*qQ8gd7#cRMh_9S=bgFE4MZR$fujYSx)2XFWK} z{#A$@=B|ui*|5fP@xNSv*6Km$7bPW$U%t3=#-JFq*s?v%fG?_Pl#~Dj3O6VZ0hzr4 z*UB13pl78E`OFnMzqVmXfj>`ltruvs(!dx;tXVY^GAwZ!OgZYRqa#eHoW4W67Rbxp z@Ij@kUO}CDx{!(0zFW)f0p`{lZC-=1|&rM8X-%y_%G zT~n;N$r+Q7lq3VYDP-O8^2qlWN%9&S+_=tnOJAP{RXlST8-W0k$$_W{eNLQ5vAspH z$oLHx)ed*(-@4*B_hdG*6kX$jQGC2wz`v}ltVtwb5?o4tWMu3Ll$X0ohSnjGB$SB|l+DfWsHrg#?pYkH ze%sji#B^sVU{vS zBrMcI*VM{bjXqEJdIh$ zt00I64j(?Op0ed>VKKY>>4iM;N!a_}lMvoAR_Z$E*%g3zK)TZP&wh;~PVQ37LqF>3 z1dPXpPOT1KRFlpC9OLd@-lP7*f*nN~LdTECDzN(=sja^)_9sB--Y{EXFHx?+_9L*< zR6xzJ+<<|W7W<;JlM}E^yZ0Q3|Ij|V2e-Mk^?t&=>cM*_TWtsg?+TRO0Vw?xDBOr~ zXQ^XIOr3*@n(WQ-s-<ja z2oSKwGAhs~uASXR08Msq{fix##*2l2J3q8_bac0-?)AYJHNyFcIZEWv zTCj&aki>oyAPC8u5F@9TG=C~@{m2F8C~AU{0He5g@r`nn4HFb0f;(!*4vaJ{U7RV> z=f|7-H6|yHAE(`_#p#06m_P{FMjI_WzpO5rq!j}!KM3_^bU+~qV#(?i+dZ!n)iR6( zXg=gv+1L<^OC25er11ZmTSc)60;D0r>&qMVpLcQ{qQJOwPIf1Ow7Aw)>MynQ>iUw$ zgMcfQ-)a5`ACBl!!N+(veZp;FbiZSOyN3tJ3NLAUt4Ut=m7liw`VJzG$t17I+*z?E zHpxaAGC*v>EB~BKT>h)!i>X(pZ$np&tm~Znm8+OhE?hWFc$SkBtMLXqD$w>D>%Wf5 zyUHN%fHOuht(APIeIj*bPFi~b5*Snde)I0L5n0>xhK@6>RfGQcXhOYNV5!3A^ScPZ zjj(poo;XcTN<+49*AC3xl9pcFz){85^nULkqQ%}LB$qPV@nL0f6SU{ty>zoLv(min zelq)-j*rRsP*8QbZSMeH8o0@_be_h?e>M{;=o!Z@4!LZ=4G|&~@MFgT0ubPvHa2QR z;^a_Z;BgdnGTzTIC=Tsm9|E+sZ?TaN%@qxJE?gQOHl?K{ zh6YJaGMb;f|+-xL^8NA{fw_KGH-nyp&-mo_ijhB zvZ7aWA~Pi{GLn{}COTU0B>}+K3>6Uo`>Tx-N*;QOUH)_Ub0}R92!9kG4^bHmX&u>D z?B<^}j4Zl`T)f$Y#wCqR>*GUGhOlpt$e!cW{*gOimVd3FhpRwh{(~gW_$#@Fz~LtE zl%l*{S6lnGM{gUxTS$Hk`0fI5qX>i#i-VJMzjWfrNL=~Wn*RN+HpoVfh)50HDP=!a z;8g7N>Rz`E=kh1Kv+%KZl$4ar&xbLD1#*R>GiYrj1=lW(<~93d4KA0p`Qtev7g%XV zM@HcCLja^uf_!}Dejz040h>llX@pWW#MH1X|80)9m$kQVnVl7&-7!gI!#{sUP$LY# zd-whlLp^VNY%H=$p^bhJA3wgb8@M*!76{f@wpV4e{V(0 z^pv|$RJjW_)Qj0}UvA~{!}nWp`S;J0v$ylz<$zu$H*ra z+<16$4O2XSsdMr3V`azs`ohePi=HwN)|w>sTle_;*wAAc{zZi$tj0(HeQU@SQLGus z%hU8X_NyNJX0hn!$Ie6zx9h;mkRz6|csPs&;xVi|Yd@qQ@D1HddnqWgzFQaDpQL|< znr&hUF;6UQVLGAl+j7J|B^^->!ZupxyVVj5qqUu~M-KX&pfe zIK?0bUH!}oa!j`vF0-bz=-;>@de`oxe-#%muWlB5#z`XYXOf4&Q-N>x!rlceGj~c+ zM2~N|%SK&Jt`#J)MEkc{^eSs*y@yE&6Cw7*;W>k1r;PV5#;)Wj|3xIrgZkfyJ;gi5 zcpuz+P__5qr!~oyHMA=|*iBA+qgKK}lBKo&au72Ywng_fQkxE@IXcVB3kAxP5LR5v zuDp4aB5~V~=G#=z?GjzWy}m8#lZD{hf8@+S`VLfOFF{DGi<*Evp+>+aQE>~E#*R#Y zeOf2NjRd-SdhlABnhf#c12wsQz(X&(F`#urJqd||LkSZew3k&5;Yw)X~UTUy>1M$XAKP;pWfc)7Z{{e`4{T zx@Bo%f+BTXQ2iEDCAi^Q#xAL=lM+0oZ=hSxzlxD@^+Hi;X_&$%uq)B;a$ZeN!o3xj zt{Uek_EUpPSV%|Qimhn5a}G|s9P}gsAry*lneq-3jagHW!xIGgZ=@#Rnb4p zMgLx}!u`n7ztquDPRet8rV?dYk+Y!dUxhOxz_@FPubD37MMZ_Z>(v{e>8!R)nW)d4 zIYayOt8RA3*g`?!6uQm~w>vZmq0bLrd|@cFnl!NSP>u5#IZ9K%nh71`GmtNnC*1q+ z;W2`sQUIMQX6a~gJ(6WbA`}&iwCl*%eV4_EcciW#5`R4Uc9Z|s4>Vb55j?zude@?) z_w6g(FIp|6nEB~Hg#?^0++q!V&K2sNvnCe$+<>oT*s;YT#)}&H@&R)nJFNBu$(Nut z_v_fg6ZI2=T@uGWtI-81F>8~0aqsX_&ed(+3j&*v94k#{wJYXZ+ zSQth-*Lh_pF{YsEL(PuM{FtBEo&5mFwia>Gzq-l`5@J{N@9E?PqObLZk$}TNXM4@8 z?_(+3-g0u$*pQt^!#;Z4MRtbteBJ1$PbP%QH`iGLZykW7q7BIqeRe4sQlPKv?vlBZ z5`2HoKv18Tm)GkmKu^(kq3a2ZtRhKvXnk~W`*3h7bI~IVmUyCGeb|+>eMMejyQ~<)@loa<11daXk-JIn ziZ4RMdX$+tLxbql3_0=Cdt)v$I5^u^)(BN1t8;1FTz?V-@ADFI*YlN7B7FS2gKR#> zFIhL>VI6_G`>>IjV_hR9^;EL@ZWtBug9>$zEnHFyM+MK!Kt*AG{-)u|UpXLwy~A?? z36!W{=G4YbQ&;D3bEE^R8ks+rD2Wmc!o_>wrkbydlK6S*(}sK|^?jg}w$ooOs9G8r zX~i|;v%&u*7$e?nhwr@(E8yzB`4}!)+wXD8f%l4ChKT zscc%SrSPlX>GBYs{=0huYE0m~5=x+>+=b+wKD*LVOAW-@5pN*Y0lB}&b{Z{=)*=7| zLxRtIeX~bjoCjrs+DSgXYj2J6E*y{}1-p{*ggO9^>(fYr66?{#E-wv>G z3}MrAMfUx^V9Xmv=DB%tv5B@%--)h&1j1I-&J*3FNK?oFEx`+86(eOv?{rCYA3f27 zPo!W?zMbWcMLi$B!RYQ=N+h7?9lBD_(*5_DV5h3{e?dTWU~^I-m@g?dyIh=TLCegisIjqw3=9l{35~L>VnWaDt*uX;Opuh2 zcn9{1)YqZm@d?Dq699tewKTqT4kjE+*X}0s z{Db_44Ey(=M{W%B-P^aZtX<}gg{lRt78${aarxUh>e`y)-z;1z21JE~-q{b>vG`MseMHck!xh#tHZ?IJeS0#X!)hnNqM#K9&BE^2 zK>lDMqo*h?E8{(RGEn^%FavI>6EOL;XPhGUgZLSP7H$aOW}4}ttT89yzb!2tM&)L} zVF9ETft@NZXXcK5)oQWny}h-W^69Pn|9{S?*{Q=xX%1z1jl}v4JBWE#un?Z8WgzF& zQS3=ysmv|{Fhe9HeI0R1)d(II3pM!_)Nf?|s z=pg+g5V~wI6;XxY-mEj;$$I?wDIqO@pc>b%VROCVF})N_ew&Lp`$Crk#$AK!XP#+k zlleJKm+78;z`;HVJZu>|r-`AHxmx3JgdO(Y5|?QCRJeh@0lpQaL^mQxa&hs?9CWq= zTm9jC;tlxFycH6rim-a&gz(RX>$_QOOob8xpk?nVnu{)WR;4A|M@Fg;XuxM*8)=J7 zeqIKk5AGlPF)h)BAVdStgqe_=iAh^mm-1B-F21Ld9(St7$6q##pec^X`70?gM2iNg zal+U~dJna&bz=*tq6LD%dHgt#5CTnh$5(UbturZ-|9fP~fB&7YnSPbq8cSNw+z-SfLhNuF;(--7Lqn`ZV#k;C%W*m?XW@UNNQya^~gWb0B| zYU-P3&s;lRok0@PIncD#|B&|o(fiwAk@@Bgy%M9rPsb5~^QW61dd2oO^HX~7%?3Z! zK(dOd4Vh8G?kIqPj0W*om`u}Jaa%u%jXk$|Rh#P(>=YD%5=hOIdOc9K22}=AQqywH z!IZ)eA_wW|4<3x;y;0s~A_%PNFyS66bVjz;)*n6B9vaHL=%nsXZaMIOXI<_HWG;CA zckS9$QX=8uQA#2UutHByBCg>a4Tw2;bE9Y5{?uE4SJuI|0>VFdN>45G^hx>)o}PXh zT<`QwfrPQJx8Fh3Ys|ZXQC!rwfvB!#&;jhFh^Xk0SbuvvK1WoeLJmPNTK+>yub7lH z1v>+*-39N3^>ZGBevGUg-a!c7LBbGrdqS%lI+sP)vgzq*q}kvUA08UIW%Cz>-t-h_ zcz7h)*pS=ZI^uN7u%ge&=D{asiy&%c%yqQmvby8>C_`GkAlzk|E*+*pMJntJ~yEX<;!GJJf# z8bFV*qa!KhC<{wzatrnU|MZ-EX7O~wy^F^LmA`l{ZwVzxF-KJo67Cr>GKhrP+uH6a zeKWb_?<;#x;nPc*HK4}|~q$(rS zKak03(C;L0#nO8F-~z{IMLUm76hz`3qsMQ<6|GE=g~4l~W&0k@vsMcNq!82LP2hjf zKCq3LKY)`s>Kzf8Bzsj$=zN+c0O}iD1lS)txfm2hR3H+fkEy^hSOC*tiwI1a%z)%z=M@$W8R2B^H6MyTGM*= zWMReQ=g-Bd&n_Y;qe_4m!UiXNNvNGOJIF}$>(`m1@o$w+XPeq*r< zs5b*ie2h#Ev;wH?13bEjL;|4=9WSGjyrxceM4JWs9%Fh%M<%#_4o9dzQVVOtYW8p4 z!`XQO%#Nk7o{0(iT9L~1OLc*nQ2F}W#Gu`NuVXPP=z{n{@qfbv4*C0}K)F>_;S}-< z4V`b#ytL-&%^bA?+Hh~+bA7j;Rs{eh;g{BV1xge>#MR%e_6gNYveY8fC9{Mips?)_ zrIMp#h|>P7_5x;cr{LgwYv_YyG;G4;Z&jcPQ=3v6GVKYnNWo5O;{4lVql?519VO5C zdiCTtOAV7y_WD&FdLD>cPiP9#TEBh&j^`JG#+jKTjN@?^(m{Wjm=2>xx@ceq;#qLb zIoa83uO!GEi+`$T4l6AbcVYY;9UUs+eIrf~CEOkG@^Eo+wF<-@ z4pGck4&n$KP7{>=`O?>qe;bYhVMP>!Oo1Cwgu8MAAIP&-1tCVt(mq3d{q~+7QUVtj z*N~H2;i~K1yP2&P*f??YE@JgM#h?nn8eh;`%pA^Qf7Cbuzks44Djp!JU~s&`LFZgt z2BTzGmn?4)T)fJQv41tSwSkf&PoVhD^uMr!E$FMjOvDpYPwLA`fEW+NHJKbF6QK9b ziOs`O0Udaknb7j0%cZHDtGsTLS+|9}^wBW8<2i9hUYmW} zKjK6}0M-H+xVDy9CihEe!Kknoj5EU1#c!#fOm2ph6A8o|cKfKOU=)Iq@!h)x1r;n8 z=H|NazCtB+s`)f-DzzPony4{O)j%HfjvTxW%#^#}oIx6-AT=NhUn$w2Hz){xtf0N4 z&wo%m1=YU2eJ3>V32KH~LY-p^iV82s8c)^;{9(wRo|qs4Au!*?B}%AfM*uyb+|@qp z*gioiUpe>|SIcp_39xfBpF`4s7j11QN-?K&O`r>1Bq>6HeQcyjB(s!8ZT2*`OciN{qcGc65kOBka!ua@z+rV&QEsm zbgq2J$+>A_f@yB^*KQf)Ys%w`)!^dhdkWF_$ddc*5)nw;Qc}?Dg)o(!gzp_4;5^`5 zo?G+Vd$76BlUqGSx&RpyP~?2NoTvfA33>((N8ACLhJEr4k{lwqd3g~AdwNtGipvN3 zByu#!2uRgn9#5Ac@nhwn+fyxoz>56tU)0CQNZp+^vbM9fgzi0HexV5eAimBPu4qZ^qZ3Y&mRAR=r^VnK8%hyzjrlJQ4JzkrgtAw!+2 zF4l>k}?PN0sSgn)S?#k&M;#g`QoYk(IZ2dcNPwRL$gs5i5D zYzb~F{NxW~wD;Yw#}O3RfCBqUlRV_X+|UxrePMbO*mAXR4d-1J7 zzgS~}PxX)w9g1V*<>`W|-{j;7CYUQP5HHP@9oXY=5(Pp)HFe!%&;CcC2oFWkztkLTux|e$8eGE6AG2E~|iy9j$_*jGTRTq7h0M>vrt$!pH0^##GpQ zGw&*9zToFXA>r?ahK4djdlwhpn0m~Kz^r*0l3K<@&zvD85VhhEOnvzxn81sQy^aq2 zADRj6G?uR(nMaX1@G5i|`Bw=is7a?F+ysuzUYpJ#(%9H!0FYJ%_v_7|W6AF}xaJ0k zfApCIEMiz~;B;oCfh8I(LBfg9IAGZfI`9;;WZ~6D{GlqNA_F^rV+8&tuI~0Qdgime zIY}f#+(xtXF}KwsF)4|ghX<}94K9OsW`_vBzQ#5LP(}`4zI+Ap0$@VJt4sQlcuVl_>3$Rx zyP`K5TQ}~yqlXWNhkrLWH%IVVOuf$a>ne2sV{k6eZKmXHS>nDyoJbm1s4-d-T{nNc zZWt+Xo!baM0JS69J=S*}7>q%&_I)jVDj?K22pFbh=yL!Vju>dCjvSF1Kv% z)@}lU+z)C~Us=Xwp$cZcICR$?qU0nHK= z$yBTFfEZJxEUQ_*_yDQ@gI*)N;%jS2UOAQGIp1n4RSq-(aviQv7)b88ydQ|=b1W{y z$4V3Ox%95j&u+II^;8Xz6fbppj_O7lcZJ_iB=>8qZ+-FkEBkK)GR2Dwoh%<>cb*d? zJYzj(qT=XzbGULY?0Tn+D-TDlG6TaG9T6%WVafrOG5BC<_l{{A=XXvh^zJJV?k#Roh4cdaZn_UM2E_eyIbK5fz8ROC%b8lPWvIXg`3dU!O; zPnE3nTvJ7gYV*U919KCHcUJh+x%Qr+p}&=t#!ePzy)L=C@ic{jjIggP2Yskt)h`HY zaMTP@NjenLgmAzH*6ywKzQ^J}zNbIiP!95j<{cS?pCSm-ILyL=km`tFjhOluaL>R{ zl9^TZ;rzm0eCWsN@;aw-UcEw!;_Fu>?pL^j5EPKb{(Z6zOCd7*4rL)w z3`Z>0!0~8hOzQ@3jPhVjceAkAb?!A{asuV65YfPyW+>Ctyc=Q8sWg$S!MaCKq(@5z z>5Hf+F!<3?CHfjQ&X~?AMa@TI7SCJ90a=pz1~-}a+WeTCn|u0{&!i^gxdjvgtTc>= z4(Vo}kxxZ0FnksGQm@)WQUy6a&e|sPBsHb9Rz@n3+s-s(n%tMs7us@gbrT0?TW6ay=R}_JU=Cm8Qgi@1r-cdX4l@4X#IU)Z2)_p1;3j zKS^A}f9#3*tQ~+&cT*dZ^rSj#UziG?AyfR zf4O-V7`uQ~BFTJgFR3pf&)FtV?S>=f<AAzY=T_ZX!m-%aCs*uR6MHJTFRU|JCC&a{5K%WY;6akvQUAxya|1QH;d*y~#(+o8+zwdhKopbO^ zO4gGC5*q^M(EJ?!1j7|R~Hw-X!BnLaqG_)SJ;Q2mzdHs6cz(> zp?c=_Vy299X&=DHxw#O`vIHZMBx;s^pN&;b0wJ!U_pPzEO1%L)8}@#Ttf+z#^Vw?b ze9AlW`*-g3QfVPARmNj(Qcou*vk@V5EV30g^2-F8kKW)+8LHoY{ThlE1E3p-??2D$ zLsAKxw#eYA4tH<E{#LT&X4mP0&Y++m2==y_Sy4EqK@G{yo^$W6g*EVH?| z|5Fbl&Cf#z2FD!^>8re02WD18MMbx^Rw`h_ggg7vgo^|L1U|ak@=8k=mO5{!A}@Eb z^%Umh&k5nZ({^@t|Hji+GSh!TT_*FdHA}GGr=}A)Du7?TdJPdkXR~g)4;kZ9SXo8+9Ovu=2NG$k)<0_MTRKLyL zpXEb&_@Y204Rvg`Mj4V2HvZnNKx-I+6WoSEZsCR+EGz*9`1EXPaKREZ!bqJ$6#MY- zen1KU2vt=VkiG^E+scX?|7A#SYL$T7{O>$Km;q!%szD%=X1epkf{z_MdUOE_$bbR% zih+UF)ZUNl!*FOqyu{ANwud0gscq;neY;{{WiV(4(mm4vFN|N=x^E1Kk$F)vTMrc2 z&#wK>FD@>=;q8oug@P2%cQFo|dWCjguw5+Qxvmg^85#BNL_V2XV&DK#C?rEmp{Qqz zPDD5&=hk;1)*XEI;4f8*K&R^aa09y7*t}0oHRPhtNN)nrJsA5~_egJxKV-zk0VgPauQd{YXa^Z&t*z1F;c5jE??91zdG$fu^(hd|fn&Q!tDqx= zJ?C1!5O8c5A7JVk9867W+z}{$?W22+E^_J_E$r+bDZc>RhY1eHQ~)XP)d;0_t2D@J zpm{=cB>tblAoI|NVjS{->H*It5n^p_(U>(^9aG$rU2SN7>!Q#Ut$)xH*WW`faPa!rYSfBC!aZb(& z7u&OE&#I`@*F&c4%9I2yEVyulm9_8?DFH~SbMUqoZoSruTV80BOU^kZ$M z^(=VO@Jw4iRm18D8R6H`&Ryqo>@FEuI;wd-3eYIA(px-{u}b*;qAu)R+N-2RdFHdy z7u3=pJmDK?T_}0nyhlD$Eu4-oDW=lARf7!P<=GRE7lA-}%NwC|daX(dv_QWX|t59w~?IkM7 zhmfrNZW|yBybSA~LrkSp?pj#LvPVmAt!i5pn7gN;y24>l`+9>CNDD0|D+ z<~BCEkyQtvhbrjov134$DdQTJAbtLG=ZN1k0xKp3^Za5sc|3&xHZvPMBXZfQcu;W} zU>E}-gG~?teCb-K^i<~Xyo$HO;LRTt-4Ipcir5hm)!NHw_{sd{$mg1xsBp^dxv1^9 zt{}tr78Ag>Bu(}4o7;-?mbs-Pr~&(5u^}kb(Xp0{R*PFLPm$$*#Q6K1&sGaR7(hhy z%%zjU<_*bfB`AFYAvX33L{^u5WgjFaibzNxw+OxPI2JEGm7*d%XgC02_Y8_9U0fEM z4&WCMlaPQs#ph2Ktx4%7wqpGcHi}M87hKPTvyOM?pD48Vi7G-4X=k9kCLELlTgxJj zck+NdVl&#-UWj5OeIUh{ukf0L?=yj|CH-^N3`^Jz_Bh3aX z7Gwl_&DE$7?jgZ+W_v5;`SXYQw=UgvG1wb_T1aT)#`ehJ| z|9xGS$Q3b8Y zKsZT^q|qwl=hF93oQ#wI;=p8cEtZ7vwnu7rxy9D@pT4_B1|0=l8(z(e{W=-Srzdp_ z%r39=JK8g<5qA5r%|7&qiCceYQ2xHbt6ueQ+`4k==lHIBwm*N{6|cOqx@^r6(epCy zWTLe5*Y)9exw?z@qRp%~x8!br})C+lXC*p$3=fhPw ze&6R(IPIL~W^hNfv}Wu?%hu>1VnjSllq-*xByQsLjr(-PqdtI6f#b{u? zAX^JxgOTx7mD~FFp3S!%yTY$*JIy#gc{emrDpvlziQzki&(=262PujKqhIY))sp$C zU1nru;N&S5*JP46JJH>$EwqoEEwf>zwBm+q9lw^PWnPEXMb#vD@FSV(Z(Ufl>z+4P z2q-Tuo9VK6TcbG`{o7t&b0#LCzOMe!(=(62ttqyVik_ZEq!I9w`@MYi%5|yZ z)P;1UQ|6<*Kv`4A(y}$zdx=F;Q`4!q4AyuDF}waUZ}_In548XWGW5Ew3g%9Je12pv zQMhUUZeWIb>qo(d4@mg17VepxeC6k7N}l@ueF*$;94deN*4Kd0)5=Fj|HCuygH*t! z$&QAq%~6~t-rMWj_j1@sTqR^l36(El1K)KHk{+anq14&jS=HJ)OfM%v#%C~D@{Cv{ zM(f0kiy7|bi%~SMP}Cyr^;j>*xcoA)YZ{OwnYCfE^!2we*M0joYfp1YA;6IDN|C`| z{5Vz7KXdd&wYA&d>)F25hl)ZsP$*&YEOViJs*(IzAmQNpiw)jX(Hv!9;Ebt9*#F#W z)dCPJ#u8|d5mwBkw@5> z&DTd0#>O{>KkgmS0%Z%7?hL)Cl$ZLQQ~u}>@y;FLMf99|B z5MSIe4h}WGZKo^qU%yhAQ|J<wNS(dz=wJS%n!kAMra%K(Qzz{(f zLRtM5Fib!|>5&hJw?_VzqS9oy&GI?Adjz@U($;6%4H;&PT%polIaF-F=XNz-N4fox z!d|a^mC0}E6sS>;#1`xz^r9L_v3`A$o?mVaQ=TB|Ogwz>0XQ6EEk zjIEwv$Td&T^rEctbbg*Q^0}AkFTekAyPH;Cdb`u`c7!o5a9Q#*!op;CJ>dcsPHJ-h z$aehr^k`G*neot2yFUGmLWEVX87DU7peB=xUgS(d{CS_Hr6uxKh=f#xwzpR9(xS|r z>*PsAzBp_v#{%M2EUI7VBFYloEBI&cmYrlWQ56y6wN`pvTN_r=_1ivFgnM~=kc*{+ ze!QD@-w|c7H7dFtLW6+&YR8{O!N~3Ai&N#IM>(G>0fJ;;#(sNb&0dhO(LX7!Lg>S~ z`5swU*LZn0Xl4C*7<;Bgf~tW+*O&;N)>wA`Smnrkv7KJ=Sb*RH105ab>#KR@L!aT= zJHm!w{kjUZDgT4yApgLFNP9|YLH0o7KSiZWm*U_J z(Az^$q4Tcr`R0-8@Puj?@(B|@ZU|6@)X)(*Bgce8{gmb-vMw%-2h$vSrk2RAKn>v? z`kYy7!DV~v;}KD57KRMN0;}oyk!%c{_I)Lq8V*m2^S2zFio<0d zmm{yXWBGCT2b=Oka=0d${=K5*@ z7Y_1SPrvmZc6v^XaG;|lYwhV_viUPH0T#kWL=uVA@r1>dfm=?R4rfGE=!7rEaE#m; z=!=VZUiZrn(V3_SDln;;oOL)8IZWP4%~!D~3&j>IaEA>KpTZ^g&4c^i56lEjOA=hI z{yV^s$cxO3@$6$Fi5Z`&J0>P#_zc8UX~-f?8za9{N~g4pcwhS*)175o*C*{OyV^8_ zFfwnSd)-sQVnmXvQKNE(+EY++WNWW`jY)mzfo$-GunnTQeAD{|9RE^o-1)C(2QjB( z@Zq8%pPZWFeOxYk51csUxjq`(TU*|_olt3=Ieh)CX3meFrDs3=+T8ay`TA*34iznW z+rr+jUoZGY@G=BtWZ4_UZhwie1~k^5*h4{BM>I`&8G5H~?xo!$<8h4^#Cg9r=U+d!d!x=eK!(^hG7Ln1(4z9d51KqiA^JS!zK=ekZMz?QJhn z?R&u)mZSTI8I@9NwRb1f#{_L`qEQ1VO}mRjl=5Qb#UDWjloSHI0fr!eJ|Y6C_f&qY zu2S9tqDMF%zTgT4rBP++O^(R3CY__JdYPmIsgtY-ICc3YX8k3+TlgXbG4KD|c~@8d@^$w2o98WN>#)Ue-aN?AZ}jE3RRM6m!h(cN?}6&w-z2Upz{REV5U9HQ z@RxlLIdonwEJ*&lZmvx++6(e5+tN|0>Z?fv_h|?T;E< ziGrq&b+h+MA4hduhGoJZ2n_=?E?nqw@GIsAXomDz-%3=VxqHm02Luyc3ySza2A}vI z8r`|lW18QMiOQGYxauISs3~#%GYSxi%Dd=j@hADH5Z;fy1c@LAv@PK?;ikWkm~r@U zc|V^Xv23*L{K~mHbK?K%V*G=yjt=ykoM=p=lfFT-f4}5v@wec?ch{JfimTQifWB$crP|dmcUan@Lt8cPzdu zn1j&`htP^Dno|s65T`S%KEZLki+CKLx3bc6EkfoCnlShE3z-;IK8+I#?-fO-`;w9jTw}F+1UX^y}C$fX|+A|uxnqMx&jX=rknV~J}Zh36b^iDIm`zPXm;O8nfu2#ysY6kY_;X}v^Lyft_*0$J)?Kxx)OkfNEE#vpY zuDeH_$z7}h&B_>N!o$L91s=iRilaNI;&)wiHKGDw3)TOy@iwm&w88v>;2uTjVO=JKlKGw&6o?nS8q-Hz0epgF$RFqen*9BH2xzz?QY68wq>ZM& z$5o%62hfPUc6ks~YrrtF_exjio~K6%!w4FFW^g%OC~ zeG-n367FSEau5jNk@Yc|!8Pch`uFNpZg`G|yE{q|ZkGhB#Jp>MdiKEn{inVDy+&s} zfK;fTqLqI;P?DYSh9(ZySG5#r=PEx%#PA>+hBM|`&g0$FbLf}u?PO7>La1K-6e_5xzxzOU%f?&KF+%Q`D`qke*x)s60jaYPK)gtZ}>N}Xo9=&0S zeE9G=e!7<(lW{k^JBH_=c0Zp%tPBaF8o}ZY4WE^;UVw(BWeEJNRx|1puU@{4KVyyI zb_pdEZ?5KnJb+v$=;^$1{I8fkNAHW&W!RO0em$Ki}8 zPs+Nw!~$sYle%ic#{76bv4mXv{@yREuc2*lGRAOe~U2s<|rvOvGqz z;jcRi zO$8Kk^b3vAMklj55k(^p%*)M98`E0Z+Gx~Xibz;*evh|Sn3<$Z~7awx$+jY*~{?fH;d9}l6 zM$660(#?_w$bR3LSm*KDZ0ZMfyrnp{ykp1mb8}Zlo2K~U!uE(k-^@{uw1I!_rjCxO zC@CX`ZHgy1`}qx%$*p?!_ZBt)DEV#`ap6E)m&L1>TrBfDCjR~{an97sjgrSbUs6yo zf!^W65kG81PM>STON9&yM@QPzeLIOYppc2GKb3M^noP%|4*Xp6sw;8NRO965<_1Ig zzSp*gAQ(XNO=1v1WFacNG;YNXG(Pc57E0-W$a4Dw*0|yx8IIO>LR@<|S8L z{ck3!-Wh7(nYUfu-!d~RF=*B=wAC31 zdGO;>SeMQ6gNsw>mElu8%6{0v{j2qi_C+nW!ILjYA94r=NIk8b?%@k~aDneZsN24r zP21~t$C}Phn0d=+nodsqy({{D*|M5LimGAwSTo`-?I*Oql11cfo=V9CxPK(y5BY8ps%GbVoNJZBT2+#hxv1fx-9bGTgv z1E|H=3pu(|{>|I0RbNApMi*VEjA=r`^ovbc4U7n5YN@fs&IfIJ7TGUqBe1Sw-y2V|erdTjX`=X5Xx%aS(&NG5?DMBV}a14tH$ll%p6Ewa>J_`b(`q)&Sne zTlP|WQ>q8wUj0**9mEpSG6otps`jjafWrVa&JGNdxmTh_j|{$Z#F&2f-^NPPK#TdH z)5(;kPrIK;NAb@V{4LAB>KZJsO!MM)WdrX)Dp*te3x9em1Q@)zaA0U<9embZ9c5f} zdEHDI^M5{`PdGcn70R@61m;d)3Rip%;D&4-bU4M(K;D96gm3|6Bo8*0hoPiUH8ae0 zeR=@?6sV>8`XYv16%@!Khtt!KZ!g{OVVoW(Aio{D)f)G!w%<%|flzt%^nC^rz)5*m|2T>7KB%m8L+TOS1HfGeYzCo{)h~96t!eX_{Y5fL!j;00 zyeHKQ7cwmWeM?2)xu}h6vyGiNa;!{!q|xe)*4$m0?Rg$6x1y{E4B(%mtp8do zWn)W45J;k-{b~)rH(CI)$*VCTql4CM&DQ(^Tr;PEU?ZUtqCRWunO|b4jULc{_xn&{ z1|r<-eiosENXGOFZ*HeE(jv@nrQ3(s4kO5#mJGn&m!Iqxl$G_~8quoIffQ!kdZJ0F zJk~1Q*WP}1HD#|rh6eo^0RdLHSq%6hhmXBw{w1mSkR!iu-fOIT2cdGm8Rc;T8yg$< zWh5KgTD+9;6qD&f^XfTy`2!TkqeOqwc^?tAJIwfYWpPpX3{vlxmXu<$s!S$OWTrqK z7?gclh|}%k)1jeHNFIkd?NlHxNonsqIMU0zfqk((!ofr1GxTV)Qdl$NnO z)Lw@hbXcf=Y!GWka&l6+LJtifei5zY<>gz*@jrc14s$bLPgOtG```0`(D5>O7*%=? z_{>2p5LV+PRxV_W#`4gbArJ_!eL9gh-7Hy=!DUr<@fdXS^b|)UeRp3mse+JZfThUZ zk_tKL=J`jdc5e)j69gW&3SXr8TsN~HIqbjWzUY$5whOD!Niq90CEkV;gWCOF)bJ|i zP|N^D2FxlCckEckI08%Dpjf%X;6ns;Fx3Xi4?4GeG%C=epooM;6SF6h>yeMpJKB`{ zrRF#?XVB0%nXQi)4S?tPB$|?ZzWp%oFJ9RHkb_1Z8zJ}<`1Y$E8;9pGk0eWb2^GD= zm~y-R;Vr}`-XCO+Dt-A9EM>m%MOdz-L`C5e(xxv!%X|K<7D?|70l5c&g=UuAw^1Q; znxA^_-Wvs05qdcz4qehI12%SNT^+V7?;T~M$D-u9#+{gfR_ulO42WMs*|D-wvosfW z+uSfXdlQ{;6oC}Aj)lFKbzG*}()SK%S|Xtn|I9u*tMaP7o@?-4)kxKusD!o7!4hIL{{9cS7N56b!gV_~O*kE;#sNzgi?Btc;TH)VB$C znA6T68-z7j_8yWovA|FS4q@1@vnxCq`wEKq5QW62Poet%uOA+QCh*f3vpl8kAzRb8 z-^|9*t`1}e8GS&2AU082&i`K*!6gpQ_d6KB+7-ehO6lAfYsfR-njZ-Rra1Y1LR>uN8n3RE z)hiuvemrXnDch@mOMTwFc>~S};R`snQ+&!7;OQ|h>^=2(3*3G!(juu&NAIboalRe! z4bFZ}^~Uk3DM$qJw>Me_h-BiR16*2s`X8hi@5xrKxJpUh@!XiYu|40I5Cb11DjB(B zDcFQC18k5;hsaUOPfz{oQ=5d_pNa>pJe~(dRySdF-5+jKAM8w6>L39`P zC{FF_2WgO*u}7~0K8MTZ82R&zjFOKZH}Ti31P3dB?AN&Jir_4EbT_=~okok(IYVgy z0oc{!53S*5Sb01GoCSn3?x58eY=$iaFP^)<)GyJqRgYknVTh~8b#--($sTzwVPQ(P&)+2=JH`s7iz92Ldfw!}Us-_H zRFDLJ5L`T7@`#WSVgu@ZHM;}>wmoeBmZ#tS`twZk?yL2G|JaW$!6MLmXNZt*Y5zeVAxV z-?{fO_=xigg;#51c5$UL203p$5LWX zs2~rITT|+uF{uX6^++8D63eGS^2pZ1X1gf zvwL#Pn$Cdd;a6<-Z)LLwy^()+LRck1#yb_R@(9=3)wLJmFk&J?P$ylS)7tCeiex#% z+fdDR(2rCNO!_PmJdWT5zD4x)_fJbvG1elVEElnApYl2IR^aMK^~CcP1CyT8V?m59 zTG}zNRbyvk+jNaxSVcgibnJZRz@#|S_H=a-TO;u%09_`ZVzKpRUfP;_sI0tr>F;3# zibkAGyKW)8|9DvG^_FXT*%~a}oAURsT`r-UwQ6)1fpWk%0k3>*;c7o_02jb$v!=q{ z-d^wdTK$ef$CH`g@Z9ILjv$7pu&_vUWZ5f0mIbukhvdYkPYagw_z-i{oDm6CV4=sn z5=wiK7^tg&>%oP+QFGYtjU;ovEQ@BYiLRoet-AUYoUk`u+vn-&Nqqw2Q5=;<3{Hzq zgZC%(OFRtwJ~rDA@PQe*ZQC?r)8IhF7nzG@S4?{YBTeH!&Ilx+Objm?qJ(hVI5{~{ z&vO6w?VP82XJIPgqOTpD8W^wzWGId2n!6>{FI_^c&@|!T#q|KQR~z~Z?1EPdKRsC?=mH-4Lw5B7PXA#Wph|?gtw=X{KSJ3Egm@af+W3=?A3n6dFuVf$eHE2@YwyJwQ-4a%%nh#f z__dO*@L<3QkFrR2@4ij?GPqGef{pU8B?T}X>AqXmXD82=(_!WQCr=cN){`V-$a6tK z`%^&qp>d9z)Px%XM~)w#elsAlH%Nhg>$%g9kiU+HIrpU^vU20NCMF zJE@_O)-=d4pMgE%=%GV>?QfdgXGZqTXZVEr8!`xeJK&pY7Cry5hhZ*zbpaS#!-q|j z#d0I9jzNh)BGbuZ+gt8%UR|<0`@Zk*lM93IZgh;5HoV=>7kT)hQioN8&roWvChr@a z9vd+X`Mg#p6FS@0RokYk_d69~D%JGf#2zH+4l8y=yVKWb%AZ`=8{CVw!97F}2$j4l zqNi<=Wmz7au0T{!=L)>wYx`O)zAeUYle~+-%X40TbLZxK%Yrs+sFs=Q9;<8N4BxD< zO8I16c+sDXlMqT)cs4EL*)vJIUj{6sceWmbU;1F~1G)48&#AJogAKp>&!RbrRY*o_ z3{j?ZLN<_?6JpWkp75PShRR(buSW} z0Qc(^PW81T%exM8B>2zLoW#!axLZ?EQNaFpX8sDYm~`LR*<$o(ltay0n4dojvjtoX z>T$U7926AXS$!E?QSe~KFcS@CmbyoZ=4Ul)ec2}%MOAH!#(B}H6^bovz<~kM+;rk)6pTL%(JyMw6pt&Rt~-tcr<9qZl3CZ zV4?lnx$|Qk%TA*2MxS-84*hkCw^;CG<~B&fq>(D@iHG!2|MI&b=gy~-Ut29>TMeiT z!%%~o_L10yqxcl?%JikHSRY$Pp>h z_!R~|x-B@x4+Q|07bJ7z>8%&_hAom5^A43Jaw5N^4(z-zD^OBZhvzvtQHc^HTQ{}? zT_gPAo<5~y3~zu3`yiVfn}DAoA`lt|1ez95u1-LtSWEHxm2Y}=o*Vql2)O$@dy70v zpmCuA%tmPqcer*pHLcHIqU@97b3vKZgmV5&k)Oy(D(kKa3;PMacv6z~!Gj=?s$t8y zE_e)N(F>g6d-m+nD{|VvTJfCeo9Qe3cL4E^xy?Vtx`Kd+`)zG4s-gY>VqEXh_6>ZI z6su@?`Fucy;17p~heJ~S3gB7YUd)7b<0b%BgFoES(IFVc%dltiz;^$pwzgd7u>q9w zj3O3bpMLuI@zBwuhq=Y7`u@VI?P&`m=IYrxZ=N@ridwoMcB|!ECtSiIbxshv)``Oz z7i&LoR)rD*$AGPX;l;qf7$_)Ere1z+k)oAZUmu63WWH;uzYFFW{^RG$a(;OQb4ZxpVy~-PUYx!6eG_#FJF3cSd7_kc^)6que!@07v`2AWm`depuOw7I(r`+T-{6mF{>%{~Yjs`!K2*Y4S{a(={@hF=Byy z7VeF_^mu~7BDvyKnvEZm)G3BmRxw;Kikbjc$rSA0hKBCd<@@X;(2dvtwYuKI$L^b@ z^X5TVn1bq8;0Ui?zh?0b3x_o#+nmQb|8f<0v}QB|d2Go#*Va}~OziCJ#FF`N+DDo5 z3Y*-W60hYUbjZZSm6esvyTZWSN12B?PfJG!5G3-ehJimrLq=I%(?h$HbH15A&(k_$ zA+q@K;Tf>?C7DHec=qwE?Lruk?9<*%AUj;U1|fY@cj}KH=KX;f$3e*npV<)j&mjvO zv$NqL^G&nD`>vNVXeXnyT5wBNNJay+`)&nTPSq1|&TP?h_ZfVw&ST32OAENOn%Ro) zH<>ISeGjQ6?B_lH%r359CqrfsS~x|-G$D)wiQ$2_{r&L>3k2r^jjCm;wAEqh?iGVb zx9z*B(WlQX&Z1h`Exprj0yLX%zu%!)0(p@6LQXq#4qHk=dN z$4bY$Y3e?Ry!a{?c)b%ISK!DpU)b=wzn+m2-F}{%hI$FD!hSo4(}qlel>wwMrK`X_ z>rJjOfUAo3FDjYAuSu9q@d68pI(ub&+%($jtJnx1ysu%!&8DhQ^~8WZu#!`e%u6rS z6~-Y?(!X+b;N{iB0G4?o50l6oieH35JCkCb9d97S%b_UKEt0mhvML#C1dYRaYz5KB z&c;4#$KEari-Uw6)h4+>I?r;3BikYIe8JV)9boLA%wMdfeNje|D)3fUrz1bj%}vhF zuO6O;KTB_Q2!^VX-`AD%-(rb9>#wx?uggitH#$H-;p!CU>?JX0C#+JW^U441ct!~? zO@m1;H1Mo+0cii+rhXe@8s+yCGUIKjySmMq!Bs?1u=HweRS`H3&upF6E0txxcd53_P4W&i*pJH+?^Lce!SV>4x8fp9vc$1VSbw!(^&@x zVM;Xt3%II^3aiegA*7~mpG;k8fjR1+-EkB_Xvpo4=eI!^5Pd}3i-9?7Z@;1q(~jUV z3|c~}VF`>fba~km6-l<}Q}t)n%>NK8m%^Y-E&_v}yxebnPsiHsDlB}TO|x*|#1oFg z9Qt%fuO%+?&ImQ|YUi4Gg16aWb;T_}?mh63Q@3yDn?`@Ej{}BeetisMA2#3M{Sxre zMNliOHf8vZ96{PJWo4ay(vr0;?$nfKdx@@yrIzQVOEak|N2{v2FabjMgt@b{>1>Ys zyoVmmNsO6eM2gjQJTgj3J`Fm6MU9I|Rewf4c@hSx6&B9px)uMzb>lCg)_-i~YpAKN z?x6lv!{o0fuP5eH`Z-39aB6IAcl&i(8nFfE_B=^Z5oSoD^o=3jZ>y)k3=g<-2Nr>)f)g1rm)!NuLVP$x`&Qw?6)c7-}l{Z*Ys*V+$Z~ku*Y1=z=@s* zL#}<-&&7(p#$NX7)xB4*Xrfbrn*)0GFK1@@;ylj3ma|BZyoegnX2Ai_Ze{VGI&qEg zbi>6NOYohL%|=W_e*p0jC@DUBR=zdw1*w~MZ~7kaH2srHIyKcM`=)*a{QLgLskoB` zzS+#@yuH009XI5*TyS=t7bshm4XR(dSscy+R5lP&>pV54|NOpG5x+B0NJY8B- z?f1g;;j?KcvqcdsgEo-W0lW_czhqwG+Ig30`za{p6q0vu*h zpzZmuA?Y^rPj4P-4DJztc3E_wUc10~EX#AzK!cb6US39N5F`GGUj{N_L z`@CUG{Vy_W!oovCV_S*n>^#m{x!gK%}?JQu&ID`lPy@ocMdXrE96Js}r-D181+n?kKkv5MCF8gnUy&n+6R^aKM2o-N9Ed zyE%Rz(5LK{!*q5cF-=WP0DCykDz8=^T`84ifdbP)Btt3Xi@75{iqhqYkkV2RKj4dn z_6jvy^8Phwuj(nS3Q~ukaPvs&=X$9n2j9+qEEkIeA z9_oW0h5s-$rHqSOcKfy{Mh_)uHbO)F;B>#XYM)SUCO&@Qbu5ZQ zz?3Nv$#MJFHR|3AQ#GvnVa2DHjXa>uJ2W8U&TsSSeN;wDX&J^-jzWV(A+T3eJh^|L zbW;{I135NZ7!}JQG5X2Pq^Ghh80vzOfFV4JDwa)zbJTp1h`P)=&%IGJT6r4`W$RjW zb#*12mclviLRA?hbnSW`E%+mlbEa|+jrT0UW>uPl17wkV3L}&Yb$NepitaHG_4n^% zno{dEUt3(os2aIV#hx}yYhFADu`R=d$#s$*c3?*@|5ZLwCV->|X|#NJy`-e~K)&jt zkD)(J$*lMI{rM&$FyNh1A1{SMODSD_8vXIe;`;6w;tmb(G54cz{-?2$^epT~V_N6Y z0pp%9YVw^V?taB+99b(&rqMI=ZyEdy8ASeuQnuLcyFyV7?5F6;gvmH4<95z+Gdbk^g9?C1)NPg%v0zHephs=%<57u zJ{5moU)X(~#+0#aU~*=98mp}=2>pFowom#P%XuLTSSiWm+;p90mX>G=TSC01!k<5n z#ULLe#QWRnwX_#{rb%WT+WLb$D*Q+mr*}1DG9#3lOK5g?Bddjth+m76R16= z(fA*qjDuAC5z|vsZzn%lD;y_Me!;yR$wG1%78bcp3kFu=In9z|W43#cItZL-Tsxtm zw$6q@XDl}9gS*~zN97tELwKiV^mQ~8L6najB*N$ahYNtRKVAK~R$fGHpT|K?rjR># zXwI5O)b3VF2}>O;D_ZL#@e50Cs-7V{zf>C~#0BIQ8nu_3`27sAA(?bbJ_1qnW?lOpQ9Weq4u!a^WX~`umHnUQNM=tmk11v}3;= z2&}Hqc%T=7sv(@~9Htmx0Zz}(1}Vi7?j->vTY`-Ewbqfc2xN%a{yy*JJR7;SeRbU5 z8PoJD$%nopy=HNytrYptDJf=h@Zv&?@<{akW`fjQ1Q2+D$x<4aO$LNXlk zvKt54V1d+Om64Hg-MrAurO@?Tb~^gw)NRUF$(RAqSUYn4PBj`A{VUJ zjt>B3KRl|#62NxmOd$S@{jnDA6xdg)vrRdyqPXKzoWvvp z+kej4^z{$_{yX6qPAS;aju#Ve71*ambKC`YFoS}I*koOzCZlg%jJ9fwtKPFEf!kx8chL&jSF;@4sbSrYqZ!WqmmSEz<78D zx6{zjNQe9jU&!@W7@c;5??$oS*!>x}2E_4w8JL7sp)ctKHKg8%85%DPiIih=9euOs z$%V^aDx1a%nJ;I$pkz7u$vRI9IoX$Vb&o$;o*yU`HMVr z!L^&>6Qo1M5?M=&b}5YGCW&+BT?~E0!ooICmC3BWY3{Q-M7ISg&|y!idqGbY(?Kc% zdhJJ#nD*|Sui?U=)64h1EDM5y8T=@57L(x|wp}p`5F(E|&U>6NGP(fioR=b-JMv?9L7N-_Ae2|L8J|P`(4gZL0du{0`z8~pyl?!*ge$lUcVkGz*2QD)-ePhSn8gJ7#iY5*W=$r)`czsAr`LyZl=eA-2=29X8mdYsr(kkog{{ZGh*O0tLCTyV_k!1+bfo@D$%VZjOLdLGh2cjiyFWjTc8NzbfE=qXK3EuB8-E3cjh2qid+5`EhAjZ9 z6`~LHocf&zhZNuYI(+*1qph%shpdMr2MzaVM*<8$9`gLE+*8`nV}m&gB6-+-v7EB? zia!~ff6uuBZP{Alj8x2{M+hX2fBEu@^?X%X_*rf`1%-X^qyVqwg=$7~W#vI?s+Ds8 z$=Q)sQiQkVEtqpx(2vZGa?L=0ni>`mu5sAUF0237w2LE!zi4j@v$`!g!?m%@sG~t3U z*Yn(h3`rOv;`!<_&%;b{&>@slO)8uK3u6{OKA7K)wm~YEe?6}-Hn#oq=NAzX5!S0& zW#NaVz1{~NwL->dC4X$HS!Asvx*8bRI>L65w!pSm>+J0_ab)+rwZpAl~xC2uXq9*P2G225mW%q`SlT+jo;YI5Rh{a{nbn^Ij7!z$DD5Sc{ zA}$`0YK9T_aM@Pq< zcR3Jy4Kffh(R-=4I6gl9oJ@yw!Riym%R<*aaVoxi`qai@?a+DmT?EH2vgE?bGz^Cf46Rp%m z<-%*wLgYH~Ecqw+W3*pecUAF5$MUlt!l#z>6r|hE#>Sf@9&RzXvfaPWeOJPPzosINdymbVs(RUW2Y?4-Riulse7QiXSYmZ`znEn zA9CX_=UR=nyCPZ$`)yfioJx#dtkAXi(;Pt5J*3AVUIiPDx#I)nH0BoxGNl59j+qzS zXnAN(GWfCkBCZ2PJd~^}_ch=zlB4NM+V|E&ghYgSF?DH*+1J+jcWtX{=7dORJ3`cJ z>9fNwx&&Jf{kO3%VHz5C2*5*uB#TSfix>P9^UY)Os^G4JOLQiq*(^^SHc9lUsG<%Y ztUURVH0VGJhC=n_^mH?151P^4tsvrQyFoIy5QhJV4=c)V*bzf)1=2KdaG=;QadUIq zc!Gqe_42vKTUJlBN_I|!XlWs4v8-9uRaFu52y#hiC_F3>E*~AeZ>-~%EN=wlRZP`+T9z&a(PkAC$AC@O zU$r#vMGy`MgBPEXqEo?~=Q^0;3tKO)G;~y2yvsga$6T~PUV@7_KOdi$P4a1uLdRhf z3|VZnWXcC7|Fq4{-xmUB=m-+jZ2JKPYiM4$7^1q`U2`?}vUL~V)zrcb0x1cn!;B-++h=b>9s)Mfa>{mGC)@A72_XRe^fl-`}=};k+CX=?daZ>!CssR*{Gc{_-Wsz2QpERFMw6Y+%d;jnRr)KpFjZ|6C|^O1r$57nEPY2gGnhj#zn*lF ze514OUm@tnV88js**z2Bg_W}TQd1?KP20M8bER#&>0A3bo0U72a56&m4MwjE8eNhcpC<*t++^06lBx%x94^4NV) zNd2+{Y2hosC&+53PocJ&a+5O2-OCCwP-{~Yg1_PQW!MuG>egg%4`ep&SEe<$Hf+s! zhVN^^x&%`Vq?e90Aw#}aCcKx$#b;6?MUbabQdA_t%j*F;9E{tM02zk5njnTGoKUJXJ+bud!J^uaJ}9l)okkiN?mB# z{?lRKi=4q^i9L25tP?AwiIAV>=MTU&TA#N%PALr8G95j9*v#4*M%IO1%Rf+&V-Ub6>I`QV2pQlR zfq3JoK{d>nUzJn(*LRP6fH#J|xqu5!Xb|0pI8pb}wiDT+zo%8pv`2`I9Ew_*m%so< zpHKuAkun_SjMb^gQ5W|2o^mMzG zv$uCbqf2$qoSnFugM+f1+!Khc_l@yy-Tdf}Zrs^ZW@ZyMo$L&1|94Qd+Kyb@IsSg@ zQ5Y56ZY3gP6tV8`0V=M0B8W%^llnq%yAaIDRDCF5XmIclx0ut<3W5B#X-x{&2-=A8 zFCd{+cdO$G{4fPpNX9M<9Ax$nY}cmUPC~KMZ0>rmWvz!+GpWnOiPes9uzi2;n-epd zsZM%RUPW@}%5Of(Hx$aihW{h_$p2S_lo8q@bT7}eGEoFlpJ4G_^3p$b%AG=MR8`*e zkOu_}a+igV9oy~&T?!=m92{Rw--5!2Qqp6II!_B@wq-9F`)99Ti=c)}9i(*!t%dR> zc~^mNolDQ{NCXbGTZx{4m;~J@@}-lLdwWAxX^Hp?R6(F+m|eYE*|oYd+MOtwaFl|F zxw%yVZ9{4^@J~uQRkV2H*sNzLVXmmCXlQu#fcxxThDt}i?W=WlGtD#2qt8a4Juj4_ z9h%}Kbr|qd;h3B2tWb;{eh~Ak#LL>l`X?io?asEcjw%s`nC(07Z0B(x?Hnq$(*I+= zI9j(_{(U&_oiJm~qk&m7xboKtu}jBZ>wf^!Qn5*{S>5Owa74J_{^|Qc0(vCYU(;?d ze(*D7+I}uW1rbeP43E9dtue`k#&3;ucPj2QNlx<-=;NEIseDP$VobO&_(A%W-*&rK zET&#jNvY9192HWkO7;esL;pT5g2LV+OmBb9F21&2eg4+tC>ail$ai*VeYxpnZW`{u zCH0Y_%v6j=Wme~h<|nVwLMD}|r(0;#lZ0-HNyh6{PEJpj+`j?PyJBnQT{q6J#rrgH zDL;A?5dp19iHaJX{6+PVGs+aZQ-~bNR0OZnfS}+Et2Tm^_jrZhzYmxEBlPwj9!Uzx*faz0+<^|q%lq-m zm$&rT*FGDA2LdWEbydCak`leZ;KxsMiU^lT%*^7Bt1&(o;{V+B-DNi`&o5qBqUxpu z5G@1hO=PA%iw7j3&;;#-JGt?N<8U>7plhAgrW>{=RMo-Q>+Y5{N)nNhqBMkXC4-R{ zC7|MW-iw9B#ZR&6#~7x1_phy)l8`Dl;(2H1NF;X0gMUI^aup%Y7&pU|60aUdR z0S6Hy^B;d++is_&EYB{DE5$Uw(Q5y`DqDImyJZnRZ(nL}P>uUk8<3!{8Cq^cggELrfzz?@6nR#P-(`C@T$YTd6*C4t9FVYL`LR!jI)4U&_$>BA0$^`V$ z6b2GpVSoQ-fD2W%Oo_U_{vNFZobM?AsQc1AGb&kCZU?6^ZVp!;-Jqui8v+)R_6M+) z4inZf9N6g7^EuIHdRjlGVyF1~`aZkm->1%j84(ti;Jp%wrM8v+!M*4ys>NGt$mOMb zx>V!Y-o;f$IUv-Qq?568HD^pGx>J2-3J$ewd(Cv*?rC1$2G%Dn!_srzy3kL+3ADv$ zqk%G*i|}=7SE`3O;*&FKK9`P(DgU?0KbjDOLuLOY`#Nv;E^r zDL-#x|41oi-xvd7?!;Z4*)zAwlc`opX7!lHG%5d;py0zQyY>yC{lC+|Zt4GWBWM3R zEG!85?@8tP-&x}5e+iQ|2mU)jT>LMe^8fWE`Kv~hE??e-oaMN){#|3Ih^~^OkaPN+ zI2ZP7fBqZW-Yb}u;Krh!>e5{s4-p7U20^-1FW}2nA(vU(_hc6#yXBhjzKxqUiCDUU z($O*Hz*N0;Ynp<5C6i=9mr>5=+c0H^Dk(E__y3GQttxQ@fOD6`jezwD7t(tG4hp*> z@8AE>XNLec{W9rgQNx_?0D&M#K&>O1xrW^n2nAWVvn2A(8{P<8>+5r;1)U?~iSYy& zoSe#!9wg|??de3SqJ>CIrBSb#ZAUUPg$E|#gnm5)e%evW3aTG0L>jveWL5V4g*A1f zDU7T0y|4Y}1~66$uOq@$-+8R_xb4qhXeVIj~ZJ_@-kNl#mCJW6501lzslzt@Lf%H0G9GRLC7UL4v@zaN#S~-||XKh|*f= zMCgtevI6Jl4u@iH>pc>}puV-V`1i_@Z#nhXwU$xKuAQP*=H?tV1o=<~h3w06s$VrG z{SfgDhYREce)vF4Xh;w?3m_*h{IT}N>4S0H&&pZ=npMVv^(I09#?;|&wKt}|HQzeF zx)+l^AdU*q98#?dtR#m$(aKcKIK~_@kgETmnyX+>&^4-e1O8^h`@%TtO+c&1%vkBn z88x1Z7t-r2L|A=sU+$0)){Q)c&k%sXs7(};F74MIU)$R;XDumMw=ucY8!Godc=s37 znp!ds2O`V#^yvbJK_g&wcrN)O-MeL7RaAD9zrHdPN!}m|nQSdyZ-FX*>!qv(CS*Y+R^dGg%;3o5Mgr?j&0ihDQQhS(UOy;US%_F77F zzhnHAW5uR{p@|y)w{RJl+E_k}lLd7yiZa~sBa!}?vm(7c-nXjD+>%r-9?S$v1M?4BfACj933O!Z3~s`mQaqU2M=~0NRW+$ zp?Z3=t#pF5vGK2>5at_2EU?_>*co*19t;u~6JykAwrxW+Z1KyNNyWu+%;(pppEif9 z>~}xD4rN|bS_W1)9b*POb&H%VcQC`v)NT1ZI$KOOuy$SNOM-)6Gv7$##6@~@bP0b%Vr5+ihtIeh+NUXS5$gV)TJgdH=lC{@L~ z7St?=PH^bmLbH(_^ZPGPYPQ@~N@IL$)6@P`V-Y=BetuE@Y=%Z6)_3y0#$iXdV!l@u z79##m6DJ29PKtM&H?8?_XL+c3A*ORHp$kSmM__)zW^0-#$996)IR8vxmv=8cdSW@Y zgLkqs4cv!?`q!5A>Kt?ZI)wR9w3bR&>ExMZyg>bMealW|a1V)oF{0ieV4d9B)}~EM z#_y(+m&cCn{9${vu$i5gm#V#eFQDDp+F6kI{Wy_SDp9bW@{S0ypJ%z(*}RDb<9Gjl zOUT@g9lO{I($EzU7J+V!7WxAZ!t%y8iEX8K#T}Tz^gc{%z`025RLg7-M&>kSP~kaLyy71plAa zH|g5tK4!VyU&y}yIiih#i2IU?$4hIBmzomvo@EqCb_!6=&2BwPHPz(|^sre&A26=c zxrX~nS7|nuTZlx}_k(WS+^oBA>^J4bZ9*t|4)+^~mRXuSH~XgzFv;dykW(of30rGb zYyv5&koX>_A{fS2NvzSI+S?4GY$*R4`{4g!J@$WVd4wX1f(UzP4^?lue&w{PDbtig{S z*BiG2dPo?APdP3XOs8TNmJlj+Frq(fNQW-P*(OMnaYHbmH;k z$KwefS@4^0ts+GUmIVgr9$5U)_(?cwwa*1*68Ij*};QznxjxULPk>`o#FI z4)dozyVGIt9Mjd^56=p5@0Ip~ittc@vf*int2>0(olj>|I#Ww}4>t9PjTm_cEO%hO ze2t$$A=&n4MGgGgnYN2cN;3Vc8E=gFpz@PrqfIzqB0Piy8g%vjFzEt6nr=&{m%AEB zZT0)!!Ba(!?azpX_v*4UZZJcI$E*RvYm3(P2wnmm)~$Hu<3nc7@coR8;2zP!i@R1| z+FEdLwL}$Tj@A)8q2}fbUs7si=6@xBK6&t9AO8#fV&4Uf8B(`S*!pYvN`?O#Sv98jxUUW=0sW248{s6@#Dd zn+r%@Iq-uwxVNWg3r#sfW>~sQX9^koZu=kR4iIFRa@c%=q?Gb;Y!-r|Fpg}-Om&`e zek9f&3fSj(r_8|D|1j8SroM?2+;mF5_w}+DQ>%alYH1ao=f>we!f3rzZl1^HD;!-g z5brJxZ6yF$92W;1k0&%-6N$-c1KS%&vaz5pBM%ub$V0cKr~^7=>w{iXeeC<0Uw>)+ zkq4z1u((SxlBk4XKvvYjR~TDwaxPlZrn#K6zYG<6Edr!u69j5yTIYHec0c|8q`?mgh zjmWi(l$5*MV`_}0$KUzjIxR#ZlRkvfg81O-IIUR7UTeTVP!}cPKC@>+jEUWUhX%8> zj$-w$fbt&VZ8l$&w0j0SVQiX~<__*G-Wh%1ahEqJjS&CHAI0m-9aI0>eKr^a^96hx zFXfKoz0yKtQ~CYs-puE`GIqc4O^@9hfKi7x`oMPk<0p856f`$;iCV98S52_{^3$9- zeOjmJ^}X7@jZ_o?F+MZwV*7RjSwv~FbxW!e$IFqCLl-Y{4gP)pTv0Hp-GnhKqX@-6 zc2Rm>%_mLUivNC0_`PKp*I6%=Q*5Es)dC3(&PZ5 z?+xB7WQ*s8FaIJCNrILPH@0&!%e;O)P?Ottm95IG?G1~~1=&<`Y`zRMRIC+7IUhfY z(C>-FhZ0#UPpZKBKPNT)Tq_gMomIXBiO2%Q=Z&^Me;131iI;Qx5!~F1J^;n_7^Sk# z)SexWJw7QwbCP)IAryO0(OErHr^SEnwPp9c^jtH~L?vBmch5w@`kS(-cglCb*<4%p zR5DU>*^|Fz=^l;rmxu!yKlJ|nx$uM~tc=iL&~ckFT}3_#?AnsJ^TbCRPbFxUcpUVs z+^|&%yN}V8W_V5_{sPlvMCoZ+draP z$W+eH8J?of^UoHKlSGta4rv)KHd`XHO3PSO23$mQ)?+h1zZ4t0giVl(`16N03Ls%I zG0+c?o;@thKY806elNJVz;A!FOEZV zE6aXqJR1ezYZt|ZT9d-klJySuh(<10L2 zkV?SR6G+jW+CKW-DyZ95?(G!<>#54b9#;-B?zuQ|RlSlO<)1;A03}3?8p0kPW98$+3LczxyD9tV{{0)h5G8YE z@4tt%tbo8hTc~ekXbgi61K(VP62XmK+I=P#UYS)@88Atf)CrA`Z)|CiF#BT691=qM zVje!X#Gl_57Zw&k0^MN9`LFjHqTO9`EOj&C1V23-l@MR=%g-FbMHfK4WolXgTfHDs zL?|+V1+}%c!Q?xsY7A1prKKa7ym0ta385@IAJZx^o$Bs2?SzdtTB&6D2JkB8x zTXL+VD-(sqKY_ixwy)k>PCyZAV_;w(F@HrlvAv3(3hl`6#N1;E~40IZoVgL&m=R86n!ovJO!osrG zLmo2ELo|U{d$AO!p*+jB2;})bTH4?8GMqdL+jV;^IkrwN*8z9fZ>yg z{qM^k&_$FP`1xlZ@LpnFmN zP6`T`Is^uu0m&M98Mti)Nk;lcN%X8(_qTRXvsU!|<)^9XvkT+Uj-S_VOv=Kwj zRizQCsa{PR$&jYO&%=&WV=+|+Br8pF8%y^G(SS=Ll*oAanadEA5bvH@MRskJR|G=JY zG&DHh;?BZL&$i?{|ysC-`ChCZf&r zuyNX!32J>fqSYAd#vn6$eYNdIAKK>>45nkMZI-0|;SerVQb0Tz8mF+C8Ju1EA&a?&TdiD*4EY5 zuJ4`Lx%1Uw4e3Ym@s~Bl@{)`WNQFPDG4|_xj8`t|z@aRuGcnhD4oMeb9N2UQckD~% zJE8hDv-%v2vdbPm;11a0>DB_JS!_&9Le%jSyb*Z3TmLxWsnL@d+{^0Q3o9}XMZeDA zhJk#oBhm>wSigRE0SUCK>e;Sc;YLPZEiI3LNn?_WYz#2op=SpMGddc>w`cL>F2)SK zVhZ+_1++idnU_*g%&{``9w$6#G<~A~3I?jUEp|UE6kT06pf5Gatr>KHqZ53eJjct5 zTH;;*NU9fg^iR8iH0ZrNyjn2&H?n0P^XrA>638GCe6%CqMd^OiV3K}N)6sr2WlkY> zb{M*8T#OqT8v0OMYmL~WVSRn(Jkf7?bX)r17fVXg^IksSz;QNh5}Aj9#bJKyOI}BQ znwgpR)bvNnnLYZhSErPsiHT4YAot8wvU7*D%fPRiURc%vDEnLMUEDioJ$v&rEK|hn z`(q&#{_lKsX!@!>RN#78t`FJa`6AfEAaRmGL zc#pEI#B{7o4^9`t^OrvG;(3bN8+3|NvqvRmk40lta9HD3!sg1)P?>WQDI?2G2`d*g z#U5rgeft*B>vG~mV!42k@IIttUb}WmQ&SWCWdt;2d9StdgwgK>nN-Focnz$3WnGi5#(Y;gNG&|0Z%|gueVv0iw3zOKOIvtu#xba z)RB4SQ}*FwG=gPAn5AG%52_h#b)_7KrnnM3;0(}$IGd{~Xe_ao;hev}86L*^z@5B@+dMd z`5BbMYq-N}Rwre=5li>1+5C#pS5akx)y`EF>(!W%&SIgX**EkuuC-+C@0vQ8n36IN z03H-(KJ6JKRA+ZFm(_T? z!D<*sO@3D=%uq3zLw@vN7$9)8dY^~qb=r0vta-OMRtn`WE(jh8H%ah@1x>2+wPkJO ziD2o2uPO!|N+v(WpdUx84%nTRte1^0@5f31?O&P^->n9&ui2MhOG{*5xN@Q^TN%mC zoT8^r#5C~c`aU}OBU-P7;bNxOyOT1a?CbdxcECOkAK-l(7kW8#H%vMLBuZN%V79mnc8~<7Q+u zolLI!t@c%;A!Lnk`f*_LTHT|#_;^L{-GhUJd`G)lKHJ=;ENi8sT;?!>2eH5uUoPMG zF=sL4El+wL=2d>-wOkGgF360aRvapD*iG4I-yM0c&eQx|M=|poe^ebh`Owhph&!RD zIlvbtjXOIzp$7!rl9`z~3z314P+N%LV#@eXD1_Ji0u+~cbPi}V!U!Y%uP~U1#7wyr zR~n_d#~~;X&tJEJ_wU`b@6i&H6JflI9?n>BXxc5t@{u&=32=8rS>j_Kj8R99rcs{O zJ%#c}fit_er06h@Iu$*?6nIvY?nlX*N&xr>Q#H-TVicq?DqT|-ViEGid6qW}=ZRXSI)I=Uq0oB#xbj$aMQNo6R@JGw({q1RdvY8sk1nD($@)Hz}k5-juzu z!on{sEXK23aAFBP4_PglQvdo!+N{KfP}Z=IA22ccS27)h=|vhA&Lo0RI_ z(Xp}QGvMlgSfS1X+78YmQ{kcM!tTj3{b3Z7%a+uYo*k=got-lkyBJ+1SDMbPJ}oGyFcw^zZ#W9VTzqHQKFS^H z{)QPV;hpDCzJmmr#nw`prE&J!h|JG}4zQC785&aSDzT;fT)TgjJ(mH25X3@Exgc-t z#RTtla>-0Ldf9v}?;xFm`;cne*|o0E_ZHyJiL?vy zNLyS@Z05X84|2@vfQ1x8+;r)7JOttM9}gcbcQT_~ zK*2hcK@8qg=!<4soQfu0N`ABkmG^v>L4U%`wBX&L);+z37Ff~r!|h^!kyWI6UoA+@*OUjqykBwY1Y5JV5THJr&R_VvuoDmJqRSjY9TkUw+(;b%gxj zB<|9#)f%ptko^)n={a4d8mlo%5$-%e!ScG}sR0qsQg1<+i;MK~R5*65boH63rUuS~ zDfgV!*WT&uI}!__gyI2)6s^*zdd`IefbB?SQqa+P+xDkqV$_22bA*-+;WyUJ1$*W* z-dw{8J@O5R|Isx4Z%y+*eE+ka|EdxMcAHn4hCwHp0g^lCQ6dm%$aGf@zUPM!om&GZ zazgHX&(=wYO;X}Duo4jr zU#!>l+2-oV=s&4ldrTGII?XqBjvyM3C)|{MXO6u1Dv)}RlXit(;l48GVV-ErQ7|MQ zon0Io%KHjp{;?EZ=#exBZ)x}AiOFWPB+!q7?=C-yX z`+;j~qf5|DU`UG3GQ8${VkR=Rsn@PoX7DpHfzNm<##C}}42RJ<%@L`z?7D=kwuFbNl2 z)j$5&AgB$oy>%3=slo~4J_1hY@wiFjV_l`$6rveE-=rjv@ED;Tc=?hOvleL46VD@# zF|g93!%2(@_Yh+tY(jhxjxhK|DOaibn6I@5iRaxUnUfpA+I$hqVzbfbCh0x@NVJ;R zmfP_IKP@x{07?oEWjq_%jfeUBqM%?9WqNF5SlnSxpk2G@#Dup#J@J{y3O~k zB9@Sth#oRwWol1OPBi$W3+!ua6LXNxN1TMj(_xaXe_gDsyu7>;$%z#d3e_9QrLs*e zPtvXlMk$9q!PG~3+2PEYGrQzf0W_5^{|N+1R;10wq@Q}D5BzqvGjStb{Y+#QQpbs` zMI9@jBx0cI;|`D`))@c2m~rWvu`#Sa-PD(HUZOjmp7%H>J+JKK1jVl$v3TlBf)3xT z_i~H1#cM;L!bX)J;o1Lr9mZKjPJapz3!dj%nYk6wLHu<_0-_>%DQA|vR^mb_$w zy#+RFv(d8q!uaVo1$%`X_wctPKsS*xwL~AXckQj-$ljYzeZvoq*LOxY@f7SieDT$bR5FN(n4aI_YY}@uyb6pT;)^iIe%HbickbHtI z6hKY&0q=#p7CnFty>@SKhXVpqL+;%JPY<*DOV@!vo+8ba`Rv|aeWzRiE`ZztCG? zSGH+v<1l{2Q@ta95t1ozK$L&-5wPmjSyPYM1@tcvWYh{!a!J&xdqxu!= z0WLi_$)FShf|GGU{<&_^+2p%N`S@Iyr%RjC;9&&RcfXX|Y2JwE+8Pn}A3GLFK|S}z zrU&7YAK61BIe~`!cmj+cDBmG9J6LhUIPSXnGfZEkex*J!R=nDG6HVL9>}+I2gesle zpS)7-O!}e@>8nbg9vphZ7kPblbpN$aUqANsAlv?|ii-A|zhzLHB}kOi!-59vD^N@@ zkg0Dt${(Y$W`CuzFGxS=sJMM9_+iO1Qzu*hGD!%mAt*qq1AKiH16S=eX%ue057a(hC;{#|pszl8aOigW^{nPwsR(Tjk&fHK*!Wuwo^QSbRuhzwxXk*-d^ zckjc{&^(N-rl&PfjW$sV=+A>q$6zg66Lyv7qA{uvtxO=l?Js&7QM2OEMzQ@x1s0J| z;H&nA0+KKP*DYe2Z+x$mU_eg1!?A%9{sVL$uaw}mpy=%l%L2H116zLbM0#-~WblU$ z-;QcqXc2lR26qNlGBF)I7Y0*tz>D8mXIvyH%*R}y1F4lL|7R8PC{gTe?dpQuP?RRiq(1LdkbZo4kQgQQ+qB9MxapFX+v(} z^mNNAGh+rA187CTk=cc$h_kW0B%;@JhCYigM8VFZ5Lpf&rzI>p8iz#Q4~{pI9w3QY z<-50J{c(_BXP-f!UTA3O=PIPvq1?Crv&JhR+*s_uMu!iqAwCYBHLEXBC}89}sZWeK z0wW?)og&gw)6&mW21GFU#njVhG?S0E_>hvg?Y=IK4S)J{mH&}guo_+8M1jw3>4XrD z^+fQL2Y#sW)36ga%ESChNSJ`3nTY;1+eA!@5L@0bu!TzJ1q@C z-)|%(xwx#C7yNhae8m=Oiioos;|p|svx|s_p#)NF_usX9x2~2}#KU6(N3&TT5im>x zmMVNqcbnyEdYadR*jSIaw0{r$yJJ;zTM1WTs5*=&1B6n$kK}Nn1;VO>XWx5-cEv$r z;EaLAY?t@I522I`gPHnOMgo|PZ1ma7n6a52hQx{I!H)LHm|*ec9|=74flmH1FK0ji zoVwhGGexc3?v|8v!dAaed$S2f6ByE9veXcpPML(Hw+v%m3mkU$7Q}kqYZ-R`6mn6ob~m)yHYxyE1p{V?Qf)TaSQ{go@2u83&LR8V?|$Crx$o<~1`xY}801F-F|ZZC zj&}nBx9@ys+u@6{7!F}0-M_JD0~Cz%6kLb^7*q!ynn+%|)-4OL7tVk;hhluM+Py{G z13pD)24G#&GO9>KzXdK5L7}YI9+q2s_r?%Y(B6NIqlZevz3$PkEZr00X77HEj|;KY zLc5LO*L4y1&21zT50Jn+11H1xN2MxpK>W6aw7ZV{CO0Vd&C0pao}bH zcY^T~RC7)KAcwEaH$KnGx?Lpoo6Oj=y+4poO6mYcE|`a&O+VKOQi}{A!a7UXrna@4 z?5&+7eZG#3RsVWrlE-DWxyY8NsZ&Huo6Ykj>4{)#abZ5oNUa1DJsFuE`~6r>x>+&C z^X#=#u*{CCx5|$mrFGcUFi5d+S6vWALTz9*xCXPweQ2s7>(UW`>l%CL#avXuLrs^f zD67zN1DD`Yb#-&oW>U)KKmrz8<)UsYVdfXQXKgFp)G$1+!4yt1My(BXu(-IbgzsN% zVP?|F!Jea{qB6VWh0X*(^LNf$<$EyFpeG{5Qm%4;*Gstb6YtK3FU?=S?Qq1Y_Xrhj zDD~pXch9MzLI+;XQ!D*inY}4F;|wQMH`z-4v|z_n zo&dF>^1d(WZ+V@C5?pv4?qxncW|;Qankgtyl-X=n=ap_mlFBGaKEpTa=@JrIk zW8VkxO+x=Ra!{ZqPdsVa0pfo!2Xk%c{$kfC(zghH$DKW?2(Y@VLtgC1{&6!=kS$=_ z9>yc}J>M_iT9_FQ{Jw9~NIzRi*Km!80PA>2tC^IpbHI?@_Ht`=WDkUcQhZ8y)u*CbMD*tLPfU|7EG_Tm6qwft z&<0*KE(gNd^F$aHpvchLMXhA@i>%DpEh@+9Fk3DB$-~3XkBuE^Z)uBH1pUs={UAwmG9Txk^HKgCpxDM93fZp|Ww z5d5{hot5Y%vUujnJ>UnY)2gglPZPJ0|7>dN-&Yi$Wby`#@1#cfkOemmuh_r)*FN^0 zEn3)u)P#L9`XGED(0Rf!*lT_1_3=eoz`hp*B4ODoS?+!x1G|Vbk)3ugJMF5DH8BK1 zz;qZbXGi`u#E=p}DIab)^gVANKRx~D;^KSk^;~y}w>gO9)p=KsytjPG#m(Jd&6pt2 zL!F|1@q zIB7MGiC@X70V+S-KM`f@AtfuDl9BNnPHn6=O5`}eO5_cnYMY2HFCCLrAgw9FB!zQ# z7U8B$BJ?}h^Xea;s5H$Z!2wRaULw1iH_N_#=TQS8 z$ef<$5f4n3;Y3sY;DN;5hl*TP!k_Jn;9Jlf@{q^C;HFBX~0)}Z*Q0FI1(@kzJWk02Xf^;j?H&lkRXUd6-_Zyo6fkl-Laop`(B<*z|*Wr4!3 zpJ+v~RLal5xD%1zS5Xk!pGwifQO0d}jo}pRv-&Y#RpT9N+Yr~*ZVr`Qwp3H2dBDiC zcjWKin=60S0c2u?0L=+8h3=%+0_3m66i^b-?ccoj4yw0TAmGWTC=%-%8Zb!#3+5N# zn;DOZ@&9$57d9TZ+^ZE;f5Essw86SDuE>vv0u4c(`pSKpt>;OC^wsz86~pUfWb9sb z{}qivX!9UGDnPTwx#245AUUCx{|wO`GPv-mz$Y|cUldZX&72wzdIW=j3gr?f(Vb^} z5^HW}YVhehh}4zdw<+k}%mc6}*b%4pAuMbsQ0Fj}6N$OJLKe)tk!P;QCwq1PM#h^~ zgkr4DQat7}*1VXryrt#rWM1olBTL9uVBPe=17=yh_HNSqNd6lFBm$a!p895Pr$0t^ z|J4q{VG?}_PRaW<<`Qw3HF-t|=HLUH4!mWI>Tp*z zGA$e(AL6b=i;T5x`-$m0=~B*|xmRP}I(7q2`rO=Ob$q_FzzUOpSLCj7yY*0AbwlU9^~mh6QHTY1gk`#}$I4$)lPmd+7v< zHIV+((=Fq!y}>Z%eb68vnpv$yQbTwlVYT+81o}ac#V`uGA)Np#XVPvF7n_5?6F1Xj zfbxg+wVVbkL9W`nKPkCo$F=XPK6-jKMnQ_}t3K_7Uku*)k)2A^DwC`P>s+9A^h;SRbyYR7NxkW`77yX4W zDoN%hM0;5;WE|n#e@jlw=&d8dIE!8q_#X_S+0j({_S>aIQ?|3``}d4i-pI#~4;(l! zJT&Cc{n~2c`z4qRu&5gWMXCRV9snj1;9DYfd3~u-@9f!nuwziO`792ULgJ9|@2p<+ z^NtItggo$iys5B#Ay(ST)Lq74nW>*c~(|_f}VCLYysJ8pg zG#s1t@P_p(X0>%csi?XzRYN&q*SFpoBUZRc7;DZYExwV5Zdt8h`fQ*Kz8FMZJC&Z! zl-mvfTj|=hqoi3(ldbsB&`?~%2RV*@$KZ#S1WtH>G=Hf_`27=Wi;Tne|B~Q{uFh*I|ea>%fx<8oVEurz_Ij@f*xx*NNEWgZilD{Nk@{i4ja6b>3|CO6j4b@2}$vxwY^PEj#EFDR#&<5 z^_`Yo)L|%7^!A^M+VMz9IHh0p0POzU005&_z=lUv_NE~l3Bsx6%uP7zV$^uo))VV2 zw~mdtlnj_{2cCN!bgYFHB(vd++KD@^k`}Zws+pt*v?49d;UPhbY1f}^fs0)N$EuVZ zh_`Q<@zZlq+`6h+yrcc1QXsX|Jx8`o{(E(nkACjSqAKpSFEh5u*B=QzNK9$!Wa8QT zrsg4jprTrsnNn%MBvIq{oHV3&q0tC$#pv9p-#GW!o7BxJl<+3E$CVs~0k~#@M*2>_ zzXhSDGIHarznIcahbxC12XuUR@V4tlA1{(Tbk*F#q8e8{x<%yL>w%JzvmiIi-+t`l z#_lq>OOWCgK}nnP6y;e*Hq@pr1r!trpwI)-sq@@)%ae1Fj~+?L*cIaupX5rZ_k(#E zTdfGqhA1Jp#=O_`fVzjDy1sr#5+Yh5PS#cyp>dXElYDSh{CbuAGo5wyAXp?u{r0Iw3sgEdx=E+$3r3cATaQdB-@u`a}`jjwT%9Be1i=UdM*xnA*`cl zx`#Ycl9IT;00zK2#X>0iG6JulWsCxBEP*fD>45%+aUiD18*QRQd%=0@ia{$=_S$TY#>{-vH z>jv`lvJD|*ky{8?(wTX%l6gp^Nbn#*t^b__) zD?`IxV)s%}wlnVAmjL(Vf}}Or6~;6U+gNLGs7@nylb90D7YfmqQTBtCB45vOuwZnv zP>E)wr#ngZAZgblmvFbKzu!+c?yb*S004WqpADC^U%7e}XCqJ?62kB79InQTVv6e0 zC7b%kp^%oM;@MaXHGyRmHm=L!*WuAMIdJA~6X`f-<|LlhZWfPGD~CoBWJXYTV5*A^ z_Yl*W(Aw~r7$v%?4PGb?N1C}&3&FBo;DVy2W)ZX_Dk`ACSr&uF|b(xV&H{rvOawh)J6b0koj@+w~s=t&F(ds0!k~` zHWb?g$jK^BGiqu+LF%G9ZLNy4vzR>pfdg}Od`X~&zJ|h@hMv^K5f)QQLg3r4VBO))_xK@ZuU7Pj=O(cyCL`nQ}nc+`*6ZBe0Ctkgn>_J zH~jU<%yGAI;)7Hvm!~i;he^uq+o^a~G5;y2RQ0)$g4sO4`V-S1EdX)i(1OS)XWSfH z>*SqNdU~~w5AV-5ER^Owy^k?1ga4DQI7v2LUQSDLKL9XD8T-aKX`es z@M*+@3ki28Ha5t1bh27!*R;Rg*xi!*TpC#?u<*wL)2!f)B4oVxIM^q_^dME)cTP7m zY7#9hT9=mmiQ0gr$;m{;#17HFS$em+M<^bV>KKY}ZT>SFSnM`IlD29@3qQ-t`;VuN z#Ht7nrehb(EIJGYprmug>zwhgz;zKl0@N1yDA4wCk}*?I>IuZWdXRgt(sA+k^d)Nd zKd&>WJzI>wx@EP5IK~q)_6kL@h9HcL7+AfNc$Y?D8~Lq#5qkOe=4b&P z)`!DrzI}{p>m7?h*k2t)*q%HRQ$V^R^J^Rqlux-{>I^QeL>wb+phfr9{<-$%iXvRrjmV}xj zy^Qo_lQ$(|x5jU>ksI!`JmYsGEy00Usdm^d@zm$K_U!Y?cN@f1e15-I-bLPY|5nJw zKcq`v5XA2(8Q%MA@_x-v-&~$8$GTP$l{idx+;>XRa_+sj$hA-A;r5%)sc5eg-wMaA z4xUS8Fg{rKu<{+v$4Whx&0j&g`73tWa$F#nk@(#3woG$~itGvHqq~($^Cl1W8oHOn z3x0aHlMF96l6VX6U_pX*`%sK(FgXi{0$D&1`-hp1hk|cB+Sj=SjOdam%w<*F8QB=F zJM=t@*!Hu#=N3WbCP)8jKQrlF&fe+Yu-jQuv`gR=ub=E5;?3m8r(CIL-E-Nk81*A} z+`RH`Se}Ras4hok@Kv*7sxz~98~wGIV(n;FhQ1Q0=-PJqsj3nxU)aYDg#N{rPyEY(G_ZQFGgf?xIRUDo=SxsDf7lyM$CLq}ze2@iC11j@$oAiRxk`Vw9n2AT)#Zfl+Ooa(`q<2n zPk3!&EkC7NVM@BVca($_PlFPs*@N`Kl}g(!7OEJvqcb?og$9ENgox*+H7@eaj^*1l zT*S_?%RE%4p3@5?(1_|sDBm@b?4`=|VCLMmJ4W@^dPa$B;6R_I7@bx1SFf*j{tH*5 zO_>O$bK=oC{>FQ}+CEC&5k8(E_{l$V%g=cKy|b5MCbNgq)G=Urp6omiYSMBwaqoHK`sLg0X`QWw4QCH^4cQ)B- zYlO*St&Gy;%;DK8K6SOEZM1Gxe%o!g8oqFR!MfEuFL&2Fk%v@rm5FcbNsnZTNQMg~ zEPNs#fBE=X9CRx5L@v^3#E!}QAty-0t#w#vevT1aSe)Wsng44RJ=GH75T=pox%4Xu zW|b3NbNP+KWm8lZnA#$<4b6N}H;6z$(#HP$VP+o5yzJpLs5r9ipcp+ZtDrG|JApu1 zT}jZftPB%MwtYxNMvyk@54rTrVY__pebt@5ahy-d2(d5JCcCL0(9eeY$xm|+)~S+l z(!CLkzQ&`pe8{(kWp5tQ@?efG>#SS^IpM!%`ZT}Ps(s}5$Oy@MiM4W-Thv;2;(c{n z{$?NqDK38&8>_Fk0a`~JsL-N=^xGHlD?@P`Fawojvp4=Oo}iHw7l*Kr!70_m)k9Hy zaSc*56!IyPfxLv`;udyqmk>D)VxU6MBk;*)mabe8n&??F<9BgxJi9a2&Pd`Xu9w>7 zVJ0V`(t?6aB@B<7c&XgSZ3IWF{?!|sKHmzsh3=D=Yw@mv^-QSpV z*qGmjtY)_f`_f)l2*gw?Rw|T$W7G~Rr8Vc|2od_H-Y^8|Wb5V{&e3zibjM`e#cxD* z&XIN?ziJ;LlkW7y(_Q9TD#9j@@;`+od$L`JyU7P;Y8>C4mm z+3IZXm$4ITD_H{;p2x5+w5HJ*-K-2Ht(fEX_ZSGpMzYtsT<+c5FXgm&hwe2QfiwN3 z)Az@RkBrV;hA{{tvz}*{8C~>T>T(7bQ9kUqqojGh?GME#=W2w5TSlYvjv(%;JrilS zNsXS>&lGX?#i(KBfx)@Z4u?BXT5=gqX6gLSOfuHHP?-Gc)t@d(4k;-Efk*?vJ3(pz z^f0gCisF-EbFJ8@&AkFP%auZ2mXH!7g?9E|Q|^Y@2$3o_Qh*WS#as2ie$QP-3JqAK z%C&yu?BujeS2#7QrzEU3>sxP>70gW*2$;7$jF8}^-x5n^A;4^@H^230rkuyu*3(;+ z{m4F^XAFtX2QYjuGI?nrcP?@=cU8Fmjtb4WbW>fqdSPLjJSv?hr^*Aq8OEHaD4Gt! z0^}5z%HSu-!UcC9VxrzbGkf3+a{$;95nB9e>K8y0BUD1hXQ-_`HQLf=*F7Hvs;8Y?V(`(guMTQ3H~a?&sb3X#>l0a$di5g8isQ zgv|0ttTMa7B|W|H*yrCyXF(5HnRi3H&!>8u6YGoNuq?fs$A1qqkd6L3NKeZKSmX`2 zGbEPudCi!RK}6@!IgQz_w4-TX)twbGjw23ThjQNzId=4UFZ@;EdFk})Id+B_cP|2z zb+Ej&1D868Qb8ax+jwme8KshJwAD~_gAL}b{D94znU{~xttI2Ikx*_yL0P)xRzUOa zlP%yReE(4tG`{tKfYv8d9zw{23A;bORn+Umk#G)m>dciC{(WE1_xnrzG@|1k2&bl) z{IJ@*;GWz|YrX5OuF{t|QF5UO8+x*ZZFhG*@k`}APsVz-|0{>M zY5Hrf_AH%?k$6jtaf1^UrSi7V)tiOnAm$lxgz#SoJ?w{IC!whAuqt7b^%?=vZ0q1a zfo+B>9QkG+?Q|41gx_SN-AD)0lKrXXF((C|Z7p(eOj1dRGb zW8OY}Y6)Wo5|M8o)^JVD6Qp~cd-kpU1KN;$pS9BkQneEcy!Ok(pP%)-x_p)^kM&XA zPk_sI5}DcAN3}84vlLzW9J6cdo$HpC@2?b6-l=-|ayo?dn3c6P1R3k=vauN%nvK5W z#SOgY+dh8G)8ZH8=U0nQeEb+>?zs4PBO{|n9hpzxdOem;Nq+jK{^)G~9XjkE#HjkQ z-@n<|*wg^Mm(GtuRly_l4bUg1j#Y!F`C5Vrggp%;F2K|a-K_2tk7A!2!EoAt`+fq3 zIY%NteQgnY{(SdW@oV||<(F!M$FJFucRu4_yxmKY&D|%(l$nyTU!QWwDva!;mt)ZN zEgali+P-icn&D*jmpD!^s@rRKsza}lCRol;^ua%1lmuIdG|>Rfe^4`h7r zr7s;K6R%0=SK(v3x`m)0LDAUAx&0+4TVPtYW1Z{V?A2{U(N}#x98@4xlz&B(xC!Fw zn6ocV)wXLSCFZvN#y}s)7lvEC&CNq|#%`$^GVHlIvd;aLKF@TPVWP-NgSl+QwQkSC zLhxn&!1P!}{Q~%wU%nigi9$x+(o8EdZ=ohtQaaEmQ&5ia$(uK`02SEUr;+vuJ8KJz zwZs#pe_TDy%$o6kwr{@=UcnI@uV%td#j6Vy8++u@;!H2eKM@65y;9I9yKm1Ve1-6Q zDW5h%XT3CRg5>~*Cp^D@96JyTg2&RZK*|$TBfNHz{#G$jn!36=0D;s>0Px8C($jge zb!`d_XP3nZ%xr8wor?YamEc9+n0N^f*rPhjEWMN3#%u?)aIwLK zqkZ;86Wv8C9@~ADPY0Y_cUS(ASXf@(W-8p;-ku;eqb|vI#V**z&Fx8sK*LacGbLtz z>rfMvo&bwegEhMj!V-} z>`M%qXeO&>>31UF%Wg+uR{vs$GKf+_xwbAJ;z}17LLgc7cI%RFX+DiFoNP z%|z`z)6mYCD7yS!njwgQoj$bIf&j<=v}Ph9*gHQ8srRKKzRJqon=0Or!B|+-V5BUc zV%zz0*Y@3lXPD0LFc4H^+>#zP4ui#_Krk)nWC;3Z`xy?mu<=a?AL_%0LsEX|;Ioqw z6G2iy5J`tp5gb#*)e%SP&vnE0BW^^7<`E9dsAk)jhKKPi7#G*IyZ#+Z#KH6m%}b@yKa zeaPvRmFw$ANsEx4Jo+W2A95~>jqas#g?)sr3mF(4BXgH?%jW3}vq8(&h$g5>ZeR4A zpW9osqAsIBMu^7Q=F*FW?<+H5+$IN%K_kscdS8mx zMfsZ5`{2}rT4;yAf_wlgK{comW zHm)b_SdW2$0imhAT`b2C8HmEnsri@b1%7g336F{5OieyFY2>CF9 zC_b`TUTSQPU@St{E4@#s{bBo<_A_w^E0QmlWM$P4?uD*KlttZsfk@yR|hHPmtoSU6EkJG=BPowB27&euGhdNMJ}@qOD@CZGTQkN^V z2)X*+TyZUhliu^zPUm4=6r;FMi1ro-TE(m*5~OcTSJQ1sn+>Aulaj)zB=`=_(bLn| zTab~~)g@!*O$r9_giQ|~_kFabjl=3^&ziin+!EISq#Ua*HUpnf!ONF5KkQH%gMgUS z*xu5T5Ou69J>AZ|BeG+{L`ZXaF4tFCdn)_l##g9S8jkS+s}mKaxl7{f$SdNYyp@X&{TKWwJ8La z+g*<7zwYxxP$=rWzP>oi=gCROt5@q`b{?xgST8(V#ChokG?e-Jt7x=w^R1mFs)aWL zN<-m5&$tT!VeKH?cT2pM&ZT0jv#+^l7N#OD{u93S1bUjSZsR>9l`uSRpSQ9En7tcl z!s^Fera%qm*_f!g=vDQ?U{}y~*3eq;S=UB0S9nSkC%*5^-#y$^6MLQG4@0oex=ax zUMhqg9}WkcKCf1^zQ2=vr$WuP*X!dRH{3tneid1<^Z87MXx<93+Py23_K)wHM(r)E z-QJK4drFR5X3-!s;ZJwF5d+9}{daV<{Cl&b zlmT6wwjhpQWw3JvJC1=%dkUPd{>Bz8z zsI|G1%NMaK)V|$uoZ>{L0oSi|yIcOJMRek)>CUC39N$MIZHiILK|BPE{FA(0P2cTZ zCH5vT$KLbwtm^j6q&S83*0lDE?-2otAdY;}_WX$QneWVOe_U?~Rx0+xx5kYPukQT2lxw6TOpyy-BLj{d z=6ls5glW#>;%f&FMZ%!y!LR!LUek3p0Re1?2S1`bQGCq4XSI^zEW)Q(5U*H@bgT8H zJveItzf=n&olYVSo6x<0fD#DvLs+*~3V+5 z8%qdcS>gSnp{LglKQ3r@4=@B#-Ex%ln*S36H>$wu0h^@WHlys2)L!&@p9UK&q`lx>LowH z$5n8n2vZ^XsW@A2iK^cM16t(n!u9D(PL4)g0}IX8$TJsCooXI2*tM&`U*7EedG5e! z$ROq}T-Xi`DEx^l^cm3j+GnA=s!b(Y`XE^R50LL$+YJEw|`bhSmc5x_#xeQdxR9;aq- zI*kfDNoQv#fu7o*cj}Pbzda+v4*3nEaLDWi*zjve!*j_B7Yo{)l;^yfvT`Xj(9FoU zg_}Ec@)vYI=VX^*lBD}s>VOgwhnHc4)9^eRF%FV!FovDPuv@j|Gg5aFJ+AaNOcd9d z=L6w@oy&hU=6Lwieub&bhHJ{g+ZMT|J{1#s70ZP>0w)054A#=sntub67QRfn22v9} z#aHfI<-z>XRQPdZBq%=YgrUzde7o--Ki-YX;{5sZwev^a>@Vo*zOE6STwl2e^8it? z5MUyrF)sxK1l;~~j5~IaQNu@@WQ_*4QO0FMAmE;;v%-0wmb zJMZ1ruU~swS}Y`N&hmUkgYmb!Zyy_5p5eBQ`JzVBW3+a{sko=uIZMK>Bws&1G7_=Z<*U=q2q=4$I=S@L#Me8%dLSKI zG{sZ|k78g5ikUyxQTP>Px4n8LuB`)m2?7CTN(2Ict0IdcQk#aOBPp)rn%u#A(k>(Q zX#2m!9=({>3|JI}pFpGs)+cz4W4W5~vTJkrD8qpcMOr;jeCOe9D9mi<;PB+>8+}2{ zCIK^utMeJ&SLDLyymD*~DZ*Is51%R!&6qPvOULfeeGgUSO1tqv*6PS%3_sG-`EiTH zyR@C0sFNDcXSLE)qbf%!qWt9Cn2QIT`gSx@#8C^cM%Byk1arWpFS1CD{gEKi)HKPu1_CphpJuBXi-k7CLS^jB%rIw z_(2V}yB@u7%jnnl=GT8vc`GQar7GRW%mWJ^3JsK?!Kc#*{Vvk)2J+54K_Yjl*Af>2 zO=(Mp`o_9O^}xsBr2TJ}+MQaz8F}E;K-3g;yH)l{rWen}X27E>CN2(0{WG2C?lQ7w zgDF}~=J_8jr}0E&<>n^j@+{I6>$Pev(_7!Vaf+nIJ>MJMRK zN=ImIwL#vII7>mI=lIREW<_nC3$4gCI9_}T8VqcTY0Wwp3j5*n;!|;iyL$3xcq1lm z`z7-xAao))F3&zAjS#f7qTTED&1)O4->x!saM0Ay7zZ4O7^KXK3YhI9Pw2#AKm1VZ z;cJMryO*6WWRr?g&1pFSsct2QaQiv%? zjP4J{lww=9D8Y{f{zqyCpyn176hH-~-7t^`o7@9!HErLFSlC?;e7Ytv25xa56s{A} z3F|R7iCf^)-qPM49%dH(p5t=tI{Z!bvORw0*Cz4{2uyjD0ZzJ7m{C@iU0i%nn~#37 z{hLwZ@uGXFPZJY!pxV6J9aKBm+M4O?JQIAnB`bH`+ra_Pp-9ZhYQmwc_AT|va{o7m4hf`{`g4Tn+p z9(6HjFm&QGo{iNgU}s|AzmVF8(au@u?=0)4QAsH#WMl*Y+&9R6+*|;~5cr~8VUsZP zQEngoN1Ou6v zYy&heF8=LFrj23tohsAG-8tf$MXh|hk~m94#Juu;Cc^$+T24g}TOtLb>W_+w z2A3{x9yS<^{XR`#U=9Gi81>28DH{ys9zEJCogjO%BDu7*Wn#g`n&mSI2w0zMujM=O z5f2oMt;hZf(+s-8@@XOanE$`}F5NV=_u@>>E^2>}jGdjF&{(0n-`uQVB!JMtob2r4 zmgdb)fYYTh`u9P(BKhpL$B(}>jkOSA27gXZ@3?T2TjrgAZ+^ts=?E#`g!B=oTzp^B jg4%!cl`?4mZx^wClIwE0wxjSrqME9bhGLGq>Fxgks+~x#%XL@cY1!D{^#DC>^yt2XTERd z+*A7#Zmq38Ug#`ftL6DLZRR#fp5C#DOMTG_fKKX>X=K}%)yJRUMq9`RILZs+q zZ)Ry@3IZY-mXrdes&atp_x5=Pj}G}DXe~}2gqpY>1Z-MJRTx#0iirXOqqeR&fF?W~ znhLI&DtF@$c32A;u2HNzz*`9OovSYGqT)|D-rm#Bt2G|`@w6vj^V8?6iP4rfE@#kO z2&evE@R~4wvP#KhB;BC|SUG}22%xmNps0f2bch-s%tAs#K}5~wyGGiULDF^XH5CRQ z@9y5zRNcL(u|TL$Hche&q%c8BM82##cqF^Wx1p#f5y6l=FOwC^UxiA^ zXB)A4{Gj|05X^`V!kg9?R|qE9D13ZvWA_0yl=ov`?H|N{#MKVlPy~^3lx(egQ5}jPY-%EI0NS2|E{DnW|h03vA@>`gy9EJs%%@8+UzW%tCB-;n76D zgGm|mn<&J+u1e|S(wZwdSuDcCdCYj{nE2B&dWN(ptM|fRad!4xcHra@vt*K7n~!Xn z)E1bfGTcOD8h)RKe)vd@is>A}75~%O^kB-V&2J)kXaYraVBDdRk-{aU=pe4Aj-R$g zmn0%~ZvyMx{b=?PLp7huV~S_6&BGe4kZNxGr*WHCFBE6?udMRfcrj;397kw$cUa~R z!xO0HK_f2@IG|2#tUSt{9B>bu=64|@pHl~6U~>$+!GwvxykcQE{Sd+Y89+WhV|+{q zu1OBpkPa#hpyftuvGwBC?r*5gUtV5X24(bcD;5alaQk{nCfYZ#-U$J6%wZiN zb}HzN55ju#F=NVn8x{j}@>3E`f{DWNWC9XA5tvvmEUO-Xa&7NCL%_xqJcMumYY#7u>?1dSm)popXTZca!* zm@>C+(zFDs6%Ij=bkcesEi&MH&4&u`jBaN`$kCv{O)7VkOjw3M=M7$W8XZ`TzR(S` zds;7y&Ubfx6Prxvf^mwhiTpos2Lx*s4ND+YVWk7K0zU{Q<(4T$m9VQ)9zvE8-hkbp zM2V?Pxzw{Q;p2aa7I&T+nY5nNo;2ML+&8=SxJI}J@kD>Y5b3cnre(6jW~V?*2>%%U zeJIhuifM=mi?NAOB-KrmHaUcCpw$4p_F|Fs_`@;gv7QZDBmQzAet-0)11CZz`8YUM z$kxU;hlggqW|3x=X1x{UQ}FDdg}&vjmkSto6d&+T2>lp=sIviqff%$z=s^e$VQha1 zO(`mpW6FAzDzp&jEm6~a>Zw3%F)-CSl-|U z*d5q0*bZ0*44Cl2aM^)@aISFj@FDbSnodO$sx+$FL{4ez#2-oWR5#R7)GA3QiG7JI zNljD>H2UfU>OG~YCHJN0s+X!(s^g{b%1WvtA0mDf*%h7^>*XSr8mY;t{VcOA3oZ*) zYg3h&Q=NT3XEdu`l2o3hd{mrgLBYyS7pN}EBi$zV#42Hq=#1z)zRMNm?77#jv7mgX zzE_S_!cn@e{8lKma6Tisuvj&ff1!w0X_?m|=-jf)KL(f1P_Nps($K8+PD`TU)Ut00 za|vasyxzLL+A`)~{}5vTi|g%v=8Q+4%*@Ta+{|j}XDv6;n6kZ6%Gu>oH}NwZ-KgL!DuEV(2#|7+NC;se@O|igSt0l#1>&CKS5Zz;xRIwg zXpuOBU|Xw$S%YVCvT{ap>}mC>@EK(p-{hQS@ni{8l}6h~lhf2PR#}JASw?5Z?$X_~ zyD{Z4!6KX@j*@GN>WU_vs!d}s27k;+o2c2&naeerX_;$tXd*36+6ddQFV-)%XIisz z7@pp?WI1;&asM=1JZDN^1?BOxQvxy3)k zBd=QgAfJ)Ro!QCR#wnADmnESSsS~gBLFW;>EYe{RbC6skvOMNUYayYEa5Z!F+e&on z%ck8)_Nm?(KktMKf$!R@M<4+t!TXpGF+K{d=J9)X*)MvJdhe^Ps)yD>)_Bjf&WdH7 z&2X=fuZm(SWBT`+Cq5_RS+kX|V(s8+11k?WQ(R6Z}j> z!N}?G*?>?xbj)<2Rw7U*KpiRzi2_OjGUc5BVl8xBQ2kiw9@N-6)0ei(=d2F5=3hDWdZdoe`H|AHrJ+Z87O0PQNHcN=24N zcn}`pX}@14XJFQ?H=5cRNRME_ z%+bnk4yxPMM5Ul+FXcaAp^Q`+!;vwg)F6v-`na;Xvd3$`Ccg%~9;iR+oBk_KIg>f_ zFs_xQ%MCWFsI;X?!qZ~Y^R#LvlC2ah3Erf5!?&aK6R$PAW)HO(KWId0sw(R> zTRe7V-oIrMs^@7qYPfD6?p00TYmVvYHb816w0||O++1pJ5IF*y$JbHN$?1GeL1@Ga z=V)KWZmXqJptRRr+u#6QXWgdRmbrXlZ?P|X#(b$fU#=QM%(%08)#|2cR<_XARKE9s za~nxIJMN@;u`{y%F<(Wpm+!q?vn;x7XMeZkQ={3!S?umG^o&2obHD@lsdKf#WMKz& zDE`N4|LV8Zmm=b#%FmIvHp^EnvWlO|SBl$9h1-mr2cA0GJ35})@7UB2RWa3l9`){D zvda9*cC8W)<8f`|K8+>3Fg@}38ayj%lz-ILeA@Bb7kuma61aDyb9i{za1?>N0r|0S zIImx1HPjoaiCv3Booy-|HpY+i8|j3P?Bm7l)J6gR5cUwRFY{~ZFU}ixA(q+pZyxnx zlhfr2ig`=SyVpO-IkY<>70l;2Dqs2fzoio=Sp?>->Fd`um7oih_=zj%CZCSHna4Ov6?e=ZjPONK5%c z>&VT#-NI>Owg+GF=MK+_wet?g3yP=RIqkeAPdkbA&Y6_O1>aCN^Lx9&RgJrEXHo0= zcOX}}8+p@x@e)fhWxi~04W;WXZ?k@9-3>!=F=t3lP&scDFDF-uYiK_b;)^{MjzUgC z6{7EBTm-c5ZT4I4AMPWb*OPp!-7Rk~iv`->n%QwVxUZ!zt$y7kbKu$|w!3;QGhy=I z?(6QhUEIARWaWSVJbb_SKz%zibFq`-m?P7b>TCIg`+UBHrR6+AyG zdk`MZ;TwGtImeouXfZ1x@r3xWFplBlFDy_SGVA^Q?j!yEDOzMdKZDeFWn>>vzKa;W z9C&0TLd*t7+sI+&J9{e{^sO>r2A4RWxKW7P!`ZU&B0mAZu92yxl$o3y$OqsU8Uzd! z6$BhO0tJ3SLM=fc{yGK$p#a`NK)~ZeK%jtkRNzlB7wkW0A%t_m|8oqK2Y!T9M5LsE zcNJqNQ&T%<3wxKxPZ0os2IIF>)pXI6ljSzHx1~2Uu{ScMcei!;T?B;Jof|l`HFYs0 za<{dybLMvEBl+tJZs7R$#|$Jye_i5Y%}1gsr${7X?_^5EPR~fsNWu?GL`1~vWMamx zEGqu*;=q4=Bo;0%4%`e3Zf*2fdCxyi{ZaIH8@LsmEP>k@ z{_aG6CSHdB>$87f&&%+;hyUpDe+}nfp915_56jE&-?_mLd(uLO0|FulA|)!M>JECG z^-dG>Bi2v~aw2k#pkgiDa|PQxW?P%aK=-M7e|Ik;yy|gx72EvjDLsTLG71^Q!Tl=( z*3i$pcMzgtFB5$%pHDmX2A|FJ?y|Y|)|6P7m>vS5U}8c3=k?4BG3%S1=Tt~02=+g( zTp~f1kcl392|-<5UAZWQS9`a0kDmWt(uE2tzw1-f_TBn{*`L|;2R@(Y?*5bt1w~6& zg&YDZ5$Jzj{_s+QEF#h2fj_=LAmVe!k;`Dt#p$-YuZ`PfTD{&)lxkGxRaKovU`?E@ zcTsu{`Qfozz(4#*lCfX+6e&?ENDc`ZB=ogVt2D%3Ed)PF1VgP0Bl8B4w1ynm|yb@t|SI2(3(baSij&gGL#N=0R{Klv&! zV!geHFzE#I`H_tSfz{Q8}Qg|RI79bYiny4s&vyh9anONL^9ZI zPEJm~Jh_Q{ytc4>5MWJWF_)JclZ}gutJd$r<*@62x;tC0KbR~}K?s3jV+AuG zNuo(Cbw z0yGSaU?{Vxe2;tye0*K)WvL?RB%x+4Ny+o+q6qF!&pd9YD|e@>_#AeHlbdP(8E9aD zHh9n^r}4m#Na*RSREpV|n3$$hAMXf_3=MHGZ!d=9M3l{#g*&|-62e7M8yE@4;z-Sz z>AXy*{6Ix&xWVe?Bw`38<=E_2+MV~h37bJC`AIUio_O~k$pl*cZ- z*qSafZVf5K(+g-f9;>UnUhOeVwz+Yb^osgN7}oyhxAKp5kM7Z; zDpbK~us9qjt1x(wY0&I_{sdFOlcK3Om(IJR!6pOYN&O(P;LD{RSL*!y_PRRkqzBve z6bjkx$PW8Q<^ycKvcgyv`X-mMe=OVc7Z|b@6&xFES&j@2d%7rUpsE_f!fgd&hWCKOwG;A%*@Rtm@8vKY$RGt=Ehw^9ld*~!5oaL3j|3S zio{XzygPl}{%%YLhe^w7G0CWeV$Q2{?rO8zio!h<{X(--FkdLOg+-eR4hNc6W4N-q z8iI&lS^B((D?lcbj=vc-AFl3*8^)o3!$Uq9G(60s|1S)c~vbmjBOisqs z7$%mnNd4LREEuwbD1V&5JXX6Ele4ufBiWNB*F>c8>2I@>c?Adv2u4OmIlLYw_V%G% zB?&WH5PKW=?Tw9}o^I*Ly+_}fk7phoK8~*WD1VPnh9+lbWep;}xW5pQDz;mF%;Iqy zfV1BQihI3y?mgb%^-#|?SVPGwe7-#n#Br|H(?v0zZE@xp=JRwBa$8%|d$_`yo}24A zx&qb+pSy#;l_GRAGVQ^jjJK+&yg%4G!~8D?%<=Ag0+#U|rKLD#i)ZUka@oAZZgwo2 zYJ%s}BPplGgH)Jb%*U*nKb=r8H3q}&t+l#}u)gAD*O{?l^V|wp8%Glggl`CfKt%0~ zq-?ASVKW!5_XG|Z8YeQm6=zQSfwJ4#Rb6J@Yei$xX9iA|C?%kh(-Ij(@xzAzOPSqz z9`$Z~R&_HIhqVOgB_`vLmpD?&I9lCS+QE&32QA+E%}vAD;H3->J>m1ayAO$ML@U#Vn{e6ah`g<=y!f^$Zm9@z*K2=%jpWsnO)7aKxjgn zNVqKNqz|N2CF+&ju{5eBK|9FElUc!HrG24DoIKS*LPoZ>q*@6%hCBmCx}=IEkBHaj{trjW(mVl<$< zC}6}DI{bz(;SNGV(pw~e4dMsFBA(0X{TPJ2!E$ly1CC>sH{64hR>ls0S=*F434@3j z0#c5_9ytsHr-Gg1u>HkkB-vKIdJP2pV6m1Z6p{Lv{C#f#s?*Z=*;+@^2NDRBZ>`+y zrmuY~yaMBzsH8U7!!^MUC&=!9hVf@XFey)CMhZ8#J79b_A5)nJ8f|`FLf0+TTfSs+ z!Sy@X+Mrt#d@~yh$6BM)Zlu?$Zyrt=1&L#2{=sj*W<<*jL;+f-AIWr3)(|qS112aV zJ#Wu-B$r2X)?dDtSDt7t!e~_Mg`B9ieOe8KLNb618$fkCTN~7ZQ&5;FQ!6Lre?|(3 z{&coRzZ9B8LJ|y%MXy|E21FDAQrUys6TB}x0ghmMAfp6}x^v|VsN9-?h@clvKfjsw zsm_hkGI$A1Wb=tpP^@SQ(a*NG>)Efh6MRcc!|9DeRwsLK4(dH~9$e5+O}USlqww=H zy+eg1e&c|U+5Dx#rwr}9#0td=lFw}eqp5fvQ`(pulDWT+U5Xj0CpFjyg40-^2o8#e zJ)DsEXN>O@@ZWA{!XB$N4&9*aq3tprqWAIfAt11uMt-`%tG8WVW3y)Okq-04&pz+e zadLqkMCoLe}laP0@sDp0tWO(u)gR=PyDQ&~oTqQ3T@?H)s4<(9GNw4&$M z0Bwpo3niY+$v~PKg9!%AAr}Ub1XgC4@qvhFSdpyjvf}Gk#6ZlbZo=trrd#4shX$20 z`L@C;Y=je$R=ZfvdhPCr_}G^54?!<82BE&SBp81KB|nHxYJY~&liQQ!KsM(2`3^&Y z?(o=<0NeD#*;2QI=?7r%b={woZm&<4-T_lD%oOl#^mz$kv!c==XACm1k!<7L`JSLa zMG69waW0Kf8<@rzid-0^S&hqPW%Qjh*~J+0XX(uPB@tn%G&9(3i|5m=ZQG};nng(M zWJ3-;sTQ|0AI%Ovhg<~p%Wjyf3*#@UiHS;N)QYjtI_>Uy!vzuw-DQ;6sC^+(gRp2O z;SI0xX6eDBX$`@~l$_X4>`-}GQVHnUtPdz?Xi;R@YPH|qeVYtYtkjBPO(g^-tA4$J z>*44?ga)vC9daO1qqDkG{Ea~guLeP+SILuB+T5__n}{G`937qTb-+e3-hZ(Q z%#lEUc%tFuW$dU~6R(oxq6VwM6vQs75xYC)a{1NYvO9)>$7@gtcS|T!re1c5B20l< zVt@of8_DJK{2mNHNvqlW3DapqdAaS5G1*usBu4&NU8COOqCjE-n72Zu(w9;d88_S$~Ev&DMh z7GME%I?d=23RQX?-)xuFw+mDtP&Ol9AY|QUE5cWT7(U#iWU^W%pmt#5>YAnnLBY)=iyy>YJWj#ZBfCXG*Q|Z%3lT_ofhiyfxI!UYt3OU1I6w8`@Z zRzN_1>Px*2)Uv=AHSUu9%1XL2K}vf0>+JKDAFY^NFvcRT$1zRz>vmpaXfYP$>T&~W zg(m0U*s0_Hpi706ploPp39L<_wnH@@Oab4fC&7|CbMp@~v1J}+<_&NMiOM#_c#Iak zyuFhk!OxJtwmX0pwd}0dk?3e{P~(&wAcFGnZ*2;>?cg!Tum`-AzR2YG$KN*vQLd z{*fZxqqInkzTNJ~s$t&L$W>-W@pyXp+t&xibnqFGELzb)e?w^>LNHv1;%9!15gKxT zRg~^eV2grC1lXL;8>YQK2p1V0CV&2n>f=aMo0$i+fY0y{7K6|5Zehk`|6PfH9mJwY`V=##k%;|4qW(HD zj1819iG1o-`ZK%%$Azf?CqpmDC;7Yf-&Y6@0wk5fcm*mt;P1x$-t&kCfQkySF);po zdf)^zBxpJl&KAD|`hSV+zYeG=fQkl6N+kcllK>%(WrDWYKR6)gj;D}I$HT?#^w=V2 zU}I;uo6PpELw^#1{Ay^X*mzP>KbaZrz$Dx4_&^8Y>gq~a%qA}Wv$wBrZg%!?&f2fK7zm$y2;RVA7+SbnjUx?J;s8)7m-DWy z6lrv{{N8xh&lYEG>BLfz|83nl9}Jo0V0VcB%VfL9QO9Sua8T3nOaOV`;bc~xpf57Q zVU2gV9DsQqFW4()ao+%u-f^?HMHK<$lvHQn@y5DJzw1Lar^`NwhqBr@K(_!^S@tkW z{Ev2RLd3HeGd2%KWk{OIwtd3i=^IO=o|!FWfyJZ^kafGmN}z~}2@l6*F%w>Ee_%G9 z4p=vyuduADnm9hemz9$cbU2@{c47U5~BgUV*x7;0opM6n<}R-X)a`EZGOY&g$okmWm~wTxHm`?Y$#gtyY;4x^ z6}l}>NmaT$k_}Y9wvf_zaBL3Iz2rlm)87rx?=kSUAv-jVPp0>p)c zTA;6;iG#smqq{Q@>W)}|sC#|>6Eo(K@d79rpai&{u2@3Pm8n&0)=qzwJ2H?aJ^-}+ z%}q$58$chLFV|qus8H18X|h|jn6G#TUpW**I505q`0ya4SlRpjfA<)FLKz}17D!T_ zPsfVOjrdG;XN$FPUvJ`>Ktf@pf$^HJ(uD$>&)I<2fFCzB%;Vfbww3`9X+&Y$=K$h3 z)zys+gFF}xXb5+IAaZ?qe_&%}71Ei_?@jAOz~>2)XCgHM@D{;tOcN3TA|ghK==Z|% zuaT>ZL8ahq*akdqb_#kqMgQ1(1Twp^MuCm5!E$D5sg;A5;AoyprZ2e1Z~t4RHixj# z4^>oTElfN-?G8`6Ae%g($zO#xBV1oz)+Ho{h~|&heKD3J!i;Z^-)WA0GaZ4v&Jgew zsx|3S%=fO5?{eZIgHZ=pcL9-%v^Y z1em#am|`w2*HZ;KQLu}Y{QUd?o4&lh?oZJK7=99|#4Q2et2*vU8cQ+IaT}y`U#6JZ z*)fW!OFwUPp8`QF2G6_+z$&wcGv@X22YezjSd5x8nwJl)U5eT!*6JVKx1KI| zX(mhCy58)Fk2$E*;fX^LgdL^1V{gsld3zjeJhVi@0w5PaZ$efilMdbu$B@zMx&>yZ zmZ<1mcP56)94RfKHf)GPjOd|ZApDA#rwfY)yQ-+X9aFRreFfhixV-C)&Z z;BO2_3|mJRqW`=9#wtOVq@|{MjcL}{hy#PUzAi8&E*_JOOhB-^-;7*zUa~=x46NkX z#Dr=ZT+u~r8#1+&F8~W}Y)r1tq?lS$$qsY)X7lqK9JqK{Q648NDJf~;d)R+;5RSj# z6Vh72trw8aBED4D)S{ll+d>-?y`R!IqPaDEbUJjkrU ze!{TZaoK;&4noNd>kcOU_uR=_8YPNSDk?AIS<5S3_Yut{|Im-m#lY5AA|HN1|MP?( zSSd+v_6OS!34cJV-+O5{5~U!^ZsT$C@*E<$gmHx2&;Ul;V3md{kt}g^KN2F zN-=LJ^WUiD*%Kn3)i|Bi^7S-p;^s(WXTiqCMyJ7Q3<$OPlG!yp-=tDSASPePtRqh$u4p(05&dvvN3GyBRxk)$1LuKxGu-Db>A<+!KRvvLx5=gU0X_e zJY|AcA^S}eU&`_;ngye%sE3jKtYBe0p6idK9<)@?ir=~6fx?b35 zbF%=y&vQv(tnBpUBvsn9z3Md^xcpVDfvU;(cyd6u%zx*>Ow`?_-4tzU$CVZi==M|1 zip}m9I?U+@YKb%{wb9YhCPLKYGv!!~f8ZJ^l*!R_wxduaLe&VvzKxU5SG$!!455~0 zVhKbjD0|3q=H=r9&ZdUQJ8us^h)~Q}Vp|PXpyJ^8)A`tQs^x^@iu-yzeWN zLYpk`_b2A1+ueP~$~wDg?D$D9ObbxVP}h17X7+g99k3=ccw0OhW_}Hfy&0?@zLw(>Ygk$&;URRfYk<{3wZ9?4eJHm9o_`6aB?`EwsTQ~0K|5Cx{3r2QVWH2 z8im8c%g+Ak^_jd#`sM6L(g+}T&&^yVWv$*fSaY8t>t=>`Vv*lM;UDz>+zq{MjWHA`R}lzS|_L39F;qDs|94xb1k`JTU@1yWI z;-r@wo+ctpMpezm(vN<9Gk?16h>oVY;8wTj-Kw>mxy|CatJZ2jWRF)}{ZU4+D?1GI zwDW4~OGnZWOWwG7mzy)K7{4>1cr+EUhl(D^`5iaIFtg}Ca0kB zR3X;gkvPWlp<{$$dlt}Aj#{Y%Gw9$zSB1xbcNB=GVmnp3 zm5w3a%=T*)z_Y>QFryw_Qp&%Fi!ge5qytu==s~*&A|p5nDd|RAcMO<<43I(r@Czb^ znVH9CQZFeKn+K`_o6~ma;oK$`#5*0t-A5xCkUZawZvMp&?!!BCj*I>o^MaW2Uy<0VGjOWfAa=L)F3d6(~+N>yA{Z-4)eO7 zV^^fR8w#|`0<@rpg~<<4yVOb)Ef1!}ieyr3=gR0t$%YjZC>t7B`lN!ts#ojz=L1ZX zs2RP1Xsg-xji5??nD=kQBbW|jAubw3srGYqwL=s}1{+4@>tZsUHUUEjhpm=?d35h_ zPazZwhHNDw!AdCEuS;87N@Ltmtfth?#ii(hYxJ{?O+1t+4vR@_G+GIXfykjL$Ia;? zn$1jWs=?K-n(yZXY{fexxj|vs)=7_2CsL@&0~)|1~4PTIZk+ZBqSu+@z}7t zm-9>m<_^O^qh5qQm;|mo+BHJbZgDclLC%42Fa`#N(Ilo#5uKTnG6NzgPiqU6!`=@r+_4n}D}jU#FqC*oc9akB@J~&afQFW5YLbYO{+OU`GRrd>li3 znYsSDTW^Sv(%mT^jYbs-Q>YNlL0jvGNKn>j799xXPUOjV6%-JDKNsQs{L56+%RmcG zfpqi^-TmW-+gfNu#JKUAMdI>O>Usl}o~0g^0?B^D>3acFuZONOjpE8m1eY2^#h-nB z2$Etn?ux-EsTKuqub=n(LW$5}^kW&(FSG>_z102v{c9SW_Si98?N?ig?a8Pll~5`s zu@c2l0)7PH7~9z)9;tdd`b{(FQM5}b1|q;nq*);BO&5(o;|NGmC;Xwn6{ZQs%RGxk z3`OHxEjN?f@9Xt508VTW346%_!dK?i5D-%vHF3G+Uxm8tfDRkk>r_uw@;Zn2l{M+oN$2VZ!F1bOK+D{k&7ad$d( zOIK2px49mL?a(mNovwB8SAh75e`6sSFc*hVPprEYAQNwk(PFo z-DM&ja&HW@IGj%m^il7xEEm)7W&y7lVnF4%&2dv{=mX^6)!v4^(eE* zYczq8DWHL9?cRtzjHE(WT(G^=vR6ibn+R4+)zQrt)VRQU0Z|zaS-JCCOb_mgm=-sA zkH~>=(~tyeP#G|SK!e89cqtJu8ZhquYHTz{UY>7teUi^=^{R!%5ZnMFqh?L5#T1Z+ zW$2*{c@IHCAx**i9x~>2v9_`8lWk0Nbn;P2IgR>TADsUrEw81+fI%ozi?A{?ufWV# zu5NW4o=@2DWrefb57dM;?drFs-K?4>bMbRdo<(Wzg$QPQ^VNp>7%kuzrHOU`Z(+&$lgRwPbN&=9FPJt z;$r@FAcj#9?I&a2|AmRs>2Se5Xy97&k)+`^32aRpi(UsJVq`1p!we%5zq2?>@>drk zap<$gDIUyR8VpMdDzoWSy{&ib^U5?y%+%1`4r;>wV->*O5tH%~h06vy2f&PQ%})1* zH!9;*lx!T@vq3@#D#<7SUW$;Wegg!0YHfDXm3LE9#dY~iO5~kCCn)=+Z;lpbmRchY z%dqnjFF{A1gmszNgFbqn9>+|4qgrjS##I4j%r(|~obOqTms3g#UtL&=g- z>h$KYDz#BQgI!8P!|h~g4A7=9tIwx$dAYnFZ8)71`BV4z_k)ta%kbz)$wqtg z(YXf_tw)lhfT$=K1Fg^-A_*tZ(J{yzqEhFi z$j1A|#ly)wHNgI~!wvX|LXW7^@KHonx;AkZYZbEMBWRTni6W_eP{o$q2?`mzL|vz8 zSa!hWJ0yWiOXbM_d(Fatf82l74nc0zT%3ex#-HeaSMitraYu9>O#ZrV41N3uI{g>b zQ5NwtleMx?O8L8Oe<>s2$Us$~c3`3ZP+wwk!B~xzMIu`Np^V`80f`iN2Q*HIzqi=m zVu=6j?}~7>X376oydMVnossd&=qCP$+Fcj|R5Ux8PyfGd5QHSk%_}ZW0S)Q-tAyYq z@^D4v$D?ZD%EOd0#SdqpF(^K-gj04?0bD%nbk0})<~lluo|c+*?q6kb^W$dco`se$ zWcI8-uIGyn1hjsvU(tJd%T;>Lt1e#cy3)rMw9qV^#zyTBlIH%;+UdrEDV)Mn0n8vk zwgjGlw_QAHN&lGC8-teat;uSR8!(+*+a_0%E95$EnE~V~;kBaTki7b>QU(s=1CS25 zbUk9XwzTv;>h$Tj_1z?lQ>Tb(*~+-F(U=kxaOP(z0Q0B|Th>I00IpO$ayUfGp~ql(yNp zO>1DQ`dC@c$5PLq@n7d{UsZpIPSd6cC0#y@Br>XfkUoT@E@k?Uqe-7E_dyIn?VT*4 zoZMJ`e*Wz2EWo1YI=zc8wj>~-pvtX$A~FH(4-b$TaL~}uuIQG`Gr~~!*E%Te++<}d zs1RUbd0h|P^V7@HNF}1@rlzvkZR4$!(w)VlaEq&RZU7VxP&G?CGIETaKn{S~J7_XG z@6H0deNmxZ$h75biDkLE?c?=&waQJygh#o2D0MDBsJ> zGopnmk}G%{wp9-lr&nJq!wvCJeN1=^Eqy|SRH8WZV!Le=rHnsp(OBv zMoi(j>H78crVLBB>nVg6?GmlY4Ik28{f8)XDPCdO_y6ejlG%b~W2s67gMA?%TbzD| zp$$#CoGht>L&BfTm7nE{UB#b;6$$Y8`@Zo3S>`fU9kJ6DGj8sW(~3-KA3oOM>U8a~~*^5qc%lwnF#L&b?4?F#_t3rG-Tzy=alA&8PL` zL(3f0D&y1eea@PWOE*P?vsxTfYNa;(#bYUupUTb5jF53~R=sE0x2;X5->=oRn%1tw zD(HXGZM(t^dNvdHkcB7OW@DS4RR!@ldIHr=#lgeIHS2*x{C>2vc~G4p_Ss*TWq%{J z>G7C_L!Wpnb00yAvvzpg3irEH ze8axnmYHIOB-)R#EM!wIT|VIDYUQOxMK`Z6pWEwwULG-ay~fA!085Nsm5xWVBH&y( z-C%qH+*y+vYE>H5hA{*kKt{~QQ0cci6desG5tFS5AkKS2a|?_8=_0sleT`>U{19K0-OjxF@qN!X2uM=Ez+Xg!`O`BpjJxUSKj%)?TV4Sa*z`wX65r?B zk9A*L+S=sOO_2JqS@Q1AUI25Y->1RIv{*_7y=`o~jG!Qhv!8WW8$IBcGM^lOR+g52 zERt@JPI?7$X9&2NfXE6YSvPV&Uv4vb0?0{>^fLNzzA}bgiN<_f$I#FafQ|=0XCUo5 zhKD67DTjdIo98_jYJ0jeFueiDd$UC{93@eN_IH;>PpM3#ll&&U&lcN2xTjI)%vUX4 z2k`Q+1ieYAk&Vqtop}tP_XH@7Wi*)pen8u3&$`_;ncU6D5!~g+uDl#(3wEL@V_Aif7e&}wS`%`^@EYUA19*M1z zA5;_-^{dt4w{_-3`|MzbGJt`(wj2J}xuSz~DXHE(SG6Thaj(5r=&2#irRGT%>1 zAI1l{ZX&QogNJF(+z3zkZ$qX6h)QHQ_|6%Zk?cXVcScPYa$`{F4z-}YE2?l-I?DEz zb5|u!*~(R>?Ib(+x7+~P413>{V7{(3JNh>G=rn004e3k`d~iAl)K%8$upnP8srNq6 z;b#2ko%MM5*Z!aX^^9(8_ZR(KUfyhRb<#RIISF1*tg4ERnb2-$^gQ3-zXtL+OD4SWB*B#9yvX9&-<- zOJNDsTU!aaCB=P!@@c=@jzWKVS63YCaa&-XWAuz*h3@@2jdg7nBLl)S+lqVmOSAJq zxjWQh8C0Ew+E1jBpo5N?8&~bxwZU3lxncqZmXp#oP_O;ET&;9+{-r7K*9&iyRnp|l znAh6@UMb0c(7$A&;Nkorkf1OEbG-QF`)b~9^Yd4!3T6JyrxWhEQkA#aQnd3?gHBH8 zT^$o)LUGA7X49<9WPtq_J8b6DY1K$cM95~YVnM*}W1dI(-dM8vCF;lU}#DIhsDRh^a9VIjH}XMx7j`*3AmUS3YB zdH}@GngYN=0r(`KUPKAmA2t9F1$m~@a#LF_!*vAZ`&(?tF!Qw^Wp)|tCu&b>xLoli zoB$8zJ(NkIUu$zS2l6XG79naK&WFN6Zl6?7USD6KfsNer_O`Cuw-0g;$n9WJDO&tU z#3>>15v}=zNuL?Pfe5%CX%%ycd^`c?eK0kc5ukiwbZmG5wldiQIyxDl!D>7uXX&m} zAbrro510mmrgpy@)5EunrqxMm2X>!#2NK`F^`V+=M&r}(qeEITKL7$GIBR=lH$Du^ zgP(Q`6Xn}EE1){cra1u~fqntbK&TkOr)j`6w_x5|HIt&>Ei*asiR0B~4`1luh{HeQ zcCFp%si=?|Mk{T$dd-{7X;7dpOWtrzpV5a{?y40twTI!On@`b5k}Z^-gcv16^{tgY z6F0@D$i5z3iBnqv7pz@SFZ_J!MaI73lcCYq?chD5o8kMGP$rOikMmh$rqrDb2I&`A zPlD#qKZu}nS<*#x)+ee3ozsSco`=9`~L+>b%(iAc)RW9-$nYqG9TwPf~R{c7Q z9^V`eEJvZ#&TBHy#HTESKKS%{tOfU%PD+#JFi}?o*M<~5P?3{6{gxN$ZFKetrFy|= za7qHZMQ7vNA2XXMQwU{P5^-Zey62oisk`pNI^)53r%2hJBK)p9?`poto+H7yZu@gYNS>~?9j&y?AOp@By;`Fpxr}-8GWd7z z0lnd35Cx2)4M@@T)g!&}bOCvC3cggo!SeHKaOhdUgy5TRJj$O!uWMqbx6$qIUBeO= zrfp`;gOjjucZNYs1GqWjzK$>g`T18rU-8-C9iqwvM~Bo9+0no{(~%I&(a}rTtS?`_ zcwCtYg!&5W1d{q2L;-%3ayN#bAErh4@69K&g=fabFuap!?kGd}%*SQhnL|C)YmIia8Y%$i zFX+1>pEyzhK%OWEggAwWwl=)WO@&xlu$FW(ng$95AhQF3IXjjC8>(>e3sbF(O0O@% z_)wKcKwur<{N2uTxk9Aa;n6K$cI%yCkN}m0iFfZp#>e-*J;qTY8?VtkFBnOt zdm4z?8_#)Dh|`ga2dqtDUt?KWMy?k0VeC)iRL4TScQ!Zuu`sE`yf)@5+s?s<1kfcZ zZqB>IMJ&fNxft|2O^l5ZJ|1)*Jx`ufX+*7pBBgRj zM`i3X`|((>L5MXcHYP)ke{K2J>Ha_vFyg=bMK2H;9W`2z`F)YAF z;GtP>zW}}h<2scO8weU&epCk}u7tW@FskU<33@Ag1R@<40E>dh&0*9<_!}2-z^RBN z#5b_Oq=E(Y79A90_tR6j;snEaTBAG0#m_7$If6+vO?*0hUc`wXsunSFmvY|GBz=bh z)vhSCXjVhrL0JxFn!1eHr?%0pu`IF9Uh9(sFO79_t z@77BHcEkc-SSlQk6rx4Y>XA`lGHnMeUKA#PiroX}y4|E>*;jWCLx(`rrbrM z!W{t$2Yh{o!%n9UNJ?}S=8{o0P>`dLLdnU#1lv+q3Cmu`A>l!qk9wkbY59PO z1*CQp2?!v%di2I}x^fle4>x+49xIAU--nL7(k{3D^AX;-d!QJc-}Qg{yILur!omDf&tw$R4zrH3{Z|v{B5)Y z)cOrSu&ev!l-z^8Vs{k3zU5`@74^j+At7vK;jPY2dz4@*7iFhG5}Z8s_E;u*xDhQ; z<_{ml7quL`4YH7!H`RL|eq^OM)Ieu-=e|9EdA(x6SYCI#D6xyhKQ=ZN$YdAEGg*he_?1%X6_KJ*(2P&y z&^%*M3mEj>KXnZm!PADNF&QKNN>|p?urNx4`s&G8SW64V1*mI7q~TnSR?AWkeH3QN zrx%^*_YgIf+GURcN04*|MzH3jA9}rnu@{G8VCxW^RVw2AK>A2YNP70A%N*NrLEZqz z6o~;Xbyni`*~$S}Uo~Jq05Y7hNo5AH;83^zYym|KUrzD(Jf9b9Nhho0lzQzz<2T7Z z^y1%<_;?`Aqi>2!e$BG-aX5zxiV4?pxbIfJxqP%Cra}-QtDPPkx8qIRd^(&deycGo zXme45Fe*CpFJ~DpOC8(lj{csGdnoL)hXp?ZX=p}5JN ztw5r!d8>e(EhSv_o%{5*07B41>0u$+P=1NyM(F>c>?^~nXuGxn0qJf;x|A*frMtU3 zMM6rE?vzHPRJuV@6lqC8kdP9j1yMSr<6Ay=`~Ld)!LbjN*?WeW>ssrqrEZbKSQ>B` z^+>CX;1PB6+spkuP7}NE&>O}gvZ%snBTpvI$w<(ptL}?72PcpgYWr_49FE^2yBRls zDdfTN@G?CA74DBeaHcaiWP%Ia7wv29mrrr2gw?Ceb6l6!w|U5T^^B%_J#PkleNX$! zWo=xg>0UT%u+TDid{wpZpc(Nod_^%k!^)bU>EBB(x8 zzy@exqoa0&rKNA8sr19*3GVEi*-l0iSPWe5SZ;_Gf
          yk1}drv6V+uiXbF{Iurs zSFYmdWUSK1VO|M;hCg9cpvb>YHv}ewDiSWA`_r#Q`rAR3+hK)%HDA*~vDfoLR6ilS zO8AUy7^gcspI!}s(m-C46HL9Q+Q?T3X5%wOoXqvmFr{w<2g+Om71{P7^4YD*chM-{ zhAQ&pww)s*Yg~r$wTdY%7@s&=h#9kDE&JLsEsi)W^pCBV_BkXnb z=x!JKVjy+e=@%Z?87h=9q`y?K& z-BNcm>V3#SeqB{sH4dBylulNksJZ<$H55Z7SA?ooyFAoQ)*D{;E!*?xTo>_)W~pCj zb`YmdH7HVCXnAo1)35Rk#v_#{Q(cMioZB>lDqo}h1~W!EqBdr#%HNMpiqE#ZO~+4* zwiEGcDQ()@7V#w^L><0(f{r7iL$&fJ=ok1ru<%YI0r_<@HeFCQbL*0dQ@d9#^~67x zzt3D$;Msg~I5*SiQP+)Sb$QVYT|K_LV6mV5wOmP6ZG*x>bu%!m+4|Jp_KIa2DpnQ#xn&5VcF(vk01CA7S3-;{O|SUsE3BJ`=L?#zf1XymCgz_s zdF2XDf7njhgNx(4@VVK)eKbMKy5b?NuB8>DIGbTVGVZaz{uz_IQ3hX^kQPCCb)HSE z^C##nn!u1NAaHIjI@21UR^f7X)T%Gxzxl<$t1#h>N2I2bD&KyOz+>~+(tJ^UpvR4>X=`<|8cMW)r6dpzFa0=C zUe3Z~D?2^gHvfdi7LX<2L^6dei+HAm%X-53nnp^S`1Q7?9evFDUaQj1*iu$a-R%lh zGW|Cud7ApdH7)~hC1%PnUIq+`a^K>2)GzZ~n(7*kj5l-9*Jrq%b(FGLR`&e)8#79= zw!VAemRe7W?zcp!F-x1%p?46+YmJqT?L@qwtaef2rdht7X&JoWtX+|`M0b64$bC@v zFHbo;U!x!+q2T@rU?1^-DdS0KeH`anAKx|sK4;Dj2?;*Wt^%#LdMLXczIbIaXW6-d zauknY$1}ZtLs7lFF#(X{MPaT1-^;WUEAAe3v+lvi{EH+ zmk3@a*)g@XzgyhOs>)^4pkgJ=K-Wt7B|`bg_sdb5`di~q_3&}VpZHvjY}&(HBYDrf8ijXB9cy?3W3 z2}$W8aa9g3EnmVp=a88QGZ?9Hzr=F+SM3B&UJ*A%CU2#3+zzZ)EI5;XvJ)?dqkkHe z!jyrohQ{`WH9DT2Kv_DBv9vHFYH+6QvDQf_%jm0DeEll1vnME5dz_hRbVesW3H0V% z?y4ZXW_`k=#h82}#b+^Fn9RN*fSpgLBl{0sW1E^Z&DboNt5X`Ph}xpm3X9_L9X7_k zUQX7FDE-S)sV-?_QBt*i9@o65Oz)B?9?vHxB;6zF?1>yPHqlnzx6q`+dCOPLuE} z3xa~qKg6)Vs^{Stg;(shz}>w^rvhVS(jBl>odc+04RlWC5O>J#D zj!*f!t%aQ9Dzu1>;VXep9gS5y;P|+K6pEbo=@nv(t(N8rIhSmtVvF!_>5GNe0^XZ@CqDz4*^B zY<~d4XYa!oMN_o@FgRx%K=_<-Jj$5(i-`E+*Z%(xFMo@dNvlw~BrGZXM#)C-$$#En z9I5qskoGffd;1?pT1XboVr#3zyubkK^r;6))Tq*M z&5ylLzU|z-pJ|rq4C)F6cXxNM!lbhaGaagHE0^bw9wlaRW=RS;&wedsscU2S&nd$7 z2@JGtP+y&EO$AHv^c!cUPln*P-??j<1aeVqb)y#F-sKOZUmpNMQ`#_L8`9?CXjTD#wdn){B6O|VPceGKuQ86*V z_dLJltN>!z%Oj}`C|4i;7}e67u=`x2p|3w#>8HmtHTEvt>+(WmQ(l&mtOqo(30R2i z>@PvQ_9;dI6+ik9VBX&p>HD5P)hFZfiCbJ;$Y>xweUDAShl7qj4#HclLgQN7mv=E&!_{WkP??FoU?(#y0;7;7>Q`e={8!!a7iD@Dj@0Y4l}y2&t}fPIq(v}h`T5SaQ-EhK zw4x&OJyD;6jzRO(JxI&|uhY!TOd&`*E9tB=1K1ED8H4N3fwl3M3K}Xm{78|Y+3Ps8zD7lw`$ov!);B_Qpnta=WuHpe zlJwtyNb>ZyLjfzzuEqC>At3lGHEYd@ieg>t`Fb{u>)hRq#IX}g1aa}T8?$fCX1Tu-Y_U=u#Ya$|k(%B2AMcZ9eVi%Qs zT>9+~^m{ZC-}0o^7*#Sh#JwX($}hL?_Z=%MJp z$uAj%?C*sHzL+nq0r5XbpVwIT1`paVT;2UZIFItDv?K7jIK@Qw`)5amHE#}|VN;HO z%oOqKiF^6VqJ{OxsDLPNuD6_OiV zgY|Uq?F0oqzMdtjvrhId1lgYu$wd`HkVSv;+B{~LM1*EGieF>9V|}L4 z;c#;U5_OhV>*Yr{b;|`sW4$+~h|f&wT}W<=N7B7=bas9Ob|1MOl#GmYKnmA3FOaBY zq@{D^k`>w2X@bl$5i-vZuQ-B>iRq1Xl@4lBl}i;9cIKejbtKM&Kku-w$VW(Osv&L- z_@0L!uR78Cv(eEZamD~NiEjzIVG{Tzgjz(-=Jgi;?8K9l44Io7Nf?6?MB~DEv6g znU6E}f7fU}8n$p>e0<_0S_Hkviw;G*^wrn89%+CZZFk3N6^xhP`VCleKUi83Ka9ZH zpe7=UJOg6lSw_advu}8FQ{Pgm6>hmn*MjAOHZKfxu3cr|Txz94bo3p`mFduZnQ?S{ zeC|Oyi1`EKS=ZDJ+W#pujGaHJEcWrH4JUn!4Y|14Z=w1e)uaKh?F+L-dTC6dtkd7>HCizxAW1GCC%O2m{Q>}Z7X`9Q9k*2 zUUU05)eE&e&6uq+$WeD((;#>f3rAgzDM%vy)`l6hi#8Hz!lnBxz!>&2WYJaVef70diw`dbc zcx8!WQ&Ps^FS7fMGnBIiMA0}E1ilQ?dU}JOy_SGZ00|2z*{YcRC>O)lm$wFm%3i>n zLg>Kp>FF)UNn{<R4o*!FvL6ku$8a81N} z669SiSK|?BqD(3H?2^R-f?&ZPEt{y4i=Tyc^@dps(v-v!FnfU%EmxhLx6JMBA2<8q zpXvVLyS@LVzR(-}|9E>1(DH4f0#^FdtDP#2LJ&igUT|A^1R;e%$GiIV71o^1v)hmG zc`VB8?CrtF48*Zvljpl4>k>w#6|;s13ze;<<0V?SyC4gID}ZK%qGR46Eho3|f%cas zybG>7@Q&Z$;X14R5@xIqf=mO)lA5*?4HPnW?_oy0qyS6L-uqQ64 z`A>0n+by~T66asZLEFrz4=&C=7buaYKO+@%F^6cK(*$z7d2kkz>p~XRW3^hR>DMSL zSCIu}UBFAV1~ntd@W9RW6KpPFA|b7XDn@Nd5+$)Jw{oI5b>Nyb*bOg&e(Z3^D_Ys} zq07Nx05t_gVcwGj>A15r;jxc{gNNYB;oxXoC^o3IeOg_;6Gt_TLw#}8UP3~`s#`f> zO-q#)@n`_d9#BD$GlyABD}z zxt59B9^9-%al zkMGrfRvnDbn zNk0-g@`v;Df|LVnl0uM~liCMQmlAdCv2*R?6$|5q zCd;lQs1SV5$O!Q8fPvR$HOqlb`@a|U8$-6OrDc*S{lv(~`1m*m4$ege>TqOc=Jk}_ zoBX+Xc_Cc97SG$Pu9#up;Z+na?H$fz4vmNq>JBh1RHI)1@Fm-M?z-__DaK==e-~N| z+l2V?5!pQ7?ZHO6&CK|TDH|o=Qko)>lAX);Yp=EN?zRg!U96to7|YHpDM5F}bxN~# zsgC^5r}M`^`u;t(H;pu=`RWbr;{1{l|8E~RlG%!S)AZhH{G);VU*Ro}?C-}b+o1is zW3?4EXy0J*(xGZz=RdtH0{R)zukMuSO;pIg9E!hgjU#2~a_^EP|L01<+Kd4*NdL#v zof3cRZ2vf-FXTO}@M0?d=K_c$iJ|;*ly*5S()_l_ixNV&oQ}fy`)wEul|j~`fNR2U z2g*YKl^fxwS|D!!rQQIbbaQiYj0e2AiokJ$u*axO*94-oZoMG|TP3+`@-@Q$cBtYb z$fL^2%1In5`PSfIgBUb}Mh_i28*!y-&1)bSKZFZL!vq0%m_dLqo$TQm+5X zOL+u>_PMRt*p;xUgr|mvXqcD|K)-Wv-~rKrs;Umn&CRfA=a-c&E$w+M_t|jKiszX$ z;($g89wm42K(XDQKYxOGX%zS|u(mu}8`qdOd~^Rp>*e*S7C(nvcCZSL&Cb3X9pw`c z*o5txOLb-NQ9Tsv;IS=KeW6ihj?cHad0{z{zvHGBos&b$MvkTSz!lu9ay>E-Nhr-T z{J6@+dw=yDQcf_VHPtKBb4F6wDRHjfLGat3EE)_9y5bZZB369BQt5edW+2xSmMi!B z_B|3Ne!{jBflWw7#qXTi5p>0eosDh!)xC&!kTTGYAn1D(Si7f4pXWF}F7O`489WAu z_rbQyGv2!^;JSNE$_Zf;`p>Uu$tfurHROX(Bl1kzC{xHiv%0z$+=~BXImqJwn3^8E zp`N`Rj{R|MqLM>BdnlQeHy@Su==Ag|Dk_Mb{dd29ui}Hd<>QOn8=IRc+Ffi0HEm52 zau7lhA%T*IStlI=APMyDvdV_JB7HYEKi6uBqW1lE^O>p9_%(402+VL12`bDs?F4HT zz`kQ?4P7R94p85^EYLxcMYy?*&Mh9E5g@g`!pCX1%F9W7&RQ_#)^yLJ$*M;HAB%*D zh|jhkd6>#u=;4pffoHc8*i66VDn2cxGZO}LfL&W)&gH4uJwY!=#}g616YD;r>9n*o z>l;&3abbudBym)?M<5Z8Ol*5Q?HTE0YXB#YmZrv!7yok5{CXJ08}I-tC^T!8sIwmn zk_gu4;peXtyJ*W=+}_(G1PAOR-wSFXx35P>+|t&I>swo?ymvWROKuduett8R`&V8V zrpf0$uy(ohmc!=Rl7)4gbm5n!=s%j z;8Wp7FV@F_0c=}YXd2JYd>1|k8qxFZ)9>fyS(&3)3=8@4%VUtL4hDEZ*39G-_7r1>qi`1wf3jl8v1kZ!EYy8VdB3cjvrT5q)X-nfC!tW49K4#FXH15efa(}F0KYe{N-6-+yA6`^cGxuk_ zBW-RdVBepp*xjH;~>+PwzCF!igDT9A+ zg`gMd?k>#boD}#w|H1ck+-G%2L&(i~Yk0}|9s`&&@l>HwTZi(;Dp5I_#-(g%V8Vbrn`zLZQNrVk!b$Tie%7X=fR1$zTCSlLGDj|$_{k8pA4fM-{ z=})R2f<66~dAd05@Z*|y%&&sp&3p6n@qrJAxkgi8gW}3xGP+-)`Cq#EO6G(ggJw)) zj0fb9q}j1zqQDw?24=DL&q%kwLcS&P)0YOdam@1tEAG{c+A z8y(e#tl5L59(1!;%3crcVgDl&Mg8~sBgPs;ZQgyBpYPvn@hRr`=O%0Aze)svAA0?~ zcW+5-ubJ2usRmGsc%ugBhwrbMQ2qPA!8SfpqeWg~ql^S5@prc4I5?j`tRF)xN5LW-sh&8K>;#F3j~4%_O2luV+nJ|+)z;1NmSq?M)M}C)O#1=gIu_mZ+L*HO z6=DW-XsNpnc2X9dQa;gP_x)A;N4I1$gjfL-;|n*nK~ zj+8}D1Oj$TrhoS5GbCid_%XjocQKY5zr7Ym>Z?Iy^kzZLcnm~~G}>jlwZ6w#+?6EqOZmZ0bt^aovOoHJrr;gG(^H6+r^eLZWSaxAyA&68<(!XojQe0w| z%>(eM_;dmLXsxm|tu7)g%;E>z`Zb6YQ-{m%^e$K?j{5SA?#n4ls*mB=)2|_D?DPN| zD2U9=%3pCnxFe$_9@~51i)kMkLaReUI-|N)=;h@#HKhtUpq=1Q0xNDQ1V_a`|Cr8u zrOYoMu`Njbm7Obf)*JN{o@L3tt86E~bmVW{mZ9Qc5&yIIA2}}jo{AoB%|(nPfx2*e zdmE&`^rQBd7kQs+dM_y5R)^5b?+<3a&=ix04eLv1C((eD(?(x1>rI`7&D*zco3*Ti zi2NrAEce$Y+{eq0^;u<`To!y`#o`*|F!7fjBxF{-Y1TqVKoe89KFeNvw*48fN05CYN*6x8R#;w}T86OVQCOm^Cw4NOs zP;yT-d36-2=ufn_Yn}yR1XY-$l%@H0@S`SA-tZ`>H zJqq#{2|S!~1%P8^-#%c3CSps>6Vj^GZS&g$m|wl9A}h1(>Vw7Nt?QC=IgS)G%-;bI z+Sze_SzaE2MScOvs#R57>mROSkp*jnV^an(wuNo|7`uszD#T65a$T?T?)Uyk)F3*dRbhlgR5U^Pg{jVzm5FkYhnlRLqFcLZ)oZXW&er3t4=LydG)67F?m z$-K7q1?)%#sW%c4>J{1Mcl^)rZegy;d`k%W7_&Ag#)*vlMJJ8y>_puS+!{mT?mNZV z$a@kbk4W|_O!h)5g3--;11|lj9%Ij6;pxPi)q3kTM#`B9k-t=rIf!ig$XcDH0$jJxMg97^ z3K04Du$Y~3ByoY)G^{d5_xPG8i``}MX^XPp{JffQw#DxgyzP+wdTY)Dh@T+6uK~g? z8Dj_)&m3ZbRq^U*!trvd*ROS5-t+291X;?-yzDXH6Uu;Ud;R(t;tclZgZevZv%)m! zoNTu)HBG5v2#P!1vU#HD5kuLSY%LPyUX)FKdCPMJlf#Zko2UVtcp~g znUrWg1td;dM&`%b+T7bE&deu}STpsRIPgxt%E1B75R0#`F0D~jwp0+(fn9LG(fh@( zuvIkDgYw3IRbD_q0OE*>O&YH&0znsJ7KUk0yW$QR9H7Xd^(b?irXGBLtdax`I`KZC zb-?*gH2;PBsV79l2Cp6K5~@Mij`ZX$NZ~SF>_pQ7ix)Zn*=CD%tO8LR#W^eQO={qO zdZT83v_0&3j@!!QD6*4D*!AAGyh|%8KR6DJeM=Q-<8wW5%h_h&x<6J zk$p|*lR=Uacd!REr_$69pCVuVRD)2~$T4-<2hSVdw?dtaiYj_;QvY)zs%6GdN%lsY zCN2N)*g2O|iMqR_*F$xNKpbH#3Q=z&{0R)8%JS zrtuvGi=pUzQD4iI@eYsqEy|)Ru~QDBW%%N~w*g{!k5rN?4VJ)7lr9-|E$4GCo^B1` zcS?gX4Xy^Ne~BfwU*H{8p=+7Cz}LHA6j#$9m93jel``^yFH9~%L#2IueAdN)Kzw7_ zWr>yzK@~`oR~A+oq!l4@ss8Su=;Xwr6#49|5)IQF`lqbaHo%qVWyXutF5!lxnMXv$ z3!Ps&f8^_H494IEYR|>c^%sXl#*?Pb=Xi^pYv@vBA2+9)e(Y?8xGnid&H*A^P z{Vpd#zAXSZDk0%lkO6IwQFy>d^*b){p@Ds7Palyq6fm&eV}io^bK{}eC3g_keUaqc z8#<*XExy0T4QM)BSX8?d~wf^m*O!a7Cn@*()DPs zkK}2dBWQ4g@bz+kA^*`2O+BD|n!tXdO6f3K%xe7fS9mk5RvM?XyeujQFh0f3G)J-k zgBXvKHaa5FyAhtj7c?hLCXI2CR1v8e#om`U*ChB9*4EC=@bU2>dpTsP@ES3_bUy9u zn<0%`7RS{L7MI7+d)&#^=Mm#HikQ zh+^;!B#5x-kiz}e#BSDtW|>REL}905Yr8U%{FN~GR*AI#N=ewr*G~j41R>RY+}t_F zZ!s8^gcnHUovvd42niUjimh*GSSSvsy8U{dmEinCEZxK6T89abE}gd( z#Eu3O!RUVhz(HHj136lJiwNGuQME#6Nk;o#kPU6tl3DG#98zNzI$<}|uY?l)BcxnR zs?UGSt541}WA?cwtIxG;t`2orX@lTsfiRd)wJ$hAp(oBs8>h3qQbs(KLq6}>!M3EZ zcL!04^ao_q=8jnPP&K>zbkr0%H0b=OlwTr8w`N(i{SL|x2*>a6om9W-&(n-*SIoIo z3c7}2fIV}tcB@{SwMfLr<7}r#=&bDCr$P~BJV7Kxm3c457jJTMBH~NiT~W{!gJ!db z`oM*$Gj+Rk!6106Sd!V$Rxa+$48RxxC&Q~cR~rcF;H$Lsc zdse}7$HZXwlhUiKs+H=YcttAImqfay31dSWKiB*PKQ{picyxt(Rq~m@OVZselL!g; zyp_`5Fj@r#41K6jop{STve~cU!;Bzg8`OY=Fyco5JdgOA&llj(5C8Mfh|?vsP+S>C z!L;qrn(O=;@*`NPf4=tXQf;X!73p*E%8D)BXUtcI0BQ82lZz;;&k)ochCqzGczR+= zBv)Y5)Z^T;e7twpXTLsH&|iAoVngu7V)K*PTVfAY{}Lj|&#&PR<#)?-oO-Us(4>E^ zC6)ik%*{P~yf?k{go;H%xfQKhoFY{pGebT)xTr;&gP2DGi6J`)p{WUPCBNoI8A*6( z=zLXOd4q68^j{>(d@D`1fPid=xh57?+~f8#%MB`9zWv@(PPKXWu5RDsba&~$?!aH@ z6WoMM4$2L7opL85#CdUG^&uCRwct3`l{Qal<^FN6zl^NTG1O(7yyJ94T$kBMQ*g+$l1 zY^9&=OtL~aXDgQ)PX?Tyl;yf#oHIN7Y2U>7J5$T|4YFPA@qK4MS(5vAQv=!pX`zlU zc8uAz`Jnrh?R&oZ&8Oc!+y#ueA%oxHCK~V!!EU}PIyrZ&KD#b88JqZ6mpc{O+1S|$ zx-LGzD>JM+VOI6*O?pavL%UC(S>U*TB@V*LOn06O)jVZ+ek)aBN=u{CaAD=AqOW6? z&Ex5_$t~5x z@juG(0HL|IDuaaqjm zFW;3_7CYNE2(|mU*G_oObXKZ@o2A4QALcrsh%%t;R=fsFQ*uE;SBX{+fGwlFzA3vF z9kLS9DGgBBE1Vus<+J@$17sy4yyz39?`NCUIavQ3O_b;qur}db?>v`@Rems5mf(Nx z{Wv@&#mjA3QOnc+@|^F&I=h4IlXRwRLv&5u0QL3jukX+Nc)<7+1q*xUyW!^o;{rbg z)ey&VFO`k*e#=FIb*F)0E;c%j8%!-m)4OAR)AXnFu19D5-|}&a;vIdDvx;CZWH(W? z9;|5nHaXC7cQbM-gBVkwRHr;pg~RV0w^G~9dV+c+FI-FG=KHfv%2yVZ)C4*oh*yUz za=)D|UEdTF{5nWQKyur4A?lVZI*QZ4M!A~=O>3+Wku5{8RNm4eVPXOYZ>=$mKbd{& z-l)9`k*bc4SlF@oAKBUWR(k1;P&og3AcF=~#a~iR9ah$ztbhwh>kA^I z^k6#J?|&88%gxhEv)$0IL^Czdtn+`cSD0PIQ7N6c8~JpBp_LNYdDWE1I)?h`>Q)#1PqLf(4nUb zxhuN4?MC8TEexU_`yQ8DS>+vWO#AGw(xSbw8!q)bjoT(tR91#g_dU$=%138mNM_{j zfb7|MqY5bM<)lNwW|aLW{g?g;!JzzOXQwqJO#?aaJXWewX*wev!DR#KsE(i#bLsIu z-VMvM!he7DYAa+=JsQmP!@|M>?iw=x;tAeEpi!&s0CmmXTWGie;1SseBzv@SuGr_% zVe4fJ6eKcic$dgPDq^iYz7xxCBoK35?2m)F@W+e9PL;oglieVuqhV@ z@P{`yU67KHgts?5TmxEStg{oSN?QnXhBO8Ok;u6kMkmxqm9!&Ta(t4DoyUPHtrrh( zb1|^8E=MThc<2`H?&^9egWJa5(sBFECFa_l!WV`qBJSTs`4S#~^f+(S^&uzlTit)L zTi{5AkzZ1`ggWZ}>W!e+MW&AF6I3xGbl+><3qR=Hd8M=nuh>bScsG3W4f&z_=)q<6 zNR3K>D&?4d41cjvM)XXnQ_Hu?JIPE{79AeNx4^0apfW`!clrLetRg`{A|%t*F~9@5 znn?~(290`?J_6j(=yS+%{}VXoATd7m`E!^aQV4l&!onoPxW@pm487eY;LtWtR)Oo?<; zm+dnI^tU^PM#q(uMAg;tKUe{ZuDh%2;g7Ev7J^l@_;`3+0T=6mfsH_G2fHzPZE zY68RZ{1jb7iaG7mKAdI-PY{`BQ=)|89900 z#^%g)_JqXSA9Dd*Y}z2!Lt-q4jXREOL2GJevVEA*d=JRB z*jx5=vy5u@coaj=ksr%>etpJW8^12%zc<)=9kaLnAVuaH8*bLYT+?OcvBSq!zh{$G zw%jEho%vr8O;5)+8+O-iwEZ2@@of_(E($0)>9|4K&7B@Sab00ozCWFpm||(**(FWT z`qy6Gs^=gCt1#WbzBv#>?ykYIiMg2kRCS?T{SYHG8L1Q|pUhz*@U!6OBrJtA z4o*&29K!J+YG%Y++(I~%8#dB!^eTU$`IjM>Klg&e8GpNFjvA*eMUQhTY0iNT1> zMw4$)n}QG)8m)AtX`NJ;o;qvn`t`hQil}hVgrg$X3rReQaI3eCeRBt!kdQYLhD5;- zk`Vy$r3t^2rj#8W36>jXpDsig##4(KHtLeteEs&wrX$=*kkbOZg6|cTo=mkLd2N{@ z)S#8(hbD^po#b=9Zqv80v58I!$F`W0H>kE`9RV-~Qjal~l-1QUL`cH8-bzb%N#)7Q zE6XA=em8xz+1fCFh-az6?Yx8e=9RCP^1Qjn@rhPgG0V3_7}D)66QO8ht!wsPKP@0~ zCaW5R+%;@5KUBWl*3vQ%dj6R%&&ECSah#SA`5k7@Ied}>3Urs+H;)oB^^aDdGh&Kb zsW+GH$P1PZ!yw+d?RUa3Ii6jQL&1l2S%P?6Rkcmdy8^ioWK1^8%ot=#i?i7|_56>v zPON}dsZ127H9WsKCD*S?1n}K@tn}Urn{|O};)={)^>H>MVx4`==*3LqBTv7{e1+PP z0wtv|x}ZxV&@($O_dRq`#K*aTfkaW`Ss8VBvN3%bnr2m>`>qo8vi6bN4Vdw;1(yeI z3mj4$z8?P%9~`cE5V))a)y7V`!k|!uIKB|npO9M2{F(-2u%Y?UN>X|gn}vn8p3KcQ zAG)=QRLw(>q=JU(S3a5`Q@;h3qa*<(zGHoJQ@2Cf^)ezfv^}Lyh3t4SnKx5~*2&Z@ z^YZ8yRvA6I6IvhMRAH{Jt<^H97%Fljq4aaKFQD>JS2qXsWK4|pJJcc5&^sO*@-#?@ zYF(k|PjYm5xH~g0~9PC!sn_5HQ8j$9VihzuMIh-ATDcDk0-E3SmlEosG()*E4lF`w%xxbgAgRQvBUY~pl8-w-_V)KqfcrK=BB2)qwPSF*Z0Y3QlgaD_OR%D-5-&GEX!^hWecQ+ zH$6Nx=dtOqt0q#3$il*5zYKjeRI2jZ(Rcj#Nqr;2_YW^XZh^_R#uDp!XVQevM}YowVgLtea^KUm7_3R zi=D-L;XGaz*!P?=S%$CS_{&GSLdLHf1V3TV)I9#HX&3iFvL7RJd;o&kSQQ4-p%hL| z_iFV+G4rD#QU#GV3?6mz@$%0!;SmHQ)mD^YCE{%ZFK-FMjLB{$2t+&eq-D3hBhn+O zCqdEtPNZXS>&6J9qF_{HG$C`G$M+E`3}OMV$*}b~PWSmljx;o`Ywf7&NQdzSN_y>r zpg>-^F7jpJB9z9liM|I?RGt8lZH2R{V*f$90oj}ZQHlkt_0nG#jlMYB_ZY)GP9*?1 z|KQ;3O@5SDH#A1u*|KYl{j-OL@a))JN*X+OnzV8F(Vav@nAuJ5P}{TnriX6G5G1IH zOURHkYRcnK3TU<{(!PxS3IqvWNtg@g5zg|Ub37W!Fi2W!ZXLR$OxHQw&TJb!T*c5u z2pb-$nW(%(x#U=7Pvtz7T$cI<%#$8_X&${=-rd0#z_K%V?@|QcHIJ>XN-$s^HK9R$ zS_8Zz1yP|JPNs|<#b4Ux!_&rop>s$RWX zpPn#TW-$1BxL7tetoT?IOV8=nJLb=JVL}9emF=pzHF9LamX;%TM5>hVI7}0y4GVnj zvxIkcT(^nLc0@mtB}qo$hf{SDo4bcgrm1gZmVJQyB$$_sTEx`!Om3mYuW|Wyk0>Rj zpdDu}9uffI@p#H2f|h6lTXVQEv9Tb05jLHsmo*NhdwQ&E7=&)3h#J&vR zk@GVV=1DL%BIcS9iO%JjJ5}}f#g?+0sotPOenTCw4y+jE99Pg@8cW0#-1fX-N;bD4 zH5Z~ZG~J+<(DHg|jL#6@2ZNgQq?hLHSV!9tj!cL&wBaGI_C{u6%wna4J+FRM)GhMSshBxlFGz(4a)C=)UKD z?s3?dx^8-97>iO1UQ{zZS1vDSFb%ACVzag zGO)H&jOom%Alo9;U*u9!s-8p8uL7H({L3WWM5aha7&%_#wI`r%tN!5h;H6ZA=tu7; z`Y!+LhL17x6E1vMM6}G?nYIRs9UZ9t+teD%?d=M*k8z z?S$A^KVGkze&d4{&B(KxH%n)4sWtw*k;TF%>SB&-JlY+f6|R`J5*uT6ZPT zy-p8I6cq_n+hy2u8!(AnRw1H8fRT&*;o89yNy6vi^XtYGu0*ihbVP3~bo7|tjhV=W znou|445xPYs*A;Op-9s8as}v18!BrzG%s)=_)Htq=2Q=E$AyS0d z(syEPi#Nj)gQ(3i*7({Xx6967jBp8;{n;hV-)7G4rO3mHO-!@^y~cJoX@*oRg_!we zgLN;`!**(;xS8w9j4)rv|74$48^@QJvU*~3ljqhsp!43|s-2m{5o0$VfXeG$6I%pN zt>3Bb-ETFUn|`3;+Fh&k!CQ^r639kxVYGg*kAOhqs30w&T@m?cjBA7D=Ts;^G6I{RoS!40BBO?zl6i zqLZYN-nJJrm{eS@$&pOG7`rZi#p%&D*>avox1l|g;5`+uq^vg#9HNK;+6Uwm6&t%U zd!eEEr}3|JzGmymmxlEX*Rg6JOD~wdpOdRkSxE8@DXlEuP^we@8+o=Zy`L$y<0s}@8^+cSaFv@0U7?5z@=w^ zZ0#t_BPu)EMlqhv=@%y}5{sTs2XR)rN2n(PeozQ~)%wN;r|FrLzhI#P0&-O?HCHxs z(a0XvGh2oNk4W)_jZcGNVyNU@pCPTx0Md-CC!5a8)}+ z2jA7?Z)y`>%rOPU=v%e)D_XaZ?(9(CCJ}vmUai9Nn;SpjE!wJ0#do*Y|Nhngz2*-e z{0)p3XQCJ9XL>TjrTSluy?mfOR@NU{(!ak4Da!`hD>F4(JpV0S8DWe}^vZ8%CSjwHg9`5>kEVQ=O5!T;-yFXr7^B{d59e4wq zG%!DdSz>C6if7-lTB${SX&B0MUuHgk{s5?#5{urX0!PPn)htmMOe5?vUj+mhcz?Tk zdX7&_u`n^8bf*0&mHp@R1|@&tq_6I|V43Y=M+9f;}**XA_0JHfkp$o*lz9~^Pguk6K0Uq+G@KZ)+W{{QEgG?1# zVcctzcO4uKKdG7205DZub3l-U)#z$fKp)nx`<}8umw= zRtQE*!T6-o_QLV|h#8G;vv=%+u>Z@HOcAQDX*11*fu<6$@Q#iS8L%ne16Mx-A|)jy zD|;4;aXncLry1%8Ql8(&l8GZ_$-@Q7D=N~1z~%ZB1AYBuPBZ)t5KO9J+1}6mFz_;- zuPQTh6CQyAN06<8g88vvdJ^M{#ib?uRZbml;FbPM-DLejqC+Yy9s-UpBgcFUk*>Er z9HF^q?*^Rb`}RUeesxdWPwB|kWOl7W$3(g=yybwkaqP~+4oa0$%fHFzzXq|1z6dnr zNA*a9$e)v=@{>t!i0<*(GHvU5o$IShhd|m1GXo^H!fu=zjE_}WSg~~9{dktLFnjG9 z23WWd?goR`Z)bN|>HC3|tu2VLm1t3|@+!Bo1j{*RbZ?-zeSII40|CK1M>~0Q{Q z?fdN0a(Rm%61a1piTDI1CUO&ntLa&p6Fk3tmC_j@K`BMV}LqhUw$p`9KS*d@3DVqDiD%!RD3jk8>bg6Ho{Ug~6QkJASf718L zOx~^Li>$(_ZF0XP^7H44oTlrs>^_#3?RO1e1VdvEdT3blMe^*IFWw8MF9D@J-|5kX zPN$36*n)GUumdj4YrA2PC9PC-1C`JMz~j`bBx^kLgAbe^G&Pgp`kgJsvx7YB;OzJl zsN2aYDV2E4*jypkE{@8mgXl^JSo-KeNO{~9z9RmwtN0ncxUTzbU(4ue2sZhMS&r|) z`uAL9$~v@@$dw{i`c?{VRJvq=dVHEay0K2o+oN%^&j}uLDpwhBthVd?` zryRcz<3Qn$W(95x?51#Yyg*^k-hPZ8d%7E(>C*Jx9fF{f&MQYTOCXx3A+#w2S|g@A zu%ryrIAXR<{^lPx2uz~G+VjDsus>S`u-xy5?o~o55g9 zOAb_bvE;tCJguOR?Ko;J&hz6Ew?_8`mh;jx2Yc6vkF0WHUq9B;CR=j7M@!hVeH@5b zjFRm`>jYpzNoDH2T>LDG)?M(!D$q<6B;SID>N=;khn=blvGyYZ=}R)r zO2HYYrD1(z03~}dF%$?PO*J+2m~oZk+G=hON#JqvCD*(_27e;@e9bKFZN2a6xw)42hq%3R!5lyE_Tm8{6ilP4lI_-nzVM@HA)cU&y1rqV4(p`neiE6Gjcx(Aw z)E{-vy1-`Im$MgNFHgm z+jL;9k@r=FUE``z?>uCM*wJj}8`nITjPi+vXX;4)k09N^0jfF1W5<@;9;N$F&;*al z=^54`5kR()^OQl4yP8fd-&MHky7OK;d@2e*llipz zGtK0(Oo<@pP1{&+$7xQUR zub7KvJGj!7R-!p$6BEBuwB&$<(vbkR)ivRz$q+|ODDP@WvS_-Xg$x~nYJG0SPa%nz z?I&s{E3-ka)_Z5Ov@0`3P~^$pF5%RicrUl2Uvjc5)d9xYMB+Y-+(L$an@nXtNkNfy zftyLyU$$$;A``#r)O=jIpitWC$pOTN3VSkx(8y6Q>TN~E`zTqE*=znnONrb<# z!$Z*{GH!k>yKhS3SF4E z^AD&C_l0KN9Glv0HE!9>&CS|Gr3_-e9bk}$YT-K1LILv~ypR>SyFb1p2Pq(6qdqZ_ z2#ddZkk@tH`7^oyi$DF<_hsIzLz{M%zX2pr;Q%9{nwHU2L7kne$0ED;#33Q_?`z2aXXCZ}XymybW3dfLDS@6-+)tsH+?ejP(pH_2 zrJ>zu8!YVr0rJ$;6dvyPtOayX6P!*Fh|3uld>4j~<-llwaB>P$gcMt58K0V)Z{2gi zGw`X-Q=%e;l+h=el!W9x5QG$v5ef@SW{QJ-+rM|K+^K)KF))(8E11g4j@|jqj&1)M zSDpkJxwNOd(_ogKp&^ev7E}VcWe%I+;j6HJOGuzmO-)T5Z&(y0cGGQwjTjRX(|C9A zgBI{c3_Md^``@_>Uw0oZHl6U;*}OV=mTUYR0Kuw6DDQ1+YinA^l@KY=FDIZlb;`!Z z=4>!xL0D82?(y*9goE|=zh8ra7y!r03cr5O^uvRt#--N_P6pW!gu^2Gf)8Er1bw^{ zs4|UFzS&hy=S>?H05r+oyVn4$On#j8WVLcrks@RF0y~D(!_R^8*Ol2=D%!p6{-amD ztQ+J0dV?By_XS;WgeAnqr9BVZ;i930Egd-QfgGpepA&M;^QR`jLDLQ~Y=*$V$Cj=Q-J6U*0n-=X@*Y9LfAH z_g`bYr@FaKQah0u2+x?k5h1lw`nAIsF-{3H`S_bpdw~wUc`vVVL}@PO8|YRt#7@>4 zrp_Ctp84QY+@1cM#;meY6 ztyo9*T#jdRX(;Ta5PgH%%D@@$=r(=`kRS$tuL)GzyEreaw}ao?1X*-Q3qwI@cUIvHGt9xnd)dnULn zRWaBl$#1*o*#|OjcXji8vfA@jO?!o2l7T6 zxtU`Jv>F0wcu61l(HYeGB^>^!t%>(VhOJIr*0DWKIe5o=lJC~>@=D{N>-4_aq~JXi zDS6FQ|H5m!>ht`OhM$ew*Yy^<^oqCKYMf02zt=0Ke-yMq3ADx_W~IDMHhl9>NQ-vl zUE{Y%>8hA@xj3#;*Nu&iTs86koEuhmzIdLKYmutwMVS@NVF{!)7cTNlx26|gc~7Mi zee&m_3SIYXiq88}iKEIz*DU1&tc)i3lD+5!=2+PR@OpImb0A#9~=2kBmwz+SvCS|g;SEH|m%lL7+7eRbB0XJM??p)=;Px%re{ad$^Y zzT4DS5Ck1RaUuafEnQ=_-(ms+2SKKT@@V&KeZZ-s_fB=#HO{SZPqgwfcIGC=H9g+K@6vtm^`luQC^1ftxwB0A(_92q<@}GxKf4W8W7g`wGXICzI zV_LdOmPa%i*x1-0mx_s+I@h@tN_p=6JTncEvJ3d&e#hvGdOaI5iSL8S{Wc#PR*y=B9+URZdJ%oWF@dpQCi4z+C!W zmKK);kzB_;Dnohm_AVJL1;%*8DeLk$gFP1&{#YTuK|9Ae^LFvXo>v|ciW}P^4bn<6 zspmN@d~+g*(o!CET5T-0H|C<1PF*-qaYoD0ux9d#6MT&T!|qg6RR0-|HB+T73cX$Qyg+8b{DT$ z7XgoRQ~!HIRko=vHY@J{gaUJoplJ;eF+863qqtStvs4L>e%e@NfUL!k$L!d!Z~0fT z`=ADdiMU6m5?K#&HKBXWp-}aE6Y!b{DhQ`J)O#b}Z>j&@+r~z_#vH~7>lc(jgw<9I3clkv5ocRq~H^aEZ5$D}pv zyTkA8gpxWyV3k?E_M}>D-gup-)r`6kvVDCi)o;rN2a^U$lk1DvZoxGmTxY%vWr8j< zUrbyalqD_TQ9ui2U25wrzyLl2mhD(WbMFf>h6J9g#NQF%)R9+^Me#xLIvDVa%Qi6cL`>?Z_F$;IR3op0(xYS`wT=C6ckie_CgW` zoD+T<-_z~i*n+VZ2@9iWVPRn?;ZC6I9vA>C`1Q%=T96^zy?stEOK z3Nn9P&eIbosF85_lEPWJq97kc5|?XMU!_2R2f?0X`*6+jjjZz+ z51p{3F4_pUB=+_hL6i) zU)`_FB;+TSh618wz+~r?>lGOa=L=_KSnb#EjszeqEerO|x+|z= zK~0)ft3;?;8-3!J!B5PJrzMxOPe98DY1-N4N8kDJC1j4p*$np80|>?1`wy2tRGu$8 zqe6atGxE`X8U_PJ30H0H&%ia4@x~y~6Y7cw7r(9d@{@eUN_A?g3wP++%bFSqHrAcq zBZ}5fF5G!2%Xaqc%3yXFPXMQSoCfOdx}%p{fd%9Zbj26SZNjmqLwz6;|BZE6G~ji3 z>~32KWi*}YZoknzfo2AmXhmy=t?*X%8`d2z`E zh)zp$;+@lpEx+NXAlD6YC*kX}eV;(mXeReL29fMa*fRLqpfZxX}K60gBkeR z$Vp}kq2>ws)1(+mdn9i_Wp+Op=kyEpvv2>1xj)Y$+M)1VOTukoSS^@h22z_goRhoL znvZG>ere^i6bo!>4$%O%`9uH+I;S4u9PNA=qxC>TB>P_cAnHrz_);^9&Ev$Og~NxF zsuq!#1Q{i^oAQJ$o3wK-UR0S{6t-&jzFzHQWmWE&{4MUqv~}|F1lN|pX_&oEa>_cq z^GVzNxxQ4-sX_C=xbvC@BR%GUe$7N+CHTg;xo9o;GJVgv z(o*3kJnUla$NIGKEU6!>N2_{K%@Nqz*1FdDOEPKREF3#YkPMxHUsOdySaZ180xDnI zW=(2j60aKDLb_EeNiP1^psEz^Y@69LttG@;?tg}$4$(sw09KqJe9_i6yCeZeh8j_# zO!d^rM)7k)JRlIvsfbgp4g*2?+}uRem)xa=L3Bo;i$SkGv2z zT5EJav^?3zl_AG~VQZF1)L=h6f&~<*!8-EYtCyyK2d!A|J9^4idS{0I`tMIW>~l?G z%X|ihA%+~TQ4%aF`F%WUMgOLcQucjBy}!Ej{$fPrXt;nHJw9$K@H^D>zwxw;3+Em< zQ{wp?-WBDRdyK*sOg)b0aZJ|Qwr9S2smt>LfU`;w;I*xUd=bUqZ^VgtvtNcvzz!dssk{7Jmn7_th%^TS9-r>Lx)oJ408 z)#&^w1>#wr-WtrB0l^SFEqO#mMPK=hf}wyOt^~-@g{g9N25%^ZLZby?v&I*1J*fy{ z;Ifs4n!|5a0KcYO>^1tTO(412SsXFFy&j%R3+tno=olDYGg&(pePF{}eO>8-r9>vd zG8Hrb=F{6s_8ygVX-_3G2tf8fffwKQsR3eo(*;a7vw<_Hbx-!wouxWN0q%b`o41H| ZShTvbNpFa94IY6XHKogn#qySc{|8+{b3Xt8 diff --git a/docs/images/vscode-format-on-save.png b/docs/images/vscode-format-on-save.png new file mode 100644 index 0000000000000000000000000000000000000000..a03349b6f8d55325bc40f55d9974b86e12989b26 GIT binary patch literal 41262 zcmeFZWq4dWmIZ2Nierp1W-c=`GsnyrGc(&UJ7#8vn3#)_Dp~CCVhXs zUvJ8%Tq+&yBOOU4?Y-8j3YC`?LxlST2Lb|uC?PJa2m%6y08CH7Kmq@6Z&KobfFN*~ z2?@zd2ni9&+uN9!SsH_Yh=(SqLaQkaV`OT^M)QBok%Dc9oi2?>(a4vC#`z43A{pYB zZ2$;|tI(#=6H*mH(^lr652L`q0QJyDQIMbS_t$od18X^_-blMh<9dHR81tD(=W@8f z15uu+3hcpEM)%bc@S`9j@y(1+7bL$0MJNXQWD9<0DcceK0S^yJ58LcrXMG(aB){E+ zeCo;c-G|m(ONSR4gyhpUvo$X{=5`*)COU3TF$hTRH?|A~!gxJ3zaSVWm@7uuiRdjj zSlPI(Ud6N~EV90F5DJRwrCbD%_?6FcfL$Yg#65u!JP5505D;|EzK-T*H?0t*&kg>p zf+3_&_+}eNMlUiQBH(#X@)`( zl5Wh7Ui2{fYy-2I9wE!vL!1b821b#?5>`%8_WFmsa-5Ec$b=?zjl%Q2NjvbvYIm^h zUsY4M6SWAG=td%>z9oZItAFPEjA~#Ua&}W|*t^TR6V8|tL(EEK7eV696k_P=9}SYi ztCCCy7a6mXw7VZQhPe_mY$`HhXC+{wRZPRD#uQBZonQje;s6%wikP$QCI2#}+1AZZ zpr+Z-i(A06OzWV%ijYv06{85oA$RYt2^K&u+>^$C8mo&%O%P6w)&)s9GdL3nIb~PF zew9me_wB1X_k%eKQZgaRPd}`A=4j{|kWQ;?Z;N)S(uZ`HA_sqM_M$n9s^JLF)<=(g@mU*X~KZu5J?;m6OQ(04O z_Py`^jzXTh&j5ztl}FMcS4%DhlC@#T>aU*9rXJf0jtkRcF={gc>jC+gb10Qj%?}V=|1bznT=3-O<7YBPY2;pPL zkdAJEYQYAgu<993V-=R~l}B)JaFovukvS-P3$FG1$p-tVRgKGeKOSy%vHZYREIeoj zsq&`m3}jFjnp*cGdv|3r+adUWVyJdiciHVRn!h;`x3Nt9f&haD4!#m<0 z`!W8cXGY5KH_4uvB65UnL0$W%k_-Kl^B0XfWV@ep&g9f*1ii3i43mf@eSEBs;XR5~ zj?&-8dnKzF%TP%-C{TL#x_S;72)J9zAe-LUurI1TSojKd`jn z5cGAT7DIUX({_h<5s`dggkgf||HjyZ-^0-3)|BK9YZEG*i!l{@h;(nj$Pmt+*5u!m z;2Po@v?y@;87W4bL_3ytI2cXDAP!EvKYu(QJbxx%RuOR2?w{));~ytjB^c(Lfnu!LP9rm~6OE^b@DKRj$Lj39nC!7@HsGA^M{k~-mzDnp?q?^mj1frk8R z3FR!I$GEOp>;}GL1se7s9EUk6)wD7cvDv|S4 ziS98$N#lzX*0dsHzzTt zQ$KOby;mvdRg{@nm$+lfJ#R*I@-WpAiYK@ubX}T&d7cf41q0`T*_!Fi$iNKMre

          ~N&M>Q_~(1*=M90_)D9j`g>G_F6m2o%sk0?EAUyxzB_8jlDc#PJ^(K;kY<> zx*SXFcIhJ-6yPB>KXx$rb*9rS9BdZeDmb+EPrddUs7MSTi&P1N^6vW7Q$d{WR;>v>MJ zot5v_Pq)(h(uJDgnoF7oA&>nn1spQ<*T>qBa>}dJ7FpITo`Q}7a_OfsJxP2dy@mXs zUSe#}HA8(+T`-?85-~fnV(52CO=z=j>nNHIla?MVCr%4F1{^RZjxtA+ zTOIHj0aiLQo->b9`}cG(>Qy$MjrH$(HZVD8G+GbGxBL3POCcoEs7>D}4av>*kM!qm zYf7~zS?dM?b^sQd=WU)h*OjEJv7-e@1;zzgsNIMsOWc0zOo5 ze{j}o>eI>ia@BGnF}|32WGX>9yC|26V({$v51g{evI}!@>qBkgUf~sSzH(0Lz_&SX zah^OS;KZ{AAL<|%9X#&53}$&Gap&+-dYJ#J`!QK^A?#!8^IR)2>7E6j<@1T+P3deh z3{wRV`L_42dZIV2cOf-3x}{33bJDT?Jg_G-Bme7XZ)39!Upuv1<+Jw&bQCfz!ACyc zSLPk2qnkp&yzZyYAg^}5bS`chqwvLPT~GuSW*$6WRS(c?GI0KYcer?onwzXT!WyPh zG{5(6#-_q%cHr4itg#!e``92zz2;lU_4+uFE9^eLoLo`!F}10`v?wWsU6B^I2n8}k z#k!(IocCYo&IvRL6`Vl%8s5P^(|S^H7wrCyB@&I*Bur#vK&XIe7!XKMR1k1r3KaMU z0{RIA@*ims5J^y+|4J)@Qv6j035Z0ulYZ)WRg zW@AnG`?~rDHcpN_L`1(U`me`7+iC1-_TM#GJN$K9z#9boJ_BH&qX+zNW{zeie=z%f z=AUN&xUYX!$Nl?aobqO_#+GWrW>&zi1~!eCfrXi!`yciEzfS#kOaE#5#lhHK$i@n2 z>B#%vgY}p3zn}b{hX1Hj{lDvEq-Xv2D*x@wzghmi2Tny}2OCSL-+lPS+RTxcksI*8 zW&ckr_5U{GWngCh%jn;8|EGo8|7!8?x&PBb&fW~z5Bk5G#>?|lxyK(P!P8K(8#F#ZaL2{AS7D}y{FCLa14Fdb0kC!4?qX)SS9-B-Eao_)V@PEke z_C@#mk7a;Y;Qy)DCCLv)@;65S=*izTE!r1YVZwiI)bF!U;ParUgnx5L_*!69efrOR z0Xz$AJm=rE9E_w38>$Ta?`{w*7DOAh`u}SDJ^%jy(W}0k(VvB&6iVk=hztiJ%25Ai zhFoTmL?3n9F3>}?yTx|y)&pRAU5D$D$BV;rlp`p`mp~&>9S2=v(d48xZJ{`PHAU%yWagU7>QRaW)CQYU3FSm+aAD4D`w2(h|6Dh zV9?gXi2TEcmQWj}?_0OtW>+_n=|nmxI2PZV*VQDS4|F;&FRzYriQ>3qr_BcMsGjXb z`#rTGD3Zxgw8E;74>W`8WvR-tk5abVji$)+9WsQcROefZRs_MjPS;Tiy(^f@>XayN z+_Olxf1nYM<2x=utBJ6|W`m4OCY8|p)k*ylTkJ9d4xK8jLYv@&@kso~$D0FHCObt% z#lFyws-%+WLP@1CN=!eBOXzx>IVseA zWiYPlYgQ_f{Q&GXq}|z&0<)jlF~vIVK_keMk%E6*iew>HKS>tlDTK8i|0qqU;r%(9 zK%-7Y5#ZP9$!4=okuAPZW3|GHr>q%Y?r>0{vic47B3veoRpVJz5kxeu#&{G`Yj=0o z=o13>*V~f?-FP}}(S8H6kt+QF9z}=-ct}Q*hTXB0(W`G`DNNyE=+vQ~h1OBHoGme< zc;;o&IUEKUtTaT|ombAbQ%p0_?dt7;uA$A7TPQp zDyT2lrxbIAhkX&C9@^(BH{`Pl8@~Kd{@&8vr2=yP$Cb?&8O)hBJ4*O{|4`RErASmP zi`z}`b+}b%(@oZA+g`+5;R4BoIo)>mTcH*kEHK`; z2ZyWyut{l!gN~PLoETb7=Sd;6mMC>duP5#cV;b8QiU@0Bu}EjmUzHI70!7B7DkbYU zSc-q#P&Oq$qkLpSkXFN_OP8C29Bpy37+2~+io$!AU3Ak5#V%97Nm^{QshrGxe>|Yd z8gwOO2E!`hvs{Epd;Z)MqF!%akj$`yQ|)qr&jJroQ8SW2ZKF*h7Kv*Q@osxHs}!Yf zXNDaTC5J*0K$)z5vlYD4zg%x&ggqM8V6_rTCS%2wt2Ji)gYNaff(u_%~yc)#lovl)|-?^Db5J|$1k?~i_xYb{Q58jzek$-LL%nC+#< z6vvcW?oKE3LjAom3eR_VxNB+xZr*cWR7*BwOB9VEjz_%8+l{A1V%g8kRCN^;>rh&HiBgX-#zr;F-TWQ}24y}FIt+~6$cvuKk%_p#`& zTfqdy3cY75eA#Ff^M0d#n$~8Nm(bXpzrGm9H+hOvJ_I3PlO==%I>y&~9p(goQP*+Z zQU~<=B++RX5IsOqpD|7TYU74mE6^JRjWC*rQ)sF)o61dicsw9Th+W}ifCI%cdb%f| zSlcnWY0Ox?pXBWSkV;-pD!6^_vu zI!JIqiGD`hHk@0hXUea9Y&jV4QcUEOp!3P6s%Er>}V2h)S|>pnax z%BrHQ-SB?a1}t#H!onVNY^A?G--kY*TLfq8Hs7kKu1$qv(52fjVH~x(gf`Zq{zn2_>42bT8KRq?~Qeq0f80 z&5gEjF_`f!(_?iK-!3|s;GAr^u6eYc_`UP}P3@@R$id=$N{j&0Wz8vS{Ln8zyTwsy z@)(%YfSq3UF#ti&3rKYZb7nf-uibMFJckJ{owrs7sHVi=OTGiQG$r6>FnZ-kBh6#b z$E6cKNKUScVmKJ-%st4&s4>P}IqLNXSJrRw^JS%4?`EdQvecf9p~PG{{d~x1JS904 zlBdi?;SvU%BSlL_1msgL#pvah%_wB%t04iqZ53|HDJ#a|O?5xT(`TWeQ7c0?U7*%{k<^SQnHV2)4lw)zy`s>Q7EA4&pbIZ=*bVY63t)?c6< zF3qsG>k{EbP){~R`VAHO69R_;2Mu#|GesGu$X@_f*H0A z>BiVDeo*4jkI*DkT1_EZRS!&l*km~{CZJ|!(|u>L5`+5TDQx}WttN>21nDoZBda;R zLcF69G4Ec_cMfHZYAf4kjf1Y(@U}c{V(xdRw5Hlii2Rwx5*8+z3p>1j2%`8cQ7WfHry)y)OU)HCd|9x&bPqU{?9tw{bm-LSaW->;TMmtMR)Btmx}E7{=9haIOhwsT z^i$xj*gVGAF9}5q8UcwCZ+tRO3-*|@UGl5*q@vX-95IW_MWsyVHP}8XfV*y!mw{S% z6u6!C@x7PT@ByD`?0Q>pU>- z6VhhAVDoub_J_)5=IIY|Gf0X;2-?csMULa zd$pf^+)0c@hmUKpz)ZJ5G3s!=61;U8rKK&KnheR}eU)OcS&xFzuzx;#Cx4x86^qQ` z@eri~A*hQ_4unHT1#W6_Oz>LP22?6#G_TF73LV4c(w2T`^-X0(+h`K=<(lMPHL6vL zHj7o=aL_o1Keq&$>AGkmi~Md{FCuFqZ;x)$#|gN!X7!YtF`Aa$&YOW9@QLWoQn47ULfE z(ZWUnVLycf7MJtsV#T%f&rQ)%>vUc(Nyp>aZj~So2X6)M)fg=A-Foh4OB?ib2E#;S z+pg`7rxwnP&T@`z+@l7|rBgt&)2Xl4MK?F51+Qf+JPMZt&;v3%bnV(kVq?Oxsw^=7 z(mEwL$YoUxQ+sp=O;g!i*zhFe-o&9%z3sC-Bgbd2)d^aW_p1d5xL?K7#bhdlbDdax z$6-?_pYij;0u95UEyVE3WIdC*+6>4jH$}*LdwL|c8ci%OGhAdd#oY9+*V`AkSm)`_ z@~N0tnC6*;K5h(#p%0|alAmYp(!jhuVN-tWxlK9v1fC3=4_OiGetVqf(%t}c#Ah(r z?6#o|u6O0inpAc1h`yt;{qVx7dAjq`xwhj`!ji432%`*uLX5WXd@0Md-ybXSMowng zk;?5KTe!uR`$KSn!UeI~+izGTZH~r;W+>~U<~ono^!C$V;T6#Kb5K!{2!Dig3`$(e zY_%zr_Sp|yw;=+O-FCAJGz|>Ju3WQKbb$DjlF8J&a-QZgV(=|VS2hv;=8Y=*bRf4n z%bRnUQk~yU9$yIi0*r$A@C+-1)Be07PnpC*1(CXKVzqWck#bJap= zc7>72nSOd%8N)FDeJW4vJDOmH*w4vjIayf@zBl%jWib$VQj4RtX9*7KywIoCn+dMA z5nmC5dOb8A1e6%mCK5*Doq^l^ib;Btl4OHx$@=pg@J~eX^B*#lP48wywQUwA5qQ|Rx@81dd zCO9EQp(*z3na%8Lff0by+VEx3j7o{3OvQV2wo8KkC^N=pmoF%Ql8o~M0-k$fs7Ybe zmP_$>$dCYqQdL0X2a%$gm9LC53%iMb3XPp%g=KL*6?iZwcr}s4Cu-1}zXC&3;LbOZ z^&XBZp*6f5D9x-M;dq@TQn=i-vs782)N>KY{4u7Vil{YEunT0!a0jLeQSL}fxBw`DPGAzp5FXx(v>rz$K+ep{{H z_l@J%hc@(AX#?($Ym_NrQqrq?H)rW&FBx>+Z$T2={T~EE0B?@xN`I&KG>~2ZqrFC$D)bFDSg$?!Mi@e$HB40O-t4T z=zRHMpSPoq#f`jbN}`S8rek=b@@xr9;idGkDT3j<6a~47T7FWOtFIIHWpIr?=ml_{ z*6e4{R;{;Ol6+cmX$`MI9R?8{-|^J-cLA9%ELJIRkyI>Av>@X@nYSuaqR#`ffc-iJ zPjKS3z;s&?K+nFZo`)dI6#MJ3#HvU(gUD3b@yk7^F?R$p+uCej>Yi^sxgyh>+neb2 z&JG^nx`xYxKa{bXpuWrgM-OD4Nhc-rMyQ;32`dI31-j~LkeWyx8U&uk3$D^X= z?dOZm1nY0}#fK-AmE=Hh$(pP>ut@e*>k~rI5B8T1`kC!z3kyv%@Ap?96)ZoXt2P9g z)v9J^)6Swbmj0MgPjCd1Ns6I7PzEiYM7Oqk3U==fuj|9ZGbeSv(m0v8e_UD`#^GSH zv|VL5LDJR1D%?dI!=VIO%R45L8H2IS5!a25<7M*Hviir#Mh3be=9tM1+5rzW-E8HnzJfVQ~M18pr=N|+uW!e zzDfbIV5)5Lk>->-ZOPYb75BFo;pA!lA}NLv6+qX+3To(dskZO=A_{$3&9_FSRE2nx z$b+s6Zz$B~wSGDAbT0|IgayqqCdp;9u~WO%!z!2?)3E_BVpI11Jc{yO(3WAg^PPVW zY>@Iz0ygr&Y=-qhW)U?X3(>9?SB6-(Oi? zchzTgzy*&AJU7yE@uwB;wB4e?I9wA`ukPLHIg9)lvtJOoOsXEK$l4T?(3sxC(}~$U zgRWl!wNE3Sy}L_xgqoTKiKo>HvLkf(sP|~;+N1OP=cepeGFQB z{Yt4RZUbUsh=W(+mu>x+y20vZhtz2l-Dx!3{-I!3@#34uOH}rm#<2HU}?Zy_R z^g*>Uc^m05{L`{=Bt^Kdg}OJMCP&%xs*lb0#&fk3<)9pEw<8*^khfkd8rkbKT%}LE z#|eX3;Ln)XX$i&&l|)e3RX?~ptP4kx1&wqH0J`5a`{U0F{2$bF1W6N^fyBf1nhRgF zS!_Hb%jfQLH8KCk8=o4juw*xA)bqvaS`cCw1ZrfSS#_#JXb5|AHM1ZDw=bS=kIJLB zsAyfaCa?LPUB9=-{bz!XonXXT>ek*C*Ke{qo!%MBbvjiTOIE=f9ph?QV;ml08eagvQooBU&hd4Rjn&ye&1nS1JUc)cE^mRt#sdH3$ zDFVPyibkXwI}2m0+2J5$z5Q8Zj~{!(%O#!N?n8mepf<9w`=nG2t1|FonNQG24{j1ut`KCTvr$kx?C6PPl&-P ze6DwgsmHJdi;F&zML3L+CyO_s^aw5&N~g20uioN#?TEsk_Y@{(%Qs`JPPmYkzIspSbjVZ%4YJT8WLU0rXx#31#Mkb7drqHuGG zgzS8JxV_=1d#n^C;!mt@2rL+bK0Uo-7^uM2ue7%no6!P~7+A$-w~3t>v})HYu-^n# z!$Uk;`)_| zy$>=PfppcAOQTWC54(}U2nR{{d5!er$OA9G_Qa{Y4GaQr_Vs-nfIE`BA1_aMjy+r9wZ?9J>dpj$dcmyHDkw(GncNe>SaKDYeDI=exJAym}_l$!NgOMgT|50AT}ljD@*?$C!v zonz85Cl&geE~RPzlmnKgKZeH75Zk+g-RsMFi-5*SRD*oBRVV@VCa-7Kqtu~ttvfeG z6zI*y-~3~<2?Hh=Ypw5d0+0s%VNZyk=aFL+rL4XQ-y!-vb^D@oVHty%bu@ZjKVm2t zo~*0{WaBA~%_dgz7mu0OQpkQ(%sD!>ipt)dF@(gKfAUrggP~{|!PD%-6?f#5Mys=S zGnBAdJq#dz0EobS5v7tdZarw8S_Nn}q&M9ybN;aIWtj;>@02p^aTfzmF>R*z06Ss+ zy4M2O@jY)3^R^#1~G-ohq68AUY(^x>NKUIszuGOLUfIfk@Ty4_HXT1^8g=aFM zQti+ff9n2(y#EBlDPz7u9iwi3-?#Ipjlu83!vZz}SgTbb(cg#~Q0Za&zDW_)@*~9k z!Fm5LT2MF(1QBY=bb|U%p4VR``Nx1V55j$XSa{(-taAU7M@*6P2MGL1xe5Ezef*V= z;sEiLKBQT!2Q214Hj!N;r zxfcd8U#Ng&4-y)bzp48Fy752tg> z`i1!qx5slIDJdzpU+*_QVghuenNaJ^wW&EBUF9v;TGS)(o-1~oMiObsD>^$ei7Z*nXa>yTmAmTw-N0E=kR^DT#3?S&pEo!ZmkBZTBf<~oWgEWy=6O{$xt%I$j z!{s*)?y})kNwouH48!rb8pO)m-s|D(t=B~3Y19>Q*=^;e)9(6x&hEfFHfYpqLMpUd z!<(Aes~wL}tKDy@PPBAy7bOY7JC?1m8I4fnxUb?pp$hs234AE#E3^$WF&wt2%iE4X zQLMh-9887-H~NCdy~he^ylOtta?M6`nbcJp?U zd^ql&wX$258lS2bw~Jul&NgF+=fWy=%`Po<1c_P z<9k(0=XPTpKR*HrMwG(Frwc~IfGByG+l_afcIlVW`CO% z^nfk)6mkSbJ|WP2LU_@H0n+#a2>35SL&*$zPExS2SIk&y%m&mbCYi{oAhCn`i z&I*%Kk=Yz7VD=v)hEAo73am$IFHj&2Dxj{k`nS5L9(p2^M<~FLV654GFEOltpGu@q zI>izST=!PZ^q_JLD$qDj^!pdZ-I-&m)oQE&r4Fv$J@WM|X`Ev1!X-L014 z;oFyP()^NJq z6{}pRxtoYQ*LdVZiIHf!y*I4Y22aZ|`zzlq?g z-y}38J2J10qT#+O;8OY>o+OgByR#*Tt z;{YK%9?s!bD-94@bdKUOhTTBox$o|51&sH7Bee>sn@}n8+8xq2Ge>)BWQ?ePKHl)j zHm32la|BW)+m)Sf5%mV5?c7JVvR+4|3pZ-DCiOtL;Ygv=Mu+|h!vAsI)%zk>S3@TT zqKAA_Jxa-<(X9}<6Jl#GT0@g!egtQIEy%|iDErQ+X!6#>MUfCz^p^-r+dQF8PQp{LGMKF*)6W54yH{1^=5OzmBDbbl$0}tuB4`(*wBA&(< zH%vxoDfXBj+$=UK-;ikB#c(yB%UxQSBSR;ZB++bm6pcn=CY?#g7>6{^QoEyTzqE> zQjthpj=3u!4222wDlsPcHU=fL*8QLmter}xB6+IYQ>bp>o}zTT^DJ#+@t+BhA9}$X2bglq2h7`WPy6A z_CVeRC}og1lHAT=b|Q5q-IA5Cf~tZtXy%+}ibADWB7G>y9oR6e(lc#h)5df(b$j#= z90f7blk60ZhH^0+Vgh!T3x|kLGDEtu@h#6@pJ@$#M9}wcTh(>u!HIw*9Ubo+;uZ6thoX6cqJ3|=s=z;W`1|uP> zyEMC8SQ{f;YPEvo87?<=>K2B7+#6LzYh0aHY&lD|${6JT1=9tnIKo+IvrnL!D_c{q z^{(pahR7}p&@%!34%r=TxJ(_&zc-?)-mhJMjQj~6xXwlcjq>l>ukPE!btv6PQDLI~ zIYNlUcT-1gio253HX3&2Urs)yRqMSzIT`%S1~oqeyGbpy5N;Clyy{O9X|z5U&@#~o z%9Gn{z34!H$a~>}(PD4VJWYQ4I%^FTKp$0h&59;m4x-Q^U)L;p)L?MO7?{RuiVeTH zZh9~));2%LUS$+PVXKYF(hI^Cd%yhLH;mUARy$pcf=FpAp6~4?Q?|nnU1s- zfQLzbJ=da&R!lx4A@HzaLJy=PeR12KW1lmziTns*jbIqPQb~M{OH5}qActOF9v$pC zPirIL@qBLQlsVit*7Scvv7LL}?l3^vk}~`S2DOTo-iJE9Js>9hgS)CpSVO!-v0%=i zh(47a)>GAh1RbOFCSl-++sCdc2`J2=#U!r4Mg8dGwu2=qW3g0in1%#Z|2+<1J5+60 z^4!|%06FM>`w4~{@Q{b3qUeFd*$Lz_#GRdHpAb1GRt+G45wZ5gO;d_WFi-`WcT8~| z*&v+jE%L`YQ3a9-eP)@2SBmg_w4l&HAmD=f_R);-g(k^j|kxm zr)|`d4Z>@reUBaGME-3ebsevEanI+=*Y0PCjS4+d)CDn*9NCN(dld1&Y;UgaL>APe zE9=l-_k8I#^d{@MYXMeGsG-hjbl{?;d21Tg2BdiCKUv$C1-H1ty$o~e0tC%Y4o@Ik zMBXLgF*tGQH$?!3ppiB}DPG&vfL?}j3&c42d0TBp{RO~x12WTv-ip=dv7nzJ{=>$S z{7A?>?#of0_77772qjTZa0Z7Duk2RoNc%5()7x)9kp?`dl6mv2h4Lb%z6wD*$Yq*U zV?ZBk((m=X>I>XI-D+EzV)gqcsQoywv%}syJToA&$SH-?>JiptG@77V5Tq!r$f8V} z)zvz$h1QBhND&t79-)fzoeUKeq?t`4b+L;nxBbHMgqt3aFt!9AW-0O`4B@I`X{Tdi zGM=YXoI+mUyQPa{9EaHFei-5naP)^Gu?+roGuovvUE-Rg=I#~*(S0u3LPW#4?hUe# znUzF!vv4+#DY$3&?97tq;p5EiO+fohb(x5^4)(WnFMGXETx}bmo=H$LjIl6-t4bjw zvs@Xkvy*Z*=G)7jNFukQ=|{_U7pm+mc5aU*B}IfwE-6C^_*cE+4HB=?oVyP_kNZ2z z8kHfQM4z{Q-4id(Bj4&67zFw0gn+YMEn9&1AI%hbu1{|F!_Vbve;w;NAmeNXih3Ih z#GrpjC0Vl)Jcvi9rEVLk-bn=4XUNH7; z&04W;T`LuUVErw5t~D8-O+s+>07_71d(?rtOREE1K5ywZAf^Ng5RZt1M!?FCH@udi zKJRG#J_3|+50si3nDClJcq}h%c7wmtsUa40J4`OoW+zMJy7|BFM7cE93`*@Tnd-_T z+Lbxz!%auxzc#cLIhoYK{Nived$g_qtzZ*FoH?-XhvX#}IGCSQy1SpJ~1E0d;Wm zZ%T4J81a)!^2e&hogYf0y}@ipne@6!kMGmBuImIyI$f`FA8r?nN5(Nl5!~T8MdWyw zM(tG#qk!rq*>PS*ZF26nhd4oiJdiZ<;KfA8XW9oZRaz{W0dKgUdcAj1z9n?nr+HE| zZ}o7=eL^H9JFn?~UOrm7F|(kB%h*3}y@=~9c%D56@@L`IhHI0U1Z6->dIVVwJLBb= zRiqh%pXWwvceNJj+5Nz^Q0k%u|B&lT0EkrE&21~%)dSwyYO_$=)A1-MEfS3J-brQD zPxT+P9kfqtwN57{kJk3oI*x)AsnCe-+LQyUc=AgR@pQA7<(FRwJbC2G?ioGqq>rw5 zh`mCU8+Qg|&>n9vQTFc#xXq^XCuc9fHyVJ#$bCSE2eQ(T|V7!p5! zu-^E&e?@NgD%)2t^ayprxZxn@G1XwjwZetmc>#p*#i2HijdV1N+;P9QB7!sUzPW~t zI4sqWZkIO(dF=UYc;U4zOFXm_@OcBjB)}*8a<^h%=`j6+7ERnu$PH?%AwbaT#MKX; z5Nw0~Yy^EH(KPGq?DmbV_HidF0SvtMmj*Q3hG+OVEx~bybshrNrT^EZYv=lk^d;z? z+}-5RYoPep#N-TX;4~Oh*HZ*fv(@?gwuf?WZe3VCZT4ERA)j(pw$n@h4UN|rE z6Gi43>#xsK2iK>q%Z%5Hj}JSOdwRvEHCA?N6}JohJHX#~hz5S0;mSQL6DYBlPQL8u zvYD6odDrd1ZnNHYU6uA>89a{M2h~=$7RaR4$auuHKy(m4WG4F`L>wS?i>q?mD2?3^ z__U>+zT?s(m(tJI3uZ7QLb_u7#_y9Xw7eKQz5qo&0L-V3`FXxx53})9KI4sdmL=zw z?6^{^{F7$d8(SBnwAxK4%USwf~2o<1znQFf_gh;(1KNE z6XC9iaxDiZtqyj}eyVLE+Z*&o8Ei~emR7wb)!U*g6nF0sb%a=ee!=rOI)yzt{u;(! z^CX35Yz5Eern1}75-85$BWn42>aFn7upsQOTr5PF!AHv~*VHQskI8_&;}BY_;EV$S z=^@~z`?OvTHhgh>b?eaAU0~R*b!QYSd1{~0sUm?)hhN_CXzo%cx=Nt-kjQ>_f8WEj z*6&ax?1$4L>GK3xK8pJ;rek=;rC8)8yIZoXk+{c@_WASU*Ie=RHQnZ^YT0Q&;J%Y{ zLV(fyW1UWq9;k(SH_i9RZoh#F4>yfE`KoZ5s45%@$ENWN6Yn+jy4v79D@#INa1O=k zg1*3oeX#R3dHM=3kX3Uqs4B8_M^M6oSQQD4AbSvLsdU7HtO zE5lJTJINXco-RSUO9F7s7dmEb{qZ6efmQg6YQEoyF!o6x1Ay?W+dFRT!j!`6n|#M( zOWR^@=kpLT&#cS9EOo9AkJnRD!(FsnW~VLt>#O|A)7!|$V}{m5mRYSHc4Rod@~<4u zry&mq1U7p=Oz&QwJF_{d536vwOfDYu9U;&x_WhfmJekdL*sQ5=!~lmB7Nt0CSb_AO z4=X<$%v3N)`i5c~*WDLb-MNLJT);<1PVKw6HzwY!90=SG^`{EQwHriZ zcq1pEFvu*{UsQnZ4aWC%>$TMp&>IrRMQFrNKXkB6+B$6urI(M-JA9O;P8=(qaf|W< z=L4iCpy>vW-E%*-zdfay_eBn?6ZF=)?iLOIF;f^_e$qz5!x@cQDantLY`k7-h zG;rv!J+GGz^)kcEC|{llMZ;P^a=8rqZTOXHxOllr}) z?oOQA_c-LHxLO4Wl80C+2J`wp7r0E?G_$w-8zsdz^gXQRvx_I%VH*lZ)5iVJ7jiXd zfn+$7w&tAx-N9--7KHV?9ea0+ju-p7eeqJdlm#KY0J|QgP+w+O3?M3_Liusr;U$pG zTB{N%Pse>iaVU)~>-M?J2A&vM2DBH*T$fTzB6Y}Oj_?F&nBKB@S>-+AFlUuKuk5|8 zKT_pk6AWLcJ_cQ%^*%mv`Q0Y!eVrQsW4hq)+0r4990Tejw+mK#>T{IcZ)EPJ6@B(n zIBq;n=+Pu(!S+yJ&V}d=8CVQKrwjJDK0F3LAr3TSiGvlCtBdyS+^^LbQ|m`kh_zA5 z-Y(vxSrm$?Wf{KVJMu8j2tJh+Xs z)HlRd>a=rax4idb#wB#)k>}EWQ?Sz*I5o&ab$j02{Nh9)jd7tu=-M3@!aB3&N8l=d-%yao4v~e z>Hg4-7wz8FN2S!+ZTE+r_Uj684wY)a_Z)HQ=8G!;X+@m*r!NCXyaAlL?JOU2aVNQn z6Kbwq_9=m&45}R8+TfKNv(>Wn8u2o0=6%RL*;8t}2j4+T!Oq+J+kGi|B_g!SHv}!G zxi9nQ<7{lTJ)FKvEhrQw=@F1@>x;r28|RnD!CUIT!J|};>>I{Lp`f-L6W}izeB9af zE!Qx&{eRedtEjl5Y->2dgA)jDfh4#EcSvx82X{ztcPF?*@ZfI2f_oJbBxvxUg2~zx{7#6ve82_St*wv(}n(uKWz@b-8)hiTl0<4xJN%bX$@H&~u_n zAnYYtP?&WeUnTuWLb7{cJLtW&?oB77o)xS%`+6z<{4Fspj^7MP`D3JusCjNtynGlR zO7zn67QBX7ROYGM^aek3>+WxK3M&^N#^pWvO}Rz1f=?X&yQGfhPuW?>wri#oQd&20 z76v_UMm|Pi2M7-H;G=%dP%=hnRm8b1D9jK`XI?dsVSU9#OD$~aWW}60dWE@in*!iH zH&5$~+gEfxZ}ouEurr=Z-Jy#SdKW+a1z_i>*Ujh5Kt*p8)Iz(m{ zP54bFZNt|1lkzPo1hV}Rw+?LqgYT{)>NC|pjz=<1-Ai}WJ$bg(Fs7bg#ppiYLFZcm ztmcMdh+7VSL;_=5K)SFNid}z%sZBo zx40h|aL9&wrYbBw%hfG+os^S7G+6l8%0v{IE&v1u1+~b5EdW=;L=jvwsY&V{jdq2_ z(OE_GlXN?b3H+7Ya=g5HS9~<~i%DqzcTE;e29J@nF=kvXiP%pOCMkzN3Xu84G^ibo z$XxYalJhM-rcx}1g3@nV5CDf@CX=yK$-V{Yv^s&*i&s4KSteV#$Q_-}2Y>hMmP2Q1 zf;L-EM7+-d}kF)AGk$7)}=x_TPG6gS$>-_H21qt(0GJge;Pz!AyEv~S<0EJYuc6c1U z$^RWL5p)I=KNQ|C2&w%o^_J_J^C}|a02Kn7#H$0{R9yPh{7}EW0(P4>*mMwI$41^t zlZo8!0O7<6W9RSmWP6TMD_`;gZ|(O9-jiO1C0>zAhe2!y<8xAa38~0+x&!Z>QHDu>qAGss%ZcjOcz=JP zBE$%tQ5x3a-x8YnmlnVmjQar+woDG_(({UZwt`{JPOoQI6jWmO_ICk$JDx-|=iQF@ z^uH$Mdu1_#A%ZfI?=CM;NJiNwuTZ%yiP`U^?}4~$_(~Iq9!e7F(p_jc0j}gi8?<8l z=HB!5?BByh=Lvq%Gg<~^N^O}>_whD!oicCzB~q9)l)FwQ_x+EWp61Hg!GZGm+f~sT z0!?(h;}(OpJ3U#{`R*q0V?el1dXbT-2L+L-m5IpRmd0D-mLT%Dmoo&_p+QNAvb>$) z3=HAV{*JF8{Yo>!$Y`5}9UemQCXFu)j_=P$LIoB_=VD+W2K!)iaPKiOr&O3mi*L1hROdbca#E+A`rE}YaqvZ4U+ z)G9<0CxGw{J~Do$Qw)Aw_Y0Xc3NO?efn5cToB-6awbtyq#gB2<;ZFrgpS7%n+nS1U zbvDpiVO1O4b(qCDvaJfHvS_EtZhRzf6eT3|tZ3YyCC1z(D-W&=>}mO%qiL-r@hb;F z%yaTV*aK5hT>1nu(ip3cx!msV_X`b{pF2Fmvz1OOZ3qh;b|y~L<4tyqZ;o>`sS${3 zfPYifGGBR3nsSi~dD-ZD_2kFVQj2hVrTZ|Af3d)VOoZKHqa+#mk0I_w92{~Ub%;sI zi<9hHaPCej>Ue*Z5h+g^t1c@shY_uAN-AWpG~E(DP_cjo5F89CMSXrk{YHZ$^8LSD zGl4qXp+*dWW&D+VY>RH3a=^nZGTKEWTqjq%ix%m>qC!`>A7KAQ*5<`9^F2%w$$6tB z-6(P3C$$*>+0wc$Pk?o{xmu1aK=W8W3ogF=OG&()t<+X&%E*DKYRSC)BJ>3!)@sTl zj;*4%c0R(R3`G=(#d{=DxBjqS(xS3oDzp!~7J_ZxvaeCh74(JJm|z?~l?nMw-N5*l zlySiEw)X?dCC%?$8FBKE&ic=;Y`1Ze;qc6<>rqDLarZ~OKJ)4YOHIA6Kj>x6a8RcD0NTPP$hFIjLVa{%b}YT z7E#>khTVHHTi*}0222ZKw2(Zf_Cu^2kx+Y2LeB;Vqmf)SQC4{RG) zTIvc;j5q76=z(6%=)`eJ4ai!GsP3j}l_JKmu!@p4MUhDe z^+ss+l{3>_)%3oRa~S}DE%*GYKDFj3vw2tFRC(^4rM^%I1mugi3?a0u6_pE@7aeqLIe`vY^Ne4~MzcOELs2Sb0Aj z2by|L22W+_h@%8(8}Cyxrx?*whFsN=T#mRcMj2-#KQd4}3VBE&kH7vFk4*AGkC;ub zJOxJDUqT@l#H!!{t={A8*jjP~t5g1n2wwoIu%8(Lu}3=GIZij?cLerBf-YO-?m{wP zp*Z5Y=cG?RU>SlDH1sk<1gm9T8=MMQ2#J?g5@Hvl8fkFq*2lZ!4#(L&qgWl;qI)35 zNsQ|;ZT7p0uied0=xAmdmi~GSypA@i8RBVJHFY9jCf1$01s=|R+ruwh$WLWm#Fg*H zX7+!C1wEY(O->pgA~@};Ry!0pf!3DAOo+kX@wSg8%9})rYg8b=W=L7P+^U4x|Pv03=(#Jwx=HkiRzF+t%+@g3^AShtpGm|VDkeBP6yK9Dq znJcfZo+K3Nh*~4+OebXQ>=LfQw8Z3S= ztHY^WSmXc{?mCXqmi9@nOfe5)(!4L&A6wmiZrd~7l&31K&*?TW{yo!RU0fsh9|Weh z`~h;DiU;wrQDP*@$&Re~dkKIp8k%fPZiC)FKUy<+wd_GrGuw92H}`rlfyNS!Sl5qy zDnv?!-7|#f2{Be%zqG*$yTJa~!|{mKOhu%iKiFyX!?ba?>He-v@vQLX!T#oO!M;ft zVA?T*L!g~W?-LQD+@jUZ{4m1u5GN*pO67gg+plyG+)ROuhR=8+ii5VJ=T2%s7@02` zN|tVA2@qQ~$1Pm&NWZM3ps_vV^shZ<2nm7;F>P$88-GQMh_kr?UN=8J#1PQSR6JE| zoj6{hNktC+U3*E4ZE-MJl(lVyGmki^w6>99!-jsd297G2N5Sy4%8e#6y_48tVe%WL zANB9_@wfW`V&m8S#iod>r9KJr>J)%66?0e{+c5s#m&|?!ehj5u8g{M+YjV%NEyM}) zd=@ZG%JW&F!J;LzWB5sEbFBlvWKb={mNatnmFk9xL`DFyTuAd==rbCY5H#%PCYag^ z_@m9CrWnBjjnhsl_?Lv169~!cK!`T7Fy|WGOVh@;*ySh#V7XaWdc_x`*|IJ$@ka=x z4;)CBbY0b~%r%}BP5zi?W+-I0_>HMlX z?;92A0bY5IXs0Hu%$QlBJjE*sN0%`$6J$-2cv_S3ZIRJ%FL^{OBD_%xWV z8`7)nbJDSIq|Q$Y*FE-n&!n8!8%In`USARpW%GjFFGqW>v;>;|hI((|q}~aeQIN}e zXE9n5=5a><+uf=^QY(1NWI2K+^CbIzqAd|xe$4g5yiAR1=nY(_=r>}PTfHOl9oo^! zSvy!W{tQ8IR?dNw&nF`L>=%DNcg64syn2mbuOH$?dmgQLGc~n`;;Bb6k)wLo+nOKi z?eZq5tmn!0d`(=u;%0Cf6{Rg)=KB6jT7SIe_v(#btc%_SG_8890yF-hbj8 zwc~_5fZ$M<;6nm|oZe{omv}6Tm;n+L(58}k&^U73Dk|0`MuWiMez6?gp{3lTVMwwf@T>ku`tHs_VnN1*n$T4Iud!FlmT2kng<__FuNfDrqO4m*eQ# zU3{1Lr$kZqisXA;cdq&3@oa@_j{DQw^1*Uj74Q9$0EMXV+w<+5>OY{|5KANY_0h!v zC!1lr&Kp-==HE=e0kiBfo85n&o>g%GUCTQ9Ws&7j?~75r+Qb#)o&{iR3umvlE(wj_t6P%_Su)mmfY+MDM>296-XnRW#r z$5Zu#?3RDdooBVtz}KD%5Z-Y!f?w{J9LPaHU3PLAzkKn<1jx|NGa&D zXVnC-zQday?=SqTf8a{2BW?1a?4rToDj$|h#?KDRq5engPa1MZZxTI_gB-JtKUBuX z2KKC)7avrqp=j=0!f-OTF?h1IPGaT!;itHMH!Cg3T~sWFuWH2|vf=(U9Gv!f-wtv~sx!&9mVvim+H8)xHZlRa0R8c+nJRJ;Z4MAO0 zS%rU{fFF-%uLnGDPQXoX*~Uktb2Y>`c_ixaxGb}wjqK?XHSXw0T=|=wKp9~;=pEko z6RffP$^tDzM+H=HC8>CoaER z#|+}|uL@jaQmvseKm@Vqt?H+B9=BVRiZoZ?UPGSjG#!#NX*1ZMcoBF)I@AJaj zlZyQ4_mRG*Gd`YTr+2WnVKkNf#VMI}n!}15%!3m5$_>iiDRySZ6>i^d>+%h=sWsmV z>Djw#dyKJnevmA88 zF%n@rk5}_HS#=WW*0-lG=R6x#3+RLvPx!JC0j$ke+;?3|jFddWP8P`Ye-w-AiYP?% zyf;z?0nG>L&4IC*0^6DjdP83?{Sfz}!3!YwZ|Gpr>$`8(Bg?==Az(Y_m9CiA@Ok7- z$)BGi;3~JiP_!2D9>(N&D&dM(R@niUlb;0r-P$O*>gC+oCx^gE#WtEZSU_@OB~JQ+ z`nTL5kG~u4Rix2{K<{6-B*d5?iaL54q1FZPV$MaXu1z_=JSV4j^Lr+%eaWXTiPcS51u_S>Lf#7&3-c0jqy>E!^6ySR$e&l3TKYrs^$Gyp=*=aRt z=CY+u&8s-TQ~G&y57AZFfTqns8kZ1HeS3gcy1y}$ZD_*$EB|Mg671_W0|3jq@DwOF zcWQVl88KnKC>&o6=uh3}(LHXkdTK`UZ$otEC-=bz%-ZH)#q{H;)TKwJmQSk8w{Wy? z2E90N7!}}%J1^dK{LLzxzuw5~SPb%a zs(Uf)`C5Hm{Iz9-py4Bs$bY-atB;0uA@S3%%(wlu&17N8Xz$g-!#cWW8T(g1_e{Bf z$G$tXqU!uO3&g79w~CJ?3cQB*Jdn9+C^=O;)*VH^n9YoSz{vCJW>tZS?h7=(E(-sv z7j%1vNAjf9&SDniA2NA# zuOqZ8J#GMQae8?C1%my^3tJ{!_}Ho_z9$YDyPNbfKMwp2C!8$rTi6qlSO6FC(YjL0 zovCQOaCYX|HEQLxuQ{8Z)Zr@O6$?il#T2nK1}@e(F#xz@tz2 z5cu)KjY2pXb&%YYm}7vKcJZq`ZM2uhen~1+&vnmJ6GyOG;SIU-eZ6zKF6sDW8?Mo@ zE~Th*JVWjasqrk;j)tL@Mis{l47&1fEhj9)G_dmT7f-{aV{?91$?lxROtB>pPh63^ zbxu_CkRPVUD4e7_#Ji+baI7JiZ6|GP(7uSFLjzNi90EPYyapy|Biw#>d`^?e!q#<- ziq-8FjObpZ&>MAUkFSQWHmydAMD99$y84*&VXNFL2D48f$q)A9McynYX*X(O@~0VY zZj*1x4HV;4E5|9U`K@x$zma(cDsD>x{sI3Z9*x85r13(BXUmrW^mYq|n=*?#0^BAr zO{KlRHcRgXdr@mbSbWpRsyzhlL90Z|&fb#`l2@|YDJ}~wc@Db08EoLZ+3n-v1zIK4rKf(av@uce>Aw-$!0v!^C9H)?!r>E$PR8o zTD9zLDLnfl{3)~E^9tCDeaO)7f?D}`(vymD5}{@QB=|89;PqC?ou_gozM8@m@uID}HKV45j z^JhADe`AH0oFJeX2I;cG+2s&@!iejkLsTZ8JK44gQ8>++>Z_!G#HLL)ZNdpoFEFS5aP5mfI(x6DeX+j5! zY!n%5V26yumv&ReW8phl)^m&YY}hSQKn|lR$^UMfL`&f76Htp&oYPTL6WgW)?QVuO zr};p7ci1NfYtHUbol9;Jbhq2A>Nq|M8L4+?s;xh4EjnwVw=w*(GxW7Hi$u4p03V{) zhR_u4CqRy?6nlP*{2+fX3Baa{maj)Mx782eED>U8oA_ug-G8u-IY~{RHkQSVBr#S+ z&DO5z05~vP2xmfm!tBhFNXY9n9~5gJ0~LIRrfSu80>TyAbA^sL5d!YS=)SjZ#q6ev zWRwxSUKO?iOS}k3Ikv>JCu&2%-cBUEb((iMKDD5_T+B@dT{LyajhqEq>>D;|`fsa> zoi-cXpO}Oq;%j|wKcvvT7)%@L@zdR6w8vOxz9Z7z`LxeLjfKZR)V9dAQ1WTlXD>tG zb(7o6(_gyBGKt`L11wec9~5kDPKzrHN{n8b-RZoRxvwa^zmauICnp;u*$RiUo!{jx zx63`eto;kiqkQ4;{0=I%rN^Up@LZwUU*8U~#bByanfUcdB|T}f}G#Q zLz5}j#d9=d479Dgx9n>I!-ZG;e^ic^VtLyC;RDi}pS)IL0A5@Z+_$GnR>X-|-iCew z-`Fz_ui!`H2WhAy4I`(%#Se0+)~+4g9?B`<6OXeR(yZ}IHRy!CuqA#+d&i};htf@s zwE_erj82@3=+n_f^oiBR>nUV3;m0e&Bho|Ss>BBKR^Hn2q<3!cqw4LM#;7TpE?=Ve zfDmHIAN-K)gw>*_WxrwLKKUyTPC-6ABfm9+f7o2}UBA z@nk(fuP|JiU7xSP{W0+L)53NIyq$g}U-JEn1V|h>JV7C4{IRAHvX-i~>K4#xY78j< z?C636kJ2#ca~g%|NLTWUW7wWOP#l8eD0D!HW~MGUjiTRcbLJrE{#1~qZXHx#V^9qV zkl)cZ3i?SScIbeP$_+)KuWveBZqq=Ywu_mBb$E8jL}wwtZLB2sLkEOTNl&i|L>|{d zzD>ZIyG}c-jIu08Dn4zI8QPH2HObs!f4)c1n{vcBO>bT9ewVg@JFA0KjpPL1k`=eNcgLIFYOcKOAvzH z(24p7ncQmKx6;2o6NUF{i<~E z%+L8{J%t6a12(J}rB?Ib-Q$=sE#x|HRy%BF;_i}s?zV&KbK7N`WWO(48-jb87>)y* z4MMR4t@g}kHXa|0^%pXn;(`bE?!^3aNjN%BtJ<-#*+~gddwLfgyRJ%)$jsaSZ2g)B zgcJi?iHYQN1SqJ84JO=VdE5_(mY4z`yJXx&2<`v{*6nw{8tezBZP2$xfW+`yR^a^X z-ubO5kogOVuIUrEqqHGl#D?s+G+58a`AM<-Y=T%6 zjLqV2Z&KeRojJY#2nLPZMiQtaECw^@jPA8n-=r5r`Rf-7!qr^q`?Gm(&ev! zYHyp|L-o10rPkS6q^DOgifzdr-*5T^x3kOw$_l6yOCC4eFr3tYL(JHFFf3}8%bZW5 zc-Ui3r+hBkek~)=Pwd9?S&fz%z-vCfPs~wR$o&d2^r&?i?3YjfAgy`1;6Ls|R_j`b zpUCCPm)Me4>4-f388e|zI%#7COF+$pi+ zx+#MI`H|au zavZA(?D#geq&WZ$dOXeag@C_Z5>tAhJE-=K?b*Ggd1l2(i8A+o{Z_F;LSmPXjak(5 zYiZL_Z0L-097t*zfL@HgCwKRJsPFI05}=^*z#c^c*3vM>=j9kvx_~B+O;mz*gz{Wx>0^8r^>${jHcsK61FO2%zsc@teNq_WNDNd zr?Q{{I*DRPifOD#vg$LFTGhutEYv45E<)S~+TCkzxC}S|y>-ogbNf2EVIb{WeaQKB zLxH4~d@8BB)%HikDu2sDOxO)#;_J)gj2z7Og0Yh`U+ts~(P*1C&s5rM+bBIf0uLGI zM5C>jL^~j#|8y62lWpYSM4qV!RmukBEu7S7H^)wyGU&^Dc8Q%2TG~v0p4Rz7_nAda zI6p~ppQb8%`L@ViAxc;VgOu}LzNXSaGX}eo=e)zsCtdO7$w{_TLXV+FoAUIGam_H> zy+t~gz7e!FH!6usEZs#q3|Z$7>=w4bXa01fA@y>M^e%g~8T*%%!+sj0m?K#tQ$*#7 z`{BvS$Id$yisJe$CMNJphZ8i5%tqXZBAVDsex~2PaWni7H%CV!3YmbaF6175{;#|N z?~YCeZS=)gaL~RaB;x4(?rsNOvVG>8`*|MIjeMlz1Dw15{C>t$rUpps$(9USZ5egJ z{*3qI%4qUA_+4z@5@i)Gvp9bxXfKF)3xkf{jS!2gf5-?k`52yj4)TYif9#{N9`zjr zaggy?MH=+2VYQXdTE>3{l;KQsd;ks}3uR>xWZSGvkJ|4?!}g>4pecOO_Wkyd^ZW>3 zHd2hvgX?6JM$ng7$zlQj0|tdTUK^FjI)7-u)Xj{xkIV`DG?N z&t<438|#05K+b*k%xAa_ieW*r?4JHeuuU3=1LZ(zu)DOXla4V^(AHM2d33r#>SsY2 zReE%(A$k{oz|JNHxBCw0xU`dUntYAN_3d!T>2MZu+jFX|Sl?^C-k+XmA3vC_takE2 z@2!SbbZIas-%HJAsTB>Bt3~ZRydy9l7jgM6Y~fS(!$WP`jdez#W#g@~$#-z_C7@qF zOFvU$0(xB&MrTOnK1v*7w`8F$W8%h!0wF#^d%}%J$Mmlan)M$W6g5D9k!_x>rSU76 zY93=@d&Dq@H*i-5s?!QF5p6}YUtaC%0;gMvf2`JH(`zZJL4IEx04{u31>m5yP)~s1 zTeC2uMYeN=J>mq$D`*bu^+z+}Coz!{u%}{d0aUKOFEa17qA}m%BJLaXD_jAZOZ5V+ zvNur5&Kh2eHNQnDe>)A*sOO1#uY1*k>=4B{MHS3TbUGTGh)rgI%;*%q57XEU;;lj= zAY~s;uU$*MoYjudgG?MPtvoPHgnnZ?v>ttz1%wrrRmG(QbJ5sz`SYZ`Rz5QXDm}Cv z&Qm1}i-cC()@_f7`0o#wzZf*Od9_7QZh*>|iAPPirR~hVU$%w)B2g8 zc^9|KZD})CZATXW3SX9Epuna23DdP_Gn8%|g4gwj>;87P^5F|fo>#>ht4?hPixEh8 zoaXAG<5Wmjb_ii`J#{5@T&Xv#2Gw=5%XCO)r@(efe9ra>qLkJ{lv3ms)1x)hMw)5* zg*U75)6ikH%8*`T>6m7sawU*!@tFQolu*{(PyS+2RC&P8TdHoUxNadNZ=7C|ebKOZ z-_=K(67fKPm*{*|Sv|yqk-gab(}gV59n<8AQxbMYL$n|7NfU04XgQAC8*|4Hxi@W3 zoR2H-Dd^&>a|+J;_0YU)?Q472JO)gko^iw3Z|+JE-vL;RmiMSc4@G;_c@9V`ur)v+ zi5S+S3YK4AmMsR|kzSgS)3{{-I;^WU6#MY$K|lMx{ga5LIay%>2tW3WWETDNB&O#X zp;>>`$xAr;aa?A8jLhPSEo)Y4X=9x^EH=vjl@nk`Q`2C3p7r(XYGGoKdf`wP7<(#{{$VJ=fdf>4Y0O>2!(KOgVOQ-QYM=ZXh64S1XBU@U!&d7nTCzCTaS#MN#&zOwNM&0UO#NWZG3 zIu;GppV#m$d#8pP<^!-Be`YzxCt*y+>=Oc42)nv zH=^)ho23?;ShXBL7L3iUFVG_1=OCN5C1NSL*ZQA z$N(J01E3(TLI%D(j0C!bEGQ3ltx**v^wn+zA*0(__pZoS3S}9AdsMxPrM=Z?rY@G! zSLaoZbk}lLt8}q!U*S*rwtrJ(OK23M9_RN0R!hlJ;>-F-XO~OY_tx3tY-=89C%pjP zFd7h0OrPub91ZLZy$RFm_1K?MYMMVoMAQ=5dm=4z zL9@G42EYQ)i=Hi%jv3~wjxnW`mJol&?d+Zfh~mSCAabr;<^%jLhF`{PibWQc>=&0m zmq>y%N+5s+gkzqEVd6%>;k#x2R(J(Cwrexas~>|MxMMt69x{0GDe! zRw`kvinXW!NDydrth9?3!f3IG@2g<-R{GZff?b&z;E>H>qCeMpJ^%DC@uM;)2+_sF zqIF-hT$(?+=oCrzCXr~AFKh{;mAAiY1W?LKwy(~c?S*i57eJu7f{BIk(&w;>ZB$fS zo9KZpZib)xR3lYY*Bq2g(L8}_N9lGCr2_REgw8&2N0(22%83n~Gu|IP$5!i=G3dVf z9Yj*zWvk>Hgi(kx#XDwlB&i&}_?1qQFM7Eom00w_pCJ8pC8N_rADwHnpUe86*Bcud z<^U%A(eXq%|Bw+X6%?o|H;RjGLW^NakV>Bq;ueF%_6cIsA2`eGM%71dQasho;rtRD zzd5aDp-Of=i(;heWC-=`-Cw*qyAeUcQtE!?epBv?0sKA8(Gv zyZrBF1y@=eX0^9ZhF7us{H4DhsETpxSnmfo$a&2Uy-eDF7xXQA%mwKdwU>kL`?#_zFs>G!}P zn)|TBf=Y_kHThD{=_(0sYrD8!EnB)5>2=lnIO-6sqD;sQ{-g4MQ(NWL&gZ+^LX+iB zEL-LtceV2#13+RdP7#ZFg?^w9812A7%8ic;%a{9~7-S zm^v&5?@X=XAwEbhlh=qC@WINZqjl4Jp?2%O5vEK;Mm?n9F8M)i$z(yaVS2HQ=2zyG zUW&UTI1YYoR7N6dXDv|#<0bCCAzcr3&ziWu6jjcBK^A#pxNY=?NsQY z*TQyA-r+H8Tb@C!?zsf@Va&w%3_oRBnL(Y2QQvE`6=6yzuT{14Eq^>^?g50N-d)xm z6B4O;edqBvLFI8VC|8y7^{0c%&Ao6IM^0yfV?5mJ>=|0$R0fq8M^BAvDpkpdLC`aYvS`d^uNl z6M=l-1##D%)jJQ!Y4~xx7sY2f_NhXp;Z|BkJQcA!DWRKX*LqyP%~#yafeK(N@w)6| z1pH)Vkq+E0Qn7#5`bTg*^f=~sj>n>4;1vD2_vK^+p4CdrvWtdRh)Mc=F9)b|Q`Yo; z7SDCZK(noAxHZvZ=w*b(QMStH;=pCOK5r|3o!$7e zseAhzPH<0Tr?Ph(LcLY#z6%T_2b^hB(?K3DRq{AgzVjf~LT+|<C+{;6-G*rSHpUqJ+DH$7OD^pZPZm^XeW!{X4r8dD_tB z=7o#*-1G0o4nx>5HJy7+YTeDQgpXz}h)mB;Rr<$v@RFnmxt+T@AFd~>*2_B+st~YW zu*rmguMVAOu)eIN{AF z1Y^fb%D`>Y?V^^F3b>=Ld2x2>HX^!1r#=2K_dVYOX zje`-j!^p_enK1XR+wPX>b1{eTxw7g&aV}pv5Gm~YzUnB=_xT#7+TwoxoQ!Ls^Gu?# z=Sri&G-ul4Qe(lE4v*>&TWO$#cu!lnFx;?xq^ChW8a(ymdf&M0S%2GSM0=jWehN@9U-jfU*6~O+dpu%o(qXbOSW0id__8_WFHY zd~4L%zDiy$L?regCNBK;H=AA~XO7p#U_;inXyUBPqL=zbFVXePhJcSwbKW)a@W02MNj0yJK!Q`y#9=`Hv%UjNMfe_^lnYCO6Ay zb9-+)ieXk_%zXR8-O_~Lj)u4X&9)24{>HDI)^%c%lI?}rMfM?^QW2vMiyMPdA~=3M0HA-i(KZTA;O(EyN=B8yEEZPGEW{M? z1?VEj@pBUjNato@Keq!I{(Wm4h;NubU}M1Y@DYeYh$}0AOv}*w1-v?Ln-hMA!#m2k zHx~42W1>h{{hW@gO8r)S^B7Yr9!q0gVk6SMw+2R@E6ax++u3I7CG+RIJOSN&u)VwZC~wX9_3!)954wktWBZ$Xj`+9&k-3)Z9N1|e zUJ0P6;Cz8oz6uu*(+4!r&VJb7F5BIyC za|0vvV`Nl9&d6fziQ$!AY`gRW6x**$Ne2C6`C<3C+5zaU$1x(r+bp}n zrFd?n<3~4JbvKsn-;6r>hF$%d)7YRDTp9=w9tFsJL&#(ct4H(&hGR@$i%bf-|3H>nA}LFPAEHnAR3fg=lW)wqjOCHZe=l+ZjCsTh$s(o znUWv0R8f0uocFE{5CtIcZXSg9Bf3Yyji*dY$Y60;4c zYUG;nNK15djxEMk$NqH8O;#3SmmX|cXfdjtaULUq7(?gW^C;kOu_#FK*%#dhp$)x< zVHS=N8(+~G+m&s8Xg#E^&d(rX2JejOD&g@qgUv?l+VbO8gBM#Zw+)to&wdzAZA2f( zHN2uMx3S-nTP*O5R=Eh0>3oELv7z@lzi%@^TuW%Y{k#kYomX=RE-%{;U#);$Fsi2| zB)Gu7(VUpmNGXNLKy(RI#Tej6!hr!NfNyojy%gX$pPjcg&Z*&3hFsh+?T827q*~wA zf|mS?TE2bja?m-m({tG*v%V_y^({?1e)h@J%67VADh(P(j>3UBUu<+%Vsg^ZdqW&> z7dF^nfA7D#0CW(}lHEYtsqe5X(@}Z&o$AwUC|-My2&;PkXOH7$I0;Q_jfidKW|*z^ z@)MdheDA;mn1;p-?H{wDxt0yEgJO*1xPy!5Y;{Lx^|{xB!tllLW{F#v+L>PFtZ2Kp zG0`^bjySyGVhSt6d(uFYOEh=G*saf6w}BszB)Q(p?Bt{uhog2VSfZ??b$!LQT-^C8 zvu!&|Q{`Sn^lD{u>L5UfEB=j_QLCl0p4S7D^=3O;V9Rb$jM=O|>6L;8m?Qc#Mdtv* z(B-0R8q3o-XVyn&g;x3+Cy&arE{_Cp`ty+c^wFmzN@67`Yh0P2n+4Alv26I5Y2`6*nq%ODaPo&;2GBttld`d>_wC-U8ji*b2$wq*Fvrz-g zS3_(!4a^X+i7?qR|FK)Vaj!LQ?%(D!bxAofmVGe-KeRO#<`3L!5MgVk0YBUD`?JR{ zotU@Llnt>6IN^7#rkRhDCfiugEC8gF^2EAi{TSy2q@a;Dp?|rVt45Dl9IPXbu$g(r zKZ~WMN=sr#P4lbXyGfH^NjHf}h-7Qim1d5(`@u{nvj+;^Mqy>f%iN?@`xdeVjmDyS z3OTHcozzTSV^#`w_+f*iQQSjR)k3ko>6BeATt8s+8<#i5`DDe?!R$iRV+BJ?EB=Y& zoz{2^LlMv-twjX?df9ard`~|y$-eM2D*2q|=~;*qXP*D&1tJtwfPCi1U8^h@ly*8xzpAk9m20m+O0+%1@6E zi8;$@Wg8YI`fR(SQ+u8xWIk}L+aSj6k{lF}24gm!A&xm2Y<+5kAXw0b1t}*ykd2i| zyAn8?o9gEjp=C~3OySLQEq$L@Ghqv-2Um;TH2J{euB9($iFOlOb;NeQ(Kllh^XZkQ zPNVta#=CAqjap;_sG}*2o!PC@ZQBYzIGgjru)ZhNT8!h38DYJ+qZ)=DR#Rypcg;n; z9T*$2n7FB1LBVb@30^zVB-<+=}e`8~0df zGZ$hfwg9*Al_5qC_YClM#xi*}eP=xWiFs5Wf4JZ)ODnHz?=4uxtu%_QFUjX89sM>b z8YXPCiOcV5n;%#0K87Po!~A((zZlc#?|TPy>RD;5^c^Y%Z!bBl?$ue}&lpaZR~0R^ z-nDXd+zEf|`*t>2;OPN{rKZFDp8H+4%3Cj|>@Q63n_pPOoR`L+c@?#(1<1y&vNI3Q zAfd-iVedBXHP8;f*v6W^;`oe5n?fB-Id0G2aa>3E$S9q4O;Jzri=w`?5bdp0n`}bP z*Q1lGg#csWuhPCHapsoG@!Zp`)(drl9)1BA52-H{r$;!%5|3uCTUSWEDZv*Y>*Z_i z`ib%SMu!E*2J#oPHibKb4~;7g=H}iWePY6V;cXv^xclmo%gVSm>nH9G#NGG__+pnR z?py4;^M~@akx(%3X(hfqd5ZM#tP^OM(bZO)VMTom3U88!>#vF+q3AK-OBPwZ zdvi=$W6(w?JvL=8%7aOY{R%G*2@P4-NbjEpB!r*E+Lw(EVLknq#UN%RAm#H*_yl-R zkd%34s8K14q5JH%CUJWBlOSR&DL7&>4IzmxO|i4E*}vel;y%Aqiy-))!JuF?Dob?d zyI(hd_&c`0gXEM8D*q1G4!oN0N<$!Sz`|8y0hf#4_)#!;UOUaG(a0CcT)9=;>=h*x z=RF*bm(E$6{(C4ps3_Q({EcY;{=l9U|A81Ftg5eqd>bhcn>3KG$6Yta_Sslj^b#gN zkS4j-TAerRudj_i+^l$dMt?D`4BxBbf<*%z*_Ed_y|!@u!T%Hn34at-GAT0|33l$ zpRWKDyGkrB08QHXaJ^LajPOk{(5|XUNVr+$Uu%Xl6v@!g(E4bx$@=bm+xh`^^}f}j zlI}krc~Akdm3235Fe)INS}D<^dZKwnS=#;N3I2n;l;lS!{Xf6k7$qTs|JHfq=l%Lu z%Uo}n-}y?{F?RpC_VN=Y6p_)?8fXKgYIGakRO{5y0YJ$LHEN}Q*}x|)KmwW$Do>Xx zjf9{%AKlzvOeFkH8shuU6(nSwU*bUg_19ggK}(GhW!ps>Z41^e z3swKmeU<-!sz=Vr2xC=k$bY~i5`6W~L1Sy>x6ZNDJfL+@kNn#s{T*}nDP|*&31_Et zgU7#o$$yUF?;gni{^g6LCe!}E_rw3bkU+=6Aay$(*W~#x22?eH{rNq`?Z0iG5MX-> zdF?Wj|KA_}=d&wkrZrL3R1o?v=70AfA)!%qy1t0}FAnJA3w+LU=GRpJ#r&QLu>EmY z+oEOuwO0OfQT)I5u0EdWwT+jDBI~H+B|=5%!Ko=PC2y6Nko4ju!&;>yMxu=j)9mSu z4($W{e~CcxO9O9EQBD>|mDHHP5}LX4dD~^WXE|*kIuRLAfwz4C-0}D`-wYT%| z-(g$`(DO$YKuO_E9Zn~5jpF9&93Rzv7wskxywZ$wH+o`dM z96>Kjdw~FK5Qbt#4=J_2CRHyKlEXo()ShZDxD+X$R33ZL1Sgu5IkZ~M(qN_8MaVNS zDk^ZHlcfDG#SWFuwbI=8jT%om2UHEBl0$Jx)pu)9d=b=Hhyw9#yp!C1t<8!!()_~U zbN#uk=~t@I@ZyMCPY=CsB)E(m(mvcqE$G|0CG)O`F3?A$%kb>U=D7hSdd6VeH(C>e zl=nT9I^oT+3E(4=+ zv#f10;{;yQQy)q6gGkEda2R-Z$ztRurBP-fKf3qh%(1M+KhzlTXil%;ydjB}g5|&0 z8FtnBL>O5Ab&70P*+GY;#lBgAr8)Sl%vJxF$tm9Wvo^@?NMX)T9m{E&uFkn{HKQCT z;QN?N9N2dFuEGje1m(&)_^-!5y||csEp0S;3)AoAV0q&nf(1H=%3~B!@n?l{;S*;Kkrd3-z?ofK#w=^IrnU_>CLz1lHb~>;-;^_a!!KzY-9h_Cb4=sq zR-a#~D%;zNytvUSSH-yb;fx`-d7bP1huNV^Gjo<1k$v+MfqgWc(f8n0n=PnT$7Joy zl8Or_67ug{0GFVg5}E-M9ELGLqpy^{PbHBB;K(gc_x=Hk?|mzvy?)9DXx0rf)5m|)k$1O6g zX88dNgKBLJ1(`8ieK|;wg~Jz!;UbhPc#K5Gt0Yb4TI-9gmT*p(Pl9vao;gDlE2{W#Qp-8g)!b{pr!I5{QXMk-=evu^ zKbLpXXR9WPk}@3gPh_UkwM>KDE&6ZZ8Ap{q7h3j+(xU8Q*%Io9GFntlosvz?c~^XI z1hK>L>;`t?wxd2Oc0Y&>3QT}F3!JtyZR0BN-ivccV}t&ZUkHu#;CU5?uAt7ldC}qv zfZNSvgxi+pZkstYe)cAk##NIah83YR9#PIiPpy zn@8XVu{|xBiyWFC3!FGxX+@9gbLruX^_pgR&)TeWEgM9rl0ZE$K=r3Gy3|{>z*vxz z!&BWagY}T<<~n8}-IirhKcKGqLOwO^@u3*C5YXYUvb;(g{0={w!y&qo4gVyFV#$xd zeG*SBoBjv&+AAX_&hgryPV7Jeg|}-JVG6Hu z2T7}VlZdSTFJtc!tYa~ejxrpg<3VYOqwFp3>_?`MTQ7n=m+P37q84)J4r|W}FCps4{?8{RzKI($=T~;();sCu!s@ya8HL zXG_W?iVpE)xC8)4m4E6KuXJ$VZ7w $out;; 'header' ) diff --git a/scripts/kernels.py b/scripts/kernels.py index 124b5d4e8..8e766d2da 100755 --- a/scripts/kernels.py +++ b/scripts/kernels.py @@ -84,6 +84,8 @@ def getkernelfuncs(w,R): #--work out the integration constant for the potential # parg = list(pot.args) + lastarg = len(pot.args) - 1 + parg[lastarg] = (sympify(-1/(q)),pot.args[lastarg].cond) if isinstance(pot, Piecewise): for i, (e, c) in reversed(list(enumerate(pot.args))): if i < len(pot.args) - 1: @@ -98,15 +100,28 @@ def getkernelfuncs(w,R): #--derivative of potential with respect to h # dpotdh = pot - parg = list(pot.args) + pharg = list(pot.args) if isinstance(pot, Piecewise): for i, (e, c) in enumerate(pot.args): ep = simplify(-e - q*diff(e,q)) - parg[i] = (ep, c) - tuple(parg) - dpotdh = Piecewise(*parg) + pharg[i] = (ep, c) + tuple(pharg) + dpotdh = Piecewise(*pharg) - return (dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh) + # + #--kernel function needed in gradient acceleration + # for 4th order Forward Symplectic Integrator + # + farg = list(fsoft.args) + if isinstance(fsoft, Piecewise): + for i, (e, c) in enumerate(fsoft.args): + ep = simplify(q*diff(e,q) - e) + farg[i] = (ep, c) + tuple(farg) + gsoft = Piecewise(*farg) + + #gsoft = piecewise_fold(simplify(diff(q*fsoft,q) - fsoft)) + return (dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh, gsoft) #--------------------------------------------- # function to get the variance of the kernel @@ -225,11 +240,12 @@ def printvariances(w,R): # function to print basic kernel information to the screen #----------------------------------------------------------- def printkernel(w,R): - dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh = getkernelfuncs(w,R) + dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh, gsoft = getkernelfuncs(w,R) print ("\n%s W:" %name) print (w) print ("\nFirst derivative:") print (dw) + #print (fmt(dw)) print ("\n2nd derivative:") print (d2w) print ("\nnormalisation:") @@ -241,6 +257,8 @@ def printkernel(w,R): avnorm = -pi/8*c2D*integrate(q*q*dw,(q,0,R)) print (avnorm) printvariances(w,R) + print ("\n gradient acceleration term:") + print (gsoft) return #------------------------------------------------------------- @@ -290,6 +308,10 @@ def fmt(e): # replace 15*x with 15.*x as long as it is not **15*x s = re.sub("(?!\*\d+)(\D\d+)\*","\g<1>.*", s) + # replace " 2)" with " 2.)" + # Use re.sub to replace " digit)" with " digit.)" + s = re.sub(r" (\d)\)", r" \1.)", s) + f = sympify(s) # # expand if it makes it shorter @@ -302,6 +324,9 @@ def fmt(e): # replace 1.4000000 with 1.4 g = re.sub("(\.[1-9]*)(0+)(\D|$)","\g<1>\g<3>", g) + # replace " 2)" with " 2.)" + # Use re.sub to replace " digit)" with " digit.)" + g = re.sub(r" (\d)\)", r" \1.)", g) # only return simplify-ed strings if no fully expanded floats 0.345242545.. if re.search("(\.\d\d\d\d\d+)",g): @@ -614,7 +639,7 @@ def print_decl(w): #--------------------------------- def printkernel_phantom(w,R,name): import datetime - dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh = getkernelfuncs(w,R) + dw, d2w, c1D, c2D, c3D, fsoft, pot, dpotdh, gsoft = getkernelfuncs(w,R) w0 = w.subs(q,0) dpotdh0 = dpotdh.subs(q,0) #print("GOT dpotdh0",simplify(dpotdh0)) @@ -627,31 +652,26 @@ def printkernel_phantom(w,R,name): lb = "!"+"-"*62 print ("!--------------------------------------------------------------------------!") print ("! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. !") - print ("! Copyright (c) 2007-2019 The Authors (see AUTHORS) !") + print ("! Copyright (c) 2007-2024 The Authors (see AUTHORS) !") print ("! See LICENCE file for usage and distribution conditions !") - print ("! http://phantomsph.bitbucket.io/ !") + print ("! http://phantomsph.github.io/ !") print ("!--------------------------------------------------------------------------!") - print ("!+") - print ("! MODULE: kernel") + print ("module kernel") print ("!") - print ("! DESCRIPTION:") - print ("! This module implements the %s kernel" %name) + print ("! This module implements the %s kernel" %name) print ("! DO NOT EDIT - auto-generated by kernels.py") print ("!") - print ("! REFERENCES: None") + print ("! :References: None") print ("!") - print ("! OWNER: Daniel Price") + print ("! :Owner: Daniel Price") print ("!") - print ("! $Id:$") + print ("! :Runtime parameters: None") print ("!") - print ("! RUNTIME PARAMETERS: None") + print ("! :Dependencies: physcon") print ("!") - print ("! DEPENDENCIES: physcon") + print ("! :Generated:",datetime.datetime.now()) print ("!") - print ("! GENERATED:",datetime.datetime.now()) - print ("!+") print ("!--------------------------------------------------------------------------") - print ("module kernel") print (" use physcon, only:pi") print (" implicit none") print (" character(len=%i), public :: kernelname = '%s'" %(len(name),name)) @@ -660,9 +680,9 @@ def printkernel_phantom(w,R,name): print (" real, parameter, public :: cnormk = %s" %fmt(c3D)) print (" real, parameter, public :: wab0 = %s, gradh0 = -3.*wab0" %fmt(w0)) print (" real, parameter, public :: dphidh0 = %s" %fmtp(dpotdh0)) - print (" real, parameter, public :: cnormk_drag = %s " %fmt(c3Ddrag)) + print (" real, parameter, public :: cnormk_drag = %s" %fmt(c3Ddrag)) var, relvar, reldev = getvar(w,R) - print (" real, parameter, public :: hfact_default = %.1f " %(1.2/reldev[2])) + print (" real, parameter, public :: hfact_default = %.1f" %(1.2/reldev[2])) #print " real, parameter, public :: hfact_default = %s " %fmt(reldev[2]) print (" real, parameter, public :: av_factor = %s" %fmt(avratio)) print ("\ncontains\n") @@ -774,7 +794,7 @@ def printkernel_phantom(w,R,name): print ("pure subroutine kernel_softening(q2,q,potensoft,fsoft)") print (" real, intent(in) :: q2,q") print (" real, intent(out) :: potensoft,fsoft") - print_decl(pot) + print_decl(fsoft) if isinstance(dw, Piecewise): for i, (de, c) in enumerate(dw.args): (pote, potc) = pot.args[i] @@ -793,6 +813,30 @@ def printkernel_phantom(w,R,name): print (" potensoft = %s" %fmtp(pot)) print (" fsoft = %s" %fmtp(fsoft)) print ("\nend subroutine kernel_softening\n") + + print ("!------------------------------------------") + print ("! gradient acceleration kernel needed for") + print ("! use in Forward symplectic integrator") + print ("!------------------------------------------") + print ("pure subroutine kernel_grad_soft(q2,q,gsoft)") + print (" real, intent(in) :: q2,q") + print (" real, intent(out) :: gsoft") + print_decl(gsoft) + if isinstance(dw, Piecewise): + for i, (de, c) in enumerate(dw.args): + (ge, gc) = gsoft.args[i] + if i == 0: + print (" if (%s) then" %fmt(c)) + elif i == len(dw.args)-1 and c == True: + print (" else") + else: + print (" elseif (%s) then" %fmt(c)) + print_defs(4,fmtp(ge)) + print (" gsoft = %s" %fmtp(ge)) + print (" endif") + else: + print (" gsoft = %s" %fmtp(gsoft)) + print ("\nend subroutine kernel_grad_soft\n") print ("!------------------------------------------") print ("! double-humped version of the kernel for") print ("! use in drag force calculations") @@ -956,8 +1000,8 @@ def f6(R): # define which kernel to use #f, name = sinq(R,3) -#f, name = m5(R) -f, name = w6(R) +f, name = m4(R) +#f, name = w6(R) #print_avdiss(f,R) #printvariances(f,R) diff --git a/scripts/stats.sh b/scripts/stats.sh index 9c9cc7d94..070486499 100755 --- a/scripts/stats.sh +++ b/scripts/stats.sh @@ -42,6 +42,11 @@ count_unique_matches() n=`cd $phantomdir; grep "$1" src/*/*.*90 | cut -d':' -f 2 | sort -u | wc -l`; echo "$n"; } +count_files_ending_in() +{ + n=`cd $phantomdir; ls src/*/*$1 | wc -l`; + echo "$n"; +} get_subroutine_count() { nsub=$(count_matches 'end subroutine'); @@ -59,12 +64,12 @@ get_lines_of_code() } get_setup_count() { - nsetup=`cd $phantomdir; grep 'ifeq ($(SETUP)' build/Makefile | grep -v skip | cut -d, -f 2 | cut -d')' -f 1 | wc -l`; + nsetup=`cd $phantomdir; grep 'ifeq ($(SETUP)' build/Makefile_setups | grep -v skip | cut -d, -f 2 | cut -d')' -f 1 | wc -l`; echo "$nsetup"; } get_system_count() { - nsystem=`cd $phantomdir; grep 'ifeq ($(SYSTEM)' build/Makefile | cut -d, -f 2 | cut -d')' -f 1 | wc -l`; + nsystem=`cd $phantomdir; grep 'ifeq ($(SYSTEM)' build/Makefile_systems | cut -d, -f 2 | cut -d')' -f 1 | wc -l`; echo $nsystem; } # @@ -126,12 +131,21 @@ get_build_status_from_git_tags() nauthors=$(get_author_count); ncode="$(get_lines_of_code)"; nifdef="$(count_unique_matches '#ifdef')"; +nifdefall="$(count_matches '#ifdef')"; +nfiles="$(count_files_ending_in '.*90')"; +nf90="$(count_files_ending_in '.f90')"; +nF90="$(count_files_ending_in '.F90')"; subcount="$(get_subroutine_count)"; nsetup="$(get_setup_count)"; nsystem="$(get_system_count)"; -echo "Lines of code: $ncode"; +echo "Lines of code: main setup tests utils"; +echo " $ncode"; echo "Number of modules, subroutines, functions: $subcount"; -echo "Number of #ifdef statements : $nifdef"; +echo "Number of source files (.f90, .F90): $nfiles"; +echo "Number of .f90 files : $nf90"; +echo "Number of .F90 files : $nF90"; +echo "Number of unique #ifdef statements : $nifdef"; +echo "Number of total #ifdef statements : $nifdefall"; echo "Number of authors : $nauthors"; echo "Number of SETUP= options : $nsetup"; echo "Number of SYSTEM= options : $nsystem"; diff --git a/src/main/eos.F90 b/src/main/eos.F90 deleted file mode 100644 index 55ae32e93..000000000 --- a/src/main/eos.F90 +++ /dev/null @@ -1,1617 +0,0 @@ -!--------------------------------------------------------------------------! -! 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 eos -! -! This module contains stuff to do with the equation of state -! Current options: -! 1 = isothermal eos -! 2 = adiabatic/polytropic eos -! 3 = eos for a locally isothermal disc as in Lodato & Pringle (2007) -! 4 = GR isothermal -! 5 = polytropic EOS with vary mu and gamma depending on H2 formation -! 6 = eos for a locally isothermal disc as in Lodato & Pringle (2007), -! centered on a sink particle -! 7 = z-dependent locally isothermal eos -! 8 = Barotropic eos -! 9 = Piecewise polytrope -! 10 = MESA EoS -! 11 = isothermal eos with zero pressure -! 12 = ideal gas with radiation pressure -! 13 = locally isothermal prescription from Farris et al. (2014) generalised for generic hierarchical systems -! 14 = locally isothermal prescription from Farris et al. (2014) for binary system -! 15 = Helmholtz free energy eos -! 16 = Shen eos -! 20 = Ideal gas + radiation + various forms of recombination energy from HORMONE (Hirai et al., 2020) -! 21 = read tabulated eos (for use with icooling == 9) -! -! :References: -! Lodato & Pringle (2007) -! Hirai et al. (2020) -! -! :Owner: Daniel Price -! -! :Runtime parameters: -! - X : *H mass fraction (ignored if variable composition)* -! - Z : *metallicity (ignored if variable composition)* -! - ieos : *eqn of state (1=isoth;2=adiab;3=locally iso;8=barotropic)* -! - metallicity : *metallicity* -! - mu : *mean molecular weight* -! -! :Dependencies: dim, dump_utils, eos_barotropic, eos_gasradrec, -! eos_helmholtz, eos_idealplusrad, eos_mesa, eos_piecewise, eos_shen, -! eos_stamatellos, eos_stratified, infile_utils, io, mesa_microphysics, -! part, physcon, units -! - use part, only:ien_etotal,ien_entropy,ien_type - use dim, only:gr - implicit none - integer, parameter, public :: maxeos = 21 - real, public :: polyk, polyk2, gamma - real, public :: qfacdisc = 0.75, qfacdisc2 = 0.75 - logical, public :: extract_eos_from_hdr = .false. - integer, public :: isink = 0. - - public :: equationofstate,setpolyk,eosinfo,utherm,en_from_utherm,get_mean_molecular_weight - public :: get_TempPresCs,get_spsound,get_temperature,get_pressure,get_cv - public :: eos_is_non_ideal,eos_outputs_mu,eos_outputs_gasP - public :: get_local_u_internal,get_temperature_from_u - public :: calc_rec_ene,calc_temp_and_ene,entropy,get_rho_from_p_s,get_u_from_rhoT - public :: calc_rho_from_PT,get_entropy,get_p_from_rho_s - public :: init_eos,finish_eos,write_options_eos,read_options_eos - public :: write_headeropts_eos, read_headeropts_eos - - private - - integer, public :: ieos = 1 - integer, public :: iopacity_type = 0 ! used for radiation - real, public :: gmw = 2.381 ! default mean molecular weight - real, public :: X_in = 0.74 ! default metallicities - real, public :: Z_in = 0.02 ! default metallicities - logical, public :: use_var_comp = .false. ! use variable composition - real, public :: temperature_coef - - logical, public :: done_init_eos = .false. - ! - ! error codes for calls to init_eos - ! - integer, public, parameter :: & - ierr_file_not_found = 1, & - ierr_option_conflict = 2, & - ierr_units_not_set = 3, & - ierr_isink_not_set = 4 - -! -! Default temperature prescription for vertical stratification (0=MAPS, 1=Dartois) -! - integer, public:: istrat = 0. -! -! 2D temperature structure fit parameters for HD 163296 -! - real, public :: z0 = 1. - real, public :: alpha_z = 3.01 - real, public :: beta_z = 0.42 - -contains - -!---------------------------------------------------------------- -!+ -! subroutine returns pressure/density as a function of density -! (and position in the case of the isothermal disc) -!+ -!---------------------------------------------------------------- -subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gamma_local,mu_local,Xlocal,Zlocal) - use io, only:fatal,error,warning - use part, only:xyzmh_ptmass, nptmass - use units, only:unit_density,unit_pressure,unit_ergg,unit_velocity - use physcon, only:kb_on_mh,radconst - use eos_mesa, only:get_eos_pressure_temp_gamma1_mesa,get_eos_1overmu_mesa - use eos_helmholtz, only:eos_helmholtz_pres_sound - use eos_shen, only:eos_shen_NL3 - use eos_idealplusrad - use eos_gasradrec, only:equationofstate_gasradrec - use eos_stratified, only:get_eos_stratified - use eos_barotropic, only:get_eos_barotropic - use eos_piecewise, only:get_eos_piecewise - use eos_stamatellos - integer, intent(in) :: eos_type - real, intent(in) :: rhoi,xi,yi,zi - real, intent(out) :: ponrhoi,spsoundi - real, intent(inout) :: tempi - real, intent(in), optional :: eni - real, intent(inout), optional :: mu_local,gamma_local - real, intent(in) , optional :: Xlocal,Zlocal - integer :: ierr, i - real :: r1,r2 - real :: mass_r, mass ! defined for generalised Farris prescription - real :: gammai,temperaturei,mui,imui,X_i,Z_i - real :: cgsrhoi,cgseni,cgspresi,presi,gam1,cgsspsoundi - real :: uthermconst,kappaBar,kappaPart,gmwi - real :: enthi,pondensi - ! - ! Check to see if equation of state is compatible with GR cons2prim routines - ! - if (gr .and. .not.any((/2,4,11,12/)==eos_type)) then - ponrhoi = 0.; spsoundi = 0. ! avoid compiler warning - call fatal('eos','GR currently only works for ieos=2,12 or 11',& - var='eos_type',val=real(eos_type)) - endif - - gammai = gamma - mui = gmw - X_i = X_in - Z_i = Z_in - if (present(gamma_local)) gammai = gamma_local - if (present(mu_local)) mui = mu_local - if (present(Xlocal)) X_i = Xlocal - if (present(Zlocal)) Z_i = Zlocal - - select case(eos_type) - case(1) -! -!--Isothermal eos -! -! :math:`P = c_s^2 \rho` -! -! where :math:`c_s^2 \equiv K` is a constant stored in the dump file header -! - ponrhoi = polyk - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - - case(2,5) -! -!--Adiabatic equation of state (code default) -! -! :math:`P = (\gamma - 1) \rho u` -! -! if the code is compiled with ISOTHERMAL=yes, ieos=2 gives a polytropic eos: -! -! :math:`P = K \rho^\gamma` -! -! where K is a global constant specified in the dump header -! - if (gammai < tiny(gammai)) call fatal('eos','gamma not set for adiabatic eos',var='gamma',val=gammai) - - if (gr) then - if (.not. present(eni)) call fatal('eos','GR call to equationofstate requires thermal energy as input!') - if (eni < 0.) call fatal('eos','utherm < 0',var='u',val=eni) - if (gammai <= 1.) then - spsoundi = 0.; ponrhoi = 0. ! avoid compiler warning - call fatal('eos','GR not compatible with isothermal equation of state, yet...',var='gamma',val=gammai) - elseif (gammai > 1.0001) then - pondensi = (gammai-1.)*eni ! eni is the thermal energy - enthi = 1. + eni + pondensi ! enthalpy - spsoundi = sqrt(gammai*pondensi/enthi) - ponrhoi = pondensi ! With GR this routine actually outputs pondensi (i.e. pressure on primitive density, not conserved.) - endif - else - if (present(eni)) then - if (eni < 0.) then - !write(iprint,'(a,Es18.4,a,4Es18.4)')'Warning: eos: u = ',eni,' < 0 at {x,y,z,rho} = ',xi,yi,zi,rhoi - call fatal('eos','utherm < 0',var='u',val=eni) - endif - if (gammai > 1.0001) then - ponrhoi = (gammai-1.)*eni ! use this if en is thermal energy - else - ponrhoi = 2./3.*eni ! en is thermal energy and gamma = 1 - endif - else - ponrhoi = polyk*rhoi**(gammai-1.) - endif - spsoundi = sqrt(gammai*ponrhoi) - endif - - tempi = temperature_coef*mui*ponrhoi - - case(3) -! -!--Locally isothermal disc as in Lodato & Pringle (2007) where -! -! :math:`P = c_s^2 (r) \rho` -! -! sound speed (temperature) is prescribed as a function of radius using: -! -! :math:`c_s = c_{s,0} r^{-q}` where :math:`r = \sqrt{x^2 + y^2 + z^2}` -! - ponrhoi = polyk*(xi**2 + yi**2 + zi**2)**(-qfacdisc) ! polyk is cs^2, so this is (R^2)^(-q) - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - - case(4) -! -!--Isothermal equation of state for GR, enforcing cs = constant -! -! .. WARNING:: this is experimental: use with caution -! - uthermconst = polyk - ponrhoi = (gammai-1.)*uthermconst - spsoundi = sqrt(ponrhoi/(1.+uthermconst)) - tempi = temperature_coef*mui*ponrhoi - - case(6) -! -!--Locally isothermal disc centred on sink particle -! -! As in ieos=3 but in this version radius is taken with respect to a designated -! sink particle (by default the first sink particle in the simulation) -! - ponrhoi = polyk*((xi-xyzmh_ptmass(1,isink))**2 + (yi-xyzmh_ptmass(2,isink))**2 + & - (zi-xyzmh_ptmass(3,isink))**2)**(-qfacdisc) ! polyk is cs^2, so this is (R^2)^(-q) - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - - case(7) -! -!--Vertically stratified equation of state -! -! sound speed is prescribed as a function of (cylindrical) radius R and -! height z above the x-y plane -! -! .. WARNING:: should not be used for misaligned discs -! - call get_eos_stratified(istrat,xi,yi,zi,polyk,polyk2,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,ponrhoi,spsoundi) - tempi = temperature_coef*mui*ponrhoi - - case(8) -! -!--Barotropic equation of state -! -! :math:`P = K \rho^\gamma` -! -! where the value of gamma (and K) are a prescribed function of density -! - call get_eos_barotropic(rhoi,polyk,polyk2,ponrhoi,spsoundi,gammai) - tempi = temperature_coef*mui*ponrhoi - - case(9) -! -!--Piecewise Polytropic equation of state -! -! :math:`P = K \rho^\gamma` -! -! where the value of gamma (and K) are a prescribed function of density. -! Similar to ieos=8 but with different defaults and slightly different -! functional form -! - call get_eos_piecewise(rhoi,ponrhoi,spsoundi,gammai) - tempi = temperature_coef*mui*ponrhoi - - case(10) -! -!--MESA equation of state -! -! a tabulated equation of state including gas, radiation pressure -! and ionisation/dissociation. MESA is a stellar evolution code, so -! this equation of state is designed for matter inside stars -! - cgsrhoi = rhoi * unit_density - cgseni = eni * unit_ergg - call get_eos_pressure_temp_gamma1_mesa(cgsrhoi,cgseni,cgspresi,temperaturei,gam1,ierr) - presi = cgspresi / unit_pressure - - ponrhoi = presi / rhoi - spsoundi = sqrt(gam1*ponrhoi) - tempi = temperaturei - if (present(gamma_local)) gamma_local = gam1 ! gamma is an output - if (present(mu_local)) mu_local = 1./get_eos_1overmu_mesa(cgsrhoi,cgseni) - if (ierr /= 0) call warning('eos_mesa','extrapolating off tables') - - case(11) -! -!--Isothermal equation of state with pressure and temperature equal to zero -! -! :math:`P = 0` -! -! useful for simulating test particle dynamics using SPH particles -! - ponrhoi = 0. - spsoundi = sqrt(polyk) - tempi = 0. - - case(12) -! -!--Ideal gas plus radiation pressure -! -! :math:`P = (\gamma - 1) \rho u` -! -! but solved by first solving the quartic equation: -! -! :math:`u = \frac32 \frac{k_b T}{\mu m_H} + \frac{a T^4}{\rho}` -! -! for temperature (given u), then solving for pressure using -! -! :math:`P = \frac{k_b T}{\mu m_H} + \frac13 a T^4` -! -! hence in this equation of state gamma (and temperature) are an output -! - temperaturei = tempi ! Required as initial guess - cgsrhoi = rhoi * unit_density - cgseni = eni * unit_ergg - call get_idealplusrad_temp(cgsrhoi,cgseni,mui,temperaturei,ierr) - call get_idealplusrad_pres(cgsrhoi,temperaturei,mui,cgspresi) - call get_idealplusrad_spsoundi(cgsrhoi,cgspresi,cgseni,spsoundi,gammai) - if (present(gamma_local)) gamma_local = gammai ! gamma is an output - spsoundi = spsoundi / unit_velocity - presi = cgspresi / unit_pressure - ponrhoi = presi / rhoi - tempi = temperaturei - if (ierr /= 0) call warning('eos_idealplusrad','temperature iteration did not converge') - - - case(13) -! -!--Locally isothermal eos for generic hierarchical system -! -! Assuming all sink particles are stars. -! Generalisation of Farris et al. (2014; for binaries) to N stars. -! For two sink particles this is identical to ieos=14 -! - mass_r = 0 - mass = 0 - - do i=1,nptmass - mass_r = mass_r+xyzmh_ptmass(4,i)/sqrt((xi-xyzmh_ptmass(1,i))**2 + (yi-xyzmh_ptmass(2,i))**2 + (zi-xyzmh_ptmass(3,i))**2) - mass = mass + xyzmh_ptmass(4,i) - enddo - ponrhoi=polyk*(mass_r)**(2*qfacdisc)/mass**(2*qfacdisc) - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - - - case(14) -! -!--Locally isothermal eos from Farris et al. (2014) for binary system -! -! uses the locations of the first two sink particles -! - r1 = sqrt((xi-xyzmh_ptmass(1,1))**2+(yi-xyzmh_ptmass(2,1))**2 + (zi-xyzmh_ptmass(3,1))**2) - r2 = sqrt((xi-xyzmh_ptmass(1,2))**2+(yi-xyzmh_ptmass(2,2))**2 + (zi-xyzmh_ptmass(3,2))**2) - ponrhoi=polyk*(xyzmh_ptmass(4,1)/r1+xyzmh_ptmass(4,2)/r2)**(2*qfacdisc)/(xyzmh_ptmass(4,1)+xyzmh_ptmass(4,2))**(2*qfacdisc) - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - - case(15) -! -!--Helmholtz equation of state (computed live, not tabulated) -! -! .. WARNING:: not widely tested in phantom, better to use ieos=10 -! - call eos_helmholtz_pres_sound(tempi, rhoi, ponrhoi, spsoundi, eni) - - case(16) -! -!--Shen (2012) equation of state for neutron stars -! -! this equation of state requires evolving temperature as the energy variable -! -! .. WARNING:: not tested: use with caution -! - if (present(eni)) then - cgsrhoi = rhoi * unit_density - !note eni is actually tempi - call eos_shen_NL3(cgsrhoi,eni,0.05,cgspresi,cgsspsoundi) - spsoundi=cgsspsoundi / unit_velocity - presi = cgspresi / unit_pressure - ponrhoi = presi / rhoi - tempi = eni - call warning('eos','Not sure if this is correct now that temperature is always passed into eos') - else - spsoundi = 0.; presi = 0.; ponrhoi = 0.; tempi = 0. ! to avoid compiler warnings - call fatal('eos','tried to call NL3 eos without passing temperature') - endif - - case(20) -! -!--Gas + radiation + various forms of recombination -! -! from HORMONE, Hirai+2020, as used in Lau+2022b -! - cgsrhoi = rhoi * unit_density - cgseni = eni * unit_ergg - imui = 1./mui - if (tempi > 0.) then - temperaturei = tempi - else - temperaturei = min(0.67 * cgseni * mui / kb_on_mh, (cgseni*cgsrhoi/radconst)**0.25) - endif - call equationofstate_gasradrec(cgsrhoi,cgseni*cgsrhoi,temperaturei,imui,X_i,1.-X_i-Z_i,cgspresi,cgsspsoundi,gammai) - ponrhoi = real(cgspresi / (unit_pressure * rhoi)) - spsoundi = real(cgsspsoundi / unit_velocity) - tempi = temperaturei - if (present(mu_local)) mu_local = 1./imui - if (present(gamma_local)) gamma_local = gammai - - case(21) -! -!--interpolate tabulated eos from Stamatellos+(2007). For use with icooling=9 -! - if (eni < 0.) then - call fatal('eos (stamatellos)','utherm < 0',var='u',val=eni) - endif - cgsrhoi = rhoi * unit_density - cgseni = eni * unit_ergg - call getopac_opdep(cgseni,cgsrhoi,kappaBar,kappaPart,tempi,mui) - cgspresi = kb_on_mh*cgsrhoi*tempi/mui - presi = cgspresi/unit_pressure - ponrhoi = presi/rhoi - gammai = 1.d0 + presi/(eni*rhoi) - !if (gammai < 1.d0 .or. gammai > 2.d0) then - ! print *, gammai, tempi, mui,cgseni,cgsrhoi,cgspresi - !endif - spsoundi = sqrt(gammai*ponrhoi) - - case default - spsoundi = 0. ! avoids compiler warnings - ponrhoi = 0. - tempi = 0. - call fatal('eos','unknown equation of state') - end select - -end subroutine equationofstate - -!----------------------------------------------------------------------- -!+ -! initialise equation of state (read tables etc.) -!+ -!----------------------------------------------------------------------- -subroutine init_eos(eos_type,ierr) - use units, only:unit_velocity - use physcon, only:Rg - use io, only:error,warning,fatal - use eos_mesa, only:init_eos_mesa - use eos_helmholtz, only:eos_helmholtz_init - use eos_piecewise, only:init_eos_piecewise - use eos_barotropic, only:init_eos_barotropic - use eos_shen, only:init_eos_shen_NL3 - use eos_gasradrec, only:init_eos_gasradrec - use eos_stamatellos,only:read_optab,init_S07cool,eos_file - use dim, only:maxvxyzu,do_radiation - integer, intent(in) :: eos_type - integer, intent(out) :: ierr - integer :: ierr_mesakapp - - ierr = 0 - ! - !--Set coefficient to convert P/rho into temperature - ! calculation will be in cgs; the mean molecular weight, gmw, will be - ! included in the function call rather than here - ! c_s^2 = gamma*P/rho = gamma*kT/(gmw*m_p) -> T = P/rho * (gmw*m_p)/k - ! - temperature_coef = unit_velocity**2 / Rg - - select case(eos_type) - case(6) - ! - !--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 - endif - - case(8) - ! - ! barotropic equation of state - ! - call init_eos_barotropic(polyk,polyk2,ierr) - - case(9) - ! - ! piecewise polytropic equation of state (similar to barotropic) - ! - call init_eos_piecewise(ierr) - - case(10) - ! - !--MESA EoS initialisation - ! - write(*,'(1x,a,f7.5,a,f7.5)') 'Initialising MESA EoS with X = ',X_in,', Z = ',Z_in - call init_eos_mesa(X_in,Z_in,ierr) - if (do_radiation .and. ierr==0) then - call error('eos','ieos=10, cannot use eos with radiation, will double count radiation pressure') - ierr=ierr_option_conflict !return error if using radiation and mesa EOS, shouldn't use mesa eos, as it will double count rad pres - endif - - case(12) - ! - ! ideal plus radiation - ! - write(*,'(1x,a,f7.5)') 'Using ideal plus radiation EoS with mu = ',gmw - if (do_radiation) then - call error('eos','ieos=12, cannot use eos with radiation, will double count radiation pressure') - ierr = ierr_option_conflict - endif - - case(15) - - call eos_helmholtz_init(ierr) - - case(16) - - call init_eos_shen_NL3(ierr) - - case(20) - - call init_eos_gasradrec(ierr) - if (.not. use_var_comp) then - write(*,'(a,f7.5,a,f7.5)') 'Assuming fixed composition X = ',X_in,', Z = ',Z_in - endif - if (do_radiation) then - call error('eos','ieos=20, cannot use eos with radiation, will double count radiation pressure') - ierr = ierr_option_conflict - endif - case(21) - call read_optab(eos_file,ierr) - if (ierr > 0) call fatal('init_eos','Failed to read EOS file') - call init_S07cool - - end select - done_init_eos = .true. - - if (do_radiation .and. iopacity_type==1) then - write(*,'(1x,a,f7.5,a,f7.5)') 'Using radiation with MESA opacities. Initialising MESA EoS with X = ',X_in,', Z = ',Z_in - call init_eos_mesa(X_in,Z_in,ierr_mesakapp) - ierr = max(ierr,ierr_mesakapp) - endif - -end subroutine init_eos - -!----------------------------------------------------------------------- -!+ -! finish equation of state -!+ -!----------------------------------------------------------------------- -subroutine finish_eos(eos_type,ierr) - use eos_mesa, only: finish_eos_mesa - use eos_stamatellos, only: finish_S07cool - - integer, intent(in) :: eos_type - integer, intent(out) :: ierr - - ierr = 0 - - select case(eos_type) - case(10) - ! - !--MESA EoS deallocation - ! - call finish_eos_mesa - - case(21) - ! Stamatellos deallocation - call finish_S07cool - end select - done_init_eos=.false. - -end subroutine finish_eos - -!----------------------------------------------------------------------- -!+ -! Calculate gas temperature, sound speed, and pressure. -! This will be required for various analysis routines if eos_vars -! is not saved in the dump files -!+ -!----------------------------------------------------------------------- -subroutine get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi,spsoundi,gammai,mui,Xi,Zi) - use dim, only:maxvxyzu - integer, intent(in) :: eos_type - real, intent(in) :: vxyzui(:),xyzi(:),rhoi - real, intent(inout) :: tempi - real, intent(out), optional :: presi,spsoundi - real, intent(inout), optional :: gammai,mui - real, intent(in), optional :: Xi,Zi - real :: csi,ponrhoi,mu,X,Z - logical :: use_gamma - - mu = gmw - X = X_in - Z = Z_in - if (present(mui)) mu = mui - if (present(Xi)) X = Xi - if (present(Zi)) Z = Zi - use_gamma = .false. - if (present(gammai)) then - if (gammai > 0.) use_gamma = .true. - endif - - if (maxvxyzu==4) then - 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) - else - call equationofstate(eos_type,ponrhoi,csi,rhoi,xyzi(1),xyzi(2),xyzi(3),tempi,vxyzui(4),& - mu_local=mu,Xlocal=X,Zlocal=Z) - endif - else - call equationofstate(eos_type,ponrhoi,csi,rhoi,xyzi(1),xyzi(2),xyzi(3),tempi,mu_local=mu) - endif - - if (present(presi)) presi = ponrhoi*rhoi - if (present(spsoundi)) spsoundi = csi - if (present(mui)) mui = mu - if (present(gammai)) gammai = gamma - -end subroutine get_TempPresCs - -!----------------------------------------------------------------------- -!+ -! Wrapper function to calculate sound speed -!+ -!----------------------------------------------------------------------- -real function get_spsound(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) - integer, intent(in) :: eos_type - real, intent(in) :: xyzi(:),rhoi - real, intent(in) :: vxyzui(:) - real, intent(in), optional :: Xi,Zi - real, intent(inout), optional :: gammai,mui - real :: spsoundi,tempi,gam,mu,X,Z - - !set defaults for variables not passed in - mu = gmw - X = X_in - Z = Z_in - tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess - gam = -1. ! to indicate gamma is not being passed in - if (present(Xi)) X = Xi - if (present(Zi)) Z = Zi - if (present(gammai)) gam = gammai - if (present(mui)) mu = mui - - call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,spsoundi=spsoundi,gammai=gam,mui=mu,Xi=X,Zi=Z) - - get_spsound = spsoundi - - if (present(mui)) mui = mu - if (present(gammai)) gammai = gam - -end function get_spsound - -!----------------------------------------------------------------------- -!+ -! Wrapper function to calculate temperature -!+ -!----------------------------------------------------------------------- -real function get_temperature(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) - integer, intent(in) :: eos_type - real, intent(in) :: xyzi(:),rhoi - real, intent(in) :: vxyzui(:) - real, intent(in), optional :: Xi,Zi - real, intent(inout),optional :: gammai,mui - real :: tempi,gam,mu,X,Z - - !set defaults for variables not passed in - mu = gmw - X = X_in - Z = Z_in - tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess - gam = -1. ! to indicate gamma is not being passed in - if (present(Xi)) X = Xi - if (present(Zi)) Z = Zi - if (present(gammai)) gam = gammai - if (present(mui)) mu = mui - - call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,gammai=gam,mui=mu,Xi=X,Zi=Z) - - get_temperature = tempi - - if (present(mui)) mui = mu - if (present(gammai)) gammai = gam - -end function get_temperature - - -!----------------------------------------------------------------------- -!+ -! Wrapper function to calculate temperature -!+ -!----------------------------------------------------------------------- -real function get_temperature_from_u(eos_type,xpi,ypi,zpi,rhoi,ui,gammai,mui,Xi,Zi) - integer, intent(in) :: eos_type - real, intent(in) :: xpi,ypi,zpi,rhoi - real, intent(in) :: ui - real, intent(in), optional :: Xi,Zi - real, intent(inout),optional :: gammai,mui - real :: tempi,gam,mu,X,Z - real :: vxyzui(4),xyzi(3) - - !set defaults for variables not passed in - mu = gmw - X = X_in - Z = Z_in - tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess - gam = -1. ! to indicate gamma is not being passed in - if (present(Xi)) X = Xi - if (present(Zi)) Z = Zi - if (present(gammai)) gam = gammai - if (present(mui)) mu = mui - - vxyzui = (/0.,0.,0.,ui/) - xyzi = (/xpi,ypi,zpi/) - call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,gammai=gam,mui=mu,Xi=X,Zi=Z) - - get_temperature_from_u = tempi - - if (present(mui)) mui = mu - if (present(gammai)) gammai = gam - - -end function get_temperature_from_u -!----------------------------------------------------------------------- -!+ -! Wrapper function to calculate pressure -!+ -!----------------------------------------------------------------------- -real function get_pressure(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) - integer, intent(in) :: eos_type - real, intent(in) :: xyzi(:),rhoi,vxyzui(:) - real, intent(in), optional :: Xi,Zi - real, intent(inout),optional :: gammai,mui - real :: presi,tempi,gam,mu,X,Z - - !set defaults for variables not passed in - mu = gmw - X = X_in - Z = Z_in - tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess - gam = -1. ! to indicate gamma is not being passed in - if (present(mui)) mu = mui - if (present(Xi)) X = Xi - if (present(Zi)) Z = Zi - if (present(gammai)) gam = gammai - if (present(mui)) mu = mui - - call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi=presi,gammai=gam,mui=mu,Xi=X,Zi=Z) - - get_pressure = presi - - if (present(mui)) mui = mu - if (present(gammai)) gammai = gam - -end function get_pressure - -!----------------------------------------------------------------------- -!+ -! query function to return the internal energy for calculations with a -! local mean molecular weight and local adiabatic index -!+ -!----------------------------------------------------------------------- -real function get_local_u_internal(gammai, gmwi, gas_temp_local) - real, intent(in) :: gammai, gmwi, gas_temp_local - real :: ponrhoi - - ponrhoi = gas_temp_local/(gmwi*temperature_coef) - get_local_u_internal = ponrhoi/(gammai-1.) - -end function get_local_u_internal - -!----------------------------------------------------------------------- -!+ -! get u from rho, T -!+ -!----------------------------------------------------------------------- -real function get_u_from_rhoT(rho,temp,eos_type,uguess) result(u) - use eos_mesa, only:get_eos_u_from_rhoT_mesa - integer, intent(in) :: eos_type - real, intent(in) :: rho,temp - real, intent(in), optional :: uguess - - select case (eos_type) - case(10) ! MESA EoS - if (present(uguess)) then - call get_eos_u_from_rhoT_mesa(rho,temp,u,uguess) - else - call get_eos_u_from_rhoT_mesa(rho,temp,u) - endif - - case default - u = temp/(gmw*temperature_coef*(gamma-1.)) - end select - -end function get_u_from_rhoT - - -!----------------------------------------------------------------------- -!+ -! the following two functions transparently handle evolution -! of the entropy instead of the thermal energy -!+ -!----------------------------------------------------------------------- -real function utherm(vxyzui,rho,gammai) - real, intent(in) :: vxyzui(4),rho,gammai - real :: gamm1,en - - en = vxyzui(4) - if (gr) then - utherm = en - elseif (ien_type == ien_entropy) then - gamm1 = (gammai - 1.) - if (gamm1 > tiny(gamm1)) then - utherm = (en/gamm1)*rho**gamm1 - else - stop 'gamma=1 using entropy evolution' - endif - elseif (ien_type == ien_etotal) then - utherm = en - 0.5*dot_product(vxyzui(1:3),vxyzui(1:3)) - else - utherm = en - endif - -end function utherm - -!----------------------------------------------------------------------- -!+ -! function to transparently handle evolution of the entropy -! instead of the thermal energy -!+ -!----------------------------------------------------------------------- -real function en_from_utherm(vxyzui,rho,gammai) - real, intent(in) :: vxyzui(4),rho,gammai - real :: gamm1,utherm - - utherm = vxyzui(4) - if (gr) then - en_from_utherm = utherm - elseif (ien_type == ien_entropy) then - gamm1 = gammai - 1. - if (gamm1 > tiny(gamm1)) then - en_from_utherm = gamm1*utherm*rho**(1.-gamma) - else - stop 'gamma=1 using entropy evolution' - endif - elseif (ien_type == ien_etotal) then - en_from_utherm = utherm + 0.5*dot_product(vxyzui(1:3),vxyzui(1:3)) - else - en_from_utherm = utherm - endif - -end function en_from_utherm - -!----------------------------------------------------------------------- -!+ -! Get recombination energy (per unit mass) assumming complete -! ionisation -!+ -!----------------------------------------------------------------------- -subroutine calc_rec_ene(XX,YY,e_rec) - real, intent(in) :: XX, YY - real, intent(out) :: e_rec - real :: e_H2,e_HI,e_HeI,e_HeII - real, parameter :: e_ion_H2 = 1.312e13, & ! ionisation energies in erg/mol - e_ion_HI = 4.36e12, & - e_ion_HeI = 2.3723e13, & - e_ion_HeII = 5.2505e13 - - ! XX : Hydrogen mass fraction - ! YY : Helium mass fraction - ! e_rec : Total ionisation energy due to H2, HI, HeI, and HeII - - e_H2 = 0.5 * XX * e_ion_H2 - e_HI = XX * e_ion_HI - e_HeI = 0.25 * YY * e_ion_HeI - e_HeII = 0.25 * YY * e_ion_HeII - e_rec = e_H2 + e_HI + e_HeI + e_HeII - -end subroutine calc_rec_ene - -!----------------------------------------------------------------------- -!+ -! Calculate temperature and specific internal energy from -! pressure and density. Inputs and outputs are in cgs units. -! -! Note on composition: -! For ieos=2, 5 and 12, mu_local is an input, X & Z are not used -! For ieos=10, mu_local is not used -! For ieos=20, mu_local is not used but available as an output -!+ -!----------------------------------------------------------------------- -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 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 - integer, intent(in) :: eos_type - real, intent(in) :: rho,pres - real, intent(inout) :: ene,temp - real, intent(in), optional :: guesseint,X_local,Z_local - real, intent(inout), optional :: mu_local - integer, intent(out) :: ierr - real :: mu,X,Z - - ierr = 0 - mu = gmw - X = X_in - Z = Z_in - if (present(mu_local)) mu = mu_local - if (present(X_local)) X = X_local - if (present(Z_local)) Z = Z_local - select case(eos_type) - case(2,5) ! Ideal gas - temp = pres / (rho * kb_on_mh) * mu - ene = pres / ( (gamma-1.) * rho) - case(12) ! Ideal gas + radiation - call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) - call get_idealplusrad_enfromtemp(rho,temp,mu,ene) - case(10) ! MESA EoS - call get_eos_eT_from_rhop_mesa(rho,pres,ene,temp,guesseint) - case(20) ! Ideal gas + radiation + recombination (from HORMONE, Hirai et al., 2020) - call calc_uT_from_rhoP_gasradrec(rho,pres,X,1.-X-Z,temp,ene,mu,ierr) - if (present(mu_local)) mu_local = mu - case default - ierr = 1 - end select - -end subroutine calc_temp_and_ene - -!----------------------------------------------------------------------- -!+ -! Calculate density from pressure and temperature. Inputs and outputs -! are in cgs units. -! -! Note on composition: -! For ieos=2 and 12, mu_local is an input, X & Z are not used -! For ieos=10, mu_local is not used -! For ieos=20, mu_local is not used but available as an output -!+ -!----------------------------------------------------------------------- -subroutine calc_rho_from_PT(eos_type,pres,temp,rho,ierr,mu_local,X_local,Z_local) - use physcon, only:kb_on_mh - 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 - integer, intent(in) :: eos_type - real, intent(in) :: pres,temp - real, intent(inout) :: rho - real, intent(in), optional :: X_local,Z_local - real, intent(inout), optional :: mu_local - integer, intent(out) :: ierr - real :: mu,X,Z - - ierr = 0 - mu = gmw - X = X_in - Z = Z_in - if (present(mu_local)) mu = mu_local - if (present(X_local)) X = X_local - if (present(Z_local)) Z = Z_local - select case(eos_type) - case(2) ! Ideal gas - rho = pres / (temp * kb_on_mh) * mu - case(12) ! Ideal gas + radiation - call get_idealplusrad_rhofrompresT(pres,temp,mu,rho) - case default - ierr = 1 - end select - -end subroutine calc_rho_from_PT - -!----------------------------------------------------------------------- -!+ -! Calculates specific entropy (gas + radiation + recombination) -! up to an additive integration constant, from density and pressure. -!+ -!----------------------------------------------------------------------- -function entropy(rho,pres,mu_in,ientropy,eint_in,ierr) - use io, only:fatal,warning - use physcon, only:radconst,kb_on_mh - 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 - integer, intent(in) :: ientropy - integer, intent(out), optional :: ierr - real :: mu,entropy,logentropy,temp,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) - - ! check temp - if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') - - case(2) ! Include both gas and radiation entropy (up to additive constants) - temp = pres * mu / (rho * kb_on_mh) ! Guess for temp - 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) - - ! check temp - if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') - - 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') - - if (present(eint_in)) then - eint = eint_in - else - call get_eos_eT_from_rhop_mesa(rho,pres,eint,temp) - endif - - ! Get entropy from rho and eint from MESA tables - if (present(ierr)) then - call getvalue_mesa(rho,eint,9,logentropy,ierr) - else - call getvalue_mesa(rho,eint,9,logentropy) - endif - entropy = 10.**logentropy - - case default - entropy = 0. - call fatal('eos','Unknown ientropy (can only be 1, 2, or 3)') - end select - -end function entropy - -real function get_entropy(rho,pres,mu_in,ieos) - use units, only:unit_density,unit_pressure,unit_ergg - use physcon, only:kboltz - integer, intent(in) :: ieos - real, intent(in) :: rho,pres,mu_in - real :: cgsrho,cgspres,cgss - - cgsrho = rho * unit_density - cgspres = pres * unit_pressure - select case (ieos) - case (12) - cgss = entropy(cgsrho,cgspres,mu_in,2) - case (10, 20) - cgss = entropy(cgsrho,cgspres,mu_in,3) - case default - cgss = entropy(cgsrho,cgspres,mu_in,1) - end select - cgss = cgss/kboltz ! s/kb - get_entropy = cgss/unit_ergg - -end function get_entropy - -!----------------------------------------------------------------------- -!+ -! Calculate density given pressure and entropy using Newton-Raphson -! method -!+ -!----------------------------------------------------------------------- -subroutine get_rho_from_p_s(pres,S,rho,mu,rhoguess,ientropy) - real, intent(in) :: pres,S,mu,rhoguess - real, intent(inout) :: rho - real :: srho,srho_plus_dsrho,S_plus_dS,dSdsrho - real(kind=8) :: corr - real, parameter :: eoserr=1e-9,dfac=1e-12 - integer, intent(in) :: ientropy - - ! We apply the Newton-Raphson method directly to rho^1/2 ("srho") instead - ! of rho since S(rho) cannot take a negative argument. - srho = sqrt(rhoguess) ! Initial guess - corr = huge(corr); - do while (abs(corr) > eoserr*abs(srho)) - ! First calculate dS/dsrho - srho_plus_dsrho = srho * (1. + dfac) - S_plus_dS = entropy(srho_plus_dsrho**2,pres,mu,ientropy) - dSdsrho = (S_plus_dS - entropy(srho**2,pres,mu,ientropy)) / (srho_plus_dsrho - srho) - corr = ( entropy(srho**2,pres,mu,ientropy) - S ) / dSdsrho - srho = srho - corr - enddo - rho = srho**2 - -end subroutine get_rho_from_p_s - -!----------------------------------------------------------------------- -!+ -! Calculate temperature given density and entropy using Newton-Raphson -! method -!+ -!----------------------------------------------------------------------- -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 io, only:fatal - use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_pres - use units, only:unit_density,unit_pressure,unit_ergg - real, intent(in) :: S,mu,rho - real, intent(inout) :: temp - real, intent(out) :: P - integer, intent(in) :: ieos - real :: corr,df,f,temp_new,cgsrho,cgsp,cgss - real, parameter :: eoserr=1e-12 - integer :: niter - integer, parameter :: nitermax = 1000 - - ! change to cgs unit - cgsrho = rho*unit_density - cgss = s*unit_ergg - - niter = 0 - select case (ieos) - case (2,5) - temp = (cgsrho * exp(mu*cgss*mass_proton_cgs))**(2./3.) - cgsP = cgsrho*kb_on_mh*temp / mu - case (12) - corr = huge(corr) - do while (abs(corr) > eoserr .and. niter < nitermax) - f = 1. / (mu*mass_proton_cgs) * log(temp**1.5/cgsrho) + 4.*radconst*temp**3 / (3.*cgsrho*kboltz) - cgss - df = 1.5 / (mu*temp*mass_proton_cgs) + 4.*radconst*temp**2 / (cgsrho*kboltz) - corr = f/df - temp_new = temp - corr - if (temp_new > 1.2 * temp) then - temp = 1.2 * temp - elseif (temp_new < 0.8 * temp) then - temp = 0.8 * temp - else - temp = temp_new - endif - niter = niter + 1 - enddo - call get_idealplusrad_pres(cgsrho,temp,mu,cgsP) - case default - cgsP = 0. - call fatal('eos','[get_p_from_rho_s] only implemented for eos 2 and 12') - end select - - ! check temp - if (temp > huge(0.)) call fatal('entropy','entropy too large gives infinte temperature, & - &reducing entropy factor C_ent for one dump') - - ! change back to code unit - P = cgsP / unit_pressure - -end subroutine get_p_from_rho_s - -!----------------------------------------------------------------------- -!+ -! Calculate mean molecular weight from X and Z, assuming complete -! ionisation -!+ -!----------------------------------------------------------------------- -real function get_mean_molecular_weight(XX,ZZ) result(mu) - real, intent(in) :: XX,ZZ - real :: YY - - YY = 1.-XX-ZZ - mu = 1./(2.*XX + 0.75*YY + 0.5*ZZ) - -end function get_mean_molecular_weight - -!--------------------------------------------------------- -!+ -! return cv from rho, u in code units -!+ -!--------------------------------------------------------- -real function get_cv(rho,u,cv_type) result(cv) - use mesa_microphysics, only:getvalue_mesa - use units, only:unit_ergg,unit_density - use physcon, only:Rg - real, intent(in) :: rho,u - integer, intent(in) :: cv_type - real :: rho_cgs,u_cgs,temp - - select case (cv_type) - - case(1) ! MESA EoS - rho_cgs = rho*unit_density - u_cgs = u*unit_ergg - call getvalue_mesa(rho_cgs,u_cgs,4,temp) - cv = u_cgs/temp / unit_ergg - case default ! constant cv - cv = Rg/((gamma-1.)*gmw*unit_ergg) - end select - -end function get_cv - -!----------------------------------------------------------------------- -!+ -! subroutine sets polyk based on utherm/positions -! read from an sphNG dump file -!+ -!----------------------------------------------------------------------- -subroutine setpolyk(eos_type,iprint,utherm,xyzhi,npart) - use part, only:xyzmh_ptmass - use io, only:id,master - integer, intent(in) :: eos_type,iprint - real, intent(in) :: utherm(:) - real, intent(in) :: xyzhi(:,:) - integer, intent(in) :: npart - integer :: ipart - real :: r2,polykalt - - !-- pick a random particle from which to extract polyk - ipart = npart/2 - - select case(eos_type) - case(1,8) -! -!--isothermal eos -! - polykalt = 2./3.*utherm(ipart) - !--check all other utherms identical - if (any(utherm(1:npart) /= utherm(ipart)) .and. id==master) then - write(iprint,*) 'WARNING! different utherms but run is isothermal' - endif - - case(2,5) -! -!--adiabatic/polytropic eos -! this routine is ONLY called if utherm is NOT stored, so polyk matters -! - if (id==master) write(iprint,*) 'Using polytropic equation of state, gamma = ',gamma - polykalt = 2./3.*utherm(ipart) - if (gamma <= 1.00000001) then - stop 'silly to use gamma==1 without using isothermal eos' - endif - - case(3) -! -!--locally isothermal disc as in Lodato & Pringle (2007) -! cs = cs_0*R^(-q) -- polyk is cs^2, so this is (R^2)^(-q) -! - r2 = xyzhi(1,ipart)*xyzhi(1,ipart) + xyzhi(2,ipart)*xyzhi(2,ipart) & - + xyzhi(3,ipart)*xyzhi(3,ipart) - polykalt = 2./3.*utherm(ipart)*r2**qfacdisc - - case(6) -! -!--locally isothermal disc as in Lodato & Pringle (2007), centered on specified sink particle -! cs = cs_0*R^(-q) -- polyk is cs^2, so this is (R^2)^(-q) -! - r2 = (xyzhi(1,ipart)-xyzmh_ptmass(1,isink))**2 + & - (xyzhi(2,ipart)-xyzmh_ptmass(2,isink))**2 + & - (xyzhi(3,ipart)-xyzmh_ptmass(3,isink))**2 - - polykalt = 2./3.*utherm(ipart)*r2**qfacdisc - case default -! -!--don't die in this routine as it can be called from readdump -! (ie. not necessarily as part of a run) -! - if (id==master) write(iprint,*) ' WARNING! unknown equation of state in setpolyk' - polykalt = polyk - - end select - - if (diff(polykalt,polyk) .and. id==master) then - write(iprint,*) 'WARNING! polyk set using RK2 in dump differs from that set using thermal energy' - write(iprint,*) 'using polyk = ',polykalt, ' (from RK2 = ',polyk,')' - endif - polyk = polykalt -! -!--warn if polyk is zero, die if negative -! - if (polyk < 0.) then - write(iprint,*) 'ERROR: polyk < 0 in setting equation of state' - stop - elseif (polyk < tiny(polyk) .and. id==master) then - write(iprint,*) 'WARNING: polyk = 0 in equation of state' - endif - -end subroutine setpolyk -!----------------------------------------------------------------------- -!+ -! small utility returns whether two real numbers differ -!+ -!----------------------------------------------------------------------- -logical pure function diff(r1,r2) - real, intent(in) :: r1,r2 - - diff = abs(r1-r2) > tiny(r1) - -end function diff - -!----------------------------------------------------------------------- -!+ -! Query function to return whether an EoS is non-ideal -! Mainly used to decide whether it is necessary to write -! things like pressure and temperature in the dump file or not -!+ -!----------------------------------------------------------------------- -logical function eos_is_non_ideal(ieos) - integer, intent(in) :: ieos - - select case(ieos) - case(10,12,15,20) - eos_is_non_ideal = .true. - case default - eos_is_non_ideal = .false. - end select - -end function eos_is_non_ideal - -!----------------------------------------------------------------------- -!+ -! Query function to return whether an EoS outputs mean molecular weight -!+ -!----------------------------------------------------------------------- -logical function eos_outputs_mu(ieos) - integer, intent(in) :: ieos - - select case(ieos) - case(20) - eos_outputs_mu = .true. - case(21) - eos_outputs_mu = .true. - case default - eos_outputs_mu = .false. - end select - -end function eos_outputs_mu - -!----------------------------------------------------------------------- -!+ -! Query function to whether to print pressure to dump file -!+ -!----------------------------------------------------------------------- -logical function eos_outputs_gasP(ieos) - integer, intent(in) :: ieos - - select case(ieos) - case(8,9,10,15) - eos_outputs_gasP = .true. - case default - eos_outputs_gasP = .false. - end select - -end function eos_outputs_gasP - -!----------------------------------------------------------------------- -!+ -! prints equation of state info in the run header -!+ -!----------------------------------------------------------------------- -subroutine eosinfo(eos_type,iprint) - use dim, only:maxvxyzu - use io, only:fatal,id,master - use eos_helmholtz, only:eos_helmholtz_eosinfo - use eos_barotropic, only:eos_info_barotropic - use eos_piecewise, only:eos_info_piecewise - use eos_gasradrec, only:eos_info_gasradrec - use eos_stamatellos, only:eos_file - integer, intent(in) :: eos_type,iprint - - if (id/=master) return - - select case(eos_type) - case(1,11) - if (1.0d-5 < polyk .and. polyk < 1.0d3) then - write(iprint,"(/,a,f10.6)") ' Isothermal equation of state: cs^2 = ',polyk - else - write(iprint,"(/,a,Es13.6)") ' Isothermal equation of state: cs^2 = ',polyk - endif - if (eos_type==11) write(iprint,*) ' (ZERO PRESSURE) ' - case(2) - if (maxvxyzu >= 4) then - write(iprint,"(/,a,f10.6,a,f10.6)") ' Adiabatic equation of state: P = (gamma-1)*rho*u, gamma = ',& - gamma,' gmw = ',gmw - else - write(iprint,"(/,a,f10.6,a,f10.6,a,f10.6)") ' Polytropic equation of state: P = ',polyk,'*rho^',gamma,' gmw = ',gmw - endif - case(3) - write(iprint,"(/,a,f10.6,a,f10.6)") ' Locally isothermal eq of state (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc - case(5) - if (maxvxyzu >= 4) then - write(iprint,"(' Adiabatic equation of state: P = (gamma-1)*rho*u, where gamma & mu depend on the formation of H2')") - else - stop '[stop eos] eos = 5 cannot assume isothermal conditions' - endif - case(6) - write(iprint,"(/,a,i2,a,f10.6,a,f10.6)") ' Locally (on sink ',isink, & - ') isothermal eos (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc - case(8) - call eos_info_barotropic(polyk,polyk2,iprint) - case(9) - call eos_info_piecewise(iprint) - case(10) - write(iprint,"(/,a,f10.6,a,f10.6,a,f10.6,a)") ' MESA EoS: X = ',X_in,' Z = ',Z_in,' (1-X-Z = ',1.-X_in-Z_in,')' - case(12) - write(iprint,"(/,a,f10.6,a,f10.6)") ' Gas + radiation equation of state: gmw = ',gmw,' gamma = ',gamma - case(15) - call eos_helmholtz_eosinfo(iprint) - case(20) - call eos_info_gasradrec(iprint) - if (use_var_comp) then - write(*,'(1x,a,i1,a)') 'Using variable composition' - else - write(*,'(1x,a,f10.6,a,f10.6)') 'Using fixed composition X = ',X_in,", Z = ",Z_in - endif - case(21) - write(iprint,"(/,a,a)") 'Using tabulated Eos from file:', eos_file, 'and calculated gamma.' - end select - write(iprint,*) - -end subroutine eosinfo - -!----------------------------------------------------------------------- -!+ -! write relevant options to the header of the dump file -!+ -!----------------------------------------------------------------------- -subroutine write_headeropts_eos(ieos,hdr,ierr) - use dump_utils, only:dump_h,add_to_rheader,add_to_iheader - integer, intent(in) :: ieos - type(dump_h), intent(inout) :: hdr - integer, intent(out) :: ierr - - call add_to_iheader(isink,'isink',hdr,ierr) - call add_to_rheader(gamma,'gamma',hdr,ierr) - call add_to_rheader(1.5*polyk,'RK2',hdr,ierr) - call add_to_rheader(polyk2,'polyk2',hdr,ierr) - call add_to_rheader(qfacdisc,'qfacdisc',hdr,ierr) - call add_to_rheader(qfacdisc2,'qfacdisc2',hdr,ierr) - - if (ieos==7) then - call add_to_iheader(istrat,'istrat',hdr,ierr) - call add_to_rheader(alpha_z,'alpha_z',hdr,ierr) - call add_to_rheader(beta_z,'beta_z',hdr,ierr) - call add_to_rheader(z0,'z0',hdr,ierr) - endif - -end subroutine write_headeropts_eos - -!----------------------------------------------------------------------- -!+ -! read relevant options from the header of the dump file -!+ -!----------------------------------------------------------------------- -subroutine read_headeropts_eos(ieos,hdr,ierr) - use dump_utils, only:dump_h, extract - use io, only:iprint,id,master - use dim, only:use_krome,maxvxyzu - integer, intent(in) :: ieos - type(dump_h), intent(in) :: hdr - integer, intent(out) :: ierr - real :: RK2 - - - call extract('gamma',gamma,hdr,ierr) - call extract('RK2',rk2,hdr,ierr) - polyk = 2./3.*rk2 - if (id==master) then - if (maxvxyzu >= 4) then - if (use_krome) then - write(iprint,*) 'KROME eos: initial gamma = 1.666667' - elseif (ieos==21) then - write(iprint,*) 'Tabulated eos with derived gamma' - else - write(iprint,*) 'adiabatic eos: gamma = ',gamma - endif - else - write(iprint,*) 'setting isothermal sound speed^2 (polyk) = ',polyk,' gamma = ',gamma - if (polyk <= tiny(polyk)) write(iprint,*) 'WARNING! sound speed zero in dump!, polyk = ',polyk - endif - endif - call extract('polyk2',polyk2,hdr,ierr) - call extract('qfacdisc',qfacdisc,hdr,ierr) - call extract('qfacdisc2',qfacdisc2,hdr,ierr) - call extract('isink',isink,hdr,ierr) - - if (abs(gamma-1.) > tiny(gamma) .and. maxvxyzu < 4) then - write(*,*) 'WARNING! compiled for isothermal equation of state but gamma /= 1, gamma=',gamma - endif - - ierr = 0 - if (ieos==3 .or. ieos==6 .or. ieos==7) then - if (qfacdisc <= tiny(qfacdisc)) then - if (id==master) write(iprint,*) 'ERROR: qfacdisc <= 0' - ierr = 2 - else - if (id==master) write(iprint,*) 'qfacdisc = ',qfacdisc - endif - endif - - if (ieos==7) then - call extract('istrat',istrat,hdr,ierr) - call extract('alpha_z',alpha_z,hdr,ierr) - call extract('beta_z', beta_z, hdr,ierr) - call extract('z0',z0,hdr,ierr) - if (abs(qfacdisc2) <= tiny(qfacdisc2)) then - if (id==master) write(iprint,*) 'ERROR: qfacdisc2 == 0' - ierr = 2 - else - if (id==master) write(iprint,*) 'qfacdisc2 = ',qfacdisc2 - endif - endif - -end subroutine read_headeropts_eos - -!----------------------------------------------------------------------- -!+ -! writes equation of state options to the input file -!+ -!----------------------------------------------------------------------- -subroutine write_options_eos(iunit) - use infile_utils, only:write_inopt - use eos_helmholtz, only:eos_helmholtz_write_inopt - use eos_barotropic, only:write_options_eos_barotropic - use eos_piecewise, only:write_options_eos_piecewise - use eos_gasradrec, only:write_options_eos_gasradrec - integer, intent(in) :: iunit - - write(iunit,"(/,a)") '# options controlling equation of state' - call write_inopt(ieos,'ieos','eqn of state (1=isoth;2=adiab;3=locally iso;8=barotropic)',iunit) -#ifndef KROME - if (.not. eos_outputs_mu(ieos)) call write_inopt(gmw,'mu','mean molecular weight',iunit) -#endif - select case(ieos) - case(8) - call write_options_eos_barotropic(iunit) - case(9) - call write_options_eos_piecewise(iunit) - case(10) - call write_inopt(X_in,'X','hydrogen mass fraction',iunit) - call write_inopt(Z_in,'Z','metallicity',iunit) - case(15) ! helmholtz eos - call eos_helmholtz_write_inopt(iunit) - case(20) - call write_options_eos_gasradrec(iunit) - if (.not. use_var_comp) then - call write_inopt(X_in,'X','H mass fraction (ignored if variable composition)',iunit) - call write_inopt(Z_in,'Z','metallicity (ignored if variable composition)',iunit) - endif - end select - -end subroutine write_options_eos - -!----------------------------------------------------------------------- -!+ -! reads equation of state options from the input file -!+ -!----------------------------------------------------------------------- -subroutine read_options_eos(name,valstring,imatch,igotall,ierr) - use dim, only:store_dust_temperature,update_muGamma - use io, only:fatal - use eos_barotropic, only:read_options_eos_barotropic - use eos_piecewise, only:read_options_eos_piecewise - use eos_gasradrec, only:read_options_eos_gasradrec - 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_eos' - logical :: igotall_barotropic,igotall_piecewise,igotall_gasradrec - - imatch = .true. - igotall_barotropic = .true. - igotall_piecewise = .true. - igotall_gasradrec = .true. - - select case(trim(name)) - case('ieos') - read(valstring,*,iostat=ierr) ieos - ngot = ngot + 1 - if (ieos <= 0 .or. ieos > maxeos) call fatal(label,'equation of state choice out of range') - if (ieos == 5) then - store_dust_temperature = .true. - update_muGamma = .true. - endif - if (ieos == 21) update_muGamma = .true. - case('mu') - read(valstring,*,iostat=ierr) gmw - ! not compulsory to read in - if (gmw <= 0.) call fatal(label,'mu <= 0') - case('X') - read(valstring,*,iostat=ierr) X_in - if (X_in <= 0. .or. X_in >= 1.) call fatal(label,'X must be between 0 and 1') - ngot = ngot + 1 - case('Z') - read(valstring,*,iostat=ierr) Z_in - if (Z_in <= 0. .or. Z_in > 1.) call fatal(label,'Z must be between 0 and 1') - ngot = ngot + 1 - case default - imatch = .false. - end select - if (.not.imatch .and. ieos== 8) call read_options_eos_barotropic(name,valstring,imatch,igotall_barotropic,ierr) - if (.not.imatch .and. ieos== 9) call read_options_eos_piecewise( name,valstring,imatch,igotall_piecewise, ierr) - if (.not.imatch .and. ieos==20) call read_options_eos_gasradrec( name,valstring,imatch,igotall_gasradrec, ierr) - - !--make sure we have got all compulsory options (otherwise, rewrite input file) - igotall = (ngot >= 1) .and. igotall_piecewise .and. igotall_barotropic .and. igotall_gasradrec - -end subroutine read_options_eos - - -!----------------------------------------------------------------------- - -end module eos diff --git a/src/main/eos.f90 b/src/main/eos.f90 deleted file mode 100644 index b68bf45b6..000000000 --- a/src/main/eos.f90 +++ /dev/null @@ -1,1560 +0,0 @@ -!--------------------------------------------------------------------------! -! 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 eos -! -! This module contains stuff to do with the equation of state -! Current options: -! 1 = isothermal eos -! 2 = adiabatic/polytropic eos -! 3 = eos for a locally isothermal disc as in Lodato & Pringle (2007) -! 4 = GR isothermal -! 5 = polytropic EOS with vary mu and gamma depending on H2 formation -! 6 = eos for a locally isothermal disc as in Lodato & Pringle (2007), -! centered on a sink particle -! 7 = z-dependent locally isothermal eos -! 8 = Barotropic eos -! 9 = Piecewise polytrope -! 10 = MESA EoS -! 11 = isothermal eos with zero pressure -! 12 = ideal gas with radiation pressure -! 13 = locally isothermal prescription from Farris et al. (2014) generalised for generic hierarchical systems -! 14 = locally isothermal prescription from Farris et al. (2014) for binary system -! 15 = Helmholtz free energy eos -! 16 = Shen eos -! 20 = Ideal gas + radiation + various forms of recombination energy from HORMONE (Hirai et al., 2020) -! 21 = read tabulated eos (for use with icooling == 9) -! -! :References: -! Lodato & Pringle (2007) -! Hirai et al. (2020) -! -! :Owner: Daniel Price -! -! :Runtime parameters: -! - X : *H mass fraction (ignored if variable composition)* -! - Z : *metallicity (ignored if variable composition)* -! - ieos : *eqn of state (1=isoth;2=adiab;3=locally iso;8=barotropic)* -! - metallicity : *metallicity* -! - mu : *mean molecular weight* -! -! :Dependencies: dim, dump_utils, eos_barotropic, eos_gasradrec, -! eos_helmholtz, eos_idealplusrad, eos_mesa, eos_piecewise, eos_shen, -! eos_stratified, infile_utils, io, mesa_microphysics, part, physcon, -! units -! - use part, only:ien_etotal,ien_entropy,ien_type - use dim, only:gr - implicit none - integer, parameter, public :: maxeos = 21 - real, public :: polyk, polyk2, gamma - real, public :: qfacdisc = 0.75, qfacdisc2 = 0.75 - logical, public :: extract_eos_from_hdr = .false. - integer, public :: isink = 0. - - public :: equationofstate,setpolyk,eosinfo,get_mean_molecular_weight - public :: get_TempPresCs,get_spsound,get_temperature,get_pressure,get_cv - public :: eos_is_non_ideal,eos_outputs_mu,eos_outputs_gasP - public :: get_local_u_internal,get_temperature_from_u - public :: calc_rec_ene,calc_temp_and_ene,entropy,get_rho_from_p_s,get_u_from_rhoT - public :: calc_rho_from_PT,get_entropy,get_p_from_rho_s - public :: init_eos,finish_eos,write_options_eos,read_options_eos - public :: write_headeropts_eos, read_headeropts_eos - - private - - integer, public :: ieos = 1 - integer, public :: iopacity_type = 0 ! used for radiation - real, public :: gmw = 2.381 ! default mean molecular weight - real, public :: X_in = 0.74 ! default metallicities - real, public :: Z_in = 0.02 ! default metallicities - logical, public :: use_var_comp = .false. ! use variable composition - real, public :: temperature_coef - - logical, public :: done_init_eos = .false. - ! - ! error codes for calls to init_eos - ! - integer, public, parameter :: & - ierr_file_not_found = 1, & - ierr_option_conflict = 2, & - ierr_units_not_set = 3, & - ierr_isink_not_set = 4 - -! -! Default temperature prescription for vertical stratification (0=MAPS, 1=Dartois) -! - integer, public:: istrat = 0. -! -! 2D temperature structure fit parameters for HD 163296 -! - real, public :: z0 = 1. - real, public :: alpha_z = 3.01 - real, public :: beta_z = 0.42 - -contains - -!---------------------------------------------------------------- -!+ -! subroutine returns pressure/density as a function of density -! (and position in the case of the isothermal disc) -!+ -!---------------------------------------------------------------- -subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gamma_local,mu_local,Xlocal,Zlocal) - use io, only:fatal,error,warning - use part, only:xyzmh_ptmass, nptmass - use units, only:unit_density,unit_pressure,unit_ergg,unit_velocity - use physcon, only:Rg,radconst - use eos_mesa, only:get_eos_pressure_temp_gamma1_mesa,get_eos_1overmu_mesa - use eos_helmholtz, only:eos_helmholtz_pres_sound - use eos_shen, only:eos_shen_NL3 - use eos_idealplusrad - use eos_gasradrec, only:equationofstate_gasradrec - use eos_stratified, only:get_eos_stratified - use eos_barotropic, only:get_eos_barotropic - use eos_piecewise, only:get_eos_piecewise - use eos_stamatellos - integer, intent(in) :: eos_type - real, intent(in) :: rhoi,xi,yi,zi - real, intent(out) :: ponrhoi,spsoundi - real, intent(inout) :: tempi - real, intent(in), optional :: eni - real, intent(inout), optional :: mu_local,gamma_local - real, intent(in) , optional :: Xlocal,Zlocal - integer :: ierr, i - real :: r1,r2 - real :: mass_r, mass ! defined for generalised Farris prescription - real :: gammai,temperaturei,mui,imui,X_i,Z_i - real :: cgsrhoi,cgseni,cgspresi,presi,gam1,cgsspsoundi - real :: uthermconst,kappaBar,kappaPart,gmwi - real :: enthi,pondensi - ! - ! Check to see if equation of state is compatible with GR cons2prim routines - ! - if (gr .and. .not.any((/2,4,11,12/)==eos_type)) then - ponrhoi = 0.; spsoundi = 0. ! avoid compiler warning - call fatal('eos','GR currently only works for ieos=2,12 or 11',& - var='eos_type',val=real(eos_type)) - endif - - gammai = gamma - mui = gmw - X_i = X_in - Z_i = Z_in - if (present(gamma_local)) gammai = gamma_local - if (present(mu_local)) mui = mu_local - if (present(Xlocal)) X_i = Xlocal - if (present(Zlocal)) Z_i = Zlocal - - select case(eos_type) - case(1) -! -!--Isothermal eos -! -! :math:`P = c_s^2 \rho` -! -! where :math:`c_s^2 \equiv K` is a constant stored in the dump file header -! - ponrhoi = polyk - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - - case(2,5) -! -!--Adiabatic equation of state (code default) -! -! :math:`P = (\gamma - 1) \rho u` -! -! if the code is compiled with ISOTHERMAL=yes, ieos=2 gives a polytropic eos: -! -! :math:`P = K \rho^\gamma` -! -! where K is a global constant specified in the dump header -! - if (gammai < tiny(gammai)) call fatal('eos','gamma not set for adiabatic eos',var='gamma',val=gammai) - - if (gr) then - if (.not. present(eni)) call fatal('eos','GR call to equationofstate requires thermal energy as input!') - if (eni < 0.) call fatal('eos','utherm < 0',var='u',val=eni) - if (gammai <= 1.) then - spsoundi = 0.; ponrhoi = 0. ! avoid compiler warning - call fatal('eos','GR not compatible with isothermal equation of state, yet...',var='gamma',val=gammai) - elseif (gammai > 1.0001) then - pondensi = (gammai-1.)*eni ! eni is the thermal energy - enthi = 1. + eni + pondensi ! enthalpy - spsoundi = sqrt(gammai*pondensi/enthi) - ponrhoi = pondensi ! With GR this routine actually outputs pondensi (i.e. pressure on primitive density, not conserved.) - endif - else - if (present(eni)) then - if (eni < 0.) then - !write(iprint,'(a,Es18.4,a,4Es18.4)')'Warning: eos: u = ',eni,' < 0 at {x,y,z,rho} = ',xi,yi,zi,rhoi - call fatal('eos','utherm < 0',var='u',val=eni) - endif - if (gammai > 1.0001) then - ponrhoi = (gammai-1.)*eni ! use this if en is thermal energy - else - ponrhoi = 2./3.*eni ! en is thermal energy and gamma = 1 - endif - else - ponrhoi = polyk*rhoi**(gammai-1.) - endif - spsoundi = sqrt(gammai*ponrhoi) - endif - - tempi = temperature_coef*mui*ponrhoi - - case(3) -! -!--Locally isothermal disc as in Lodato & Pringle (2007) where -! -! :math:`P = c_s^2 (r) \rho` -! -! sound speed (temperature) is prescribed as a function of radius using: -! -! :math:`c_s = c_{s,0} r^{-q}` where :math:`r = \sqrt{x^2 + y^2 + z^2}` -! - ponrhoi = polyk*(xi**2 + yi**2 + zi**2)**(-qfacdisc) ! polyk is cs^2, so this is (R^2)^(-q) - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - - case(4) -! -!--Isothermal equation of state for GR, enforcing cs = constant -! -! .. WARNING:: this is experimental: use with caution -! - uthermconst = polyk - ponrhoi = (gammai-1.)*uthermconst - spsoundi = sqrt(ponrhoi/(1.+uthermconst)) - tempi = temperature_coef*mui*ponrhoi - - case(6) -! -!--Locally isothermal disc centred on sink particle -! -! As in ieos=3 but in this version radius is taken with respect to a designated -! sink particle (by default the first sink particle in the simulation) -! - ponrhoi = polyk*((xi-xyzmh_ptmass(1,isink))**2 + (yi-xyzmh_ptmass(2,isink))**2 + & - (zi-xyzmh_ptmass(3,isink))**2)**(-qfacdisc) ! polyk is cs^2, so this is (R^2)^(-q) - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - - case(7) -! -!--Vertically stratified equation of state -! -! sound speed is prescribed as a function of (cylindrical) radius R and -! height z above the x-y plane -! -! .. WARNING:: should not be used for misaligned discs -! - call get_eos_stratified(istrat,xi,yi,zi,polyk,polyk2,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,ponrhoi,spsoundi) - tempi = temperature_coef*mui*ponrhoi - - case(8) -! -!--Barotropic equation of state -! -! :math:`P = K \rho^\gamma` -! -! where the value of gamma (and K) are a prescribed function of density -! - call get_eos_barotropic(rhoi,polyk,polyk2,ponrhoi,spsoundi,gammai) - tempi = temperature_coef*mui*ponrhoi - - case(9) -! -!--Piecewise Polytropic equation of state -! -! :math:`P = K \rho^\gamma` -! -! where the value of gamma (and K) are a prescribed function of density. -! Similar to ieos=8 but with different defaults and slightly different -! functional form -! - call get_eos_piecewise(rhoi,ponrhoi,spsoundi,gammai) - tempi = temperature_coef*mui*ponrhoi - - case(10) -! -!--MESA equation of state -! -! a tabulated equation of state including gas, radiation pressure -! and ionisation/dissociation. MESA is a stellar evolution code, so -! this equation of state is designed for matter inside stars -! - cgsrhoi = rhoi * unit_density - cgseni = eni * unit_ergg - call get_eos_pressure_temp_gamma1_mesa(cgsrhoi,cgseni,cgspresi,temperaturei,gam1,ierr) - presi = cgspresi / unit_pressure - - ponrhoi = presi / rhoi - spsoundi = sqrt(gam1*ponrhoi) - tempi = temperaturei - if (present(gamma_local)) gamma_local = gam1 ! gamma is an output - if (present(mu_local)) mu_local = 1./get_eos_1overmu_mesa(cgsrhoi,cgseni) - if (ierr /= 0) call warning('eos_mesa','extrapolating off tables') - - case(11) -! -!--Isothermal equation of state with pressure and temperature equal to zero -! -! :math:`P = 0` -! -! useful for simulating test particle dynamics using SPH particles -! - ponrhoi = 0. - spsoundi = sqrt(polyk) - tempi = 0. - - case(12) -! -!--Ideal gas plus radiation pressure -! -! :math:`P = (\gamma - 1) \rho u` -! -! but solved by first solving the quartic equation: -! -! :math:`u = \frac32 \frac{k_b T}{\mu m_H} + \frac{a T^4}{\rho}` -! -! for temperature (given u), then solving for pressure using -! -! :math:`P = \frac{k_b T}{\mu m_H} + \frac13 a T^4` -! -! hence in this equation of state gamma (and temperature) are an output -! - temperaturei = tempi ! Required as initial guess - cgsrhoi = rhoi * unit_density - cgseni = eni * unit_ergg - call get_idealplusrad_temp(cgsrhoi,cgseni,mui,temperaturei,ierr) - call get_idealplusrad_pres(cgsrhoi,temperaturei,mui,cgspresi) - call get_idealplusrad_spsoundi(cgsrhoi,cgspresi,cgseni,spsoundi,gammai) - if (present(gamma_local)) gamma_local = gammai ! gamma is an output - spsoundi = spsoundi / unit_velocity - presi = cgspresi / unit_pressure - ponrhoi = presi / rhoi - tempi = temperaturei - if (ierr /= 0) call warning('eos_idealplusrad','temperature iteration did not converge') - - - case(13) -! -!--Locally isothermal eos for generic hierarchical system -! -! Assuming all sink particles are stars. -! Generalisation of Farris et al. (2014; for binaries) to N stars. -! For two sink particles this is identical to ieos=14 -! - mass_r = 0 - mass = 0 - - do i=1,nptmass - mass_r = mass_r+xyzmh_ptmass(4,i)/sqrt((xi-xyzmh_ptmass(1,i))**2 + (yi-xyzmh_ptmass(2,i))**2 + (zi-xyzmh_ptmass(3,i))**2) - mass = mass + xyzmh_ptmass(4,i) - enddo - ponrhoi=polyk*(mass_r)**(2*qfacdisc)/mass**(2*qfacdisc) - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - - - case(14) -! -!--Locally isothermal eos from Farris et al. (2014) for binary system -! -! uses the locations of the first two sink particles -! - r1 = sqrt((xi-xyzmh_ptmass(1,1))**2+(yi-xyzmh_ptmass(2,1))**2 + (zi-xyzmh_ptmass(3,1))**2) - r2 = sqrt((xi-xyzmh_ptmass(1,2))**2+(yi-xyzmh_ptmass(2,2))**2 + (zi-xyzmh_ptmass(3,2))**2) - ponrhoi=polyk*(xyzmh_ptmass(4,1)/r1+xyzmh_ptmass(4,2)/r2)**(2*qfacdisc)/(xyzmh_ptmass(4,1)+xyzmh_ptmass(4,2))**(2*qfacdisc) - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - - case(15) -! -!--Helmholtz equation of state (computed live, not tabulated) -! -! .. WARNING:: not widely tested in phantom, better to use ieos=10 -! - call eos_helmholtz_pres_sound(tempi, rhoi, ponrhoi, spsoundi, eni) - - case(16) -! -!--Shen (2012) equation of state for neutron stars -! -! this equation of state requires evolving temperature as the energy variable -! -! .. WARNING:: not tested: use with caution -! - if (present(eni)) then - cgsrhoi = rhoi * unit_density - !note eni is actually tempi - call eos_shen_NL3(cgsrhoi,eni,0.05,cgspresi,cgsspsoundi) - spsoundi=cgsspsoundi / unit_velocity - presi = cgspresi / unit_pressure - ponrhoi = presi / rhoi - tempi = eni - call warning('eos','Not sure if this is correct now that temperature is always passed into eos') - else - spsoundi = 0.; presi = 0.; ponrhoi = 0.; tempi = 0. ! to avoid compiler warnings - call fatal('eos','tried to call NL3 eos without passing temperature') - endif - - case(20) -! -!--Gas + radiation + various forms of recombination -! -! from HORMONE, Hirai+2020, as used in Lau+2022b -! - cgsrhoi = rhoi * unit_density - cgseni = eni * unit_ergg - imui = 1./mui - if (tempi > 0.) then - temperaturei = tempi - else - temperaturei = min(0.67 * cgseni * mui / Rg, (cgseni*cgsrhoi/radconst)**0.25) - endif - call equationofstate_gasradrec(cgsrhoi,cgseni*cgsrhoi,temperaturei,imui,X_i,1.-X_i-Z_i,cgspresi,cgsspsoundi,gammai) - ponrhoi = real(cgspresi / (unit_pressure * rhoi)) - spsoundi = real(cgsspsoundi / unit_velocity) - tempi = temperaturei - if (present(mu_local)) mu_local = 1./imui - if (present(gamma_local)) gamma_local = gammai - - case(21) -! -!--interpolate tabulated eos from Stamatellos+(2007). For use with icooling=9 -! - if (eni < 0.) then - call fatal('eos (stamatellos)','utherm < 0',var='u',val=eni) - endif - cgsrhoi = rhoi * unit_density - cgseni = eni * unit_ergg - call getopac_opdep(cgseni,cgsrhoi,kappaBar,kappaPart,tempi,mui) - cgspresi = kb_on_mh*cgsrhoi*tempi/mui - presi = cgspresi/unit_pressure - ponrhoi = presi/rhoi - gammai = 1.d0 + presi/(eni*rhoi) - !if (gammai < 1.d0 .or. gammai > 2.d0) then - ! print *, gammai, tempi, mui,cgseni,cgsrhoi,cgspresi - !endif - spsoundi = sqrt(gammai*ponrhoi) - - - case default - spsoundi = 0. ! avoids compiler warnings - ponrhoi = 0. - tempi = 0. - call fatal('eos','unknown equation of state') - end select - -end subroutine equationofstate - -!----------------------------------------------------------------------- -!+ -! initialise equation of state (read tables etc.) -!+ -!----------------------------------------------------------------------- -subroutine init_eos(eos_type,ierr) - use units, only:unit_velocity - use physcon, only:Rg - use io, only:error,warning,fatal - use eos_mesa, only:init_eos_mesa - use eos_helmholtz, only:eos_helmholtz_init - use eos_piecewise, only:init_eos_piecewise - use eos_barotropic, only:init_eos_barotropic - use eos_shen, only:init_eos_shen_NL3 - use eos_gasradrec, only:init_eos_gasradrec - use eos_stamatellos,only:read_optab,init_S07cool,eos_file - use dim, only:maxvxyzu,do_radiation - integer, intent(in) :: eos_type - integer, intent(out) :: ierr - integer :: ierr_mesakapp - - ierr = 0 - ! - !--Set coefficient to convert P/rho into temperature - ! calculation will be in cgs; the mean molecular weight, gmw, will be - ! included in the function call rather than here - ! c_s^2 = gamma*P/rho = gamma*kT/(gmw*m_p) -> T = P/rho * (gmw*m_p)/k - ! - temperature_coef = unit_velocity**2 / Rg - - select case(eos_type) - case(6) - ! - !--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 - endif - - case(8) - ! - ! barotropic equation of state - ! - call init_eos_barotropic(polyk,polyk2,ierr) - - case(9) - ! - ! piecewise polytropic equation of state (similar to barotropic) - ! - call init_eos_piecewise(ierr) - - case(10) - ! - !--MESA EoS initialisation - ! - write(*,'(1x,a,f7.5,a,f7.5)') 'Initialising MESA EoS with X = ',X_in,', Z = ',Z_in - call init_eos_mesa(X_in,Z_in,ierr) - if (do_radiation .and. ierr==0) then - call error('eos','ieos=10, cannot use eos with radiation, will double count radiation pressure') - ierr=ierr_option_conflict !return error if using radiation and mesa EOS, shouldn't use mesa eos, as it will double count rad pres - endif - - case(12) - ! - ! ideal plus radiation - ! - write(*,'(1x,a,f7.5)') 'Using ideal plus radiation EoS with mu = ',gmw - if (do_radiation) then - call error('eos','ieos=12, cannot use eos with radiation, will double count radiation pressure') - ierr = ierr_option_conflict - endif - - case(15) - - call eos_helmholtz_init(ierr) - - case(16) - - call init_eos_shen_NL3(ierr) - - case(20) - - call init_eos_gasradrec(ierr) - if (.not. use_var_comp) then - write(*,'(a,f7.5,a,f7.5)') 'Assuming fixed composition X = ',X_in,', Z = ',Z_in - endif - if (do_radiation) then - call error('eos','ieos=20, cannot use eos with radiation, will double count radiation pressure') - ierr = ierr_option_conflict - endif - - case(21) - - call read_optab(eos_file,ierr) - if (ierr > 0) call fatal('init_eos','Failed to read EOS file') - call init_S07cool - - end select - done_init_eos = .true. - - if (do_radiation .and. iopacity_type==1) then - write(*,'(1x,a,f7.5,a,f7.5)') 'Using radiation with MESA opacities. Initialising MESA EoS with X = ',X_in,', Z = ',Z_in - call init_eos_mesa(X_in,Z_in,ierr_mesakapp) - ierr = max(ierr,ierr_mesakapp) - endif - -end subroutine init_eos - -!----------------------------------------------------------------------- -!+ -! finish equation of state -!+ -!----------------------------------------------------------------------- -subroutine finish_eos(eos_type,ierr) - use eos_mesa, only: finish_eos_mesa - use eos_stamatellos, only: finish_S07cool - - integer, intent(in) :: eos_type - integer, intent(out) :: ierr - - ierr = 0 - - select case(eos_type) - case(10) - ! - !--MESA EoS deallocation - ! - call finish_eos_mesa - - case(21) - ! Stamatellos deallocation - call finish_S07cool - - end select - done_init_eos=.false. - -end subroutine finish_eos - -!----------------------------------------------------------------------- -!+ -! Calculate gas temperature, sound speed, and pressure. -! This will be required for various analysis routines if eos_vars -! is not saved in the dump files -!+ -!----------------------------------------------------------------------- -subroutine get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi,spsoundi,gammai,mui,Xi,Zi) - use dim, only:maxvxyzu - integer, intent(in) :: eos_type - real, intent(in) :: vxyzui(:),xyzi(:),rhoi - real, intent(inout) :: tempi - real, intent(out), optional :: presi,spsoundi - real, intent(inout), optional :: gammai,mui - real, intent(in), optional :: Xi,Zi - real :: csi,ponrhoi,mu,X,Z - logical :: use_gamma - - mu = gmw - X = X_in - Z = Z_in - if (present(mui)) mu = mui - if (present(Xi)) X = Xi - if (present(Zi)) Z = Zi - use_gamma = .false. - if (present(gammai)) then - if (gammai > 0.) use_gamma = .true. - endif - - if (maxvxyzu==4) then - 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) - else - call equationofstate(eos_type,ponrhoi,csi,rhoi,xyzi(1),xyzi(2),xyzi(3),tempi,vxyzui(4),& - mu_local=mu,Xlocal=X,Zlocal=Z) - endif - else - call equationofstate(eos_type,ponrhoi,csi,rhoi,xyzi(1),xyzi(2),xyzi(3),tempi,mu_local=mu) - endif - - if (present(presi)) presi = ponrhoi*rhoi - if (present(spsoundi)) spsoundi = csi - if (present(mui)) mui = mu - if (present(gammai)) gammai = gamma - -end subroutine get_TempPresCs - -!----------------------------------------------------------------------- -!+ -! Wrapper function to calculate sound speed -!+ -!----------------------------------------------------------------------- -real function get_spsound(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) - integer, intent(in) :: eos_type - real, intent(in) :: xyzi(:),rhoi - real, intent(in) :: vxyzui(:) - real, intent(in), optional :: Xi,Zi - real, intent(inout), optional :: gammai,mui - real :: spsoundi,tempi,gam,mu,X,Z - - !set defaults for variables not passed in - mu = gmw - X = X_in - Z = Z_in - tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess - gam = -1. ! to indicate gamma is not being passed in - if (present(Xi)) X = Xi - if (present(Zi)) Z = Zi - if (present(gammai)) gam = gammai - if (present(mui)) mu = mui - - call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,spsoundi=spsoundi,gammai=gam,mui=mu,Xi=X,Zi=Z) - - get_spsound = spsoundi - - if (present(mui)) mui = mu - if (present(gammai)) gammai = gam - -end function get_spsound - -!----------------------------------------------------------------------- -!+ -! Wrapper function to calculate temperature -!+ -!----------------------------------------------------------------------- -real function get_temperature(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) - integer, intent(in) :: eos_type - real, intent(in) :: xyzi(:),rhoi - real, intent(in) :: vxyzui(:) - real, intent(in), optional :: Xi,Zi - real, intent(inout),optional :: gammai,mui - real :: tempi,gam,mu,X,Z - - !set defaults for variables not passed in - mu = gmw - X = X_in - Z = Z_in - tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess - gam = -1. ! to indicate gamma is not being passed in - if (present(Xi)) X = Xi - if (present(Zi)) Z = Zi - if (present(gammai)) gam = gammai - if (present(mui)) mu = mui - - call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,gammai=gam,mui=mu,Xi=X,Zi=Z) - - get_temperature = tempi - - if (present(mui)) mui = mu - if (present(gammai)) gammai = gam - -end function get_temperature - - -!----------------------------------------------------------------------- -!+ -! Wrapper function to calculate temperature -!+ -!----------------------------------------------------------------------- -real function get_temperature_from_u(eos_type,xpi,ypi,zpi,rhoi,ui,gammai,mui,Xi,Zi) - integer, intent(in) :: eos_type - real, intent(in) :: xpi,ypi,zpi,rhoi - real, intent(in) :: ui - real, intent(in), optional :: Xi,Zi - real, intent(inout),optional :: gammai,mui - real :: tempi,gam,mu,X,Z - real :: vxyzui(4),xyzi(3) - - !set defaults for variables not passed in - mu = gmw - X = X_in - Z = Z_in - tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess - gam = -1. ! to indicate gamma is not being passed in - if (present(Xi)) X = Xi - if (present(Zi)) Z = Zi - if (present(gammai)) gam = gammai - if (present(mui)) mu = mui - - vxyzui = (/0.,0.,0.,ui/) - xyzi = (/xpi,ypi,zpi/) - call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,gammai=gam,mui=mu,Xi=X,Zi=Z) - - get_temperature_from_u = tempi - - if (present(mui)) mui = mu - if (present(gammai)) gammai = gam - - -end function get_temperature_from_u -!----------------------------------------------------------------------- -!+ -! Wrapper function to calculate pressure -!+ -!----------------------------------------------------------------------- -real function get_pressure(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) - integer, intent(in) :: eos_type - real, intent(in) :: xyzi(:),rhoi,vxyzui(:) - real, intent(in), optional :: Xi,Zi - real, intent(inout),optional :: gammai,mui - real :: presi,tempi,gam,mu,X,Z - - !set defaults for variables not passed in - mu = gmw - X = X_in - Z = Z_in - tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess - gam = -1. ! to indicate gamma is not being passed in - if (present(mui)) mu = mui - if (present(Xi)) X = Xi - if (present(Zi)) Z = Zi - if (present(gammai)) gam = gammai - if (present(mui)) mu = mui - - call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi=presi,gammai=gam,mui=mu,Xi=X,Zi=Z) - - get_pressure = presi - - if (present(mui)) mui = mu - if (present(gammai)) gammai = gam - -end function get_pressure - -!----------------------------------------------------------------------- -!+ -! query function to return the internal energy for calculations with a -! local mean molecular weight and local adiabatic index -!+ -!----------------------------------------------------------------------- -real function get_local_u_internal(gammai, gmwi, gas_temp_local) - real, intent(in) :: gammai, gmwi, gas_temp_local - real :: ponrhoi - - ponrhoi = gas_temp_local/(gmwi*temperature_coef) - get_local_u_internal = ponrhoi/(gammai-1.) - -end function get_local_u_internal - -!----------------------------------------------------------------------- -!+ -! get u from rho, T -!+ -!----------------------------------------------------------------------- -real function get_u_from_rhoT(rho,temp,eos_type,uguess) result(u) - use eos_mesa, only:get_eos_u_from_rhoT_mesa - integer, intent(in) :: eos_type - real, intent(in) :: rho,temp - real, intent(in), optional :: uguess - - select case (eos_type) - case(10) ! MESA EoS - if (present(uguess)) then - call get_eos_u_from_rhoT_mesa(rho,temp,u,uguess) - else - call get_eos_u_from_rhoT_mesa(rho,temp,u) - endif - - case default - u = temp/(gmw*temperature_coef*(gamma-1.)) - end select - -end function get_u_from_rhoT - -!----------------------------------------------------------------------- -!+ -! Get recombination energy (per unit mass) assumming complete -! ionisation -!+ -!----------------------------------------------------------------------- -subroutine calc_rec_ene(XX,YY,e_rec) - real, intent(in) :: XX, YY - real, intent(out) :: e_rec - real :: e_H2,e_HI,e_HeI,e_HeII - real, parameter :: e_ion_H2 = 1.312e13, & ! ionisation energies in erg/mol - e_ion_HI = 4.36e12, & - e_ion_HeI = 2.3723e13, & - e_ion_HeII = 5.2505e13 - - ! XX : Hydrogen mass fraction - ! YY : Helium mass fraction - ! e_rec : Total ionisation energy due to H2, HI, HeI, and HeII - - e_H2 = 0.5 * XX * e_ion_H2 - e_HI = XX * e_ion_HI - e_HeI = 0.25 * YY * e_ion_HeI - e_HeII = 0.25 * YY * e_ion_HeII - e_rec = e_H2 + e_HI + e_HeI + e_HeII - -end subroutine calc_rec_ene - -!----------------------------------------------------------------------- -!+ -! Calculate temperature and specific internal energy from -! pressure and density. Inputs and outputs are in cgs units. -! -! Note on composition: -! For ieos=2, 5 and 12, mu_local is an input, X & Z are not used -! For ieos=10, mu_local is not used -! For ieos=20, mu_local is not used but available as an output -!+ -!----------------------------------------------------------------------- -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 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 - integer, intent(in) :: eos_type - real, intent(in) :: rho,pres - real, intent(inout) :: ene,temp - real, intent(in), optional :: guesseint,X_local,Z_local - real, intent(inout), optional :: mu_local - integer, intent(out) :: ierr - real :: mu,X,Z - - ierr = 0 - mu = gmw - X = X_in - Z = Z_in - if (present(mu_local)) mu = mu_local - if (present(X_local)) X = X_local - if (present(Z_local)) Z = Z_local - select case(eos_type) - case(2,5) ! Ideal gas - temp = pres / (rho * kb_on_mh) * mu - ene = pres / ( (gamma-1.) * rho) - case(12) ! Ideal gas + radiation - call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) - call get_idealplusrad_enfromtemp(rho,temp,mu,ene) - case(10) ! MESA EoS - call get_eos_eT_from_rhop_mesa(rho,pres,ene,temp,guesseint) - case(20) ! Ideal gas + radiation + recombination (from HORMONE, Hirai et al., 2020) - call calc_uT_from_rhoP_gasradrec(rho,pres,X,1.-X-Z,temp,ene,mu,ierr) - if (present(mu_local)) mu_local = mu - case default - ierr = 1 - end select - -end subroutine calc_temp_and_ene - -!----------------------------------------------------------------------- -!+ -! Calculate density from pressure and temperature. Inputs and outputs -! are in cgs units. -! -! Note on composition: -! For ieos=2 and 12, mu_local is an input, X & Z are not used -! For ieos=10, mu_local is not used -! For ieos=20, mu_local is not used but available as an output -!+ -!----------------------------------------------------------------------- -subroutine calc_rho_from_PT(eos_type,pres,temp,rho,ierr,mu_local,X_local,Z_local) - use physcon, only:kb_on_mh - 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 - integer, intent(in) :: eos_type - real, intent(in) :: pres,temp - real, intent(inout) :: rho - real, intent(in), optional :: X_local,Z_local - real, intent(inout), optional :: mu_local - integer, intent(out) :: ierr - real :: mu,X,Z - - ierr = 0 - mu = gmw - X = X_in - Z = Z_in - if (present(mu_local)) mu = mu_local - if (present(X_local)) X = X_local - if (present(Z_local)) Z = Z_local - select case(eos_type) - case(2) ! Ideal gas - rho = pres / (temp * kb_on_mh) * mu - case(12) ! Ideal gas + radiation - call get_idealplusrad_rhofrompresT(pres,temp,mu,rho) - case default - ierr = 1 - end select - -end subroutine calc_rho_from_PT - -!----------------------------------------------------------------------- -!+ -! Calculates specific entropy (gas + radiation + recombination) -! up to an additive integration constant, from density and pressure. -!+ -!----------------------------------------------------------------------- -function entropy(rho,pres,mu_in,ientropy,eint_in,ierr) - use io, only:fatal,warning - use physcon, only:radconst,kb_on_mh - 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 - integer, intent(in) :: ientropy - integer, intent(out), optional :: ierr - real :: mu,entropy,logentropy,temp,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) - - ! check temp - if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') - - case(2) ! Include both gas and radiation entropy (up to additive constants) - temp = pres * mu / (rho * kb_on_mh) ! Guess for temp - 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) - - ! check temp - if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') - - 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') - - if (present(eint_in)) then - eint = eint_in - else - call get_eos_eT_from_rhop_mesa(rho,pres,eint,temp) - endif - - ! Get entropy from rho and eint from MESA tables - if (present(ierr)) then - call getvalue_mesa(rho,eint,9,logentropy,ierr) - else - call getvalue_mesa(rho,eint,9,logentropy) - endif - entropy = 10.**logentropy - - case default - entropy = 0. - call fatal('eos','Unknown ientropy (can only be 1, 2, or 3)') - end select - -end function entropy - -real function get_entropy(rho,pres,mu_in,ieos) - use units, only:unit_density,unit_pressure,unit_ergg - use physcon, only:kboltz - integer, intent(in) :: ieos - real, intent(in) :: rho,pres,mu_in - real :: cgsrho,cgspres,cgss - - cgsrho = rho * unit_density - cgspres = pres * unit_pressure - select case (ieos) - case (12) - cgss = entropy(cgsrho,cgspres,mu_in,2) - case (10, 20) - cgss = entropy(cgsrho,cgspres,mu_in,3) - case default - cgss = entropy(cgsrho,cgspres,mu_in,1) - end select - cgss = cgss/kboltz ! s/kb - get_entropy = cgss/unit_ergg - -end function get_entropy - -!----------------------------------------------------------------------- -!+ -! Calculate density given pressure and entropy using Newton-Raphson -! method -!+ -!----------------------------------------------------------------------- -subroutine get_rho_from_p_s(pres,S,rho,mu,rhoguess,ientropy) - real, intent(in) :: pres,S,mu,rhoguess - real, intent(inout) :: rho - real :: srho,srho_plus_dsrho,S_plus_dS,dSdsrho - real(kind=8) :: corr - real, parameter :: eoserr=1e-9,dfac=1e-12 - integer, intent(in) :: ientropy - - ! We apply the Newton-Raphson method directly to rho^1/2 ("srho") instead - ! of rho since S(rho) cannot take a negative argument. - srho = sqrt(rhoguess) ! Initial guess - corr = huge(corr); - do while (abs(corr) > eoserr*abs(srho)) - ! First calculate dS/dsrho - srho_plus_dsrho = srho * (1. + dfac) - S_plus_dS = entropy(srho_plus_dsrho**2,pres,mu,ientropy) - dSdsrho = (S_plus_dS - entropy(srho**2,pres,mu,ientropy)) / (srho_plus_dsrho - srho) - corr = ( entropy(srho**2,pres,mu,ientropy) - S ) / dSdsrho - srho = srho - corr - enddo - rho = srho**2 - -end subroutine get_rho_from_p_s - -!----------------------------------------------------------------------- -!+ -! Calculate temperature given density and entropy using Newton-Raphson -! method -!+ -!----------------------------------------------------------------------- -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 io, only:fatal - use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_pres - use units, only:unit_density,unit_pressure,unit_ergg - real, intent(in) :: S,mu,rho - real, intent(inout) :: temp - real, intent(out) :: P - integer, intent(in) :: ieos - real :: corr,df,f,temp_new,cgsrho,cgsp,cgss - real, parameter :: eoserr=1e-12 - integer :: niter - integer, parameter :: nitermax = 1000 - - ! change to cgs unit - cgsrho = rho*unit_density - cgss = s*unit_ergg - - niter = 0 - select case (ieos) - case (2,5) - temp = (cgsrho * exp(mu*cgss*mass_proton_cgs))**(2./3.) - cgsP = cgsrho*kb_on_mh*temp / mu - case (12) - corr = huge(corr) - do while (abs(corr) > eoserr .and. niter < nitermax) - f = 1. / (mu*mass_proton_cgs) * log(temp**1.5/cgsrho) + 4.*radconst*temp**3 / (3.*cgsrho*kboltz) - cgss - df = 1.5 / (mu*temp*mass_proton_cgs) + 4.*radconst*temp**2 / (cgsrho*kboltz) - corr = f/df - temp_new = temp - corr - if (temp_new > 1.2 * temp) then - temp = 1.2 * temp - elseif (temp_new < 0.8 * temp) then - temp = 0.8 * temp - else - temp = temp_new - endif - niter = niter + 1 - enddo - call get_idealplusrad_pres(cgsrho,temp,mu,cgsP) - case default - cgsP = 0. - call fatal('eos','[get_p_from_rho_s] only implemented for eos 2 and 12') - end select - - ! check temp - if (temp > huge(0.)) call fatal('entropy','entropy too large gives infinte temperature, & - &reducing entropy factor C_ent for one dump') - - ! change back to code unit - P = cgsP / unit_pressure - -end subroutine get_p_from_rho_s - -!----------------------------------------------------------------------- -!+ -! Calculate mean molecular weight from X and Z, assuming complete -! ionisation -!+ -!----------------------------------------------------------------------- -real function get_mean_molecular_weight(XX,ZZ) result(mu) - real, intent(in) :: XX,ZZ - real :: YY - - YY = 1.-XX-ZZ - mu = 1./(2.*XX + 0.75*YY + 0.5*ZZ) - -end function get_mean_molecular_weight - -!--------------------------------------------------------- -!+ -! return cv from rho, u in code units -!+ -!--------------------------------------------------------- -real function get_cv(rho,u,cv_type) result(cv) - use mesa_microphysics, only:getvalue_mesa - use units, only:unit_ergg,unit_density - use physcon, only:Rg - real, intent(in) :: rho,u - integer, intent(in) :: cv_type - real :: rho_cgs,u_cgs,temp - - select case (cv_type) - - case(1) ! MESA EoS - rho_cgs = rho*unit_density - u_cgs = u*unit_ergg - call getvalue_mesa(rho_cgs,u_cgs,4,temp) - cv = u_cgs/temp / unit_ergg - case default ! constant cv - cv = Rg/((gamma-1.)*gmw*unit_ergg) - end select - -end function get_cv - -!----------------------------------------------------------------------- -!+ -! subroutine sets polyk based on utherm/positions -! read from an sphNG dump file -!+ -!----------------------------------------------------------------------- -subroutine setpolyk(eos_type,iprint,utherm,xyzhi,npart) - use part, only:xyzmh_ptmass - use io, only:id,master - integer, intent(in) :: eos_type,iprint - real, intent(in) :: utherm(:) - real, intent(in) :: xyzhi(:,:) - integer, intent(in) :: npart - integer :: ipart - real :: r2,polykalt - - !-- pick a random particle from which to extract polyk - ipart = npart/2 - - select case(eos_type) - case(1,8) -! -!--isothermal eos -! - polykalt = 2./3.*utherm(ipart) - !--check all other utherms identical - if (any(utherm(1:npart) /= utherm(ipart)) .and. id==master) then - write(iprint,*) 'WARNING! different utherms but run is isothermal' - endif - - case(2,5) -! -!--adiabatic/polytropic eos -! this routine is ONLY called if utherm is NOT stored, so polyk matters -! - if (id==master) write(iprint,*) 'Using polytropic equation of state, gamma = ',gamma - polykalt = 2./3.*utherm(ipart) - if (gamma <= 1.00000001) then - stop 'silly to use gamma==1 without using isothermal eos' - endif - - case(3) -! -!--locally isothermal disc as in Lodato & Pringle (2007) -! cs = cs_0*R^(-q) -- polyk is cs^2, so this is (R^2)^(-q) -! - r2 = xyzhi(1,ipart)*xyzhi(1,ipart) + xyzhi(2,ipart)*xyzhi(2,ipart) & - + xyzhi(3,ipart)*xyzhi(3,ipart) - polykalt = 2./3.*utherm(ipart)*r2**qfacdisc - - case(6) -! -!--locally isothermal disc as in Lodato & Pringle (2007), centered on specified sink particle -! cs = cs_0*R^(-q) -- polyk is cs^2, so this is (R^2)^(-q) -! - r2 = (xyzhi(1,ipart)-xyzmh_ptmass(1,isink))**2 + & - (xyzhi(2,ipart)-xyzmh_ptmass(2,isink))**2 + & - (xyzhi(3,ipart)-xyzmh_ptmass(3,isink))**2 - - polykalt = 2./3.*utherm(ipart)*r2**qfacdisc - case default -! -!--don't die in this routine as it can be called from readdump -! (ie. not necessarily as part of a run) -! - if (id==master) write(iprint,*) ' WARNING! unknown equation of state in setpolyk' - polykalt = polyk - - end select - - if (diff(polykalt,polyk) .and. id==master) then - write(iprint,*) 'WARNING! polyk set using RK2 in dump differs from that set using thermal energy' - write(iprint,*) 'using polyk = ',polykalt, ' (from RK2 = ',polyk,')' - endif - polyk = polykalt -! -!--warn if polyk is zero, die if negative -! - if (polyk < 0.) then - write(iprint,*) 'ERROR: polyk < 0 in setting equation of state' - stop - elseif (polyk < tiny(polyk) .and. id==master) then - write(iprint,*) 'WARNING: polyk = 0 in equation of state' - endif - -end subroutine setpolyk -!----------------------------------------------------------------------- -!+ -! small utility returns whether two real numbers differ -!+ -!----------------------------------------------------------------------- -logical pure function diff(r1,r2) - real, intent(in) :: r1,r2 - - diff = abs(r1-r2) > tiny(r1) - -end function diff - -!----------------------------------------------------------------------- -!+ -! Query function to return whether an EoS is non-ideal -! Mainly used to decide whether it is necessary to write -! things like pressure and temperature in the dump file or not -!+ -!----------------------------------------------------------------------- -logical function eos_is_non_ideal(ieos) - integer, intent(in) :: ieos - - select case(ieos) - case(10,12,15,20) - eos_is_non_ideal = .true. - case default - eos_is_non_ideal = .false. - end select - -end function eos_is_non_ideal - -!----------------------------------------------------------------------- -!+ -! Query function to return whether an EoS outputs mean molecular weight -!+ -!----------------------------------------------------------------------- -logical function eos_outputs_mu(ieos) - integer, intent(in) :: ieos - - select case(ieos) - case(20) - eos_outputs_mu = .true. - case default - eos_outputs_mu = .false. - end select - -end function eos_outputs_mu - -!----------------------------------------------------------------------- -!+ -! Query function to whether to print pressure to dump file -!+ -!----------------------------------------------------------------------- -logical function eos_outputs_gasP(ieos) - integer, intent(in) :: ieos - - select case(ieos) - case(8,9,10,15) - eos_outputs_gasP = .true. - case default - eos_outputs_gasP = .false. - end select - -end function eos_outputs_gasP - -!----------------------------------------------------------------------- -!+ -! prints equation of state info in the run header -!+ -!----------------------------------------------------------------------- -subroutine eosinfo(eos_type,iprint) - use dim, only:maxvxyzu - use io, only:fatal,id,master - use eos_helmholtz, only:eos_helmholtz_eosinfo - use eos_barotropic, only:eos_info_barotropic - use eos_piecewise, only:eos_info_piecewise - use eos_gasradrec, only:eos_info_gasradrec - integer, intent(in) :: eos_type,iprint - - if (id/=master) return - - select case(eos_type) - case(1,11) - if (1.0d-5 < polyk .and. polyk < 1.0d3) then - write(iprint,"(/,a,f10.6)") ' Isothermal equation of state: cs^2 = ',polyk - else - write(iprint,"(/,a,Es13.6)") ' Isothermal equation of state: cs^2 = ',polyk - endif - if (eos_type==11) write(iprint,*) ' (ZERO PRESSURE) ' - case(2) - if (maxvxyzu >= 4) then - write(iprint,"(/,a,f10.6,a,f10.6)") ' Adiabatic equation of state: P = (gamma-1)*rho*u, gamma = ',& - gamma,' gmw = ',gmw - else - write(iprint,"(/,a,f10.6,a,f10.6,a,f10.6)") ' Polytropic equation of state: P = ',polyk,'*rho^',gamma,' gmw = ',gmw - endif - case(3) - write(iprint,"(/,a,f10.6,a,f10.6)") ' Locally isothermal eq of state (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc - case(5) - if (maxvxyzu >= 4) then - write(iprint,"(' Adiabatic equation of state: P = (gamma-1)*rho*u, where gamma & mu depend on the formation of H2')") - else - stop '[stop eos] eos = 5 cannot assume isothermal conditions' - endif - case(6) - write(iprint,"(/,a,i2,a,f10.6,a,f10.6)") ' Locally (on sink ',isink, & - ') isothermal eos (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc - case(8) - call eos_info_barotropic(polyk,polyk2,iprint) - case(9) - call eos_info_piecewise(iprint) - case(10) - write(iprint,"(/,a,f10.6,a,f10.6,a,f10.6,a)") ' MESA EoS: X = ',X_in,' Z = ',Z_in,' (1-X-Z = ',1.-X_in-Z_in,')' - case(12) - write(iprint,"(/,a,f10.6,a,f10.6)") ' Gas + radiation equation of state: gmw = ',gmw,' gamma = ',gamma - case(15) - call eos_helmholtz_eosinfo(iprint) - case(20) - call eos_info_gasradrec(iprint) - if (use_var_comp) then - write(*,'(1x,a,i1,a)') 'Using variable composition' - else - write(*,'(1x,a,f10.6,a,f10.6)') 'Using fixed composition X = ',X_in,", Z = ",Z_in - endif - end select - write(iprint,*) - -end subroutine eosinfo - -!----------------------------------------------------------------------- -!+ -! write relevant options to the header of the dump file -!+ -!----------------------------------------------------------------------- -subroutine write_headeropts_eos(ieos,hdr,ierr) - use dump_utils, only:dump_h,add_to_rheader,add_to_iheader - integer, intent(in) :: ieos - type(dump_h), intent(inout) :: hdr - integer, intent(out) :: ierr - - call add_to_iheader(isink,'isink',hdr,ierr) - call add_to_rheader(gamma,'gamma',hdr,ierr) - call add_to_rheader(1.5*polyk,'RK2',hdr,ierr) - call add_to_rheader(polyk2,'polyk2',hdr,ierr) - call add_to_rheader(qfacdisc,'qfacdisc',hdr,ierr) - call add_to_rheader(qfacdisc2,'qfacdisc2',hdr,ierr) - - if (ieos==7) then - call add_to_iheader(istrat,'istrat',hdr,ierr) - call add_to_rheader(alpha_z,'alpha_z',hdr,ierr) - call add_to_rheader(beta_z,'beta_z',hdr,ierr) - call add_to_rheader(z0,'z0',hdr,ierr) - endif - -end subroutine write_headeropts_eos - -!----------------------------------------------------------------------- -!+ -! read relevant options from the header of the dump file -!+ -!----------------------------------------------------------------------- -subroutine read_headeropts_eos(ieos,hdr,ierr) - use dump_utils, only:dump_h, extract - use io, only:iprint,id,master - use dim, only:use_krome,maxvxyzu - integer, intent(in) :: ieos - type(dump_h), intent(in) :: hdr - integer, intent(out) :: ierr - real :: RK2 - - - call extract('gamma',gamma,hdr,ierr) - call extract('RK2',rk2,hdr,ierr) - polyk = 2./3.*rk2 - if (id==master) then - if (maxvxyzu >= 4) then - if (use_krome) then - write(iprint,*) 'KROME eos: initial gamma = 1.666667' - else - write(iprint,*) 'adiabatic eos: gamma = ',gamma - endif - else - write(iprint,*) 'setting isothermal sound speed^2 (polyk) = ',polyk,' gamma = ',gamma - if (polyk <= tiny(polyk)) write(iprint,*) 'WARNING! sound speed zero in dump!, polyk = ',polyk - endif - endif - call extract('polyk2',polyk2,hdr,ierr) - call extract('qfacdisc',qfacdisc,hdr,ierr) - call extract('qfacdisc2',qfacdisc2,hdr,ierr) - call extract('isink',isink,hdr,ierr) - - if (abs(gamma-1.) > tiny(gamma) .and. maxvxyzu < 4) then - write(*,*) 'WARNING! compiled for isothermal equation of state but gamma /= 1, gamma=',gamma - endif - - ierr = 0 - if (ieos==3 .or. ieos==6 .or. ieos==7) then - if (qfacdisc <= tiny(qfacdisc)) then - if (id==master) write(iprint,*) 'ERROR: qfacdisc <= 0' - ierr = 2 - else - if (id==master) write(iprint,*) 'qfacdisc = ',qfacdisc - endif - endif - - if (ieos==7) then - call extract('istrat',istrat,hdr,ierr) - call extract('alpha_z',alpha_z,hdr,ierr) - call extract('beta_z', beta_z, hdr,ierr) - call extract('z0',z0,hdr,ierr) - if (abs(qfacdisc2) <= tiny(qfacdisc2)) then - if (id==master) write(iprint,*) 'ERROR: qfacdisc2 == 0' - ierr = 2 - else - if (id==master) write(iprint,*) 'qfacdisc2 = ',qfacdisc2 - endif - endif - -end subroutine read_headeropts_eos - -!----------------------------------------------------------------------- -!+ -! writes equation of state options to the input file -!+ -!----------------------------------------------------------------------- -subroutine write_options_eos(iunit) - use dim, only:use_krome - use infile_utils, only:write_inopt - use eos_helmholtz, only:eos_helmholtz_write_inopt - use eos_barotropic, only:write_options_eos_barotropic - use eos_piecewise, only:write_options_eos_piecewise - use eos_gasradrec, only:write_options_eos_gasradrec - integer, intent(in) :: iunit - - write(iunit,"(/,a)") '# options controlling equation of state' - call write_inopt(ieos,'ieos','eqn of state (1=isoth;2=adiab;3=locally iso;8=barotropic)',iunit) - - if (.not.use_krome .or. .not.eos_outputs_mu(ieos)) then - call write_inopt(gmw,'mu','mean molecular weight',iunit) - endif - - select case(ieos) - case(8) - call write_options_eos_barotropic(iunit) - case(9) - call write_options_eos_piecewise(iunit) - case(10) - call write_inopt(X_in,'X','hydrogen mass fraction',iunit) - call write_inopt(Z_in,'Z','metallicity',iunit) - case(15) ! helmholtz eos - call eos_helmholtz_write_inopt(iunit) - case(20) - call write_options_eos_gasradrec(iunit) - if (.not. use_var_comp) then - call write_inopt(X_in,'X','H mass fraction (ignored if variable composition)',iunit) - call write_inopt(Z_in,'Z','metallicity (ignored if variable composition)',iunit) - endif - end select - -end subroutine write_options_eos - -!----------------------------------------------------------------------- -!+ -! reads equation of state options from the input file -!+ -!----------------------------------------------------------------------- -subroutine read_options_eos(name,valstring,imatch,igotall,ierr) - use dim, only:store_dust_temperature,update_muGamma - use io, only:fatal - use eos_barotropic, only:read_options_eos_barotropic - use eos_piecewise, only:read_options_eos_piecewise - use eos_gasradrec, only:read_options_eos_gasradrec - 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_eos' - logical :: igotall_barotropic,igotall_piecewise,igotall_gasradrec - - imatch = .true. - igotall_barotropic = .true. - igotall_piecewise = .true. - igotall_gasradrec = .true. - - select case(trim(name)) - case('ieos') - read(valstring,*,iostat=ierr) ieos - ngot = ngot + 1 - if (ieos <= 0 .or. ieos > maxeos) call fatal(label,'equation of state choice out of range') - if (ieos == 5) then - store_dust_temperature = .true. - update_muGamma = .true. - endif - if (ieos == 21) update_muGamma = .true. - case('mu') - read(valstring,*,iostat=ierr) gmw - ! not compulsory to read in - if (gmw <= 0.) call fatal(label,'mu <= 0') - case('X') - read(valstring,*,iostat=ierr) X_in - if (X_in <= 0. .or. X_in >= 1.) call fatal(label,'X must be between 0 and 1') - ngot = ngot + 1 - case('Z') - read(valstring,*,iostat=ierr) Z_in - if (Z_in <= 0. .or. Z_in > 1.) call fatal(label,'Z must be between 0 and 1') - ngot = ngot + 1 - case default - imatch = .false. - end select - if (.not.imatch .and. ieos== 8) call read_options_eos_barotropic(name,valstring,imatch,igotall_barotropic,ierr) - if (.not.imatch .and. ieos== 9) call read_options_eos_piecewise( name,valstring,imatch,igotall_piecewise, ierr) - if (.not.imatch .and. ieos==20) call read_options_eos_gasradrec( name,valstring,imatch,igotall_gasradrec, ierr) - - !--make sure we have got all compulsory options (otherwise, rewrite input file) - igotall = (ngot >= 1) .and. igotall_piecewise .and. igotall_barotropic .and. igotall_gasradrec - -end subroutine read_options_eos - - -!----------------------------------------------------------------------- - -end module eos diff --git a/src/utils/analysis_getneighbours.f90 b/src/utils/analysis_getneighbours.f90 index fb20606c7..f5fffe2a0 100644 --- a/src/utils/analysis_getneighbours.f90 +++ b/src/utils/analysis_getneighbours.f90 @@ -44,10 +44,10 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! Output neighbour lists to file !************************************** - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) call write_neighbours(neighbourfile, npart) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + print*, 'Neighbour finding complete for file ', trim(dumpfile) end subroutine do_analysis !-------------------------------------------------------------------------- diff --git a/src/utils/analysis_gws.f90 b/src/utils/analysis_gws.f90 index 9be0e4330..70b12ab2b 100644 --- a/src/utils/analysis_gws.f90 +++ b/src/utils/analysis_gws.f90 @@ -87,7 +87,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunitone) ! Write a file where I append all the values of the strain wrt time if (first) then first = .false. - open(unit=iu, file='strain.gw',status='replace') + open(unit=iu,file='strain.gw',status='replace') write(iu,"('#',9(1x,'[',i2.2,1x,a11,']',2x))") & 1, 'time', & 2, 'hx_0', & @@ -99,7 +99,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunitone) 8, 'hx_{90}', & 9, 'hx_{90}' else - open(unit=iu, file='strain.gw',position='append') + open(unit=iu,file='strain.gw',position='append') endif print*, 'time', time @@ -125,7 +125,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunitone) ! Write a file where I append all the values of the strain wrt time if (firstdump) then firstdump = .false. - open(unit=iuu, file='quadrupole.txt',status='replace') + open(unit=iuu,file='quadrupole.txt',status='replace') write(iuu,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & 1, 'q11', & 2, 'q12', & @@ -134,14 +134,14 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunitone) 5, 'q23', & 6, 'q33' else - open(unit=iuu, file='quadrupole.txt',position='append') + open(unit=iuu,file='quadrupole.txt',position='append') endif write(iuu,'(6(es18.10,1X))') q(1), q(2), q(3), q(4), q(5), q(6) if (firstdumpa) then firstdumpa = .false. - open(unit=iuuu, file='second_time_quadrupole.txt',status='replace') + open(unit=iuuu,file='second_time_quadrupole.txt',status='replace') write(iuuu,"('#',7(1x,'[',i2.2,1x,a11,']',2x))") & 1, 'time',& 2, 'ddq_xy(1,1)', & @@ -151,7 +151,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunitone) 6, 'ddq_xy(2,3)', & 7, 'ddq_xy(3,3)' else - open(unit=iuuu, file='second_time_quadrupole.txt',position='append') + open(unit=iuuu,file='second_time_quadrupole.txt',position='append') endif write(iuuu,'(7(es18.10,1X))') time,ddq_xy(1,1),ddq_xy(1,2),ddq_xy(1,3),ddq_xy(2,2),ddq_xy(2,3),ddq_xy(3,3) diff --git a/src/utils/analysis_kepler.f90 b/src/utils/analysis_kepler.f90 index e6e63d942..e057510cb 100644 --- a/src/utils/analysis_kepler.f90 +++ b/src/utils/analysis_kepler.f90 @@ -641,16 +641,16 @@ subroutine composition_array(interpolate_comp,columns_compo,comp_label) !Save composition read from file. allocate(interpolate_comp(columns_compo,n_rows)) - open(12, file=filename) + open(12,file=filename) ierr = 0 !get column labels and send them back. - read(12, '(a)', iostat=ierr) line + read(12, '(a)',iostat=ierr) line allocate(comp_label(columns_compo)) call get_column_labels(line,n_labels,comp_label) close(12) print*,"comp_label ",comp_label - open(13, file=filename) + open(13,file=filename) call skip_header(13,nheader,ierr) do k = 1, n_rows read(13,*,iostat=ierr) interpolate_comp(:,k) @@ -673,7 +673,7 @@ subroutine assign_atomic_mass_and_number(comp_label,A_array,Z_array) real,allocatable :: A_array(:), Z_array(:) integer :: size_to_allocate, i - if ( ANY( comp_label=="nt1" ) ) then + if ( any( comp_label=="nt1" ) ) then size_to_allocate = size(comp_label(:))-1 else @@ -814,14 +814,14 @@ subroutine write_dump_info(fileno,density,temperature,mass,xpos,rad,distance,pos ! open the file for appending or creating if (file_exists) then - open(unit=file_id, file=filename, status='old', position="append", action="write", iostat=status) + open(unit=file_id,file=filename,status='old', position="append",action="write",iostat=status) if (status /= 0) then write(*,*) 'Error opening file: ', filename stop endif else - open(unit=file_id, file=filename, status='new', action='write', iostat=status) + open(unit=file_id,file=filename,status='new',action='write',iostat=status) if (status /= 0) then write(*,*) 'Error creating file: ', filename stop diff --git a/src/utils/analysis_protostar_environ.F90 b/src/utils/analysis_protostar_environ.F90 index 6ac1dcd41..895d04933 100644 --- a/src/utils/analysis_protostar_environ.F90 +++ b/src/utils/analysis_protostar_environ.F90 @@ -294,7 +294,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) + (xyzmh_ptmass(2,isink)-xyzmh_ptmass(2,j))**2 & + (xyzmh_ptmass(3,isink)-xyzmh_ptmass(3,j))**2 if (rtmp2 < rmerge2) then - write(filelog,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'.log' + write(filelog,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'.log' inquire(file=filelog,exist=iexist) if ( firstlog .or. .not.iexist ) then firstlog = .false. @@ -315,13 +315,13 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) write(rval, '(I3.3)') rthreshAU write(csink,'(I3.3)') isink if (isink==0) then - write(fileout1,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_discRM.dat' - write(fileout2,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_discRMnx.dat' - write(fileout3,'(5a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_vol',rval,'RM.dat' + write(fileout1,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_discRM.dat' + write(fileout2,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_discRMnx.dat' + write(fileout3,'(5a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_vol',rval,'RM.dat' else - write(fileout1,'(5a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_S',csink,'discRM.dat' - write(fileout2,'(5a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_S',csink,'discRMnx.dat' - write(fileout3,'(7a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_S',csink,'vol',rval,'RM.dat' + write(fileout1,'(5a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_S',csink,'discRM.dat' + write(fileout2,'(5a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_S',csink,'discRMnx.dat' + write(fileout3,'(7a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_S',csink,'vol',rval,'RM.dat' endif if ( no_file(isink) ) then open(iunit,file=fileout1,status='replace') @@ -473,7 +473,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! Print the globally averaged eta-values, for particles with rho > rho_crit if (calc_eta) then - write(fileout6,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_eta.dat' + write(fileout6,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_eta.dat' if ( no_file(maxptmass+1) ) then open(eunit,file=fileout6,status='replace') call write_header_file6(eunit) @@ -504,9 +504,9 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) call get_mu(npart,nptmass,nmu_global,rmu_global,mu_global,mass_mu_global,B_mu_global, & xyzh,xyzmh_ptmass,Bxyz,particlemass) - write(fileout7,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_mu.dat' - write(fileout8,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_mu_mass.dat' - write(fileout9,'(3a)') 'analysisout_',trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_mu_B.dat' + write(fileout7,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_mu.dat' + write(fileout8,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_mu_mass.dat' + write(fileout9,'(3a)') 'analysisout_',trim(dumpfile(1:index(dumpfile,'_')-1)),'_mu_B.dat' if ( no_file(maxptmass+1) ) then open(eunit,file=fileout7,status='replace') call write_header_file7(eunit) diff --git a/src/utils/analysis_raytracer.f90 b/src/utils/analysis_raytracer.f90 index 2a8305c9e..f70a7589a 100644 --- a/src/utils/analysis_raytracer.f90 +++ b/src/utils/analysis_raytracer.f90 @@ -229,10 +229,10 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) if (analyses == 2 .and. method==1) then ! get neighbours if (SPH) then - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh) then - print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' + print*, 'SPH neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart2) else ! If there is no neighbour file, generate the list @@ -243,7 +243,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) totalTime = (finish-start)/1000. print*,'Time = ',totalTime,' seconds.' call write_neighbours(neighbourfile, npart2) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + print*, 'Neighbour finding complete for file ', trim(dumpfile) endif else allocate(neighb(npart2+2,100)) @@ -254,7 +254,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) else call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') endif - open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + open(newunit=iu4,file='neighbors_tess.txt',status='old',action='read') do i=1, npart2+2 read(iu4,*) neighb(i,:) enddo @@ -266,10 +266,10 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! INWARD INTEGRATION ANALYSIS if (method == 1) then - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh) then - print*, 'SPH neighbour file ', TRIM(neighbourfile), ' found' + print*, 'SPH neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart2) else ! If there is no neighbour file, generate the list @@ -280,7 +280,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) totalTime = (finish-start)/1000. print*,'Time = ',totalTime,' seconds.' call write_neighbours(neighbourfile, npart2) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + print*, 'Neighbour finding complete for file ', trim(dumpfile) endif print*,'' print*, 'Start calculating optical depth inward SPH' @@ -295,11 +295,11 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='times_inwards_'//dumpfile//'.txt',status='replace',action='write') write(iu4, *) timeTau close(iu4) totalTime = timeTau - open(newunit=iu2, file='taus_inwards_SPH_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_inwards_SPH_'//dumpfile//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -313,7 +313,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) else call execute_command_line('python3 getNeigh.py -f '//'points_'//dumpfile//'.txt') endif - open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + open(newunit=iu4,file='neighbors_tess.txt',status='old',action='read') do i=1, npart2+2 read(iu4,*) neighb(i,:) enddo @@ -331,18 +331,18 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_inwards_'//dumpfile//'.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_inwards_'//dumpfile//'.txt',position='append',status='old',action='write') write(iu4, *) timeTau close(iu4) totalTime = timeTau - open(newunit=iu2, file='taus_inwards_Del_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_inwards_Del_'//dumpfile//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo ! OUTWARD INTEGRATION realTIME ANALYSIS elseif (method == 2) then - open(newunit=iu4, file='times_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='times_'//dumpfile//'.txt',status='replace',action='write') close(iu4) totalTime=0 @@ -361,11 +361,11 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_'//dumpfile//'.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_'//dumpfile//'.txt',position='append',status='old',action='write') write(iu4, *) timeTau close(iu4) totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_'//trim(jstring)//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -376,7 +376,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS elseif (method == 3) then - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='times_interpolation_'//dumpfile//'.txt',status='replace',action='write') close(iu4) totalTime=0 @@ -395,12 +395,12 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_interpolation_'//dumpfile//'.txt',position='append',status='old',action='write') write(iu4, *) timeTau close(iu4) totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & - status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & + status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -411,7 +411,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! OUTWARD INTEGRATION INTERPOLATION ANALYSIS elseif (method == 4) then - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='times_interpolation_'//dumpfile//'.txt',status='replace',action='write') close(iu4) totalTime=0 @@ -434,14 +434,14 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) print*,'Time = ',timeTau,' seconds.' times(k+1) = timeTau totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & - status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_'//trim(jstring)//'_int_'//trim(kstring)//'.txt', & + status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo close(iu2) enddo - open(newunit=iu4, file='times_interpolation_'//dumpfile//'.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_interpolation_'//dumpfile//'.txt',position='append',status='old',action='write') write(iu4, *) times(1:7) close(iu4) enddo @@ -450,7 +450,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) !ADAPTIVE (OUTWARD) INTEGRATION ANALYSIS elseif (method == 5) then - open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='times_adapt_'//dumpfile//'.txt',status='replace',action='write') close(iu4) totalTime=0 @@ -475,14 +475,14 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) print*,'Time = ',timeTau,' seconds.' times(k-minOrder+1) = timeTau totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & - '_'//trim(kstring)//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & + '_'//trim(kstring)//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo close(iu2) enddo - open(newunit=iu4, file='times_adapt_'//dumpfile//'.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_adapt_'//dumpfile//'.txt',position='append',status='old',action='write') write(iu4, *) times(1:maxOrder-minOrder+1) close(iu4) enddo @@ -493,7 +493,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) elseif (method == 6) then order = 5 print*,'Start doing scaling analysis with order =',order - open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt', status='replace', action='write') + open(newunit=iu4,file='times_'//dumpfile//'_scaling.txt',status='replace',action='write') close(iu4) do i=1, omp_get_max_threads() call omp_set_num_threads(i) @@ -511,7 +511,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'nthread = ',omp_get_max_threads(),': Time = ',timeTau,' seconds.' - open(newunit=iu4, file='times_'//dumpfile//'_scaling.txt',position='append', status='old', action='write') + open(newunit=iu4,file='times_'//dumpfile//'_scaling.txt',position='append',status='old',action='write') write(iu4, *) omp_get_max_threads(), timeTau close(iu4) enddo @@ -531,14 +531,14 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu1, file='npart_wind.txt',position='append', action='write') + open(newunit=iu1,file='npart_wind.txt',position='append',action='write') write(iu1, *) npart2 close(iu1) - open(newunit=iu4, file='times_wind.txt',position='append', action='write') + open(newunit=iu4,file='times_wind.txt',position='append',action='write') write(iu4, *) timeTau close(iu4) totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -562,9 +562,9 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' if (SPH) then - open(newunit=iu2, file='taus_'//dumpfile//'_inwards.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_inwards.txt',status='replace',action='write') else - open(newunit=iu2, file='taus_'//dumpfile//'_tess_inwards.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_tess_inwards.txt',status='replace',action='write') endif do i=1, size(tau) write(iu2, *) tau(i) @@ -584,7 +584,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_'//trim(jstring)//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -603,7 +603,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu2, file='taus_'//dumpfile//'_'//trim(jstring)//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_'//trim(jstring)//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -623,8 +623,8 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & - '_'//trim(kstring)//'.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_adapt_'//trim(jstring)// & + '_'//trim(kstring)//'.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo @@ -646,7 +646,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' - open(newunit=iu4, file='taus_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu4,file='taus_'//dumpfile//'.txt',status='replace',action='write') do i=1, size(tau) write(iu4, *) tau(i) enddo @@ -660,7 +660,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) enddo ! allocate(neighb(npart2+2,100)) ! neighb = 0 - ! open(newunit=iu4, file='neighbors_tess.txt', status='old', action='read') + ! open(newunit=iu4,file='neighbors_tess.txt',status='old',action='read') ! do i=1, npart2+2 ! read(iu4,*) neighb(i,:) ! enddo @@ -674,20 +674,20 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) timeTau = (finish-start)/1000. print*,'Time = ',timeTau,' seconds.' totalTime = totalTime + timeTau - open(newunit=iu2, file='taus_'//dumpfile//'_raypolation_7.txt', status='replace', action='write') + open(newunit=iu2,file='taus_'//dumpfile//'_raypolation_7.txt',status='replace',action='write') do i=1, size(tau) write(iu2, *) tau(i) enddo close(iu2) elseif (analyses == 5) then - open(newunit=iu1, file='points_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu1,file='points_'//dumpfile//'.txt',status='replace',action='write') do i=1, npart2+2 write(iu1, *) xyzh2(1:3,i) enddo close(iu1) - open(newunit=iu3, file='rho_'//dumpfile//'.txt', status='replace', action='write') + open(newunit=iu3,file='rho_'//dumpfile//'.txt',status='replace',action='write') do i=1,npart2 rho(i) = rhoh(xyzh2(4,i), particlemass) write(iu3, *) rho(i) diff --git a/src/utils/analysis_sphere.f90 b/src/utils/analysis_sphere.f90 index 837a5257a..a74eab303 100644 --- a/src/utils/analysis_sphere.f90 +++ b/src/utils/analysis_sphere.f90 @@ -222,7 +222,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) enddo close(iunit) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_AM.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_AM.dat' inquire(file=fileout,exist=iexist) if ( .not.iexist .or. firstcall ) then firstcall = .false. diff --git a/src/utils/analysis_velocitydispersion_vs_scale.f90 b/src/utils/analysis_velocitydispersion_vs_scale.f90 index 7bd2daa9d..ec46ee0b6 100644 --- a/src/utils/analysis_velocitydispersion_vs_scale.f90 +++ b/src/utils/analysis_velocitydispersion_vs_scale.f90 @@ -96,11 +96,11 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) ! Check if a neighbour file is present - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh.eqv..true.) then - print*, 'Neighbour file ', TRIM(neighbourfile), ' found' + print*, 'Neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart) else @@ -358,7 +358,7 @@ subroutine read_analysis_options print '(a,a,a)', "Parameter file ",inputfile, " found: reading analysis options" - open(10,file=inputfile, form='formatted') + open(10,file=inputfile,form='formatted') read(10,*) nscale read(10,*) rscalemin read(10,*) rscalemax @@ -376,7 +376,7 @@ subroutine read_analysis_options ! Write choices to new inputfile - open(10,file=inputfile, status='new', form='formatted') + open(10,file=inputfile,status='new',form='formatted') write(10,*) nscale, " Number of scale evaluations" write(10,*) rscalemin, " Minimum scale (code units)" write(10,*) rscalemax, " Maximum scale (code units)" diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 8bd6b847b..28580cd41 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -29,37 +29,16 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) use io, only:id,master,nprocs,set_io_unit_numbers,die use mpiutils, only:init_mpi,finalise_mpi use initial, only:initialise,finalise,startrun,endrun - !use evolve, only:evol_init use tmunu2grid use einsteintk_utils use extern_gr use metric - use part, only:npart!, tmunus - - + use part, only:npart implicit none character(len=*), intent(in) :: infilestart real, intent(in) :: dt_et integer, intent(inout) :: nophantompart real, intent(out) :: dtout - !character(len=500) :: logfile,evfile,dumpfile,path - !integer :: i,j,k,pathstringlength - - ! For now we just hardcode the infile, to see if startrun actually works! - ! I'm not sure what the best way to actually do this is? - ! Do we store the phantom.in file in par and have it read from there? - !infile = "/Users/spencer/phantomET/phantom/test/flrw.in" - !infile = trim(infile)//'.in' - !print*, "phantom_path: ", phantom_path - !infile = phantom_path // "flrw.in" - !infile = trim(path) // "flrw.in" - !infile = 'flrw.in' - !infile = trim(infile) - !print*, "Phantom path is: ", path - !print*, "Infile is: ", infile - ! Use system call to copy phantom files to simulation directory - ! This is a digusting temporary fix - !call SYSTEM('cp ~/phantomET/phantom/test/flrw* ./') ! The infile from ET infilestor = infilestart @@ -72,26 +51,11 @@ subroutine init_et2phantom(infilestart,dt_et,nophantompart,dtout) ! setup io call set_io_unit_numbers ! routine that starts a phantom run - print*, "Start run called!" - ! Do we want to pass dt in here?? call startrun(infilestor,logfilestor,evfilestor,dumpfilestor) - print*, "Start run finished!" - !print*, "tmunugrid: ", tmunugrid(1,1,6,6,6) - !stop - ! Intialises values for the evol routine: t, dt, etc.. - !call evol_init(infilestor,logfilestor,evfilestor,dumpfilestor,dt_et,nophantompart) - !print*, "Evolve init finished!" + nophantompart = npart - ! Calculate the stress energy tensor for each particle - ! Might be better to do this in evolve init - !call get_tmunugrid_all - ! Calculate the stress energy tensor + call get_metricderivs_all(dtout,dt_et) ! commented out to try and fix prim2cons - !call get_tmunu_all(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) ! commented out to try and fix prim2cons - !call get_tmunu_all_exact(npart,xyzh,metrics,vxyzu,metricderivs,dens,tmunus) - ! Interpolate stress energy tensor from particles back - ! to grid - !call get_tmunugrid_all(npart,xyzh,vxyzu,tmunus,calc_cfac=.true.) ! commented out to try and fix cons2prim call get_phantom_dt(dtout) @@ -122,29 +86,6 @@ subroutine et2phantom(rho,nx,ny,nz) ! send grid limits end subroutine et2phantom - ! DONT THINK THIS IS USED ANYWHERE!!! - ! subroutine step_et2phantom(infile,dt_et) - ! use einsteintk_utils - ! use evolve, only:evol_step - ! use tmunu2grid - ! character(len=*), intent(in) :: infile - ! real, intent(inout) :: dt_et - ! character(len=500) :: logfile,evfile,dumpfile,path - - - ! ! Print the values of logfile, evfile, dumpfile to check they are sensible - ! !print*, "logfile, evfile, dumpfile: ", logfile, evfile, dumpfile - ! print*, "stored values of logfile, evfile, dumpfile: ", logfilestor, evfilestor, dumpfilestor - - ! ! Interpolation stuff - ! ! Call et2phantom (construct global grid, metric, metric derivs, determinant) - ! ! Run phantom for a step - ! call evol_step(infile,logfilestor,evfilestor,dumpfilestor,dt_et) - ! ! Interpolation stuff back to et - ! !call get_tmunugrid_all() - ! ! call phantom2et (Tmunu_grid) - - ! end subroutine step_et2phantom subroutine phantom2et() ! should take in the cctk_array for tmunu?? @@ -190,7 +131,6 @@ subroutine step_et2phantom_MoL(infile,dt_et,dtout) ! to grid call get_phantom_dt(dtout) - end subroutine step_et2phantom_MoL subroutine et2phantom_tmunu() @@ -208,7 +148,7 @@ subroutine et2phantom_tmunu() use linklist, only:set_linklist real :: stressmax - real(kind=16) :: cfac + real :: cfac stressmax = 0. @@ -237,15 +177,13 @@ subroutine et2phantom_tmunu() call check_conserved_dens(rhostargrid,cfac) ! Correct Tmunu - ! Convert to 8byte real to stop compiler warning - tmunugrid = real(cfac)*tmunugrid - + tmunugrid = cfac*tmunugrid 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 + use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& + Bevol,rad,radprop,metrics,igas,rhoh,alphaind,dvdx,gradh use densityforce, only:densityiterate use metric_tools, only:init_metric use linklist, only:set_linklist @@ -253,7 +191,7 @@ subroutine phantom2et_consvar() use tmunu2grid, only:check_conserved_dens real :: stressmax - real(kind=16) :: cfac + real :: cfac ! Init metric call init_metric(npart,xyzh,metrics) @@ -276,7 +214,6 @@ subroutine phantom2et_consvar() ! Interpolate entropy to grid call phantom2et_entropy - ! Conserved quantity checks + corrections ! Density check vs particles @@ -285,12 +222,9 @@ subroutine phantom2et_consvar() ! Momentum check vs particles ! Correct momentum and Density - ! Conversion of cfac to 8byte real to avoid - ! compiler warning - rhostargrid = real(cfac)*rhostargrid - pxgrid = real(cfac)*pxgrid - entropygrid = real(cfac)*entropygrid - + rhostargrid = cfac*rhostargrid + pxgrid = cfac*pxgrid + entropygrid = cfac*entropygrid end subroutine phantom2et_consvar @@ -320,9 +254,9 @@ subroutine phantom2et_rhostar() ! Get the conserved density on the particles dat = 0. pmass = massoftype(igas) - ! $omp parallel do default(none) & - ! $omp shared(npart,xyzh,dat,pmass) & - ! $omp private(i,h,rho) + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,dat,pmass) & + !$omp private(i,h,rho) do i=1, npart ! Get the smoothing length h = xyzh(4,i) @@ -331,7 +265,7 @@ subroutine phantom2et_rhostar() rho = rhoh(h,pmass) dat(i) = rho enddo - ! $omp end parallel do + !$omp end parallel do rhostargrid = 0. call interpolate_to_grid(rhostargrid,dat) @@ -348,7 +282,6 @@ subroutine phantom2et_entropy() real :: dat(npart) integer :: i - ! Get new cons density from new particle positions somehow (maybe)? ! Set linklist to update the tree for neighbour finding ! Calculate the density for the new particle positions @@ -385,7 +318,6 @@ subroutine phantom2et_momentum() real :: dat(3,npart) integer :: i - ! Pi is directly updated at the end of each MoL add ! Interpolate from particles to grid @@ -410,12 +342,8 @@ subroutine phantom2et_momentum() ! pz component call interpolate_to_grid(pxgrid(3,:,:,:),dat(3,:)) - - end subroutine phantom2et_momentum - - ! Subroutine for performing a phantom dump from einstein toolkit subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) use einsteintk_utils @@ -424,9 +352,6 @@ subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) use fileutils, only:getnextfilename use tmunu2grid, only:check_conserved_dens real, intent(in) :: time, dt_et - !real(kind=16) :: cfac - !logical, intent(in), optional :: checkpoint - !integer, intent(in) :: checkpointno character(*),optional, intent(in) :: checkpointfile logical :: createcheckpoint @@ -451,15 +376,6 @@ subroutine et2phantom_dumphydro(time,dt_et,checkpointfile) call write_fulldump(time,checkpointfile) endif - ! Quick and dirty write cfac to txtfile - - ! Density check vs particles -! call check_conserved_dens(rhostargrid,cfac) -! open(unit=777, file="cfac.txt", action='write', position='append') -! print*, time, cfac -! write(777,*) time, cfac -! close(unit=777) - end subroutine et2phantom_dumphydro ! Provides the RHS derivs for a particle at index i @@ -506,7 +422,7 @@ subroutine get_metricderivs_all(dtextforce_min,dt_et) dtextforce_min = bignumber !$omp parallel do default(none) & - !$omp shared(npart, xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & + !$omp shared(npart,xyzh,metrics,metricderivs,vxyzu,dens,C_force,fext) & !$omp firstprivate(pri) & !$omp private(i,dtf) & !$omp reduction(min:dtextforce_min) @@ -517,26 +433,18 @@ subroutine get_metricderivs_all(dtextforce_min,dt_et) dtextforce_min = min(dtextforce_min,C_force*dtf) enddo !$omp end parallel do - ! manually add v contribution from gr - ! do i=1, npart - ! !fxyzu(:,i) = fxyzu(:,i) + fext(:,i) - ! vxyzu(1:3,i) = vxyzu(1:3,i) + fext(:,i)*dt_et - ! enddo + end subroutine get_metricderivs_all subroutine get_eos_quantities(densi,en) use cons2prim, only:cons2primall - use part, only:dens,vxyzu,npart,metrics,xyzh,pxyzu,eos_vars + use part, only:dens,vxyzu,npart,metrics,xyzh,pxyzu,eos_vars real, intent(out) :: densi,en - !call h2dens(densi,xyzhi,metrici,vi) ! Compute dens from h - densi = dens(1) ! Feed the newly computed dens back out of the routine - !call cons2primall(npart,xyzh,metrics,vxyzu,dens,pxyzu,.true.) + densi = dens(1) ! Feed the newly computed dens back out of the routine call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) - ! print*,"pxyzu: ",pxyzu(:,1) - ! print*, "vxyzu: ",vxyzu(:,1) en = vxyzu(4,1) -end subroutine get_eos_quantities +end subroutine get_eos_quantities end module einsteintk_wrapper diff --git a/src/utils/interpolate3D.f90 b/src/utils/interpolate3D.f90 index 95fe2d7d6..3b9e849f5 100644 --- a/src/utils/interpolate3D.f90 +++ b/src/utils/interpolate3D.f90 @@ -85,7 +85,7 @@ subroutine interpolate3D(xyzh,weight,dat,itype,npart,& !logical, parameter :: exact_rendering = .true. ! use exact rendering y/n integer :: usedpart, negflag -!$ integer :: omp_get_num_threads,omp_get_thread_num +!$ integer, external :: omp_get_num_threads,omp_get_thread_num integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits ! Fill the particle data with xyzh @@ -425,7 +425,7 @@ subroutine interpolate3D_vecexact(xyzh,weight,dat,ilendat,itype,npart,& integer :: usedpart, negflag -!$ integer :: omp_get_num_threads,omp_get_thread_num +!$ integer, external :: omp_get_num_threads,omp_get_thread_num integer(kind=selected_int_kind(10)) :: iprogress,j ! up to 10 digits ! Fill the particle data with xyzh diff --git a/src/utils/io_structurefn.f90 b/src/utils/io_structurefn.f90 index ca736c360..00af14e20 100644 --- a/src/utils/io_structurefn.f90 +++ b/src/utils/io_structurefn.f90 @@ -242,7 +242,7 @@ subroutine openw_sf (file,origin,n_lag,lag,n_order,n_rho_power) real, intent(in) :: lag(n_lag) namelist /structurefn/n_lag,n_order,n_rho_power,origin ! - open (power_unit,file=trim(file),status='unknown',form='formatted') ! open unit + open(power_unit,file=trim(file),status='unknown',form='formatted') ! open unit write (power_unit,structurefn) ! dimensions info write (power_unit,'(1x,8g15.7)') lag ! lag vector end subroutine openw_sf diff --git a/src/utils/moddump_growthtomultigrain.f90 b/src/utils/moddump_growthtomultigrain.f90 index 0c5e599df..bcc8ab7c4 100644 --- a/src/utils/moddump_growthtomultigrain.f90 +++ b/src/utils/moddump_growthtomultigrain.f90 @@ -62,7 +62,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call prompt('Enter number of bins per dex',bins_per_dex,1) else !- file created by phantom/scripts/growthtomcfost.py module - open (unit=420, file=infile) + open(unit=420,file=infile) read(420,*) force_smax, smax_user, bins_per_dex close(unit=420) endif diff --git a/src/utils/moddump_removeparticles_radius.f90 b/src/utils/moddump_removeparticles_radius.f90 index d9bbd3e94..65bad1b90 100644 --- a/src/utils/moddump_removeparticles_radius.f90 +++ b/src/utils/moddump_removeparticles_radius.f90 @@ -42,13 +42,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)) diff --git a/src/utils/moddump_sink.f90 b/src/utils/moddump_sink.f90 index 444a45e22..01c4c3506 100644 --- a/src/utils/moddump_sink.f90 +++ b/src/utils/moddump_sink.f90 @@ -30,12 +30,12 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) real, intent(inout) :: xyzh(:,:),vxyzu(:,:),massoftype(:) integer :: i,isinkpart real :: racc,hsoft,mass,mass_old,newx,Lnuc_cgs - logical :: iresetCM + logical :: reset_CM,delete_sink print*,'Sink particles in dump:' do i=1,nptmass print "(a,1x,i4,a)",'Sink',i,':' - print "(7(a5,1x,a,1x,f13.7,/))",& + print "(7(a5,1x,a,1x,es24.16e3,/))",& 'x','=',xyzmh_ptmass(1,i),& 'y','=',xyzmh_ptmass(2,i),& 'z','=',xyzmh_ptmass(3,i),& @@ -54,39 +54,51 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call prompt('Enter the sink particle number to modify (0 to exit):',isinkpart,0,nptmass) if (isinkpart <= 0) exit - mass = xyzmh_ptmass(4,isinkpart) - mass_old = mass - call prompt('Enter new mass for the sink:',mass,0.) - print*,'Mass changed to ',mass - xyzmh_ptmass(4,isinkpart) = mass + call prompt('Delete sink?',delete_sink,.false.) + if (delete_sink) then + if (isinkpart==nptmass) then + xyzmh_ptmass(:,isinkpart) = 0. + vxyz_ptmass(:,isinkpart) = 0. + else + xyzmh_ptmass(:,isinkpart:nptmass-1) = xyzmh_ptmass(:,isinkpart+1:nptmass) + vxyz_ptmass(:,isinkpart:nptmass-1) = vxyz_ptmass(:,isinkpart+1:nptmass) + endif + nptmass = nptmass - 1 + else + mass = xyzmh_ptmass(4,isinkpart) + mass_old = mass + call prompt('Enter new mass for the sink:',mass,0.) + print*,'Mass changed to ',mass + xyzmh_ptmass(4,isinkpart) = mass - racc = xyzmh_ptmass(ihacc,isinkpart) - ! rescaling accretion radius for updated mass - racc = racc * (mass/mass_old)**(1./3) - call prompt('Enter new accretion radius for the sink:',racc,0.) - print*,'Accretion radius changed to ',racc - xyzmh_ptmass(ihacc,isinkpart) = racc + racc = xyzmh_ptmass(ihacc,isinkpart) + ! rescaling accretion radius for updated mass + racc = racc * (mass/mass_old)**(1./3) + call prompt('Enter new accretion radius for the sink:',racc,0.) + print*,'Accretion radius changed to ',racc + xyzmh_ptmass(ihacc,isinkpart) = racc - hsoft = xyzmh_ptmass(ihsoft,isinkpart) - call prompt('Enter new softening length for the sink:',hsoft,0.) - print*,'Softening length changed to ',hsoft - xyzmh_ptmass(ihsoft,isinkpart) = hsoft + hsoft = xyzmh_ptmass(ihsoft,isinkpart) + call prompt('Enter new softening length for the sink:',hsoft,0.) + print*,'Softening length changed to ',hsoft + xyzmh_ptmass(ihsoft,isinkpart) = hsoft - newx = xyzmh_ptmass(1,isinkpart) - call prompt('Enter new x-coordinate for the sink in code units:',newx,0.) - xyzmh_ptmass(1,isinkpart) = newx - print*,'x-coordinate changed to ',xyzmh_ptmass(1,isinkpart) + newx = xyzmh_ptmass(1,isinkpart) + call prompt('Enter new x-coordinate for the sink in code units:',newx,0.) + xyzmh_ptmass(1,isinkpart) = newx + print*,'x-coordinate changed to ',xyzmh_ptmass(1,isinkpart) - Lnuc = xyzmh_ptmass(ilum,isinkpart) - Lnuc_cgs = Lnuc * unit_energ / utime - call prompt('Enter new sink heating luminosity in erg/s:',Lnuc_cgs,0.) - xyzmh_ptmass(ilum,isinkpart) = Lnuc_cgs / unit_energ * utime - print*,'Luminosity [erg/s] changed to ',xyzmh_ptmass(ilum,isinkpart) * unit_energ / utime + Lnuc = xyzmh_ptmass(ilum,isinkpart) + Lnuc_cgs = Lnuc * unit_energ / utime + call prompt('Enter new sink heating luminosity in erg/s:',Lnuc_cgs,0.) + xyzmh_ptmass(ilum,isinkpart) = Lnuc_cgs / unit_energ * utime + print*,'Luminosity [erg/s] changed to ',xyzmh_ptmass(ilum,isinkpart) * unit_energ / utime + endif enddo - iresetCM = .false. - call prompt('Reset centre of mass?',iresetCM) - if (iresetCM) call reset_centreofmass(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) + reset_CM = .false. + call prompt('Reset centre of mass?',reset_CM) + if (reset_CM) call reset_centreofmass(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) return end subroutine modify_dump diff --git a/src/utils/powerspectrums.f90 b/src/utils/powerspectrums.f90 index 0ffd56515..de772a8b6 100644 --- a/src/utils/powerspectrums.f90 +++ b/src/utils/powerspectrums.f90 @@ -89,7 +89,7 @@ subroutine power_fourier(npts,x,dat,omega,power) sum1 = sum1 + dat(i)*cos(-omega*x(i)) sum2 = sum2 + dat(i)*sin(-omega*x(i)) enddo - power= sqrt(sum1**2 + sum2**2)/REAL(npts) + power= sqrt(sum1**2 + sum2**2)/real(npts) return end subroutine power_fourier diff --git a/src/utils/prompting.f90 b/src/utils/prompting.f90 index c87e5f77c..b68033c5f 100644 --- a/src/utils/prompting.f90 +++ b/src/utils/prompting.f90 @@ -104,7 +104,7 @@ module prompting ! 06/05/11: D. Price: ! Added prompt for integer arrays ! - + implicit none private ! @@ -492,7 +492,7 @@ recursive subroutine string_prompt(text, string, length, case, noblank, list) integer, optional, intent(out) :: length integer, optional, intent(in) :: case logical, optional, intent(in) :: noblank - integer :: is, ia + integer :: is,ia,i integer, parameter :: aoffset = 32 logical :: allowblank,inlist character(len=*), intent(in), optional :: list(:) diff --git a/src/utils/struct_part.f90 b/src/utils/struct_part.f90 new file mode 100644 index 000000000..781a3c2fd --- /dev/null +++ b/src/utils/struct_part.f90 @@ -0,0 +1,269 @@ +!--------------------------------------------------------------------------! +! 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 structurefn_part +! +! module for obtaining structure functions +! direct from SPH particles +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: random, timing +! + implicit none + +contains + +subroutine get_structure_fn(sf,nbins,norder,distmin,distmax,xbins,ncount,npart,xyz,vel,& + rho,dxbox,dybox,dzbox,massweighted,ierr) + !use fastmath, only:finvsqrt + use timing, only:get_timings,print_time + use random, only:ran2 + integer, intent(in) :: npart,nbins,norder + real, intent(in) :: xyz(:,:) + real, intent(in) :: vel(:,:) + real, intent(in) :: rho(:) + real(kind=8), intent(out) :: sf(2,norder,nbins) + real, intent(out) :: xbins(nbins) + integer(kind=8), intent(out) :: ncount(nbins) + real, intent(in) :: distmax,distmin + real, intent(in) :: dxbox,dybox,dzbox + logical, intent(in) :: massweighted + integer, intent(out) :: ierr + + real(kind=8) :: sfprev(2,norder,nbins) + integer, allocatable :: list(:) + integer :: i,iran,ipart,ipt,iorder,ibin,iseed,npts,isf,nptstot,its + real :: err(norder),sfmax(norder) + real :: xpt(3),velpt(3) + real :: dxbin,dvx,dvy,dvz,dx,dy,dz,rij1,rij + real(kind=4) :: t1,t2,tcpu1,tcpu2 + real :: rij2,distmin2,ddxbin,minusdistminddxbin + real :: dvdotr,dvterm,dvtrans,rhomax,errtot,temp + real(kind=8) :: dvdotrterm,dvtransterm +!$ integer :: omp_get_num_threads + logical :: converged +! +!--set up the distance bins (linear) +! + dxbin = (distmax-distmin)/float(nbins-1) + do ibin=1,nbins + xbins(ibin) = distmin + (ibin-0.5)*dxbin + enddo + distmin2 = distmin*distmin + ddxbin = 1./dxbin + minusdistminddxbin = -distmin*ddxbin + ierr = 0 +! +!--set structure functions to zero +! + sf(:,:,:) = 0. + sfprev(:,:,:) = 0. + ncount(:) = 0 + iseed = -128 + npts = min(128,npart) + nptstot = 0 + its = 0 +! +!--start with a low number of points, and we keep adding more +! points until the structure function calculation is converged +! + converged = .false. + !$omp parallel + !$omp master +!$ print*,' Using ',omp_get_num_threads(),' cpus' + !$omp end master + !$omp end parallel + + iterations: do while(nptstot <= npart .and. .not.converged) + + its = its + 1 + nptstot = nptstot + npts + print "(a,i2,2(a,i10),a)",' Iteration ',its,': adding ',npts,' sample particles (',nptstot,' in total)' + if (allocated(list)) deallocate(list) + allocate(list(npts),stat=ierr) + if (ierr /= 0) then + print*,' error: cannot allocate memory for ',npts,' sample particles ' + sf = sfprev + return + endif + print*,' iseed = ',iseed,' ncount(1:10) = ',ncount(1:10) + + ! + !--choose a random selection of npts particles + ! + if (massweighted) then + ! + !--select particles randomly according to particle id + ! (this preferentially selects particles in dense regions) + ! + do ipt=1,npts + iran = int(ran2(iseed)*npart) + 1 + list(ipt) = iran + enddo + else + ! + !--alternatively, select particles but weight selection by + ! the volume element m/rho, i.e., inversely proportional to rho + ! + rhomax = 0. + !$omp parallel do schedule(static) private(i) reduction(max:rhomax) + do i=1,npart + rhomax = max(rho(i),rhomax) + enddo + if (rhomax <= 0.) then + print*,' ERROR: max density on particles <= 0' + print*,' cannot use volume element weighting for structure fns' + return + endif + ipt = 0 + write(*,"(2x,a,i8,a)",ADVANCE='NO') 'choosing ',npts,' volume-weighted points...' + do while(ipt < npts) +!--first random number chooses the particle + iran = int(ran2(iseed)*npart) + 1 +!--then select particle if rho/rhomax (0..1) is less than +! a second random number + if (rho(iran)/rhomax < ran2(iseed)) then + ipt = ipt + 1 + list(ipt) = iran + endif + enddo + print*,' done' + endif + + call get_timings(t1,tcpu1) + !$omp parallel do schedule(runtime) default(none) & + !$omp shared(npts,xyz,vel,list,npart,tcpu1) & + !$omp firstprivate(distmin2,dxbox,dybox,dzbox,ddxbin,norder,minusdistminddxbin) & + !$omp private(ipt,xpt,velpt,dx,dy,dz,rij2,rij1,rij,dvdotr) & + !$omp private(i,dvx,dvy,dvz,tcpu2) & + !$omp private(dvterm,dvtrans,dvdotrterm,dvtransterm,ibin) & + !$omp reduction(+:ncount) & + !$omp reduction(+:sf) + do ipt=1,npts +!$ if (.false.) then + if (mod(ipt,100)==0) then + call cpu_time(tcpu2) + print*,' ipt = ',ipt,tcpu2-tcpu1 + endif +!$ endif + i = list(ipt) + xpt(1) = xyz(1,i) + xpt(2) = xyz(2,i) + xpt(3) = xyz(3,i) + velpt(1) = vel(1,i) + velpt(2) = vel(2,i) + velpt(3) = vel(3,i) + + do ipart=1,npart + dx = xyz(1,ipart) - xpt(1) + dy = xyz(2,ipart) - xpt(2) + dz = xyz(3,ipart) - xpt(3) + !--mod distances with periodic boundary + if (abs(dx) > 0.5*dxbox) dx = dx - dxbox*sign(1.0,dx) + if (abs(dy) > 0.5*dybox) dy = dy - dybox*sign(1.0,dy) + if (abs(dz) > 0.5*dzbox) dz = dz - dzbox*sign(1.0,dz) + + rij2 = dx*dx + dy*dy + dz*dz +! +!--work out which distance bin this pair lies in +! exclude pairs which lie closer than the minimum +! separation bin +! + if (rij2 > distmin2) then + dvx = vel(1,ipart) - velpt(1) + dvy = vel(2,ipart) - velpt(2) + dvz = vel(3,ipart) - velpt(3) + + ! rij1 = finvsqrt(rij2) + rij1 = 1./sqrt(rij2) + + dvdotr = abs((dvx*dx + dvy*dy + dvz*dz)*rij1) + dvterm = (dvx*dvx + dvy*dvy + dvz*dvz) - dvdotr*dvdotr + if (dvterm < 0.) dvterm = 0. + dvtrans = sqrt(dvterm) + + rij = 1./rij1 + ibin = int(rij*ddxbin + minusdistminddxbin) + 1 + !if (ibin < 1 .or. ibin > nbins) stop 'ibin out of range' + + dvdotrterm = 1.0d0 + dvtransterm = 1.0d0 + do iorder=1,norder + dvdotrterm = dvdotrterm*dvdotr ! dvdotrterm = dvdotr**iorder + dvtransterm = dvtransterm*dvtrans ! dvtransterm = dvtrans**iorder + + sf(1,iorder,ibin) = sf(1,iorder,ibin) + dvdotrterm + sf(2,iorder,ibin) = sf(2,iorder,ibin) + dvtransterm + enddo + ncount(ibin) = ncount(ibin) + 1_8 + endif + enddo + enddo + !$omp end parallel do + call get_timings(t2,tcpu2) + call print_time(t2-t1,' wall time :') + call print_time(tcpu2-tcpu1,' cpu time :') + + err(:) = 0. + sfmax(:) = 0. + !$omp parallel do schedule(runtime) private(ibin) & + !$omp reduction(+:err) & + !$omp reduction(max:sfmax) + do ibin=1,nbins + if (ncount(ibin) > 0) then + do iorder=1,norder + do isf=1,2 + temp = sf(isf,iorder,ibin)/real(ncount(ibin)) + err(iorder) = err(iorder) + (temp - sfprev(isf,iorder,ibin))**2 + sfmax(iorder) = max(sfmax(iorder),temp) + sfprev(isf,iorder,ibin) = temp + enddo + enddo + else + sfprev(:,:,ibin) = 0. + endif + enddo + !$omp end parallel do + + errtot = 0. + do iorder=1,norder + if (sfmax(iorder) > 0.) then + err(iorder) = err(iorder)/sfmax(iorder)**2/real(nbins*2) + endif + errtot = errtot + err(iorder) + print*,' Error in structure function of order ',iorder,' = ',sqrt(err(iorder)) + enddo + errtot = sqrt(errtot/real(norder)) + print*,' mean square error = ',errtot + converged = maxval(sqrt(err(1:norder))) < 1.e-2 .and. errtot < 1.e-2 + npts = min(nptstot,npart-nptstot) + + ! + !--write the iterations to file (debugging only) + ! + !do i=1,nbins + ! write(10+its,*) xbins(i),(sfprev(1,iorder,i),iorder=1,norder) + !enddo + + enddo iterations + + print*,' Converged!' + + !$omp parallel do schedule(static) private(ibin) + do ibin=1,nbins + sf(:,:,ibin) = sfprev(:,:,ibin) + enddo + + if (allocated(list)) deallocate(list) + +end subroutine get_structure_fn + +end module structurefn_part diff --git a/src/utils/utils_getneighbours.F90 b/src/utils/utils_getneighbours.F90 index 0e889d282..d63d33e1c 100644 --- a/src/utils/utils_getneighbours.F90 +++ b/src/utils/utils_getneighbours.F90 @@ -183,9 +183,9 @@ subroutine generate_neighbour_lists(xyzh,vxyzu,npart,dumpfile,write_neighbour_li ! 3. Output neighbour lists to file (if requested; these files can become very big) !************************************** if (write_neighbour_list) then - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) call write_neighbours(neighbourfile, npart) - print*, 'Neighbour finding complete for file ', TRIM(dumpfile) + print*, 'Neighbour finding complete for file ', trim(dumpfile) endif deallocate(dumxyzh) @@ -214,7 +214,7 @@ subroutine neighbours_stats(npart) stop endif - meanneigh = sum(neighcount)/REAL(npart) + meanneigh = sum(neighcount)/real(npart) sdneigh = 0.0 !$omp parallel default(none) & @@ -228,7 +228,7 @@ subroutine neighbours_stats(npart) !$omp enddo !$omp end parallel - sdneigh = sqrt(sdneigh/REAL(npart)) + sdneigh = sqrt(sdneigh/real(npart)) print*, 'Mean neighbour number is ', meanneigh print*, 'Standard Deviation: ', sdneigh @@ -250,8 +250,8 @@ subroutine read_neighbours(neighbourfile,npart) neighcount(:) = 0 neighb(:,:) = 0 - print*, 'Reading neighbour file ', TRIM(neighbourfile) - open(2, file= neighbourfile, form = 'UNFORMATTED') + print*, 'Reading neighbour file ', trim(neighbourfile) + open(2,file= neighbourfile, form = 'UNFORMATTED') read(2) neighcheck, tolcheck, meanneigh,sdneigh,neighcrit if (neighcheck/=neighmax) print*, 'WARNING: mismatch in neighmax: ', neighmax, neighcheck read(2) (neighcount(i), i=1,npart) @@ -287,10 +287,10 @@ subroutine write_neighbours(neighbourfile,npart) real, parameter :: tolerance = 2.0e0 ! A dummy parameter used to keep file format similar to other codes (Probably delete later) neigh_overload = .false. - neighbourfile = TRIM(neighbourfile) + neighbourfile = trim(neighbourfile) print*, 'Writing neighbours to file ', neighbourfile - open (2, file=neighbourfile, form='unformatted') + open(2,file=neighbourfile,form='unformatted') write(2) neighmax, tolerance, meanneigh,sdneigh,neighcrit write(2) (neighcount(i), i=1,npart) do i=1,npart diff --git a/src/utils/utils_gravwave.f90 b/src/utils/utils_gravwave.f90 index 225f091b6..5f568aaad 100644 --- a/src/utils/utils_gravwave.f90 +++ b/src/utils/utils_gravwave.f90 @@ -272,7 +272,7 @@ subroutine write_rotated_strain_components(time,ddq_xy) ! Write a file where I append all the values of the strain wrt time if (firstdump) then firstdump = .false. - open(newunit=iuu, file='quadrupole_plane_xy.txt',status='replace') + open(newunit=iuu,file='quadrupole_plane_xy.txt',status='replace') write(iuu,"('#',7(1x,'[',i2.2,1x,a11,']',2x))") & 1, 'time', & 2, 'ddm11', & @@ -282,7 +282,7 @@ subroutine write_rotated_strain_components(time,ddq_xy) 6, 'ddm23', & 7, 'ddm33' else - open(newunit=iuu, file='quadrupole_plane_xy.txt',position='append') + open(newunit=iuu,file='quadrupole_plane_xy.txt',position='append') endif write(iuu,'(7(es18.10,1X))') time, ddq_xy(1,1),ddq_xy(1,2),ddq_xy(1,3),& ddq_xy(2,2),ddq_xy(2,3),ddq_xy(3,3) diff --git a/src/utils/utils_raytracer_all.f90 b/src/utils/utils_raytracer_all.f90 new file mode 100644 index 000000000..a257b00c4 --- /dev/null +++ b/src/utils/utils_raytracer_all.f90 @@ -0,0 +1,1199 @@ +!--------------------------------------------------------------------------! +! 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 raytracer_all +! +! raytracer_all +! +! :References: Esseldeurs M., Siess L. et al, 2023, A&A, 674, A122 +! +! :Owner: Mats Esseldeurs +! +! :Runtime parameters: None +! +! :Dependencies: healpix, kernel, linklist, part, units +! + use healpix + implicit none + public :: get_all_tau_outwards, get_all_tau_inwards, get_all_tau_adaptive + private +contains + + !*********************************************************************! + !*************************** ADAPTIVE ****************************! + !*********************************************************************! + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the adaptive ray- + ! tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa: The array containing the kappa of all SPH particles + ! IN: Rstar: The radius of the star + ! IN: minOrder: The minimal order in which the rays are sampled + ! IN: refineLevel: The amount of orders in which the rays can be + ! sampled deeper + ! IN: refineScheme: The refinement scheme used for adaptive ray selection + !+ + ! OUT: taus: The list of optical depths for each particle + !+ + ! OPT: companion: The xyz coordinates of the companion + ! OPT: Rcomp: The radius of the companion + !+ + !-------------------------------------------------------------------------- +subroutine get_all_tau_adaptive(npart, primary, xyzh, kappa, Rstar, minOrder,& + refineLevel, refineScheme, taus, companion, Rcomp) + integer, intent(in) :: npart, minOrder, refineLevel, refineScheme + real, intent(in) :: primary(3), kappa(:), xyzh(:,:), Rstar + real, optional :: Rcomp, companion(3) + real, intent(out) :: taus(:) + + integer :: i, nrays, nsides, index + real :: normCompanion, theta0, unitCompanion(3), theta, root, dist, vec(3), dir(3) + real, dimension(:,:), allocatable :: dirs + real, dimension(:,:), allocatable :: listsOfDists, listsOfTaus + integer, dimension(:), allocatable :: indices, rays_dim + real, dimension(:), allocatable :: tau, dists + + if (present(companion) .and. present(Rcomp)) then + unitCompanion = companion-primary + normCompanion = norm2(unitCompanion) + theta0 = asin(Rcomp/normCompanion) + unitCompanion = unitCompanion/normCompanion + + call get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, dirs, indices, nrays) + allocate(listsOfDists(200, nrays)) + allocate(listsOfTaus(size(listsOfDists(:,1)), nrays)) + allocate(tau(size(listsOfDists(:,1)))) + allocate(dists(size(listsOfDists(:,1)))) + allocate(rays_dim(nrays)) + + !$omp parallel do private(tau,dist,dir,dists,root,theta) + do i = 1, nrays + tau=0. + dists=0. + dir = dirs(:,i) + theta = acos(dot_product(unitCompanion, dir)) + if (theta < theta0) then + root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) + dist = normCompanion*cos(theta)-root + call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i), dist) + else + call ray_tracer(primary, dir, xyzh, kappa, Rstar, tau, dists, rays_dim(i)) + endif + listsOfTaus(:,i) = tau + listsOfDists(:,i) = dists + enddo + !$omp end parallel do + + nsides = 2**(minOrder+refineLevel) + taus = 0. + !$omp parallel do private(index,vec) + do i = 1, npart + vec = xyzh(1:3,i)-primary + call vec2pix_nest(nsides, vec, index) + index = indices(index + 1) + call get_tau_on_ray(norm2(vec), listsOfTaus(:,index), listsOfDists(:,index), rays_dim(index), taus(i)) + enddo + !$omp end parallel do + + else + call get_all_tau_outwards_single(npart, primary, xyzh, kappa, & + Rstar, minOrder+refineLevel, 0, taus) + endif +end subroutine get_all_tau_adaptive + + !-------------------------------------------------------------------------- + !+ + ! Return all the directions of the rays that need to be traced for the + ! adaptive ray-tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: companion: The xyz coordinates of the companion + ! IN: Rcomp: The radius of the companion + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: minOrder: The minimal order in which the rays are sampled + ! IN: refineLevel: The amount of orders in which the rays can be + ! sampled deeper + ! IN: refineScheme: The refinement scheme used for adaptive ray selection + !+ + ! OUT: rays: A list containing the rays that need to be traced + ! in the adaptive ray-tracing scheme + ! OUT: indices: A list containing a link between the index in the + ! deepest order and the rays in the adaptive ray-tracing scheme + ! OUT: nrays: The number of rays after the ray selection + !+ + !-------------------------------------------------------------------------- +subroutine get_rays(npart, primary, companion, Rcomp, xyzh, minOrder, refineLevel, refineScheme, rays, indices, nrays) + integer, intent(in) :: npart, minOrder, refineLevel, refineScheme + real, intent(in) :: primary(3), companion(3), xyzh(:,:), Rcomp + real, allocatable, intent(out) :: rays(:,:) + integer, allocatable, intent(out) :: indices(:) + integer, intent(out) :: nrays + + real :: theta, dist, phi, cosphi, sinphi + real, dimension(:,:), allocatable :: circ + integer :: i, j, minNsides, minNrays, ind,n, maxOrder, max, distr(12*4**(minOrder+refineLevel)) + integer, dimension(:,:), allocatable :: distrs + + maxOrder = minOrder+refineLevel + nrays = 12*4**(maxOrder) + allocate(rays(3, nrays)) + allocate(indices(12*4**(maxOrder))) + rays = 0. + indices = 0 + + !If there is no refinement, just return the uniform ray distribution + minNsides = 2**minOrder + minNrays = 12*4**minOrder + if (refineLevel == 0) then + do i=1, minNrays + call pix2vec_nest(minNsides,i-1, rays(:,i)) + indices(i) = i + enddo + return + endif + + !Fill a list to have the number distribution in angular space + distr = 0 + !$omp parallel do private(ind) + do i = 1, npart + call vec2pix_nest(2**maxOrder, xyzh(1:3, i)-primary, ind) + distr(ind+1) = distr(ind+1)+1 + enddo + max = maxval(distr) + + !Make sure the companion is described using the highest refinement + dist = norm2(primary-companion) + theta = asin(Rcomp/dist) + phi = atan2(companion(2)-primary(2),companion(1)-primary(1)) + cosphi = cos(phi) + sinphi = sin(phi) + dist = dist*cos(theta) + n = int(theta*6*2**(minOrder+refineLevel))+4 + allocate(circ(n,3)) + do i=1, n !Define boundary of the companion + circ(i,1) = dist*cos(theta) + circ(i,2) = dist*sin(theta)*cos(twopi*i/n) + circ(i,3) = dist*sin(theta)*sin(twopi*i/n) + circ(i,:) = (/cosphi*circ(i,1) - sinphi*circ(i,2),sinphi*circ(i,1) + cosphi*circ(i,2), circ(i,3)/) + enddo + do i=1, n !Make sure the boundary is maximally refined + call vec2pix_nest(2**maxOrder,circ(i,:),ind) + distr(ind+1) = max + enddo + + !Calculate the number distribution in all the orders needed + allocate(distrs(12*4**(minOrder+refineLevel),refineLevel+1)) + distrs = 0 + distrs(:,1) = distr + do i = 1, refineLevel + do j = 1, 12*4**(maxOrder-i) + distrs(j,i+1) = distrs(4*j,i)+distrs(4*j+1,i)+distrs(4*j+2,i)+distrs(4*j+3,i) + enddo + enddo + max = maxval(distrs(:,refineLevel+1))+1 + + !Fill the rays array walking through the orders + ind=1 + + ! refine half in each order + if (refineScheme == 1) then + do i=0, refineLevel-1 + call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) + do j=1, 6*4**minOrder*2**(i) + call pix2vec_nest(2**(minOrder+i), distr(j)-1, rays(:,ind)) + indices(4**(refineLevel-i)*(distr(j)-1)+1:4**(refineLevel-i)*distr(j)) = ind + ind=ind+1 + distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max + enddo + do j = j+1, 12*4**(minOrder+i) + if (distrs(distr(j),refineLevel-i+1) == max) then + distrs(4*(distr(j)-1)+1:4*(distr(j)), refineLevel-i) = max + endif + enddo + enddo + + ! refine overdens regions in each order + elseif (refineScheme == 2) then + do i=0, refineLevel-1 + call merge_argsort(distrs(1:12*4**(minOrder+i),refineLevel-i+1), distr) + j=1 + do while (distrs(distr(j),refineLevel-i+1) 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 9 rays, linear interpolation + elseif (raypolation==2) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = norm2(vectemp) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,nneigh + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 4 rays, square interpolation + elseif (raypolation==3) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = dot_product(vectemp,vectemp) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = dot_product(vectemp,vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 9 rays, square interpolation + elseif (raypolation==4) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = dot_product(vectemp,vectemp) + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = dot_product(vectemp,vectemp) + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,nneigh + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 4 rays, cubed interpolation + elseif (raypolation==5) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = norm2(vectemp)**3 + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp)**3 + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,3 + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + + ! 9 rays, cubed interpolation + elseif (raypolation==6) then + vec_norm2 = norm2(vec) + !returns rayIndex, the index of the ray vector that points to the particle (direction vec) + call vec2pix_nest(nsides, vec, rayIndex) + !returns ray(3), the unit vector identifying the ray with index number rayIndex + call pix2vec_nest(nsides, rayIndex, ray) + vectemp = vec - vec_norm2*ray + distRay_sq = norm2(vectemp)**3 + call get_tau_on_ray(vec_norm2, rays_tau(:,rayIndex+1), rays_dist(:,rayIndex+1), rays_dim(rayIndex+1), tautemp) + if (distRay_sq > 0.) then + tau = tautemp/distRay_sq + weight = 1./distRay_sq + else + ! the particle sits exactly on the ray, no need to get the neighbours + tau = tautemp + return + endif + + !returns the number nneigh and list of vectors (n) neighbouring the ray number index + call neighbours_nest(nsides, rayIndex, neighbours, nneigh) + !for each neighbouring ray calculate its distance to the particle + do i=1,nneigh + call pix2vec_nest(nsides, neighbours(i), ray) + vectemp = vec - vec_norm2*ray + tempdist(i) = norm2(vectemp)**3 + enddo + neighbours = neighbours+1 + mask = .true. + if (nneigh <8) mask(nneigh+1:8) = .false. + !take tau contribution from the 3 closest rays + do i=1,nneigh + k = minloc(tempdist,1,mask) + mask(k) = .false. + call get_tau_on_ray(vec_norm2, rays_tau(:,neighbours(k)), & + rays_dist(:,neighbours(k)), rays_dim(neighbours(k)), tautemp) + tau = tau + tautemp/tempdist(k) + weight = weight + 1./tempdist(k) + enddo + tau = tau / weight + endif +end subroutine interpolate_tau + + + !-------------------------------------------------------------------------- + !+ + ! Interpolation of the optical depth for an arbitrary point on the ray, + ! with a given distance to the starting point of the ray. + !+ + ! IN: distance: The distance from the staring point of the ray to a + ! point on the ray + ! IN: tau_along_ray: The vector of cumulative optical depths along the ray + ! IN: dist_along_ray: The vector of distances from the primary along the ray + ! IN: len: The length of listOfTau and listOfDist + !+ + ! OUT: tau: The optical depth to the given distance along the ray + !+ + !-------------------------------------------------------------------------- +subroutine get_tau_on_ray(distance, tau_along_ray, dist_along_ray, len, tau) + real, intent(in) :: distance, tau_along_ray(:), dist_along_ray(:) + integer, intent(in) :: len + real, intent(out) :: tau + + integer :: L, R, m ! left, right and middle index for binary search + + if (distance < dist_along_ray(1)) then + tau = 0. + elseif (distance > dist_along_ray(len)) then + tau = 99. + else + L = 2 + R = len-1 + !bysection search for the index of the closest ray location to the particle + do while (L < R) + m = (L + R)/2 + if (dist_along_ray(m) > distance) then + R = m + else + L = m + 1 + endif + enddo + !interpolate linearly ray properties to get the particle's optical depth + tau = tau_along_ray(L-1)+(tau_along_ray(L)-tau_along_ray(L-1))/ & + (dist_along_ray(L)-dist_along_ray(L-1))*(distance-dist_along_ray(L-1)) + endif +end subroutine get_tau_on_ray + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth along a given ray + !+ + ! IN: primary: The location of the primary star + ! IN: ray: The unit vector of the direction in which the + ! optical depts will be calculated + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: kappa: The array containing the particles opacity + ! IN: Rstar: The radius of the primary star + !+ + ! OUT: taus: The distribution of optical depths throughout the ray + ! OUT: listOfDists: The distribution of distances throughout the ray + ! OUT: len: The length of tau_along_ray and dist_along_ray + !+ + ! OPT: maxDistance: The maximal distance the ray needs to be traced + !+ + !-------------------------------------------------------------------------- +subroutine ray_tracer(primary, ray, xyzh, kappa, Rstar, tau_along_ray, dist_along_ray, len, maxDistance) + use linklist, only:getneigh_pos,ifirstincell,listneigh + use kernel, only:radkern + use units, only:umass,udist + real, intent(in) :: primary(3), ray(3), Rstar, xyzh(:,:), kappa(:) + real, optional :: maxDistance + real, intent(out) :: dist_along_ray(:), tau_along_ray(:) + integer, intent(out) :: len + + integer, parameter :: maxcache = 0 + real, allocatable :: xyzcache(:,:) + real :: distance, h, dtaudr, previousdtaudr, nextdtaudr + integer :: nneigh, inext, i + + distance = Rstar + + h = Rstar/100. + inext=0 + do while (inext==0) + h = h*2. + call getneigh_pos(primary+Rstar*ray,0.,h,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) + call find_next(primary, ray, distance, xyzh, listneigh, inext, nneigh) + enddo + call calc_opacity(primary+Rstar*ray, xyzh, kappa, listneigh, nneigh, previousdtaudr) + + i = 1 + tau_along_ray(i) = 0. + distance = Rstar + dist_along_ray(i) = distance + do while (hasNext(inext,tau_along_ray(i),distance,maxDistance)) + i = i + 1 + call getneigh_pos(primary + distance*ray,0.,xyzh(4,inext)*radkern, & + 3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) + call calc_opacity(primary + distance*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) + dtaudr = (nextdtaudr+previousdtaudr)/2 + previousdtaudr = nextdtaudr + tau_along_ray(i) = tau_along_ray(i-1)+(distance-dist_along_ray(i-1))*dtaudr + dist_along_ray(i) = distance + call find_next(primary, ray, distance, xyzh, listneigh, inext,nneigh) + enddo + len = i + tau_along_ray = tau_along_ray*umass/(udist**2) +end subroutine ray_tracer + +logical function hasNext(inext, tau, distance, maxDistance) + integer, intent(in) :: inext + real, intent(in) :: distance, tau + real, optional :: maxDistance + real, parameter :: tau_max = 99. + if (present(maxDistance)) then + hasNext = inext /= 0 .and. distance < maxDistance .and. tau < tau_max + else + hasNext = inext /= 0 .and. tau < tau_max + endif +end function hasNext + + !*********************************************************************! + !**************************** INWARDS ****************************! + !*********************************************************************! + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the inwards ray- + ! tracing scheme + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + !+ + ! OUT: tau: The array of optical depths for each SPH particle + !+ + ! OPT: companion: The location of the companion + ! OPT: R: The radius of the companion + !+ + !-------------------------------------------------------------------------- +subroutine get_all_tau_inwards(npart, primary, xyzh, neighbors, kappa, Rstar, tau, companion, R) + real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) + integer, intent(in) :: npart, neighbors(:,:) + real, optional :: R, companion(3) + real, intent(out) :: tau(:) + + if (present(companion) .and. present(R)) then + call get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, R, tau) + else + call get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) + endif +end subroutine get_all_tau_inwards + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the inwards ray- + ! tracing scheme concerning only a single star + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + !+ + ! OUT: taus: The list of optical depths for each particle + !+ + !-------------------------------------------------------------------------- +subroutine get_all_tau_inwards_single(npart, primary, xyzh, neighbors, kappa, Rstar, tau) + real, intent(in) :: primary(3), kappa(:), Rstar, xyzh(:,:) + integer, intent(in) :: npart, neighbors(:,:) + real, intent(out) :: tau(:) + + integer :: i + + !$omp parallel do + do i = 1, npart + call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) + enddo + !$omp end parallel do +end subroutine get_all_tau_inwards_single + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth of each particle, using the inwards ray- + ! tracing scheme concerning a binary system + !+ + ! IN: npart: The number of SPH particles + ! IN: primary: The xyz coordinates of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the primary star + ! IN: companion: The xyz coordinates of the companion + ! IN: Rcomp: The radius of the companion + !+ + ! OUT: tau: The array of optical depths for each SPH particle + !+ + !-------------------------------------------------------------------------- +subroutine get_all_tau_inwards_companion(npart, primary, xyzh, neighbors, kappa, Rstar, companion, Rcomp, tau) + real, intent(in) :: primary(3), companion(3), kappa(:), Rstar, xyzh(:,:), Rcomp + integer, intent(in) :: npart, neighbors(:,:) + real, intent(out) :: tau(:) + + integer :: i + real :: normCompanion, theta0, uvecCompanion(3), norm, theta, root, norm0 + + uvecCompanion = companion-primary + normCompanion = norm2(uvecCompanion) + uvecCompanion = uvecCompanion/normCompanion + theta0 = asin(Rcomp/normCompanion) + + !$omp parallel do private(norm,theta,root,norm0) + do i = 1, npart + norm = norm2(xyzh(1:3,i)-primary) + theta = acos(dot_product(uvecCompanion, xyzh(1:3,i)-primary)/norm) + if (theta < theta0) then + root = sqrt(normCompanion**2*cos(theta)**2-normCompanion**2+Rcomp**2) + norm0 = normCompanion*cos(theta)-root + if (norm > norm0) then + tau(i) = 99. + else + call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) + endif + else + call get_tau_inwards(i, primary, xyzh, neighbors, kappa, Rstar, tau(i)) + endif + enddo + !$omp end parallel do +end subroutine get_all_tau_inwards_companion + + !-------------------------------------------------------------------------- + !+ + ! Calculate the optical depth for a given particle, using the inwards ray- + ! tracing scheme + !+ + ! IN: point: The index of the point that needs to be calculated + ! IN: primary: The location of the primary star + ! IN: xyzh: The array containing the particles position+smooting lenght + ! IN: neighbors: A list containing the indices of the neighbors of + ! each particle + ! IN: kappa: The array containing the opacity of all the SPH particles + ! IN: Rstar: The radius of the star + !+ + ! OUT: tau: The list of optical depth of the given particle + !+ + !-------------------------------------------------------------------------- +subroutine get_tau_inwards(point, primary, xyzh, neighbors, kappa, Rstar, tau) + use linklist, only:getneigh_pos,ifirstincell,listneigh + use kernel, only:radkern + use units, only:umass,udist + real, intent(in) :: primary(3), xyzh(:,:), kappa(:), Rstar + integer, intent(in) :: point, neighbors(:,:) + real, intent(out) :: tau + + integer :: i, next, previous, nneigh + integer, parameter :: nmaxcache = 0 + real :: xyzcache(0,nmaxcache) + real :: ray(3), nextDist, previousDist, maxDist, dtaudr, previousdtaudr, nextdtaudr + + ray = primary - xyzh(1:3,point) + maxDist = norm2(ray) + ray = ray / maxDist + maxDist=max(maxDist-Rstar,0.) + next=point + call getneigh_pos(xyzh(1:3,point),0.,xyzh(4,point)*radkern, & + 3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) + call calc_opacity(xyzh(1:3,point), xyzh, kappa, listneigh, nneigh, nextdtaudr) + nextDist=0. + + tau = 0. + i=1 + do while (nextDist < maxDist .and. next /=0) + i = i + 1 + previous = next + previousDist = nextDist + call find_next(xyzh(1:3,point), ray, nextDist, xyzh, neighbors(next,:), next) + if (nextDist > maxDist) then + nextDist = maxDist + endif + call getneigh_pos(xyzh(1:3,point) + nextDist*ray,0.,xyzh(4,previous)*radkern, & + 3,listneigh,nneigh,xyzh,xyzcache,nmaxcache,ifirstincell) + previousdtaudr=nextdtaudr + call calc_opacity(xyzh(1:3,point) + nextDist*ray, xyzh, kappa, listneigh, nneigh, nextdtaudr) + dtaudr = (nextdtaudr+previousdtaudr)/2 + tau = tau + (nextDist-previousDist)*dtaudr + enddo + !fix units for tau (kappa is in cgs while rho & r are in code units) + tau = tau*umass/(udist**2) +end subroutine get_tau_inwards + + !*********************************************************************! + !**************************** COMMON *****************************! + !*********************************************************************! + + !-------------------------------------------------------------------------- + !+ + ! Find the next point on a ray + !+ + ! IN: inpoint: The coordinate of the initial point projected on the + ! ray for which the next point will be calculated + ! IN: ray: The unit vector of the direction in which the next + ! point will be calculated + ! IN: xyzh: The array containing the particles position+smoothing length + ! IN: neighbors: A list containing the indices of the neighbors of + ! the initial point + ! IN: inext: The index of the initial point + ! (this point will not be considered as possible next point) + !+ + ! OPT: nneighin: The amount of neighbors + !+ + ! OUT: inext: The index of the next point on the ray + !+ + !-------------------------------------------------------------------------- +subroutine find_next(inpoint, ray, dist, xyzh, neighbors, inext, nneighin) + integer, intent(in) :: neighbors(:) + real, intent(in) :: xyzh(:,:), inpoint(:), ray(:) + integer, intent(inout) :: inext + real, intent(inout) :: dist + integer, optional :: nneighin + + real :: trace_point(3), dmin, vec(3), tempdist, raydist + real :: nextdist + integer :: i, nneigh, prev + + dmin = huge(0.) + if (present(nneighin)) then + nneigh = nneighin + else + nneigh = size(neighbors) + endif + + prev=inext + inext=0 + nextDist=dist + trace_point = inpoint + dist*ray + + i = 1 + do while (i <= nneigh .and. neighbors(i) /= 0) + if (neighbors(i) /= prev) then + vec=xyzh(1:3,neighbors(i)) - trace_point + tempdist = dot_product(vec,ray) + if (tempdist>0.) then + raydist = dot_product(vec,vec) - tempdist**2 + if (raydist < dmin) then + dmin = raydist + inext = neighbors(i) + nextdist = dist+tempdist + endif + endif + endif + i = i+1 + enddo + dist=nextdist +end subroutine find_next + + !-------------------------------------------------------------------------- + !+ + ! Calculate the opacity in a given location + !+ + ! IN: r0: The location where the opacity will be calculated + ! IN: xyzh: The xyzh of all the particles + ! IN: opacities: The list of the opacities of the particles + ! IN: neighbors: A list containing the indices of the neighbors of + ! the initial point + ! IN: nneigh: The amount of neighbors + !+ + ! OUT: dtaudr: The local optical depth derivative at the given location (inpoint) + !+ + !-------------------------------------------------------------------------- +subroutine calc_opacity(r0, xyzh, opacities, neighbors, nneigh, dtaudr) + use kernel, only:cnormk,wkern + use part, only:hfact,rhoh,massoftype,igas + real, intent(in) :: r0(:), xyzh(:,:), opacities(:) + integer, intent(in) :: neighbors(:), nneigh + real, intent(out) :: dtaudr + + integer :: i + real :: q + + dtaudr=0 + do i=1,nneigh + q = norm2(r0 - xyzh(1:3,neighbors(i)))/xyzh(4,neighbors(i)) + dtaudr=dtaudr+wkern(q*q,q)*opacities(neighbors(i))*rhoh(xyzh(4,neighbors(i)), massoftype(igas)) + enddo + dtaudr = dtaudr*cnormk/hfact**3 +end subroutine calc_opacity +end module raytracer_all From 39e3c11ca12111656c5f1384f5b3eb1cbc704310 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 2 May 2024 11:29:20 +0100 Subject: [PATCH 506/814] Incomplete updates from Upstream --- src/main/eos.f90 | 1565 +++++++++++++++++++++++++++++ src/main/eos_gasradrec.f90 | 4 +- src/main/eos_idealplusrad.f90 | 12 +- src/main/extern_corotate.f90 | 24 +- src/main/extern_gnewton.f90 | 19 +- src/main/extern_lensethirring.f90 | 25 +- src/main/extern_prdrag.f90 | 117 ++- src/main/externalforces.f90 | 39 +- src/main/part.F90 | 8 +- src/main/ptmass.F90 | 290 +++--- src/main/readwrite_infile.F90 | 32 +- 11 files changed, 1876 insertions(+), 259 deletions(-) create mode 100644 src/main/eos.f90 diff --git a/src/main/eos.f90 b/src/main/eos.f90 new file mode 100644 index 000000000..92b6ec4b7 --- /dev/null +++ b/src/main/eos.f90 @@ -0,0 +1,1565 @@ +!--------------------------------------------------------------------------! +! 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 eos +! +! This module contains stuff to do with the equation of state +! Current options: +! 1 = isothermal eos +! 2 = adiabatic/polytropic eos +! 3 = eos for a locally isothermal disc as in Lodato & Pringle (2007) +! 4 = GR isothermal +! 5 = polytropic EOS with vary mu and gamma depending on H2 formation +! 6 = eos for a locally isothermal disc as in Lodato & Pringle (2007), +! centered on a sink particle +! 7 = z-dependent locally isothermal eos +! 8 = Barotropic eos +! 9 = Piecewise polytrope +! 10 = MESA EoS +! 11 = isothermal eos with zero pressure +! 12 = ideal gas with radiation pressure +! 13 = locally isothermal prescription from Farris et al. (2014) generalised for generic hierarchical systems +! 14 = locally isothermal prescription from Farris et al. (2014) for binary system +! 15 = Helmholtz free energy eos +! 16 = Shen eos +! 20 = Ideal gas + radiation + various forms of recombination energy from HORMONE (Hirai et al., 2020) +! 21 = read tabulated eos (for use with icooling == 8) +! +! :References: +! Lodato & Pringle (2007) +! Hirai et al. (2020) +! +! :Owner: Daniel Price +! +! :Runtime parameters: +! - X : *H mass fraction (ignored if variable composition)* +! - Z : *metallicity (ignored if variable composition)* +! - ieos : *eqn of state (1=isoth;2=adiab;3=locally iso;8=barotropic)* +! - metallicity : *metallicity* +! - mu : *mean molecular weight* +! +! :Dependencies: dim, dump_utils, eos_barotropic, eos_gasradrec, +! eos_helmholtz, eos_idealplusrad, eos_mesa, eos_piecewise, eos_shen, +! eos_stratified, infile_utils, io, mesa_microphysics, part, physcon, +! units +! + use part, only:ien_etotal,ien_entropy,ien_type + use dim, only:gr + implicit none + integer, parameter, public :: maxeos = 21 + real, public :: polyk, polyk2, gamma + real, public :: qfacdisc = 0.75, qfacdisc2 = 0.75 + logical, public :: extract_eos_from_hdr = .false. + integer, public :: isink = 0. + + public :: equationofstate,setpolyk,eosinfo,get_mean_molecular_weight + public :: get_TempPresCs,get_spsound,get_temperature,get_pressure,get_cv + public :: eos_is_non_ideal,eos_outputs_mu,eos_outputs_gasP + public :: get_local_u_internal,get_temperature_from_u + public :: calc_rec_ene,calc_temp_and_ene,entropy,get_rho_from_p_s,get_u_from_rhoT + public :: calc_rho_from_PT,get_entropy,get_p_from_rho_s + public :: init_eos,finish_eos,write_options_eos,read_options_eos + public :: write_headeropts_eos, read_headeropts_eos + + private + + integer, public :: ieos = 1 + integer, public :: iopacity_type = 0 ! used for radiation + real, public :: gmw = 2.381 ! default mean molecular weight + real, public :: X_in = 0.74 ! default metallicities + real, public :: Z_in = 0.02 ! default metallicities + logical, public :: use_var_comp = .false. ! use variable composition + real, public :: temperature_coef + + logical, public :: done_init_eos = .false. + ! + ! error codes for calls to init_eos + ! + integer, public, parameter :: & + ierr_file_not_found = 1, & + ierr_option_conflict = 2, & + ierr_units_not_set = 3, & + ierr_isink_not_set = 4 + +! +! Default temperature prescription for vertical stratification (0=MAPS, 1=Dartois) +! + integer, public:: istrat = 0. +! +! 2D temperature structure fit parameters for HD 163296 +! + real, public :: z0 = 1. + real, public :: alpha_z = 3.01 + real, public :: beta_z = 0.42 + +contains + +!---------------------------------------------------------------- +!+ +! subroutine returns pressure/density as a function of density +! (and position in the case of the isothermal disc) +!+ +!---------------------------------------------------------------- +subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gamma_local,mu_local,Xlocal,Zlocal) + use io, only:fatal,error,warning + use part, only:xyzmh_ptmass, nptmass + use units, only:unit_density,unit_pressure,unit_ergg,unit_velocity + use physcon, only:Rg,radconst,kb_on_mh + use eos_mesa, only:get_eos_pressure_temp_gamma1_mesa,get_eos_1overmu_mesa + use eos_helmholtz, only:eos_helmholtz_pres_sound + use eos_shen, only:eos_shen_NL3 + use eos_idealplusrad + use eos_gasradrec, only:equationofstate_gasradrec + use eos_stratified, only:get_eos_stratified + use eos_barotropic, only:get_eos_barotropic + use eos_piecewise, only:get_eos_piecewise + use eos_stamatellos + integer, intent(in) :: eos_type + real, intent(in) :: rhoi,xi,yi,zi + real, intent(out) :: ponrhoi,spsoundi + real, intent(inout) :: tempi + real, intent(in), optional :: eni + real, intent(inout), optional :: mu_local,gamma_local + real, intent(in) , optional :: Xlocal,Zlocal + integer :: ierr, i + real :: r1,r2 + real :: mass_r, mass ! defined for generalised Farris prescription + real :: gammai,temperaturei,mui,imui,X_i,Z_i + real :: cgsrhoi,cgseni,cgspresi,presi,gam1,cgsspsoundi + real :: uthermconst,kappaBar,kappaPart + real :: enthi,pondensi + ! + ! Check to see if equation of state is compatible with GR cons2prim routines + ! + if (gr .and. .not.any((/2,4,11,12/)==eos_type)) then + ponrhoi = 0.; spsoundi = 0. ! avoid compiler warning + call fatal('eos','GR currently only works for ieos=2,12 or 11',& + var='eos_type',val=real(eos_type)) + endif + + gammai = gamma + mui = gmw + X_i = X_in + Z_i = Z_in + if (present(gamma_local)) gammai = gamma_local + if (present(mu_local)) mui = mu_local + if (present(Xlocal)) X_i = Xlocal + if (present(Zlocal)) Z_i = Zlocal + + select case(eos_type) + case(1) +! +!--Isothermal eos +! +! :math:`P = c_s^2 \rho` +! +! where :math:`c_s^2 \equiv K` is a constant stored in the dump file header +! + ponrhoi = polyk + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + + case(2,5) +! +!--Adiabatic equation of state (code default) +! +! :math:`P = (\gamma - 1) \rho u` +! +! if the code is compiled with ISOTHERMAL=yes, ieos=2 gives a polytropic eos: +! +! :math:`P = K \rho^\gamma` +! +! where K is a global constant specified in the dump header +! + if (gammai < tiny(gammai)) call fatal('eos','gamma not set for adiabatic eos',var='gamma',val=gammai) + + if (gr) then + if (.not. present(eni)) call fatal('eos','GR call to equationofstate requires thermal energy as input!') + if (eni < 0.) call fatal('eos','utherm < 0',var='u',val=eni) + if (gammai <= 1.) then + spsoundi = 0.; ponrhoi = 0. ! avoid compiler warning + call fatal('eos','GR not compatible with isothermal equation of state, yet...',var='gamma',val=gammai) + elseif (gammai > 1.0001) then + pondensi = (gammai-1.)*eni ! eni is the thermal energy + enthi = 1. + eni + pondensi ! enthalpy + spsoundi = sqrt(gammai*pondensi/enthi) + ponrhoi = pondensi ! With GR this routine actually outputs pondensi (i.e. pressure on primitive density, not conserved.) + endif + else + if (present(eni)) then + if (eni < 0.) then + !write(iprint,'(a,Es18.4,a,4Es18.4)')'Warning: eos: u = ',eni,' < 0 at {x,y,z,rho} = ',xi,yi,zi,rhoi + call fatal('eos','utherm < 0',var='u',val=eni) + endif + if (gammai > 1.0001) then + ponrhoi = (gammai-1.)*eni ! use this if en is thermal energy + else + ponrhoi = 2./3.*eni ! en is thermal energy and gamma = 1 + endif + else + ponrhoi = polyk*rhoi**(gammai-1.) + endif + spsoundi = sqrt(gammai*ponrhoi) + endif + + tempi = temperature_coef*mui*ponrhoi + + case(3) +! +!--Locally isothermal disc as in Lodato & Pringle (2007) where +! +! :math:`P = c_s^2 (r) \rho` +! +! sound speed (temperature) is prescribed as a function of radius using: +! +! :math:`c_s = c_{s,0} r^{-q}` where :math:`r = \sqrt{x^2 + y^2 + z^2}` +! + ponrhoi = polyk*(xi**2 + yi**2 + zi**2)**(-qfacdisc) ! polyk is cs^2, so this is (R^2)^(-q) + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + + case(4) +! +!--Isothermal equation of state for GR, enforcing cs = constant +! +! .. WARNING:: this is experimental: use with caution +! + uthermconst = polyk + ponrhoi = (gammai-1.)*uthermconst + spsoundi = sqrt(ponrhoi/(1.+uthermconst)) + tempi = temperature_coef*mui*ponrhoi + + case(6) +! +!--Locally isothermal disc centred on sink particle +! +! As in ieos=3 but in this version radius is taken with respect to a designated +! sink particle (by default the first sink particle in the simulation) +! + ponrhoi = polyk*((xi-xyzmh_ptmass(1,isink))**2 + (yi-xyzmh_ptmass(2,isink))**2 + & + (zi-xyzmh_ptmass(3,isink))**2)**(-qfacdisc) ! polyk is cs^2, so this is (R^2)^(-q) + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + + case(7) +! +!--Vertically stratified equation of state +! +! sound speed is prescribed as a function of (cylindrical) radius R and +! height z above the x-y plane +! +! .. WARNING:: should not be used for misaligned discs +! + call get_eos_stratified(istrat,xi,yi,zi,polyk,polyk2,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,ponrhoi,spsoundi) + tempi = temperature_coef*mui*ponrhoi + + case(8) +! +!--Barotropic equation of state +! +! :math:`P = K \rho^\gamma` +! +! where the value of gamma (and K) are a prescribed function of density +! + call get_eos_barotropic(rhoi,polyk,polyk2,ponrhoi,spsoundi,gammai) + tempi = temperature_coef*mui*ponrhoi + + case(9) +! +!--Piecewise Polytropic equation of state +! +! :math:`P = K \rho^\gamma` +! +! where the value of gamma (and K) are a prescribed function of density. +! Similar to ieos=8 but with different defaults and slightly different +! functional form +! + call get_eos_piecewise(rhoi,ponrhoi,spsoundi,gammai) + tempi = temperature_coef*mui*ponrhoi + + case(10) +! +!--MESA equation of state +! +! a tabulated equation of state including gas, radiation pressure +! and ionisation/dissociation. MESA is a stellar evolution code, so +! this equation of state is designed for matter inside stars +! + cgsrhoi = rhoi * unit_density + cgseni = eni * unit_ergg + call get_eos_pressure_temp_gamma1_mesa(cgsrhoi,cgseni,cgspresi,temperaturei,gam1,ierr) + presi = cgspresi / unit_pressure + + ponrhoi = presi / rhoi + spsoundi = sqrt(gam1*ponrhoi) + tempi = temperaturei + if (present(gamma_local)) gamma_local = gam1 ! gamma is an output + if (present(mu_local)) mu_local = 1./get_eos_1overmu_mesa(cgsrhoi,cgseni) + if (ierr /= 0) call warning('eos_mesa','extrapolating off tables') + + case(11) +! +!--Isothermal equation of state with pressure and temperature equal to zero +! +! :math:`P = 0` +! +! useful for simulating test particle dynamics using SPH particles +! + ponrhoi = 0. + spsoundi = sqrt(polyk) + tempi = 0. + + case(12) +! +!--Ideal gas plus radiation pressure +! +! :math:`P = (\gamma - 1) \rho u` +! +! but solved by first solving the quartic equation: +! +! :math:`u = \frac32 \frac{k_b T}{\mu m_H} + \frac{a T^4}{\rho}` +! +! for temperature (given u), then solving for pressure using +! +! :math:`P = \frac{k_b T}{\mu m_H} + \frac13 a T^4` +! +! hence in this equation of state gamma (and temperature) are an output +! + temperaturei = tempi ! Required as initial guess + cgsrhoi = rhoi * unit_density + cgseni = eni * unit_ergg + call get_idealplusrad_temp(cgsrhoi,cgseni,mui,temperaturei,ierr) + call get_idealplusrad_pres(cgsrhoi,temperaturei,mui,cgspresi) + call get_idealplusrad_spsoundi(cgsrhoi,cgspresi,cgseni,spsoundi,gammai) + if (present(gamma_local)) gamma_local = gammai ! gamma is an output + spsoundi = spsoundi / unit_velocity + presi = cgspresi / unit_pressure + ponrhoi = presi / rhoi + tempi = temperaturei + if (ierr /= 0) call warning('eos_idealplusrad','temperature iteration did not converge') + + + case(13) +! +!--Locally isothermal eos for generic hierarchical system +! +! Assuming all sink particles are stars. +! Generalisation of Farris et al. (2014; for binaries) to N stars. +! For two sink particles this is identical to ieos=14 +! + mass_r = 0 + mass = 0 + + do i=1,nptmass + mass_r = mass_r+xyzmh_ptmass(4,i)/sqrt((xi-xyzmh_ptmass(1,i))**2 + (yi-xyzmh_ptmass(2,i))**2 + (zi-xyzmh_ptmass(3,i))**2) + mass = mass + xyzmh_ptmass(4,i) + enddo + ponrhoi=polyk*(mass_r)**(2*qfacdisc)/mass**(2*qfacdisc) + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + + + case(14) +! +!--Locally isothermal eos from Farris et al. (2014) for binary system +! +! uses the locations of the first two sink particles +! + r1 = sqrt((xi-xyzmh_ptmass(1,1))**2+(yi-xyzmh_ptmass(2,1))**2 + (zi-xyzmh_ptmass(3,1))**2) + r2 = sqrt((xi-xyzmh_ptmass(1,2))**2+(yi-xyzmh_ptmass(2,2))**2 + (zi-xyzmh_ptmass(3,2))**2) + ponrhoi=polyk*(xyzmh_ptmass(4,1)/r1+xyzmh_ptmass(4,2)/r2)**(2*qfacdisc)/(xyzmh_ptmass(4,1)+xyzmh_ptmass(4,2))**(2*qfacdisc) + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + + case(15) +! +!--Helmholtz equation of state (computed live, not tabulated) +! +! .. WARNING:: not widely tested in phantom, better to use ieos=10 +! + call eos_helmholtz_pres_sound(tempi, rhoi, ponrhoi, spsoundi, eni) + + case(16) +! +!--Shen (2012) equation of state for neutron stars +! +! this equation of state requires evolving temperature as the energy variable +! +! .. WARNING:: not tested: use with caution +! + if (present(eni)) then + cgsrhoi = rhoi * unit_density + !note eni is actually tempi + call eos_shen_NL3(cgsrhoi,eni,0.05,cgspresi,cgsspsoundi) + spsoundi=cgsspsoundi / unit_velocity + presi = cgspresi / unit_pressure + ponrhoi = presi / rhoi + tempi = eni + call warning('eos','Not sure if this is correct now that temperature is always passed into eos') + else + spsoundi = 0.; presi = 0.; ponrhoi = 0.; tempi = 0. ! to avoid compiler warnings + call fatal('eos','tried to call NL3 eos without passing temperature') + endif + + case(20) +! +!--Gas + radiation + various forms of recombination +! +! from HORMONE, Hirai+2020, as used in Lau+2022b +! + cgsrhoi = rhoi * unit_density + cgseni = eni * unit_ergg + imui = 1./mui + if (tempi > 0.) then + temperaturei = tempi + else + temperaturei = min(0.67 * cgseni * mui / Rg, (cgseni*cgsrhoi/radconst)**0.25) + endif + call equationofstate_gasradrec(cgsrhoi,cgseni*cgsrhoi,temperaturei,imui,X_i,1.-X_i-Z_i,cgspresi,cgsspsoundi,gammai) + ponrhoi = real(cgspresi / (unit_pressure * rhoi)) + spsoundi = real(cgsspsoundi / unit_velocity) + tempi = temperaturei + if (present(mu_local)) mu_local = 1./imui + if (present(gamma_local)) gamma_local = gammai + + case(21) +! +!--interpolate tabulated eos from Stamatellos+(2007). For use with icooling=8 +! + if (eni < 0.) then + call fatal('eos (stamatellos)','utherm < 0',var='u',val=eni) + endif + cgsrhoi = rhoi * unit_density + cgseni = eni * unit_ergg + call getopac_opdep(cgseni,cgsrhoi,kappaBar,kappaPart,tempi,mui) + cgspresi = kb_on_mh*cgsrhoi*tempi/mui + presi = cgspresi/unit_pressure + ponrhoi = presi/rhoi + gammai = 1.d0 + presi/(eni*rhoi) + !if (gammai < 1.d0 .or. gammai > 2.d0) then + ! print *, gammai, tempi, mui,cgseni,cgsrhoi,cgspresi + !endif + spsoundi = sqrt(gammai*ponrhoi) + + case default + spsoundi = 0. ! avoids compiler warnings + ponrhoi = 0. + tempi = 0. + call fatal('eos','unknown equation of state') + end select + +end subroutine equationofstate + +!----------------------------------------------------------------------- +!+ +! initialise equation of state (read tables etc.) +!+ +!----------------------------------------------------------------------- +subroutine init_eos(eos_type,ierr) + use units, only:unit_velocity + use physcon, only:Rg + use io, only:error,warning,fatal + use eos_mesa, only:init_eos_mesa + use eos_helmholtz, only:eos_helmholtz_init + use eos_piecewise, only:init_eos_piecewise + use eos_barotropic, only:init_eos_barotropic + use eos_shen, only:init_eos_shen_NL3 + use eos_gasradrec, only:init_eos_gasradrec + use eos_stamatellos,only:read_optab,init_S07cool,eos_file + use dim, only:maxvxyzu,do_radiation + integer, intent(in) :: eos_type + integer, intent(out) :: ierr + integer :: ierr_mesakapp + + ierr = 0 + ! + !--Set coefficient to convert P/rho into temperature + ! calculation will be in cgs; the mean molecular weight, gmw, will be + ! included in the function call rather than here + ! c_s^2 = gamma*P/rho = gamma*kT/(gmw*m_p) -> T = P/rho * (gmw*m_p)/k + ! + temperature_coef = unit_velocity**2 / Rg + + select case(eos_type) + case(6) + ! + !--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 + endif + + case(8) + ! + ! barotropic equation of state + ! + call init_eos_barotropic(polyk,polyk2,ierr) + + case(9) + ! + ! piecewise polytropic equation of state (similar to barotropic) + ! + call init_eos_piecewise(ierr) + + case(10) + ! + !--MESA EoS initialisation + ! + write(*,'(1x,a,f7.5,a,f7.5)') 'Initialising MESA EoS with X = ',X_in,', Z = ',Z_in + call init_eos_mesa(X_in,Z_in,ierr) + if (do_radiation .and. ierr==0) then + call error('eos','ieos=10, cannot use eos with radiation, will double count radiation pressure') + ierr=ierr_option_conflict !return error if using radiation and mesa EOS, shouldn't use mesa eos, as it will double count rad pres + endif + + case(12) + ! + ! ideal plus radiation + ! + write(*,'(1x,a,f7.5)') 'Using ideal plus radiation EoS with mu = ',gmw + if (do_radiation) then + call error('eos','ieos=12, cannot use eos with radiation, will double count radiation pressure') + ierr = ierr_option_conflict + endif + + case(15) + + call eos_helmholtz_init(ierr) + + case(16) + + call init_eos_shen_NL3(ierr) + + case(20) + + call init_eos_gasradrec(ierr) + if (.not. use_var_comp) then + write(*,'(a,f7.5,a,f7.5)') 'Assuming fixed composition X = ',X_in,', Z = ',Z_in + endif + if (do_radiation) then + call error('eos','ieos=20, cannot use eos with radiation, will double count radiation pressure') + ierr = ierr_option_conflict + endif + + case(21) + call read_optab(eos_file,ierr) + if (ierr > 0) call fatal('init_eos','Failed to read EOS file',var='ierr',ival=ierr) + call init_S07cool + + end select + done_init_eos = .true. + + if (do_radiation .and. iopacity_type==1) then + write(*,'(1x,a,f7.5,a,f7.5)') 'Using radiation with MESA opacities. Initialising MESA EoS with X = ',X_in,', Z = ',Z_in + call init_eos_mesa(X_in,Z_in,ierr_mesakapp) + ierr = max(ierr,ierr_mesakapp) + endif + +end subroutine init_eos + +!----------------------------------------------------------------------- +!+ +! finish equation of state +!+ +!----------------------------------------------------------------------- +subroutine finish_eos(eos_type,ierr) + use eos_mesa, only: finish_eos_mesa + use eos_stamatellos, only: finish_S07cool + + integer, intent(in) :: eos_type + integer, intent(out) :: ierr + + ierr = 0 + + select case(eos_type) + case(10) + ! + !--MESA EoS deallocation + ! + call finish_eos_mesa + + case(21) + ! Stamatellos deallocation + call finish_S07cool + + end select + done_init_eos=.false. + +end subroutine finish_eos + +!----------------------------------------------------------------------- +!+ +! Calculate gas temperature, sound speed, and pressure. +! This will be required for various analysis routines if eos_vars +! is not saved in the dump files +!+ +!----------------------------------------------------------------------- +subroutine get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi,spsoundi,gammai,mui,Xi,Zi) + use dim, only:maxvxyzu + integer, intent(in) :: eos_type + real, intent(in) :: vxyzui(:),xyzi(:),rhoi + real, intent(inout) :: tempi + real, intent(out), optional :: presi,spsoundi + real, intent(inout), optional :: gammai,mui + real, intent(in), optional :: Xi,Zi + real :: csi,ponrhoi,mu,X,Z + logical :: use_gamma + + mu = gmw + X = X_in + Z = Z_in + if (present(mui)) mu = mui + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + use_gamma = .false. + if (present(gammai)) then + if (gammai > 0.) use_gamma = .true. + endif + + if (maxvxyzu==4) then + 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) + else + call equationofstate(eos_type,ponrhoi,csi,rhoi,xyzi(1),xyzi(2),xyzi(3),tempi,vxyzui(4),& + mu_local=mu,Xlocal=X,Zlocal=Z) + endif + else + call equationofstate(eos_type,ponrhoi,csi,rhoi,xyzi(1),xyzi(2),xyzi(3),tempi,mu_local=mu) + endif + + if (present(presi)) presi = ponrhoi*rhoi + if (present(spsoundi)) spsoundi = csi + if (present(mui)) mui = mu + if (present(gammai)) gammai = gamma + +end subroutine get_TempPresCs + +!----------------------------------------------------------------------- +!+ +! Wrapper function to calculate sound speed +!+ +!----------------------------------------------------------------------- +real function get_spsound(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) + integer, intent(in) :: eos_type + real, intent(in) :: xyzi(:),rhoi + real, intent(in) :: vxyzui(:) + real, intent(in), optional :: Xi,Zi + real, intent(inout), optional :: gammai,mui + real :: spsoundi,tempi,gam,mu,X,Z + + !set defaults for variables not passed in + mu = gmw + X = X_in + Z = Z_in + tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess + gam = -1. ! to indicate gamma is not being passed in + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + if (present(gammai)) gam = gammai + if (present(mui)) mu = mui + + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,spsoundi=spsoundi,gammai=gam,mui=mu,Xi=X,Zi=Z) + + get_spsound = spsoundi + + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + +end function get_spsound + +!----------------------------------------------------------------------- +!+ +! Wrapper function to calculate temperature +!+ +!----------------------------------------------------------------------- +real function get_temperature(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) + integer, intent(in) :: eos_type + real, intent(in) :: xyzi(:),rhoi + real, intent(in) :: vxyzui(:) + real, intent(in), optional :: Xi,Zi + real, intent(inout),optional :: gammai,mui + real :: tempi,gam,mu,X,Z + + !set defaults for variables not passed in + mu = gmw + X = X_in + Z = Z_in + tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess + gam = -1. ! to indicate gamma is not being passed in + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + if (present(gammai)) gam = gammai + if (present(mui)) mu = mui + + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,gammai=gam,mui=mu,Xi=X,Zi=Z) + + get_temperature = tempi + + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + +end function get_temperature + + +!----------------------------------------------------------------------- +!+ +! Wrapper function to calculate temperature +!+ +!----------------------------------------------------------------------- +real function get_temperature_from_u(eos_type,xpi,ypi,zpi,rhoi,ui,gammai,mui,Xi,Zi) + integer, intent(in) :: eos_type + real, intent(in) :: xpi,ypi,zpi,rhoi + real, intent(in) :: ui + real, intent(in), optional :: Xi,Zi + real, intent(inout),optional :: gammai,mui + real :: tempi,gam,mu,X,Z + real :: vxyzui(4),xyzi(3) + + !set defaults for variables not passed in + mu = gmw + X = X_in + Z = Z_in + tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess + gam = -1. ! to indicate gamma is not being passed in + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + if (present(gammai)) gam = gammai + if (present(mui)) mu = mui + + vxyzui = (/0.,0.,0.,ui/) + xyzi = (/xpi,ypi,zpi/) + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,gammai=gam,mui=mu,Xi=X,Zi=Z) + + get_temperature_from_u = tempi + + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + + +end function get_temperature_from_u +!----------------------------------------------------------------------- +!+ +! Wrapper function to calculate pressure +!+ +!----------------------------------------------------------------------- +real function get_pressure(eos_type,xyzi,rhoi,vxyzui,gammai,mui,Xi,Zi) + integer, intent(in) :: eos_type + real, intent(in) :: xyzi(:),rhoi,vxyzui(:) + real, intent(in), optional :: Xi,Zi + real, intent(inout),optional :: gammai,mui + real :: presi,tempi,gam,mu,X,Z + + !set defaults for variables not passed in + mu = gmw + X = X_in + Z = Z_in + tempi = -1. ! needed because temperature is an in/out to some equations of state, -ve == use own guess + gam = -1. ! to indicate gamma is not being passed in + if (present(mui)) mu = mui + if (present(Xi)) X = Xi + if (present(Zi)) Z = Zi + if (present(gammai)) gam = gammai + if (present(mui)) mu = mui + + call get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi=presi,gammai=gam,mui=mu,Xi=X,Zi=Z) + + get_pressure = presi + + if (present(mui)) mui = mu + if (present(gammai)) gammai = gam + +end function get_pressure + +!----------------------------------------------------------------------- +!+ +! query function to return the internal energy for calculations with a +! local mean molecular weight and local adiabatic index +!+ +!----------------------------------------------------------------------- +real function get_local_u_internal(gammai, gmwi, gas_temp_local) + real, intent(in) :: gammai, gmwi, gas_temp_local + real :: ponrhoi + + ponrhoi = gas_temp_local/(gmwi*temperature_coef) + get_local_u_internal = ponrhoi/(gammai-1.) + +end function get_local_u_internal + +!----------------------------------------------------------------------- +!+ +! get u from rho, T +!+ +!----------------------------------------------------------------------- +real function get_u_from_rhoT(rho,temp,eos_type,uguess) result(u) + use eos_mesa, only:get_eos_u_from_rhoT_mesa + integer, intent(in) :: eos_type + real, intent(in) :: rho,temp + real, intent(in), optional :: uguess + + select case (eos_type) + case(10) ! MESA EoS + if (present(uguess)) then + call get_eos_u_from_rhoT_mesa(rho,temp,u,uguess) + else + call get_eos_u_from_rhoT_mesa(rho,temp,u) + endif + + case default + u = temp/(gmw*temperature_coef*(gamma-1.)) + end select + +end function get_u_from_rhoT + +!----------------------------------------------------------------------- +!+ +! Get recombination energy (per unit mass) assumming complete +! ionisation +!+ +!----------------------------------------------------------------------- +subroutine calc_rec_ene(XX,YY,e_rec) + real, intent(in) :: XX, YY + real, intent(out) :: e_rec + real :: e_H2,e_HI,e_HeI,e_HeII + real, parameter :: e_ion_H2 = 1.312e13, & ! ionisation energies in erg/mol + e_ion_HI = 4.36e12, & + e_ion_HeI = 2.3723e13, & + e_ion_HeII = 5.2505e13 + + ! XX : Hydrogen mass fraction + ! YY : Helium mass fraction + ! e_rec : Total ionisation energy due to H2, HI, HeI, and HeII + + e_H2 = 0.5 * XX * e_ion_H2 + e_HI = XX * e_ion_HI + e_HeI = 0.25 * YY * e_ion_HeI + e_HeII = 0.25 * YY * e_ion_HeII + e_rec = e_H2 + e_HI + e_HeI + e_HeII + +end subroutine calc_rec_ene + +!----------------------------------------------------------------------- +!+ +! Calculate temperature and specific internal energy from +! pressure and density. Inputs and outputs are in cgs units. +! +! Note on composition: +! For ieos=2, 5 and 12, mu_local is an input, X & Z are not used +! For ieos=10, mu_local is not used +! For ieos=20, mu_local is not used but available as an output +!+ +!----------------------------------------------------------------------- +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 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 + integer, intent(in) :: eos_type + real, intent(in) :: rho,pres + real, intent(inout) :: ene,temp + real, intent(in), optional :: guesseint,X_local,Z_local + real, intent(inout), optional :: mu_local + integer, intent(out) :: ierr + real :: mu,X,Z + + ierr = 0 + mu = gmw + X = X_in + Z = Z_in + if (present(mu_local)) mu = mu_local + if (present(X_local)) X = X_local + if (present(Z_local)) Z = Z_local + select case(eos_type) + case(2,5) ! Ideal gas + temp = pres / (rho * kb_on_mh) * mu + ene = pres / ( (gamma-1.) * rho) + case(12) ! Ideal gas + radiation + call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) + call get_idealplusrad_enfromtemp(rho,temp,mu,ene) + case(10) ! MESA EoS + call get_eos_eT_from_rhop_mesa(rho,pres,ene,temp,guesseint) + case(20) ! Ideal gas + radiation + recombination (from HORMONE, Hirai et al., 2020) + call calc_uT_from_rhoP_gasradrec(rho,pres,X,1.-X-Z,temp,ene,mu,ierr) + if (present(mu_local)) mu_local = mu + case default + ierr = 1 + end select + +end subroutine calc_temp_and_ene + +!----------------------------------------------------------------------- +!+ +! Calculate density from pressure and temperature. Inputs and outputs +! are in cgs units. +! +! Note on composition: +! For ieos=2 and 12, mu_local is an input, X & Z are not used +! For ieos=10, mu_local is not used +! For ieos=20, mu_local is not used but available as an output +!+ +!----------------------------------------------------------------------- +subroutine calc_rho_from_PT(eos_type,pres,temp,rho,ierr,mu_local,X_local,Z_local) + use physcon, only:kb_on_mh + 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 + integer, intent(in) :: eos_type + real, intent(in) :: pres,temp + real, intent(inout) :: rho + real, intent(in), optional :: X_local,Z_local + real, intent(inout), optional :: mu_local + integer, intent(out) :: ierr + real :: mu,X,Z + + ierr = 0 + mu = gmw + X = X_in + Z = Z_in + if (present(mu_local)) mu = mu_local + if (present(X_local)) X = X_local + if (present(Z_local)) Z = Z_local + select case(eos_type) + case(2) ! Ideal gas + rho = pres / (temp * kb_on_mh) * mu + case(12) ! Ideal gas + radiation + call get_idealplusrad_rhofrompresT(pres,temp,mu,rho) + case default + ierr = 1 + end select + +end subroutine calc_rho_from_PT + +!----------------------------------------------------------------------- +!+ +! Calculates specific entropy (gas + radiation + recombination) +! up to an additive integration constant, from density and pressure. +!+ +!----------------------------------------------------------------------- +function entropy(rho,pres,mu_in,ientropy,eint_in,ierr) + use io, only:fatal,warning + use physcon, only:radconst,kb_on_mh + 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 + integer, intent(in) :: ientropy + integer, intent(out), optional :: ierr + real :: mu,entropy,logentropy,temp,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) + + ! check temp + if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') + + case(2) ! Include both gas and radiation entropy (up to additive constants) + temp = pres * mu / (rho * kb_on_mh) ! Guess for temp + 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) + + ! check temp + if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') + + 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') + + if (present(eint_in)) then + eint = eint_in + else + call get_eos_eT_from_rhop_mesa(rho,pres,eint,temp) + endif + + ! Get entropy from rho and eint from MESA tables + if (present(ierr)) then + call getvalue_mesa(rho,eint,9,logentropy,ierr) + else + call getvalue_mesa(rho,eint,9,logentropy) + endif + entropy = 10.**logentropy + + case default + entropy = 0. + call fatal('eos','Unknown ientropy (can only be 1, 2, or 3)') + end select + +end function entropy + +real function get_entropy(rho,pres,mu_in,ieos) + use units, only:unit_density,unit_pressure,unit_ergg + use physcon, only:kboltz + integer, intent(in) :: ieos + real, intent(in) :: rho,pres,mu_in + real :: cgsrho,cgspres,cgss + + cgsrho = rho * unit_density + cgspres = pres * unit_pressure + select case (ieos) + case (12) + cgss = entropy(cgsrho,cgspres,mu_in,2) + case (10, 20) + cgss = entropy(cgsrho,cgspres,mu_in,3) + case default + cgss = entropy(cgsrho,cgspres,mu_in,1) + end select + cgss = cgss/kboltz ! s/kb + get_entropy = cgss/unit_ergg + +end function get_entropy + +!----------------------------------------------------------------------- +!+ +! Calculate density given pressure and entropy using Newton-Raphson +! method +!+ +!----------------------------------------------------------------------- +subroutine get_rho_from_p_s(pres,S,rho,mu,rhoguess,ientropy) + real, intent(in) :: pres,S,mu,rhoguess + real, intent(inout) :: rho + real :: srho,srho_plus_dsrho,S_plus_dS,dSdsrho + real(kind=8) :: corr + real, parameter :: eoserr=1e-9,dfac=1e-12 + integer, intent(in) :: ientropy + + ! We apply the Newton-Raphson method directly to rho^1/2 ("srho") instead + ! of rho since S(rho) cannot take a negative argument. + srho = sqrt(rhoguess) ! Initial guess + corr = huge(corr); + do while (abs(corr) > eoserr*abs(srho)) + ! First calculate dS/dsrho + srho_plus_dsrho = srho * (1. + dfac) + S_plus_dS = entropy(srho_plus_dsrho**2,pres,mu,ientropy) + dSdsrho = (S_plus_dS - entropy(srho**2,pres,mu,ientropy)) / (srho_plus_dsrho - srho) + corr = ( entropy(srho**2,pres,mu,ientropy) - S ) / dSdsrho + srho = srho - corr + enddo + rho = srho**2 + +end subroutine get_rho_from_p_s + +!----------------------------------------------------------------------- +!+ +! Calculate temperature given density and entropy using Newton-Raphson +! method +!+ +!----------------------------------------------------------------------- +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 io, only:fatal + use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_pres + use units, only:unit_density,unit_pressure,unit_ergg + real, intent(in) :: S,mu,rho + real, intent(inout) :: temp + real, intent(out) :: P + integer, intent(in) :: ieos + real :: corr,df,f,temp_new,cgsrho,cgsp,cgss + real, parameter :: eoserr=1e-12 + integer :: niter + integer, parameter :: nitermax = 1000 + + ! change to cgs unit + cgsrho = rho*unit_density + cgss = s*unit_ergg + + niter = 0 + select case (ieos) + case (2,5) + temp = (cgsrho * exp(mu*cgss*mass_proton_cgs))**(2./3.) + cgsP = cgsrho*kb_on_mh*temp / mu + case (12) + corr = huge(corr) + do while (abs(corr) > eoserr .and. niter < nitermax) + f = 1. / (mu*mass_proton_cgs) * log(temp**1.5/cgsrho) + 4.*radconst*temp**3 / (3.*cgsrho*kboltz) - cgss + df = 1.5 / (mu*temp*mass_proton_cgs) + 4.*radconst*temp**2 / (cgsrho*kboltz) + corr = f/df + temp_new = temp - corr + if (temp_new > 1.2 * temp) then + temp = 1.2 * temp + elseif (temp_new < 0.8 * temp) then + temp = 0.8 * temp + else + temp = temp_new + endif + niter = niter + 1 + enddo + call get_idealplusrad_pres(cgsrho,temp,mu,cgsP) + case default + cgsP = 0. + call fatal('eos','[get_p_from_rho_s] only implemented for eos 2 and 12') + end select + + ! check temp + if (temp > huge(0.)) call fatal('entropy','entropy too large gives infinte temperature, & + &reducing entropy factor C_ent for one dump') + + ! change back to code unit + P = cgsP / unit_pressure + +end subroutine get_p_from_rho_s + +!----------------------------------------------------------------------- +!+ +! Calculate mean molecular weight from X and Z, assuming complete +! ionisation +!+ +!----------------------------------------------------------------------- +real function get_mean_molecular_weight(XX,ZZ) result(mu) + real, intent(in) :: XX,ZZ + real :: YY + + YY = 1.-XX-ZZ + mu = 1./(2.*XX + 0.75*YY + 0.5*ZZ) + +end function get_mean_molecular_weight + +!--------------------------------------------------------- +!+ +! return cv from rho, u in code units +!+ +!--------------------------------------------------------- +real function get_cv(rho,u,cv_type) result(cv) + use mesa_microphysics, only:getvalue_mesa + use units, only:unit_ergg,unit_density + use physcon, only:Rg + real, intent(in) :: rho,u + integer, intent(in) :: cv_type + real :: rho_cgs,u_cgs,temp + + select case (cv_type) + + case(1) ! MESA EoS + rho_cgs = rho*unit_density + u_cgs = u*unit_ergg + call getvalue_mesa(rho_cgs,u_cgs,4,temp) + cv = u_cgs/temp / unit_ergg + case default ! constant cv + cv = Rg/((gamma-1.)*gmw*unit_ergg) + end select + +end function get_cv + +!----------------------------------------------------------------------- +!+ +! subroutine sets polyk based on utherm/positions +! read from an sphNG dump file +!+ +!----------------------------------------------------------------------- +subroutine setpolyk(eos_type,iprint,utherm,xyzhi,npart) + use part, only:xyzmh_ptmass + use io, only:id,master + integer, intent(in) :: eos_type,iprint + real, intent(in) :: utherm(:) + real, intent(in) :: xyzhi(:,:) + integer, intent(in) :: npart + integer :: ipart + real :: r2,polykalt + + !-- pick a random particle from which to extract polyk + ipart = npart/2 + + select case(eos_type) + case(1,8) +! +!--isothermal eos +! + polykalt = 2./3.*utherm(ipart) + !--check all other utherms identical + if (any(utherm(1:npart) /= utherm(ipart)) .and. id==master) then + write(iprint,*) 'WARNING! different utherms but run is isothermal' + endif + + case(2,5) +! +!--adiabatic/polytropic eos +! this routine is ONLY called if utherm is NOT stored, so polyk matters +! + if (id==master) write(iprint,*) 'Using polytropic equation of state, gamma = ',gamma + polykalt = 2./3.*utherm(ipart) + if (gamma <= 1.00000001) then + stop 'silly to use gamma==1 without using isothermal eos' + endif + + case(3) +! +!--locally isothermal disc as in Lodato & Pringle (2007) +! cs = cs_0*R^(-q) -- polyk is cs^2, so this is (R^2)^(-q) +! + r2 = xyzhi(1,ipart)*xyzhi(1,ipart) + xyzhi(2,ipart)*xyzhi(2,ipart) & + + xyzhi(3,ipart)*xyzhi(3,ipart) + polykalt = 2./3.*utherm(ipart)*r2**qfacdisc + + case(6) +! +!--locally isothermal disc as in Lodato & Pringle (2007), centered on specified sink particle +! cs = cs_0*R^(-q) -- polyk is cs^2, so this is (R^2)^(-q) +! + r2 = (xyzhi(1,ipart)-xyzmh_ptmass(1,isink))**2 + & + (xyzhi(2,ipart)-xyzmh_ptmass(2,isink))**2 + & + (xyzhi(3,ipart)-xyzmh_ptmass(3,isink))**2 + + polykalt = 2./3.*utherm(ipart)*r2**qfacdisc + case default +! +!--don't die in this routine as it can be called from readdump +! (ie. not necessarily as part of a run) +! + if (id==master) write(iprint,*) ' WARNING! unknown equation of state in setpolyk' + polykalt = polyk + + end select + + if (diff(polykalt,polyk) .and. id==master) then + write(iprint,*) 'WARNING! polyk set using RK2 in dump differs from that set using thermal energy' + write(iprint,*) 'using polyk = ',polykalt, ' (from RK2 = ',polyk,')' + endif + polyk = polykalt +! +!--warn if polyk is zero, die if negative +! + if (polyk < 0.) then + write(iprint,*) 'ERROR: polyk < 0 in setting equation of state' + stop + elseif (polyk < tiny(polyk) .and. id==master) then + write(iprint,*) 'WARNING: polyk = 0 in equation of state' + endif + +end subroutine setpolyk +!----------------------------------------------------------------------- +!+ +! small utility returns whether two real numbers differ +!+ +!----------------------------------------------------------------------- +logical pure function diff(r1,r2) + real, intent(in) :: r1,r2 + + diff = abs(r1-r2) > tiny(r1) + +end function diff + +!----------------------------------------------------------------------- +!+ +! Query function to return whether an EoS is non-ideal +! Mainly used to decide whether it is necessary to write +! things like pressure and temperature in the dump file or not +!+ +!----------------------------------------------------------------------- +logical function eos_is_non_ideal(ieos) + integer, intent(in) :: ieos + + select case(ieos) + case(10,12,15,20) + eos_is_non_ideal = .true. + case default + eos_is_non_ideal = .false. + end select + +end function eos_is_non_ideal + +!----------------------------------------------------------------------- +!+ +! Query function to return whether an EoS outputs mean molecular weight +!+ +!----------------------------------------------------------------------- +logical function eos_outputs_mu(ieos) + integer, intent(in) :: ieos + + select case(ieos) + case(20) + eos_outputs_mu = .true. + case(21) + eos_outputs_mu = .true. +case default + eos_outputs_mu = .false. + end select + +end function eos_outputs_mu + +!----------------------------------------------------------------------- +!+ +! Query function to whether to print pressure to dump file +!+ +!----------------------------------------------------------------------- +logical function eos_outputs_gasP(ieos) + integer, intent(in) :: ieos + + select case(ieos) + case(8,9,10,15) + eos_outputs_gasP = .true. + case default + eos_outputs_gasP = .false. + end select + +end function eos_outputs_gasP + +!----------------------------------------------------------------------- +!+ +! prints equation of state info in the run header +!+ +!----------------------------------------------------------------------- +subroutine eosinfo(eos_type,iprint) + use dim, only:maxvxyzu + use io, only:fatal,id,master + use eos_helmholtz, only:eos_helmholtz_eosinfo + use eos_barotropic, only:eos_info_barotropic + use eos_piecewise, only:eos_info_piecewise + use eos_gasradrec, only:eos_info_gasradrec + use eos_stamatellos, only:eos_file + integer, intent(in) :: eos_type,iprint + + if (id/=master) return + + select case(eos_type) + case(1,11) + if (1.0d-5 < polyk .and. polyk < 1.0d3) then + write(iprint,"(/,a,f10.6)") ' Isothermal equation of state: cs^2 = ',polyk + else + write(iprint,"(/,a,Es13.6)") ' Isothermal equation of state: cs^2 = ',polyk + endif + if (eos_type==11) write(iprint,*) ' (ZERO PRESSURE) ' + case(2) + if (maxvxyzu >= 4) then + write(iprint,"(/,a,f10.6,a,f10.6)") ' Adiabatic equation of state: P = (gamma-1)*rho*u, gamma = ',& + gamma,' gmw = ',gmw + else + write(iprint,"(/,a,f10.6,a,f10.6,a,f10.6)") ' Polytropic equation of state: P = ',polyk,'*rho^',gamma,' gmw = ',gmw + endif + case(3) + write(iprint,"(/,a,f10.6,a,f10.6)") ' Locally isothermal eq of state (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc + case(5) + if (maxvxyzu >= 4) then + write(iprint,"(' Adiabatic equation of state: P = (gamma-1)*rho*u, where gamma & mu depend on the formation of H2')") + else + stop '[stop eos] eos = 5 cannot assume isothermal conditions' + endif + case(6) + write(iprint,"(/,a,i2,a,f10.6,a,f10.6)") ' Locally (on sink ',isink, & + ') isothermal eos (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc + case(8) + call eos_info_barotropic(polyk,polyk2,iprint) + case(9) + call eos_info_piecewise(iprint) + case(10) + write(iprint,"(/,a,f10.6,a,f10.6,a,f10.6,a)") ' MESA EoS: X = ',X_in,' Z = ',Z_in,' (1-X-Z = ',1.-X_in-Z_in,')' + case(12) + write(iprint,"(/,a,f10.6,a,f10.6)") ' Gas + radiation equation of state: gmw = ',gmw,' gamma = ',gamma + case(15) + call eos_helmholtz_eosinfo(iprint) + case(20) + call eos_info_gasradrec(iprint) + if (use_var_comp) then + write(*,'(1x,a,i1,a)') 'Using variable composition' + else + write(*,'(1x,a,f10.6,a,f10.6)') 'Using fixed composition X = ',X_in,", Z = ",Z_in + endif + + case(21) + write(iprint,"(/,a,a)") 'Using tabulated Eos from file:', eos_file, 'and calculated gamma.' + end select + write(iprint,*) + +end subroutine eosinfo + +!----------------------------------------------------------------------- +!+ +! write relevant options to the header of the dump file +!+ +!----------------------------------------------------------------------- +subroutine write_headeropts_eos(ieos,hdr,ierr) + use dump_utils, only:dump_h,add_to_rheader,add_to_iheader + integer, intent(in) :: ieos + type(dump_h), intent(inout) :: hdr + integer, intent(out) :: ierr + + call add_to_iheader(isink,'isink',hdr,ierr) + call add_to_rheader(gamma,'gamma',hdr,ierr) + call add_to_rheader(1.5*polyk,'RK2',hdr,ierr) + call add_to_rheader(polyk2,'polyk2',hdr,ierr) + call add_to_rheader(qfacdisc,'qfacdisc',hdr,ierr) + call add_to_rheader(qfacdisc2,'qfacdisc2',hdr,ierr) + + if (ieos==7) then + call add_to_iheader(istrat,'istrat',hdr,ierr) + call add_to_rheader(alpha_z,'alpha_z',hdr,ierr) + call add_to_rheader(beta_z,'beta_z',hdr,ierr) + call add_to_rheader(z0,'z0',hdr,ierr) + endif + +end subroutine write_headeropts_eos + +!----------------------------------------------------------------------- +!+ +! read relevant options from the header of the dump file +!+ +!----------------------------------------------------------------------- +subroutine read_headeropts_eos(ieos,hdr,ierr) + use dump_utils, only:dump_h, extract + use io, only:iprint,id,master + use dim, only:use_krome,maxvxyzu + integer, intent(in) :: ieos + type(dump_h), intent(in) :: hdr + integer, intent(out) :: ierr + real :: RK2 + + + call extract('gamma',gamma,hdr,ierr) + call extract('RK2',rk2,hdr,ierr) + polyk = 2./3.*rk2 + if (id==master) then + if (maxvxyzu >= 4) then + if (use_krome) then + write(iprint,*) 'KROME eos: initial gamma = 1.666667' + elseif (ieos==21) then + write(iprint,*) 'Tabulated eos with derived gamma' + else + write(iprint,*) 'adiabatic eos: gamma = ',gamma + endif + else + write(iprint,*) 'setting isothermal sound speed^2 (polyk) = ',polyk,' gamma = ',gamma + if (polyk <= tiny(polyk)) write(iprint,*) 'WARNING! sound speed zero in dump!, polyk = ',polyk + endif + endif + call extract('polyk2',polyk2,hdr,ierr) + call extract('qfacdisc',qfacdisc,hdr,ierr) + call extract('qfacdisc2',qfacdisc2,hdr,ierr) + call extract('isink',isink,hdr,ierr) + + if (abs(gamma-1.) > tiny(gamma) .and. maxvxyzu < 4) then + write(*,*) 'WARNING! compiled for isothermal equation of state but gamma /= 1, gamma=',gamma + endif + + ierr = 0 + if (ieos==3 .or. ieos==6 .or. ieos==7) then + if (qfacdisc <= tiny(qfacdisc)) then + if (id==master) write(iprint,*) 'ERROR: qfacdisc <= 0' + ierr = 2 + else + if (id==master) write(iprint,*) 'qfacdisc = ',qfacdisc + endif + endif + + if (ieos==7) then + call extract('istrat',istrat,hdr,ierr) + call extract('alpha_z',alpha_z,hdr,ierr) + call extract('beta_z', beta_z, hdr,ierr) + call extract('z0',z0,hdr,ierr) + if (abs(qfacdisc2) <= tiny(qfacdisc2)) then + if (id==master) write(iprint,*) 'ERROR: qfacdisc2 == 0' + ierr = 2 + else + if (id==master) write(iprint,*) 'qfacdisc2 = ',qfacdisc2 + endif + endif + +end subroutine read_headeropts_eos + +!----------------------------------------------------------------------- +!+ +! writes equation of state options to the input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_eos(iunit) + use dim, only:use_krome + use infile_utils, only:write_inopt + use eos_helmholtz, only:eos_helmholtz_write_inopt + use eos_barotropic, only:write_options_eos_barotropic + use eos_piecewise, only:write_options_eos_piecewise + use eos_gasradrec, only:write_options_eos_gasradrec + integer, intent(in) :: iunit + + write(iunit,"(/,a)") '# options controlling equation of state' + call write_inopt(ieos,'ieos','eqn of state (1=isoth;2=adiab;3=locally iso;8=barotropic)',iunit) + + if (.not.use_krome .or. .not.eos_outputs_mu(ieos)) then + call write_inopt(gmw,'mu','mean molecular weight',iunit) + endif + + select case(ieos) + case(8) + call write_options_eos_barotropic(iunit) + case(9) + call write_options_eos_piecewise(iunit) + case(10) + call write_inopt(X_in,'X','hydrogen mass fraction',iunit) + call write_inopt(Z_in,'Z','metallicity',iunit) + case(15) ! helmholtz eos + call eos_helmholtz_write_inopt(iunit) + case(20) + call write_options_eos_gasradrec(iunit) + if (.not. use_var_comp) then + call write_inopt(X_in,'X','H mass fraction (ignored if variable composition)',iunit) + call write_inopt(Z_in,'Z','metallicity (ignored if variable composition)',iunit) + endif + end select + +end subroutine write_options_eos + +!----------------------------------------------------------------------- +!+ +! reads equation of state options from the input file +!+ +!----------------------------------------------------------------------- +subroutine read_options_eos(name,valstring,imatch,igotall,ierr) + use dim, only:store_dust_temperature,update_muGamma + use io, only:fatal + use eos_barotropic, only:read_options_eos_barotropic + use eos_piecewise, only:read_options_eos_piecewise + use eos_gasradrec, only:read_options_eos_gasradrec + 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_eos' + logical :: igotall_barotropic,igotall_piecewise,igotall_gasradrec + + imatch = .true. + igotall_barotropic = .true. + igotall_piecewise = .true. + igotall_gasradrec = .true. + + select case(trim(name)) + case('ieos') + read(valstring,*,iostat=ierr) ieos + ngot = ngot + 1 + if (ieos <= 0 .or. ieos > maxeos) call fatal(label,'equation of state choice out of range') + if (ieos == 5) then + store_dust_temperature = .true. + update_muGamma = .true. + endif + case('mu') + read(valstring,*,iostat=ierr) gmw + ! not compulsory to read in + if (gmw <= 0.) call fatal(label,'mu <= 0') + case('X') + read(valstring,*,iostat=ierr) X_in + if (X_in <= 0. .or. X_in >= 1.) call fatal(label,'X must be between 0 and 1') + ngot = ngot + 1 + case('Z') + read(valstring,*,iostat=ierr) Z_in + if (Z_in <= 0. .or. Z_in > 1.) call fatal(label,'Z must be between 0 and 1') + ngot = ngot + 1 + case default + imatch = .false. + end select + if (.not.imatch .and. ieos== 8) call read_options_eos_barotropic(name,valstring,imatch,igotall_barotropic,ierr) + if (.not.imatch .and. ieos== 9) call read_options_eos_piecewise( name,valstring,imatch,igotall_piecewise, ierr) + if (.not.imatch .and. ieos==20) call read_options_eos_gasradrec( name,valstring,imatch,igotall_gasradrec, ierr) + + !--make sure we have got all compulsory options (otherwise, rewrite input file) + igotall = (ngot >= 1) .and. igotall_piecewise .and. igotall_barotropic .and. igotall_gasradrec + +end subroutine read_options_eos + + +!----------------------------------------------------------------------- + +end module eos diff --git a/src/main/eos_gasradrec.f90 b/src/main/eos_gasradrec.f90 index d8e949aba..831a9302e 100644 --- a/src/main/eos_gasradrec.f90 +++ b/src/main/eos_gasradrec.f90 @@ -23,6 +23,7 @@ module eos_gasradrec public :: equationofstate_gasradrec,calc_uT_from_rhoP_gasradrec,read_options_eos_gasradrec,& write_options_eos_gasradrec,eos_info_gasradrec,init_eos_gasradrec private + real, parameter :: eoserr=1.e-15,W4err=1.e-2 contains !----------------------------------------------------------------------- @@ -39,7 +40,6 @@ subroutine equationofstate_gasradrec(d,eint,T,imu,X,Y,p,cf,gamma_eff) real, intent(in) :: X,Y real, intent(out) :: p,cf,gamma_eff real :: corr,erec,derecdT,dimurecdT,Tdot,logd,dt,Tguess - real, parameter :: W4err=1.e-2,eoserr=1.e-13 integer, parameter :: nmax = 500 integer n @@ -69,6 +69,7 @@ subroutine equationofstate_gasradrec(d,eint,T,imu,X,Y,p,cf,gamma_eff) print*,'d=',d,'eint=',eint/d,'Tguess=',Tguess,'mu=',1./imu,'T=',T,'erec=',erec call fatal('eos_gasradrec','Failed to converge on temperature in equationofstate_gasradrec') endif + call get_erec_imurec(logd,T,X,Y,erec,imu) p = ( Rg*imu*d + radconst*T**3/3. )*T gamma_eff = 1.+p/(eint-d*erec) cf = sqrt(gamma_eff*p/d) @@ -92,7 +93,6 @@ subroutine calc_uT_from_rhoP_gasradrec(rhoi,presi,X,Y,T,eni,mui,ierr) integer, intent(out) :: ierr integer :: n real :: logrhoi,imu,dimurecdT,dT,Tdot,corr - real, parameter :: W4err=1.e-2,eoserr=1.e-13 if (T <= 0.) T = min((3.*presi/radconst)**0.25, presi/(rhoi*Rg)) ! initial guess for temperature ierr = 0 diff --git a/src/main/eos_idealplusrad.f90 b/src/main/eos_idealplusrad.f90 index b48c73974..e2a6c10aa 100644 --- a/src/main/eos_idealplusrad.f90 +++ b/src/main/eos_idealplusrad.f90 @@ -20,7 +20,7 @@ module eos_idealplusrad ! use physcon, only:Rg,radconst implicit none - real, parameter :: tolerance = 1e-15 + real, parameter :: tolerance = 1.e-15 public :: get_idealplusrad_temp,get_idealplusrad_pres,get_idealplusrad_spsoundi,& get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp,& @@ -64,19 +64,17 @@ end subroutine get_idealplusrad_temp subroutine get_idealplusrad_pres(rhoi,tempi,mu,presi) - real, intent(in) :: rhoi,mu - real, intent(in) :: tempi + real, intent(in) :: rhoi,tempi,mu real, intent(out) :: presi - presi = Rg*rhoi*tempi/mu + 1./3.*radconst*tempi**4 ! Eq 13.2 (Kippenhahn et al.) + presi = (Rg*rhoi/mu + radconst*tempi**3/3.)*tempi ! Eq 13.2 (Kippenhahn et al.) end subroutine get_idealplusrad_pres subroutine get_idealplusrad_spsoundi(rhoi,presi,eni,spsoundi,gammai) real, intent(in) :: rhoi,presi,eni - real, intent(out) :: spsoundi - real, intent(out) :: gammai + real, intent(out) :: spsoundi,gammai gammai = 1. + presi/(eni*rhoi) spsoundi = sqrt(gammai*presi/rhoi) @@ -127,7 +125,7 @@ subroutine get_idealplusrad_enfromtemp(densi,tempi,mu,eni) real, intent(in) :: densi,tempi,mu real, intent(out) :: eni - eni = 3./2.*Rg*tempi/mu + radconst*tempi**4/densi + eni = 1.5*Rg*tempi/mu + radconst*tempi**4/densi end subroutine get_idealplusrad_enfromtemp diff --git a/src/main/extern_corotate.f90 b/src/main/extern_corotate.f90 index 72eedd4e5..e8d9bfff8 100644 --- a/src/main/extern_corotate.f90 +++ b/src/main/extern_corotate.f90 @@ -39,7 +39,7 @@ module extern_corotate real, public :: primarycore_xpos = 1., primarycore_mass = 1. integer, public :: icompanion_grav = 0 - public :: update_coriolis_leapfrog + public :: update_coriolis public :: get_coriolis_force,get_centrifugal_force,get_companion_force public :: write_options_corotate, read_options_corotate private @@ -132,17 +132,16 @@ end subroutine get_coriolis_force ! returning the forces plus the Coriolis force. !+ !--------------------------------------------------------------- -subroutine update_coriolis_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& - vcrossomega,dt) +subroutine update_coriolis(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& + vcrossomega,dkdt) use vectorutils, only:cross_product3D,matrixinvert3D use io, only:fatal - real, intent(in) :: dt + real, intent(in) :: dkdt real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(out) :: vcrossomega(3) integer :: ierr - real :: dton2 real :: A(3),v1(3),Omegap(3) real :: Rmat(3,3),Rinv(3,3) @@ -161,15 +160,14 @@ subroutine update_coriolis_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& ! ! and fxi,fyi,fzi are the components of f1_sph !-------------------------------------------------- - dton2 = 0.5*dt - A(1) = vhalfx + dton2*fxi - A(2) = vhalfy + dton2*fyi - A(3) = vhalfz + dton2*fzi + A(1) = vhalfx + dkdt*fxi + A(2) = vhalfy + dkdt*fyi + A(3) = vhalfz + dkdt*fzi ! This is the matrix from the equation for v1: [Rmat][v1] = [A] - Rmat = reshape((/1., -dton2*Omegap(3), dton2*Omegap(2), & - dton2*Omegap(3), 1., -dton2*Omegap(1), & - -dton2*Omegap(2), dton2*Omegap(1), 1. /),(/3,3/)) + Rmat = reshape((/1., -dkdt*Omegap(3), dkdt*Omegap(2), & + dkdt*Omegap(3), 1., -dkdt*Omegap(1), & + -dkdt*Omegap(2), dkdt*Omegap(1), 1. /),(/3,3/)) ! Get the inverse matrix call matrixinvert3D(Rmat,Rinv,ierr) @@ -188,7 +186,7 @@ subroutine update_coriolis_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& fyi = fyi + vcrossomega(2) fzi = fzi + vcrossomega(3) -end subroutine update_coriolis_leapfrog +end subroutine update_coriolis !----------------------------------------------------------------------- !+ diff --git a/src/main/extern_gnewton.f90 b/src/main/extern_gnewton.f90 index 75a8563e9..8d60fe62e 100644 --- a/src/main/extern_gnewton.f90 +++ b/src/main/extern_gnewton.f90 @@ -21,7 +21,7 @@ module extern_gnewton ! implicit none public :: get_gnewton_spatial_force, get_gnewton_vdependent_force - public :: update_gnewton_leapfrog + public :: update_gnewton public :: get_gnewton_energy private @@ -99,18 +99,18 @@ subroutine get_gnewton_vdependent_force(xyzi,veli,mass,fexti) end subroutine get_gnewton_vdependent_force -subroutine update_gnewton_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,mass) +subroutine update_gnewton(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,mass) use io, only:fatal - real, intent(in) :: dt,xi,yi,zi, mass + real, intent(in) :: dkdt,xi,yi,zi, mass real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(inout) :: fexti(3) real :: fextv(3) - real :: v1x, v1y, v1z, v1xold, v1yold, v1zold, vhalf2, erri, dton2 + real :: v1x, v1y, v1z, v1xold, v1yold, v1zold, vhalf2, erri logical :: converged integer :: its, itsmax integer, parameter :: maxitsext = 50 ! maximum number of iterations on external force - character(len=30), parameter :: label = 'update_gnewton_leapfrog' + character(len=30), parameter :: label = 'update_gnewton' real, parameter :: tolv = 1.e-2 real, parameter :: tolv2 = tolv*tolv real,dimension(3) :: pos,vel @@ -118,7 +118,6 @@ subroutine update_gnewton_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi, itsmax = maxitsext its = 0 converged = .false. - dton2 = 0.5*dt v1x = vhalfx v1y = vhalfy @@ -142,9 +141,9 @@ subroutine update_gnewton_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi, v1y = vel(2) v1z = vel(3) - v1x = vhalfx + dton2*(fxi + fextv(1)) - v1y = vhalfy + dton2*(fyi + fextv(2)) - v1z = vhalfz + dton2*(fzi + fextv(3)) + v1x = vhalfx + dkdt*(fxi + fextv(1)) + v1y = vhalfy + dkdt*(fyi + fextv(2)) + v1z = vhalfz + dkdt*(fzi + fextv(3)) erri = (v1x - v1xold)**2 + (v1y - v1yold)**2 + (v1z - v1zold)**2 erri = erri / vhalf2 @@ -162,7 +161,7 @@ subroutine update_gnewton_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi, fyi = fyi + fexti(2) fzi = fzi + fexti(3) -end subroutine update_gnewton_leapfrog +end subroutine update_gnewton !----------------------------------------------------------------------- diff --git a/src/main/extern_lensethirring.f90 b/src/main/extern_lensethirring.f90 index cfc6b9b03..e1f318e46 100644 --- a/src/main/extern_lensethirring.f90 +++ b/src/main/extern_lensethirring.f90 @@ -31,7 +31,7 @@ module extern_lensethirring real, public :: blackhole_spin_angle = 0. real, public :: cos_spinangle = 1., sin_spinangle = 0. - public :: update_ltforce_leapfrog + public :: update_ltforce public :: get_lense_thirring_force,check_lense_thirring_settings public :: write_options_ltforce, read_options_ltforce private @@ -111,25 +111,22 @@ end subroutine get_lense_thirring_force ! returning the forces plust the Lense-Thirring force. !+ !--------------------------------------------------------------- -subroutine update_ltforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& - vcrossomega,dt,xi,yi,zi,bh_mass) +subroutine update_ltforce(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& + vcrossomega,dkdt,xi,yi,zi,bh_mass) use vectorutils, only : cross_product3D,matrixinvert3D use io, only : fatal,warning - real, intent(in) :: dt,xi,yi,zi,bh_mass + real, intent(in) :: dkdt,xi,yi,zi,bh_mass real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(out) :: vcrossomega(3) integer :: ierr - real :: dton2,dton2sq !,f2,flt2 real :: A(3),v1(3),Omegap(3) !,v1check real :: Rmat(3,3),Rinv(3,3) ! Half the timestep and compute its square - dton2 = 0.5*dt - dton2sq = dton2**2 ! Equation we are solving is: v1 = v0 + 0.5dt*(f0 + f1_sph + v1 cross Omega) ! vhalf = v0 + 0.5*dt*f0 @@ -142,14 +139,14 @@ subroutine update_ltforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& !---------------------------------------------------------------------- ! Third attempt with matrix inversion. !---------------------------------------------------------------------- - A(1) = vhalfx + dton2*fxi - A(2) = vhalfy + dton2*fyi - A(3) = vhalfz + dton2*fzi + A(1) = vhalfx + dkdt*fxi + A(2) = vhalfy + dkdt*fyi + A(3) = vhalfz + dkdt*fzi ! This is the matrix from the equation for v1: [Rmat][v1] = [A] - Rmat = reshape((/1., -dton2*Omegap(3), dton2*Omegap(2), & - dton2*Omegap(3), 1., -dton2*Omegap(1), & - -dton2*Omegap(2), dton2*Omegap(1), 1. /),(/3,3/)) + Rmat = reshape((/1., -dkdt*Omegap(3), dkdt*Omegap(2), & + dkdt*Omegap(3), 1., -dkdt*Omegap(1), & + -dkdt*Omegap(2), dkdt*Omegap(1), 1. /),(/3,3/)) ! Get the inverse matrix call matrixinvert3D(Rmat,Rinv,ierr) @@ -189,7 +186,7 @@ subroutine update_ltforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,& ! call warning('extern_lensethirring',' lense-thirring force > 10% of total force') ! endif -end subroutine update_ltforce_leapfrog +end subroutine update_ltforce !--------------------------------------------------------------- !+ diff --git a/src/main/extern_prdrag.f90 b/src/main/extern_prdrag.f90 index 78456bd68..da3f311ff 100644 --- a/src/main/extern_prdrag.f90 +++ b/src/main/extern_prdrag.f90 @@ -19,7 +19,7 @@ module extern_prdrag ! ! subroutine get_prdrag_spatial_force-- use beta_module, only:beta ! subroutine get_prdrag_vdependent_force-- use beta_module, only:beta -! subroutine update_prdrag_leapfrog-- use beta_module, only:beta +! subroutine update_prdrag-- use beta_module, only:beta ! subroutine write_options_prdrag-- use beta_module, only:write_options_beta ! subroutine read_options_prdrag-- use beta_module, only:read_options_beta ! @@ -27,9 +27,10 @@ module extern_prdrag ! ! :Owner: Daniel Price ! -! :Runtime parameters: None +! :Runtime parameters: +! - beta : *beta parameter* ! -! :Dependencies: eos, infile_utils, io, lumin_nsdisc, units +! :Dependencies: eos, infile_utils, io, units, vectorutils ! use eos, only:qfacdisc @@ -41,9 +42,10 @@ module extern_prdrag real, private :: k2 = 1. ! transverse drag real, private :: k0 = 1. ! radiation pressure real, private :: k1 = 1. ! redshift + real, private :: beta = 0.01 public :: get_prdrag_spatial_force, get_prdrag_vdependent_force - public :: update_prdrag_leapfrog + public :: update_prdrag public :: read_options_prdrag, write_options_prdrag private @@ -56,7 +58,6 @@ module extern_prdrag !+ !------------------------------------------------ subroutine get_prdrag_spatial_force(xi,yi,zi,MStar,fextxi,fextyi,fextzi,phi) - use lumin_nsdisc, only:beta use units, only:get_G_code real, intent(in) :: xi,yi,zi,Mstar real, intent(inout) :: fextxi,fextyi,fextzi @@ -66,7 +67,7 @@ subroutine get_prdrag_spatial_force(xi,yi,zi,MStar,fextxi,fextyi,fextzi,phi) gcode = get_G_code() r2 = xi*xi + yi*yi + zi*zi - betai = beta(xi,yi,zi) + betai = beta rbetai = k0*betai if (r2 > epsilon(r2)) then dr = 1./sqrt(r2) @@ -86,8 +87,7 @@ end subroutine get_prdrag_spatial_force !+ !----------------------------------------------------------------------- subroutine get_prdrag_vdependent_force(xyzi,vel,Mstar,fexti) - use lumin_nsdisc, only:beta !Change your Poynting-Robertson here. - use units, only:get_c_code,get_G_code + use units, only:get_c_code,get_G_code real, intent(in) :: xyzi(3), vel(3) real, intent(in) :: Mstar real, intent(out) :: fexti(3) @@ -104,63 +104,79 @@ subroutine get_prdrag_vdependent_force(xyzi,vel,Mstar,fexti) rhat = xyzi/r vr = dot_product(vel, rhat) - betai = beta( xyzi(1), xyzi(2), xyzi(3) ) + betai = beta fexti = (-betai*Mstar*gcode/ccode)* & ( (vr/r3)*xyzi*k1 + vel/r2*k2 ) end subroutine get_prdrag_vdependent_force -subroutine update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,Mstar) - use lumin_nsdisc, only:beta - use units, only:get_c_code - use io, only:warn - real, intent(in) :: dt,xi,yi,zi, Mstar +!----------------------------------------------------------------------- +!+ +! solve for the velocity update in the leapfrog corrector step +! i.e. v^n+1 = vhalf + 0.5*dt*f_sph + 0.5*dt*f_pr(x,v^n+1) +!+ +!----------------------------------------------------------------------- +subroutine update_prdrag(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,Mstar) + use units, only:get_c_code,get_G_code + use io, only:warn,fatal + use vectorutils, only:matrixinvert3D + real, intent(in) :: dkdt,xi,yi,zi,Mstar real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(inout) :: fexti(3) - real :: r, r2, r3, Q, betai - real :: Tx, Ty, Tz, vonex, voney, vonez - real :: denominator, vrhalf, vrone, twoQondt - real :: xi2, yi2, zi2, ccode, kd - character(len=30), parameter :: label = 'update_prdrag_leapfrog' + integer :: ierr + real :: r2,dr,rx,ry,rz + real :: gcode,ccode,betai,bterm,b,vr + real :: rhat(3),vel(3),A(3),Rmat(3,3),Rinv(3,3) + character(len=30), parameter :: label = 'update_prdrag' ccode = get_c_code() + gcode = get_G_code() - xi2 = xi*xi - yi2 = yi*yi - zi2 = zi*zi - kd = k1 - k2 - r2 = (xi2 + yi2 + zi2) - r = sqrt(r2) - r3 = r*r2 - vrhalf = vhalfx*xi + vhalfy*yi + vhalfz*zi + r2 = xi*xi + yi*yi + zi*zi + dr = 1./sqrt(r2) + rx = xi*dr + ry = yi*dr + rz = zi*dr + rhat = (/rx,ry,rz/) - betai = beta( xi, yi, zi ) - Q = Mstar*betai*dt/(2.*ccode*r*r) - twoQondt = 2.*Q/dt - denominator = -r2*( k2*kd*Q*Q + (kd-k2)*Q - 1 ) + ! solve for v^1 using matrix inversion of [Rmat][v1] = [A] + A(1) = vhalfx + dkdt*fxi + A(2) = vhalfy + dkdt*fyi + A(3) = vhalfz + dkdt*fzi - Tx = vhalfx + 0.5*dt*fxi - Ty = vhalfy + 0.5*dt*fyi - Tz = vhalfz + 0.5*dt*fzi + betai = beta + bterm = betai*gcode*Mstar/(ccode*r2) + b = dkdt*bterm - vonex = (-(Q*k1*xi)*(Ty*yi+Tz*zi)+Q*kd*Tx*r2-Tx*(r2+Q*k1*xi2))/denominator - voney = (-(Q*k1*yi)*(Tx*xi+Tz*zi)+Q*kd*Ty*r2-Ty*(r2+Q*k1*yi2))/denominator - vonez = (-(Q*k1*zi)*(Tx*xi+Ty*yi)+Q*kd*Tz*r2-Tz*(r2+Q*k1*zi2))/denominator + ! This is the matrix from the equation for v1: [Rmat][v1] = [A] + Rmat = reshape((/1. + b*(k2 + k1*rx*rx), b*k1*ry*rx, b*k1*rz*rx, & + b*k1*rx*ry, 1. + b*(k2 + k1*ry*ry), b*k1*rz*ry, & + b*k1*rx*rz, b*k1*ry*rz, 1. + b*(k2 + k1*rz*rz)/),(/3,3/)) - vrone = (vonex*xi + voney*yi + vonez*zi)/r ! vr = rhat dot v +! Get the inverse matrix + call matrixinvert3D(Rmat,Rinv,ierr) + if (ierr /= 0) then + call fatal('extern_prdrag','Error: determinant = 0 in matrix inversion') + endif + +! Compute v1 via matrix multiplication. + vel(:) = matmul(A,Rinv) + + vr = dot_product(vel,rhat) - fexti(1) = twoQondt * (vonex*k2 + k1*vrone*xi/r) - fexti(2) = twoQondt * (voney*k2 + k1*vrone*yi/r) - fexti(3) = twoQondt * (vonez*k2 + k1*vrone*zi/r) + ! velocity dependent part of the P-R drag force (e.g. equation 142 of Klacka 1992) + fexti(:) = -bterm*(vr*rhat*k1 + vel*k2) - fxi = fxi + fexti(1) - fyi = fyi + fexti(2) - fzi = fzi + fexti(3) + !v1check(:) = A(:) + dton2*fexti(:) ! this should match expression for v1 -end subroutine update_prdrag_leapfrog + fxi = fxi + fexti(1) + fyi = fyi + fexti(2) + fzi = fzi + fexti(3) + +end subroutine update_prdrag !----------------------------------------------------------------------- !+ @@ -169,11 +185,11 @@ end subroutine update_prdrag_leapfrog !----------------------------------------------------------------------- subroutine write_options_prdrag(iunit) use infile_utils, only:write_inopt - use lumin_nsdisc, only:write_options_lumin_nsdisc integer, intent(in) :: iunit write(iunit,"(/,a)") '# options relating to Poynting-Robertson drag' + call write_inopt(beta,'beta','beta parameter',iunit) call write_inopt(k0, 'RadiationPressure', & 'Radiation pressure multiplier', iunit) call write_inopt(k2, 'TransverseDrag', & @@ -181,8 +197,6 @@ subroutine write_options_prdrag(iunit) call write_inopt(k1, 'Redshift', & 'Redshift multiplier', iunit) - call write_options_lumin_nsdisc(iunit) - end subroutine write_options_prdrag !----------------------------------------------------------------------- @@ -191,8 +205,7 @@ end subroutine write_options_prdrag !+ !----------------------------------------------------------------------- subroutine read_options_prdrag(name,valstring,imatch,igotall,ierr) - use io, only:fatal, warning - use lumin_nsdisc, only:read_options_lumin_nsdisc + use io, only:fatal, warning character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr @@ -203,6 +216,9 @@ subroutine read_options_prdrag(name,valstring,imatch,igotall,ierr) igotall = .false. select case(trim(name)) + case('beta') + read(valstring,*,iostat=ierr) beta + ngot = ngot + 1 case('RadiationPressure') read(valstring,*,iostat=ierr) k0 ngot = ngot + 1 @@ -214,7 +230,6 @@ subroutine read_options_prdrag(name,valstring,imatch,igotall,ierr) ngot = ngot + 1 case default imatch = .false. - call read_options_lumin_nsdisc(name,valstring,imatch,igotall,ierr) end select igotall = (ngot >= 1) diff --git a/src/main/externalforces.f90 b/src/main/externalforces.f90 index 51f3ecd3c..aa5aad3ba 100644 --- a/src/main/externalforces.f90 +++ b/src/main/externalforces.f90 @@ -21,7 +21,7 @@ module externalforces ! :Dependencies: dump_utils, extern_Bfield, extern_binary, extern_corotate, ! extern_densprofile, extern_geopot, extern_gnewton, extern_gwinspiral, ! extern_lensethirring, extern_prdrag, extern_spiral, extern_staticsine, -! infile_utils, io, lumin_nsdisc, part, units +! infile_utils, io, part, units ! use extern_binary, only:accradius1,mass1,accretedmass1,accretedmass2 use extern_corotate, only:omega_corotate ! so public from this module @@ -33,7 +33,7 @@ module externalforces public :: accradius1,omega_corotate,accretedmass1,accretedmass2 public :: write_options_externalforces,read_options_externalforces public :: initialise_externalforces,is_velocity_dependent - public :: update_vdependent_extforce_leapfrog + public :: update_vdependent_extforce public :: update_externalforce public :: write_headeropts_extern,read_headeropts_extern @@ -493,14 +493,14 @@ end subroutine externalforce_vdependent ! necessary for using v-dependent forces in leapfrog !+ !----------------------------------------------------------------------- -subroutine update_vdependent_extforce_leapfrog(iexternalforce, & - vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,densi,ui) - use extern_corotate, only:update_coriolis_leapfrog - use extern_prdrag, only:update_prdrag_leapfrog - use extern_lensethirring, only:update_ltforce_leapfrog - use extern_gnewton, only:update_gnewton_leapfrog +subroutine update_vdependent_extforce(iexternalforce, & + vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,densi,ui) + use extern_corotate, only:update_coriolis + use extern_prdrag, only:update_prdrag + use extern_lensethirring, only:update_ltforce + use extern_gnewton, only:update_gnewton integer, intent(in) :: iexternalforce - real, intent(in) :: dt,xi,yi,zi + real, intent(in) :: dkdt,xi,yi,zi real, intent(in) :: vhalfx,vhalfy,vhalfz real, intent(inout) :: fxi,fyi,fzi real, intent(out) :: fexti(3) @@ -508,16 +508,16 @@ subroutine update_vdependent_extforce_leapfrog(iexternalforce, & select case(iexternalforce) case(iext_corotate,iext_corot_binary) - call update_coriolis_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt) + call update_coriolis(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt) case(iext_prdrag) - call update_prdrag_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,mass1) + call update_prdrag(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,mass1) case(iext_lensethirring,iext_einsteinprec) - call update_ltforce_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,mass1) + call update_ltforce(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,mass1) case(iext_gnewton) - call update_gnewton_leapfrog(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,mass1) + call update_gnewton(vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dkdt,xi,yi,zi,mass1) end select -end subroutine update_vdependent_extforce_leapfrog +end subroutine update_vdependent_extforce !----------------------------------------------------------------------- !+ @@ -525,9 +525,8 @@ end subroutine update_vdependent_extforce_leapfrog !+ !----------------------------------------------------------------------- subroutine update_externalforce(iexternalforce,ti,dmdt) - use io, only:iprint,iverbose,warn - use lumin_nsdisc, only:set_Lstar,BurstProfile,LumAcc,make_beta_grids - use part, only:xyzh,vxyzu,massoftype,npartoftype,igas,npart,nptmass,& + use io, only:warn + use part, only:xyzh,vxyzu,igas,npart,nptmass,& xyzmh_ptmass,vxyz_ptmass use extern_gwinspiral, only:gw_still_inspiralling,get_gw_force use extern_binary, only:update_binary @@ -538,12 +537,6 @@ subroutine update_externalforce(iexternalforce,ti,dmdt) select case(iexternalforce) case(iext_binary,iext_corot_binary) call update_binary(ti) - case(iext_prdrag) - call make_beta_grids( xyzh, massoftype(igas), npartoftype(igas) ) - call set_Lstar( BurstProfile, ti, dmdt, mass1 ) - if (iverbose >= 1) then - write(iprint,*) 'updating prdrag at t = ',ti,' Mdot = ',dmdt,' LAcc = ',LumAcc - endif case(iext_gwinspiral) call gw_still_inspiralling(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,stopped_now) call get_gw_force() diff --git a/src/main/part.F90 b/src/main/part.F90 index 652935668..362587bc2 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -204,10 +204,12 @@ module part integer, parameter :: i_mlast = 17 ! accreted mass of last time integer, parameter :: imassenc = 18 ! mass enclosed in sink softening radius integer, parameter :: iJ2 = 19 ! 2nd gravity moment due to oblateness + integer, parameter :: ndptmass = 13 ! number of properties to conserve after a accretion phase or merge real, allocatable :: xyzmh_ptmass(:,:) real, allocatable :: vxyz_ptmass(:,:) - real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:) + real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:),fsink_old(:,:) real, allocatable :: dsdt_ptmass(:,:),dsdt_ptmass_sinksink(:,:) + real, allocatable :: dptmass(:,:) integer :: nptmass = 0 ! zero by default real :: epot_sinksink character(len=*), parameter :: xyzmh_ptmass_label(nsinkproperties) = & @@ -431,6 +433,8 @@ subroutine allocate_part call allocate_array('vxyz_ptmass', vxyz_ptmass, 3, maxptmass) call allocate_array('fxyz_ptmass', fxyz_ptmass, 4, maxptmass) call allocate_array('fxyz_ptmass_sinksink', fxyz_ptmass_sinksink, 4, maxptmass) + call allocate_array('fsink_old', fsink_old, 4, maxptmass) + call allocate_array('dptmass', dptmass, ndptmass,maxptmass) call allocate_array('dsdt_ptmass', dsdt_ptmass, 3, maxptmass) call allocate_array('dsdt_ptmass_sinksink', dsdt_ptmass_sinksink, 3, maxptmass) call allocate_array('poten', poten, maxgrav) @@ -517,6 +521,8 @@ subroutine deallocate_part if (allocated(vxyz_ptmass)) deallocate(vxyz_ptmass) if (allocated(fxyz_ptmass)) deallocate(fxyz_ptmass) if (allocated(fxyz_ptmass_sinksink)) deallocate(fxyz_ptmass_sinksink) + if (allocated(fsink_old)) deallocate(fsink_old) + if (allocated(dptmass)) deallocate(dptmass) if (allocated(dsdt_ptmass)) deallocate(dsdt_ptmass) if (allocated(dsdt_ptmass_sinksink)) deallocate(dsdt_ptmass_sinksink) if (allocated(poten)) deallocate(poten) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e36d26066..9d536862e 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -47,7 +47,7 @@ module ptmass public :: pt_write_sinkev, pt_close_sinkev public :: get_accel_sink_gas, get_accel_sink_sink public :: merge_sinks - public :: ptmass_predictor, ptmass_corrector + public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured public :: ptmass_accrete, ptmass_create public :: write_options_ptmass, read_options_ptmass @@ -55,6 +55,7 @@ module ptmass public :: calculate_mdot public :: ptmass_calc_enclosed_mass public :: ptmass_boundary_crossing + public :: set_integration_precision ! settings affecting routines in module (read from/written to input file) integer, public :: icreate_sinks = 0 @@ -67,6 +68,19 @@ module ptmass real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius real, public :: f_crit_override = 0.0 ! 1000. + + + logical, public :: use_fourthorder = .true. + integer, public :: n_force_order = 3 + real, public, parameter :: dk2(3) = (/0.5,0.5,0.0/) + real, public, parameter :: ck2(2) = (/1.,0.0/) + real, public, parameter :: dk4(3) = (/1./6.,2./3.,1./6./) + real, public, parameter :: ck4(2) = (/0.5,0.5/) + + real, public :: dk(3) + real, public :: ck(2) + + ! Note for above: if f_crit_override > 0, then will unconditionally make a sink when rho > f_crit_override*rho_crit_cgs ! This is a dangerous parameter since failure to form a sink might be indicative of another problem. ! This is a hard-coded parameter due to this danger, but will appear in the .in file if set > 0. @@ -81,8 +95,14 @@ module ptmass ! calibration of timestep control on sink-sink and sink-gas orbital integration ! this is hardwired because can be adjusted by changing C_force ! just means that with the default setting of C_force the orbits are accurate - real, parameter :: dtfacphi = 0.05 - real, parameter :: dtfacphi2 = dtfacphi*dtfacphi + real, parameter :: dtfacphilf = 0.05 + real, parameter :: dtfacphi2lf = dtfacphilf**2 + real, parameter :: dtfacphifsi = 0.15 + real, parameter :: dtfacphi2fsi = dtfacphifsi**2 + + real :: dtfacphi = dtfacphifsi + real :: dtfacphi2 = dtfacphifsi + ! parameters to control output regarding sink particles logical, private, parameter :: record_created = .false. ! verbose tracking of why sinks are not created @@ -91,7 +111,6 @@ module ptmass character(len=50), private :: pt_prefix = 'Sink' character(len=50), private :: pt_suffix = '00.sink' ! will be overwritten to .ev for write_one_ptfile = .false. - integer, public, parameter :: ndptmass = 13 integer, public, parameter :: & idxmsi = 1, & idymsi = 2, & @@ -121,7 +140,8 @@ 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) + pmassi,fxyz_ptmass,dsdt_ptmass,fonrmax, & + dtphi2,extrapfac,fsink_old) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -132,15 +152,16 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, real, intent(in) :: xi,yi,zi,hi real, intent(inout) :: fxi,fyi,fzi,phi real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, optional, intent(in) :: pmassi + real, optional, intent(in) :: pmassi,extrapfac real, optional, intent(inout) :: fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) + real, optional, intent(in) :: fsink_old(4,nptmass) real, optional, intent(out) :: fonrmax,dtphi2 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 integer :: j - logical :: tofrom + logical :: tofrom,extrap ! ! Determine if acceleration is from/to gas, or to gas ! @@ -151,6 +172,14 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, tofrom = .false. endif + ! check if it is a force computed using Omelyan extrapolation method for FSI + if (present(extrapfac)) then + extrap = .true. + else + extrap = .false. + endif + + ftmpxi = 0. ! use temporary summation variable ftmpyi = 0. ! (better for round-off, plus we need this bit of ftmpzi = 0. ! the force to calculate the dtphi timestep) @@ -158,9 +187,15 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, f2 = 0. do j=1,nptmass - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) + if (extrap) then + dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fsink_old(1,j)) + dy = yi - (xyzmh_ptmass(2,j) + extrapfac*fsink_old(2,j)) + dz = zi - (xyzmh_ptmass(3,j) + extrapfac*fsink_old(3,j)) + else + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + endif pmassj = xyzmh_ptmass(4,j) hsoft = xyzmh_ptmass(ihsoft,j) J2 = xyzmh_ptmass(iJ2,j) @@ -264,7 +299,7 @@ end subroutine get_accel_sink_gas !+ !---------------------------------------------------------------- subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,& - iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass) + iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass,extrapfac,fsink_old) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -272,14 +307,16 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(out) :: fxyz_ptmass(4,nptmass) - real, intent(out) :: phitot,dtsinksink - integer, intent(in) :: iexternalforce - real, intent(in) :: ti - integer, intent(out) :: merge_ij(:),merge_n - real, intent(out) :: dsdt_ptmass(3,nptmass) + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(out) :: fxyz_ptmass(4,nptmass) + real, intent(out) :: phitot,dtsinksink + integer, intent(in) :: iexternalforce + real, intent(in) :: ti + integer, intent(out) :: merge_ij(:),merge_n + real, intent(out) :: dsdt_ptmass(3,nptmass) + real, optional, intent(in) :: extrapfac + real, optional, intent(in) :: fsink_old(4,nptmass) real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii real :: ddr,dx,dy,dz,rr2,rr2j,dr3,f1,f2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft @@ -288,6 +325,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real :: J2i,rsinki,shati(3) real :: J2j,rsinkj,shatj(3) integer :: i,j + logical :: extrap dtsinksink = huge(dtsinksink) fxyz_ptmass(:,:) = 0. @@ -295,7 +333,13 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin phitot = 0. merge_n = 0 merge_ij = 0 - if (nptmass <= 1) return + 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 + extrap = .true. + else + extrap = .false. + endif ! !--get self-contribution to the potential if sink-sink softening is used ! @@ -314,6 +358,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp parallel do default(none) & !$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) & !$omp private(i,xi,yi,zi,pmassi,pmassj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & @@ -323,9 +368,15 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) do i=1,nptmass - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) + if (extrap) then + xi = xyzmh_ptmass(1,i) + extrapfac*fsink_old(1,i) + yi = xyzmh_ptmass(2,i) + extrapfac*fsink_old(2,i) + zi = xyzmh_ptmass(3,i) + extrapfac*fsink_old(3,i) + else + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + endif pmassi = xyzmh_ptmass(4,i) !hsofti = xyzmh_ptmass(5,i) if (pmassi < 0.) cycle @@ -340,9 +391,15 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dsz = 0. do j=1,nptmass if (i==j) cycle - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) + if (extrap) then + dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fsink_old(1,j)) + dy = yi - (xyzmh_ptmass(2,j) + extrapfac*fsink_old(2,j)) + dz = zi - (xyzmh_ptmass(3,j) + extrapfac*fsink_old(3,j)) + else + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + endif pmassj = xyzmh_ptmass(4,j) !hsoftj = xyzmh_ptmass(5,j) if (pmassj < 0.) cycle @@ -437,13 +494,13 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin ! !--store sink-sink forces (only) ! - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + fxi - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + fyi - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + fzi - fxyz_ptmass(4,i) = fxyz_ptmass(4,i) + phii - dsdt_ptmass(1,i) = dsdt_ptmass(1,i) + pmassi*dsx - dsdt_ptmass(2,i) = dsdt_ptmass(2,i) + pmassi*dsy - dsdt_ptmass(3,i) = dsdt_ptmass(3,i) + pmassi*dsz + fxyz_ptmass(1,i) = fxi + fxyz_ptmass(2,i) = fyi + fxyz_ptmass(3,i) = fzi + fxyz_ptmass(4,i) = phii + dsdt_ptmass(1,i) = pmassi*dsx + dsdt_ptmass(2,i) = pmassi*dsy + dsdt_ptmass(3,i) = pmassi*dsz enddo !$omp end parallel do @@ -463,12 +520,13 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin ! so that with the default C_force of ~0.25 we get a few ! hundred steps per orbit ! - if (f2 > 0. .and. nptmass > 1) then + if (f2 > 0. .and. (nptmass > 1 .or. iexternalforce > 0)) then dtsinksink = min(dtsinksink,dtfacphi*sqrt(abs(phii)/f2)) endif enddo end subroutine get_accel_sink_sink + !---------------------------------------------------------------- !+ ! Update position of sink particles if they cross the periodic boundary @@ -494,106 +552,94 @@ end subroutine ptmass_boundary_crossing ! (called from inside a parallel section) !+ !---------------------------------------------------------------- -subroutine ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) +subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) integer, intent(in) :: nptmass - real, intent(in) :: dt + real, intent(in) :: ckdt real, intent(inout) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: vxyz_ptmass(3,nptmass) - real, intent(in) :: fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real :: vxhalfi,vyhalfi,vzhalfi integer :: i !$omp parallel do schedule(static) default(none) & - !$omp shared(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) & - !$omp private(i,vxhalfi,vyhalfi,vzhalfi) + !$omp shared(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) & + !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then - vxhalfi = vxyz_ptmass(1,i) + 0.5*dt*fxyz_ptmass(1,i) - vyhalfi = vxyz_ptmass(2,i) + 0.5*dt*fxyz_ptmass(2,i) - vzhalfi = vxyz_ptmass(3,i) + 0.5*dt*fxyz_ptmass(3,i) - xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dt*vxhalfi - xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dt*vyhalfi - xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dt*vzhalfi - vxyz_ptmass(1,i) = vxhalfi - vxyz_ptmass(2,i) = vyhalfi - vxyz_ptmass(3,i) = vzhalfi - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + 0.5*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + 0.5*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + 0.5*dt*dsdt_ptmass(3,i) + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ckdt*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ckdt*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + ckdt*vxyz_ptmass(3,i) endif enddo !$omp end parallel do -end subroutine ptmass_predictor +end subroutine ptmass_drift !---------------------------------------------------------------- !+ -! corrector step for the point masses -! (called from inside a parallel section) +! kick step for the point masses !+ !---------------------------------------------------------------- -subroutine ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,iexternalforce) - use externalforces, only:update_vdependent_extforce_leapfrog,is_velocity_dependent +subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass) integer, intent(in) :: nptmass - real, intent(in) :: dt + real, intent(in) :: dkdt real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) real, intent(in) :: fxyz_ptmass(4,nptmass) real, intent(in) :: dsdt_ptmass(3,nptmass) + integer :: i + + + !$omp parallel do schedule(static) default(none) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dkdt,nptmass) & + !$omp private(i) + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dkdt*fxyz_ptmass(1,i) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dkdt*fxyz_ptmass(2,i) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dkdt*fxyz_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) + endif + enddo + !$omp end parallel do + + +end subroutine ptmass_kick + +!---------------------------------------------------------------- +!+ +! force correction due to vdep force. +!+ +!---------------------------------------------------------------- +subroutine ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) + use externalforces, only:update_vdependent_extforce + integer, intent(in) :: nptmass + real, intent(in) :: dkdt + real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(inout) :: fxyz_ptmass(4,nptmass) integer, intent(in) :: iexternalforce - real :: vxhalfi,vyhalfi,vzhalfi real :: fxi,fyi,fzi,fextv(3) integer :: i - ! - ! handle special case of velocity-dependent external forces - ! in the leapfrog integrator - ! - if (is_velocity_dependent(iexternalforce)) then - !$omp parallel do schedule(static) default(none) & - !$omp shared(vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,dt,nptmass,iexternalforce) & - !$omp private(vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi,fextv) & - !$omp private(i) - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - vxhalfi = vxyz_ptmass(1,i) - vyhalfi = vxyz_ptmass(2,i) - vzhalfi = vxyz_ptmass(3,i) - fxi = fxyz_ptmass(1,i) - fyi = fxyz_ptmass(2,i) - fzi = fxyz_ptmass(3,i) - call update_vdependent_extforce_leapfrog(iexternalforce,& - vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi,fextv,dt,& - xyzmh_ptmass(1,i),xyzmh_ptmass(2,i),xyzmh_ptmass(3,i)) - fxi = fxi + fextv(1) - fyi = fyi + fextv(2) - fzi = fzi + fextv(3) - vxyz_ptmass(1,i) = vxhalfi + 0.5*dt*fxi - vxyz_ptmass(2,i) = vyhalfi + 0.5*dt*fyi - vxyz_ptmass(3,i) = vzhalfi + 0.5*dt*fzi - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + 0.5*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + 0.5*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + 0.5*dt*dsdt_ptmass(3,i) - endif - enddo - !$omp end parallel do - else - !$omp parallel do schedule(static) default(none) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,nptmass) & - !$omp private(i) - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + 0.5*dt*fxyz_ptmass(1,i) - vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + 0.5*dt*fxyz_ptmass(2,i) - vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + 0.5*dt*fxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + 0.5*dt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + 0.5*dt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + 0.5*dt*dsdt_ptmass(3,i) - endif - enddo - !$omp end parallel do - endif - -end subroutine ptmass_corrector + !$omp parallel do schedule(static) default(none) & + !$omp shared(vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dkdt,nptmass,iexternalforce) & + !$omp private(fxi,fyi,fzi,fextv) & + !$omp private(i) + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + fxi = fxyz_ptmass(1,i) + fyi = fxyz_ptmass(2,i) + fzi = fxyz_ptmass(3,i) + call update_vdependent_extforce(iexternalforce,& + vxyz_ptmass(1,i),vxyz_ptmass(2,i),vxyz_ptmass(3,i), & + fxi,fyi,fzi,fextv,dkdt,xyzmh_ptmass(1,i),xyzmh_ptmass(2,i), & + xyzmh_ptmass(3,i)) + fxyz_ptmass(1,i) = fxi + fextv(1) + fxyz_ptmass(2,i) = fyi + fextv(2) + fxyz_ptmass(3,i) = fzi + fextv(3) + endif + enddo + !$omp end parallel do +end subroutine ptmass_vdependent_correction !---------------------------------------------------------------- !+ @@ -685,6 +731,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & integer :: j real :: mpt,drdv,angmom2,angmomh2,epart,dxj,dyj,dzj,dvxj,dvyj,dvzj,rj2,vj2,epartj logical :: mostbound +!$ external :: omp_set_lock,omp_unset_lock accreted = .false. ifail = 0 @@ -908,9 +955,9 @@ end subroutine update_ptmass !+ !------------------------------------------------------------------------- subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& - massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,time) + massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) use part, only:ihacc,ihsoft,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & - ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP,igamma + ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP,igamma,ndptmass use dim, only:maxp,maxneigh,maxvxyzu,maxptmass,ind_timesteps use kdtree, only:getneigh use kernel, only:kernel_softening,radkern @@ -935,14 +982,13 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote real, intent(in) :: vxyzu(:,:),fxyzu(:,:),fext(:,:),massoftype(:) real(4), intent(in) :: divcurlv(:,:),poten(:) real, intent(inout) :: xyzmh_ptmass(:,:) - real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:),dptmass(ndptmass,nptmass+1) real, intent(in) :: time integer(kind=1) :: iphasei,ibin_wakei,ibin_itest integer :: nneigh integer, parameter :: maxcache = 12000 integer, parameter :: nneigh_thresh = 1024 ! approximate epot if neigh>neigh_thresh; (-ve for off) real, save :: xyzcache(maxcache,3) - real :: dptmass(ndptmass,nptmass+1) real :: xi,yi,zi,hi,hi1,hi21,xj,yj,zj,hj1,hj21,xk,yk,zk,hk1 real :: rij2,rik2,rjk2,dx,dy,dz real :: vxi,vyi,vzi,dv2,dvx,dvy,dvz,rhomax @@ -1585,6 +1631,24 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_i end subroutine merge_sinks +subroutine set_integration_precision + + if (use_fourthorder) then + n_force_order = 3 + ck = ck4 + dk = dk4 + dtfacphi = dtfacphifsi + dtfacphi2 = dtfacphi2fsi + else + n_force_order = 1 + ck = ck2 + dk = dk2 + dtfacphi = dtfacphilf + dtfacphi2 = dtfacphi2lf + endif + +end subroutine set_integration_precision + !----------------------------------------------------------------------- !+ ! Open files to track sink particle data diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index a1705b37c..aa2cccbf6 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -34,7 +34,6 @@ module readwrite_infile ! - dtwallmax : *maximum wall time between dumps (hhh:mm, 000:00=ignore)* ! - dumpfile : *dump file to start from* ! - flux_limiter : *limit radiation flux* -! - hdivbbmax_max : *max factor to decrease cleaning timestep propto B/(h|divB|)* ! - hfact : *h in units of particle spacing [h = hfact(m/rho)^(1/3)]* ! - ien_type : *energy variable (0=auto, 1=entropy, 2=energy, 3=entropy_s)* ! - implicit_radiation : *use implicit integration (Whitehouse, Bate & Monaghan 2005)* @@ -76,7 +75,7 @@ module readwrite_infile use options, only:nfulldump,nmaxdumps,twallmax,iexternalforce,tolh, & alpha,alphau,alphaB,beta,avdecayconst,damp,rkill, & ipdv_heating,ishock_heating,iresistive_heating,ireconav, & - icooling,psidecayfac,overcleanfac,hdivbbmax_max,alphamax,calc_erot,rhofinal_cgs, & + icooling,psidecayfac,overcleanfac,alphamax,calc_erot,rhofinal_cgs, & use_mcfost,use_Voronoi_limits_file,Voronoi_limits_file,use_mcfost_stellar_parameters,& exchange_radiation_energy,limit_radiation_flux,iopacity_type,mcfost_computes_Lacc,& mcfost_uses_PdV,implicit_radiation,mcfost_keep_part,ISM, mcfost_dust_subl @@ -84,7 +83,7 @@ module readwrite_infile use viscosity, only:irealvisc,shearparam,bulkvisc use part, only:hfact,ien_type use io, only:iverbose - use dim, only:do_radiation,nucleation,use_dust,use_dustgrowth + use dim, only:do_radiation,nucleation,use_dust,use_dustgrowth,mhd_nonideal implicit none logical :: incl_runtime2 = .false. @@ -112,12 +111,8 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) use inject, only:write_options_inject #endif use dust_formation, only:write_options_dust_formation -#ifdef NONIDEALMHD use nicil_sup, only:write_options_nicil -#endif -#ifdef GR use metric, only:write_options_metric -#endif use eos, only:write_options_eos,ieos,X_in,Z_in use ptmass, only:write_options_ptmass use ptmass_radiation,only:write_options_ptmass_radiation @@ -206,7 +201,6 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) call write_inopt(alphaB,'alphaB','shock resistivity parameter',iwritein) call write_inopt(psidecayfac,'psidecayfac','div B diffusion parameter',iwritein) call write_inopt(overcleanfac,'overcleanfac','factor to increase cleaning speed (decreases time step)',iwritein) - call write_inopt(hdivbbmax_max,'hdivbbmax_max','max factor to decrease cleaning timestep propto B/(h|divB|)',iwritein) endif call write_inopt(beta,'beta','beta viscosity',iwritein) if (maxalpha==maxp .and. maxp > 0) then @@ -272,10 +266,6 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) call write_options_porosity(iwritein) endif -#ifdef PHOTO - call write_options_photoevap(iwritein) -#endif - write(iwritein,"(/,a)") '# options for injecting/removing particles' #ifdef INJECT_PARTICLES call write_options_inject(iwritein) @@ -287,9 +277,8 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) write(iwritein,"(/,a)") '# options controling radiation pressure from sink particles' call write_options_ptmass_radiation(iwritein) endif -#ifdef NONIDEALMHD - call write_options_nicil(iwritein) -#endif + + if (mhd_nonideal) call write_options_nicil(iwritein) if (do_radiation) then write(iwritein,"(/,a)") '# options for radiation' @@ -309,16 +298,15 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) call write_inopt(cv_type,'cv_type','how to get cv and mean mol weight (0=constant,1=mesa)',iwritein) endif endif -#ifdef GR - call write_options_metric(iwritein) -#endif + + if (gr) call write_options_metric(iwritein) + call write_options_gravitationalwaves(iwritein) call write_options_boundary(iwritein) if (iwritein /= iprint) close(unit=iwritein) if (iwritein /= iprint) write(iprint,"(/,a)") ' input file '//trim(infile)//' written successfully.' - return end subroutine write_infile !----------------------------------------------------------------- @@ -347,9 +335,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) use inject, only:read_options_inject #endif use dust_formation, only:read_options_dust_formation,idust_opacity -#ifdef NONIDEALMHD use nicil_sup, only:read_options_nicil -#endif use part, only:mhd,nptmass use cooling, only:read_options_cooling use ptmass, only:read_options_ptmass @@ -494,8 +480,6 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) read(valstring,*,iostat=ierr) psidecayfac case('overcleanfac') read(valstring,*,iostat=ierr) overcleanfac - case('hdivbbmax_max') - read(valstring,*,iostat=ierr) hdivbbmax_max case('beta') read(valstring,*,iostat=ierr) beta case('ireconav') @@ -571,9 +555,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (.not.imatch .and. sink_radiation) then call read_options_ptmass_radiation(name,valstring,imatch,igotallprad,ierr) endif -#ifdef NONIDEALMHD if (.not.imatch) call read_options_nicil(name,valstring,imatch,igotallnonideal,ierr) -#endif if (.not.imatch) call read_options_eos(name,valstring,imatch,igotalleos,ierr) if (.not.imatch .and. maxvxyzu >= 4) call read_options_cooling(name,valstring,imatch,igotallcooling,ierr) if (.not.imatch) call read_options_damping(name,valstring,imatch,igotalldamping,ierr) From a037668cf00871e07174a0be404b4b95d7b4ccb4 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 2 May 2024 16:08:38 +0100 Subject: [PATCH 507/814] Further updates --- src/main/evolve.F90 | 16 +- src/main/force.F90 | 2 +- src/main/readwrite_infile.F90 | 13 +- src/main/step_leapfrog.F90 | 908 +---------------------- src/main/substepping.F90 | 1126 +++++++++++++++++++++++++++++ src/tests/test_derivs.F90 | 709 +++++++++--------- src/tests/test_dust.f90 | 2 +- src/tests/test_eos.f90 | 56 +- src/tests/test_eos_stratified.f90 | 10 +- src/tests/test_externf.f90 | 17 +- src/tests/test_gnewton.f90 | 6 +- src/tests/test_ptmass.f90 | 374 +++++++--- src/tests/testsuite.F90 | 5 +- src/tests/utils_testsuite.f90 | 9 +- 14 files changed, 1837 insertions(+), 1416 deletions(-) create mode 100644 src/main/substepping.F90 diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 68cface6f..c96f339c1 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -37,7 +37,7 @@ 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,hdivBB_xa + use energies, only:etot,totmom,angtot,mdust,np_cs_eq_0,np_e_eq_0,hdivBonB_ave,hdivBonB_max use checkconserved, only:etot_in,angtot_in,totmom_in,mdust_in,& init_conservation_checks,check_conservation_error,& check_magnetic_stability @@ -88,10 +88,11 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) use io, only:ianalysis #endif use part, only:npart,nptmass,xyzh,vxyzu,fxyzu,fext,divcurlv,massoftype, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gravity,iboundary, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,gravity,iboundary, & fxyz_ptmass_sinksink,ntot,poten,ndustsmall,accrete_particles_outside_sphere use quitdump, only:quit - use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot + use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & + set_integration_precision use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries @@ -162,6 +163,11 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) dtmax_log_dratio = 0.0 endif + ! + ! Set substepping integration precision depending on the system (default is FSI) + ! + call set_integration_precision + #ifdef IND_TIMESTEPS use_global_dt = .false. istepfrac = 0 @@ -270,7 +276,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! creation of new sink particles ! call ptmass_create(nptmass,npart,ipart_rhomax,xyzh,vxyzu,fxyzu,fext,divcurlv,& - poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,time) + poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) endif ! ! Strang splitting: implicit update for half step @@ -390,7 +396,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) call check_conservation_error(mdust(j),mdust_in(j),1.e-1,'dust mass',decrease=.true.) enddo endif - if (mhd) call check_magnetic_stability(hdivBB_xa) + if (mhd) call check_magnetic_stability(hdivBonB_ave,hdivBonB_max) 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 b542aafef..011f6cf2b 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -1024,7 +1024,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g real :: bigv2j,alphagrj,enthi,enthj real :: dlorentzv,lorentzj,lorentzi_star,lorentzj_star,projbigvi,projbigvj real :: bigvj(1:3),velj(3),metricj(0:3,0:3,2),projbigvstari,projbigvstarj - real :: radPj,fgravxi,fgravyi,fgravzi,kfldi,kfldj,Ti,Tj,diffterm,gmwi + real :: radPj,fgravxi,fgravyi,fgravzi,kfldi,kfldj,Ti,Tj,diffterm real :: gradpx,gradpy,gradpz,gradP_cooli=0d0,gradP_coolj=0d0 ! unpack diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index aa2cccbf6..ec94e4cee 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module readwrite_infile ! @@ -270,9 +270,10 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) #ifdef INJECT_PARTICLES call write_options_inject(iwritein) #endif - if (nucleation) call write_options_dust_formation(iwritein) call write_inopt(rkill,'rkill','deactivate particles outside this radius (<0 is off)',iwritein) + if (nucleation) call write_options_dust_formation(iwritein) + if (sink_radiation) then write(iwritein,"(/,a)") '# options controling radiation pressure from sink particles' call write_options_ptmass_radiation(iwritein) @@ -298,9 +299,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) call write_inopt(cv_type,'cv_type','how to get cv and mean mol weight (0=constant,1=mesa)',iwritein) endif endif - if (gr) call write_options_metric(iwritein) - call write_options_gravitationalwaves(iwritein) call write_options_boundary(iwritein) @@ -555,7 +554,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (.not.imatch .and. sink_radiation) then call read_options_ptmass_radiation(name,valstring,imatch,igotallprad,ierr) endif - if (.not.imatch) call read_options_nicil(name,valstring,imatch,igotallnonideal,ierr) + if (.not.imatch .and. mhd_nonideal) call read_options_nicil(name,valstring,imatch,igotallnonideal,ierr) if (.not.imatch) call read_options_eos(name,valstring,imatch,igotalleos,ierr) if (.not.imatch .and. maxvxyzu >= 4) call read_options_cooling(name,valstring,imatch,igotallcooling,ierr) if (.not.imatch) call read_options_damping(name,valstring,imatch,igotalldamping,ierr) @@ -681,10 +680,6 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (psidecayfac < 0.) call fatal(label,'stupid value for psidecayfac') if (psidecayfac > 2.) call warn(label,'psidecayfac set outside recommended range (0.1-2.0)') if (overcleanfac < 1.0) call warn(label,'overcleanfac less than 1') - if (hdivbbmax_max < overcleanfac) then - call warn(label,'Resetting hdivbbmax_max = overcleanfac') - hdivbbmax_max = overcleanfac - endif endif if (beta < 0.) call fatal(label,'beta < 0') if (beta > 4.) call warn(label,'very high beta viscosity set') diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 2de7b5a88..500ea70d6 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -22,11 +22,10 @@ module step_lf_global ! ! :Runtime parameters: None ! -! :Dependencies: boundary_dyn, chem, cons2prim, cons2primsolver, cooling, -! cooling_ism, damping, deriv, dim, dust_formation, eos, extern_gr, -! externalforces, growth, io, io_summary, krome_interface, metric_tools, -! mpiutils, options, part, porosity, ptmass, ptmass_radiation, timestep, -! timestep_ind, timestep_sts, timing, units +! :Dependencies: boundary_dyn, cons2prim, cons2primsolver, cooling, +! damping, deriv, dim, eos, extern_gr, growth, io, io_summary, +! metric_tools, mpiutils, options, part, porosity, substepping, timestep, +! timestep_ind, timestep_sts, timing ! use dim, only:maxp,maxvxyzu,do_radiation,ind_timesteps use part, only:vpred,Bpred,dustpred,ppred @@ -100,11 +99,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) dustfrac,dustevol,ddustevol,eos_vars,alphaind,nptmass,& dustprop,ddustprop,dustproppred,pxyzu,dens,metrics,ics,& filfac,filfacpred,mprev,filfacprev - use options, only:avdecayconst,alpha,ieos,alphamax,icooling + use options, only:avdecayconst,alpha,ieos,alphamax use deriv, only:derivs use timestep, only:dterr,bignumber,tolv use mpiutils, only:reduceall_mpi - use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,ibin_wake + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & + dsdt_ptmass,fsink_old,ibin_wake,dptmass use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax @@ -119,11 +119,13 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use cooling, only:ufloor,cooling_in_step use timing, only:increment_timer,get_timings,itimer_extf use growth, only:check_dustprop - use options, only:use_porosity + use options, only:use_porosity,icooling use porosity, only:get_filfac use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate + use substepping, only:substep,substep_gr, & + substep_sph_gr,substep_sph integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -169,9 +171,9 @@ 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) & + !$omp shared(dustprop,ddustprop,dustproppred,ufloor,icooling) & !$omp shared(mprev,filfacprev,filfac,use_porosity) & - !$omp shared(ibin,ibin_old,twas,timei,icooling) & + !$omp shared(ibin,ibin_old,twas,timei) & !$omp firstprivate(itype) & !$omp private(i,hdti) & !$omp reduction(+:nvfloorp) @@ -202,7 +204,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) 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 @@ -243,16 +245,17 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if ((iexternalforce > 0 .and. imetric /= imet_minkowski) .or. idamp > 0) then call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) call get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtextforce) - call step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,t) + call substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,t) else - call step_extern_sph_gr(dtsph,npart,xyzh,vxyzu,dens,pxyzu,metrics) + call substep_sph_gr(dtsph,npart,xyzh,vxyzu,dens,pxyzu,metrics) endif else if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then - call step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) + call substep(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& + dptmass,fsink_old,nbinmax,ibin_wake) else - call step_extern_sph(dtsph,npart,xyzh,vxyzu) + call substep_sph(dtsph,npart,xyzh,vxyzu) endif endif call get_timings(t2,tcpu2) @@ -272,7 +275,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) & !$omp shared(twas,timei) & !$omp shared(rad,drad,radpred)& !$omp private(hi,rhoi,tdecay1,source,ddenom,hdti) & @@ -476,7 +479,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + dti*fxyzu(:,i) else - if (icooling /= 9) then + if (icooling /= 9) then vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) else vxyzu(1:3,i) = vxyzu(1:3,i) + dti*fxyzu(1:3,i) @@ -501,14 +504,16 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) - elseif (icooling /= 9) then - vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) else - vxyzu(1:3,i) = vxyzu(1:3,i) + dti*fxyzu(1:3,i) + if (icooling /= 9) then + vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) + else + vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,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 nvfloorc = nvfloorc + 1 @@ -575,7 +580,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(2,i) = vyi vxyzu(3,i) = vzi !--this is the energy equation if non-isothermal - if (maxvxyzu >= 4 .and. icooling/=9) vxyzu(4,i) = eni + if (maxvxyzu >= 4 .and. icooling /= 9) vxyzu(4,i) = eni endif if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) + hdtsph*ddustprop(:,i) @@ -612,10 +617,10 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp parallel do default(none)& !$omp private(i) & !$omp shared(npart,hdtsph)& -!$omp shared(store_itype,vxyzu,fxyzu,vpred,iphase,icooling) & +!$omp shared(store_itype,vxyzu,fxyzu,vpred,iphase) & !$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(filfac,filfacpred,use_porosity,icooling) & !$omp shared(rad,drad,radpred) & !$omp firstprivate(itype) & !$omp schedule(static) @@ -653,10 +658,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! if (gr) then pxyzu(:,i) = pxyzu(:,i) - hdtsph*fxyzu(:,i) - elseif (icooling /= 9) then - vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) else - vxyzu(1:3,i) = vxyzu(1:3,i) - hdtsph*fxyzu(1:3,i) + if (icooling /= 9 ) then + vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) + else + vxyzu(1:3,i) = vxyzu(1:3,i) - hdtsph*fxyzu(1:3,i) + endif endif if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) - hdtsph*ddustprop(:,i) if (itype==igas) then @@ -715,851 +722,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) end subroutine step -subroutine step_extern_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) - use part, only:isdead_or_accreted,igas,massoftype,rhoh,eos_vars,igasP,& - ien_type,eos_vars,igamma,itemp - use cons2primsolver, only:conservative2primitive - use eos, only:ieos - use io, only:warning - use metric_tools, only:pack_metric - use timestep, only:xtol - real, intent(in) :: dt - integer, intent(in) :: npart - real, intent(inout) :: xyzh(:,:),dens(:),metrics(:,:,:,:) - real, intent(in) :: pxyzu(:,:) - real, intent(out) :: vxyzu(:,:) - integer, parameter :: nitermax = 50 - integer :: i,niter,ierr - real :: xpred(1:3),vold(1:3),diff - logical :: converged - real :: rhoi,pri,tempi,gammai - - !$omp parallel do default(none) & - !$omp shared(npart,xyzh,vxyzu,dens,dt,xtol) & - !$omp shared(pxyzu,metrics,ieos,massoftype,ien_type,eos_vars) & - !$omp private(i,niter,diff,xpred,vold,converged,ierr) & - !$omp private(pri,rhoi,tempi,gammai) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - - !-- unpack and compute values for initial guess in cons2prim - pri = eos_vars(igasP,i) - tempi = eos_vars(itemp,i) - gammai = eos_vars(igamma,i) - rhoi = rhoh(xyzh(4,i),massoftype(igas)) - - call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),& - pri,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_sph_gr (a)]','enthalpy did not converge',i=i) - ! - ! main position update - ! - xpred = xyzh(1:3,i) + dt*vxyzu(1:3,i) - vold = vxyzu(1:3,i) - converged = .false. - niter = 0 - do while (.not. converged .and. niter<=nitermax) - niter = niter + 1 - call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),& - pri,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_sph_gr (b)]','enthalpy did not converge',i=i) - xyzh(1:3,i) = xpred + 0.5*dt*(vxyzu(1:3,i)-vold) - diff = maxval(abs(xyzh(1:3,i)-xpred)/xpred) - if (diff < xtol) converged = .true. - ! UPDATE METRIC HERE - call pack_metric(xyzh(1:3,i),metrics(:,:,:,i)) - enddo - if (niter > nitermax) call warning('step_extern_sph_gr','Reached max number of x iterations. x_err ',val=diff) - - ! repack values - eos_vars(igasP,i) = pri - eos_vars(itemp,i) = tempi - eos_vars(igamma,i) = gammai - endif - enddo - !$omp end parallel do - -end subroutine step_extern_sph_gr - -subroutine step_extern_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) - use dim, only:maxptmass,maxp,maxvxyzu - 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 - use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete - use timestep, only:bignumber,C_force,xtol,ptol - use eos, only:equationofstate,ieos - use cons2primsolver,only:conservative2primitive - use extern_gr, only:get_grforce - use metric_tools, only:pack_metric,pack_metricderivs - use damping, only:calc_damp,apply_damp,idamp - integer, intent(in) :: npart,ntypes - real, intent(in) :: dtsph,time - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:),pxyzu(:,:),dens(:),metrics(:,:,:,:),metricderivs(:,:,:,:) - integer :: i,itype,nsubsteps,naccreted,its,ierr,nlive - real :: timei,t_end_step,hdt,pmassi - real :: dt,dtf,dtextforcenew,dtextforce_min - real :: pri,spsoundi,pondensi,tempi,gammai - real, save :: pprev(3),xyz_prev(3),fstar(3),vxyz_star(3),xyz(3),pxyz(3),vxyz(3),fexti(3) -!$omp threadprivate(pprev,xyz_prev,fstar,vxyz_star,xyz,pxyz,vxyz,fexti) - real :: x_err,pmom_err,accretedmass,damp_fac - ! real, save :: dmdt = 0. - logical :: last_step,done,converged,accreted - integer, parameter :: itsmax = 50 - integer :: pitsmax,xitsmax - real :: perrmax,xerrmax - real :: rhoi,hi,eni,uui,densi - - pitsmax = 0 - xitsmax = 0 - perrmax = 0. - xerrmax = 0. - -! -! determine whether or not to use substepping -! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - - timei = time - itype = igas - pmassi = massoftype(igas) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - substeps: do while (timei <= t_end_step .and. .not.done) - hdt = 0.5*dt - timei = timei + dt - nsubsteps = nsubsteps + 1 - dtextforcenew = bignumber - - call calc_damp(time, damp_fac) - - if (.not.last_step .and. iverbose > 1 .and. id==master) then - write(iprint,"(a,f14.6)") '> external forces only : t=',timei - endif - !--------------------------- - ! predictor during substeps - !--------------------------- - ! - ! predictor step for external forces, also recompute external forces - ! - !$omp parallel do default(none) & - !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype) & - !$omp shared(maxphase,maxp,eos_vars) & - !$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) & - !$omp private(converged,pmom_err,x_err,pri,ierr,gammai) & - !$omp firstprivate(pmassi,itype) & - !$omp reduction(max:xitsmax,pitsmax,perrmax,xerrmax) & - !$omp reduction(min:dtextforcenew) - predictor: do i=1,npart - xyz(1) = xyzh(1,i) - xyz(2) = xyzh(2,i) - xyz(3) = xyzh(3,i) - hi = xyzh(4,i) - if (.not.isdead_or_accreted(hi)) then - if (ntypes > 1 .and. maxphase==maxp) then - itype = iamtype(iphase(i)) - pmassi = massoftype(itype) - endif - - its = 0 - converged = .false. - ! - ! make local copies of array quantities - ! - pxyz(1:3) = pxyzu(1:3,i) - eni = pxyzu(4,i) - vxyz(1:3) = vxyzu(1:3,i) - uui = vxyzu(4,i) - fexti = fext(:,i) - - pxyz = pxyz + hdt*fexti - - !-- unpack thermo variables for the first guess in cons2prim - densi = dens(i) - pri = eos_vars(igasP,i) - gammai = eos_vars(igamma,i) - tempi = eos_vars(itemp,i) - rhoi = rhoh(hi,massoftype(igas)) - - ! Note: grforce needs derivatives of the metric, - ! which do not change between pmom iterations - pmom_iterations: do while (its <= itsmax .and. .not. converged) - its = its + 1 - pprev = pxyz - call conservative2primitive(xyz,metrics(:,:,:,i),vxyz,densi,uui,pri,& - tempi,gammai,rhoi,pxyz,eni,ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (a)]','enthalpy did not converge',i=i) - call get_grforce(xyzh(:,i),metrics(:,:,:,i),metricderivs(:,:,:,i),vxyz,densi,uui,pri,fstar) - pxyz = pprev + hdt*(fstar - fexti) - pmom_err = maxval(abs(pxyz - pprev)) - if (pmom_err < ptol) converged = .true. - fexti = fstar - enddo pmom_iterations - if (its > itsmax ) call warning('step_extern_gr',& - 'max # of pmom iterations',var='pmom_err',val=pmom_err) - pitsmax = max(its,pitsmax) - perrmax = max(pmom_err,perrmax) - - call conservative2primitive(xyz,metrics(:,:,:,i),vxyz,densi,uui,pri,tempi,& - gammai,rhoi,pxyz,eni,ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (b)]','enthalpy did not converge',i=i) - xyz = xyz + dt*vxyz - call pack_metric(xyz,metrics(:,:,:,i)) - - its = 0 - converged = .false. - vxyz_star = vxyz - ! Note: since particle positions change between iterations - ! the metric and its derivatives need to be updated. - ! cons2prim does not require derivatives of the metric, - ! so those can updated once the iterations are complete - ! in order to reduce the number of computations. - xyz_iterations: do while (its <= itsmax .and. .not. converged) - its = its+1 - xyz_prev = xyz - call conservative2primitive(xyz,metrics(:,:,:,i),vxyz_star,densi,uui,& - pri,tempi,gammai,rhoi,pxyz,eni,ierr,ien_type) - if (ierr > 0) call warning('cons2primsolver [in step_extern_gr (c)]','enthalpy did not converge',i=i) - xyz = xyz_prev + hdt*(vxyz_star - vxyz) - x_err = maxval(abs(xyz-xyz_prev)) - if (x_err < xtol) converged = .true. - vxyz = vxyz_star - ! UPDATE METRIC HERE - call pack_metric(xyz,metrics(:,:,:,i)) - enddo xyz_iterations - call pack_metricderivs(xyz,metricderivs(:,:,:,i)) - if (its > itsmax ) call warning('step_extern_gr','Reached max number of x iterations. x_err ',val=x_err) - xitsmax = max(its,xitsmax) - xerrmax = max(x_err,xerrmax) - - ! re-pack arrays back where they belong - xyzh(1:3,i) = xyz(1:3) - pxyzu(1:3,i) = pxyz(1:3) - vxyzu(1:3,i) = vxyz(1:3) - vxyzu(4,i) = uui - fext(:,i) = fexti - dens(i) = densi - eos_vars(igasP,i) = pri - eos_vars(itemp,i) = tempi - eos_vars(igamma,i) = gammai - - ! Skip remainder of update if boundary particle; note that fext==0 for these particles - if (iamboundary(itype)) cycle predictor - endif - enddo predictor - !$omp end parallel do - - if (iverbose >= 2 .and. id==master) then - write(iprint,*) '------ Iterations summary: -------------------------------' - write(iprint,"(a,i2,a,f14.6)") 'Most pmom iterations = ',pitsmax,' | max error = ',perrmax - write(iprint,"(a,i2,a,f14.6)") 'Most xyz iterations = ',xitsmax,' | max error = ',xerrmax - write(iprint,*) - endif - - ! - ! corrector step on gas particles (also accrete particles at end of step) - ! - accretedmass = 0. - naccreted = 0 - nlive = 0 - 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 private(i,accreted) & - !$omp shared(ieos,dens,pxyzu,iexternalforce,C_force) & - !$omp private(pri,pondensi,spsoundi,tempi,dtf) & - !$omp firstprivate(itype,pmassi) & - !$omp reduction(min:dtextforce_min) & - !$omp reduction(+:accretedmass,naccreted,nlive) & - !$omp shared(idamp,damp_fac) - !$omp do - accreteloop: do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - if (ntypes > 1 .and. maxphase==maxp) then - itype = iamtype(iphase(i)) - pmassi = massoftype(itype) - ! if (itype==iboundary) cycle accreteloop - 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) - dtextforce_min = min(dtextforce_min,C_force*dtf) - - if (idamp > 0) then - call apply_damp(fext(1,i), fext(2,i), fext(3,i), vxyzu(1:3,i), xyzh(1:3,i), damp_fac) - endif - - ! - ! correct v to the full step using only the external force - ! - pxyzu(1:3,i) = pxyzu(1:3,i) + hdt*fext(1:3,i) - ! Do we need call cons2prim here ?? - - if (iexternalforce > 0) then - call accrete_particles(iexternalforce,xyzh(1,i),xyzh(2,i), & - xyzh(3,i),xyzh(4,i),pmassi,timei,accreted,i) - if (accreted) then - accretedmass = accretedmass + pmassi - naccreted = naccreted + 1 - endif - endif - nlive = nlive + 1 - endif - enddo accreteloop - !$omp enddo - !$omp end parallel - - if (npart > 2 .and. nlive < 2) then - call fatal('step','all particles accreted',var='nlive',ival=nlive) - endif - - if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a)") & - 'Step: at time ',timei,', ',naccreted,' particles were accreted. Mass accreted = ',accretedmass - - dtextforcenew = min(dtextforce_min,dtextforcenew) - dtextforce = dtextforcenew - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - - enddo substeps - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - -end subroutine step_extern_gr - -!---------------------------------------------------------------- -!+ -! This is the equivalent of the routine below when no external -! forces, sink particles or cooling are used -!+ -!---------------------------------------------------------------- -subroutine step_extern_sph(dt,npart,xyzh,vxyzu) - use part, only:isdead_or_accreted - real, intent(in) :: dt - integer, intent(in) :: npart - real, intent(inout) :: xyzh(:,:) - real, intent(in) :: vxyzu(:,:) - integer :: i - - !$omp parallel do default(none) & - !$omp shared(npart,xyzh,vxyzu,dt) & - !$omp private(i) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - ! - ! main position update - ! - xyzh(1,i) = xyzh(1,i) + dt*vxyzu(1,i) - xyzh(2,i) = xyzh(2,i) + dt*vxyzu(2,i) - xyzh(3,i) = xyzh(3,i) + dt*vxyzu(3,i) - endif - enddo - !$omp end parallel do - -end subroutine step_extern_sph - -!---------------------------------------------------------------- -!+ -! Substepping of external and sink particle forces. -! Also updates position of all particles even if no external -! forces applied. This is the internal loop of the RESPA -! algorithm over the "fast" forces. -!+ -!---------------------------------------------------------------- -subroutine step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,time,nptmass, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) - use dim, only:maxptmass,maxp,maxvxyzu,store_dust_temperature,use_krome,itau_alloc,& - do_nucleation,update_muGamma,h2chemistry - use io, only:iverbose,id,master,iprint,warning,fatal - use externalforces, only:externalforce,accrete_particles,update_externalforce, & - update_vdependent_extforce_leapfrog,is_velocity_dependent - use ptmass, only:ptmass_predictor,ptmass_corrector,ptmass_accrete, & - get_accel_sink_gas,get_accel_sink_sink,merge_sinks,f_acc,pt_write_sinkev, & - idxmsi,idymsi,idzmsi,idmsi,idspinxsi,idspinysi,idspinzsi, & - idvxmsi,idvymsi,idvzmsi,idfxmsi,idfymsi,idfzmsi, & - ndptmass,update_ptmass - use options, only:iexternalforce,icooling - use part, only:maxphase,abundance,nabundances,eos_vars,epot_sinksink,eos_vars,& - isdead_or_accreted,iamboundary,igas,iphase,iamtype,massoftype,rhoh,divcurlv, & - fxyz_ptmass_sinksink,dsdt_ptmass_sinksink,dust_temp,tau,& - nucleation,idK2,idmu,idkappa,idgamma,imu,igamma - use chem, only:update_abundances,get_dphot - use cooling_ism, only:dphot0,energ_cooling_ism,dphotflag,abundsi,abundo,abunde,abundc,nabn - use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete,summary_accrete_fail - use timestep, only:bignumber,C_force - use timestep_sts, only:sts_it_n - use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi - use damping, only:calc_damp,apply_damp,idamp - use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation - use cooling, only:energ_cooling,cooling_in_step - use dust_formation, only:evolve_dust,calc_muGamma - use units, only:unit_density -#ifdef KROME - use part, only: T_gas_cool - use krome_interface, only: update_krome -#endif - integer, intent(in) :: npart,ntypes,nptmass - real, intent(in) :: dtsph,time - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:),fxyzu(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - integer(kind=1), intent(in) :: nbinmax - integer(kind=1), intent(inout) :: ibin_wake(:) - integer :: i,itype,nsubsteps,naccreted,nfail,nfaili,merge_n,nlive - integer :: merge_ij(nptmass) - integer(kind=1) :: ibin_wakei - real :: timei,hdt,fextx,fexty,fextz,fextxi,fextyi,fextzi,phii,pmassi - real :: dtphi2,dtphi2i,vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi - real :: dudtcool,fextv(3),poti,ui,rhoi,mui,gammai,ph,ph_tot - real :: dt,dtextforcenew,dtsinkgas,fonrmax,fonrmaxi - real :: dtf,accretedmass,t_end_step,dtextforce_min - real, allocatable :: dptmass(:,:) ! dptmass(ndptmass,nptmass) - real :: damp_fac,dphot - real, save :: dmdt = 0. - real :: abundi(nabn),gmwvar - logical :: accreted,extf_is_velocity_dependent - logical :: last_step,done - - -! -! determine whether or not to use substepping -! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - - timei = time - extf_is_velocity_dependent = is_velocity_dependent(iexternalforce) - accretedmass = 0. - itype = igas - pmassi = massoftype(igas) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - ! allocate memory for dptmass array (avoids ifort bug) - allocate(dptmass(ndptmass,nptmass)) - - substeps: do while (timei <= t_end_step .and. .not.done) - hdt = 0.5*dt - timei = timei + dt - if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) - nsubsteps = nsubsteps + 1 - dtextforcenew = bignumber - dtsinkgas = bignumber - dtphi2 = bignumber - - call calc_damp(time, damp_fac) - - if (.not.last_step .and. iverbose > 1 .and. id==master) then - write(iprint,"(a,f14.6)") '> external/ptmass forces only : t=',timei - endif - ! - ! update time-dependent external forces - ! - call update_externalforce(iexternalforce,timei,dmdt) - - !--------------------------- - ! predictor during substeps - !--------------------------- - ! - ! point mass predictor step - ! - if (nptmass > 0) then - if (id==master) then - call ptmass_predictor(nptmass,dt,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - ! - ! get sink-sink forces (and a new sink-sink timestep. Note: fxyz_ptmass is zeroed in this subroutine) - ! pass sink-sink forces to variable fxyz_ptmass_sinksink for later writing. - ! - if (iexternalforce==14) call update_externalforce(iexternalforce,timei,dmdt) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - endif - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf - else - fxyz_ptmass(:,:) = 0. - dsdt_ptmass(:,:) = 0. - endif - call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) - call bcast_mpi(vxyz_ptmass(:,1:nptmass)) - call bcast_mpi(epot_sinksink) - call bcast_mpi(dtf) - dtextforcenew = min(dtextforcenew,C_force*dtf) - endif - - ! - ! predictor step for sink-gas and external forces, also recompute sink-gas and external forces - ! - fonrmax = 0. - !$omp parallel default(none) & - !$omp shared(maxp,maxphase) & - !$omp shared(npart,xyzh,vxyzu,fext,abundance,iphase,ntypes,massoftype,fxyzu) & - !$omp shared(eos_vars,dust_temp,store_dust_temperature) & - !$omp shared(dt,hdt,timei,iexternalforce,extf_is_velocity_dependent,cooling_in_step,icooling) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,idamp,damp_fac) & - !$omp shared(nptmass,nsubsteps,C_force,divcurlv,dphotflag,dphot0) & - !$omp shared(abundc,abundo,abundsi,abunde) & - !$omp shared(nucleation,do_nucleation,update_muGamma,h2chemistry,unit_density) & - !$omp private(dphot,abundi,gmwvar,ph,ph_tot) & - !$omp private(ui,rhoi, mui, gammai) & - !$omp private(i,dudtcool,fxi,fyi,fzi,phii) & - !$omp private(fextx,fexty,fextz,fextxi,fextyi,fextzi,poti,fextv,accreted) & - !$omp private(fonrmaxi,dtphi2i,dtf) & - !$omp private(vxhalfi,vyhalfi,vzhalfi) & - !$omp firstprivate(pmassi,itype) & -#ifdef KROME - !$omp shared(T_gas_cool) & -#endif - !$omp reduction(+:accretedmass) & - !$omp reduction(min:dtextforcenew,dtsinkgas,dtphi2) & - !$omp reduction(max:fonrmax) & - !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) - !$omp do - predictor: do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - if (ntypes > 1 .and. maxphase==maxp) then - itype = iamtype(iphase(i)) - pmassi = massoftype(itype) - endif - ! - ! predict v to the half step - ! - vxyzu(1:3,i) = vxyzu(1:3,i) + hdt*fext(1:3,i) - ! - ! main position update - ! - xyzh(1,i) = xyzh(1,i) + dt*vxyzu(1,i) - xyzh(2,i) = xyzh(2,i) + dt*vxyzu(2,i) - xyzh(3,i) = xyzh(3,i) + dt*vxyzu(3,i) - ! - ! Skip remainder of update if boundary particle; note that fext==0 for these particles - if (iamboundary(itype)) cycle predictor - ! - ! compute and add sink-gas force - ! - fextx = 0. - fexty = 0. - fextz = 0. - if (nptmass > 0) then - call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),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 - ! - ! compute and add external forces - ! - if (iexternalforce > 0) then - call externalforce(iexternalforce,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i), & - timei,fextxi,fextyi,fextzi,poti,dtf,i) - dtextforcenew = min(dtextforcenew,C_force*dtf) - - fextx = fextx + fextxi - fexty = fexty + fextyi - fextz = fextz + fextzi - ! - ! Velocity-dependent external forces require special handling - ! in leapfrog (corrector is implicit) - ! - if (extf_is_velocity_dependent) then - vxhalfi = vxyzu(1,i) - vyhalfi = vxyzu(2,i) - vzhalfi = vxyzu(3,i) - fxi = fextx - fyi = fexty - fzi = fextz - call update_vdependent_extforce_leapfrog(iexternalforce,& - vxhalfi,vyhalfi,vzhalfi, & - fxi,fyi,fzi,fextv,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i)) - fextx = fextx + fextv(1) - fexty = fexty + fextv(2) - fextz = fextz + fextv(3) - endif - endif - if (idamp > 0) then - call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), xyzh(1:3,i), damp_fac) - endif - fext(1,i) = fextx - fext(2,i) = fexty - fext(3,i) = fextz - - if (maxvxyzu >= 4 .and. itype==igas) then - ! NOTE: The chemistry and cooling here is implicitly calculated. That is, - ! dt is *passed in* to the chemistry & cooling routines so that the - ! output will be at the correct time of time + dt. Since this is - ! implicit, there is no cooling timestep. Explicit cooling is - ! calculated in force and requires a cooling timestep. - - dudtcool = 0. - rhoi = rhoh(xyzh(4,i),pmassi) - ! - ! CHEMISTRY - ! - if (h2chemistry) then - ! - ! Get updated abundances of all species, updates 'chemarrays', - ! - dphot = get_dphot(dphotflag,dphot0,xyzh(1,i),xyzh(2,i),xyzh(3,i)) - call update_abundances(vxyzu(4,i),rhoi,abundance(:,i),nabundances,& - dphot,dt,abundi,nabn,eos_vars(imu,i),abundc,abunde,abundo,abundsi) - endif -#ifdef KROME - ! evolve chemical composition and determine new internal energy - ! Krome also computes cooling function but only associated with chemical processes - ui = vxyzu(4,i) - call update_krome(dt,xyzh(:,i),ui,rhoi,abundance(:,i),eos_vars(igamma,i),eos_vars(imu,i),T_gas_cool(i)) - dudtcool = (ui-vxyzu(4,i))/dt -#else - !evolve dust chemistry and compute dust cooling - if (do_nucleation) then - call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) - eos_vars(imu,i) = nucleation(idmu,i) - eos_vars(igamma,i) = nucleation(idgamma,i) - endif - ! - ! COOLING - ! - if (icooling > 0 .and. cooling_in_step) then - if (h2chemistry) then - ! - ! Call cooling routine, requiring total density, some distance measure and - ! abundances in the 'abund' format - ! - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i),abund_in=abundi) - elseif (store_dust_temperature) then - ! cooling with stored dust temperature - if (do_nucleation) then - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) - elseif (update_muGamma) then - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& - dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i)) - 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 - 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,dudti_sph=fxyzu(4,i),part_id=i) - endif - endif -#endif - ! update internal energy - if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool - endif - endif - enddo predictor - !$omp enddo - !$omp end parallel - - if (nptmass > 0 .and. isink_radiation > 0) then - if (itau_alloc == 1) then - call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) - else - call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext) - endif - endif - - ! - ! reduction of sink-gas forces from each MPI thread - ! - if (nptmass > 0) then - call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) - endif - !--------------------------- - ! corrector during substeps - !--------------------------- - ! - ! corrector step on sinks (changes velocities only, does not change position) - ! - if (nptmass > 0) then - if (id==master) then - call ptmass_corrector(nptmass,dt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass,iexternalforce) - endif - call bcast_mpi(vxyz_ptmass(:,1:nptmass)) - endif - - ! - ! corrector step on gas particles (also accrete particles at end of step) - ! - accretedmass = 0. - nfail = 0 - naccreted = 0 - nlive = 0 - ibin_wakei = 0 - dptmass(:,:) = 0. - - !$omp parallel default(none) & - !$omp shared(maxp,maxphase) & - !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype,hdt,timei,nptmass,sts_it_n) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & - !$omp shared(iexternalforce) & - !$omp shared(nbinmax,ibin_wake) & - !$omp reduction(+:dptmass) & - !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & - !$omp firstprivate(itype,pmassi,ibin_wakei) & - !$omp reduction(+:accretedmass,nfail,naccreted,nlive) - !$omp do - accreteloop: do i=1,npart - 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 - endif - ! - ! correct v to the full step using only the external force - ! - vxyzu(1:3,i) = vxyzu(1:3,i) + hdt*fext(1:3,i) - - if (iexternalforce > 0) then - call accrete_particles(iexternalforce,xyzh(1,i),xyzh(2,i), & - xyzh(3,i),xyzh(4,i),pmassi,timei,accreted) - if (accreted) accretedmass = accretedmass + pmassi - endif - ! - ! accretion onto sink particles - ! need position, velocities and accelerations of both gas and sinks to be synchronised, - ! otherwise will not conserve momentum - ! Note: requiring sts_it_n since this is supertimestep with the most active particles - ! - if (nptmass > 0 .and. sts_it_n) then - fxi = fext(1,i) - fyi = fext(2,i) - fzi = fext(3,i) - if (ind_timesteps) ibin_wakei = ibin_wake(i) - - call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxi,fyi,fzi,& - itype,pmassi,xyzmh_ptmass,vxyz_ptmass,& - accreted,dptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) - if (accreted) then - naccreted = naccreted + 1 - cycle accreteloop - else - if (ind_timesteps) ibin_wake(i) = ibin_wakei - endif - if (nfaili > 1) nfail = nfail + 1 - endif - nlive = nlive + 1 - endif - enddo accreteloop - !$omp enddo - !$omp end parallel - - if (npart > 2 .and. nlive < 2) then - call fatal('step','all particles accreted',var='nlive',ival=nlive) - endif - - ! - ! reduction of sink particle changes across MPI - ! - if (nptmass > 0) then - call reduce_in_place_mpi('+',dptmass(:,1:nptmass)) - - naccreted = int(reduceall_mpi('+',naccreted)) - nfail = int(reduceall_mpi('+',nfail)) - - if (id==master) call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) - - call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) - call bcast_mpi(vxyz_ptmass(:,1:nptmass)) - call bcast_mpi(fxyz_ptmass(:,1:nptmass)) - endif - - if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a,i4,a)") & - 'Step: at time ',timei,', ',naccreted,' particles were accreted amongst ',nptmass,' sink(s).' - - if (nptmass > 0) then - call summary_accrete_fail(nfail) - call summary_accrete(nptmass) - ! only write to .ev during substeps if no gas particles present - if (npart==0) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & - fxyz_ptmass,fxyz_ptmass_sinksink) - endif - ! - ! check if timestep criterion was violated during substeps - ! - if (nptmass > 0) then - if (fonrmax > 0.) then - dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) - endif - if (iverbose >= 2) write(iprint,*) nsubsteps,'dt(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas - dtextforcenew = min(dtextforcenew,dtsinkgas) - endif - - dtextforcenew = reduceall_mpi('min',dtextforcenew) - - dtextforce_min = min(dtextforce_min,dtextforcenew) - dtextforce = dtextforcenew - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - enddo substeps - - deallocate(dptmass) - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - -end subroutine step_extern - !----------------------------------------------------- !+ ! Check error in v^1 compared to the predicted v^* diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 new file mode 100644 index 000000000..a3f9cd3f5 --- /dev/null +++ b/src/main/substepping.F90 @@ -0,0 +1,1126 @@ +!--------------------------------------------------------------------------! +! 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 substepping +! +! Computes sub-steps in the RESPA algorithm +! +! Multiple option of sub stepping can be choosed depending on +! the physics and the precision needed +! +! Only Hydro : substep_sph +! Hydro + GR : substep_sph_gr substep_gr +! 2nd order with all fast physics implemented : substep (use_fourthorder = false) +! 4th order without vdep forces and oblateness : substep (not yet implemented) +! +! :References: +! Verlet (1967), Phys. Rev. 159, 98-103 +! Tuckerman, Berne & Martyna (1992), J. Chem. Phys. 97, 1990-2001 +! Rantala + (2020) (2023),Chin (2007a) +! +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: chem, cons2primsolver, cooling, cooling_ism, damping, dim, +! dust_formation, eos, extern_gr, externalforces, io, io_summary, +! krome_interface, metric_tools, mpiutils, options, part, ptmass, +! ptmass_radiation, timestep, timestep_sts +! + implicit none + + public :: substep_gr + public :: substep_sph + public :: substep_sph_gr + public :: substep + + private + +contains + +subroutine substep_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) + use part, only:isdead_or_accreted,igas,massoftype,rhoh,eos_vars,igasP,& + ien_type,eos_vars,igamma,itemp + use cons2primsolver, only:conservative2primitive + use eos, only:ieos + use io, only:warning + use metric_tools, only:pack_metric + use timestep, only:xtol + real, intent(in) :: dt + integer, intent(in) :: npart + real, intent(inout) :: xyzh(:,:),dens(:),metrics(:,:,:,:) + real, intent(in) :: pxyzu(:,:) + real, intent(out) :: vxyzu(:,:) + integer, parameter :: nitermax = 50 + integer :: i,niter,ierr + real :: xpred(1:3),vold(1:3),diff + logical :: converged + real :: rhoi,pri,tempi,gammai + + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,vxyzu,dens,dt,xtol) & + !$omp shared(pxyzu,metrics,ieos,massoftype,ien_type,eos_vars) & + !$omp private(i,niter,diff,xpred,vold,converged,ierr) & + !$omp private(pri,rhoi,tempi,gammai) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + + !-- unpack and compute values for initial guess in cons2prim + pri = eos_vars(igasP,i) + tempi = eos_vars(itemp,i) + gammai = eos_vars(igamma,i) + rhoi = rhoh(xyzh(4,i),massoftype(igas)) + + call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),& + pri,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) + if (ierr > 0) call warning('cons2primsolver [in substep_sph_gr (a)]','enthalpy did not converge',i=i) + ! + ! main position update + ! + xpred = xyzh(1:3,i) + dt*vxyzu(1:3,i) + vold = vxyzu(1:3,i) + converged = .false. + niter = 0 + do while (.not. converged .and. niter<=nitermax) + niter = niter + 1 + call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),& + pri,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) + if (ierr > 0) call warning('cons2primsolver [in substep_sph_gr (b)]','enthalpy did not converge',i=i) + xyzh(1:3,i) = xpred + 0.5*dt*(vxyzu(1:3,i)-vold) + diff = maxval(abs(xyzh(1:3,i)-xpred)/xpred) + if (diff < xtol) converged = .true. + ! UPDATE METRIC HERE + call pack_metric(xyzh(1:3,i),metrics(:,:,:,i)) + enddo + if (niter > nitermax) call warning('substep_sph_gr','Reached max number of x iterations. x_err ',val=diff) + + ! repack values + eos_vars(igasP,i) = pri + eos_vars(itemp,i) = tempi + eos_vars(igamma,i) = gammai + endif + enddo + !$omp end parallel do + +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 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 + use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete + use timestep, only:bignumber,C_force,xtol,ptol + use eos, only:equationofstate,ieos + use cons2primsolver,only:conservative2primitive + use extern_gr, only:get_grforce + use metric_tools, only:pack_metric,pack_metricderivs + use damping, only:calc_damp,apply_damp,idamp + integer, intent(in) :: npart,ntypes + real, intent(in) :: dtsph,time + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:),pxyzu(:,:),dens(:),metrics(:,:,:,:),metricderivs(:,:,:,:) + integer :: i,itype,nsubsteps,naccreted,its,ierr,nlive + real :: timei,t_end_step,hdt,pmassi + real :: dt,dtf,dtextforcenew,dtextforce_min + real :: pri,spsoundi,pondensi,tempi,gammai + real, save :: pprev(3),xyz_prev(3),fstar(3),vxyz_star(3),xyz(3),pxyz(3),vxyz(3),fexti(3) + !$omp threadprivate(pprev,xyz_prev,fstar,vxyz_star,xyz,pxyz,vxyz,fexti) + real :: x_err,pmom_err,accretedmass,damp_fac + ! real, save :: dmdt = 0. + logical :: last_step,done,converged,accreted + integer, parameter :: itsmax = 50 + integer :: pitsmax,xitsmax + real :: perrmax,xerrmax + real :: rhoi,hi,eni,uui,densi + + pitsmax = 0 + xitsmax = 0 + perrmax = 0. + xerrmax = 0. + + ! + ! determine whether or not to use substepping + ! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + + timei = time + itype = igas + pmassi = massoftype(igas) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + substeps: do while (timei <= t_end_step .and. .not.done) + hdt = 0.5*dt + timei = timei + dt + nsubsteps = nsubsteps + 1 + dtextforcenew = bignumber + + call calc_damp(time, damp_fac) + + if (.not.last_step .and. iverbose > 1 .and. id==master) then + write(iprint,"(a,f14.6)") '> external forces only : t=',timei + endif + !--------------------------- + ! predictor during substeps + !--------------------------- + ! + ! predictor step for external forces, also recompute external forces + ! + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype) & + !$omp shared(maxphase,maxp,eos_vars) & + !$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) & + !$omp private(converged,pmom_err,x_err,pri,ierr,gammai) & + !$omp firstprivate(pmassi,itype) & + !$omp reduction(max:xitsmax,pitsmax,perrmax,xerrmax) & + !$omp reduction(min:dtextforcenew) + predictor: do i=1,npart + xyz(1) = xyzh(1,i) + xyz(2) = xyzh(2,i) + xyz(3) = xyzh(3,i) + hi = xyzh(4,i) + if (.not.isdead_or_accreted(hi)) then + if (ntypes > 1 .and. maxphase==maxp) then + itype = iamtype(iphase(i)) + pmassi = massoftype(itype) + endif + + its = 0 + converged = .false. + ! + ! make local copies of array quantities + ! + pxyz(1:3) = pxyzu(1:3,i) + eni = pxyzu(4,i) + vxyz(1:3) = vxyzu(1:3,i) + uui = vxyzu(4,i) + fexti = fext(:,i) + + pxyz = pxyz + hdt*fexti + + !-- unpack thermo variables for the first guess in cons2prim + densi = dens(i) + pri = eos_vars(igasP,i) + gammai = eos_vars(igamma,i) + tempi = eos_vars(itemp,i) + rhoi = rhoh(hi,massoftype(igas)) + + ! Note: grforce needs derivatives of the metric, + ! which do not change between pmom iterations + pmom_iterations: do while (its <= itsmax .and. .not. converged) + its = its + 1 + pprev = pxyz + call conservative2primitive(xyz,metrics(:,:,:,i),vxyz,densi,uui,pri,& + tempi,gammai,rhoi,pxyz,eni,ierr,ien_type) + if (ierr > 0) call warning('cons2primsolver [in substep_gr (a)]','enthalpy did not converge',i=i) + call get_grforce(xyzh(:,i),metrics(:,:,:,i),metricderivs(:,:,:,i),vxyz,densi,uui,pri,fstar) + pxyz = pprev + hdt*(fstar - fexti) + pmom_err = maxval(abs(pxyz - pprev)) + if (pmom_err < ptol) converged = .true. + fexti = fstar + enddo pmom_iterations + if (its > itsmax ) call warning('substep_gr',& + 'max # of pmom iterations',var='pmom_err',val=pmom_err) + pitsmax = max(its,pitsmax) + perrmax = max(pmom_err,perrmax) + + call conservative2primitive(xyz,metrics(:,:,:,i),vxyz,densi,uui,pri,tempi,& + gammai,rhoi,pxyz,eni,ierr,ien_type) + if (ierr > 0) call warning('cons2primsolver [in substep_gr (b)]','enthalpy did not converge',i=i) + xyz = xyz + dt*vxyz + call pack_metric(xyz,metrics(:,:,:,i)) + + its = 0 + converged = .false. + vxyz_star = vxyz + ! Note: since particle positions change between iterations + ! the metric and its derivatives need to be updated. + ! cons2prim does not require derivatives of the metric, + ! so those can updated once the iterations are complete + ! in order to reduce the number of computations. + xyz_iterations: do while (its <= itsmax .and. .not. converged) + its = its+1 + xyz_prev = xyz + call conservative2primitive(xyz,metrics(:,:,:,i),vxyz_star,densi,uui,& + pri,tempi,gammai,rhoi,pxyz,eni,ierr,ien_type) + if (ierr > 0) call warning('cons2primsolver [in substep_gr (c)]','enthalpy did not converge',i=i) + xyz = xyz_prev + hdt*(vxyz_star - vxyz) + x_err = maxval(abs(xyz-xyz_prev)) + if (x_err < xtol) converged = .true. + vxyz = vxyz_star + ! UPDATE METRIC HERE + call pack_metric(xyz,metrics(:,:,:,i)) + enddo xyz_iterations + call pack_metricderivs(xyz,metricderivs(:,:,:,i)) + if (its > itsmax ) call warning('substep_gr','Reached max number of x iterations. x_err ',val=x_err) + xitsmax = max(its,xitsmax) + xerrmax = max(x_err,xerrmax) + + ! re-pack arrays back where they belong + xyzh(1:3,i) = xyz(1:3) + pxyzu(1:3,i) = pxyz(1:3) + vxyzu(1:3,i) = vxyz(1:3) + vxyzu(4,i) = uui + fext(:,i) = fexti + dens(i) = densi + eos_vars(igasP,i) = pri + eos_vars(itemp,i) = tempi + eos_vars(igamma,i) = gammai + + ! Skip remainder of update if boundary particle; note that fext==0 for these particles + if (iamboundary(itype)) cycle predictor + endif + enddo predictor + !$omp end parallel do + + if (iverbose >= 2 .and. id==master) then + write(iprint,*) '------ Iterations summary: -------------------------------' + write(iprint,"(a,i2,a,f14.6)") 'Most pmom iterations = ',pitsmax,' | max error = ',perrmax + write(iprint,"(a,i2,a,f14.6)") 'Most xyz iterations = ',xitsmax,' | max error = ',xerrmax + write(iprint,*) + endif + + ! + ! corrector step on gas particles (also accrete particles at end of step) + ! + accretedmass = 0. + naccreted = 0 + nlive = 0 + 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 private(i,accreted) & + !$omp shared(ieos,dens,pxyzu,iexternalforce,C_force) & + !$omp private(pri,pondensi,spsoundi,tempi,dtf) & + !$omp firstprivate(itype,pmassi) & + !$omp reduction(min:dtextforce_min) & + !$omp reduction(+:accretedmass,naccreted,nlive) & + !$omp shared(idamp,damp_fac) + !$omp do + accreteloop: do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + if (ntypes > 1 .and. maxphase==maxp) then + itype = iamtype(iphase(i)) + pmassi = massoftype(itype) + ! if (itype==iboundary) cycle accreteloop + 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) + dtextforce_min = min(dtextforce_min,C_force*dtf) + + if (idamp > 0) then + call apply_damp(fext(1,i), fext(2,i), fext(3,i), vxyzu(1:3,i), xyzh(1:3,i), damp_fac) + endif + + ! + ! correct v to the full step using only the external force + ! + pxyzu(1:3,i) = pxyzu(1:3,i) + hdt*fext(1:3,i) + ! Do we need call cons2prim here ?? + + if (iexternalforce > 0) then + call accrete_particles(iexternalforce,xyzh(1,i),xyzh(2,i), & + xyzh(3,i),xyzh(4,i),pmassi,timei,accreted,i) + if (accreted) then + accretedmass = accretedmass + pmassi + naccreted = naccreted + 1 + endif + endif + nlive = nlive + 1 + endif + enddo accreteloop + !$omp enddo + !$omp end parallel + + if (npart > 2 .and. nlive < 2) then + call fatal('step','all particles accreted',var='nlive',ival=nlive) + endif + + if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a)") & + 'Step: at time ',timei,', ',naccreted,' particles were accreted. Mass accreted = ',accretedmass + + dtextforcenew = min(dtextforce_min,dtextforcenew) + dtextforce = dtextforcenew + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + + enddo substeps + + if (nsubsteps > 1) then + if (iverbose>=1 .and. id==master) then + write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + +end subroutine substep_gr + + !---------------------------------------------------------------- + !+ + ! This is the equivalent of the routine below when no external + ! forces, sink particles or cooling are used + !+ + !---------------------------------------------------------------- +subroutine substep_sph(dt,npart,xyzh,vxyzu) + use part, only:isdead_or_accreted + real, intent(in) :: dt + integer, intent(in) :: npart + real, intent(inout) :: xyzh(:,:) + real, intent(in) :: vxyzu(:,:) + integer :: i + + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,vxyzu,dt) & + !$omp private(i) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + ! + ! main position update + ! + xyzh(1,i) = xyzh(1,i) + dt*vxyzu(1,i) + xyzh(2,i) = xyzh(2,i) + dt*vxyzu(2,i) + xyzh(3,i) = xyzh(3,i) + dt*vxyzu(3,i) + endif + enddo + !$omp end parallel do + +end subroutine substep_sph + +!---------------------------------------------------------------- + !+ + ! Substepping of external and sink particle forces. + ! Also updates position of all particles even if no external + ! forces applied. This is the internal loop of the RESPA + ! algorithm over the "fast" forces. + ! (Here it can be FSI or Leapfrog) + !+ + !---------------------------------------------------------------- +subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & + fsink_old,nbinmax,ibin_wake) + use io, only:iverbose,id,master,iprint,fatal + use options, only:iexternalforce + use part, only:fxyz_ptmass_sinksink + use io_summary, only:summary_variable,iosumextr,iosumextt + use externalforces, only:is_velocity_dependent + use ptmass, only:use_fourthorder,ck,dk + integer, intent(in) :: npart,ntypes,nptmass + real, intent(in) :: dtsph,time + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + real, intent(inout) :: dptmass(:,:),fsink_old(:,:) + integer(kind=1), intent(in) :: nbinmax + integer(kind=1), intent(inout) :: ibin_wake(:) + logical :: extf_vdep_flag,done,last_step,accreted + integer :: force_count,nsubsteps + real :: timei,time_par,dt,t_end_step + real :: dtextforce_min +! +! determine whether or not to use substepping +! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + + timei = time + time_par = time + extf_vdep_flag = is_velocity_dependent(iexternalforce) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + + substeps: do while (timei <= t_end_step .and. .not.done) + force_count = 0 + timei = timei + dt + if (abs(dt) < tiny(0.)) call fatal('substepping','dt <= 0 in sink-gas substepping',var='dt',val=dt) + nsubsteps = nsubsteps + 1 + + if (.not.last_step .and. iverbose > 1 .and. id==master) then + write(iprint,"(a,f14.6)") '> external/ptmass forces only : t=',timei + endif +! +! Main integration scheme +! + call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + + 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) + + if (use_fourthorder) then !! FSI 4th order scheme + + ! FSI extrapolation method (Omelyan 2006) + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + ! the last kick phase of the scheme will perform the accretion loop after velocity update + call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + if (accreted) then + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + endif + + else !! standard leapfrog scheme + + ! the last kick phase of the scheme will perform the accretion loop after velocity update + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + 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) + endif + + endif + + dtextforce_min = min(dtextforce_min,dtextforce) + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + enddo substeps + + if (nsubsteps > 1) then + if (iverbose >=1 .and. id==master) then + write(iprint,"(a,i6,3(a,es10.3))") ' using ',nsubsteps,' substeps '//& + '(dthydro/dtextf =',dtsph/dtextforce_min,'), dt =',dtextforce_min,' dtsph =',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + +end subroutine substep + + + !---------------------------------------------------------------- + !+ + ! drift routine for the whole system (part and ptmass) + !+ + !---------------------------------------------------------------- + +subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + use part, only:isdead_or_accreted + use ptmass, only:ptmass_drift + 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(:,:) + real :: ckdt + integer :: i + + ckdt = cki*dt + + ! Drift gas particles + + !$omp parallel do default(none) & + !$omp shared(npart,xyzh,vxyzu,ckdt) & + !$omp private(i) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + xyzh(1,i) = xyzh(1,i) + ckdt*vxyzu(1,i) + xyzh(2,i) = xyzh(2,i) + ckdt*vxyzu(2,i) + xyzh(3,i) = xyzh(3,i) + ckdt*vxyzu(3,i) + endif + enddo + !$omp end parallel do + + ! Drift sink particles + if (nptmass>0) then + if (id==master) then + call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) + endif + call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) + endif + + time_par = time_par + ckdt !! update time for external potential in force routine + +end subroutine drift + + + !---------------------------------------------------------------- + !+ + ! kick routine for the whole system (part and ptmass) + !+ + !---------------------------------------------------------------- + +subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & + fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas + use 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 timestep_sts, only:sts_it_n + real, intent(in) :: dt,dki + integer, intent(in) :: npart,nptmass,ntypes + real, intent(inout) :: xyzh(:,:) + real, intent(inout) :: vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + real, optional, intent(inout) :: dptmass(:,:),fxyz_ptmass_sinksink(:,:) + real, optional, intent(in) :: timei + integer(kind=1), optional, intent(inout) :: ibin_wake(:) + integer(kind=1), optional, intent(in) :: nbinmax + logical , optional, intent(inout) :: accreted + integer(kind=1) :: ibin_wakei + logical :: is_accretion + integer :: i,itype,nfaili + integer :: naccreted,nfail,nlive + real :: dkdt,pmassi,fxi,fyi,fzi,accretedmass + + if (present(dptmass) .and. present(timei) .and. present(ibin_wake) .and. present(nbinmax)) then + is_accretion = .true. + else + is_accretion = .false. + endif + + itype = iphase(igas) + pmassi = massoftype(igas) + + dkdt = dki*dt + + ! Kick sink particles + if (nptmass>0) then + if (id==master) then + call ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass) + endif + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + call bcast_mpi(xyzmh_ptmass(ispinx,1:nptmass)) + call bcast_mpi(xyzmh_ptmass(ispiny,1:nptmass)) + call bcast_mpi(xyzmh_ptmass(ispinz,1:nptmass)) + endif + + + ! Kick gas particles + + if (.not.is_accretion) then + !$omp parallel do default(none) & + !$omp shared(maxp,maxphase) & + !$omp shared(iphase,ntypes) & + !$omp shared(npart,fext,xyzh,vxyzu,dkdt) & + !$omp firstprivate(itype) & + !$omp private(i) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + if (ntypes > 1 .and. maxphase==maxp) then + itype = iamtype(iphase(i)) + if (iamboundary(itype)) cycle + endif + vxyzu(1,i) = vxyzu(1,i) + dkdt*fext(1,i) + vxyzu(2,i) = vxyzu(2,i) + dkdt*fext(2,i) + vxyzu(3,i) = vxyzu(3,i) + dkdt*fext(3,i) + endif + enddo + !$omp end parallel do + + else + accretedmass = 0. + nfail = 0 + naccreted = 0 + nlive = 0 + ibin_wakei = 0 + dptmass(:,1:nptmass) = 0. + !$omp parallel default(none) & + !$omp shared(maxp,maxphase) & + !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & + !$omp shared(iexternalforce) & + !$omp shared(nbinmax,ibin_wake) & + !$omp reduction(+:dptmass) & + !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & + !$omp firstprivate(itype,pmassi,ibin_wakei) & + !$omp reduction(+:accretedmass,nfail,naccreted,nlive) + !$omp do + accreteloop: do i=1,npart + 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 + endif + ! + ! correct v to the full step using only the external force + ! + vxyzu(1,i) = vxyzu(1,i) + dkdt*fext(1,i) + vxyzu(2,i) = vxyzu(2,i) + dkdt*fext(2,i) + vxyzu(3,i) = vxyzu(3,i) + dkdt*fext(3,i) + + if (iexternalforce > 0) then + call accrete_particles(iexternalforce,xyzh(1,i),xyzh(2,i), & + xyzh(3,i),xyzh(4,i),pmassi,timei,accreted) + if (accreted) accretedmass = accretedmass + pmassi + endif + ! + ! accretion onto sink particles + ! need position, velocities and accelerations of both gas and sinks to be synchronised, + ! otherwise will not conserve momentum + ! Note: requiring sts_it_n since this is supertimestep with the most active particles + ! + if (nptmass > 0 .and. sts_it_n) then + fxi = fext(1,i) + fyi = fext(2,i) + fzi = fext(3,i) + if (ind_timesteps) ibin_wakei = ibin_wake(i) + + call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& + vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxi,fyi,fzi,& + itype,pmassi,xyzmh_ptmass,vxyz_ptmass,& + accreted,dptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) + if (accreted) then + naccreted = naccreted + 1 + cycle accreteloop + else + if (ind_timesteps) ibin_wake(i) = ibin_wakei + endif + if (nfaili > 1) nfail = nfail + 1 + endif + nlive = nlive + 1 + endif + enddo accreteloop + !$omp enddo + !$omp end parallel + + if (npart > 2 .and. nlive < 2) then + call fatal('step','all particles accreted',var='nlive',ival=nlive) + endif + +! +! reduction of sink particle changes across MPI +! + accreted = .false. + if (nptmass > 0) then + call reduce_in_place_mpi('+',dptmass(:,1:nptmass)) + + naccreted = int(reduceall_mpi('+',naccreted)) + nfail = int(reduceall_mpi('+',nfail)) + if (naccreted > 0) accreted = .true. + + if (id==master) call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) + + call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + call bcast_mpi(fxyz_ptmass(:,1:nptmass)) + endif + + if (iverbose >= 2 .and. id==master .and. naccreted /= 0) write(iprint,"(a,es10.3,a,i4,a,i4,a)") & + 'Step: at time ',timei,', ',naccreted,' particles were accreted amongst ',nptmass,' sink(s).' + + if (nptmass > 0) then + call summary_accrete_fail(nfail) + call summary_accrete(nptmass) + ! only write to .ev during substeps if no gas particles present + if (npart==0) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & + fxyz_ptmass,fxyz_ptmass_sinksink) + endif + endif + + +end subroutine kick + +!---------------------------------------------------------------- +!+ +! force routine for the whole system. First is computed the +! sink/sink interaction and extf on sink, then comes forces +! on gas. sink/gas, extf and dampening. Finally there is an +! update of abundances and temp depending on cooling method +! during the last force calculation of the substep. +!+ +!---------------------------------------------------------------- +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,fsink_old) + use io, only:iverbose,master,id,iprint,warning,fatal + use dim, only:maxp,maxvxyzu,itau_alloc + 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 + 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 + use damping, only:apply_damp,idamp,calc_damp + use externalforces, only:update_externalforce + use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation + integer, intent(in) :: nptmass,npart,nsubsteps,ntypes + integer, intent(inout) :: force_count + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) + real, intent(inout) :: dtextforce + real, intent(in) :: timei,dki,dt + logical, intent(in) :: extf_vdep_flag + real, optional, intent(inout) :: fsink_old(4,nptmass) + integer :: merge_ij(nptmass) + integer :: merge_n + integer :: i,itype + real, save :: dmdt = 0. + real :: dtf,dtextforcenew,dtsinkgas,dtphi2,fonrmax + real :: fextx,fexty,fextz,xi,yi,zi,pmassi,damp_fac + real :: fonrmaxi,phii,dtphi2i + real :: dkdt,extrapfac + logical :: extrap,last + + if (present(fsink_old)) then + fsink_old = fxyz_ptmass + extrap = .true. + else + extrap = .false. + endif + + force_count = force_count + 1 + extrapfac = (1./24.)*dt**2 + dkdt = dki*dt + itype = igas + pmassi = massoftype(igas) + dtextforcenew = bignumber + dtsinkgas = bignumber + dtphi2 = bignumber + fonrmax = 0 + last = (force_count == n_force_order) + + ! + ! update time-dependent external forces + ! + call calc_damp(timei, damp_fac) + call update_externalforce(iexternalforce,timei,dmdt) + ! + ! Sink-sink interactions (loop over ptmass in get_accel_sink_sink) + ! + if (nptmass > 0) then + if (id==master) then + if (extrap) then + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n, & + dsdt_ptmass,extrapfac,fsink_old) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n, & + dsdt_ptmass,extrapfac,fsink_old) + endif + else + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + endif + endif + else + fxyz_ptmass(:,:) = 0. + dsdt_ptmass(:,:) = 0. + endif + call bcast_mpi(epot_sinksink) + call bcast_mpi(dtf) + dtextforcenew = min(dtextforcenew,C_force*dtf) + endif + + ! + !-- Forces on gas particles (Sink/gas,extf,damp,cooling) + ! + + !$omp parallel default(none) & + !$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) & + !$omp shared(divcurlv,dphotflag,dphot0,nucleation,extrap) & + !$omp shared(abundc,abundo,abundsi,abunde,extrapfac,fsink_old) & + !$omp private(fextx,fexty,fextz,xi,yi,zi) & + !$omp private(i,fonrmaxi,dtphi2i,phii,dtf) & + !$omp firstprivate(pmassi,itype) & + !$omp reduction(min:dtextforcenew,dtphi2) & + !$omp reduction(max:fonrmax) & + !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) + !$omp do + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + if (ntypes > 1 .and. maxphase==maxp) then + itype = iamtype(iphase(i)) + pmassi = massoftype(itype) + endif + fextx = 0. + fexty = 0. + fextz = 0. + if (extrap) then + xi = xyzh(1,i) + extrapfac*fext(1,i) + yi = xyzh(2,i) + extrapfac*fext(2,i) + zi = xyzh(3,i) + extrapfac*fext(3,i) + else + xi = xyzh(1,i) + yi = xyzh(2,i) + zi = xyzh(3,i) + endif + if (nptmass > 0) then + 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 + endif + + ! + ! compute and add external forces + ! + 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) + endif + ! + ! damping + ! + if (idamp > 0) then + call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), (/xi,yi,zi/), damp_fac) + endif + + fext(1,i) = fextx + fext(2,i) = fexty + fext(3,i) = fextz + ! + ! temperature and abundances update (only done during the last force calculation of the substep) + ! + 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) + endif + endif + enddo + !$omp enddo + !$omp end parallel + + if (nptmass > 0 .and. isink_radiation > 0 .and. .not.extrap) then + if (itau_alloc == 1) then + call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) + else + call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext) + endif + endif + + if (nptmass > 0) then + call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) + call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + if (id==master .and. extf_vdep_flag) then + call ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,iexternalforce) + endif + endif + + if (last) then + if (nptmass > 0) then + if (fonrmax > 0.) then + dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) + endif + if (iverbose >= 2) write(iprint,*) nsubsteps,'dt(ext/sink-sink) = ',dtextforcenew,', dt(sink-gas) = ',dtsinkgas + dtextforcenew = min(dtextforcenew,dtsinkgas) + endif + + dtextforcenew = reduceall_mpi('min',dtextforcenew) + dtextforce = dtextforcenew + endif + +end subroutine get_force + +!----------------------------------------------------------------------------------- +!+ +! Update of abundances and internal energy using cooling method (see cooling module) +! NOTE: The chemistry and cooling here is implicitly calculated. That is, +! dt is *passed in* to the chemistry & cooling routines so that the +! output will be at the correct time of time + dt. Since this is +! implicit, there is no cooling timestep. Explicit cooling is +! calculated in force and requires a cooling timestep. +!+ +!------------------------------------------------------------------------------------ +subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0) + use dim, only:h2chemistry,do_nucleation,use_krome,update_muGamma,store_dust_temperature + use part, only:idK2,idmu,idkappa,idgamma,imu,igamma,nabundances + use cooling_ism, only:nabn,dphotflag + use options, only:icooling + use chem, only:update_abundances,get_dphot + use dust_formation, only:evolve_dust + use cooling, only:energ_cooling,cooling_in_step + use part, only:rhoh +#ifdef KROME + use part, only: T_gas_cool + use krome_interface, only: update_krome + real :: ui +#endif + real, intent(inout) :: vxyzu(:,:),xyzh(:,:) + real, intent(inout) :: eos_vars(:,:),abundance(:,:) + real, intent(inout) :: nucleation(:,:),dust_temp(:) + real(kind=4), intent(in) :: divcurlv(:,:) + real, intent(inout) :: abundc,abunde,abundo,abundsi + real(kind=8), intent(in) :: dphot0 + real, intent(in) :: dt,pmassi + integer, intent(in) :: i + + real :: dudtcool,rhoi,dphot + real :: abundi(nabn) + + dudtcool = 0. + rhoi = rhoh(xyzh(4,i),pmassi) + ! + ! CHEMISTRY + ! + if (h2chemistry) then + ! + ! Get updated abundances of all species, updates 'chemarrays', + ! + dphot = get_dphot(dphotflag,dphot0,xyzh(1,i),xyzh(2,i),xyzh(3,i)) + call update_abundances(vxyzu(4,i),rhoi,abundance(:,i),nabundances,& + dphot,dt,abundi,nabn,eos_vars(imu,i),abundc,abunde,abundo,abundsi) + endif +#ifdef KROME + ! evolve chemical composition and determine new internal energy + ! Krome also computes cooling function but only associated with chemical processes + ui = vxyzu(4,i) + call update_krome(dt,xyzh(:,i),ui,rhoi,abundance(:,i),eos_vars(igamma,i),eos_vars(imu,i),T_gas_cool(i)) + dudtcool = (ui-vxyzu(4,i))/dt +#else + !evolve dust chemistry and compute dust cooling + if (do_nucleation) then + call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) + eos_vars(imu,i) = nucleation(idmu,i) + eos_vars(igamma,i) = nucleation(idgamma,i) + endif + ! + ! COOLING + ! + if (icooling > 0 .and. cooling_in_step) then + if (h2chemistry) then + ! + ! Call cooling routine, requiring total density, some distance measure and + ! abundances in the 'abund' format + ! + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i),abund_in=abundi) + elseif (store_dust_temperature) then + ! cooling with stored dust temperature + if (do_nucleation) then + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),nucleation(idmu,i),nucleation(idgamma,i),nucleation(idK2,i),nucleation(idkappa,i)) + elseif (update_muGamma) then + call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,& + dust_temp(i),eos_vars(imu,i), eos_vars(igamma,i)) + 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 + 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) + endif + endif +#endif + ! update internal energy + if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool + + +end subroutine cooling_abundances_update + + !---------------------------------------------------------------- + !+ + ! routine for external force applied on gas particle + !+ + !---------------------------------------------------------------- + +subroutine get_external_force_gas(xi,yi,zi,hi,vxi,vyi,vzi,timei,i,dtextforcenew,dtf,dkdt, & + fextx,fexty,fextz,extf_is_velocity_dependent,iexternalforce) + use timestep, only:C_force + use externalforces, only: externalforce,update_vdependent_extforce + real, intent(in) :: xi,yi,zi,hi,vxi,vyi,vzi,timei,dkdt + real, intent(inout) :: dtextforcenew,dtf,fextx,fexty,fextz + integer, intent(in) :: iexternalforce,i + logical, intent(in) :: extf_is_velocity_dependent + real :: fextxi,fextyi,fextzi,poti + real :: fextv(3) + + call externalforce(iexternalforce,xi,yi,zi,hi, & + timei,fextxi,fextyi,fextzi,poti,dtf,i) + dtextforcenew = min(dtextforcenew,C_force*dtf) + + fextx = fextx + fextxi + fexty = fexty + fextyi + fextz = fextz + fextzi +! +! Velocity-dependent external forces require special handling +! in leapfrog (corrector is implicit) +! + if (extf_is_velocity_dependent) then + fextxi = fextx + fextyi = fexty + fextzi = fextz + call update_vdependent_extforce(iexternalforce,vxi,vyi,vzi, & + fextxi,fextyi,fextzi,fextv,dkdt,xi,yi,zi) + fextx = fextx + fextv(1) + fexty = fexty + fextv(2) + fextz = fextz + fextv(3) + endif + + +end subroutine get_external_force_gas + + +end module substepping diff --git a/src/tests/test_derivs.F90 b/src/tests/test_derivs.F90 index 4423158f5..271f8ccec 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 + maxdustsmall,periodic,mpi,ind_timesteps 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 @@ -53,34 +53,24 @@ subroutine test_derivs(ntests,npass,string) use viscosity, only:bulkvisc,shearparam,irealvisc use part, only:iphase,isetphase,igas use nicil, only:use_ambi -#ifdef IND_TIMESTEPS use timestep_ind, only:nactive use part, only:ibin -#endif -#ifdef DUST use dust, only:init_drag,idrag,K_code use part, only:grainsize,graindens,ndustlarge,ndusttypes -#endif use units, only:set_units use testutils, only:checkval,checkvalf,update_test_scores use mpidomain, only:i_belong integer, intent(inout) :: ntests,npass character(len=*), intent(in) :: string real :: psep,time,hzero,totmass -#ifdef IND_TIMESTEPS - integer :: itest,ierr2,nptest + integer :: itest,ierr2,nptest,nstart,nend,nstep real :: fracactive,speedup real(kind=4) :: tallactive real, allocatable :: fxyzstore(:,:),dBdtstore(:,:) -#else - integer :: nactive -#endif real :: psepblob,hblob,rhoblob,rblob,totvol,rtest -#ifdef PERIODIC integer :: maxtrial,maxactual integer(kind=8) :: nrhocalc,nactual,nexact real :: trialmean,actualmean,realneigh -#endif real :: rcut real :: rho1i,deint,demag,dekin,dedust,dmdust(maxdustsmall),dustfraci(maxdustsmall),tol real(kind=4) :: tused @@ -91,11 +81,8 @@ subroutine test_derivs(ntests,npass,string) real :: stressmax,rhoi,sonrhoi(maxdustsmall),drhodti,depsdti(maxdustsmall),dustfracj integer(kind=8) :: nptot real, allocatable :: dummy(:) -#ifdef IND_TIMESTEPS real :: tolh_old -#endif - logical :: checkmask(maxp) - + logical, allocatable :: mask(:) if (id==master) write(*,"(a,/)") '--> TESTING DERIVS MODULE' @@ -134,6 +121,7 @@ subroutine test_derivs(ntests,npass,string) testgradh = (maxgradh==maxp .and. index(kernelname,'cubic') > 0) call init_part() + allocate(mask(maxp)) iprint = 6 iverbose = max(iverbose,2) psep = dxbound/100. @@ -159,13 +147,13 @@ subroutine test_derivs(ntests,npass,string) nptot = reduceall_mpi('+',npart) massoftype(1) = totmass/reduceall_mpi('+',npart) -#ifndef PERIODIC - ! exclude particles near edge - rcut = min(xmax,ymax,zmax) - 2.*radkern*hfact*psep -#else - ! include all - rcut = sqrt(huge(rcut)) -#endif + if (periodic) then + ! include all particles + rcut = sqrt(huge(rcut)) + else + ! exclude particles near edge + rcut = min(xmax,ymax,zmax) - 2.*radkern*hfact*psep + endif print*,'thread ',id,' npart = ',npart if (id==master) print "(a,g9.2)",' hfact = ',hfact @@ -197,14 +185,15 @@ subroutine test_derivs(ntests,npass,string) !--calculate pure hydro derivatives with velocity and ! pressure distributions (no viscosity) ! - if (id==master) write(*,"(/,a)") '--> testing Hydro derivatives ' + if (id==master) write(*,"(/,a)") '--> testing Hydro derivatives (derivshydro)' call set_velocity_and_energy call reset_mhd_to_zero + if (maxvxyzu < 4) polyk = 3. ! !--calculate derivatives ! call get_derivs_global(tused) - call rcut_checkmask(rcut,xyzh,npart,checkmask) + call rcut_mask(rcut,xyzh,npart,mask) ! !--check hydro quantities come out as they should do ! @@ -214,8 +203,8 @@ subroutine test_derivs(ntests,npass,string) ! !--also check that the number of neighbours is correct ! -#ifdef PERIODIC - if (id==master .and. index(kernelname,'cubic') > 0) then + + if (id==master .and. periodic .and. index(kernelname,'cubic') > 0) then call get_neighbour_stats(trialmean,actualmean,maxtrial,maxactual,nrhocalc,nactual) realneigh = 4./3.*pi*(hfact*radkern)**3 call checkval(actualmean,real(int(realneigh)),tiny(0.),nfailed(11),'mean nneigh') @@ -225,84 +214,85 @@ subroutine test_derivs(ntests,npass,string) nexact = nptot*int(realneigh) call checkval(nactual,nexact,0,nfailed(14),'total nneigh') endif -#endif ! !--check that the timestep bin has been set ! -#ifdef IND_TIMESTEPS - call checkval(all(ibin(1:npart) > 0),.true.,nfailed(15),'ibin > 0') -#endif + if (ind_timesteps) call checkval(all(ibin(1:npart) > 0),.true.,nfailed(15),'ibin > 0') call update_test_scores(ntests,nfailed,npass) -#ifdef IND_TIMESTEPS - tallactive = tused + if (ind_timesteps) then + tallactive = tused - do itest=0,nint(log10(real(nptot)))-1 - nactive = 10**itest - if (id==master) write(*,"(/,a,i10,a)") '--> testing Hydro derivatives (on ',nactive,' active particles)' - call set_velocity_and_energy - do i=1,npart - if (i <= nactive/nprocs) then - iphase(i) = isetphase(igas,iactive=.true.) - xyzh(4,i) = hzero - else - iphase(i) = isetphase(igas,iactive=.false.) - endif - enddo - call reset_mhd_to_zero - ! - !--check timing for one active particle - ! - call get_derivs_global(tused) - if (id==master) then - fracactive = nactive/real(npart) - speedup = (tused)/tallactive - write(*,"(1x,'(',3(a,f9.5,'%'),')')") & + do itest=0,nint(log10(real(nptot)))-1 + nactive = 10**itest + if (id==master) write(*,"(/,a,i10,a)") '--> testing Hydro derivatives (on ',nactive,' active particles)' + call set_velocity_and_energy + do i=1,npart + if (i <= nactive/nprocs) then + iphase(i) = isetphase(igas,iactive=.true.) + xyzh(4,i) = hzero + else + iphase(i) = isetphase(igas,iactive=.false.) + endif + enddo + call reset_mhd_to_zero + ! + !--check timing for one active particle + ! + call get_derivs_global(tused) + if (id==master) then + fracactive = nactive/real(npart) + speedup = (tused)/tallactive + write(*,"(1x,'(',3(a,f9.5,'%'),')')") & 'moved ',100.*fracactive,' of particles in ',100.*speedup, & ' of time, efficiency = ',100.*fracactive/speedup - endif + endif - ! - ! Note that we check ALL values, including the inactives. That is we check - ! that the inactives have preserved their values from last time they were - ! calculated (finds bug of mistakenly setting inactives to zero) - ! - nfailed(:) = 0; m = 0 - call check_hydro(np,nfailed,m) - if (maxvxyzu==4) call check_fxyzu(np,nfailed,m) + ! + ! Note that we check ALL values, including the inactives. That is we check + ! that the inactives have preserved their values from last time they were + ! calculated (finds bug of mistakenly setting inactives to zero) + ! + nfailed(:) = 0; m = 0 + call check_hydro(np,nfailed,m) + if (maxvxyzu==4) call check_fxyzu(np,nfailed,m) - call update_test_scores(ntests,nfailed,npass) - ! - !--reset all particles to active for subsequent tests - ! - call reset_allactive() - enddo -#endif + call update_test_scores(ntests,nfailed,npass) + call reset_allactive() ! reset all particles to active for subsequent tests + enddo + endif endif testhydro + ! + !--for subsequent tests involving individual timesteps, cycle + ! through different numbers of active particles + ! + if (ind_timesteps) then + nstart = nint(log10(real(nptot))); nend = 0; nstep = -2 + else + nstart = 1; nend=1; nstep=1 + endif + testavderivs: if (testav .or. testall) then -#ifdef IND_TIMESTEPS - do itest=nint(log10(real(nptot))),0,-2 - nactive = 10**itest -#endif + do itest=nstart,nend,nstep + nactive = npart + if (ind_timesteps) nactive = 10**itest ! !--check artificial viscosity terms (pressure + av) ! if (id==master) then #ifdef DISC_VISCOSITY - write(*,"(/,a)") '--> testing artificial viscosity terms (disc viscosity)' + write(*,"(/,a)") '--> testing artificial viscosity terms w/disc viscosity (derivsav)' #else if (maxalpha==maxp) then - write(*,"(/,a)") '--> testing artificial viscosity terms (individual alpha)' + write(*,"(/,a)") '--> testing artificial viscosity terms w/individual alpha (derivsav)' else - write(*,"(/,a)") '--> testing artificial viscosity terms (constant alpha)' + write(*,"(/,a)") '--> testing artificial viscosity terms w/constant alpha (derivsav)' endif #endif -#ifdef IND_TIMESTEPS if (nactive /= npart) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' -#endif endif if (maxvxyzu < 4) polyk = 3. call set_velocity_only @@ -316,18 +306,16 @@ subroutine test_derivs(ntests,npass,string) if (maxalpha==maxp) alphaind(1,:) = real(alpha,kind=kind(alphaind)) call get_derivs_global() - call rcut_checkmask(rcut,xyzh,npart,checkmask) + call rcut_mask(rcut,xyzh,npart,mask) nfailed(:) = 0; m = 0 call check_hydro(np,nfailed,m) - call checkvalf(np,xyzh,fxyzu(1,:),forceavx,5.7e-3,nfailed(m+1),'art. visc force(x)',checkmask) - call checkvalf(np,xyzh,fxyzu(2,:),forceavy,1.4e-2,nfailed(m+2),'art. visc force(y)',checkmask) - call checkvalf(np,xyzh,fxyzu(3,:),forceavz,1.3e-2,nfailed(m+3),'art. visc force(z)',checkmask) + call checkvalf(np,xyzh,fxyzu(1,:),forceavx,5.7e-3,nfailed(m+1),'art. visc force(x)',mask) + call checkvalf(np,xyzh,fxyzu(2,:),forceavy,1.4e-2,nfailed(m+2),'art. visc force(y)',mask) + call checkvalf(np,xyzh,fxyzu(3,:),forceavz,1.3e-2,nfailed(m+3),'art. visc force(z)',mask) call update_test_scores(ntests,nfailed,npass) -#ifdef IND_TIMESTEPS - call reset_allactive() + if (ind_timesteps) call reset_allactive() enddo -#endif endif testavderivs ! @@ -335,7 +323,7 @@ subroutine test_derivs(ntests,npass,string) ! testcdswitch: if (testcullendehnen .or. testall) then if (maxalpha==maxp .and. nalpha > 1) then - if (id==master) write(*,"(/,a)") '--> testing ddivv/dt in Cullen & Dehnen switch' + if (id==master) write(*,"(/,a)") '--> testing ddivv/dt in Cullen & Dehnen switch (derivscd)' call set_velocity_only do i=1,npart @@ -363,7 +351,7 @@ subroutine test_derivs(ntests,npass,string) call check_hydro(np,nfailed,m) if (nalpha >= 2) then ialphaloc = 2 - call checkvalf(np,xyzh,alphaind(ialphaloc,:),alphalocfunc,3.5e-4,nfailed(m+1),'alphaloc') + call checkvalf(np,xyzh,alphaind(ialphaloc,:),alphalocfunc,3.5e-4,nfailed(m+1),'alphaloc',mask) endif call update_test_scores(ntests,nfailed,npass) else @@ -377,9 +365,9 @@ subroutine test_derivs(ntests,npass,string) ! if (id==master) then if (maxdvdx==maxp) then - write(*,"(/,a)") '--> testing physical viscosity terms (two first derivatives)' + write(*,"(/,a)") '--> testing physical viscosity terms w/two first derivatives (derivsvisc)' else - write(*,"(/,a)") '--> testing physical viscosity terms (direct second derivatives)' + write(*,"(/,a)") '--> testing physical viscosity terms w/direct second derivatives (derivsvisc)' endif endif polyk = 0. @@ -391,30 +379,29 @@ subroutine test_derivs(ntests,npass,string) bulkvisc = 0.75 call get_derivs_global() - call rcut_checkmask(rcut,xyzh,npart,checkmask) + call rcut_mask(rcut,xyzh,npart,mask) nfailed(:) = 0; m = 0 call check_hydro(np,nfailed,m) if (maxdvdx==maxp) then - call checkvalf(np,xyzh,dvdx(1,:),dvxdx,1.7e-3,nfailed(m+1), 'dvxdx',checkmask) - call checkvalf(np,xyzh,dvdx(2,:),dvxdy,2.5e-15,nfailed(m+2), 'dvxdy',checkmask) - call checkvalf(np,xyzh,dvdx(3,:),dvxdz,2.5e-15,nfailed(m+3), 'dvxdz',checkmask) - call checkvalf(np,xyzh,dvdx(4,:),dvydx,1.e-3,nfailed(m+4), 'dvydx',checkmask) - call checkvalf(np,xyzh,dvdx(5,:),dvydy,2.5e-15,nfailed(m+5), 'dvydy',checkmask) - call checkvalf(np,xyzh,dvdx(6,:),dvydz,1.e-3,nfailed(m+6), 'dvydz',checkmask) - call checkvalf(np,xyzh,dvdx(7,:),dvzdx,2.5e-15,nfailed(m+7), 'dvzdx',checkmask) - call checkvalf(np,xyzh,dvdx(8,:),dvzdy,1.5e-3,nfailed(m+8), 'dvzdy',checkmask) - call checkvalf(np,xyzh,dvdx(9,:),dvzdz,2.5e-15,nfailed(m+9),'dvzdz',checkmask) + call checkvalf(np,xyzh,dvdx(1,:),dvxdx,1.7e-3,nfailed(m+1), 'dvxdx',mask) + call checkvalf(np,xyzh,dvdx(2,:),dvxdy,2.5e-15,nfailed(m+2),'dvxdy',mask) + call checkvalf(np,xyzh,dvdx(3,:),dvxdz,2.5e-15,nfailed(m+3),'dvxdz',mask) + call checkvalf(np,xyzh,dvdx(4,:),dvydx,1.e-3,nfailed(m+4), 'dvydx',mask) + call checkvalf(np,xyzh,dvdx(5,:),dvydy,2.5e-15,nfailed(m+5),'dvydy',mask) + call checkvalf(np,xyzh,dvdx(6,:),dvydz,1.e-3,nfailed(m+6), 'dvydz',mask) + call checkvalf(np,xyzh,dvdx(7,:),dvzdx,2.5e-15,nfailed(m+7),'dvzdx',mask) + call checkvalf(np,xyzh,dvdx(8,:),dvzdy,1.5e-3,nfailed(m+8), 'dvzdy',mask) + call checkvalf(np,xyzh,dvdx(9,:),dvzdz,2.5e-15,nfailed(m+9),'dvzdz',mask) endif - call checkvalf(np,xyzh,fxyzu(1,:),forceviscx,4.e-2,nfailed(m+10),'viscous force(x)',checkmask) - call checkvalf(np,xyzh,fxyzu(2,:),forceviscy,3.e-2,nfailed(m+11),'viscous force(y)',checkmask) - call checkvalf(np,xyzh,fxyzu(3,:),forceviscz,3.1e-2,nfailed(m+12),'viscous force(z)',checkmask) + call checkvalf(np,xyzh,fxyzu(1,:),forceviscx,4.e-2,nfailed(m+10),'viscous force(x)',mask) + call checkvalf(np,xyzh,fxyzu(2,:),forceviscy,3.e-2,nfailed(m+11),'viscous force(y)',mask) + call checkvalf(np,xyzh,fxyzu(3,:),forceviscz,3.1e-2,nfailed(m+12),'viscous force(z)',mask) ! !--also check that the number of neighbours is correct ! -#ifdef PERIODIC - if (id==master) then + if (id==master .and. periodic) then call get_neighbour_stats(trialmean,actualmean,maxtrial,maxactual,nrhocalc,nactual) realneigh = 4./3.*pi*(hfact*radkern)**3 if (testall) then @@ -428,7 +415,6 @@ subroutine test_derivs(ntests,npass,string) call checkval(nactual,nexact,0,nfailed(18),'total nneigh') endif endif -#endif ! !--check that \sum m (du/dt + v.dv/dt) = 0. ! only applies if all particles active - with individual timesteps @@ -464,24 +450,24 @@ subroutine test_derivs(ntests,npass,string) ! if (use_dust) use_dustfrac=.true. if (use_dustfrac) then - if (id==master) write(*,"(/,a)") '--> testing dust evolution terms' -#ifdef DUST - idrag = 2 - gamma = 5./3. - !--Warning, K_code is not well defined when using multiple dust grains - ! and ONLY makes sense IFF all dust grains are identical (although - ! potentially binned with unequal densities). - ! K_code and K_k are related via: K_k = eps_k/eps*K_code) - K_code = 10. - grainsize = 0.01 - graindens = 3. - ndustsmall = maxdustsmall - ndustlarge = 0 - ndusttypes = ndustsmall + ndustlarge - !need to set units if testing with physical drag - !call set_units(dist=au,mass=solarm,G=1.d0) - call init_drag(nfailed(1)) -#endif + if (id==master) write(*,"(/,a)") '--> testing dust evolution terms (derivsdust)' + if (use_dust) then + idrag = 2 + gamma = 5./3. + !--Warning, K_code is not well defined when using multiple dust grains + ! and ONLY makes sense IFF all dust grains are identical (although + ! potentially binned with unequal densities). + ! K_code and K_k are related via: K_k = eps_k/eps*K_code) + K_code = 10. + grainsize = 0.01 + graindens = 3. + ndustsmall = maxdustsmall + ndustlarge = 0 + ndusttypes = ndustsmall + ndustlarge + !need to set units if testing with physical drag + !call set_units(dist=au,mass=solarm,G=1.d0) + call init_drag(nfailed(1)) + endif polyk = 0. call reset_mhd_to_zero call reset_dissipation_to_zero @@ -494,17 +480,18 @@ subroutine test_derivs(ntests,npass,string) enddo call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) nfailed(:) = 0; m = 0 call check_hydro(np,nfailed,m) do j=1,1 !ndustsmall !--Only need one because all dust species are identical -#ifdef DUST - grainsizek = grainsize(j) - graindensk = graindens(j) -#endif - call checkvalf(np,xyzh,ddustevol(j,:),ddustevol_func,4.e-5,nfailed(m+1),'deps/dt') - if (maxvxyzu>=4) call checkvalf(np,xyzh,fxyzu(iu,:),dudtdust_func,1.e-3,nfailed(m+2),'du/dt') - call checkvalf(np,xyzh,deltav(1,j,:),deltavx_func,1.01e-3,nfailed(m+3),'deltavx') + if (use_dust) then + grainsizek = grainsize(j) + graindensk = graindens(j) + endif + call checkvalf(np,xyzh,ddustevol(j,:),ddustevol_func,4.e-5,nfailed(m+1),'deps/dt',mask) + if (maxvxyzu>=4) call checkvalf(np,xyzh,fxyzu(iu,:),dudtdust_func,1.e-3,nfailed(m+2),'du/dt',mask) + call checkvalf(np,xyzh,deltav(1,j,:),deltavx_func,1.01e-3,nfailed(m+3),'deltavx',mask) enddo call update_test_scores(ntests,nfailed,npass) @@ -556,162 +543,151 @@ subroutine test_derivs(ntests,npass,string) ! !--calculate derivatives with MHD forces ON, zero pressure ! - testmhd: if (testmhdderivs .or. testall) then + testmhd: if ((testmhdderivs .or. testall) .and. mhd) then if (.not.testall) call get_derivs_global() ! obtain smoothing lengths -#ifdef IND_TIMESTEPS - do itest=nint(log10(real(nptot))),0,-2 - nactive = 10**itest -#endif + do itest=nstart,nend,nstep + if (ind_timesteps) nactive = 10**itest polyk = 0. call reset_mhd_to_zero call reset_dissipation_to_zero - if (mhd) then - if (id==master) then - write(*,"(/,a)") '--> testing MHD derivatives (using B/rho directly)' - if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' - endif - Bextx = 2.0e-1 - Bexty = 3.0e-1 - Bextz = 0.5 - call set_velocity_only - call set_magnetic_field - do i=1,npart - Bevol(4,i) = 0. - enddo - call set_active(npart,nactive/nprocs,igas) - call get_derivs_global() - ! - !--check that various quantities come out as they should do - ! - nfailed(:) = 0 - call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)') - - call checkvalf(np,xyzh,divBsymm(:),divBfunc,2.e-3,nfailed(2),'divB (symm)') - call checkvalf(np,xyzh,dBevol(1,:),dBxdt,2.e-3,nfailed(3),'dBx/dt') - call checkvalf(np,xyzh,dBevol(2,:),dBydt,2.e-3,nfailed(4),'dBy/dt') - call checkvalf(np,xyzh,dBevol(3,:),dBzdt,2.e-2,nfailed(5),'dBz/dt') - - call checkvalf(np,xyzh,fxyzu(1,:),forcemhdx,2.5e-2,nfailed(9),'mhd force(x)') - call checkvalf(np,xyzh,fxyzu(2,:),forcemhdy,2.5e-2,nfailed(10),'mhd force(y)') - call checkvalf(np,xyzh,fxyzu(3,:),forcemhdz,2.5e-2,nfailed(11),'mhd force(z)') - if (ndivcurlB >= 1) then - call checkvalf(np,xyzh,divcurlB(idivB,:),divBfunc,1.e-3,nfailed(12),'div B (diff)') - endif - if (ndivcurlB >= 4) then - call checkvalf(np,xyzh,divcurlB(icurlBx,:),curlBfuncx,1.e-3,nfailed(13),'curlB(x)') - call checkvalf(np,xyzh,divcurlB(icurlBy,:),curlBfuncy,1.e-3,nfailed(14),'curlB(y)') - call checkvalf(np,xyzh,divcurlB(icurlBz,:),curlBfuncz,1.e-3,nfailed(15),'curlB(z)') - endif - call update_test_scores(ntests,nfailed,npass) + if (id==master) then + write(*,"(/,a)") '--> testing MHD derivatives (derivsmhd)' + if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' + endif + Bextx = 2.0e-1 + Bexty = 3.0e-1 + Bextz = 0.5 + call set_velocity_only + call set_magnetic_field + do i=1,npart + Bevol(4,i) = 0. + enddo + call set_active(npart,nactive/nprocs,igas) + call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) + + ! + !--check that various quantities come out as they should do + ! + nfailed(:) = 0 + call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)',mask) + + call checkvalf(np,xyzh,divBsymm(:),divBfunc,2.e-3,nfailed(2),'divB (symm)',mask) + call checkvalf(np,xyzh,dBevol(1,:),dBxdt,2.e-3,nfailed(3),'dBx/dt',mask) + call checkvalf(np,xyzh,dBevol(2,:),dBydt,2.e-3,nfailed(4),'dBy/dt',mask) + call checkvalf(np,xyzh,dBevol(3,:),dBzdt,2.e-2,nfailed(5),'dBz/dt',mask) + + call checkvalf(np,xyzh,fxyzu(1,:),forcemhdx,2.5e-2,nfailed(9),'mhd force(x)',mask) + call checkvalf(np,xyzh,fxyzu(2,:),forcemhdy,2.5e-2,nfailed(10),'mhd force(y)',mask) + call checkvalf(np,xyzh,fxyzu(3,:),forcemhdz,2.5e-2,nfailed(11),'mhd force(z)',mask) + if (ndivcurlB >= 1) then + call checkvalf(np,xyzh,divcurlB(idivB,:),divBfunc,1.e-3,nfailed(12),'div B (diff)',mask) endif -#ifdef IND_TIMESTEPS - call reset_allactive() + if (ndivcurlB >= 4) then + call checkvalf(np,xyzh,divcurlB(icurlBx,:),curlBfuncx,1.e-3,nfailed(13),'curlB(x)',mask) + call checkvalf(np,xyzh,divcurlB(icurlBy,:),curlBfuncy,1.e-3,nfailed(14),'curlB(y)',mask) + call checkvalf(np,xyzh,divcurlB(icurlBz,:),curlBfuncz,1.e-3,nfailed(15),'curlB(z)',mask) + endif + call update_test_scores(ntests,nfailed,npass) + if (ind_timesteps) call reset_allactive() enddo - do itest=nint(log10(real(nptot))),0,-2 - nactive = 10**itest -#endif - if (mhd) then - if (id==master) then - write(*,"(/,a)") '--> testing artificial resistivity terms' - if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' - endif - call reset_mhd_to_zero - call reset_dissipation_to_zero - alphaB = 0.214 - polyk = 0. - ieosprev = ieos - ieos = 1 ! isothermal eos, so that the PdV term is zero - call set_magnetic_field + do itest=nstart,nend,nstep + if (ind_timesteps) nactive = 10**itest + if (id==master) then + write(*,"(/,a)") '--> testing artificial resistivity terms (derivsmhd)' + if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' + endif + call reset_mhd_to_zero + call reset_dissipation_to_zero + alphaB = 0.214 + polyk = 0. + ieosprev = ieos + ieos = 1 ! isothermal eos, so that the PdV term is zero + call set_magnetic_field + do i=1,npart + vxyzu(:,i) = 0. ! v=0 for this test + Bevol(4,i) = 0. ! psi=0 for this test + enddo + call set_active(npart,nactive,igas) + call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) + ! + !--check that various quantities come out as they should do + ! + nfailed(:) = 0 + ! + !--resistivity test is very approximate + ! To do a proper test, multiply by h/rij in densityforce + ! + call checkvalf(np,xyzh,dBevol(1,:),dBxdtresist,3.7e-2,nfailed(1),'dBx/dt (resist)',mask) + call checkvalf(np,xyzh,dBevol(2,:),dBydtresist,3.4e-2,nfailed(2),'dBy/dt (resist)',mask) + call checkvalf(np,xyzh,dBevol(3,:),dBzdtresist,2.2e-1,nfailed(3),'dBz/dt (resist)',mask) + call update_test_scores(ntests,nfailed,npass) + ! + !--check that \sum m (du/dt + B/rho.dB/dt) = 0. + ! only applies if all particles active - with individual timesteps + ! we just hope that du/dt has not changed all that much on non-active particles + ! + if (maxvxyzu==4 .and. nactive==npart) then + deint = 0. + demag = 0. do i=1,npart - vxyzu(:,i) = 0. ! v=0 for this test - Bevol(4,i) = 0. ! psi=0 for this test + rho1i = 1./rhoh(xyzh(4,i),massoftype(1)) + deint = deint + fxyzu(iu,i) + demag = demag + dot_product(Bevol(1:3,i),dBevol(1:3,i))*rho1i enddo - call set_active(npart,nactive,igas) - call get_derivs_global() - call rcut_checkmask(rcut,xyzh,npart,checkmask) - ! - !--check that various quantities come out as they should do - ! nfailed(:) = 0 - ! - !--resistivity test is very approximate - ! To do a proper test, multiply by h/rij in densityforce - ! - call checkvalf(np,xyzh,dBevol(1,:),dBxdtresist,3.7e-2,nfailed(1),'dBx/dt (resist)',checkmask) - call checkvalf(np,xyzh,dBevol(2,:),dBydtresist,3.4e-2,nfailed(2),'dBy/dt (resist)',checkmask) - call checkvalf(np,xyzh,dBevol(3,:),dBzdtresist,2.2e-1,nfailed(3),'dBz/dt (resist)',checkmask) - call update_test_scores(ntests,nfailed,npass) - ! - !--check that \sum m (du/dt + B/rho.dB/dt) = 0. - ! only applies if all particles active - with individual timesteps - ! we just hope that du/dt has not changed all that much on non-active particles - ! - if (maxvxyzu==4 .and. nactive==npart) then - deint = 0. - demag = 0. - do i=1,npart - rho1i = 1./rhoh(xyzh(4,i),massoftype(1)) - deint = deint + fxyzu(iu,i) - demag = demag + dot_product(Bevol(1:3,i),dBevol(1:3,i))*rho1i - enddo - nfailed(:) = 0 - call checkval(deint + demag,0.,2.7e-3,nfailed(1),'\sum du/dt + B.dB/dt = 0') - call update_test_scores(ntests,nfailed(1:1),npass) - endif - - !--restore ieos - ieos = ieosprev - + call checkval(deint + demag,0.,2.7e-3,nfailed(1),'\sum du/dt + B.dB/dt = 0') + call update_test_scores(ntests,nfailed(1:1),npass) endif -#ifdef IND_TIMESTEPS - call reset_allactive() + + !--restore ieos + ieos = ieosprev + if (ind_timesteps) call reset_allactive() enddo tolh_old = tolh - tolh = 1.e-7 - do itest=nint(log10(real(nptot))),0,-2 - nactive = 10**itest -#endif - if (mhd) then - if (id==master) then - write(*,"(/,a)") '--> testing div B cleaning terms' - if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' - endif - call reset_mhd_to_zero - call reset_dissipation_to_zero - psidecayfac = 0.8 - polyk = 2. - ieosprev = ieos - ieos = 1 ! isothermal eos - call set_velocity_only - call set_magnetic_field - call set_active(npart,nactive,igas) - call get_derivs_global() - ! - !--check that various quantities come out as they should do - ! - nfailed(:) = 0 - call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)') - call checkvalf(np,xyzh,divBsymm(:),divBfunc,1.e-3,nfailed(2),'divB') - call checkvalf(np,xyzh,dBevol(1,:),dpsidx,8.5e-4,nfailed(3),'gradpsi_x') - call checkvalf(np,xyzh,dBevol(2,:),dpsidy,9.3e-4,nfailed(4),'gradpsi_y') - call checkvalf(np,xyzh,dBevol(3,:),dpsidz,2.e-3,nfailed(5),'gradpsi_z') - !--can't do dpsi/dt check because we use vsigdtc = max over neighbours - !call checkvalf(np,xyzh,dBevol(4,:),dpsidt,6.e-3,nfailed(6),'dpsi/dt') - call update_test_scores(ntests,nfailed,npass) - - !--restore ieos - ieos = ieosprev + if (ind_timesteps) tolh = 1.e-7 + do itest=nstart,nend,nstep + if (ind_timesteps) nactive = 10**itest + if (id==master) then + write(*,"(/,a)") '--> testing div B cleaning terms (derivsmhd)' + if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' endif -#ifdef IND_TIMESTEPS - call reset_allactive() + call reset_mhd_to_zero + call reset_dissipation_to_zero + psidecayfac = 0.8 + polyk = 2. + ieosprev = ieos + ieos = 1 ! isothermal eos + call set_velocity_only + call set_magnetic_field + call set_active(npart,nactive,igas) + call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) + + ! + !--check that various quantities come out as they should do + ! + nfailed(:) = 0 + call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)',mask) + call checkvalf(np,xyzh,divBsymm(:),divBfunc,1.e-3,nfailed(2),'divB',mask) + call checkvalf(np,xyzh,dBevol(1,:),dpsidx,8.5e-4,nfailed(3),'gradpsi_x',mask) + call checkvalf(np,xyzh,dBevol(2,:),dpsidy,9.3e-4,nfailed(4),'gradpsi_y',mask) + call checkvalf(np,xyzh,dBevol(3,:),dpsidz,2.e-3,nfailed(5),'gradpsi_z',mask) + !--can't do dpsi/dt check because we use vsigdtc = max over neighbours + !call checkvalf(np,xyzh,dBevol(4,:),dpsidt,6.e-3,nfailed(6),'dpsi/dt') + call update_test_scores(ntests,nfailed,npass) + + !--restore ieos + ieos = ieosprev + if (ind_timesteps) call reset_allactive() enddo tolh = tolh_old - do itest=nint(log10(real(nptot))),0,-2 - nactive = 10**itest -#endif - if (mhd .and. use_ambi .and. testambipolar) then + do itest=nstart,nend,nstep + if (ind_timesteps) nactive = 10**itest + if (use_ambi .and. testambipolar) then if (id==master) then - write(*,"(/,a)") '--> testing Ambipolar diffusion terms' + write(*,"(/,a)") '--> testing Ambipolar diffusion term (derivsambi)' if (nactive /= np) write(*,"(a,i10,a)") ' (on ',nactive,' active particles)' endif call reset_mhd_to_zero @@ -727,25 +703,24 @@ subroutine test_derivs(ntests,npass,string) enddo call set_active(npart,nactive,igas) call get_derivs_global() + call rcut_mask(rcut,xyzh,npart,mask) ! !--check that various quantities come out as they should do ! nfailed(:) = 0 - call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)') - call checkvalf(np,xyzh,dBevol(1,:),dBambix,8.5e-4,nfailed(2),'dBambi_x') - call checkvalf(np,xyzh,dBevol(2,:),dBambiy,8.5e-4,nfailed(3),'dBambi_y') - call checkvalf(np,xyzh,dBevol(3,:),dBambiz,2.e-3,nfailed(4),'dBambi_z') + call checkval(np,xyzh(4,:),hzero,3.e-4,nfailed(1),'h (density)',mask) + call checkvalf(np,xyzh,dBevol(1,:),dBambix,8.5e-4,nfailed(2),'dBambi_x',mask) + call checkvalf(np,xyzh,dBevol(2,:),dBambiy,8.5e-4,nfailed(3),'dBambi_y',mask) + call checkvalf(np,xyzh,dBevol(3,:),dBambiz,2.e-3,nfailed(4),'dBambi_z',mask) call update_test_scores(ntests,nfailed,npass) !--restore ieos ieos = ieosprev endif - -#ifdef IND_TIMESTEPS - call reset_allactive() + if (ind_timesteps) call reset_allactive() enddo -#endif - + else + if (id==master) write(*,"(/,a)") '--> SKIPPING mhd terms (need -DMHD)' endif testmhd ! @@ -756,7 +731,7 @@ subroutine test_derivs(ntests,npass,string) ! and the 'test' particles cannot be identified using the current method ! testdenscontrast: if ((testdensitycontrast .or. testall) .and. (nprocs == 1)) then - if (id==master) write(*,"(/,a)") '--> testing Hydro derivs in setup with density contrast ' + if (id==master) write(*,"(/,a)") '--> testing Hydro derivs in setup with density contrast (derivscontrast)' npart = 0 psep = dxbound/50. @@ -813,8 +788,7 @@ subroutine test_derivs(ntests,npass,string) ! !--also check that the number of neighbours is correct ! -#ifdef PERIODIC - if (id==master .and. index(kernelname,'cubic') > 0) then + if (id==master .and. periodic .and. index(kernelname,'cubic') > 0) then call get_neighbour_stats(trialmean,actualmean,maxtrial,maxactual,nrhocalc,nactual) realneigh = 57.466651861721814 call checkval(actualmean,realneigh,1.e-17,nfailed(m+1),'mean nneigh') @@ -822,54 +796,50 @@ subroutine test_derivs(ntests,npass,string) ! !-- this test does not always give the same results: depends on how the tree is built ! - ! nexact = 1382952 ! got this from a reference calculation - ! call checkval(nrhocalc,nexact,0,nfailed(12),'n density calcs') nexact = 37263216 call checkval(nactual,nexact,0,nfailed(m+3),'total nneigh') endif -#endif call update_test_scores(ntests,nfailed,npass) -#ifdef IND_TIMESTEPS - tallactive = tused - do itest=1,nint(log10(real(nparttest))) - nactive = 10**itest - if (nactive > nparttest) nactive = nparttest - if (id==master) write(*,"(/,a,i6,a)") '--> testing Hydro derivs in setup with density contrast (nactive=',nactive,') ' + if (ind_timesteps) then + tallactive = tused + do itest=1,nint(log10(real(nparttest))) + nactive = 10**itest + if (nactive > nparttest) nactive = nparttest + if (id==master) write(*,"(/,a,i6,a)") '--> testing Hydro derivs in setup with density contrast (nactive=',nactive,') ' - call set_active(npart,nactive,igas) - call get_derivs_global(tused) - if (id==master) then - fracactive = nactive/real(npart) - speedup = tused/tallactive - write(*,"(1x,'(',3(a,f9.5,'%'),')')") & + call set_active(npart,nactive,igas) + call get_derivs_global(tused) + if (id==master) then + fracactive = nactive/real(npart) + speedup = tused/tallactive + write(*,"(1x,'(',3(a,f9.5,'%'),')')") & 'moved ',100.*fracactive,' of particles in ',100.*speedup, & ' of time, efficiency = ',100.*fracactive/speedup - endif - ! - !--check hydro quantities come out as they should do - ! - nfailed(:) = 0; m=5 - call checkval(nparttest,xyzh(4,:),hblob,4.e-4,nfailed(1),'h (density)') - call checkvalf(nparttest,xyzh,divcurlv(idivv,:),divvfunc,1.e-3,nfailed(2),'divv') - if (ndivcurlv >= 4) then - call checkvalf(nparttest,xyzh,divcurlv(icurlvxi,:),curlvfuncx,1.5e-3,nfailed(3),'curlv(x)') - call checkvalf(nparttest,xyzh,divcurlv(icurlvyi,:),curlvfuncy,1.e-3,nfailed(4),'curlv(y)') - call checkvalf(nparttest,xyzh,divcurlv(icurlvzi,:),curlvfuncz,1.e-3,nfailed(5),'curlv(z)') - endif - if (maxvxyzu==4) call check_fxyzu_nomask(nparttest,nfailed,m) - call update_test_scores(ntests,nfailed,npass) - enddo -#endif + endif + ! + !--check hydro quantities come out as they should do + ! + nfailed(:) = 0; m=5 + call checkval(nparttest,xyzh(4,:),hblob,4.e-4,nfailed(1),'h (density)') + call checkvalf(nparttest,xyzh,divcurlv(idivv,:),divvfunc,1.e-3,nfailed(2),'divv') + if (ndivcurlv >= 4) then + call checkvalf(nparttest,xyzh,divcurlv(icurlvxi,:),curlvfuncx,1.5e-3,nfailed(3),'curlv(x)') + call checkvalf(nparttest,xyzh,divcurlv(icurlvyi,:),curlvfuncy,1.e-3,nfailed(4),'curlv(y)') + call checkvalf(nparttest,xyzh,divcurlv(icurlvzi,:),curlvfuncz,1.e-3,nfailed(5),'curlv(z)') + endif + if (maxvxyzu==4) call check_fxyzu_nomask(nparttest,nfailed,m) + call update_test_scores(ntests,nfailed,npass) + enddo + endif endif testdenscontrast ! !--test force evaluation for individual timesteps when particles have very different smoothing lengths/ranges ! - testinddts: if (testindtimesteps .or. testall) then -#ifdef IND_TIMESTEPS - if (id==master) write(*,"(/,a,i6,a)") '--> testing force evaluation with ind_timesteps' + testinddts: if (ind_timesteps .and. (testindtimesteps .or. testall)) then + if (id==master) write(*,"(/,a,i6,a)") '--> testing force evaluation with ind_timesteps (derivsind)' polyk = 0. tolh = 1.e-9 call reset_mhd_to_zero @@ -945,14 +915,12 @@ subroutine test_derivs(ntests,npass,string) endif if (allocated(fxyzstore)) deallocate(fxyzstore) if (allocated(dBdtstore)) deallocate(dBdtstore) -#endif endif testinddts if (id==master) write(*,"(/,a)") '<-- DERIVS TEST COMPLETE' contains -#ifdef IND_TIMESTEPS subroutine reset_allactive ! !--reset all particles to active for subsequent tests @@ -963,22 +931,21 @@ subroutine reset_allactive nactive = npart end subroutine reset_allactive -#endif subroutine set_active(npart,nactive,itype) integer, intent(in) :: npart, nactive, itype ! ! set iphase for mixed active/inactive ! -#ifdef IND_TIMESTEPS - do i=1,npart - if (i <= nactive) then - iphase(i) = isetphase(itype,iactive=.true.) - else - iphase(i) = isetphase(itype,iactive=.false.) - endif - enddo -#endif + if (ind_timesteps) then + do i=1,npart + if (i <= nactive) then + iphase(i) = isetphase(itype,iactive=.true.) + else + iphase(i) = isetphase(itype,iactive=.false.) + endif + enddo + endif end subroutine set_active !-------------------------------------- @@ -1090,14 +1057,14 @@ subroutine check_hydro(n,nfailed,j) integer, intent(in) :: n integer, intent(inout) :: nfailed(:),j - call checkval(n,xyzh(4,1:np),hzero,3.e-4,nfailed(j+1),'h (density)',checkmask) - call checkvalf(n,xyzh,divcurlv(1,1:np),divvfunc,1.e-3,nfailed(j+2),'divv',checkmask) + call checkval(n,xyzh(4,1:np),hzero,3.e-4,nfailed(j+1),'h (density)',mask) + call checkvalf(n,xyzh,divcurlv(1,1:np),divvfunc,1.e-3,nfailed(j+2),'divv',mask) if (ndivcurlv >= 4) then - call checkvalf(n,xyzh,divcurlv(icurlvxi,1:np),curlvfuncx,1.5e-3,nfailed(j+3),'curlv(x)',checkmask) - call checkvalf(n,xyzh,divcurlv(icurlvyi,1:n),curlvfuncy,1.e-3,nfailed(j+4),'curlv(y)',checkmask) - call checkvalf(n,xyzh,divcurlv(icurlvzi,1:n),curlvfuncz,1.e-3,nfailed(j+5),'curlv(z)',checkmask) + call checkvalf(n,xyzh,divcurlv(icurlvxi,1:np),curlvfuncx,1.5e-3,nfailed(j+3),'curlv(x)',mask) + call checkvalf(n,xyzh,divcurlv(icurlvyi,1:n),curlvfuncy,1.e-3,nfailed(j+4),'curlv(y)',mask) + call checkvalf(n,xyzh,divcurlv(icurlvzi,1:n),curlvfuncz,1.e-3,nfailed(j+5),'curlv(z)',mask) endif - if (testgradh) call checkval(n,gradh(1,1:n),1.01948,1.e-5,nfailed(j+6),'gradh',checkmask) + if (testgradh) call checkval(n,gradh(1,1:n),1.01948,1.e-5,nfailed(j+6),'gradh',mask) j = j + 6 end subroutine check_hydro @@ -1112,15 +1079,15 @@ subroutine check_fxyzu(n,nfailed,j) integer, intent(in) :: n integer, intent(inout) :: nfailed(:),j - call checkvalf(n,xyzh,fxyzu(1,:),forcefuncx,1.e-3,nfailed(j+1),'force(x)',checkmask) - call checkvalf(n,xyzh,fxyzu(2,:),forcefuncy,1.e-3,nfailed(j+2),'force(y)',checkmask) - call checkvalf(n,xyzh,fxyzu(3,:),forcefuncz,1.e-3,nfailed(j+3),'force(z)',checkmask) + call checkvalf(n,xyzh,fxyzu(1,:),forcefuncx,1.e-3,nfailed(j+1),'force(x)',mask) + call checkvalf(n,xyzh,fxyzu(2,:),forcefuncy,1.e-3,nfailed(j+2),'force(y)',mask) + call checkvalf(n,xyzh,fxyzu(3,:),forcefuncz,1.e-3,nfailed(j+3),'force(z)',mask) if (ien_type == ien_entropy .or. ieos /= 2) then - call checkval(n,fxyzu(iu,:),0.,epsilon(fxyzu),nfailed(j+4),'den/dt',checkmask) + call checkval(n,fxyzu(iu,:),0.,epsilon(fxyzu),nfailed(j+4),'den/dt',mask) else allocate(dummy(n)) dummy(1:n) = fxyzu(iu,1:n)/((gamma-1.)*vxyzu(iu,1:n)) - call checkvalf(np,xyzh,dummy(1:n),dudtfunc,1.e-3,nfailed(j+4),'du/dt',checkmask) + call checkvalf(np,xyzh,dummy(1:n),dudtfunc,1.e-3,nfailed(j+4),'du/dt',mask) deallocate(dummy) endif j = j + 4 @@ -2499,19 +2466,14 @@ end function del2dustfrac real function ddustevol_func(xyzhi) use eos, only:gamma - use part, only:ndusttypes -#ifdef DUST + use part, only:use_dust,ndusttypes,rhoh use dust, only:get_ts,idrag,K_code -#endif - use part, only:rhoh real, intent(in) :: xyzhi(4) real :: dustfraci,uui,pri,tsi real :: gradu(3),gradeps(3),gradsumeps(3),gradp(3),gradts(3),gradepsts(3) real :: rhoi,rhogasi,rhodusti,spsoundi,del2P,du_dot_de,si real :: dustfracisum,del2dustfracsum -#ifdef DUST integer :: iregime -#endif rhoi = rhoh(xyzhi(4),massoftype(1)) dustfraci = dustfrac_func(xyzhi) @@ -2535,16 +2497,16 @@ real function ddustevol_func(xyzhi) del2P = (gamma-1.)*rhoi*((1. - dustfracisum)*del2u(xyzhi) - 2.*du_dot_de - uui*del2dustfracsum) tsi = 0. -#ifdef DUST - call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) - ! - ! grad(ts) = grad((1-eps)*eps*rho/K_code) - ! = rho/K_code*(1-2*eps)*grad(eps) ! note the absence of eps_k - ! - gradts(:) = rhoi/K_code(1)*(1. - 2.*dustfracisum)*gradsumeps(:) -#else - gradts(:) = 0. -#endif + if (use_dust) then + call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) + ! + ! grad(ts) = grad((1-eps)*eps*rho/K_code) + ! = rho/K_code*(1-2*eps)*grad(eps) ! note the absence of eps_k + ! + gradts(:) = rhoi/K_code(1)*(1. - 2.*dustfracisum)*gradsumeps(:) + else + gradts(:) = 0. + endif ! ! deps_k/dt = -1/rho \nabla.(eps_k ts (grad P)) ! note the presence of eps_k ! = -1/rho [eps_k ts \del^2 P + grad(eps_k ts).grad P] @@ -2572,19 +2534,14 @@ end function ddustevol_func real function dudtdust_func(xyzhi) use eos, only:gamma - use part, only:ndusttypes -#ifdef DUST + use part, only:use_dust,ndusttypes,rhoh use dust, only:get_ts,idrag -#endif - use part, only:rhoh real, intent(in) :: xyzhi(4) real :: dustfraci,uui,pri,tsi real :: gradp(3),gradu(3),gradeps(3),gradsumeps(3) real :: rhoi,rhogasi,rhodusti,spsoundi real :: dustfracisum -#ifdef DUST integer :: iregime -#endif rhoi = rhoh(xyzhi(4),massoftype(1)) dustfraci = dustfrac_func(xyzhi) @@ -2604,10 +2561,10 @@ real function dudtdust_func(xyzhi) gradp(:) = (gamma-1.)*(rhogasi*gradu - rhoi*uui*gradsumeps) tsi = 0. -#ifdef DUST - call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) - if (iregime /= 0) stop 'iregime /= 0' -#endif + if (use_dust) then + call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) + if (iregime /= 0) stop 'iregime /= 0' + endif ! this is equation (13) of Price & Laibe (2015) except ! that the sign on the second term is wrong in that paper ! (it is correct in Laibe & Price 2014a,b) @@ -2618,17 +2575,13 @@ end function dudtdust_func real function deltavx_func(xyzhi) use eos, only:gamma - use part, only:ndusttypes -#ifdef DUST + use part, only:ndusttypes,use_dust use dust, only:get_ts,idrag -#endif use part, only:rhoh real, intent(in) :: xyzhi(4) real :: rhoi,dustfraci,rhogasi,rhodusti,uui,pri,spsoundi,tsi,gradp real :: dustfracisum,gradsumeps,gradu -#ifdef DUST integer :: iregime -#endif rhoi = rhoh(xyzhi(4),massoftype(1)) dustfraci = dustfrac_func(xyzhi) @@ -2641,26 +2594,24 @@ real function deltavx_func(xyzhi) pri = (gamma-1.)*rhogasi*uui spsoundi = gamma*pri/rhogasi tsi = 0. -#ifdef DUST - call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) -#endif + if (use_dust) call get_ts(idrag,1,grainsizek,graindensk,rhogasi,rhodusti,spsoundi,0.,tsi,iregime) gradp = (gamma-1.)*(rhogasi*gradu - rhoi*uui*gradsumeps) deltavx_func = tsi*gradp/rhogasi end function deltavx_func -subroutine rcut_checkmask(rcut,xyzh,npart,checkmask) +subroutine rcut_mask(rcut,xyzh,npart,mask) use part, only:isdead_or_accreted real, intent(in) :: rcut real, intent(in) :: xyzh(:,:) integer, intent(in) :: npart - logical, intent(out) :: checkmask(:) + logical, intent(out) :: mask(:) real :: rcut2,xi,yi,zi,hi,r2 integer :: i,ncheck ncheck = 0 rcut2 = rcut*rcut - checkmask(:) = .false. + mask(:) = .false. do i=1,npart xi = xyzh(1,i) yi = xyzh(2,i) @@ -2668,11 +2619,11 @@ subroutine rcut_checkmask(rcut,xyzh,npart,checkmask) hi = xyzh(4,i) r2 = xi*xi + yi*yi + zi*zi if (.not.isdead_or_accreted(hi) .and. r2 < rcut2) then - checkmask(i) = .true. + mask(i) = .true. ncheck = ncheck + 1 endif enddo -end subroutine rcut_checkmask +end subroutine rcut_mask end module testderivs diff --git a/src/tests/test_dust.f90 b/src/tests/test_dust.f90 index 371059769..c025207f5 100644 --- a/src/tests/test_dust.f90 +++ b/src/tests/test_dust.f90 @@ -103,7 +103,7 @@ subroutine test_dust(ntests,npass) ! call test_drag(ntests,npass) call barrier_mpi() - + ! ! DUSTYBOX test with explicit/implicit scheme ! diff --git a/src/tests/test_eos.f90 b/src/tests/test_eos.f90 index 23a1372a7..44f09afe8 100644 --- a/src/tests/test_eos.f90 +++ b/src/tests/test_eos.f90 @@ -10,7 +10,7 @@ module testeos ! ! :References: None ! -! :Owner: Daniel Price +! :Owner: Terrence Tricco ! ! :Runtime parameters: None ! @@ -23,6 +23,7 @@ module testeos public :: test_helmholtz ! to avoid compiler warning for unused routine private + logical :: use_rel_tol = .true. contains !---------------------------------------------------------- @@ -116,7 +117,7 @@ subroutine test_idealplusrad(ntests, npass) use eos_idealplusrad, only:get_idealplusrad_enfromtemp,get_idealplusrad_pres use testutils, only:checkval,checkvalbuf_start,checkvalbuf,checkvalbuf_end,update_test_scores use units, only:unit_density,unit_pressure,unit_ergg - use physcon, only:kb_on_mh + use physcon, only:Rg integer, intent(inout) :: ntests,npass integer :: npts,ieos,ierr,i,j,nfail(2),ncheck(2) real :: rhocodei,gamma,presi,dum,csound,eni,temp,ponrhoi,mu,tol,errmax(2),pres2,code_eni @@ -129,7 +130,7 @@ subroutine test_idealplusrad(ntests, npass) call get_rhoT_grid(npts,rhogrid,Tgrid) dum = 0. - tol = 1.e-12 + tol = 1.e-15 nfail = 0; ncheck = 0; errmax = 0. call init_eos(ieos,ierr) do i=1,npts @@ -140,13 +141,13 @@ subroutine test_idealplusrad(ntests, npass) ! Recalculate T, P, from rho, u code_eni = eni/unit_ergg - temp = eni*mu/kb_on_mh + temp = eni*mu/Rg ! guess rhocodei = rhogrid(i)/unit_density call equationofstate(ieos,ponrhoi,csound,rhocodei,dum,dum,dum,temp,code_eni,mu_local=mu,gamma_local=gamma) pres2 = ponrhoi * rhocodei * unit_pressure - call checkvalbuf(temp,Tgrid(j),tol,'Check recovery of T from rho, u',nfail(1),ncheck(1),errmax(1)) - call checkvalbuf(pres2,presi,tol,'Check recovery of P from rho, u',nfail(2),ncheck(2),errmax(2)) + call checkvalbuf(temp,Tgrid(j),tol,'Check recovery of T from rho, u',nfail(1),ncheck(1),errmax(1),use_rel_tol) + call checkvalbuf(pres2,presi,tol,'Check recovery of P from rho, u',nfail(2),ncheck(2),errmax(2),use_rel_tol) enddo enddo call checkvalbuf_end('Check recovery of T from rho, u',ncheck(1),nfail(1),errmax(1),tol) @@ -170,9 +171,9 @@ subroutine test_hormone(ntests, npass) use testutils, only:checkval,checkvalbuf_start,checkvalbuf,checkvalbuf_end,update_test_scores use units, only:unit_density,unit_pressure,unit_ergg integer, intent(inout) :: ntests,npass - integer :: npts,ieos,ierr,i,j,nfail(4),ncheck(4) - real :: imurec,mu,eni_code,presi,pres2,dum,csound,eni,tempi - real :: ponrhoi,X,Z,tol,errmax(4),gasrad_eni,eni2,rhocodei,gamma + integer :: npts,ieos,ierr,i,j,nfail(6),ncheck(6) + real :: imurec,mu,eni_code,presi,pres2,dum,csound,eni,tempi,gamma_eff + real :: ponrhoi,X,Z,tol,errmax(6),gasrad_eni,eni2,rhocodei,gamma,mu2 real, allocatable :: rhogrid(:),Tgrid(:) if (id==master) write(*,"(/,a)") '--> testing HORMONE equation of states' @@ -185,45 +186,44 @@ subroutine test_hormone(ntests, npass) ! Testing dum = 0. - tol = 1.e-12 + tol = 1.e-14 tempi = -1. nfail = 0; ncheck = 0; errmax = 0. call init_eos(ieos,ierr) - tempi = 1. - eni_code = 764437650.64783347/unit_ergg - rhocodei = 3.2276168501594796E-015/unit_density - call equationofstate(ieos,ponrhoi,csound,rhocodei,0.,0.,0.,tempi,eni_code,mu_local=mu,Xlocal=X,Zlocal=Z,gamma_local=gamma) do i=1,npts do j=1,npts gamma = 5./3. - ! Get mu from rho, T + ! Get mu, u, P from rho, T call get_imurec(log10(rhogrid(i)),Tgrid(j),X,1.-X-Z,imurec) mu = 1./imurec - - ! Get u, P from rho, T, mu call get_idealplusrad_enfromtemp(rhogrid(i),Tgrid(j),mu,gasrad_eni) eni = gasrad_eni + get_erec(log10(rhogrid(i)),Tgrid(j),X,1.-X-Z) call get_idealplusrad_pres(rhogrid(i),Tgrid(j),mu,presi) - ! Recalculate P, T from rho, u, mu + ! Recalculate P, T from rho, u tempi = 1. eni_code = eni/unit_ergg rhocodei = rhogrid(i)/unit_density - call equationofstate(ieos,ponrhoi,csound,rhocodei,0.,0.,0.,tempi,eni_code,mu_local=mu,Xlocal=X,Zlocal=Z,gamma_local=gamma) + call equationofstate(ieos,ponrhoi,csound,rhocodei,0.,0.,0.,tempi,eni_code,& + mu_local=mu2,Xlocal=X,Zlocal=Z,gamma_local=gamma_eff) ! mu and gamma_eff are outputs pres2 = ponrhoi * rhocodei * unit_pressure - call checkvalbuf(tempi,Tgrid(j),tol,'Check recovery of T from rho, u',nfail(1),ncheck(1),errmax(1)) - call checkvalbuf(pres2,presi,tol,'Check recovery of P from rho, u',nfail(2),ncheck(2),errmax(2)) + call checkvalbuf(mu2,mu,tol,'Check recovery of mu from rho, u',nfail(1),ncheck(1),errmax(1),use_rel_tol) + call checkvalbuf(tempi,Tgrid(j),tol,'Check recovery of T from rho, u',nfail(2),ncheck(2),errmax(2),use_rel_tol) + call checkvalbuf(pres2,presi,tol,'Check recovery of P from rho, u',nfail(3),ncheck(3),errmax(3),use_rel_tol) ! Recalculate u, T, mu from rho, P - call calc_uT_from_rhoP_gasradrec(rhogrid(i),presi,X,1.-X-Z,tempi,eni2,mu,ierr) - call checkvalbuf(tempi,Tgrid(j),tol,'Check recovery of T from rho, P',nfail(3),ncheck(3),errmax(3)) - call checkvalbuf(eni2,eni,tol,'Check recovery of u from rho, P',nfail(4),ncheck(4),errmax(4)) + call calc_uT_from_rhoP_gasradrec(rhogrid(i),presi,X,1.-X-Z,tempi,eni2,mu2,ierr) + call checkvalbuf(mu2,mu,tol,'Check recovery of mu from rho, P',nfail(4),ncheck(4),errmax(4),use_rel_tol) + call checkvalbuf(tempi,Tgrid(j),tol,'Check recovery of T from rho, P',nfail(5),ncheck(5),errmax(5),use_rel_tol) + call checkvalbuf(eni2,eni,tol,'Check recovery of u from rho, P',nfail(6),ncheck(6),errmax(6),use_rel_tol) enddo enddo - call checkvalbuf_end('Check recovery of T from rho, u',ncheck(1),nfail(1),errmax(1),tol) - call checkvalbuf_end('Check recovery of P from rho, u',ncheck(2),nfail(2),errmax(2),tol) - call checkvalbuf_end('Check recovery of T from rho, P',ncheck(3),nfail(3),errmax(3),tol) - call checkvalbuf_end('Check recovery of u from rho, P',ncheck(4),nfail(4),errmax(4),tol) + call checkvalbuf_end('Check recovery of mu from rho, u',ncheck(1),nfail(1),errmax(1),tol) + call checkvalbuf_end('Check recovery of T from rho, u',ncheck(2),nfail(2),errmax(2),tol) + call checkvalbuf_end('Check recovery of P from rho, u',ncheck(3),nfail(3),errmax(3),tol) + call checkvalbuf_end('Check recovery of mu from rho, P',ncheck(4),nfail(4),errmax(4),tol) + call checkvalbuf_end('Check recovery of T from rho, P',ncheck(5),nfail(5),errmax(5),tol) + call checkvalbuf_end('Check recovery of u from rho, P',ncheck(6),nfail(6),errmax(6),tol) call update_test_scores(ntests,nfail,npass) end subroutine test_hormone diff --git a/src/tests/test_eos_stratified.f90 b/src/tests/test_eos_stratified.f90 index f8aaf1936..20ecf3f4f 100644 --- a/src/tests/test_eos_stratified.f90 +++ b/src/tests/test_eos_stratified.f90 @@ -296,11 +296,11 @@ subroutine map_stratified_temps(ntests, npass) call eosinfo(ieos,stdout) - open(1, file='HD1632996_temps.txt', status = 'replace') - open(2, file='IMLup_temps.txt', status = 'replace') - open(3, file='GMAur_temps.txt', status = 'replace') - open(4, file='AS209_temps.txt', status = 'replace') - open(5, file='MWC480_temps.txt', status = 'replace') + open(1,file='HD1632996_temps.txt',status='replace') + open(2,file='IMLup_temps.txt',status='replace') + open(3,file='GMAur_temps.txt',status='replace') + open(4,file='AS209_temps.txt',status='replace') + open(5,file='MWC480_temps.txt',status='replace') do i=1,n call get_disc_params(i,gmw,qfacdisc,qfacdisc2,alpha_z,beta_z,z0,polyk,polyk2, & diff --git a/src/tests/test_externf.f90 b/src/tests/test_externf.f90 index f6bb79410..13433ddb4 100644 --- a/src/tests/test_externf.f90 +++ b/src/tests/test_externf.f90 @@ -35,7 +35,7 @@ subroutine test_externf(ntests,npass) use externalforces, only:externalforcetype,externalforce,accrete_particles, & was_accreted,iexternalforce_max,initialise_externalforces,& accradius1,update_externalforce,is_velocity_dependent,& - externalforce_vdependent,update_vdependent_extforce_leapfrog,& + externalforce_vdependent,update_vdependent_extforce,& iext_lensethirring,iext_prdrag,iext_einsteinprec,iext_spiral,& iext_densprofile,iext_staticsine,iext_gwinspiral use extern_corotate, only:omega_corotate @@ -52,7 +52,7 @@ subroutine test_externf(ntests,npass) real :: psep,fxi,fyi,fzi,dtf,time,pmassi,dhi real :: fextxi,fextyi,fextzi,dumx,dumy,dumz,pot1,pot2 real :: xerrmax,yerrmax,zerrmax,ferrmaxx,ferrmaxy,ferrmaxz - real :: xi(4),v1(3),fext_iteration(3),fexti(3),vhalfx,vhalfy,vhalfz,dt + real :: xi(4),v1(3),fext_iteration(3),fexti(3),vhalfx,vhalfy,vhalfz,dt,hdt real :: xmini(3),xmaxi(3),poti real, parameter :: tolf = 1.5e-3 real, parameter :: tolfold = 1.e-10 @@ -199,24 +199,25 @@ subroutine test_externf(ntests,npass) fxi = -0.0789 ! non-zero, but small so that v-dependent fyi = 0.036 ! part is dominant component of the force fzi = -0.01462 + hdt = 0.5*dt ! ! get an explicit evaluation of the external force ! and solve v^1 = v^1/2 + dt/2*[f1(x^1) + f1(x^1,v^1)] ! by iterating 20 times ! - v1 = (/vhalfx + 0.5*dt*fxi,vhalfy + 0.5*dt*fyi,vhalfz + 0.5*dt*fzi/) + v1 = (/vhalfx + hdt*fxi,vhalfy + hdt*fyi,vhalfz + hdt*fzi/) do i=1,30 call externalforce_vdependent(iextf,xi(1:3),v1,fext_iteration,poti) - v1(1) = vhalfx + 0.5*dt*(fxi + fext_iteration(1)) - v1(2) = vhalfy + 0.5*dt*(fyi + fext_iteration(2)) - v1(3) = vhalfz + 0.5*dt*(fzi + fext_iteration(3)) + v1(1) = vhalfx + hdt*(fxi + fext_iteration(1)) + v1(2) = vhalfy + hdt*(fyi + fext_iteration(2)) + v1(3) = vhalfz + hdt*(fzi + fext_iteration(3)) !print*,'fext_iteration = ',fext_iteration enddo ! ! call update_leapfrog routine to get analytic solution ! - call update_vdependent_extforce_leapfrog(iextf,vhalfx,vhalfy,vhalfz,& - fxi,fyi,fzi,fexti,dt,xi(1),xi(2),xi(3)) + call update_vdependent_extforce(iextf,vhalfx,vhalfy,vhalfz,& + fxi,fyi,fzi,fexti,hdt,xi(1),xi(2),xi(3)) ! ! check that these agree with each other ! diff --git a/src/tests/test_gnewton.f90 b/src/tests/test_gnewton.f90 index 3dff7afa3..ebc352296 100644 --- a/src/tests/test_gnewton.f90 +++ b/src/tests/test_gnewton.f90 @@ -157,7 +157,7 @@ end subroutine test_gnewton !+ !----------------------------------------------------------------------- subroutine step_lf(t,dt,dtnew) - use externalforces, only:externalforce,update_vdependent_extforce_leapfrog,externalforce_vdependent + use externalforces, only:externalforce,update_vdependent_extforce,externalforce_vdependent use timestep, only:C_force use part, only:xyzh,vxyzu use options, only:iexternalforce @@ -191,9 +191,9 @@ subroutine step_lf(t,dt,dtnew) fy = fexty fz = fextz - call update_vdependent_extforce_leapfrog(iexternalforce,& + call update_vdependent_extforce(iexternalforce,& vxhalf,vyhalf,vzhalf, & - fx,fy,fz,fextv,dt,xyzh(1,1),xyzh(2,1),xyzh(3,1)) + fx,fy,fz,fextv,hdt,xyzh(1,1),xyzh(2,1),xyzh(3,1)) vxyzu(1,1) = vxhalf + hdt*fx vxyzu(2,1) = vyhalf + hdt*fy diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 2096c3d5d..7272f1276 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -15,9 +15,10 @@ module testptmass ! :Runtime parameters: None ! ! :Dependencies: boundary, checksetup, deriv, dim, energies, eos, -! gravwaveutils, io, kdtree, kernel, mpiutils, options, part, physcon, -! ptmass, random, setbinary, setdisc, spherical, step_lf_global, -! stretchmap, testutils, timestep, timing, units +! extern_binary, externalforces, gravwaveutils, io, kdtree, kernel, +! mpiutils, options, part, physcon, ptmass, random, setbinary, setdisc, +! spherical, step_lf_global, stretchmap, testutils, timestep, timing, +! units ! use testutils, only:checkval,update_test_scores implicit none @@ -27,23 +28,52 @@ module testptmass contains -subroutine test_ptmass(ntests,npass) +subroutine test_ptmass(ntests,npass,string) use io, only:id,master,iskfile use eos, only:polyk,gamma use part, only:nptmass use options, only:iexternalforce,alpha + use ptmass, only:use_fourthorder,set_integration_precision + character(len=*), intent(in) :: string character(len=20) :: filename + character(len=40) :: stringf integer, intent(inout) :: ntests,npass - integer :: itmp,ierr - logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening,do_test_merger + integer :: itmp,ierr,itest,istart + logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening + logical :: do_test_chinese_coin,do_test_merger + logical :: testall if (id==master) write(*,"(/,a,/)") '--> TESTING PTMASS MODULE' - do_test_binary = .true. - do_test_accretion = .true. - do_test_createsink = .true. - do_test_softening = .true. - do_test_merger = .true. + do_test_binary = .false. + do_test_accretion = .false. + do_test_createsink = .false. + do_test_softening = .false. + do_test_merger = .false. + do_test_chinese_coin = .false. + testall = .false. + istart = 1 + select case(trim(string)) + case('ptmassbinary') + do_test_binary = .true. + case('ptmassaccrete') + do_test_accretion = .true. + case('ptmasscreatesink') + do_test_createsink = .true. + case('ptmasssoftening') + do_test_softening = .true. + case('ptmassmerger') + do_test_merger = .true. + case('ptmasschinchen','ptmasscoin','chinchen','coin','chinesecoin') + do_test_chinese_coin = .true. + case('ptmassfsi','fsi') + istart = 2 + do_test_binary = .true. + do_test_softening = .true. + do_test_merger = .true. + case default + testall = .true. + end select ! !--general settings ! @@ -51,26 +81,47 @@ subroutine test_ptmass(ntests,npass) gamma = 1. iexternalforce = 0 alpha = 0.01 - ! - ! Tests of a sink particle binary - ! - if (do_test_binary) call test_binary(ntests,npass) - ! - ! Test of softening between sinks - ! - if (do_test_softening) call test_softening(ntests,npass) + do itest=istart,2 + ! + ! select order of integration + ! + if (itest == 2) then + use_fourthorder = .true. + stringf = ' with Forward Symplectic Integrator' + else + use_fourthorder = .false. + stringf = ' with Leapfrog integrator' + endif + call set_integration_precision + ! + ! Tests of a sink particle binary + ! + if (do_test_binary .or. testall) call test_binary(ntests,npass,stringf) + ! + ! Test of softening between sinks + ! + if (do_test_softening .or. testall) call test_softening(ntests,npass) + ! + ! Test of Chinese Coin problem + ! + if (do_test_chinese_coin .or. testall) call test_chinese_coin(ntests,npass,stringf) + ! + ! Test sink particle mergers + ! + if (do_test_merger .or. testall) call test_merger(ntests,npass) + enddo ! ! Tests of accrete_particle routine ! - if (do_test_accretion) call test_accretion(ntests,npass) + if (do_test_accretion .or. testall) then + do itest=1,2 + call test_accretion(ntests,npass,itest) + enddo + endif ! ! Test sink particle creation ! - if (do_test_createsink) call test_createsink(ntests,npass) - ! - ! Test sink particle mergers - ! - if (do_test_merger) call test_merger(ntests,npass) + if (do_test_createsink .or. testall) call test_createsink(ntests,npass) !reset stuff and clean up temporary files itmp = 201 @@ -92,12 +143,12 @@ end subroutine test_ptmass ! Unit tests of a sink particle binary orbit !+ !----------------------------------------------------------------------- -subroutine test_binary(ntests,npass) +subroutine test_binary(ntests,npass,string) use dim, only:periodic,gravity,ind_timesteps use io, only:id,master,iverbose use physcon, only:pi,deg_to_rad use ptmass, only:get_accel_sink_sink,h_soft_sinksink, & - get_accel_sink_gas,f_acc + get_accel_sink_gas,f_acc,use_fourthorder use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fext,& npart,npartoftype,massoftype,xyzh,vxyzu,fxyzu,& hfact,igas,epot_sinksink,init_part,iJ2,ispinx,ispiny,ispinz,iReff,istar @@ -116,11 +167,12 @@ subroutine test_binary(ntests,npass) use deriv, only:get_derivs_global use timing, only:getused,printused use options, only:ipdv_heating,ishock_heating - integer, intent(inout) :: ntests,npass + integer, intent(inout) :: ntests,npass + character(len=*), intent(in) :: string integer :: i,ierr,itest,nfailed(3),nsteps,nerr,nwarn,norbits integer :: merge_ij(2),merge_n,nparttot,nfailgw(2),ncheckgw(2) integer, parameter :: nbinary_tests = 5 - real :: m1,m2,a,ecc,hacc1,hacc2,dt,dtext,t,dtnew,tolen,hp_exact,hx_exact + real :: m1,m2,a,ecc,hacc1,hacc2,dt,dtext,t,dtnew,tolen,tolmom,tolang,hp_exact,hx_exact real :: angmomin,etotin,totmomin,dum,dum2,omega,errmax,dtsinksink,fac,errgw(2) real :: angle,rin,rout real :: fxyz_sinksink(4,2),dsdt_sinksink(3,2) ! we only use 2 sink particles in the tests here @@ -138,25 +190,35 @@ subroutine test_binary(ntests,npass) ipdv_heating = 0 ishock_heating = 0 + tolv = 1e-2 + binary_tests: do itest = 1,nbinary_tests select case(itest) case(4) - if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit with oblateness' + if (use_fourthorder) then + if (id==master) write(*,"(/,a)") '--> skipping integration of binary orbit with oblateness with FSI' + cycle binary_tests + else + if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit with oblateness'//trim(string) + endif case(2,3,5) if (periodic) then if (id==master) write(*,"(/,a)") '--> skipping circumbinary disc test (-DPERIODIC is set)' cycle binary_tests + elseif (use_fourthorder .and. itest==5) then + if (id==master) write(*,"(/,a)") '--> skipping circumbinary disc around oblate star test with FSI' + cycle binary_tests else if (itest==5) then - if (id==master) write(*,"(/,a)") '--> testing integration of disc around oblate star' + if (id==master) write(*,"(/,a)") '--> testing integration of disc around oblate star'//trim(string) elseif (itest==3) then - if (id==master) write(*,"(/,a)") '--> testing integration of disc around eccentric binary' + if (id==master) write(*,"(/,a)") '--> testing integration of disc around eccentric binary'//trim(string) else - if (id==master) write(*,"(/,a)") '--> testing integration of circumbinary disc' + if (id==master) write(*,"(/,a)") '--> testing integration of circumbinary disc'//trim(string) endif endif case default - if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit' + if (id==master) write(*,"(/,a)") '--> testing integration of binary orbit'//trim(string) end select ! !--setup sink-sink binary (no gas particles) @@ -183,6 +245,7 @@ subroutine test_binary(ntests,npass) hacc1 = 0.35 hacc2 = 0.35 C_force = 0.25 + if (itest==3) C_force = 0.25 omega = sqrt((m1+m2)/a**3) t = 0. call set_units(mass=1.d0,dist=1.d0,G=1.d0) @@ -217,7 +280,7 @@ subroutine test_binary(ntests,npass) call checkval(nerr,0,0,nfailed(1),'no errors during disc setup') call update_test_scores(ntests,nfailed,npass) - tolv = 1.e3 + tolv = 1.e-2 iverbose = 0 ieos = 3 fac = 1./get_G_on_dc4() @@ -297,58 +360,68 @@ subroutine test_binary(ntests,npass) if (id==master) call getused(t1) call init_step(npart,t,dtmax) do i=1,nsteps - t = t + dt dtext = dt if (id==master .and. iverbose > 2) write(*,*) ' t = ',t,' dt = ',dt call step(npart,npart,t,dt,dtext,dtnew) call compute_energies(t) errmax = max(errmax,abs(etot - etotin)) + !if (itest==3) print*,t,abs(angtot-angmomin)/angmomin ! ! Check the gravitational wave strain if the binary is circular. ! There is a phase error that grows with time, so only check the first 10 orbits ! if (calc_gravitwaves .and. abs(ecc) < epsilon(ecc) .and. itest==1 .and. t < 20.*pi/omega) then - call get_strain_from_circular_binary(t,m1,m2,a,0.,hx_exact,hp_exact) + call get_strain_from_circular_binary(t+dt,m1,m2,a,0.,hx_exact,hp_exact) call checkvalbuf(10.+hx(1)*fac,10.+hx_exact*fac,tolgw,& 'gw strain (x)',nfailgw(1),ncheckgw(1),errgw(1)) call checkvalbuf(10.+hp(1)*fac,10.+hp_exact*fac,tolgw,& 'gw strain (+)',nfailgw(2),ncheckgw(2),errgw(2)) endif + t = t + dt enddo call compute_energies(t) if (id==master) call printused(t1) nfailed(:) = 0 + tolmom = 2.e-14 + tolang = 2.e-14 select case(itest) + case(5) + tolen = 9.e-1 + case(4) + tolmom = 1.e-14 + tolen = 1.6e-2 case(3) if (ind_timesteps) then - call checkval(angtot,angmomin,2.1e-6,nfailed(3),'angular momentum') - call checkval(totmom,totmomin,5.e-6,nfailed(2),'linear momentum') + tolang = 2.1e-6 else - call checkval(angtot,angmomin,1.2e-6,nfailed(3),'angular momentum') - call checkval(totmom,totmomin,4.e-14,nfailed(2),'linear momentum') + tolang = 6.e-10 endif tolen = 1.2e-2 case(2) - call checkval(angtot,angmomin,4.e-7,nfailed(3),'angular momentum') - call checkval(totmom,totmomin,6.e-14,nfailed(2),'linear momentum') - tolen = 2.e-3 + tolen = 1.2e-3 if (gravity) tolen = 3.1e-3 + + if (use_fourthorder) then + tolang = 2.e-11 + endif case default if (calc_gravitwaves .and. itest==1) then call checkvalbuf_end('grav. wave strain (x)',ncheckgw(1),nfailgw(1),errgw(1),tolgw) call checkvalbuf_end('grav. wave strain (+)',ncheckgw(2),nfailgw(2),errgw(2),tolgw) call update_test_scores(ntests,nfailgw(1:2),npass) endif - call checkval(angtot,angmomin,4.e-13,nfailed(3),'angular momentum') - call checkval(totmom,totmomin,epsilon(0.),nfailed(2),'linear momentum') - tolen = 3.e-8 - if (itest==4) tolen = 1.6e-2 ! etot is small compared to ekin - if (itest==5) tolen = 9.e-1 + if (use_fourthorder) then + tolen = 1.e-13 + else + tolen = 3.e-8 + endif end select ! !--check energy conservation ! - call checkval(etotin+errmax,etotin,tolen,nfailed(1),'total energy') + call checkval(angtot,angmomin,tolang,nfailed(1),'angular momentum') + call checkval(totmom,totmomin,tolmom,nfailed(2),'linear momentum') + call checkval(etotin+errmax,etotin,tolen,nfailed(3),'total energy') do i=1,3 call update_test_scores(ntests,nfailed(i:i),npass) enddo @@ -462,34 +535,117 @@ subroutine test_softening(ntests,npass) end subroutine test_softening +!----------------------------------------------------------------------- +!+ +! Test Chinese Coin problem from Chin & Chen (2005) +!+ +!----------------------------------------------------------------------- +subroutine test_chinese_coin(ntests,npass,string) + use io, only:id,master,iverbose + use part, only:xyzmh_ptmass,vxyz_ptmass,ihacc,nptmass,npart,npartoftype,fxyz_ptmass,dsdt_ptmass + use extern_binary, only:mass1,mass2 + use options, only:iexternalforce + use externalforces, only:iext_binary,update_externalforce + use physcon, only:pi + use step_lf_global, only:step + use ptmass, only:use_fourthorder,get_accel_sink_sink + integer, intent(inout) :: ntests,npass + character(len=*), intent(in) :: string + character(len=10) :: tag + integer :: nfailed(3),merge_ij(1),merge_n,norbit + real :: t,dtorb,dtnew,dtext,tmax,epot_sinksink,y0,v0 + real :: tol_per_orbit_y,tol_per_orbit_v + + if (id==master) write(*,"(/,a)") '--> testing Chinese coin problem'//trim(string)//' (coin)' + + ! no gas + npart = 0 + npartoftype = 0 + + ! add a single sink particle + y0 = 0.0580752367; v0 = 0.489765446 + nptmass = 1 + xyzmh_ptmass = 0. + xyzmh_ptmass(2,1) = y0 + xyzmh_ptmass(4,1) = 1.0 + xyzmh_ptmass(ihacc,1) = 0.1 + vxyz_ptmass = 0. + vxyz_ptmass(1,1) = v0 + + ! external binary + iexternalforce = iext_binary + mass1 = 0.5 + mass2 = mass1 + dtorb = 9.*pi + tmax = 3.*dtorb + + t = 0. + dtext = 1.e-15 + iverbose = 1 + call update_externalforce(iexternalforce,t,0.) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtext,iexternalforce,t,merge_ij,merge_n,dsdt_ptmass) + + dtext = 1.e-15 ! take small first step + norbit = 0 + nfailed(:) = 0 + tol_per_orbit_y = 2.5e-2 + tol_per_orbit_v = 1.15e-2 + if (use_fourthorder) then + tol_per_orbit_y = 1.1e-3 + tol_per_orbit_v = 3.35e-4 + endif + do while (t < tmax) + ! do a whole orbit but with the substepping handling how many steps per orbit + call step(npart,npart,t,dtorb,dtext,dtnew) + t = t + dtorb + norbit = norbit + 1 + + write(tag,"(a,i1,a)") '(orbit ',norbit,')' + call checkval(xyzmh_ptmass(2,1),y0,norbit*tol_per_orbit_y,nfailed(1),'y pos of sink '//trim(tag)) + call checkval(vxyz_ptmass(1,1),v0,norbit*tol_per_orbit_v,nfailed(2),'x vel of sink '//trim(tag)) + enddo + + call update_test_scores(ntests,nfailed(1:2),npass) + iverbose = 0 ! reset verbosity + iexternalforce = 0 + +end subroutine test_chinese_coin + !----------------------------------------------------------------------- !+ ! Test accretion of gas particles onto sink particles !+ !----------------------------------------------------------------------- -subroutine test_accretion(ntests,npass) +subroutine test_accretion(ntests,npass,itest) use io, only:id,master use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,massoftype, & npart,npartoftype,xyzh,vxyzu,fxyzu,igas,ihacc,& - isdead_or_accreted,set_particle_type - use ptmass, only:ndptmass,ptmass_accrete,update_ptmass + isdead_or_accreted,set_particle_type,ndptmass,hfact + use ptmass, only:ptmass_accrete,update_ptmass use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi use testutils, only:checkval,update_test_scores + use kernel, only:hfact_default + use eos, only:polyk + use setdisc, only:set_disc integer, intent(inout) :: ntests,npass - integer :: i,nfailed(11) + integer, intent(in) :: itest + integer :: i,nfailed(11),np_disc integer(kind=1) :: ibin_wakei + character(len=20) :: string logical :: accreted - real :: dr,t + real :: t real :: dptmass(ndptmass,1) real :: dptmass_thread(ndptmass,1) - real :: xyzm_ptmass_old(4,1),vxyz_ptmass_old(3,1) real :: angmomin,etotin,totmomin xyzmh_ptmass(:,:) = 0. vxyz_ptmass(:,:) = 0. - if (id==master) write(*,"(/,a)") '--> testing accretion onto sink particles' + string = 'of two particles' + if (itest==2) string = 'of a whole disc' + if (id==master) write(*,"(/,a)") '--> testing accretion '//trim(string)//' onto sink particles' nptmass = 1 !--setup 1 point mass at (-5,-5,-5) xyzmh_ptmass(1:3,1) = 1. @@ -497,23 +653,35 @@ subroutine test_accretion(ntests,npass) xyzmh_ptmass(ihacc,1) = 20. ! accretion radius vxyz_ptmass(1:3,1) = -40. fxyz_ptmass(1:3,1) = 40. - massoftype(1) = 10. - !--setup 1 SPH particle at (5,5,5) - if (id==master) then - call set_particle_type(1,igas) - npartoftype(igas) = 1 - npart = 1 - xyzh(1:3,1) = 5. - xyzh(4,1) = 0.01 - vxyzu(1:3,1) = 80. - fxyzu(1:3,1) = 20. + hfact = hfact_default + + if (itest==1) then + !--setup 2 SPH particles at (5,5,5) + if (id==master) then + call set_particle_type(1,igas) + call set_particle_type(2,igas) + npartoftype(igas) = 2 + npart = 2 + xyzh(1:3,1:2) = 5. + xyzh(4,1:2) = 0.01 + vxyzu(1:3,1) = [40.,40.,-10.] + vxyzu(1:3,2) = [120.,120.,-30.] + fxyzu(1:3,1:2) = 20. + massoftype(1) = 5. + else + npartoftype(igas) = 0 + npart = 0 + endif else - npartoftype(igas) = 0 - npart = 0 + ! eat a large portion of a disc + np_disc = 1000 + call set_disc(id,master,nparttot=np_disc,npart=npart,rmin=1.,rmax=2.*xyzmh_ptmass(ihacc,1),p_index=1.0,q_index=0.75,& + HoverR=0.1,disc_mass=0.5*xyzmh_ptmass(4,1),star_mass=xyzmh_ptmass(4,1),gamma=1.,& + particle_mass=massoftype(igas),hfact=hfact,xyzh=xyzh,vxyzu=vxyzu,& + polyk=polyk,verbose=.false.) + npartoftype(igas) = npart endif - xyzm_ptmass_old = xyzmh_ptmass(1:4,1:nptmass) - vxyz_ptmass_old = vxyz_ptmass (1:3,1:nptmass) - dr = sqrt(dot_product(xyzh(1:3,1) - xyzmh_ptmass(1:3,1),xyzh(1:3,1) - xyzmh_ptmass(1:3,1))) + !--perform a test of the accretion of the SPH particle by the point mass nfailed(:) = 0 !--check energies before accretion event @@ -529,10 +697,12 @@ subroutine test_accretion(ntests,npass) dptmass_thread(:,1:nptmass) = 0. !$omp do do i=1,npart - call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxyzu(1,i),fxyzu(2,i),fxyzu(3,i), & - igas,massoftype(igas),xyzmh_ptmass,vxyz_ptmass, & - accreted,dptmass_thread,t,1.0,ibin_wakei,ibin_wakei) + if (.not.isdead_or_accreted(xyzh(4,i))) then + call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& + vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxyzu(1,i),fxyzu(2,i),fxyzu(3,i), & + igas,massoftype(igas),xyzmh_ptmass,vxyz_ptmass, & + accreted,dptmass_thread,t,1.0,ibin_wakei,ibin_wakei) + endif enddo !$omp enddo !$omp critical(dptmassadd) @@ -548,31 +718,34 @@ subroutine test_accretion(ntests,npass) call bcast_mpi(vxyz_ptmass(:,1:nptmass)) call bcast_mpi(fxyz_ptmass(:,1:nptmass)) - if (id==master) then - call checkval(accreted,.true.,nfailed(1),'accretion flag') - !--check that h has been changed to indicate particle has been accreted - call checkval(isdead_or_accreted(xyzh(4,1)),.true.,nfailed(2),'isdead_or_accreted flag') - endif - call checkval(xyzmh_ptmass(1,1),3.,tiny(0.),nfailed(3),'x(ptmass) after accretion') - call checkval(xyzmh_ptmass(2,1),3.,tiny(0.),nfailed(4),'y(ptmass) after accretion') - call checkval(xyzmh_ptmass(3,1),3.,tiny(0.),nfailed(5),'z(ptmass) after accretion') - call checkval(vxyz_ptmass(1,1),20.,tiny(0.),nfailed(6),'vx(ptmass) after accretion') - call checkval(vxyz_ptmass(2,1),20.,tiny(0.),nfailed(7),'vy(ptmass) after accretion') - call checkval(vxyz_ptmass(3,1),20.,tiny(0.),nfailed(8),'vz(ptmass) after accretion') - call checkval(fxyz_ptmass(1,1),30.,tiny(0.),nfailed(9), 'fx(ptmass) after accretion') - call checkval(fxyz_ptmass(2,1),30.,tiny(0.),nfailed(10),'fy(ptmass) after accretion') - call checkval(fxyz_ptmass(3,1),30.,tiny(0.),nfailed(11),'fz(ptmass) after accretion') + if (itest==1) then + if (id==master) then + call checkval(accreted,.true.,nfailed(1),'accretion flag') + !--check that h has been changed to indicate particle has been accreted + call checkval(isdead_or_accreted(xyzh(4,1)),.true.,nfailed(2),'isdead_or_accreted flag(1)') + call checkval(isdead_or_accreted(xyzh(4,2)),.true.,nfailed(2),'isdead_or_accreted flag(2)') + endif + call checkval(xyzmh_ptmass(1,1),3.,tiny(0.),nfailed(3),'x(ptmass) after accretion') + call checkval(xyzmh_ptmass(2,1),3.,tiny(0.),nfailed(4),'y(ptmass) after accretion') + call checkval(xyzmh_ptmass(3,1),3.,tiny(0.),nfailed(5),'z(ptmass) after accretion') + call checkval(vxyz_ptmass(1,1),20.,tiny(0.),nfailed(6),'vx(ptmass) after accretion') + call checkval(vxyz_ptmass(2,1),20.,tiny(0.),nfailed(7),'vy(ptmass) after accretion') + call checkval(vxyz_ptmass(3,1),-30.,tiny(0.),nfailed(8),'vz(ptmass) after accretion') + call checkval(fxyz_ptmass(1,1),30.,tiny(0.),nfailed(9), 'fx(ptmass) after accretion') + call checkval(fxyz_ptmass(2,1),30.,tiny(0.),nfailed(10),'fy(ptmass) after accretion') + call checkval(fxyz_ptmass(3,1),30.,tiny(0.),nfailed(11),'fz(ptmass) after accretion') - call update_test_scores(ntests,nfailed(1:2),npass) - call update_test_scores(ntests,nfailed(3:5),npass) - call update_test_scores(ntests,nfailed(6:8),npass) - call update_test_scores(ntests,nfailed(9:11),npass) + call update_test_scores(ntests,nfailed(1:2),npass) + call update_test_scores(ntests,nfailed(3:5),npass) + call update_test_scores(ntests,nfailed(6:8),npass) + call update_test_scores(ntests,nfailed(9:11),npass) + endif - !--compute energies after accretion event + !--compute conserved quantities after accretion event nfailed(:) = 0 call compute_energies(t) - call checkval(angtot,angmomin,1.e-10,nfailed(3),'angular momentum') - call checkval(totmom,totmomin,epsilon(0.),nfailed(2),'linear momentum') + call checkval(angtot,angmomin,1.e-14,nfailed(3),'angular momentum') + call checkval(totmom,totmomin,2.*epsilon(0.),nfailed(2),'linear momentum') !call checkval(etot,etotin,1.e-6,'total energy',nfailed(1)) call update_test_scores(ntests,nfailed(3:3),npass) call update_test_scores(ntests,nfailed(2:2),npass) @@ -592,8 +765,9 @@ subroutine test_createsink(ntests,npass) 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, & - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass - use ptmass, only:ndptmass,ptmass_accrete,update_ptmass,icreate_sinks,& + nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,ndptmass, & + dptmass + use ptmass, only:ptmass_accrete,update_ptmass,icreate_sinks,& ptmass_create,finish_ptmass,ipart_rhomax,h_acc,rho_crit,rho_crit_cgs use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceloc_mpi,reduceall_mpi @@ -712,7 +886,7 @@ subroutine test_createsink(ntests,npass) call reduceloc_mpi('max',ipart_rhomax_global,id_rhomax) endif call ptmass_create(nptmass,npart,itestp,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& - massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,0.) + massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,0.) ! ! check that creation succeeded ! diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index 180e2708b..d3bf32d13 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -156,6 +156,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) if (index(string,'damp') /= 0) dodamp = .true. if (index(string,'wind') /= 0) dowind = .true. if (index(string,'iorig') /= 0) doiorig = .true. + if (index(string,'ptmass') /= 0) doptmass = .true. doany = any((/doderivs,dogravity,dodust,dogrowth,donimhd,dorwdump,& doptmass,docooling,dogeom,dogr,dosmol,doradiation,& @@ -170,7 +171,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) dokdtree = .true. case('step') dostep = .true. - case('ptmass','sink') + case('ptmass','sink','fsi','chinchen','coin') doptmass = .true. case('gnewton') dognewton = .true. @@ -327,7 +328,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) !--test of ptmass module ! if (doptmass.or.testall) then - call test_ptmass(ntests,npass) + call test_ptmass(ntests,npass,string) call set_default_options_testsuite(iverbose) ! restore defaults endif diff --git a/src/tests/utils_testsuite.f90 b/src/tests/utils_testsuite.f90 index 8f05a7d0c..512d25766 100644 --- a/src/tests/utils_testsuite.f90 +++ b/src/tests/utils_testsuite.f90 @@ -629,16 +629,21 @@ end subroutine checkvalbuf_int ! (buffered: reports on errors only and ndiff is a running total) !+ !---------------------------------------------------------------- -subroutine checkvalbuf_real(xi,val,tol,label,ndiff,ncheck,errmax) +subroutine checkvalbuf_real(xi,val,tol,label,ndiff,ncheck,errmax,use_rel_tol) real, intent(in) :: xi real, intent(in) :: val,tol character(len=*), intent(in) :: label integer, intent(inout) :: ndiff,ncheck real, intent(inout) :: errmax + logical, intent(in), optional :: use_rel_tol real :: erri + logical :: rel_tol + + rel_tol = .false. + if (present(use_rel_tol)) rel_tol = use_rel_tol erri = abs(xi-val) - if (abs(val) > smallval .and. erri > tol) erri = erri/abs(val) + if (rel_tol .or. (abs(val) > smallval .and. erri > tol)) erri = erri/abs(val) ncheck = ncheck + 1 if (erri > tol .or. erri /= erri) then From 7f753c44b8f907ab311ca76d0a8ded4a00e5e97e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 2 May 2024 20:08:28 +0200 Subject: [PATCH 508/814] patch rad_accel_ptmass to be used with FsI --- src/main/ptmass_radiation.f90 | 102 +++++++++++++++++----------------- src/main/substepping.F90 | 30 +++++++--- 2 files changed, 74 insertions(+), 58 deletions(-) diff --git a/src/main/ptmass_radiation.f90 b/src/main/ptmass_radiation.f90 index 18954ec84..dc175ff8d 100644 --- a/src/main/ptmass_radiation.f90 +++ b/src/main/ptmass_radiation.f90 @@ -58,16 +58,25 @@ end subroutine init_radiation_ptmass ! compute radiative acceleration from ALL sink particles !+ !----------------------------------------------------------------------- -subroutine get_rad_accel_from_ptmass (nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) +subroutine get_rad_accel_from_ptmass (nptmass,npart,i,xi,yi,zi,xyzmh_ptmass,fextx,fexty,fextz,tau,fsink_old,extrapfac) use part, only:ilum use units, only:umass,unit_luminosity - integer, intent(in) :: nptmass,npart - real, intent(in) :: xyzh(:,:) - real, intent(in) :: xyzmh_ptmass(:,:) - real, intent(in), optional :: tau(:) - real, intent(inout) :: fext(:,:) - real :: xa,ya,za,Mstar_cgs,Lstar_cgs + integer, intent(in) :: nptmass,npart,i + real, intent(in) :: xi,yi,zi + real, intent(in) :: xyzmh_ptmass(:,:) + real, optional, intent(in) :: tau(:) + real, intent(inout) :: fextx,fexty,fextz + real, optional, intent(in) :: fsink_old(:,:) + real, optional, intent(in) :: extrapfac + real :: dx,dy,dz,Mstar_cgs,Lstar_cgs integer :: j + logical :: extrap + + if (present(fsink_old)) then + extrap = .true. + else + extrap = .false. + endif do j=1,nptmass if (xyzmh_ptmass(4,j) < 0.) cycle @@ -75,10 +84,16 @@ subroutine get_rad_accel_from_ptmass (nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) Lstar_cgs = xyzmh_ptmass(ilum,j)*unit_luminosity !compute radiative acceleration if sink particle is assigned a non-zero luminosity if (Lstar_cgs > 0.d0) then - xa = xyzmh_ptmass(1,j) - ya = xyzmh_ptmass(2,j) - za = xyzmh_ptmass(3,j) - call calc_rad_accel_from_ptmass(npart,xa,ya,za,Lstar_cgs,Mstar_cgs,xyzh,fext,tau) + if (extrap) then + dx = xi - xyzmh_ptmass(1,j) + extrapfac*fsink_old(1,j) + dy = yi - xyzmh_ptmass(2,j) + extrapfac*fsink_old(2,j) + dz = zi - xyzmh_ptmass(3,j) + extrapfac*fsink_old(3,j) + else + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + endif + call calc_rad_accel_from_ptmass(npart,i,dx,dy,dz,Lstar_cgs,Mstar_cgs,fextx,fexty,fextz,tau) endif enddo @@ -89,53 +104,40 @@ end subroutine get_rad_accel_from_ptmass ! compute radiative acceleration on all particles !+ !----------------------------------------------------------------------- -subroutine calc_rad_accel_from_ptmass(npart,xa,ya,za,Lstar_cgs,Mstar_cgs,xyzh,fext,tau) +subroutine calc_rad_accel_from_ptmass(npart,i,dx,dy,dz,Lstar_cgs,Mstar_cgs,fextx,fexty,fextz,tau) use part, only:isdead_or_accreted,dust_temp,nucleation,idkappa,idalpha use dim, only:do_nucleation,itau_alloc use dust_formation, only:calc_kappa_bowen - integer, intent(in) :: npart - real, intent(in) :: xyzh(:,:) - real, intent(in), optional :: tau(:) - real, intent(in) :: xa,ya,za,Lstar_cgs,Mstar_cgs - real, intent(inout) :: fext(:,:) - real :: dx,dy,dz,r,ax,ay,az,alpha,kappa - integer :: i - - !$omp parallel do default(none) & - !$omp shared(nucleation,do_nucleation,itau_alloc)& - !$omp shared(dust_temp) & - !$omp shared(npart,xa,ya,za,Mstar_cgs,Lstar_cgs,xyzh,fext,tau) & - !$omp private(i,dx,dy,dz,ax,ay,az,r,alpha,kappa) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - dx = xyzh(1,i) - xa - dy = xyzh(2,i) - ya - dz = xyzh(3,i) - za - r = sqrt(dx**2 + dy**2 + dz**2) - if (do_nucleation) then - if (itau_alloc == 1) then - call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& + integer, intent(in) :: npart,i + real, optional, intent(in) :: tau(:) + real, intent(in) :: dx,dy,dz,Lstar_cgs,Mstar_cgs + real, intent(inout) :: fextx,fexty,fextz + real :: r,ax,ay,az,alpha,kappa + + + r = sqrt(dx**2 + dy**2 + dz**2) + if (do_nucleation) then + if (itau_alloc == 1) then + call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& nucleation(idkappa,i),ax,ay,az,nucleation(idalpha,i),tau(i)) - else - call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& + else + call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& nucleation(idkappa,i),ax,ay,az,nucleation(idalpha,i)) - endif - else - kappa = calc_kappa_bowen(dust_temp(i)) - if (itau_alloc == 1) then - call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& + endif + else + kappa = calc_kappa_bowen(dust_temp(i)) + if (itau_alloc == 1) then + call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& kappa,ax,ay,az,alpha,tau(i)) - else - call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& + else + call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& kappa,ax,ay,az,alpha) - endif - endif - fext(1,i) = fext(1,i) + ax - fext(2,i) = fext(2,i) + ay - fext(3,i) = fext(3,i) + az endif - enddo - !$omp end parallel do + endif + fextx = fextx + ax + fexty = fexty + ay + fextz = fextz + az + end subroutine calc_rad_accel_from_ptmass diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index a3f9cd3f5..92a090f68 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -873,7 +873,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, endif ! - !-- Forces on gas particles (Sink/gas,extf,damp,cooling) + !-- Forces on gas particles (Sink/gas,extf,damp,cooling,rad pressure) ! !$omp parallel default(none) & @@ -883,6 +883,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$omp shared(dkdt,dt,timei,iexternalforce,extf_vdep_flag,last) & !$omp shared(divcurlv,dphotflag,dphot0,nucleation,extrap) & !$omp shared(abundc,abundo,abundsi,abunde,extrapfac,fsink_old) & + !$omp shared(isink_radiation,itau_alloc,tau) & !$omp private(fextx,fexty,fextz,xi,yi,zi) & !$omp private(i,fonrmaxi,dtphi2i,phii,dtf) & !$omp firstprivate(pmassi,itype) & @@ -936,6 +937,26 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (idamp > 0) then call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), (/xi,yi,zi/), damp_fac) endif + ! + ! Radiation pressure force with isink_radiation + ! + if (nptmass > 0 .and. isink_radiation > 0) then + 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) + else + call get_rad_accel_from_ptmass(nptmass,npart,i,xi,yi,zi,xyzmh_ptmass,fextx,fexty,fextz, & + fsink_old=fsink_old,extrapfac=extrapfac) + endif + else + if (itau_alloc == 1) then + call get_rad_accel_from_ptmass(nptmass,npart,i,xi,yi,zi,xyzmh_ptmass,fextx,fexty,fextz,tau) + else + call get_rad_accel_from_ptmass(nptmass,npart,i,xi,yi,zi,xyzmh_ptmass,fextx,fexty,fextz) + endif + endif + endif fext(1,i) = fextx fext(2,i) = fexty @@ -952,13 +973,6 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$omp enddo !$omp end parallel - if (nptmass > 0 .and. isink_radiation > 0 .and. .not.extrap) then - if (itau_alloc == 1) then - call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) - else - call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext) - endif - endif if (nptmass > 0) then call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) From 77632d0a3c58f51cc4fb01af1c2f25a0ab18bd30 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 3 May 2024 14:24:22 +0100 Subject: [PATCH 509/814] Changing Stamatellos cooling implementation for new step_leapfrog and substepping code structure. --- src/main/cooling.f90 | 4 +- src/main/cooling_stamatellos.f90 | 239 +++++++++++++++++-------------- src/main/force.F90 | 2 +- src/main/step_leapfrog.F90 | 5 +- src/main/substepping.F90 | 2 +- 5 files changed, 138 insertions(+), 114 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index aa2dda90b..c85316524 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -143,7 +143,6 @@ 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_stamatellos, only:cooling_S07 real(kind=4), intent(in) :: divv ! in code units real, intent(in) :: xi,yi,zi,ui,rho,dt ! in code units @@ -178,7 +177,8 @@ subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2 select case (icooling) case (9) - call cooling_S07(rho,ui,dudt,xi,yi,zi,Tfloor,dudti_sph,dt,part_id) + ! should not occur! + call fatal('energ_cooling','cooling_S07 called from cooling.f90') case (6) call cooling_KoyamaInutsuka_implicit(ui,rho,dt,dudt) case (5) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index 53988e395..2c9fb4c4f 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -61,139 +61,160 @@ end subroutine init_star ! ! Do cooling calculation ! -subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) +! edit this to make a loop and update energy to return evolved energy array. +subroutine cooling_S07(npart,xyzh,energ,Tfloor,dudt_sph,dt) 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 + use part, only:xyzmh_ptmass,rhoh,massoftype,igas - real,intent(in) :: rhoi,ui,dudti_sph,xi,yi,zi,Tfloor,dt - integer,intent(in) :: i - real,intent(out) :: dudti_cool + integer,intent(in) :: npart + real,intent(in) :: dudt_sph(:),xyzh(:,:),Tfloor,dt + real,intent(inout) :: energ(:) + real :: dudti_cool,ui,rhoi real :: coldensi,kappaBari,kappaParti,ri2 - real :: gmwi,Tmini4,Ti,dudt_rad,Teqi,Hstam,HLom,du_tot - real :: cs2,Om2,Hmod2 - real :: opac,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi + real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot + real :: cs2,Om2,Hmod2,xi,yi,zi + real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi + integer :: i - poti = Gpot_cool(i) - du_FLDi = duFLD(i) - - 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 + !omp parallel do default(none) & + !omp shared(npart,duFLD,xyzh,energ,rhoh,massoftype,igas,xyzmh_ptmass) & + !omp shared(isink_star,pi,steboltz,solarl,Rg,doFLD,ttherm_store,teqi_store) & + !omp shared(opac_store,Tfloor,dt,dudt_sph) + !omp private(i,poti,du_FLDi,xi,yi,zi,ui,rhoi,ri2,coldensi,kappaBari) & + !omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot) & + !omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,poti,presi,Hcomb) + overpart: do i=1,npart + poti = Gpot_cool(i) + du_FLDi = duFLD(i) + xi = xyzh(1,i) + yi = xyzh(2,i) + zi = xyzh(3,i) + ui = energ(i) + rhoi = rhoh(xyzh(4,i),massoftype(igas)) + + 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 -! get opacities & Ti for ui - call getopac_opdep(ui*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,& + ! get opacities & Ti for ui + call getopac_opdep(ui*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,& Ti,gmwi) - presi = kb_on_mh*rhoi*unit_density*Ti/gmwi ! cgs - presi = presi/unit_pressure !code units - - if (isnan(kappaBari)) then - print *, "kappaBari is NaN\n", " ui(erg) = ", ui*unit_ergg, "rhoi=", rhoi*unit_density, "Ti=", Ti, & - "i=", i - stop - endif + 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 + if (isnan(kappaBari)) then + print *, "kappaBari is NaN\n", " ui(erg) = ", ui*unit_ergg, "rhoi=", rhoi*unit_density, "Ti=", Ti, & + "i=", i + stop endif - Hmod2 = cs2 * piontwo / (Om2 + 8d0*rpiontwo*rhoi) - !Q3D = Om2/(4.d0*pi*rhoi) + + 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) + !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 + Hcomb = 1.d0/sqrt((1.0d0/HLom)**2.0d0 + (1.0d0/Hmod2)) + 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 + 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 - 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 + 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 - ! include term from FLD - Teqi = (du_FLDi + dudti_sph) *opac*unit_ergg/utime ! physical units - du_tot = dudti_sph + dudt_rad + du_FLDi - else - Teqi = dudti_sph*opac*unit_ergg/utime - du_tot = dudti_sph + dudt_rad - endif + if (doFLD) then + ! include term from FLD + Teqi = (du_FLDi + dudt_sph(i)) *opaci*unit_ergg/utime ! physical units + du_tot = dudt_sph(i) + dudti_rad + du_FLDi + else + Teqi = dudt_sph(i)*opaci*unit_ergg/utime + du_tot = dudt_sph(i) + dudti_rad + endif - 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 - call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) - ueqi = ueqi/unit_ergg + 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 + 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 + call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi*unit_density,umini) + umini = umini/unit_ergg -! calculate thermalization timescale and -! internal energy update -> in form where it'll work as dudtcool - if ((du_tot) == 0.d0) then - tthermi = 0d0 - else - tthermi = abs((ueqi - ui)/(du_tot)) - endif + ! calculate thermalization timescale and + ! internal energy update -> in form where it'll work as dudtcool + if ((du_tot) == 0.d0) then + tthermi = 0d0 + else + tthermi = abs((ueqi - ui)/(du_tot)) + endif - ttherm_store(i) = tthermi + ttherm_store(i) = tthermi - 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 (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 *, "opac=",opac,"coldensi=",coldensi,"dudti_sph",dudti_sph - print *, "dt=",dt,"tthermi=", tthermi,"umini=", umini - 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 - dudti_cool = (umini - ui)/dt - endif + if (isnan(dudti_cool)) then + ! print *, "kappaBari=",kappaBari, "kappaParti=",kappaParti + print *, "rhoi=",rhoi, "Ti=", Ti + print *, "opaci=",opaci,"coldensi=",coldensi,"dudt_sphi",dudt_sph(i) + print *, "dt=",dt,"tthermi=", tthermi,"umini=", umini + print *, "dudti_rad=", dudti_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 + dudti_cool = (umini - ui)/dt + endif + + ! evolve energy + energ(i) = energ(i) + dudti_cool * dt + + enddo overpart end subroutine cooling_S07 diff --git a/src/main/force.F90 b/src/main/force.F90 index 011f6cf2b..491b961a8 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -1605,7 +1605,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g if (rhoj == 0d0) then diffterm = 0d0 print *, "setting diffterm = 0", i, j, rhoj - elseif ((kfldj + kfldi) == 0.) then + elseif ((kfldj + kfldi) < tiny(0.)) then diffterm = 0d0 else diffterm = 4d0*pmassj/rhoi/rhoj diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 500ea70d6..a3fcd831b 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -126,7 +126,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use eos, only:equationofstate use substepping, only:substep,substep_gr, & substep_sph_gr,substep_sph - + use cooling_stamatellos, only:cooling_S07 + use cooling, only:Tfloor + integer, intent(inout) :: npart integer, intent(in) :: nactive real, intent(in) :: t,dtsph @@ -254,6 +256,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call substep(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& dptmass,fsink_old,nbinmax,ibin_wake) + if (icooling == 9) call cooling_S07(npart,xyzh,vxyzu(4,:),Tfloor,fxyzu(4,:),dtsph) else call substep_sph(dtsph,npart,xyzh,vxyzu) endif diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index a3f9cd3f5..89738c538 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -1049,7 +1049,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 From 5b1bf16111fb10ebf16a33e3cb82304938179840 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 3 May 2024 15:50:43 +0200 Subject: [PATCH 510/814] fix issue with optional arg and omp reduction --- src/main/substepping.F90 | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index ca40e3e92..83786af5b 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -480,7 +480,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! ! Main integration scheme ! - call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) if (use_regnbody) then call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) @@ -503,7 +503,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old,group_info) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) @@ -514,7 +514,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & else call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) @@ -629,7 +629,7 @@ end subroutine drift subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) - use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas + use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas,ndptmass use ptmass, only:f_acc,ptmass_accrete,pt_write_sinkev,update_ptmass,ptmass_kick use externalforces, only:accrete_particles use options, only:iexternalforce @@ -643,7 +643,8 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, real, intent(inout) :: xyzh(:,:) real, intent(inout) :: vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, optional, intent(inout) :: dptmass(:,:),fxyz_ptmass_sinksink(:,:) + real, intent(inout) :: dptmass(ndptmass,nptmass) + real, optional, intent(inout) :: fxyz_ptmass_sinksink(:,:) real, optional, intent(in) :: timei integer(kind=1), optional, intent(inout) :: ibin_wake(:) integer(kind=1), optional, intent(in) :: nbinmax @@ -654,7 +655,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, integer :: naccreted,nfail,nlive real :: dkdt,pmassi,fxi,fyi,fzi,accretedmass - if (present(dptmass) .and. present(timei) .and. present(ibin_wake) .and. present(nbinmax)) then + if (present(timei) .and. present(ibin_wake) .and. present(nbinmax)) then is_accretion = .true. else is_accretion = .false. @@ -706,7 +707,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. - !$omp parallel default(none) & + !$omp parallel do default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & @@ -714,10 +715,11 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, !$omp shared(nbinmax,ibin_wake) & !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & !$omp firstprivate(itype,pmassi,ibin_wakei) & - !$omp reduction(+:dptmass) & !$omp reduction(+:accretedmass) & - !$omp reduction(+:nfail,naccreted,nlive) - !$omp do + !$omp reduction(+:nfail) & + !$omp reduction(+:naccreted) & + !$omp reduction(+:nlive) & + !$omp reduction(+:dptmass) accreteloop: do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then if (ntypes > 1 .and. maxphase==maxp) then @@ -764,8 +766,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = nlive + 1 endif enddo accreteloop - !$omp enddo - !$omp end parallel + !$omp end parallel do if (npart > 2 .and. nlive < 2) then call fatal('step','all particles accreted',var='nlive',ival=nlive) @@ -859,6 +860,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if(present(group_info)) then wsub = .true. + else + wsub = .false. endif From f640f0620d1d46ff281579281e877100fa3e2f83 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 3 May 2024 18:21:22 +0200 Subject: [PATCH 511/814] change icreate_stars to icreate_sinks=2 and setup fix --- src/main/evolve.F90 | 4 ++-- src/main/ptmass.F90 | 7 +++---- src/setup/setup_cluster.f90 | 9 ++++----- 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 793f57cf7..fbf8c01e1 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -93,7 +93,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) linklist_ptmass use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & - set_integration_precision,icreate_stars,ptmass_create_stars + set_integration_precision,ptmass_create_stars use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries @@ -278,7 +278,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! call ptmass_create(nptmass,npart,ipart_rhomax,xyzh,vxyzu,fxyzu,fext,divcurlv,& poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklist_ptmass,dptmass,time) - if (icreate_stars > 0) call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) + if (icreate_sinks > 1) call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) endif ! ! Strang splitting: implicit update for half step diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 774348361..286f391f6 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -58,8 +58,7 @@ module ptmass public :: set_integration_precision ! settings affecting routines in module (read from/written to input file) - integer, public :: icreate_sinks = 0 - integer, public :: icreate_stars = 0 + integer, public :: icreate_sinks = 0 ! 1-standard sink creation scheme 2-Star formation scheme using core prescription real, public :: rho_crit_cgs = 1.e-10 real, public :: r_crit = 5.e-3 real, public :: h_acc = 1.e-3 @@ -1502,7 +1501,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote fxyz_ptmass_sinksink(:,nptmass) = 0.0 call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) - if (icreate_stars > 0) call ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) + if (icreate_sinks > 1) call ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) if (id==id_rhomax) then write(iprint,"(a,i3,a,4(es10.3,1x),a,i6,a,es10.3)") ' created ptmass #',nptmass,& @@ -1725,7 +1724,7 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklis - mij*(xyzmh_ptmass(1,k)*vxyz_ptmass(2,k) - xyzmh_ptmass(2,k)*vxyz_ptmass(1,k)) ! Kill sink j by setting negative mass xyzmh_ptmass(4,j) = -abs(mj) - if(icreate_stars>0) then + if(icreate_sinks>1) then ! Connect linked list of the merged sink to the survivor call ptmass_end_lklist(k,l,linklist_ptmass) linklist_ptmass(l) = j diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 35de91eb3..c87b43fbf 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -55,7 +55,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use setvfield, only:normalise_vfield use timestep, only:dtmax,tmax use centreofmass, only:reset_centreofmass - use ptmass, only:h_acc,r_crit,rho_crit_cgs,icreate_sinks,icreate_stars,tmax_acc + use ptmass, only:h_acc,r_crit,rho_crit_cgs,icreate_sinks,tmax_acc use datafiles, only:find_phantom_datafile use eos, only:ieos,gmw use kernel, only:hfact_default @@ -112,9 +112,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, dist_fac = 1.0 ! distance code unit: dist_fac * pc endif - !--Set units - call set_units(dist=dist_fac*pc,mass=mass_fac*solarm,G=1.) - if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state !--Read values from .setup @@ -131,6 +128,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call write_setupfile(fileset) endif + !--Set units + call set_units(dist=dist_fac*pc,mass=mass_fac*solarm,G=1.) + !--Define remaining variables using the inputs polyk = kboltz*Temperature/(mu*mass_proton_cgs)*(utime/udist)**2 rmax = Rcloud_pc*(pc/udist) @@ -141,7 +141,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, t_ff = sqrt(3.*pi/(32.*rhozero)) ! free-fall time (the characteristic timescale) epotgrav = 3./5.*totmass**2/rmax ! Gravitational potential energy lattice = 'random' - icreate_stars = 1 tmax_acc = (0.5*myr)/utime !--Set positions From 1ae874034fc2c951a00befe91e28f512a94c39ef Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 3 May 2024 09:28:45 -0700 Subject: [PATCH 512/814] (build) fix mcfost workflow failure --- .github/workflows/mcfost.yml | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/.github/workflows/mcfost.yml b/.github/workflows/mcfost.yml index 4860e7ed8..a30b1ec99 100644 --- a/.github/workflows/mcfost.yml +++ b/.github/workflows/mcfost.yml @@ -26,11 +26,6 @@ jobs: - name: install gfortran run: brew install gfortran - - name: soft link gfortran and check version - run: | - ln -s `ls $PREFIX/bin/gfortran-* | tail -1` $PREFIX/bin/gfortran - gfortran -v - - name: tap the homebrew repo run: brew tap danieljprice/all @@ -38,7 +33,7 @@ jobs: run: brew install mcfost - name: "Clone phantom" - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: "Compile phantom and link with mcfost" run: make SETUP=disc MCFOST=yes PREFIX=${PREFIX} LIBCXX=-lc++ From 66e3fcb083fa1c6e3d3bebb36e69c557171b6ebc Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 3 May 2024 09:40:22 -0700 Subject: [PATCH 513/814] (github) updated checkout and cache actions to v4; do not manually install gfortran in mcfost build --- .github/workflows/build.yml | 6 +++--- .github/workflows/mcfost.yml | 4 +--- .github/workflows/release.yml | 2 +- .github/workflows/test.yml | 2 +- 4 files changed, 6 insertions(+), 8 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index dccaebd65..54435883e 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -85,7 +85,7 @@ jobs: - name: Cache intel installation if: matrix.system == 'ifort' id: cache-intel - uses: actions/cache@v3 + uses: actions/cache@v4 with: path: | /opt/intel @@ -111,10 +111,10 @@ jobs: sudo apt-get install -y python3-matplotlib - name: "Clone phantom" - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: "Grab a copy of splash source code" - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: repository: danieljprice/splash path: splash diff --git a/.github/workflows/mcfost.yml b/.github/workflows/mcfost.yml index a30b1ec99..f89cf736d 100644 --- a/.github/workflows/mcfost.yml +++ b/.github/workflows/mcfost.yml @@ -23,9 +23,7 @@ jobs: # Steps represent a sequence of tasks that will be executed as part of the job steps: - - name: install gfortran - run: brew install gfortran - + - name: tap the homebrew repo run: brew tap danieljprice/all diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index bdba8393f..ca868d95d 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -20,7 +20,7 @@ jobs: # Steps represent a sequence of tasks that will be executed as part of the job steps: - name: checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index d78ab7eb4..1c2349f1a 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -66,7 +66,7 @@ jobs: - name: Cache intel installation if: matrix.system == 'ifort' id: cache-intel - uses: actions/cache@v3 + uses: actions/cache@v4 with: path: | /opt/intel From bd8895c162b3e5b63427525aee63d1db637450c6 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 3 May 2024 09:54:38 -0700 Subject: [PATCH 514/814] (github) use setup-fortran from fortran-lang --- .github/workflows/krome.yml | 2 +- .github/workflows/mcfost.yml | 8 +++++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/.github/workflows/krome.yml b/.github/workflows/krome.yml index 51302f869..336c8144a 100644 --- a/.github/workflows/krome.yml +++ b/.github/workflows/krome.yml @@ -27,7 +27,7 @@ jobs: toolchain: {compiler: intel-classic} steps: - - uses: awvwgk/setup-fortran@v1 + - uses: fortran-lang/setup-fortran@v1 with: compiler: ${{ matrix.toolchain.compiler }} diff --git a/.github/workflows/mcfost.yml b/.github/workflows/mcfost.yml index f89cf736d..d8ef214d5 100644 --- a/.github/workflows/mcfost.yml +++ b/.github/workflows/mcfost.yml @@ -23,7 +23,13 @@ jobs: # Steps represent a sequence of tasks that will be executed as part of the job steps: - + - uses: fortran-lang/setup-fortran@v1 + with: + compiler: gcc + + - name: Check gfortran version + run: gfortran --version + - name: tap the homebrew repo run: brew tap danieljprice/all From 7455e18d7ff03e0c69f53a953796259c1613d782 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 3 May 2024 10:02:01 -0700 Subject: [PATCH 515/814] (github) updated prefix to /opt/homebrew in mcfost build --- .github/workflows/mcfost.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/mcfost.yml b/.github/workflows/mcfost.yml index d8ef214d5..d74956d36 100644 --- a/.github/workflows/mcfost.yml +++ b/.github/workflows/mcfost.yml @@ -9,7 +9,7 @@ on: - 'README.md' env: - PREFIX: /usr/local/ + PREFIX: /opt/homebrew MCFOST_GIT: 1 SYSTEM: gfortran HOMEBREW_NO_INSTALL_CLEANUP: 1 From 7d6a0c04ff90f2220f6c240f292af5e89ee848fb Mon Sep 17 00:00:00 2001 From: fhu Date: Sat, 4 May 2024 04:59:53 +1000 Subject: [PATCH 516/814] Fix build failure --- src/main/inject_sim.f90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index f3063bcc7..78b6023b8 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -98,13 +98,13 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart,npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject - integer :: npart_old,ierr + integer :: ierr real :: tfac ! @@ -356,6 +356,8 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) case('final_dump') read(valstring,*,iostat=ierr) final_dump ngot = ngot + 1 + case default + imatch = .false. end select igotall = (ngot >= 3) From 434394675241550996854d16ea634481bc5a3e37 Mon Sep 17 00:00:00 2001 From: fhu Date: Sat, 4 May 2024 05:26:34 +1000 Subject: [PATCH 517/814] Merge --- src/main/utils_dumpfiles.f90 | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/src/main/utils_dumpfiles.f90 b/src/main/utils_dumpfiles.f90 index 936da5147..5257e8675 100644 --- a/src/main/utils_dumpfiles.f90 +++ b/src/main/utils_dumpfiles.f90 @@ -2528,19 +2528,11 @@ subroutine read_array_from_file_r4(iunit,filename,tag,array,ierr,use_block,iprin if (i==i_real4) then read(iunit,iostat=ierr) mytag if (trim(mytag)==trim(tag)) then -<<<<<<< HEAD - read(iunit, iostat=ierr) array(1:min(int(number8(j)),size(array))) + read(iunit,iostat=ierr) array(1:min(int(number8(j)),size(array))) if (iprint) print*,'->',mytag else if (iprint) print*,' ',mytag - read(iunit, iostat=ierr) -======= - read(iunit,iostat=ierr) array(1:min(int(number8(j)),size(array))) - print*,'->',mytag - else - print*,' ',mytag read(iunit,iostat=ierr) ->>>>>>> daniel/master endif else read(iunit,iostat=ierr) mytag ! tag From b4ee2458925440e6ab601ad0fdd1a46fe64185d9 Mon Sep 17 00:00:00 2001 From: fhu Date: Sat, 4 May 2024 06:51:05 +1000 Subject: [PATCH 518/814] (moddump_radiotde) remove unused variables --- src/utils/moddump_radiotde.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 6f5475ac3..c28eff047 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -59,7 +59,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) delete_particles_outside_sphere,kill_particle,shuffle_part, & eos_vars,itemp,igamma,igasP use io, only:fatal,master,id - use units, only:umass,udist,utime,set_units,unit_density,unit_ergg + use units, only:umass,udist,utime,set_units,unit_density use timestep, only:dtmax,tmax use eos, only:ieos,gmw use kernel, only:hfact_default From ef0b6df948abdb7c9487d17d54c96b6ea517c036 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Sat, 4 May 2024 18:11:34 +0200 Subject: [PATCH 519/814] (test_wind) reinforce checks on trans-sonic wind case + add test for a dusty (bowen) wind with radiative force included --- src/main/inject_wind.f90 | 4 +- src/tests/test_wind.f90 | 214 +++++++++++++++++++++++++++++---------- 2 files changed, 165 insertions(+), 53 deletions(-) diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index cca46c932..e81f8b640 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.f90 @@ -635,15 +635,15 @@ subroutine set_default_options_inject(flag) wind_mass_rate_Msun_yr = 8.2d-8 wind_injection_radius_au = 0. else - !trans-sonic wind if (icase == 1) then + !trans-sonic wind sonic_type = 1 wind_velocity_km_s = 0. wind_mass_rate_Msun_yr = 1.d-5 wind_injection_radius_au = 2. wind_temperature = 50000. - !super sonic-wind else + !super sonic-wind sonic_type = 0 wind_velocity_km_s = 20. wind_mass_rate_Msun_yr = 1.d-5 diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index ffd72aea9..58047aba5 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -30,29 +30,21 @@ module testwind !+ !---------------------------------------------------------- subroutine test_wind(ntests,npass) - use io, only:iprint,id,master,iverbose!,iwritein + use io, only:id,master!,iprint,iwritein + use inject, only:inject_type use boundary, only:set_boundary - use options, only:ieos!,icooling use physcon, only:au,solarm,solarl - use units, only:umass,set_units,utime,unit_energ,udist - use inject, only:init_inject,inject_particles,set_default_options_inject,inject_type - use eos, only:gmw,ieos,init_eos,gamma,polyk - use part, only:npart,init_part,nptmass,xyzmh_ptmass,vxyz_ptmass,xyzh,vxyzu,& - nptmass,npartoftype,igas,iTeff,iLum,iReff,massoftype,ntot - use timestep, only:time,tmax,dt,dtmax,nsteps,dtrad,dtforce,dtcourant,dterr,print_dtlog - use step_lf_global, only:step,init_step - use testutils, only:checkval,update_test_scores - use dim, only:isothermal,inject_parts,mpi - use partinject, only:update_injected_particles - use timestep_ind, only:nbinmax - use wind, only:trvurho_1D - use checksetup, only:check_setup + use units, only:set_units + use part, only:npart,xyzmh_ptmass,vxyz_ptmass,xyzh,vxyzu + use testutils, only:checkval,update_test_scores + use dim, only:mpi !use readwrite_infile, only:read_infile,write_infile integer, intent(inout) :: ntests,npass - integer :: i,ierr,nerror,istepfrac,npart_old,nfailed(9),nwarn - real :: dtinject,dtlast,t,default_particle_mass,dtext,dtnew,dtprint,dtmaxold,tprint + real, parameter :: eps_sum = 5e-15 + integer :: npart_old,nfailed(6),istepfrac + real :: dtinject,eint,ekin if (mpi) then if (id==master) write(*,"(/,a,/)") '--> SKIPPING WIND TEST (currently not working with MPI)' @@ -67,13 +59,89 @@ subroutine test_wind(ntests,npass) call set_units(dist=au,mass=solarm,G=1.d0) call set_boundary(-50.,50.,-50.,50.,-50.,50.) + +! test trans-sonic wind - no radiation, no dust + + call init_testwind(1,ntests,npass,npart_old,istepfrac,dtinject) + !debug if (id==master) call write_infile('w.in','w.log','w.ev','w_00000',iwritein,iprint) + call integrate_wind(npart_old,istepfrac,dtinject) + nfailed(:) = 0 + eint = sum(vxyzu(4,1:npart)) + ekin = sqrt(sum(vxyzu(1,1:npart)**2+vxyzu(2,1:npart)**2+vxyzu(3,1:npart)**2)) + print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart + call checkval(xyzmh_ptmass(4,1),1.199987894518367E+00,epsilon(0.),nfailed(1),'sink particle mass') + call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') + call checkval(npart,12180,0,nfailed(3),'number of ejected particles') + call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(4),'wind mass loss rate') + call checkval(eint,2.172921072880526E+03,eps_sum,nfailed(5),'total internal energy') + call checkval(ekin,1.452084518428992E+02,eps_sum,nfailed(6),'total kinetic energy') + call update_test_scores(ntests,nfailed,npass) + + +! test wind with bowen dust + radiative acceleration + + call init_testwind(2,ntests,npass,npart_old,istepfrac,dtinject) + !debug if (id==master) call write_infile('w.in','w.log','w.ev','w_00000',iwritein,iprint) + call integrate_wind(npart_old,istepfrac,dtinject) + nfailed(:) = 0 + eint = sum(vxyzu(4,1:npart)) + ekin = sqrt(sum(vxyzu(1,1:npart)**2+vxyzu(2,1:npart)**2+vxyzu(3,1:npart)**2)) + print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart + call checkval(xyzmh_ptmass(4,1),1.199987815414834E+00,epsilon(0.),nfailed(1),'sink particle mass') + call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') + call checkval(npart,21924,0,nfailed(3),'number of ejected particles') + call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(4),'wind mass loss rate') + call checkval(eint,1.670176368675748E+02,eps_sum,nfailed(5),'total internal energy') + call checkval(ekin,1.082975394957043E+02,eps_sum,nfailed(6),'total kinetic energy') + call update_test_scores(ntests,nfailed,npass) + + + if (id==master) write(*,"(/,a)") '<-- WIND TEST COMPLETE' + +end subroutine test_wind + +!----------------------------------------------------------------------- +! +subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) +! +!----------------------------------------------------------------------- + + use io, only:iverbose!,iwritein + use inject, only:init_inject,inject_particles,set_default_options_inject + use units, only:umass,utime,unit_energ,udist + use physcon, only:au,solarm,solarl + use eos, only:gmw,ieos,init_eos,gamma,polyk + use part, only:npart,init_part,nptmass,xyzmh_ptmass,vxyz_ptmass,xyzh,vxyzu,& + npartoftype,igas,iTeff,iLum,iReff,massoftype + use timestep, only:tmax,dt,dtmax,dtrad + use wind, only:trvurho_1D + use timestep_ind, only:nbinmax + use dim, only:isothermal + use checksetup, only:check_setup + use partinject, only:update_injected_particles + use testutils, only:checkval,update_test_scores + use ptmass_radiation, only:alpha_rad,isink_radiation + use dust_formation, only:idust_opacity + + integer, intent(in) :: icase + integer, intent(inout) :: ntests,npass + integer, intent(out) :: npart_old,istepfrac + real, intent(out) :: dtinject + + integer :: i,ierr,nerror,nwarn,nfailed(5) + real :: t,default_particle_mass,dtnew + call init_part() ! set properties of mass-losing sink particle nptmass = 1 xyzmh_ptmass(4,1) = 1.2*solarm/umass xyzmh_ptmass(5,1) = au/udist - xyzmh_ptmass(iTeff,1) = 50000. + if (icase == 1) then + xyzmh_ptmass(iTeff,1) = 50000. + elseif (icase == 2) then + xyzmh_ptmass(iTeff,1) = 3000. + endif xyzmh_ptmass(iReff,1) = au/udist xyzmh_ptmass(iLum,1) = 2e4 *solarl * utime / unit_energ @@ -97,10 +165,20 @@ subroutine test_wind(ntests,npass) call init_eos(ieos,ierr) iverbose = 0 - !icooling = 0 - dtmax = 1. - tmax = 8. - tprint = tmax + dtmax = 1. + tmax = 8. + !wind + bowen dust + radiation force + if (icase == 1) then + alpha_rad = 0. + isink_radiation = 0 !radiation + alpha_rad + idust_opacity = 0 !bowen opacity + elseif (icase == 2) then + alpha_rad = 1. + isink_radiation = 3 !radiation + alpha_rad + idust_opacity = 1 !bowen opacity + else + stop '[test wind] unknown test ' + endif dt = 0. dtinject = huge(dtinject) dtrad = huge(dtrad) @@ -108,34 +186,77 @@ subroutine test_wind(ntests,npass) dtnew = 0. ! trans-sonic wind - call set_default_options_inject(1) + call set_default_options_inject(icase) call check_setup(nerror,nwarn) - istepfrac = 0 nfailed(:) = 0 + istepfrac = 0 call init_inject(nerror) + npart_old = npart - !debug if (id==master) call write_infile('w.in','w.log','w.ev','w_00000',iwritein,iprint) +!trans-sonic wind - no radiation +if (icase == 1) then + ! check particle's mass + call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + npart,npart_old,npartoftype,dtinject) + call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) - ! check particle's mass - call checkval(massoftype(igas),1.490822861042279E-09,epsilon(0.),& - nfailed(1),'no errors in setting particle mass') - npart_old = npart - call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npart_old,npartoftype,dtinject) - call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) - - ! check 1D wind profile - i = size(trvurho_1D(1,:)) - !print '((5(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) - call checkval(trvurho_1D(2,i),7.058624412798283E+13,epsilon(0.),nfailed(2),'outer wind radius') - call checkval(trvurho_1D(3,i),1.112160584479353E+06,epsilon(0.),nfailed(3),'outer wind velocity') - call checkval(trvurho_1D(4,i),2.031820842001706E+12,epsilon(0.),nfailed(4),'outer wind internal energy') - call checkval(trvurho_1D(5,i),8.878887149408118E-15,epsilon(0.),nfailed(5),'outer wind density') + ! check 1D wind profile + i = size(trvurho_1D(1,:)) + print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) + call checkval(massoftype(igas),1.490822861042279E-9,epsilon(0.),nfailed(1),'setting particle mass') + call checkval(trvurho_1D(2,i),7.058624412798283E+13,epsilon(0.),nfailed(2),'1D wind terminal radius') + call checkval(trvurho_1D(3,i),1.112160584479353E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') + call checkval(trvurho_1D(4,i),2.031820842001706E+12,epsilon(0.),nfailed(4),'1D wind internal energy') + call checkval(trvurho_1D(5,i),8.878887149408118E-15,epsilon(0.),nfailed(5),'1D wind terminal density') + call update_test_scores(ntests,nfailed,npass) + endif + + !wind + radiation + if (icase == 2) then + ! check particle's mass + call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) + call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) + + ! check 1D wind profile + i = size(trvurho_1D(1,:)) + print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) + call checkval(massoftype(igas),6.820748526700016E-10,epsilon(0.),nfailed(1),'setting particle mass') + call checkval(trvurho_1D(2,i), 1.546371444697654E+14,epsilon(0.),nfailed(2),'1D wind terminal radius') + call checkval(trvurho_1D(3,i), 4.298693548460183E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') + call checkval(trvurho_1D(4,i), 4.318674031561777E+10,epsilon(0.),nfailed(4),'1D wind internal energy') + call checkval(trvurho_1D(5,i), 4.879641694552266E-16,epsilon(0.),nfailed(5),'1D wind terminal density') + call update_test_scores(ntests,nfailed,npass) + endif + + +end subroutine init_testwind + + +!----------------------------------------------------------------------- +! +subroutine integrate_wind(npart_old,istepfrac,dtinject) +! +!----------------------------------------------------------------------- + + use io, only:id,iprint,master + use timestep, only:time,tmax,dt,dtmax,nsteps,dtrad,dtforce,dtcourant,dterr,print_dtlog + use part, only:npart,init_part,xyzmh_ptmass,vxyz_ptmass,xyzh,vxyzu,npartoftype,ntot + use timestep_ind, only:nbinmax + use step_lf_global, only:step,init_step + use partinject, only:update_injected_particles + use inject, only:inject_particles + + integer, intent(inout) :: istepfrac,npart_old + real, intent(inout) :: dtinject + + real :: dtlast,t,dtext,dtnew,dtprint,dtmaxold,tprint dt = dtinject dtlast = 0. time = 0. + tprint = tmax + t = 0. call init_step(npart_old,time,dtmax) @@ -145,7 +266,7 @@ subroutine test_wind(ntests,npass) ! ! injection of new particles into simulation ! - npart_old=npart + npart_old = npart call inject_particles(t,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) dtmaxold = dtmax @@ -164,15 +285,6 @@ subroutine test_wind(ntests,npass) enddo - !print '((3(1x,es22.15),i8))',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),npart - call checkval(xyzmh_ptmass(4,1),1.199987894518367E+00,epsilon(0.),nfailed(6),'sink particle mass') - call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(7),'mass accreted') - call checkval(npart,12180,0,nfailed(8),'number of ejected particles') - call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(9),'wind mass loss rate') - call update_test_scores(ntests,nfailed,npass) - - if (id==master) write(*,"(/,a)") '<-- WIND TEST COMPLETE' - -end subroutine test_wind +end subroutine integrate_wind end module testwind From 65ab87ec4e7079f046730dfe683aedb5f2755809 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Sat, 4 May 2024 19:01:02 +0200 Subject: [PATCH 520/814] (substepping) generalize use of ieos=5,17 to all setups (call calc_muGamma) --- src/main/substepping.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 92a090f68..ac444c5d8 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -1059,6 +1059,8 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) eos_vars(imu,i) = nucleation(idmu,i) eos_vars(igamma,i) = nucleation(idgamma,i) + elseif (update_muGamma) then + call calc_muGamma(rhoi, dust_temp(i),eos_vars(imu,i),eos_vars(igamma,i), pH, pH_tot) endif ! ! COOLING From fd3f41a5da5e0776c7290796d2e9e21cc7aa24f2 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Sun, 5 May 2024 14:12:38 +0200 Subject: [PATCH 521/814] bug fixes --- src/main/substepping.F90 | 4 ++-- src/setup/setup_wind.f90 | 2 +- src/tests/test_wind.f90 | 10 +++++----- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index ac444c5d8..5c1784199 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -1014,7 +1014,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl use cooling_ism, only:nabn,dphotflag use options, only:icooling use chem, only:update_abundances,get_dphot - use dust_formation, only:evolve_dust + use dust_formation, only:evolve_dust,calc_muGamma use cooling, only:energ_cooling,cooling_in_step use part, only:rhoh #ifdef KROME @@ -1031,7 +1031,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl real, intent(in) :: dt,pmassi integer, intent(in) :: i - real :: dudtcool,rhoi,dphot + real :: dudtcool,rhoi,dphot,pH,pH_tot real :: abundi(nabn) dudtcool = 0. diff --git a/src/setup/setup_wind.f90 b/src/setup/setup_wind.f90 index 012d95aea..a6467b2b2 100644 --- a/src/setup/setup_wind.f90 +++ b/src/setup/setup_wind.f90 @@ -295,7 +295,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! avoid failures in the setup by ensuring that tmax and dtmax are large enough ! - tmax = max(tmax,100.) + !tmax = max(tmax,100.) !dtmax = max(tmax/10.,dtmax) end subroutine setpart diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index 58047aba5..edc048ea1 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -68,7 +68,7 @@ subroutine test_wind(ntests,npass) nfailed(:) = 0 eint = sum(vxyzu(4,1:npart)) ekin = sqrt(sum(vxyzu(1,1:npart)**2+vxyzu(2,1:npart)**2+vxyzu(3,1:npart)**2)) - print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart + !print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart call checkval(xyzmh_ptmass(4,1),1.199987894518367E+00,epsilon(0.),nfailed(1),'sink particle mass') call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') call checkval(npart,12180,0,nfailed(3),'number of ejected particles') @@ -86,7 +86,7 @@ subroutine test_wind(ntests,npass) nfailed(:) = 0 eint = sum(vxyzu(4,1:npart)) ekin = sqrt(sum(vxyzu(1,1:npart)**2+vxyzu(2,1:npart)**2+vxyzu(3,1:npart)**2)) - print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart + !print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart call checkval(xyzmh_ptmass(4,1),1.199987815414834E+00,epsilon(0.),nfailed(1),'sink particle mass') call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') call checkval(npart,21924,0,nfailed(3),'number of ejected particles') @@ -203,7 +203,7 @@ subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) ! check 1D wind profile i = size(trvurho_1D(1,:)) - print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) + !print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) call checkval(massoftype(igas),1.490822861042279E-9,epsilon(0.),nfailed(1),'setting particle mass') call checkval(trvurho_1D(2,i),7.058624412798283E+13,epsilon(0.),nfailed(2),'1D wind terminal radius') call checkval(trvurho_1D(3,i),1.112160584479353E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') @@ -218,9 +218,9 @@ subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) - ! check 1D wind profile + ! check 1D wind profile i = size(trvurho_1D(1,:)) - print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) + !print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) call checkval(massoftype(igas),6.820748526700016E-10,epsilon(0.),nfailed(1),'setting particle mass') call checkval(trvurho_1D(2,i), 1.546371444697654E+14,epsilon(0.),nfailed(2),'1D wind terminal radius') call checkval(trvurho_1D(3,i), 4.298693548460183E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') From 5a7532ef303e3b47775d8d5b68a076b213128417 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 6 May 2024 10:52:54 +0200 Subject: [PATCH 522/814] (CE-analysis) remove case 14 for saving particle therm. quantities into file --- src/utils/analysis_common_envelope.f90 | 54 +------------------------- 1 file changed, 2 insertions(+), 52 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 7edc51774..0a40d006f 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -62,9 +62,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) integer :: unitnum,i,ncols logical :: requires_eos_opts - !case 5 variables - real :: rhopart - !case 7 variables character(len=17), allocatable :: columns(:) @@ -76,17 +73,9 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) real, allocatable :: histogram_data(:,:) real :: ang_vel - real :: pres_1i, proint_1i, peint_1i, temp_1i - real :: troint_1i, teint_1i, entrop_1i, abad_1i, gamma1_1i, gam_1i - - !case 16 variables - real, allocatable :: thermodynamic_quantities(:,:) - real, allocatable :: radius_1i, dens_1i - - !chose analysis type if (dump_number==0) then - print "(41(a,/))", & + print "(40(a,/))", & ' 1) Sink separation', & ' 2) Bound and unbound quantities', & ' 3) Energies', & @@ -99,7 +88,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) '11) Profile of newly unbound particles', & '12) Sink properties', & '13) MESA EoS compute total entropy and other average td quantities', & - '14) MESA EoS save on file thermodynamical quantities for all particles', & '15) Gravitational drag on sinks', & '16) CoM of gas around primary core', & '17) Miscellaneous', & @@ -136,7 +124,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) xyzmh_ptmass,vxyz_ptmass,omega_corotate,dump_number) ! List of analysis options that require specifying EOS options - requires_eos_opts = any((/2,3,4,5,6,8,9,11,13,14,15,20,21,22,23,24,25,26,29,30,31,32,33,35,41/) == analysis_to_perform) + requires_eos_opts = any((/2,3,4,5,6,8,9,11,13,15,20,21,22,23,24,25,26,29,30,31,32,33,35,41/) == analysis_to_perform) if (dump_number == 0 .and. requires_eos_opts) call set_eos_options(analysis_to_perform) select case(analysis_to_perform) @@ -210,48 +198,10 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) call sink_properties(time,npart,particlemass,xyzh,vxyzu) case(13) !MESA EoS compute total entropy and other average thermodynamical quantities call bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) - case(14) !MESA EoS save on file thermodynamical quantities for all particles - allocate(thermodynamic_quantities(5,npart)) - do i=1,npart - - !particle radius - radius_1i = distance(xyzh(1:3,i)) * udist - - !particles density in code units - rhopart = rhoh(xyzh(4,i), particlemass) - dens_1i = rhopart * unit_density - - !gets entropy for the current particle - call get_eos_various_mesa(rhopart*unit_density,vxyzu(4,i) * unit_ergg, & - pres_1i,proint_1i,peint_1i,temp_1i,troint_1i, & - teint_1i,entrop_1i,abad_1i,gamma1_1i,gam_1i) - - !stores everything in an array - thermodynamic_quantities(1,i) = radius_1i - thermodynamic_quantities(2,i) = dens_1i - thermodynamic_quantities(3,i) = pres_1i - thermodynamic_quantities(4,i) = temp_1i - thermodynamic_quantities(5,i) = entrop_1i - - enddo - ncols = 5 - allocate(columns(ncols)) - columns = (/' radius', & - ' density', & - ' pressure', & - ' temperature', & - ' entropy'/) - call write_file('td_quantities', 'thermodynamics', columns, thermodynamic_quantities, npart, ncols, num) - - unitnum = unitnum + 1 - deallocate(thermodynamic_quantities) - case(15) !Gravitational drag on sinks call gravitational_drag(time,npart,particlemass,xyzh,vxyzu) - case(16) call get_core_gas_com(time,npart,xyzh,vxyzu) - case(17) ncols = 6 allocate(columns(ncols)) From 4eb6a35ee11e340bae9ae6b6d10ac0b116d4502f Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 6 May 2024 10:58:40 +0200 Subject: [PATCH 523/814] (CE-analysis) remove redundant case 17, replaced by divv functionality --- src/utils/analysis_common_envelope.f90 | 54 -------------------------- 1 file changed, 54 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 0a40d006f..376048ce8 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -62,17 +62,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) integer :: unitnum,i,ncols logical :: requires_eos_opts - !case 7 variables - character(len=17), allocatable :: columns(:) - - !case 12 variables - real :: etoti, ekini, einti, epoti, phii - - real, dimension(3) :: com_xyz, com_vxyz - real, dimension(3) :: xyz_a, vxyz_a - real, allocatable :: histogram_data(:,:) - real :: ang_vel - !chose analysis type if (dump_number==0) then print "(40(a,/))", & @@ -90,7 +79,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) '13) MESA EoS compute total entropy and other average td quantities', & '15) Gravitational drag on sinks', & '16) CoM of gas around primary core', & - '17) Miscellaneous', & '18) J-E plane', & '19) Rotation profile', & '20) Energy profile', & @@ -202,48 +190,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) call gravitational_drag(time,npart,particlemass,xyzh,vxyzu) case(16) call get_core_gas_com(time,npart,xyzh,vxyzu) - case(17) - ncols = 6 - allocate(columns(ncols)) - columns = (/' x', & - ' y', & - ' z', & - ' r', & - 'spec. energy', & - ' omega ratio'/) - - call orbit_com(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,com_xyz,com_vxyz) - - ang_vel = 0. - - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - xyz_a(1:3) = xyzmh_ptmass(1:3,i) - com_xyz(1:3) - vxyz_a(1:3) = vxyz_ptmass(1:3,i) - com_vxyz(1:3) - ang_vel = ang_vel + (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) - endif - enddo - - ang_vel = ang_vel / 2. - - allocate(histogram_data(6,npart)) - - do i=1,npart - xyz_a(1:3) = xyzh(1:3,i) - com_xyz(1:3) - vxyz_a(1:3) = vxyzu(1:3,i) - com_vxyz(1:3) - - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) - histogram_data(1:3,i) = xyzh(1:3,i) - histogram_data(4,i) = distance(xyz_a(1:3)) - histogram_data(5,i) = epoti + ekini - histogram_data(6,i) = (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) - histogram_data(6,i) = (histogram_data(6,i) - ang_vel) / ang_vel - enddo - - call write_file('specific_energy_particles', 'histogram', columns, histogram_data, size(histogram_data(1,:)), ncols, num) - - deallocate(histogram_data) - case(18) call J_E_plane(num,npart,particlemass,xyzh,vxyzu) end select From 27c5e3508f6fd5c902cbfbd413991cc0f87d19c8 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 6 May 2024 11:06:51 +0200 Subject: [PATCH 524/814] (CE-analysis) clean up case numbers --- src/utils/analysis_common_envelope.f90 | 131 ++++++++++++------------- 1 file changed, 65 insertions(+), 66 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 376048ce8..a7ec86cff 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -59,7 +59,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) integer, intent(in) :: num,npart,iunit real, intent(inout) :: xyzh(:,:),vxyzu(:,:) real, intent(in) :: particlemass,time - integer :: unitnum,i,ncols logical :: requires_eos_opts !chose analysis type @@ -74,37 +73,37 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ' 7) Simulation units and particle properties', & ' 8) Output .divv', & ' 9) EoS testing', & - '11) Profile of newly unbound particles', & - '12) Sink properties', & - '13) MESA EoS compute total entropy and other average td quantities', & - '15) Gravitational drag on sinks', & - '16) CoM of gas around primary core', & - '18) J-E plane', & - '19) Rotation profile', & - '20) Energy profile', & - '21) Recombination statistics', & - '22) Optical depth profile', & - '23) Particle tracker', & - '24) Unbound ion fraction', & - '25) Optical depth at recombination', & - '26) Envelope binding energy', & - '27) Print dumps number matching separation', & - '28) Companion mass coordinate vs. time', & - '29) Energy histogram',& - '30) Analyse disk',& - '31) Recombination energy vs time',& - '32) Binding energy profile',& - '33) planet_rvm',& - '34) Velocity histogram',& - '35) Unbound temperature',& - '36) Planet mass distribution',& - '37) Planet profile',& - '38) Velocity profile',& - '39) Angular momentum profile',& - '40) Keplerian velocity profile',& - '41) Total dust mass' + '10) Profile of newly unbound particles', & + '11) Sink properties', & + '12) MESA EoS compute total entropy and other average td quantities', & + '13) Gravitational drag on sinks', & + '14) CoM of gas around primary core', & + '15) J-E plane', & + '16) Rotation profile', & + '17) Energy profile', & + '18) Recombination statistics', & + '19) Optical depth profile', & + '20) Particle tracker', & + '21) Unbound ion fraction', & + '22) Optical depth at recombination', & + '23) Envelope binding energy', & + '24) Print dumps number matching separation', & + '25) Companion mass coordinate vs. time', & + '26) Energy histogram',& + '27) Analyse disk',& + '28) Recombination energy vs time',& + '29) Binding energy profile',& + '30) planet_rvm',& + '31) Velocity histogram',& + '32) Unbound temperature',& + '33) Planet mass distribution',& + '34) Planet profile',& + '35) Velocity profile',& + '36) Angular momentum profile',& + '37) Keplerian velocity profile',& + '38) Total dust mass' analysis_to_perform = 1 - call prompt('Choose analysis type ',analysis_to_perform,1,41) + call prompt('Choose analysis type ',analysis_to_perform,1,38) endif call reset_centreofmass(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) @@ -112,7 +111,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) xyzmh_ptmass,vxyz_ptmass,omega_corotate,dump_number) ! List of analysis options that require specifying EOS options - requires_eos_opts = any((/2,3,4,5,6,8,9,11,13,15,20,21,22,23,24,25,26,29,30,31,32,33,35,41/) == analysis_to_perform) + requires_eos_opts = any((/2,3,4,5,6,8,9,10,13,17,18,19,20,21,22,23,26,27,28,29,30,32,38/) == analysis_to_perform) if (dump_number == 0 .and. requires_eos_opts) call set_eos_options(analysis_to_perform) select case(analysis_to_perform) @@ -134,64 +133,64 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) call output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) case(9) !EoS testing call eos_surfaces - case(11) !New unbound particle profiles in time + case(10) !New unbound particle profiles in time call unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) - case(19) ! Rotation profile + case(11) !sink properties + call sink_properties(time,npart,particlemass,xyzh,vxyzu) + case(12) !MESA EoS compute total entropy and other average thermodynamical quantities + call bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) + case(13) !Gravitational drag on sinks + call gravitational_drag(time,npart,particlemass,xyzh,vxyzu) + case(14) + call get_core_gas_com(time,npart,xyzh,vxyzu) + case(15) + call J_E_plane(num,npart,particlemass,xyzh,vxyzu) + case(16) ! Rotation profile call rotation_profile(time,num,npart,xyzh,vxyzu) - case(20) ! Energy profile + case(17) ! Energy profile call energy_profile(time,npart,particlemass,xyzh,vxyzu) - case(21) ! Recombination statistics + case(18) ! Recombination statistics call recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) - case(22) ! Optical depth profile + case(19) ! Optical depth profile call tau_profile(time,num,npart,particlemass,xyzh) - case(23) ! Particle tracker + case(20) ! Particle tracker call track_particle(time,particlemass,xyzh,vxyzu) - case(24) ! Unbound ion fractions + case(21) ! Unbound ion fractions call unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) - case(25) ! Optical depth at recombination + case(22) ! Optical depth at recombination call recombination_tau(time,npart,particlemass,xyzh,vxyzu) - case(26) ! Calculate binding energy outside core + case(23) ! Calculate binding energy outside core call env_binding_ene(npart,particlemass,xyzh,vxyzu) - case(27) ! Print dump number corresponding to given set of sink-sink separations + case(24) ! Print dump number corresponding to given set of sink-sink separations call print_dump_numbers(dumpfile) - case(28) ! Companion mass coordinate (spherical mass shells) vs. time + case(25) ! Companion mass coordinate (spherical mass shells) vs. time call m_vs_t(time,npart,particlemass,xyzh) - case(29) ! Energy histogram + case(26) ! Energy histogram call energy_hist(time,npart,particlemass,xyzh,vxyzu) - case(30) ! Analyse disk around companion + case(27) ! Analyse disk around companion call analyse_disk(num,npart,particlemass,xyzh,vxyzu) - case(31) ! Recombination energy vs. time + case(28) ! Recombination energy vs. time call erec_vs_t(time,npart,particlemass,xyzh) - case(32) ! Binding energy profile + case(29) ! Binding energy profile call create_bindingEnergy_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(33) ! Planet coordinates and mass + case(30) ! Planet coordinates and mass call planet_rvm(time,particlemass,xyzh,vxyzu) - case(34) ! Velocity histogram + case(31) ! Velocity histogram call velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) - case(35) ! Unbound temperatures + case(32) ! Unbound temperatures call unbound_temp(time,npart,particlemass,xyzh,vxyzu) - case(36) ! Planet mass distribution + case(33) ! Planet mass distribution call planet_mass_distribution(time,num,npart,xyzh) - case(37) ! Calculate planet profile + case(34) ! Calculate planet profile call planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) - case(38) ! Velocity profile + case(35) ! Velocity profile call velocity_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(39) ! Angular momentum profile + case(36) ! Angular momentum profile call angular_momentum_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(40) ! Keplerian velocity profile + case(37) ! Keplerian velocity profile call vkep_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(41) !Total dust mass + case(38) !Total dust mass call total_dust_mass(time,npart,particlemass,xyzh) - case(12) !sink properties - call sink_properties(time,npart,particlemass,xyzh,vxyzu) - case(13) !MESA EoS compute total entropy and other average thermodynamical quantities - call bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) - case(15) !Gravitational drag on sinks - call gravitational_drag(time,npart,particlemass,xyzh,vxyzu) - case(16) - call get_core_gas_com(time,npart,xyzh,vxyzu) - case(18) - call J_E_plane(num,npart,particlemass,xyzh,vxyzu) end select !increase dump number counter dump_number = dump_number + 1 From f6bce570ec2045c1a7adf5a7a9f727557567a0ba Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Tue, 7 May 2024 00:37:25 +0200 Subject: [PATCH 525/814] fix test wind --- src/tests/test_wind.f90 | 54 +++++++++++++++++++++++------------------ 1 file changed, 31 insertions(+), 23 deletions(-) diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index edc048ea1..26448472d 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -23,6 +23,8 @@ module testwind private + logical :: vb = .false. + contains !---------------------------------------------------------- !+ @@ -30,15 +32,16 @@ module testwind !+ !---------------------------------------------------------- subroutine test_wind(ntests,npass) - use io, only:id,master!,iprint,iwritein - use inject, only:inject_type - use boundary, only:set_boundary - use physcon, only:au,solarm,solarl - use units, only:set_units - use part, only:npart,xyzmh_ptmass,vxyz_ptmass,xyzh,vxyzu - use testutils, only:checkval,update_test_scores - use dim, only:mpi - !use readwrite_infile, only:read_infile,write_infile + use io, only:id,master!,iprint,iwritein + use inject, only:inject_type + use boundary, only:set_boundary + use physcon, only:au,solarm,solarl + use units, only:set_units + use part, only:npart,xyzmh_ptmass,vxyzu,dust_temp + use testutils, only:checkval,update_test_scores + use dim, only:mpi,maxTdust,maxp + use allocutils, only:allocate_array + use readwrite_infile, only:read_infile,write_infile integer, intent(inout) :: ntests,npass @@ -63,36 +66,40 @@ subroutine test_wind(ntests,npass) ! test trans-sonic wind - no radiation, no dust call init_testwind(1,ntests,npass,npart_old,istepfrac,dtinject) - !debug if (id==master) call write_infile('w.in','w.log','w.ev','w_00000',iwritein,iprint) + !if (id==master) call write_infile('w.in','w.log','w.ev','w_00000',iwritein,iprint) call integrate_wind(npart_old,istepfrac,dtinject) nfailed(:) = 0 eint = sum(vxyzu(4,1:npart)) ekin = sqrt(sum(vxyzu(1,1:npart)**2+vxyzu(2,1:npart)**2+vxyzu(3,1:npart)**2)) - !print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart + if (vb) print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart call checkval(xyzmh_ptmass(4,1),1.199987894518367E+00,epsilon(0.),nfailed(1),'sink particle mass') call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') call checkval(npart,12180,0,nfailed(3),'number of ejected particles') call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(4),'wind mass loss rate') - call checkval(eint,2.172921072880526E+03,eps_sum,nfailed(5),'total internal energy') - call checkval(ekin,1.452084518428992E+02,eps_sum,nfailed(6),'total kinetic energy') + call checkval(eint,3.367417540822784E+03,eps_sum,nfailed(5),'total internal energy') + call checkval(ekin,5.524867074648309E+01,eps_sum,nfailed(6),'total kinetic energy') call update_test_scores(ntests,nfailed,npass) + maxTdust = maxp + if (allocated(dust_temp)) deallocate(dust_temp) + call allocate_array('dust_temp',dust_temp,maxTdust) + ! test wind with bowen dust + radiative acceleration call init_testwind(2,ntests,npass,npart_old,istepfrac,dtinject) - !debug if (id==master) call write_infile('w.in','w.log','w.ev','w_00000',iwritein,iprint) + !if (id==master) call write_infile('w2.in','w2.log','w2.ev','w2_00000',iwritein,iprint) call integrate_wind(npart_old,istepfrac,dtinject) nfailed(:) = 0 eint = sum(vxyzu(4,1:npart)) ekin = sqrt(sum(vxyzu(1,1:npart)**2+vxyzu(2,1:npart)**2+vxyzu(3,1:npart)**2)) - !print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart + if (vb) print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart call checkval(xyzmh_ptmass(4,1),1.199987815414834E+00,epsilon(0.),nfailed(1),'sink particle mass') call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') call checkval(npart,21924,0,nfailed(3),'number of ejected particles') call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(4),'wind mass loss rate') - call checkval(eint,1.670176368675748E+02,eps_sum,nfailed(5),'total internal energy') - call checkval(ekin,1.082975394957043E+02,eps_sum,nfailed(6),'total kinetic energy') + call checkval(eint,3.496431505098527E+02,eps_sum,nfailed(5),'total internal energy') + call checkval(ekin,1.109784837120262E+02,eps_sum,nfailed(6),'total kinetic energy') call update_test_scores(ntests,nfailed,npass) @@ -106,7 +113,7 @@ subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) ! !----------------------------------------------------------------------- - use io, only:iverbose!,iwritein + use io, only:iverbose use inject, only:init_inject,inject_particles,set_default_options_inject use units, only:umass,utime,unit_energ,udist use physcon, only:au,solarm,solarl @@ -120,6 +127,7 @@ subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) use checksetup, only:check_setup use partinject, only:update_injected_particles use testutils, only:checkval,update_test_scores + use ptmass, only:set_integration_precision use ptmass_radiation, only:alpha_rad,isink_radiation use dust_formation, only:idust_opacity @@ -132,11 +140,12 @@ subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) real :: t,default_particle_mass,dtnew call init_part() + call set_integration_precision() ! set properties of mass-losing sink particle nptmass = 1 - xyzmh_ptmass(4,1) = 1.2*solarm/umass - xyzmh_ptmass(5,1) = au/udist + xyzmh_ptmass(4,1) = 1.2*solarm/umass + xyzmh_ptmass(5,1) = au/udist if (icase == 1) then xyzmh_ptmass(iTeff,1) = 50000. elseif (icase == 2) then @@ -203,7 +212,7 @@ subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) ! check 1D wind profile i = size(trvurho_1D(1,:)) - !print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) + if (vb) print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) call checkval(massoftype(igas),1.490822861042279E-9,epsilon(0.),nfailed(1),'setting particle mass') call checkval(trvurho_1D(2,i),7.058624412798283E+13,epsilon(0.),nfailed(2),'1D wind terminal radius') call checkval(trvurho_1D(3,i),1.112160584479353E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') @@ -220,7 +229,7 @@ subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) ! check 1D wind profile i = size(trvurho_1D(1,:)) - !print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) + if (vb) print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) call checkval(massoftype(igas),6.820748526700016E-10,epsilon(0.),nfailed(1),'setting particle mass') call checkval(trvurho_1D(2,i), 1.546371444697654E+14,epsilon(0.),nfailed(2),'1D wind terminal radius') call checkval(trvurho_1D(3,i), 4.298693548460183E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') @@ -229,7 +238,6 @@ subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) call update_test_scores(ntests,nfailed,npass) endif - end subroutine init_testwind From 5da1605068096f7d47b8fdf87abb547941d6fde1 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Tue, 7 May 2024 11:05:07 +0200 Subject: [PATCH 526/814] fix isowind default setup + unsued variables --- src/main/inject_wind.f90 | 32 ++++++++++++++++++++++++++------ src/setup/setup_wind.f90 | 13 +++---------- 2 files changed, 29 insertions(+), 16 deletions(-) diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index e81f8b640..21b689a46 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.f90 @@ -78,7 +78,7 @@ subroutine init_inject(ierr) use options, only:icooling,ieos use io, only:fatal,iverbose use setbinary, only:get_eccentricity_vector - use timestep, only:tmax,dtmax + use timestep, only:tmax use wind_equations, only:init_wind_equations use wind, only:setup_wind,save_windprofile use physcon, only:mass_proton_cgs, kboltz, Rg, days, km, au, years, solarm, pi, Gg @@ -88,12 +88,11 @@ subroutine init_inject(ierr) use part, only:xyzmh_ptmass,vxyz_ptmass,massoftype,igas,iboundary,imloss,ilum,iTeff,iReff,nptmass use injectutils, only:get_sphere_resolution,get_parts_per_sphere,get_neighb_distance use cooling_molecular, only:do_molecular_cooling,fit_rho_power,fit_rho_inner,fit_vel,r_compOrb - use ptmass_radiation, only:alpha_rad integer, intent(out) :: ierr - integer :: ires_min,nzones_per_sonic_point,new_nfill + integer :: nzones_per_sonic_point,new_nfill real :: mV_on_MdotR,initial_wind_velocity_cgs,dist_to_sonic_point,semimajoraxis_cgs - real :: dr,dp,mass_of_particles1,tcross,tend,vesc,rsonic,tsonic,initial_Rinject,tboundary + real :: dr,dp,mass_of_particles1,tcross,tend,rsonic,tsonic,initial_Rinject,tboundary real :: separation_cgs,wind_mass_rate_cgs,wind_velocity_cgs,ecc(3),eccentricity,Tstar if (icooling > 0) nwrite = nwrite+1 @@ -232,6 +231,7 @@ subroutine init_inject(ierr) time_between_spheres = mass_of_spheres / wind_mass_rate massoftype(iboundary) = mass_of_particles if (time_between_spheres > tmax) then + call logging(initial_wind_velocity_cgs,rsonic,Tsonic,Tboundary) print *,'time_between_spheres = ',time_between_spheres,' < tmax = ',tmax call fatal(label,'no shell ejection : tmax < time_between_spheres') endif @@ -268,8 +268,29 @@ subroutine init_inject(ierr) print*,'got dr/dp = ',dr/dp,' compared to desired dr on dp = ',wind_shell_spacing endif + xyzmh_ptmass(imloss,wind_emitting_sink) = wind_mass_rate !logging + call logging(initial_wind_velocity_cgs,rsonic,Tsonic,Tboundary) + +end subroutine init_inject + + +!----------------------------------------------------------------------- + +subroutine logging(initial_wind_velocity_cgs,rsonic,Tsonic,Tboundary) + +!----------------------------------------------------------------------- + + use physcon, only:pi,gg + use units, only:utime,udist + use timestep, only:dtmax + use ptmass_radiation, only:alpha_rad + + real, intent(in) :: initial_wind_velocity_cgs,rsonic,Tsonic,Tboundary + integer :: ires_min + real :: vesc + vesc = sqrt(2.*Gg*Mstar_cgs*(1.-alpha_rad)/Rstar_cgs) print*,'mass_of_particles = ',mass_of_particles print*,'particles per sphere = ',particles_per_sphere @@ -309,9 +330,8 @@ subroutine init_inject(ierr) if (iwind_resolution < ires_min) print *,'WARNING! resolution too low to pass sonic point : iwind_resolution < ',ires_min endif - xyzmh_ptmass(imloss,wind_emitting_sink) = wind_mass_rate +end subroutine logging -end subroutine init_inject !----------------------------------------------------------------------- !+ diff --git a/src/setup/setup_wind.f90 b/src/setup/setup_wind.f90 index a6467b2b2..99d2f364c 100644 --- a/src/setup/setup_wind.f90 +++ b/src/setup/setup_wind.f90 @@ -82,7 +82,7 @@ subroutine set_default_parameters_wind() wind_gamma = 5./3. if (isothermal) then - T_wind = 30000. + T_wind = 100000. temp_exponent = 0.5 ! primary_racc_au = 0.465 ! primary_mass_msun = 1.5 @@ -132,13 +132,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use part, only: xyzmh_ptmass, vxyz_ptmass, nptmass, igas, iTeff, iLum, iReff use physcon, only: au, solarm, mass_proton_cgs, kboltz, solarl use units, only: umass,set_units,unit_velocity,utime,unit_energ,udist - use inject, only: init_inject,set_default_options_inject + use inject, only: set_default_options_inject use setbinary, only: set_binary use sethierarchical, only: set_multiple use io, only: master use eos, only: gmw,ieos,isink,qfacdisc use spherical, only: set_sphere - use timestep, only: tmax!,dtmax integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -156,7 +155,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_default_parameters_wind() filename = trim(fileprefix)//'.in' inquire(file=filename,exist=iexist) - if (.not. iexist) call set_default_options_inject + if (.not. iexist) call set_default_options_inject() !--general parameters ! @@ -292,12 +291,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif polyk = kboltz*T_wind/(mass_proton_cgs * gmw * unit_velocity**2) - ! - ! avoid failures in the setup by ensuring that tmax and dtmax are large enough - ! - !tmax = max(tmax,100.) - !dtmax = max(tmax/10.,dtmax) - end subroutine setpart !---------------------------------------------------------------- From a1385be1134a1c5fdba7f82901a494c4ddea6d3d Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Tue, 7 May 2024 17:37:18 +0200 Subject: [PATCH 527/814] (test_wind) condition test on radiatoin force if ISINK_RADIATION is defined --- src/tests/test_wind.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index 26448472d..59d90bd80 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -81,6 +81,7 @@ subroutine test_wind(ntests,npass) call update_test_scores(ntests,nfailed,npass) +#ifdef ISINK_RADIATION maxTdust = maxp if (allocated(dust_temp)) deallocate(dust_temp) call allocate_array('dust_temp',dust_temp,maxTdust) @@ -101,7 +102,7 @@ subroutine test_wind(ntests,npass) call checkval(eint,3.496431505098527E+02,eps_sum,nfailed(5),'total internal energy') call checkval(ekin,1.109784837120262E+02,eps_sum,nfailed(6),'total kinetic energy') call update_test_scores(ntests,nfailed,npass) - +#endif if (id==master) write(*,"(/,a)") '<-- WIND TEST COMPLETE' From c52b4d030bbbf2110f6d6155f8fb0ff1c24801a4 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 7 May 2024 17:32:53 +0100 Subject: [PATCH 528/814] Move cooling icooling=9 call to derivs --- build/Makefile | 2 +- src/main/cooling.f90 | 10 ++--- ..._stamatellos.f90 => cooling_radapprox.f90} | 41 +++++++++++-------- src/main/deriv.F90 | 9 +++- src/main/eos.f90 | 5 +-- src/main/step_leapfrog.F90 | 7 +--- 6 files changed, 41 insertions(+), 33 deletions(-) rename src/main/{cooling_stamatellos.f90 => cooling_radapprox.f90} (88%) diff --git a/build/Makefile b/build/Makefile index e248ee4b9..6a833e926 100644 --- a/build/Makefile +++ b/build/Makefile @@ -498,7 +498,7 @@ SRCCHEM= fs_data.f90 mol_data.f90 utils_spline.f90 \ cooling_koyamainutsuka.f90 \ cooling_ism.f90 \ cooling_molecular.f90 \ - cooling_stamatellos.f90\ + cooling_radapprox.f90\ cooling_functions.f90 \ cooling_solver.f90 \ h2chem.f90 cooling.f90 diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index c85316524..8a69ed935 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -15,7 +15,7 @@ module cooling ! 5 = Koyama & Inutuska (2002) [explicit] ! 6 = Koyama & Inutuska (2002) [implicit] ! 7 = Gammie cooling power law [explicit] -! 9 = Stamatellos et al. (2007) [implicit] +! 9 = Young et al. (2024) [implicit] ! ! :References: ! Gail & Sedlmayr textbook Physics and chemistry of Circumstellar dust shells @@ -29,7 +29,7 @@ module cooling ! ! :Dependencies: chem, cooling_gammie, cooling_gammie_PL, cooling_ism, ! cooling_koyamainutsuka, cooling_molecular, cooling_solver, -! cooling_stamatellos, dim, eos, eos_stamatellos, infile_utils, io, +! cooling_radapprox, dim, eos, eos_stamatellos, infile_utils, io, ! options, part, physcon, timestep, units, viscosity ! @@ -70,7 +70,7 @@ subroutine init_cooling(id,master,iprint,ierr) use cooling_koyamainutsuka, only:init_cooling_KI02 use cooling_solver, only:init_cooling_solver use eos_stamatellos, only:read_optab,eos_file - use cooling_stamatellos, only: init_star,od_method + use cooling_radapprox, only: init_star,od_method use viscosity, only:irealvisc integer, intent(in) :: id,master,iprint @@ -207,7 +207,7 @@ subroutine write_options_cooling(iunit) use cooling_gammie_PL, only:write_options_cooling_gammie_PL use cooling_molecular, only:write_options_molecularcooling use cooling_solver, only:write_options_cooling_solver - use cooling_stamatellos, only:write_options_cooling_stamatellos + use cooling_radapprox, only:write_options_cooling_stamatellos integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling cooling' @@ -244,7 +244,7 @@ subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) use cooling_ism, only:read_options_cooling_ism use cooling_molecular, only:read_options_molecular_cooling use cooling_solver, only:read_options_cooling_solver - use cooling_stamatellos, only:read_options_cooling_stamatellos + use cooling_radapprox, only:read_options_cooling_stamatellos character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_radapprox.f90 similarity index 88% rename from src/main/cooling_stamatellos.f90 rename to src/main/cooling_radapprox.f90 index 2c9fb4c4f..e72825df2 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_radapprox.f90 @@ -4,7 +4,7 @@ ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.bitbucket.io/ ! !--------------------------------------------------------------------------! -module cooling_stamatellos +module cooling_radapprox ! ! Cooling method of Stamatellos et al. 2007 ! @@ -24,7 +24,7 @@ module cooling_stamatellos integer :: isink_star ! index of sink to use as illuminating star 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 :: radcool_update_energ,write_options_cooling_stamatellos,read_options_cooling_stamatellos public :: init_star contains @@ -61,8 +61,8 @@ end subroutine init_star ! ! Do cooling calculation ! -! edit this to make a loop and update energy to return evolved energy array. -subroutine cooling_S07(npart,xyzh,energ,Tfloor,dudt_sph,dt) +! update energy to return evolved energy array. +subroutine radcool_update_energ(dt,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 @@ -71,8 +71,8 @@ subroutine cooling_S07(npart,xyzh,energ,Tfloor,dudt_sph,dt) use part, only:xyzmh_ptmass,rhoh,massoftype,igas integer,intent(in) :: npart - real,intent(in) :: dudt_sph(:),xyzh(:,:),Tfloor,dt - real,intent(inout) :: energ(:) + real,intent(in) :: xyzh(:,:),dt,Tfloor + real,intent(inout) :: energ(:),dudt_sph(:) real :: dudti_cool,ui,rhoi real :: coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot @@ -80,13 +80,13 @@ subroutine cooling_S07(npart,xyzh,energ,Tfloor,dudt_sph,dt) real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi integer :: i - !omp parallel do default(none) & - !omp shared(npart,duFLD,xyzh,energ,rhoh,massoftype,igas,xyzmh_ptmass) & - !omp shared(isink_star,pi,steboltz,solarl,Rg,doFLD,ttherm_store,teqi_store) & - !omp shared(opac_store,Tfloor,dt,dudt_sph) - !omp private(i,poti,du_FLDi,xi,yi,zi,ui,rhoi,ri2,coldensi,kappaBari) & - !omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot) & - !omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,poti,presi,Hcomb) + !$omp parallel do default(none) & + !$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) & + !$omp shared(opac_store,Tfloor,dt,dudt_sph,utime,udist,umass,unit_ergg,gradP_cool) & + !$omp private(i,poti,du_FLDi,xi,yi,zi,ui,rhoi,ri2,coldensi,kappaBari,Ti) & + !$omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot) & + !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb,Lstar,dudti_cool) overpart: do i=1,npart poti = Gpot_cool(i) du_FLDi = duFLD(i) @@ -204,7 +204,7 @@ subroutine cooling_S07(npart,xyzh,energ,Tfloor,dudt_sph,dt) print *, "rhoi=",rhoi, "Ti=", Ti print *, "opaci=",opaci,"coldensi=",coldensi,"dudt_sphi",dudt_sph(i) print *, "dt=",dt,"tthermi=", tthermi,"umini=", umini - print *, "dudti_rad=", dudti_rad ,"dudt_dlf=",du_fldi,"ueqi=",ueqi,"ui=",ui + print *, "dudti_rad=", dudti_rad ,"dudt_fld=",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 @@ -213,10 +213,17 @@ subroutine cooling_S07(npart,xyzh,energ,Tfloor,dudt_sph,dt) ! evolve energy energ(i) = energ(i) + dudti_cool * dt - + enddo overpart + !$omp end parallel do + ! zero fxyzu(4,:) + !$omp parallel do shared(dudt_sph) private(i) schedule(runtime) + do i=1,npart + dudt_sph(i) = 0d0 + enddo + !$omp end parallel do -end subroutine cooling_S07 +end subroutine radcool_update_energ subroutine write_options_cooling_stamatellos(iunit) @@ -274,5 +281,5 @@ subroutine read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ie end subroutine read_options_cooling_stamatellos -end module cooling_stamatellos +end module cooling_radapprox diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index fd6b06ceb..18d58ff12 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -61,7 +61,9 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& use cons2prim, only:cons2primall,cons2prim_everything,prim2consall use metric_tools, only:init_metric use radiation_implicit, only:do_radiation_implicit,ierr_failed_to_converge - use options, only:implicit_radiation,implicit_radiation_store_drad,use_porosity + use options, only:implicit_radiation,implicit_radiation_store_drad,use_porosity,icooling + use cooling_radapprox, only:radcool_update_energ + use cooling, only:Tfloor integer, intent(in) :: icall integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -181,6 +183,11 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& if (use_porosity) call get_probastick(npart,xyzh,ddustprop(1,:),dustprop,dustgasprop,filfac) endif +! +! update energy if using radiative cooling approx (icooling=9) and set fxyzu(4,:) to zero +! + if (icooling == 9 .and. dt > 0.0) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) + ! ! compute dust temperature ! diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 92b6ec4b7..f23945122 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -427,7 +427,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam case(21) ! -!--interpolate tabulated eos from Stamatellos+(2007). For use with icooling=8 +!--interpolate tabulated eos from Stamatellos+(2007). For use with icooling=9 ! if (eni < 0.) then call fatal('eos (stamatellos)','utherm < 0',var='u',val=eni) @@ -439,9 +439,6 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam presi = cgspresi/unit_pressure ponrhoi = presi/rhoi gammai = 1.d0 + presi/(eni*rhoi) - !if (gammai < 1.d0 .or. gammai > 2.d0) then - ! print *, gammai, tempi, mui,cgseni,cgsrhoi,cgspresi - !endif spsoundi = sqrt(gammai*ponrhoi) case default diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index a3fcd831b..514bdc61a 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -126,8 +126,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use eos, only:equationofstate use substepping, only:substep,substep_gr, & substep_sph_gr,substep_sph - use cooling_stamatellos, only:cooling_S07 - use cooling, only:Tfloor integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -251,12 +249,11 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else call substep_sph_gr(dtsph,npart,xyzh,vxyzu,dens,pxyzu,metrics) endif - else + elseif (icooling /= 9) then 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,fsink_old,nbinmax,ibin_wake) - if (icooling == 9) call cooling_S07(npart,xyzh,vxyzu(4,:),Tfloor,fxyzu(4,:),dtsph) else call substep_sph(dtsph,npart,xyzh,vxyzu) endif @@ -394,7 +391,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) dustpred,ddustevol,filfacpred,dustfrac,eos_vars,timei,dtsph,dtnew,& ppred,dens,metrics) - if (do_radiation .and. implicit_radiation) then + if (do_radiation .and. implicit_radiation .or. icooling == 9) then rad = radpred vxyzu(4,1:npart) = vpred(4,1:npart) endif From 6835bd154d782a8f94a52a8acec8a291d610a0c0 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 9 May 2024 16:11:37 +0200 Subject: [PATCH 529/814] fix accreted flag uninitialized --- src/main/substepping.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index e0f2f35b8..aa7380beb 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -467,6 +467,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & nsubsteps = 0 dtextforce_min = huge(dt) done = .false. + accreted = .false. substeps: do while (timei <= t_end_step .and. .not.done) force_count = 0 From dabe2a2a26972cb7cc8bcb858131dca02b0f7f8c Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 10 May 2024 19:33:52 +0200 Subject: [PATCH 530/814] remove runtime option and set use_regnbody in the setup file --- src/main/ptmass.F90 | 3 --- src/setup/setup_starcluster.f90 | 14 +++++++++----- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 111055354..016c77d8d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1947,7 +1947,6 @@ subroutine write_options_ptmass(iunit) call write_inopt(f_acc,'f_acc','particles < f_acc*h_acc accreted without checks',iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) - call write_inopt(use_regnbody, 'use_regnbody', 'Subsystem (SD and secular and AR) integration method', iunit) end subroutine write_options_ptmass @@ -2022,8 +2021,6 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) r_merge_cond if (r_merge_cond > 0. .and. r_merge_cond < r_merge_uncond) call fatal(label,'0 < r_merge_cond < r_merge_uncond') ngot = ngot + 1 - case('use_regnbody') - read(valstring,*,iostat=ierr) use_regnbody case default imatch = .false. end select diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index 52af1c30f..429558843 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -46,10 +46,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use physcon, only:solarm,kpc,pi,au,years,pc use io, only:fatal,iprint,master use eos, only:gmw - use timestep, only:dtmax + use timestep, only:dtmax,tmax use spherical, only:set_sphere use datafiles, only:find_phantom_datafile - use ptmass, only:use_fourthorder + use ptmass, only:use_fourthorder,use_regnbody integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -61,6 +61,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real, intent(out) :: vxyzu(:,:) character(len=len(fileprefix)+6) :: setupfile character(len=len(datafile)) :: filename + integer :: ntot integer :: ierr,i real :: xcom(3),vcom(3),mtot real :: psep @@ -78,9 +79,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, polyk = 0. gamma = 5./3. gmw = 0.6 ! completely ionized, solar abu; eventually needs to be WR abu - dtmax = 0.01 + dtmax = 1.e-5 + tmax = 0.001 use_fourthorder = .true. - m_gas = 1.e-20 + use_regnbody = .false. + m_gas = 1.e-4 + ntot = 2**21 ! ! read setup parameters from the .setup file ! if file does not exist, then ask for user input @@ -132,7 +136,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! setup initial sphere of particles to prevent initialisation problems ! psep = 1.0 - call set_sphere('cubic',id,master,0.,10.,psep,hfact,npart,xyzh) + call set_sphere('random',id,master,0.,10.,psep,hfact,npart,xyzh,np_requested=ntot) vxyzu(4,:) = 5.317e-4 npartoftype(igas) = npart From 476fc4180bd8942f4944e6c8812af9e9efacb8ec Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 13 May 2024 12:48:42 +0200 Subject: [PATCH 531/814] (test_wind) make tests on bulk quantities depend on setup parameters --- src/tests/test_wind.f90 | 84 ++++++++++++++++++++++++++++++----------- 1 file changed, 62 insertions(+), 22 deletions(-) diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index 59d90bd80..6c3039187 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -32,22 +32,26 @@ module testwind !+ !---------------------------------------------------------- subroutine test_wind(ntests,npass) - use io, only:id,master!,iprint,iwritein + use io, only:id,master,iprint,iwritein use inject, only:inject_type use boundary, only:set_boundary use physcon, only:au,solarm,solarl use units, only:set_units use part, only:npart,xyzmh_ptmass,vxyzu,dust_temp use testutils, only:checkval,update_test_scores - use dim, only:mpi,maxTdust,maxp + use dim, only:mpi,maxTdust,maxp,sink_radiation,nucleation,inject_parts,ind_timesteps use allocutils, only:allocate_array use readwrite_infile, only:read_infile,write_infile + use dust, only:idrag + use options, only:overcleanfac,avdecayconst,alpha,alphamax,psidecayfac,& + iresistive_heating,alphaB integer, intent(inout) :: ntests,npass real, parameter :: eps_sum = 5e-15 integer :: npart_old,nfailed(6),istepfrac real :: dtinject,eint,ekin + logical :: testkd,testcyl,test2 if (mpi) then if (id==master) write(*,"(/,a,/)") '--> SKIPPING WIND TEST (currently not working with MPI)' @@ -59,14 +63,25 @@ subroutine test_wind(ntests,npass) if (id==master) write(*,"(/,a,/)") '--> TESTING WIND MODULE' endif + print *,'@@@@@@@@@@@@@@@@@@@ ','sink_radiation=',sink_radiation,'nucleation=',nucleation,& + 'inject_parts=',inject_parts + print *,'@@@@@@@@@@@@@@@@@@@ ','psidecayfac=',psidecayfac,'overcleanfac=',overcleanfac,& + 'alpha=',alpha,'alphamax=',alphamax,'alphaB=',alphaB,'avdecayconst=',avdecayconst,& + 'iresistive_heating=',iresistive_heating,'idrag=',idrag,'ind_timesteps=',ind_timesteps + call set_units(dist=au,mass=solarm,G=1.d0) call set_boundary(-50.,50.,-50.,50.,-50.,50.) + testkd = sink_radiation .and. nucleation .and. alphamax == 1. .and. ind_timesteps + test2 = .not.sink_radiation .and. .not.nucleation .and. alphamax == 1. .and. .not.ind_timesteps + testcyl = .not.sink_radiation .and. .not.nucleation .and. alphamax == 1. .and. ind_timesteps + + print *,'testkd=',testkd,' testcyl=',testcyl,' test2=',test2 ! test trans-sonic wind - no radiation, no dust call init_testwind(1,ntests,npass,npart_old,istepfrac,dtinject) - !if (id==master) call write_infile('w.in','w.log','w.ev','w_00000',iwritein,iprint) + if (id==master) call write_infile('w.in','w.log','w.ev','w_00000',iwritein,iprint) call integrate_wind(npart_old,istepfrac,dtinject) nfailed(:) = 0 eint = sum(vxyzu(4,1:npart)) @@ -76,33 +91,58 @@ subroutine test_wind(ntests,npass) call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') call checkval(npart,12180,0,nfailed(3),'number of ejected particles') call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(4),'wind mass loss rate') - call checkval(eint,3.367417540822784E+03,eps_sum,nfailed(5),'total internal energy') - call checkval(ekin,5.524867074648309E+01,eps_sum,nfailed(6),'total kinetic energy') + if (testcyl) then + call checkval(eint,3.360686893182378E+03,eps_sum,nfailed(5),'total internal energy') + call checkval(ekin,5.605632523862468E+01,eps_sum,nfailed(6),'total kinetic energy') + elseif (testkd) then + call checkval(eint,3.164153170427767E+03,eps_sum,nfailed(5),'total internal energy') + call checkval(ekin,6.101010545772693E+01,eps_sum,nfailed(6),'total kinetic energy') + elseif (test2) then + call checkval(eint,3.367417540822784E+03,eps_sum,nfailed(5),'total internal energy') + call checkval(ekin,5.524867074648306E+01,eps_sum,nfailed(6),'total kinetic energy') + else!if (test) + call checkval(eint,3.179016341424608E+03,eps_sum,nfailed(5),'total internal energy') + call checkval(ekin,6.005124961952793E+01,eps_sum,nfailed(6),'total kinetic energy') + !else + ! stop 'problem1 identifying setup?' + endif call update_test_scores(ntests,nfailed,npass) -#ifdef ISINK_RADIATION - maxTdust = maxp - if (allocated(dust_temp)) deallocate(dust_temp) - call allocate_array('dust_temp',dust_temp,maxTdust) + if (sink_radiation) then ! test wind with bowen dust + radiative acceleration - call init_testwind(2,ntests,npass,npart_old,istepfrac,dtinject) + maxTdust = maxp + if (allocated(dust_temp)) deallocate(dust_temp) + call allocate_array('dust_temp',dust_temp,maxTdust) + + call init_testwind(2,ntests,npass,npart_old,istepfrac,dtinject) !if (id==master) call write_infile('w2.in','w2.log','w2.ev','w2_00000',iwritein,iprint) - call integrate_wind(npart_old,istepfrac,dtinject) - nfailed(:) = 0 - eint = sum(vxyzu(4,1:npart)) - ekin = sqrt(sum(vxyzu(1,1:npart)**2+vxyzu(2,1:npart)**2+vxyzu(3,1:npart)**2)) - if (vb) print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart - call checkval(xyzmh_ptmass(4,1),1.199987815414834E+00,epsilon(0.),nfailed(1),'sink particle mass') - call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') - call checkval(npart,21924,0,nfailed(3),'number of ejected particles') - call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(4),'wind mass loss rate') - call checkval(eint,3.496431505098527E+02,eps_sum,nfailed(5),'total internal energy') - call checkval(ekin,1.109784837120262E+02,eps_sum,nfailed(6),'total kinetic energy') + call integrate_wind(npart_old,istepfrac,dtinject) + nfailed(:) = 0 + eint = sum(vxyzu(4,1:npart)) + ekin = sqrt(sum(vxyzu(1,1:npart)**2+vxyzu(2,1:npart)**2+vxyzu(3,1:npart)**2)) + if (vb) print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart + call checkval(xyzmh_ptmass(4,1),1.199987815414834E+00,epsilon(0.),nfailed(1),'sink particle mass') + call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') + call checkval(npart,21924,0,nfailed(3),'number of ejected particles') + call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(4),'wind mass loss rate') + if (testkd) then + call checkval(eint,2.187465510809545E+02,eps_sum,nfailed(5),'total internal energy') + call checkval(ekin,1.709063901093157E+02,eps_sum,nfailed(6),'total kinetic energy') + else!if (test) then + call checkval(eint,2.218461223513083E+02,eps_sum,nfailed(5),'total internal energy') + call checkval(ekin,1.709669096834302E+02,eps_sum,nfailed(6),'total kinetic energy') + !else + ! stop 'problem2 identifying setup?' + endif + else + if (id==master) write(*,"(/,a,/)") ' SKIPPING SINK RADIATION TEST' + !call checkval(eint,3.496431505098527E+02,eps_sum,nfailed(5),'total internal energy') + !call checkval(ekin,1.109784837120262E+02,eps_sum,nfailed(6),'total kinetic energy') + endif call update_test_scores(ntests,nfailed,npass) -#endif if (id==master) write(*,"(/,a)") '<-- WIND TEST COMPLETE' From 13513bb3c24dc25e761b03c568736ad63a409ce0 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 13 May 2024 19:55:11 +0200 Subject: [PATCH 532/814] (test_wind) adjust tolerence + cleaning --- src/tests/test_wind.f90 | 56 +++++++++++++---------------------------- 1 file changed, 18 insertions(+), 38 deletions(-) diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index 6c3039187..3e32321e6 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -24,8 +24,6 @@ module testwind private logical :: vb = .false. - -contains !---------------------------------------------------------- !+ ! Unit tests of timestepping and boundary crossing @@ -39,17 +37,15 @@ subroutine test_wind(ntests,npass) use units, only:set_units use part, only:npart,xyzmh_ptmass,vxyzu,dust_temp use testutils, only:checkval,update_test_scores - use dim, only:mpi,maxTdust,maxp,sink_radiation,nucleation,inject_parts,ind_timesteps + use dim, only:mpi,maxTdust,maxp,sink_radiation,nucleation,ind_timesteps use allocutils, only:allocate_array + use options, only:alphamax use readwrite_infile, only:read_infile,write_infile - use dust, only:idrag - use options, only:overcleanfac,avdecayconst,alpha,alphamax,psidecayfac,& - iresistive_heating,alphaB integer, intent(inout) :: ntests,npass - real, parameter :: eps_sum = 5e-15 - integer :: npart_old,nfailed(6),istepfrac + real, parameter :: eps_sum = 1e-14 + integer :: npart_old,nfailed(5),istepfrac real :: dtinject,eint,ekin logical :: testkd,testcyl,test2 @@ -63,12 +59,6 @@ subroutine test_wind(ntests,npass) if (id==master) write(*,"(/,a,/)") '--> TESTING WIND MODULE' endif - print *,'@@@@@@@@@@@@@@@@@@@ ','sink_radiation=',sink_radiation,'nucleation=',nucleation,& - 'inject_parts=',inject_parts - print *,'@@@@@@@@@@@@@@@@@@@ ','psidecayfac=',psidecayfac,'overcleanfac=',overcleanfac,& - 'alpha=',alpha,'alphamax=',alphamax,'alphaB=',alphaB,'avdecayconst=',avdecayconst,& - 'iresistive_heating=',iresistive_heating,'idrag=',idrag,'ind_timesteps=',ind_timesteps - call set_units(dist=au,mass=solarm,G=1.d0) call set_boundary(-50.,50.,-50.,50.,-50.,50.) @@ -76,8 +66,6 @@ subroutine test_wind(ntests,npass) test2 = .not.sink_radiation .and. .not.nucleation .and. alphamax == 1. .and. .not.ind_timesteps testcyl = .not.sink_radiation .and. .not.nucleation .and. alphamax == 1. .and. ind_timesteps - print *,'testkd=',testkd,' testcyl=',testcyl,' test2=',test2 - ! test trans-sonic wind - no radiation, no dust call init_testwind(1,ntests,npass,npart_old,istepfrac,dtinject) @@ -90,21 +78,18 @@ subroutine test_wind(ntests,npass) call checkval(xyzmh_ptmass(4,1),1.199987894518367E+00,epsilon(0.),nfailed(1),'sink particle mass') call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') call checkval(npart,12180,0,nfailed(3),'number of ejected particles') - call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(4),'wind mass loss rate') if (testcyl) then - call checkval(eint,3.360686893182378E+03,eps_sum,nfailed(5),'total internal energy') - call checkval(ekin,5.605632523862468E+01,eps_sum,nfailed(6),'total kinetic energy') + call checkval(eint,3.360686893182378E+03,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,5.605632523862468E+01,eps_sum,nfailed(5),'total kinetic energy') elseif (testkd) then - call checkval(eint,3.164153170427767E+03,eps_sum,nfailed(5),'total internal energy') - call checkval(ekin,6.101010545772693E+01,eps_sum,nfailed(6),'total kinetic energy') + call checkval(eint,3.164153170427767E+03,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,6.101010545772693E+01,eps_sum,nfailed(5),'total kinetic energy') elseif (test2) then - call checkval(eint,3.367417540822784E+03,eps_sum,nfailed(5),'total internal energy') - call checkval(ekin,5.524867074648306E+01,eps_sum,nfailed(6),'total kinetic energy') - else!if (test) - call checkval(eint,3.179016341424608E+03,eps_sum,nfailed(5),'total internal energy') - call checkval(ekin,6.005124961952793E+01,eps_sum,nfailed(6),'total kinetic energy') - !else - ! stop 'problem1 identifying setup?' + call checkval(eint,3.367417540822784E+03,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,5.524867074648306E+01,eps_sum,nfailed(5),'total kinetic energy') + else + call checkval(eint,3.179016341424608E+03,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,6.005124961952793E+01,eps_sum,nfailed(5),'total kinetic energy') endif call update_test_scores(ntests,nfailed,npass) @@ -127,20 +112,15 @@ subroutine test_wind(ntests,npass) call checkval(xyzmh_ptmass(4,1),1.199987815414834E+00,epsilon(0.),nfailed(1),'sink particle mass') call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') call checkval(npart,21924,0,nfailed(3),'number of ejected particles') - call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(4),'wind mass loss rate') if (testkd) then - call checkval(eint,2.187465510809545E+02,eps_sum,nfailed(5),'total internal energy') - call checkval(ekin,1.709063901093157E+02,eps_sum,nfailed(6),'total kinetic energy') - else!if (test) then - call checkval(eint,2.218461223513083E+02,eps_sum,nfailed(5),'total internal energy') - call checkval(ekin,1.709669096834302E+02,eps_sum,nfailed(6),'total kinetic energy') - !else - ! stop 'problem2 identifying setup?' + call checkval(eint,2.187465510809545E+02,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,1.709063901093157E+02,eps_sum,nfailed(5),'total kinetic energy') + else + call checkval(eint,2.218461223513102E+02,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,1.709669096834302E+02,eps_sum,nfailed(5),'total kinetic energy') endif else if (id==master) write(*,"(/,a,/)") ' SKIPPING SINK RADIATION TEST' - !call checkval(eint,3.496431505098527E+02,eps_sum,nfailed(5),'total internal energy') - !call checkval(ekin,1.109784837120262E+02,eps_sum,nfailed(6),'total kinetic energy') endif call update_test_scores(ntests,nfailed,npass) From 256a6c8d50a086d2f335aa5104e746dd2e4d9d1b Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 13 May 2024 22:03:27 +0200 Subject: [PATCH 533/814] bug fix --- src/tests/test_wind.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index 3e32321e6..62ddefb1b 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -24,6 +24,8 @@ module testwind private logical :: vb = .false. + + contains !---------------------------------------------------------- !+ ! Unit tests of timestepping and boundary crossing From afe46fdfe164f17890c16a1551fc31424ae5833f Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 13 May 2024 16:23:57 -0700 Subject: [PATCH 534/814] (#543) MAXP should not be hardwired in the SETUP block; use phantomsetup --maxp=1e8 instead; fixes #543 --- build/Makefile_setups | 5 ----- 1 file changed, 5 deletions(-) diff --git a/build/Makefile_setups b/build/Makefile_setups index 55347ffb0..0ae51a8fb 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -455,7 +455,6 @@ ifeq ($(SETUP), nimhdshock) NONIDEALMHD=yes KERNEL=WendlandC4 ISOTHERMAL=yes - MAXP=6000000 KNOWN_SETUP=yes endif @@ -738,7 +737,6 @@ ifeq ($(SETUP), star) MODFILE= utils_binary.f90 set_binary.f90 moddump_binary.f90 ANALYSIS= ${SRCNIMHD} utils_summary.o utils_omp.o ptmass.o energies.o analysis_common_envelope.f90 KNOWN_SETUP=yes - MAXP=10000000 GRAVITY=yes endif @@ -751,7 +749,6 @@ ifeq ($(SETUP), grstar) MODFILE= moddump_tidal.f90 ANALYSIS= ${SRCNIMHD} utils_summary.o utils_omp.o ptmass.o energies.o analysis_common_envelope.f90 KNOWN_SETUP=yes - MAXP=100000000 GRAVITY=yes endif @@ -761,7 +758,6 @@ ifeq ($(SETUP), radstar) MODFILE= utils_binary.f90 set_binary.f90 moddump_binary.f90 ANALYSIS= ${SRCNIMHD} utils_summary.o utils_omp.o ptmass.o energies.o analysis_common_envelope.f90 KNOWN_SETUP=yes - MAXP=10000000 GRAVITY=yes RADIATION=yes endif @@ -773,7 +769,6 @@ ifeq ($(SETUP), dustystar) MODFILE= utils_binary.f90 set_binary.f90 moddump_binary.f90 ANALYSIS= ${SRCNIMHD} utils_summary.o utils_omp.o ptmass.o energies.o analysis_common_envelope.f90 dust_formation.f90 KNOWN_SETUP=yes - MAXP=10000000 GRAVITY=yes SINK_RADIATION=yes endif From 7903c3e0ece0367d89c9c02bc4bb6aa534dae8f8 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 13 May 2024 17:17:23 -0700 Subject: [PATCH 535/814] (checksetup) do not warn about FSI being incompatible with the GR code --- src/main/checksetup.f90 | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 39ac95b9b..57a167ef6 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -1016,13 +1016,17 @@ subroutine check_setup_radiation(npart,nerror,nwarn,radprop,rad) end subroutine check_setup_radiation subroutine check_vdep_extf(nwarn,iexternalforce) - use externalforces, only: is_velocity_dependent - use ptmass, only : use_fourthorder + use externalforces, only:is_velocity_dependent + use ptmass, only:use_fourthorder + use dim, only:gr integer, intent(inout) :: nwarn integer, intent(in) :: iexternalforce - if (is_velocity_dependent(iexternalforce) .and. use_fourthorder) then - print "(/,a,/)","Warning: velocity dependant external forces are not compatible with FSI switch back to Leapfrog..." - nwarn = nwarn + 1 + + if (iexternalforce > 0 .and. is_velocity_dependent(iexternalforce) .and. use_fourthorder) then + if (.not.gr) then ! do not give the warning in GR, just do it... + print "(/,1x,a,/)"," Warning: Switching to Leapfrog integrator for velocity-dependent external forces..." + nwarn = nwarn + 1 + endif use_fourthorder = .false. endif From 7a2d983ac361f1881df346a417a6f5e7e5d86dd6 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 13 May 2024 21:05:11 -0700 Subject: [PATCH 536/814] (utils_infile) do not return out-of-range integer if input is out-of-bounds --- src/main/utils_infiles.f90 | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/src/main/utils_infiles.f90 b/src/main/utils_infiles.f90 index c40332b25..1a5259b6c 100644 --- a/src/main/utils_infiles.f90 +++ b/src/main/utils_infiles.f90 @@ -443,11 +443,17 @@ subroutine read_inopt_int(ival,tag,db,err,errcount,min,max) if (ierr==0) then if (present(min)) then write(chmin,"(g10.0)") min - if (ival < min) ierr = ierr_rangemin + if (ival < min) then + ierr = ierr_rangemin + ival = min + endif endif if (present(max)) then write(chmax,"(g10.0)") max - if (ival > max) ierr = ierr_rangemax + if (ival > max) then + ierr = ierr_rangemax + ival = max + endif endif endif @@ -493,11 +499,17 @@ subroutine read_inopt_real(val,tag,db,err,errcount,min,max) if (ierr==0) then if (present(min)) then write(chmin,"(g13.4)") min - if (val < min) ierr = ierr_rangemin + if (val < min) then + ierr = ierr_rangemin + val = min + endif endif if (present(max)) then write(chmax,"(g13.4)") max - if (val > max) ierr = ierr_rangemax + if (val > max) then + ierr = ierr_rangemax + val = max + endif endif endif if (present(err)) then From e00e2876007977d73a3b5c000e216f27afba9eca Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 13 May 2024 21:50:04 -0700 Subject: [PATCH 537/814] (set_star) added write_options_stars and read_options_stars for reading/writing options for nstars --- src/setup/set_star.f90 | 97 +++++++++++++++++++++++++++++++++++++- src/setup/setup_binary.f90 | 34 ++++--------- src/setup/setup_grdisc.F90 | 39 ++++++++++++--- 3 files changed, 136 insertions(+), 34 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index fa316c63f..292e64411 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -50,8 +50,9 @@ module setstar end type star_t public :: star_t - public :: set_star,set_defaults_star,shift_star + public :: set_star,set_defaults_star,set_defaults_stars,shift_star public :: write_options_star,read_options_star,set_star_interactive + public :: write_options_stars,read_options_stars public :: ikepler,imesa,ibpwpoly,ipoly,iuniform,ifromfile,ievrard public :: need_polyk @@ -91,6 +92,21 @@ subroutine set_defaults_star(star) end subroutine set_defaults_star +!-------------------------------------------------------------------------- +!+ +! same as above but does it for multiple stars +!+ +!-------------------------------------------------------------------------- +subroutine set_defaults_stars(stars) + type(star_t), intent(out) :: stars(:) + integer :: i + + do i=1,size(stars) + call set_defaults_star(stars(i)) + enddo + +end subroutine set_defaults_stars + !-------------------------------------------------------------------------- !+ ! Master routine to setup a star from a specified file or density profile @@ -756,4 +772,83 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) end subroutine read_options_star +!----------------------------------------------------------------------- +!+ +! write_options routine that writes options for multiple stars +!+ +!----------------------------------------------------------------------- +subroutine write_options_stars(star,relax,iunit,nstar) + use relaxstar, only:write_options_relax + use infile_utils, only:write_inopt + type(star_t), intent(in) :: star(:) + integer, intent(in) :: iunit + logical, intent(in) :: relax + integer, intent(in), optional :: nstar + integer :: i,nstars + + ! 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) + nstars = nstar + else + nstars = size(star) + endif + + ! write options for each star + do i=1,nstars + call write_options_star(star(i),iunit,label=achar(i+48)) + enddo + + ! write relaxation options if any stars are made of gas + if (nstars > 0) then + if (any(star(1:nstars)%iprofile > 0)) then + write(iunit,"(/,a)") '# relaxation options' + call write_inopt(relax,'relax','relax stars into equilibrium',iunit) + call write_options_relax(iunit) + endif + endif + +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) + 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 + integer :: i,nstars + + ! optionally ask for number of stars + if (present(nstar)) then + call read_inopt(nstar,'nstars',db,nerr,min=0,max=size(star)) + nstars = nstar + else + nstars = size(star) + 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)) + 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) + endif + endif + +end subroutine read_options_stars + end module setstar diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index cdf4f7c8d..f3e80196a 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -55,7 +55,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& use options, only:iexternalforce use externalforces, only:iext_corotate,iext_geopot,iext_star,omega_corotate,mass1,accradius1 use io, only:master,fatal - use setstar, only:set_star,set_defaults_star,shift_star + use setstar, only:set_star,set_defaults_stars,shift_star use eos, only:X_in,Z_in,ieos use setup_params, only:rhozero,npart_total use mpidomain, only:i_belong @@ -98,9 +98,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& vxyzu(:,:) = 0. nptmass = 0 nstar = 2 - do i=1,nstar - call set_defaults_star(star(i)) - enddo + call set_defaults_stars(star) relax = .true. corotate = .false. semi_major_axis = '10.' @@ -213,8 +211,7 @@ end subroutine setpart !---------------------------------------------------------------- subroutine write_setupfile(filename) use infile_utils, only:write_inopt - use setstar, only:write_options_star - use relaxstar, only:write_options_relax + use setstar, only:write_options_stars use setunits, only:write_options_units character(len=*), intent(in) :: filename integer :: iunit @@ -224,8 +221,8 @@ subroutine write_setupfile(filename) write(iunit,"(a)") '# input file for binary setup routines' call write_options_units(iunit,gr) - call write_options_star(star(1),iunit,label='1') - call write_options_star(star(2),iunit,label='2') + call write_options_stars(star,relax,iunit) + call write_inopt(corotate,'corotate','set stars in corotation',iunit) write(iunit,"(/,a)") '# orbit settings' call write_inopt(semi_major_axis,'a','semi-major axis (e.g. 1 au), period (e.g. 10*days) or rp if e=1',iunit) @@ -234,13 +231,6 @@ subroutine write_setupfile(filename) call write_inopt(O,'O','position angle of ascending node (deg)',iunit) call write_inopt(w,'w','argument of periapsis (deg)',iunit) call write_inopt(f,'f','initial true anomaly (180=apoastron)',iunit) - call write_inopt(corotate,'corotate','set stars in corotation',iunit) - - if (any(star(:)%iprofile > 0)) then - write(iunit,"(/,a)") '# relaxation options' - call write_inopt(relax,'relax','relax stars into equilibrium',iunit) - call write_options_relax(iunit) - endif close(iunit) end subroutine write_setupfile @@ -253,8 +243,7 @@ end subroutine write_setupfile subroutine read_setupfile(filename,ieos,polyk,ierr) use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db use io, only:error,fatal - use setstar, only:read_options_star - use relaxstar, only:read_options_relax + use setstar, only:read_options_stars use setunits, only:read_options_and_set_units character(len=*), intent(in) :: filename integer, intent(inout) :: ieos @@ -268,9 +257,9 @@ 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_star(star(1),need_iso,ieos,polyk,db,nerr,label='1') - call read_options_star(star(2),need_iso,ieos,polyk,db,nerr,label='2') + call read_options_stars(star,need_iso,ieos,polyk,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_inopt(semi_major_axis,'a',db,errcount=nerr) call read_inopt(ecc,'ecc',db,min=0.,errcount=nerr) @@ -279,13 +268,6 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) call read_inopt(w,'w',db,errcount=nerr) call read_inopt(f,'f',db,errcount=nerr) - call read_inopt(corotate,'corotate',db,errcount=nerr) - - if (any(star(:)%iprofile > 0)) then - call read_inopt(relax,'relax',db,errcount=nerr) - call read_options_relax(db,nerr) - endif - call close_db(db) if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index e6fa50dc4..760ccc7be 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -34,12 +34,14 @@ module setup ! timestep, units ! use options, only:alpha + use setstar, only:star_t implicit none public :: setpart real, private :: mhole,mdisc,r_in,r_out,r_ref,spin,honr,theta,p_index,q_index,accrad,gamma_ad - integer, private :: np - logical, private :: ismooth + integer, private :: np,nstars + logical, private :: ismooth,relax + type(star_t), private :: star(1) private @@ -68,6 +70,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use timestep, only:tmax,dtmax use eos, only:ieos use kernel, only:hfact_default + use setstar, only:set_defaults_stars + use setunits, only:mass_unit integer, intent(in) :: id integer, intent(out) :: npart integer, intent(out) :: npartoftype(:) @@ -99,7 +103,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! Set default problem parameters ! - + mass_unit = '1e6*solarm' mhole = 1.e6 ! (solarm) mdisc = 10. ! (solarm) r_in = 4. ! (GM/c^2) @@ -115,11 +119,18 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, gamma_ad= 1.001 np = 1e6 accrad = 4. ! (GM/c^2) + accradius1 = accrad + gamma = gamma_ad + + ! stars + nstars = 0 + call set_defaults_stars(star) + relax = .true. ! !-- Read runtime parameters from setup file ! - if (id==master) print "(/,65('-'),1(/,a),/,65('-'),/)",'Disc setup' + 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) @@ -186,7 +197,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, npartoftype(1) = npart - return end subroutine setpart @@ -195,12 +205,17 @@ end subroutine setpart ! subroutine write_setupfile(filename) use infile_utils, only:write_inopt + use setstar, only:write_options_stars + use dim, only:gr + use setunits, only:write_options_units character(len=*), intent(in) :: filename integer, parameter :: iunit = 20 print "(a)",' writing setup options file '//trim(filename) open(unit=iunit,file=filename,status='replace',form='formatted') - write(iunit,"(a)") '# input file for grdisc setup' + call write_options_units(iunit,gr) + + write(iunit,"(/,a)") '# disc parameters' call write_inopt(mhole ,'mhole' ,'mass of black hole (solar mass)' , iunit) call write_inopt(mdisc ,'mdisc' ,'mass of disc (solar mass)' , iunit) call write_inopt(r_in ,'r_in' ,'inner edge of disc (GM/c^2, code units)' , iunit) @@ -216,6 +231,10 @@ subroutine write_setupfile(filename) call write_inopt(gamma_ad,'gamma' ,'adiabatic gamma' , iunit) call write_inopt(accrad ,'accrad' ,'accretion radius (GM/c^2, code units)' , iunit) 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_orbit(orbit,iunit) close(iunit) end subroutine write_setupfile @@ -223,16 +242,21 @@ end subroutine write_setupfile 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_stars + use eos, only:ieos,polyk + use dim, only:gr + use setunits, only:read_options_and_set_units character(len=*), intent(in) :: filename integer, intent(out) :: ierr integer, parameter :: iunit = 21 - integer :: nerr + integer :: nerr,need_iso type(inopts), allocatable :: db(:) print "(a)",'reading setup options from '//trim(filename) nerr = 0 ierr = 0 call open_db_from_file(db,filename,iunit,ierr) + call read_options_and_set_units(db,nerr,gr) call read_inopt(mhole ,'mhole' ,db,min=0.,errcount=nerr) call read_inopt(mdisc ,'mdisc' ,db,min=0.,errcount=nerr) call read_inopt(r_in ,'r_in' ,db,min=0.,errcount=nerr) @@ -248,6 +272,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 close_db(db) if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' From eae7a47cb3953396b84c17529f2744ea3ed63796 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 13 May 2024 21:50:27 -0700 Subject: [PATCH 538/814] (testsuite) added quote --- src/tests/testsuite.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index d3bf32d13..a5c129f0d 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -97,6 +97,8 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) write(*,"(14x,a,/)") '-- Richard West (former UKAFF manager)' write(*,"(2x,a)") '"Trace, test and treat"' write(*,"(14x,a,/)") '-- South Korea' + write(*,"(2x,a)") '"Testing a program demonstrates that it contains errors, never that it is correct"' + write(*,"(14x,a,/)") '-- E. W. Dijkstra' endif ntests = 0 npass = 0 From 8894e4c92a94f17af571720cfbea02ffeb85b52f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 14 May 2024 11:13:05 +0200 Subject: [PATCH 539/814] tmax adjustement and print for debugging --- src/main/ptmass.F90 | 18 +++++++++--------- src/setup/setup_cluster.f90 | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 286f391f6..3d9ea98c1 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1549,17 +1549,16 @@ subroutine ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) xyzmh_ptmass(itbirth,nptmass) = time xyzmh_ptmass(4,nptmass) = -1. xyzmh_ptmass(ihacc,nptmass) = -1. - if (i==nseed)then - linklist_ptmass(nptmass) = -1 !! null pointer - else - linklist_ptmass(nptmass) = nptmass + 1 !! link this new seed to the next one - endif + linklist_ptmass(nptmass) = nptmass + 1 !! link this new seed to the next one enddo + linklist_ptmass(nptmass) = -1 !! null pointer to end the link list + end subroutine ptmass_create_seeds subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) use physcon, only:solarm,pi use eos, only:polyk + use io, only:iprint use units, only:umass use part, only:itbirth,ihacc use utils_sampling, only:divide_unit_seg @@ -1571,7 +1570,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, real :: xi(3),vi(3) integer :: i,k,n real :: tbirthi,mi,hacci,minmass,minmonmi - real :: xk,yk,zk,dk,cs + real :: xk,yk,zk,d,cs do i=1,nptmass mi = xyzmh_ptmass(4,i) @@ -1579,6 +1578,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, tbirthi = xyzmh_ptmass(itbirth,i) if (mi<0.) cycle if (time>tbirthi+tmax_acc .and. hacci>0. ) then + write(iprint,"(i8,i8)") time, tbirthi+tmax_acc !! save xcom and vcom before placing stars xi(1) = xyzmh_ptmass(1,i) xi(2) = xyzmh_ptmass(2,i) @@ -1598,12 +1598,12 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, k=i do while(k>0) !! do some clever stuff - dk = huge(mi) - do while (dk>1.) + d = huge(mi) + do while (d>1.) xk = rand() yk = rand() zk = rand() - dk = xk**2+yk**2+zk**2 + d = xk**2+yk**2+zk**2 enddo cs = sqrt(polyk) xyzmh_ptmass(ihacc,i) = -1. diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index c87b43fbf..5aa71d54b 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -141,7 +141,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, t_ff = sqrt(3.*pi/(32.*rhozero)) ! free-fall time (the characteristic timescale) epotgrav = 3./5.*totmass**2/rmax ! Gravitational potential energy lattice = 'random' - tmax_acc = (0.5*myr)/utime + tmax_acc = 0.5*(myr/utime) !--Set positions call set_sphere(trim(lattice),id,master,0.,rmax,psep,hfact,npart,xyzh,nptot=npart_total, & From 4c0806d0bf6529c3cc2a05e86ac09eafbe6f7c42 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 14 May 2024 11:37:45 +0200 Subject: [PATCH 540/814] fix merge issues --- src/main/substepping.F90 | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index e9d940c47..7617f908e 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -495,7 +495,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & 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) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass) endif if (use_fourthorder) then !! FSI 4th order scheme @@ -503,7 +503,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! 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,fsink_old,group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass, & + fsink_old,group_info) call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) @@ -512,10 +513,12 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass,group_info=group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass, & + group_info=group_info) else call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,fsink_old) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,& + 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) @@ -531,7 +534,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass,group_info=group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass, & + group_info=group_info) elseif (accreted) then call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass) @@ -818,7 +822,7 @@ 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,fsink_old,linklist_ptmass,group_info) + force_count,extf_vdep_flag,linklist_ptmass,fsink_old,group_info) use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & From c15c82aa69651ef1b2cbee10adf5822036815cf3 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 14 May 2024 13:53:19 +0100 Subject: [PATCH 541/814] Set fxyzu(4,:) =0 for step_leapfrog integration --- src/main/cooling.f90 | 8 ++--- src/main/cooling_radapprox.f90 | 63 +++++++++++++++++++--------------- src/main/deriv.F90 | 18 +++++++++- src/main/substepping.F90 | 2 +- 4 files changed, 57 insertions(+), 34 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 8a69ed935..67fec4e62 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -207,7 +207,7 @@ subroutine write_options_cooling(iunit) use cooling_gammie_PL, only:write_options_cooling_gammie_PL use cooling_molecular, only:write_options_molecularcooling use cooling_solver, only:write_options_cooling_solver - use cooling_radapprox, only:write_options_cooling_stamatellos + use cooling_radapprox, only:write_options_cooling_radapprox integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling cooling' @@ -224,7 +224,7 @@ subroutine write_options_cooling(iunit) case(7) call write_options_cooling_gammie_PL(iunit) case(9) - call write_options_cooling_stamatellos(iunit) + call write_options_cooling_radapprox(iunit) case default call write_options_cooling_solver(iunit) end select @@ -244,7 +244,7 @@ subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) use cooling_ism, only:read_options_cooling_ism use cooling_molecular, only:read_options_molecular_cooling use cooling_solver, only:read_options_cooling_solver - use cooling_radapprox, only:read_options_cooling_stamatellos + use cooling_radapprox, only:read_options_cooling_radapprox character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr @@ -281,7 +281,7 @@ subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) case(7) call read_options_cooling_gammie_PL(name,valstring,imatch,igotallgammiePL,ierr) case(9) - call read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ierr) + call read_options_cooling_radapprox(name,valstring,imatch,igotallstam,ierr) case default call read_options_cooling_solver(name,valstring,imatch,igotallfunc,ierr) end select diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index e72825df2..d646111df 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -22,9 +22,9 @@ module cooling_radapprox implicit none real, public :: Lstar=0.0 ! in units of L_sun integer :: isink_star ! index of sink to use as illuminating star - integer :: od_method = 4 ! default = Stamatellos+ 2007 method + 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_stamatellos,read_options_cooling_stamatellos + public :: radcool_update_energ,write_options_cooling_radapprox,read_options_cooling_radapprox public :: init_star contains @@ -76,30 +76,34 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) real :: dudti_cool,ui,rhoi real :: coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot - real :: cs2,Om2,Hmod2,xi,yi,zi + real :: cs2,Om2,Hmod2 real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi - integer :: i + integer :: i,ratefile + character(len=20) :: filename - !$omp parallel do default(none) & +! write (temp,'(E5.2)') dt + write (filename, 11) dt +11 format("coolrate_", E7.2,".dat") + + ratefile = 34 + open(unit=ratefile,file=filename,status="replace",form="formatted") + !$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) & + !$omp shared(isink_star,doFLD,ttherm_store,teqi_store,od_method,unit_pressure,ratefile) & !$omp shared(opac_store,Tfloor,dt,dudt_sph,utime,udist,umass,unit_ergg,gradP_cool) & - !$omp private(i,poti,du_FLDi,xi,yi,zi,ui,rhoi,ri2,coldensi,kappaBari,Ti) & + !$omp private(i,poti,du_FLDi,ui,rhoi,ri2,coldensi,kappaBari,Ti) & !$omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot) & !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb,Lstar,dudti_cool) overpart: do i=1,npart poti = Gpot_cool(i) du_FLDi = duFLD(i) - xi = xyzh(1,i) - yi = xyzh(2,i) - zi = xyzh(3,i) ui = energ(i) rhoi = rhoh(xyzh(4,i),massoftype(igas)) 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 + 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 endif ! get opacities & Ti for ui @@ -207,26 +211,29 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) print *, "dudti_rad=", dudti_rad ,"dudt_fld=",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 - dudti_cool = (umini - ui)/dt +! else if (dudti_cool < 0.d0 .and. abs(dudti_cool) > ui/dt) then + ! dudti_cool = (umini - ui)/dt endif ! evolve energy - energ(i) = energ(i) + dudti_cool * dt - + energ(i) = ui + dudti_cool * dt + + !set fxyzu(4,i) for timestepping - or don't... + if (dudti_cool == 0d0) then + dudt_sph(i) = tiny(dudti_cool) + else + dudt_sph(i) = dudti_cool + endif + ! !$omp critical + ! write (ratefile,'(I6,1X,E15.4,E15.4)') i, dudt_sph(i), (ui - energ(i))/dt + ! !$omp end critical enddo overpart !$omp end parallel do - ! zero fxyzu(4,:) - !$omp parallel do shared(dudt_sph) private(i) schedule(runtime) - do i=1,npart - dudt_sph(i) = 0d0 - enddo - !$omp end parallel do - + close(ratefile) end subroutine radcool_update_energ -subroutine write_options_cooling_stamatellos(iunit) +subroutine write_options_cooling_radapprox(iunit) use infile_utils, only:write_inopt use eos_stamatellos, only: eos_file integer, intent(in) :: iunit @@ -238,9 +245,9 @@ subroutine write_options_cooling_stamatellos(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 +end subroutine write_options_cooling_radapprox -subroutine read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ierr) +subroutine read_options_cooling_radapprox(name,valstring,imatch,igotallstam,ierr) use io, only:warning,fatal use eos_stamatellos, only: eos_file,doFLD character(len=*), intent(in) :: name,valstring @@ -279,7 +286,7 @@ subroutine read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ie if (ngot >= 4) igotallstam = .true. -end subroutine read_options_cooling_stamatellos +end subroutine read_options_cooling_radapprox end module cooling_radapprox diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index 18d58ff12..a5e3654ee 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -162,6 +162,12 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& call do_timing('radiation',tlast,tcpulast) endif +! +! update energy if using radiative cooling approx (icooling=9) +! + if (icooling == 9 .and. dt > 0.0) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) + + ! ! compute forces ! @@ -186,7 +192,8 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& ! ! update energy if using radiative cooling approx (icooling=9) and set fxyzu(4,:) to zero ! - if (icooling == 9 .and. dt > 0.0) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) +! if (icooling == 9 .and. dt > 0.0) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) + ! ! compute dust temperature @@ -203,6 +210,15 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& enddo !$omp end parallel do endif + + if (icooling == 9) then + !$omp parallel do shared(fxyzu,npart) private(i) + do i=1,npart + fxyzu(4,i) = 0. + enddo + !$omp end parallel do + endif + ! ! set new timestep from Courant/forces condition ! diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 89738c538..1df9d19a9 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -1074,7 +1074,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl endif endif #endif - ! update internal energy + ! update internal energy if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool From 245b4a323b0b724b6630099d05b46f0d14850965 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 14 May 2024 13:57:15 +0100 Subject: [PATCH 542/814] Set fxyzu(4,:) =0 for step_leapfrog integration - part 2 --- src/main/step_leapfrog.F90 | 27 +++++++-------------------- 1 file changed, 7 insertions(+), 20 deletions(-) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 514bdc61a..6fafd8703 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -196,11 +196,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) else - if (icooling /= 9) then - vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) - else - vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) - endif + vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif !--floor the thermal energy if requested and required @@ -249,7 +245,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else call substep_sph_gr(dtsph,npart,xyzh,vxyzu,dens,pxyzu,metrics) endif - elseif (icooling /= 9) then + 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,& @@ -479,10 +475,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + dti*fxyzu(:,i) else - if (icooling /= 9) then - vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) - else - vxyzu(1:3,i) = vxyzu(1:3,i) + dti*fxyzu(1:3,i) + vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) + if (fxyzu(4,i) > TINY(fxyzu(4,i))) then + print *, "In step du/dt not zero" endif endif @@ -505,11 +500,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) else - if (icooling /= 9) then - vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) - else - vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) - endif + vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif !--floor the thermal energy if requested and required @@ -659,11 +650,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) - hdtsph*fxyzu(:,i) else - if (icooling /= 9 ) then - vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) - else - vxyzu(1:3,i) = vxyzu(1:3,i) - hdtsph*fxyzu(1:3,i) - endif + vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) endif if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) - hdtsph*ddustprop(:,i) if (itype==igas) then From 9f363743b6c11a00d90ba4bde4711ece9608fe07 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 14 May 2024 12:44:14 -0700 Subject: [PATCH 543/814] (#465) call prim2consall during get_derivs_global to fix issues relaxing stars in GR --- src/main/deriv.F90 | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index 91ef885a6..4bbab4bdf 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -58,7 +58,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& use forces, only:force use part, only:mhd,gradh,alphaind,igas,iradxi,ifluxx,ifluxy,ifluxz,ithick use derivutils, only:do_timing - use cons2prim, only:cons2primall,cons2prim_everything,prim2consall + use cons2prim, only:cons2primall,cons2prim_everything use metric_tools, only:init_metric use radiation_implicit, only:do_radiation_implicit,ierr_failed_to_converge use options, only:implicit_radiation,implicit_radiation_store_drad,use_porosity @@ -115,7 +115,6 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& if (gr) then ! Recalculate the metric after moving particles to their new tasks call init_metric(npart,xyzh,metrics) - !call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) endif if (nptmass > 0 .and. periodic) call ptmass_boundary_crossing(nptmass,xyzmh_ptmass) @@ -221,11 +220,13 @@ 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 - use timing, only:printused,getused - use io, only:id,master + 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 + use timing, only:printused,getused + use io, only:id,master + use cons2prim, only:prim2consall + use metric_tools, only:init_metric real(kind=4), intent(out), optional :: tused real, intent(out), optional :: dt_new real, intent(in), optional :: dt ! optional argument needed to test implicit radiation routine @@ -237,6 +238,13 @@ subroutine get_derivs_global(tused,dt_new,dt) dti = 0. if (present(dt)) dti = dt call getused(t1) + ! update conserved quantities in the GR code + if (gr) then + call init_metric(npart,xyzh,metrics) + call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) + endif + + ! 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) From 3621afb203a6d7b1701f18e4a1c80d0d4a6510bf Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 14 May 2024 12:44:58 -0700 Subject: [PATCH 544/814] (#465) run relaxation of polytrope in GR at low resolution in the test suite, to catch errors like #465 --- scripts/buildbot.sh | 7 ++++--- src/setup/setup_grtde.f90 | 8 +++++--- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/scripts/buildbot.sh b/scripts/buildbot.sh index 0b503882c..d5cf4a26f 100755 --- a/scripts/buildbot.sh +++ b/scripts/buildbot.sh @@ -184,9 +184,10 @@ check_phantomsetup () # myinput="\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"; prefix="myrun"; + flags="--np=1000" echo -e "$myinput" > myinput.txt; sed '/-e/d' myinput.txt > mycleanin.txt - ./phantomsetup $prefix < mycleanin.txt > /dev/null; err=$?; + ./phantomsetup $prefix $flags < mycleanin.txt > /dev/null; err=$?; if [ $err -eq 0 ]; then print_result "runs" $pass; else @@ -197,8 +198,8 @@ check_phantomsetup () # run phantomsetup up to 3 times to successfully create/rewrite the .setup file # infile="${prefix}.in" - ./phantomsetup $prefix < myinput.txt > /dev/null; - ./phantomsetup $prefix < myinput.txt > /dev/null; + ./phantomsetup $prefix $flags < myinput.txt > /dev/null; + ./phantomsetup $prefix $flags < myinput.txt > /dev/null; if [ -e "$prefix.setup" ]; then print_result "creates .setup file" $pass; #test_setupfile_options "$prefix" "$prefix.setup" $infile; diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index a6d04d9ef..897b244f9 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -60,6 +60,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use vectorutils, only:rotatevec use gravwaveutils, only:theta_gw,calc_gravitwaves use setup_params, only:rhozero,npart_total + use systemutils, only:get_command_option integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -70,7 +71,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, character(len=20), intent(in) :: fileprefix real, intent(out) :: vxyzu(:,:) character(len=120) :: filename - integer :: ierr + integer :: ierr,np_default logical :: iexist,write_profile,use_var_comp real :: rtidal,rp,semia,period,hacc1,hacc2 real :: vxyzstar(3),xyzstar(3) @@ -100,7 +101,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, 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 - star%np = 1e6 + 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 beta = 5. ecc = 0.8 @@ -109,7 +111,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, theta = 0. write_profile = .false. use_var_comp = .false. - relax = .false. + relax = .true. ! !-- Read runtime parameters from setup file ! From 2c557e4f4f5fcaca3a93b0baa516c1b5a27feb4c Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 15 May 2024 17:09:35 +0200 Subject: [PATCH 545/814] fix default value of tacc max which needs to be huge if we don't use the new scheme --- src/main/ptmass.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 41512f09f..5bf2d7fc0 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -63,7 +63,7 @@ module ptmass real, public :: r_crit = 5.e-3 real, public :: h_acc = 1.e-3 real, public :: f_acc = 0.8 - real, public :: tmax_acc = 0.0 + real, public :: tmax_acc = huge(f_acc) real, public :: h_soft_sinkgas = 0.0 real, public :: h_soft_sinksink = 0.0 real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch @@ -791,7 +791,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & mpt = xyzmh_ptmass(4,i) age = xyzmh_ptmass(itbirth,i) if (mpt < 0.) cycle - if (age + tmax_acc < time ) cycle + if (age + tmax_acc < time) cycle dx = xi - xyzmh_ptmass(1,i) dy = yi - xyzmh_ptmass(2,i) dz = zi - xyzmh_ptmass(3,i) From 61ee94b11ee5512a7cbfcb812b9a17ac6aba7e5a Mon Sep 17 00:00:00 2001 From: fhu Date: Thu, 16 May 2024 09:42:37 +1000 Subject: [PATCH 546/814] (inject_sim) Fix uninitialised variable --- src/main/inject_sim.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index 78b6023b8..4a60e71d6 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -62,9 +62,9 @@ subroutine init_inject(ierr) ! !--find the tde dump at the right time ! + next_time = -1. next_dump = getnextfilename(start_dump) call get_dump_time_npart(trim(next_dump),next_time,ierr,npart_out=npart_sim) - if (ierr /= 0) next_time = -1. ierr = 0 niter = 0 From 1641d23a3762479aaeea32bbebded5b14391e2f4 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 16 May 2024 12:40:51 +0200 Subject: [PATCH 547/814] try fix data corruption --- src/main/ptmass.F90 | 10 +++++----- src/main/substepping.F90 | 8 ++++---- src/main/writeheader.F90 | 6 +++--- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 5bf2d7fc0..77106f483 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1501,11 +1501,11 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote nptmass = nptmass + 1 if (nptmass > maxptmass) call fatal('ptmass_create','nptmass > maxptmass') n = nptmass - xyzmh_ptmass(:,n) = 0. ! zero all quantities by default - xyzmh_ptmass(1:3,n) = (/xi,yi,zi/) - xyzmh_ptmass(4,n) = 0. ! zero mass - xyzmh_ptmass(ihacc,n) = h_acc - xyzmh_ptmass(ihsoft,n) = h_soft_sinkgas + xyzmh_ptmass(:,n) = 0. ! zero all quantities by default + xyzmh_ptmass(1:3,n) = (/xi,yi,zi/) + xyzmh_ptmass(4,n) = 0. ! zero mass + xyzmh_ptmass(ihacc,n) = h_acc + xyzmh_ptmass(ihsoft,n) = h_soft_sinkgas xyzmh_ptmass(itbirth,n) = time vxyz_ptmass(:,n) = 0. ! zero velocity, get this by accreting itypej = igas ! default particle type to be accreted diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 7617f908e..3a6f91308 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -923,8 +923,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, 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) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass + fxyz_ptmass_sinksink(:,:)=fxyz_ptmass(:,:) + dsdt_ptmass_sinksink(:,:)=dsdt_ptmass(:,:) if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif else @@ -934,8 +934,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, 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) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass + fxyz_ptmass_sinksink(:,:)=fxyz_ptmass(:,:) + dsdt_ptmass_sinksink(:,:)=dsdt_ptmass(:,:) if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif endif diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index 0d32e639b..c36e8ab07 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -85,7 +85,7 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) labeltype,maxtypes use mpiutils, only:reduceall_mpi use eos, only:eosinfo - use cooling, only:cooling_in_step,Tfloor,ufloor + use cooling, only:cooling_in_step,Tfloor,ufloor,icooling use readwrite_infile, only:write_infile use physcon, only:pi,pc use kernel, only:kernelname,radkern @@ -182,12 +182,12 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) if (drag_implicit) then write(iprint,"(1x,a)") 'Two-fluid dust implicit scheme is ON' else - write(iprint,"(1x,a)") 'Two-fluid dust explicit scheme is ON' + write(iprint,"(1x,a)") 'Two-fluid dust explicit scheme is OFF' endif endif if (use_dustgrowth) write(iprint,"(1x,a)") 'Dust growth is ON' if (use_porosity) write(iprint,"(1x,a)") 'Dust porosity is ON' - if (cooling_in_step) then + if (cooling_in_step .and. icooling >0) then write(iprint,"(1x,a)") 'Cooling is calculated in step' else write(iprint,"(1x,a)") 'Cooling is explicitly calculated in force' From 6f9ac3ab834b0c951766fa03d1539db4dea35d5a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 16 May 2024 12:58:24 +0200 Subject: [PATCH 548/814] fix previous fix --- src/main/ptmass.F90 | 7 ++++--- src/main/writeheader.F90 | 6 +++--- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 77106f483..87b4630d2 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -637,9 +637,10 @@ subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_pt vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dkdt*fxyz_ptmass(1,i) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dkdt*fxyz_ptmass(2,i) vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dkdt*fxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) + if (dsdt_ptmass(1,i) /= 0.) print*, "AAAAAAAAAAAAAAH" + !xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) + !xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) + !xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) endif enddo !$omp end parallel do diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index c36e8ab07..6be8b5ffb 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -80,12 +80,12 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) use io, only:iprint use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax use boundary_dyn, only:dynamic_bdy,rho_thresh_bdy,width_bkg - use options, only:tolh,alpha,alphau,alphaB,ieos,alphamax,use_dustfrac,use_porosity + use options, only:tolh,alpha,alphau,alphaB,ieos,alphamax,use_dustfrac,use_porosity,icooling use part, only:hfact,massoftype,mhd,gravity,periodic,massoftype,npartoftypetot,& labeltype,maxtypes use mpiutils, only:reduceall_mpi use eos, only:eosinfo - use cooling, only:cooling_in_step,Tfloor,ufloor,icooling + use cooling, only:cooling_in_step,Tfloor,ufloor use readwrite_infile, only:write_infile use physcon, only:pi,pc use kernel, only:kernelname,radkern @@ -187,7 +187,7 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) endif if (use_dustgrowth) write(iprint,"(1x,a)") 'Dust growth is ON' if (use_porosity) write(iprint,"(1x,a)") 'Dust porosity is ON' - if (cooling_in_step .and. icooling >0) then + if (cooling_in_step .and. icooling > 0) then write(iprint,"(1x,a)") 'Cooling is calculated in step' else write(iprint,"(1x,a)") 'Cooling is explicitly calculated in force' From 3d9c05609eaea42def26bf245fe66b5401ba61d3 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 16 May 2024 16:32:43 +0200 Subject: [PATCH 549/814] init linklist wirte it into dump and try to fix bad behaviour of dsdt_ptmass --- build/Makefile | 5 ++--- src/main/part.F90 | 1 + src/main/readwrite_dumps_common.f90 | 11 ++++++++--- src/main/readwrite_dumps_fortran.f90 | 20 +++++++++++++++----- src/main/substepping.F90 | 12 ++++++------ 5 files changed, 32 insertions(+), 17 deletions(-) diff --git a/build/Makefile b/build/Makefile index e075cc35e..71e83262e 100644 --- a/build/Makefile +++ b/build/Makefile @@ -534,9 +534,8 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ partinject.F90 utils_inject.f90 dust_formation.f90 ptmass_radiation.f90 ptmass_heating.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ - ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} \ - utils_subgroup.f90 utils_kepler.f90 subgroup.f90\ - quitdump.f90 utils_sampling.f90 ptmass.F90 \ + ${SRCKROME} memory.f90 utils_sampling.f90 ptmass.F90 ${SRCREADWRITE_DUMPS}\ + utils_subgroup.f90 utils_kepler.f90 subgroup.f90 quitdump.f90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ mf_write.f90 evolve.F90 utils_orbits.f90 utils_linalg.f90 \ diff --git a/src/main/part.F90 b/src/main/part.F90 index 85cf77dfe..14c395e43 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -605,6 +605,7 @@ subroutine init_part xyzmh_ptmass = 0. vxyz_ptmass = 0. dsdt_ptmass = 0. + linklist_ptmass = -1 ! initialise arrays not passed to setup routine to zero if (mhd) then diff --git a/src/main/readwrite_dumps_common.f90 b/src/main/readwrite_dumps_common.f90 index 11df1d566..b9d8990ac 100644 --- a/src/main/readwrite_dumps_common.f90 +++ b/src/main/readwrite_dumps_common.f90 @@ -566,8 +566,9 @@ end subroutine unfill_rheader subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkproperties,massoftype,& alphafile,tfile,phantomdump,got_iphase,got_xyzh,got_vxyzu,got_alpha, & got_krome_mols,got_krome_gamma,got_krome_mu,got_krome_T, & - got_abund,got_dustfrac,got_sink_data,got_sink_vels,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,& + 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) use dim, only:maxp,maxvxyzu,maxalpha,maxBevol,mhd,h2chemistry,use_dustgrowth,gr,& do_radiation,store_dust_temperature,do_nucleation,use_krome @@ -579,11 +580,12 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert use options, only:alpha,use_dustfrac,use_var_comp use sphNGutils, only:itype_from_sphNG_iphase,isphNG_accreted use dust_formation, only:init_nucleation + use ptmass, only:icreate_sinks integer, intent(in) :: i1,i2,noffset,npartoftype(:),npartread,nptmass,nsinkproperties real, intent(in) :: massoftype(:),alphafile,tfile logical, intent(in) :: phantomdump,got_iphase,got_xyzh(:),got_vxyzu(:),got_alpha(:),got_dustprop(:) logical, intent(in) :: got_VrelVf,got_dustgasprop(:) - logical, intent(in) :: got_abund(:),got_dustfrac(:),got_sink_data(:),got_sink_vels(:),got_Bxyz(:) + 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 @@ -766,6 +768,9 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert if (.not.all(got_sink_vels(1:3))) then if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING! sink particle velocities not found' endif + if( icreate_sinks > 1 .and. .not.got_sink_llist) then + if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING! sink particle link list not found' + endif if (id==master .and. i1==1) then print "(2(a,i4),a)",' got ',nsinkproperties,' sink properties from ',nptmass,' sink particles' if (nptmass > 0) print "(1x,58('-'),/,1x,a,'|',5(a9,1x,'|'),/,1x,58('-'))",& diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 742bad087..ae1131f9d 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -54,7 +54,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) use part, only:xyzh,xyzh_label,vxyzu,vxyzu_label,Bevol,Bevol_label,Bxyz,Bxyz_label,npart,maxtypes, & npartoftypetot,update_npartoftypetot, & alphaind,rhoh,divBsymm,maxphase,iphase,iamtype_int1,iamtype_int11, & - nptmass,nsinkproperties,xyzmh_ptmass,xyzmh_ptmass_label,vxyz_ptmass,vxyz_ptmass_label,& + nptmass,nsinkproperties,xyzmh_ptmass,xyzmh_ptmass_label,vxyz_ptmass,vxyz_ptmass_label, linklist_ptmass, & maxptmass,get_pmass,nabundances,abundance,abundance_label,mhd,& divcurlv,divcurlv_label,divcurlB,divcurlB_label,poten,dustfrac,deltav,deltav_label,tstop,& dustfrac_label,tstop_label,dustprop,dustprop_label,eos_vars,eos_vars_label,ndusttypes,ndustsmall,VrelVf,& @@ -70,6 +70,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 ptmass, only:icreate_sinks real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer, intent(in), optional :: iorder(:) @@ -305,6 +306,9 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ilen(2) = int(nptmass,kind=8) call write_array(2,xyzmh_ptmass,xyzmh_ptmass_label,nsinkproperties,nptmass,k,ipass,idump,nums,nerr) call write_array(2,vxyz_ptmass,vxyz_ptmass_label,3,nptmass,k,ipass,idump,nums,nerr) + if (icreate_sinks > 1) then + call write_array(2,linklist_ptmass,"linklist_ptmass",nptmass,k,ipass,idump,nums,nerr) + endif if (nerr > 0) call error('write_dump','error writing sink particle arrays') endif enddo @@ -972,7 +976,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto use_dustgrowth,maxdusttypes,ndivcurlv,maxphase,gr,store_dust_temperature,& ind_timesteps,use_krome 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, & + alphaind,poten,xyzmh_ptmass,xyzmh_ptmass_label,vxyz_ptmass,vxyz_ptmass_label,linklist_ptmass, & Bevol,Bxyz,Bxyz_label,nabundances,iphase,idust, & eos_vars,eos_vars_label,maxeosvars,dustprop,dustprop_label,divcurlv,divcurlv_label,iX,iZ,imu, & VrelVf,VrelVf_label,dustgasprop,dustgasprop_label,filfac,filfac_label,pxyzu,pxyzu_label,dust_temp, & @@ -981,6 +985,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto ithick,ilambda,iorig,dt_in,krome_nmols,T_gas_cool use sphNGutils, only:mass_sphng,got_mass,set_gas_particle_mass use options, only:use_porosity + use ptmass, only:icreate_sinks integer, intent(in) :: i1,i2,noffset,narraylengths,nums(:,:),npartread,npartoftype(:),idisk1,iprint real, intent(in) :: massoftype(:) integer, intent(in) :: nptmass,nsinkproperties @@ -990,7 +995,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto logical :: match logical :: got_dustfrac(maxdusttypes) logical :: got_iphase,got_xyzh(4),got_vxyzu(4),got_abund(nabundances),got_alpha(1),got_poten - logical :: got_sink_data(nsinkproperties),got_sink_vels(3),got_Bxyz(3) + logical :: got_sink_data(nsinkproperties),got_sink_vels(3),got_sink_llist,got_Bxyz(3) 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) @@ -1011,6 +1016,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto got_poten = .false. got_sink_data = .false. got_sink_vels = .false. + got_sink_llist = .false. got_Bxyz = .false. got_psi = .false. got_eosvars = .false. @@ -1116,6 +1122,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto case(2) call read_array(xyzmh_ptmass,xyzmh_ptmass_label,got_sink_data,ik,1,nptmass,0,idisk1,tag,match,ierr) call read_array(vxyz_ptmass, vxyz_ptmass_label, got_sink_vels,ik,1,nptmass,0,idisk1,tag,match,ierr) + if (icreate_sinks > 1) then + call read_array(linklist_ptmass,'linklist_ptmass',got_sink_llist,ik,1,nptmass,0,idisk1,tag,match,ierr) + endif end select select case(iarr) ! MHD arrays can either be in block 1 or block 4 case(1,4) @@ -1137,8 +1146,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto call check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkproperties,massoftype,& alphafile,tfile,phantomdump,got_iphase,got_xyzh,got_vxyzu,got_alpha, & got_krome_mols,got_krome_gamma,got_krome_mu,got_krome_T, & - got_abund,got_dustfrac,got_sink_data,got_sink_vels,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,& + 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) if (.not. phantomdump) then print *, "Calling set_gas_particle_mass" diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 3a6f91308..453407a51 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -923,8 +923,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, 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) - fxyz_ptmass_sinksink(:,:)=fxyz_ptmass(:,:) - dsdt_ptmass_sinksink(:,:)=dsdt_ptmass(:,:) + fxyz_ptmass_sinksink(4,1:nptmass) = fxyz_ptmass(4,1:nptmass) + dsdt_ptmass_sinksink(3,1:nptmass) = dsdt_ptmass(3,1:nptmass) if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif else @@ -934,15 +934,15 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, 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) - fxyz_ptmass_sinksink(:,:)=fxyz_ptmass(:,:) - dsdt_ptmass_sinksink(:,:)=dsdt_ptmass(:,:) + fxyz_ptmass_sinksink(4,1:nptmass) = fxyz_ptmass(4,1:nptmass) + dsdt_ptmass_sinksink(3,1:nptmass) = dsdt_ptmass(3,1:nptmass) if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif endif endif else - fxyz_ptmass(:,:) = 0. - dsdt_ptmass(:,:) = 0. + fxyz_ptmass(4,1:nptmass) = 0. + dsdt_ptmass(3,1:nptmass) = 0. endif call bcast_mpi(epot_sinksink) call bcast_mpi(dtf) From 13608f55e26905eea88c6508811035cc74f4ccb6 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 17 May 2024 11:41:48 +0200 Subject: [PATCH 550/814] bad initialisation of dsdt_ptmass that corrupted data with icreate_sinks --- src/main/initial.F90 | 2 ++ src/main/ptmass.F90 | 7 +++---- src/main/substepping.F90 | 8 ++++---- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index f009025d2..c745bcb03 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -546,6 +546,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) if (r_merge_uncond < 2.0*h_acc) then write(iprint,*) ' WARNING! Sink creation is on, but but merging is off! Suggest setting r_merge_uncond >= 2.0*h_acc' endif + fxyz_ptmass=0. + dsdt_ptmass=0. endif if (abs(time) <= tiny(0.)) then !initialize nucleation array at the start of the run only diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 87b4630d2..77106f483 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -637,10 +637,9 @@ subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_pt vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dkdt*fxyz_ptmass(1,i) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dkdt*fxyz_ptmass(2,i) vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dkdt*fxyz_ptmass(3,i) - if (dsdt_ptmass(1,i) /= 0.) print*, "AAAAAAAAAAAAAAH" - !xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) - !xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) - !xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) endif enddo !$omp end parallel do diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 453407a51..8b042cde0 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -923,8 +923,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, 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) - fxyz_ptmass_sinksink(4,1:nptmass) = fxyz_ptmass(4,1:nptmass) - dsdt_ptmass_sinksink(3,1:nptmass) = dsdt_ptmass(3,1:nptmass) + fxyz_ptmass_sinksink = fxyz_ptmass + dsdt_ptmass_sinksink = dsdt_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif else @@ -934,8 +934,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, 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) - fxyz_ptmass_sinksink(4,1:nptmass) = fxyz_ptmass(4,1:nptmass) - dsdt_ptmass_sinksink(3,1:nptmass) = dsdt_ptmass(3,1:nptmass) + fxyz_ptmass_sinksink = fxyz_ptmass + dsdt_ptmass_sinksink = dsdt_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif endif From 9938cd9b77c633fa823580df260f1adeb8879220 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 17 May 2024 11:55:03 +0200 Subject: [PATCH 551/814] fix tmax for tests --- src/setup/setup_cluster.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 5aa71d54b..35481b839 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -141,7 +141,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, t_ff = sqrt(3.*pi/(32.*rhozero)) ! free-fall time (the characteristic timescale) epotgrav = 3./5.*totmass**2/rmax ! Gravitational potential energy lattice = 'random' - tmax_acc = 0.5*(myr/utime) + tmax_acc = 30*(myr/utime) !--Set positions call set_sphere(trim(lattice),id,master,0.,rmax,psep,hfact,npart,xyzh,nptot=npart_total, & From 901673980277af7041b13211daf389b417d7eb67 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 17 May 2024 13:44:26 +0200 Subject: [PATCH 552/814] tmax_acc in runtime parameters with icreate sinks --- src/main/ptmass.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 77106f483..d9463ca98 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -2074,6 +2074,8 @@ subroutine write_options_ptmass(iunit) call write_inopt(r_crit,'r_crit','critical radius for point mass creation (no new sinks < r_crit from existing sink)', & iunit) call write_inopt(h_acc, 'h_acc' ,'accretion radius for new sink particles',iunit) + !if (icreate_sinks>1) + call write_inopt(tmax_acc, "tmax_acc", "Maximum accretion time for star formation scheme", iunit) if (f_crit_override > 0. .or. l_crit_override) then call write_inopt(f_crit_override,'f_crit_override' ,'unconditional sink formation if rho > f_crit_override*rho_crit',& iunit) @@ -2159,6 +2161,9 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) r_merge_cond if (r_merge_cond > 0. .and. r_merge_cond < r_merge_uncond) call fatal(label,'0 < r_merge_cond < r_merge_uncond') ngot = ngot + 1 + case('tmax_acc') + read(valstring,*,iostat=ierr) tmax_acc + ngot = ngot + 1 case default imatch = .false. end select From 1acf24bd5386334a1801214d09a2f59d662f145e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 17 May 2024 15:37:14 +0200 Subject: [PATCH 553/814] fix writeheader previous fix --- src/main/writeheader.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index 6be8b5ffb..0aa02ea4c 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -187,10 +187,12 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) endif if (use_dustgrowth) write(iprint,"(1x,a)") 'Dust growth is ON' if (use_porosity) write(iprint,"(1x,a)") 'Dust porosity is ON' - if (cooling_in_step .and. icooling > 0) then - write(iprint,"(1x,a)") 'Cooling is calculated in step' - else - write(iprint,"(1x,a)") 'Cooling is explicitly calculated in force' + if (icooling > 0) then + if (cooling_in_step) then + write(iprint,"(1x,a)") 'Cooling is calculated in step' + else + write(iprint,"(1x,a)") 'Cooling is explicitly calculated in force' + endif endif if (ufloor > 0.) then write(iprint,"(3(a,Es10.3),a)") ' WARNING! Imposing temperature floor of = ',Tfloor,' K = ', & From bbb0e8150294e688540b98a24b6c28327b511d55 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 17 May 2024 15:50:52 +0200 Subject: [PATCH 554/814] fix writeheader previous fix part 2 --- src/main/writeheader.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index 0aa02ea4c..1852d1b7c 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -193,6 +193,8 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) else write(iprint,"(1x,a)") 'Cooling is explicitly calculated in force' endif + else + write(iprint,"(1x,a)") 'Cooling is OFF' endif if (ufloor > 0.) then write(iprint,"(3(a,Es10.3),a)") ' WARNING! Imposing temperature floor of = ',Tfloor,' K = ', & From 8a57204dad8dd591f776a8d606affbb45305f584 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 05:26:33 +1000 Subject: [PATCH 555/814] (grdisc) added set_orbit functionality for setting up orbits in different parameter sets; add helper routines to set up multiple stars; added stars to grdisc setup for qpes --- build/Makefile | 2 +- src/setup/set_binary.f90 | 13 +- src/setup/set_orbit.f90 | 270 +++++++++++++++++++++++++++++++++++++ src/setup/set_star.f90 | 121 ++++++++++++++--- src/setup/setup_binary.f90 | 96 ++++--------- src/setup/setup_grdisc.F90 | 77 +++++++++-- 6 files changed, 468 insertions(+), 111 deletions(-) create mode 100644 src/setup/set_orbit.f90 diff --git a/build/Makefile b/build/Makefile index 2f9e2e75e..90109b78a 100644 --- a/build/Makefile +++ b/build/Makefile @@ -652,7 +652,7 @@ phantomsetup: setup SRCSETUP= prompting.f90 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_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 \ set_vfield.f90 set_Bfield.f90 \ diff --git a/src/setup/set_binary.f90 b/src/setup/set_binary.f90 index e1208a837..3027f47d7 100644 --- a/src/setup/set_binary.f90 +++ b/src/setup/set_binary.f90 @@ -34,6 +34,7 @@ module setbinary end interface get_eccentricity_vector real, parameter :: pi = 4.*atan(1.) + real, parameter :: deg_to_rad = pi/180. integer, parameter :: & ierr_m1 = 1, & ierr_m2 = 2, & @@ -186,19 +187,19 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & if (present(posang_ascnode) .and. present(arg_peri) .and. present(incl)) then ! Campbell elements ecc = eccentricity - omega = arg_peri*pi/180. + omega = arg_peri*deg_to_rad ! our conventions here are Omega is measured East of North - big_omega = posang_ascnode*pi/180. + 0.5*pi - inc = incl*pi/180. + big_omega = posang_ascnode*deg_to_rad + 0.5*pi + inc = incl*deg_to_rad if (present(f)) then ! get eccentric, parabolic or hyperbolic anomaly from true anomaly ! (https://en.wikipedia.org/wiki/Eccentric_anomaly#From_the_true_anomaly) - theta = f*pi/180. + theta = f*deg_to_rad E = get_E_from_true_anomaly(theta,ecc) elseif (present(mean_anomaly)) then ! get eccentric anomaly from mean anomaly by solving Kepler equation - bigM = mean_anomaly*pi/180. + bigM = mean_anomaly*deg_to_rad E = get_E_from_mean_anomaly(bigM,ecc) else ! set binary at apastron @@ -324,7 +325,7 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & ! rotate if inclination is non-zero ! if (present(incl) .and. .not.(present(arg_peri) .and. present(posang_ascnode))) then - xangle = incl*pi/180. + xangle = incl*deg_to_rad cosi = cos(xangle) sini = sin(xangle) do i=i1,i2 diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 new file mode 100644 index 000000000..9ab67178a --- /dev/null +++ b/src/setup/set_orbit.f90 @@ -0,0 +1,270 @@ +!--------------------------------------------------------------------------! +! 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 setorbit +! +! Generic procedure for setting up two body orbits with +! different parameter sets for the orbital elements +! +! The current options are: +! 0) Campbell elements for bound or unbound orbit (aeiOwf) +! 1) Flyby parameters (periapsis, initial separation, argument of periapsis, inclination) +! 2) position and velocity for both bodies + +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: physcon +! + implicit none + public :: set_orbit + public :: set_defaults_orbit,write_options_orbit,read_options_orbit + public :: orbit_t +! + ! define data types with options needed + ! to setup an orbit + ! + type campbell_elems + character(len=20) :: semi_major_axis ! string because can specific units + real :: e ! eccentricity + real :: i ! inclination + real :: O ! position angle of the ascending node + real :: w ! argument of periapsis + real :: f ! initial true anomaly + 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 + end type posvel_elems + + type flyby_elems + character(len=20) :: rp ! pericentre distance in arbitrary units + real :: d ! initial separation + real :: O ! position angle of the ascending node + real :: i ! inclination + end type flyby_elems + + ! + ! generic type handling all options + ! + type orbit_t + integer :: itype + type(campbell_elems) :: elems + type(flyby_elems) :: flyby + type(posvel_elems) :: posvel + end type orbit_t + + private + +contains + +!---------------------------------------------------------------- +!+ +! default parameters for orbit type +!+ +!---------------------------------------------------------------- +subroutine set_defaults_orbit(orbit) + type(orbit_t), intent(out) :: orbit + + orbit%itype = 0 + orbit%elems%semi_major_axis = '10.' + orbit%elems%e = 0.0 + orbit%elems%i = 0.0 + orbit%elems%O = 0.0 + orbit%elems%w = 270. ! argument of periapsis + orbit%elems%f = 180. ! start orbit at apocentre + + orbit%flyby%rp = '10.' + 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 + +end subroutine set_defaults_orbit + +!---------------------------------------------------------------- +!+ +! setup for two body orbit +!+ +!---------------------------------------------------------------- +subroutine set_orbit(orbit,m1,m2,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,verbose,ierr,omega_corotate) + use physcon, only:days + use units, only:in_code_units,is_time_unit,utime + use setbinary, only:set_binary,get_a_from_period + use setflyby, only:set_flyby + type(orbit_t), intent(in) :: orbit + real, intent(in) :: m1,m2,hacc1,hacc2 + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(inout) :: nptmass + logical, intent(in) :: verbose + integer, intent(out) :: ierr + real, intent(out), optional :: omega_corotate + real :: rp,a + + ierr = 0 + select case(orbit%itype) + case(2) + ! body 1 + xyzmh_ptmass(1:3,nptmass+1) = orbit%posvel%x1(1:3) + xyzmh_ptmass(4,nptmass+1) = m1 + xyzmh_ptmass(5,nptmass+1) = hacc1 + vxyz_ptmass(1:3,nptmass+1) = orbit%posvel%v1(1:3) + ! body 2 + xyzmh_ptmass(1:3,nptmass+2) = orbit%posvel%x2(1:3) + xyzmh_ptmass(4,nptmass+2) = m2 + xyzmh_ptmass(5,nptmass+2) = hacc2 + vxyz_ptmass(1:3,nptmass+2) = orbit%posvel%v2(1:3) + case(1) + rp = in_code_units(orbit%flyby%rp,ierr) + + call set_flyby(m1,m2,rp,orbit%flyby%d,hacc1,hacc2,xyzmh_ptmass, & + vxyz_ptmass,nptmass,ierr,orbit%flyby%O,orbit%flyby%i,verbose=verbose) + case default + ! + !--if a is negative or is given time units, interpret this as a period + ! + a = in_code_units(orbit%elems%semi_major_axis,ierr) + if (is_time_unit(orbit%elems%semi_major_axis) .and. ierr == 0) then + a = -abs(a) + print "(a,g0,a,g0,a)",' Using PERIOD = ',abs(a),' = ',abs(a)*utime/days,' days' + endif + if (a < 0.) a = get_a_from_period(m1,m2,abs(a)) + ! + !--now setup orbit using sink particles + ! + if (present(omega_corotate)) then + call set_binary(m1,m2,a,orbit%elems%e,hacc1,hacc2,& + xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,omega_corotate,& + posang_ascnode=orbit%elems%O,arg_peri=orbit%elems%w,& + incl=orbit%elems%i,f=orbit%elems%f,verbose=verbose) + else + call set_binary(m1,m2,a,orbit%elems%e,hacc1,hacc2,& + xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,& + posang_ascnode=orbit%elems%O,arg_peri=orbit%elems%w,& + incl=orbit%elems%i,f=orbit%elems%f,verbose=verbose) + endif + end select + +end subroutine set_orbit + +!---------------------------------------------------------------- +!+ +! write options to .setup file +!+ +!---------------------------------------------------------------- +subroutine write_options_orbit(orbit,iunit,label) + use infile_utils, only:write_inopt + type(orbit_t), intent(in) :: orbit + integer, intent(in) :: iunit + character(len=*), intent(in), optional :: label + character(len=10) :: c + + ! append optional label e.g. '1', '2' + c = '' + if (present(label)) c = trim(adjustl(label)) + + write(iunit,"(/,a)") '# orbit '//trim(c) + 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) + 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%O,'O'//trim(c),'position angle of the ascending node',iunit) + call write_inopt(orbit%flyby%i,'i'//trim(c),'inclination',iunit) + case default + call write_inopt(orbit%elems%semi_major_axis,'a'//trim(c),& + 'semi-major axis (e.g. 1 au), period (e.g. 10*days) or rp if e=1',iunit) + call write_inopt(orbit%elems%e,'ecc'//trim(c),'eccentricity',iunit) + call write_inopt(orbit%elems%i,'inc'//trim(c),'inclination (deg)',iunit) + call write_inopt(orbit%elems%O,'O'//trim(c),'position angle of ascending node (deg)',iunit) + call write_inopt(orbit%elems%w,'w'//trim(c),'argument of periapsis (deg)',iunit) + call write_inopt(orbit%elems%f,'f'//trim(c),'initial true anomaly (180=apoastron)',iunit) + end select + +end subroutine write_options_orbit + +!---------------------------------------------------------------- +!+ +! read options from .setup file +!+ +!---------------------------------------------------------------- +subroutine read_options_orbit(orbit,db,nerr,label) + use infile_utils, only:inopts,read_inopt + type(orbit_t), intent(out) :: orbit + type(inopts), allocatable, intent(inout) :: db(:) + integer, intent(inout) :: nerr + character(len=*), intent(in), optional :: label + character(len=10) :: c + + ! append optional label e.g. '1', '2' + c = '' + if (present(label)) c = trim(adjustl(label)) + + call read_inopt(orbit%itype,'itype'//trim(c),db,errcount=nerr,min=0,max=2) + select case(orbit%itype) + case(2) + call read_inopt(orbit%posvel%x1(1),'x1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%x1(2),'y1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%x1(3),'z1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v1(1),'vx1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v1(2),'vy1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v1(3),'vz1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%x2(1),'x2'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%x2(2),'y2'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%x2(3),'z2'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v2(1),'vx2'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v2(2),'vy2'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v2(3),'vz2'//trim(c),db,errcount=nerr) + case(1) + call read_inopt(orbit%flyby%rp,'rp'//trim(c),db,errcount=nerr) + call read_inopt(orbit%flyby%d,'d'//trim(c),db,errcount=nerr) + call read_inopt(orbit%flyby%O,'O'//trim(c),db,errcount=nerr) + call read_inopt(orbit%flyby%i,'i'//trim(c),db,errcount=nerr) + case default + call read_inopt(orbit%elems%semi_major_axis,'a'//trim(c),db,errcount=nerr) + call read_inopt(orbit%elems%e,'ecc'//trim(c),db,min=0.,errcount=nerr) + call read_inopt(orbit%elems%i,'inc'//trim(c),db,errcount=nerr) + call read_inopt(orbit%elems%O,'O'//trim(c),db,errcount=nerr) + call read_inopt(orbit%elems%w,'w'//trim(c),db,errcount=nerr) + call read_inopt(orbit%elems%f,'f'//trim(c),db,errcount=nerr) + end select + +end subroutine read_options_orbit + +end module setorbit \ No newline at end of file diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 292e64411..3978b7263 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -50,12 +50,18 @@ module setstar end type star_t public :: star_t - public :: set_star,set_defaults_star,set_defaults_stars,shift_star - public :: write_options_star,read_options_star,set_star_interactive - public :: write_options_stars,read_options_stars + public :: set_star,set_stars + public :: set_defaults_star,set_defaults_stars + public :: shift_star,shift_stars + public :: write_options_star,write_options_stars + public :: read_options_star,read_options_stars + public :: set_star_interactive public :: ikepler,imesa,ibpwpoly,ipoly,iuniform,ifromfile,ievrard public :: need_polyk + integer, parameter :: istar_offset = 3 ! offset for particle type to distinguish particles + ! placed in stars from other particles in the simulation + private contains @@ -148,7 +154,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& integer, intent(out) :: ierr real, intent(in), optional :: x0(3),v0(3) integer, intent(in), optional :: itype - procedure(mask_prototype) :: mask + 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(:) @@ -294,7 +300,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& ! if (present(itype)) then do i=npart_old+1,npart - call set_particle_type(i,itype) + call set_particle_type(i,itype+istar_offset) enddo endif ! @@ -334,6 +340,46 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& end subroutine set_star +!-------------------------------------------------------------------------- +!+ +! As above but loops over all stars +!+ +!-------------------------------------------------------------------------- +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,& + relax,use_var_comp,write_rho_to_file,& + rhozero,npart_total,mask,ierr) + use unifdis, only:mask_prototype + type(star_t), intent(inout) :: star(:) + integer, intent(in) :: id,master,nstars + integer, intent(inout) :: npart,npartoftype(:),nptmass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),eos_vars(:,:),rad(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(inout) :: massoftype(:) + 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(in) :: X_in,Z_in + real, intent(out) :: rhozero + integer(kind=8), intent(out) :: npart_total + integer, intent(out) :: ierr + procedure(mask_prototype) :: mask + integer :: i + + 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,& + X_in,Z_in,relax,use_var_comp,write_rho_to_file,& + rhozero,npart_total,mask,ierr,itype=i) + endif + enddo + +end subroutine set_stars + !----------------------------------------------------------------------- !+ ! shift star to the desired position and velocity @@ -363,13 +409,14 @@ subroutine shift_star(npart,xyz,vxyz,x0,v0,itype,corotate) omega = L/dot_product(rcyl,rcyl) print*,'Adding spin to star: omega = ',omega endif + if (present(itype)) print "(a,i0,a,2(es10.3,','),es10.3,a)",' MOVING STAR ',itype,' to (x,y,z) = (',x0(1:3),')' over_parts: do i=1,npart if (present(itype)) then ! get type of current particle call get_particle_type(i,mytype) ! skip particles that do not match the specified type - if (mytype /= itype) cycle over_parts + if (mytype /= itype+istar_offset) cycle over_parts ! reset type back to gas call set_particle_type(i,igas) endif @@ -383,6 +430,39 @@ subroutine shift_star(npart,xyz,vxyz,x0,v0,itype,corotate) end subroutine shift_star +!----------------------------------------------------------------------- +!+ +! As above but 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,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 + logical, intent(in), optional :: corotate + integer :: i + logical :: do_corotate + + do_corotate = .false. + if (present(corotate)) do_corotate = corotate + + 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),& + v0=vxyz_ptmass_in(1:3,i),itype=i,corotate=do_corotate) + else + nptmass = nptmass + 1 + xyzmh_ptmass(:,nptmass) = xyzmh_ptmass_in(:,i) + vxyz_ptmass(:,nptmass) = vxyz_ptmass_in(:,i) + endif + enddo + +end subroutine shift_stars + !----------------------------------------------------------------------- !+ ! print a distance in both code units and physical units @@ -690,6 +770,7 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) 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 ! set defaults call set_defaults_star(star) @@ -719,18 +800,18 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) 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.) - star%lcore = lcore_lsun*real(solarl/unit_luminosity) + 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 if (star%isinkcore) then - call read_inopt(mcore_msun,'mcore'//trim(c),db,errcount=nerr,min=0.) - star%mcore = mcore_msun*real(solarm/umass) - call read_inopt(hsoft_rsun,'hsoft'//trim(c),db,errcount=nerr,min=0.) - star%hsoft = hsoft_rsun*real(solarr/udist) + 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) endif else call read_inopt(star%outputfilename,'outputfilename'//trim(c),db,errcount=nerr) @@ -741,13 +822,13 @@ 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.) - star%rcore = rcore_rsun*real(solarr/udist) + 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) 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.) - star%mcore = mcore_msun*real(solarm/umass) + 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) endif endif case(ievrard) @@ -761,11 +842,11 @@ 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.) - star%mstar = mstar_msun*real(solarm/umass) + 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) if (need_rstar(star%iprofile)) then - call read_inopt(rstar_rsun,'Rstar'//trim(c),db,errcount=nerr,min=0.) - star%rstar = rstar_rsun*real(solarr/udist) + 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) endif endif endif diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index f3e80196a..6305df51f 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -26,15 +26,15 @@ module setup ! kernel, mpidomain, options, part, physcon, relaxstar, setbinary, ! setstar, setunits, setup_params, units ! - use setstar, only:star_t + use setstar, only:star_t + use setorbit, only:orbit_t use dim, only:gr implicit none public :: setpart - real :: a,ecc,inc,O,w,f logical :: relax,corotate - type(star_t) :: star(2) - character(len=20) :: semi_major_axis + type(star_t) :: star(2) + type(orbit_t) :: orbit private @@ -49,13 +49,11 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& polyk,gamma,hfact,time,fileprefix) use part, only:gr,nptmass,xyzmh_ptmass,vxyz_ptmass,& ihacc,ihsoft,eos_vars,rad,nsinkproperties,iJ2,iReff,ispinx,ispinz - use setbinary, only:set_binary,get_a_from_period - use units, only:is_time_unit,in_code_units,utime - use physcon, only:solarm,au,pi,solarr,days + use setorbit, only:set_defaults_orbit,set_orbit use options, only:iexternalforce use externalforces, only:iext_corotate,iext_geopot,iext_star,omega_corotate,mass1,accradius1 use io, only:master,fatal - use setstar, only:set_star,set_defaults_stars,shift_star + use setstar, only:set_defaults_stars,set_stars,shift_stars use eos, only:X_in,Z_in,ieos use setup_params, only:rhozero,npart_total use mpidomain, only:i_belong @@ -73,7 +71,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& character(len=20), intent(in) :: fileprefix real, intent(out) :: vxyzu(:,:) character(len=120) :: filename - integer :: ierr,i,nstar,nptmass_in,iextern_prev + 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 logical, parameter :: set_oblateness = .false. @@ -99,15 +97,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& nptmass = 0 nstar = 2 call set_defaults_stars(star) + call set_defaults_orbit(orbit) relax = .true. corotate = .false. - semi_major_axis = '10.' - a = 10. - ecc = 0. - inc = 0. - O = 0. - w = 270. - f = 180. ieos = 2 if (id==master) print "(/,65('-'),1(/,a),/,65('-'),/)",& @@ -131,54 +123,27 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& iextern_prev = iexternalforce iexternalforce = 0 gamma = 5./3. - do i=1,nstar - 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,& - X_in,Z_in,relax,use_var_comp,write_profile,& - rhozero,npart_total,i_belong,ierr,itype=i) - endif - enddo + call set_stars(id,master,nstar,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) - ! - !--if a is negative or is given time units, interpret this as a period - ! - a = in_code_units(semi_major_axis,ierr) - if (is_time_unit(semi_major_axis) .and. ierr == 0) then - a = -abs(a) - print "(a,g0,a,g0,a)",' Using PERIOD = ',abs(a),' = ',abs(a)*utime/days,' days' - endif - if (a < 0.) a = get_a_from_period(star(1)%mstar,star(2)%mstar,abs(a)) - ! - !--now setup orbit using fake sink particles - ! nptmass_in = 0 if (iexternalforce==iext_corotate) then - call set_binary(star(1)%mstar,star(2)%mstar,a,ecc,star(1)%hacc,star(2)%hacc,& - xyzmh_ptmass_in,vxyz_ptmass_in,nptmass_in,ierr,omega_corotate,& - posang_ascnode=O,arg_peri=w,incl=inc,f=f,verbose=(id==master)) - add_spin = .false. ! already in corotating frame + 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) + add_spin = .false. else - call set_binary(star(1)%mstar,star(2)%mstar,a,ecc,star(1)%hacc,star(2)%hacc,& - xyzmh_ptmass_in,vxyz_ptmass_in,nptmass_in,ierr,& - posang_ascnode=O,arg_peri=w,incl=inc,f=f,verbose=(id==master)) + 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) add_spin = corotate endif - if (ierr /= 0) call fatal ('setup_binary','error in call to set_binary') + if (ierr /= 0) call fatal ('setup_binary','error in call to set_orbit') ! !--place stars into orbit, or add real sink particles if iprofile=0 ! - do i=1,nstar - if (star(i)%iprofile > 0) then - call shift_star(npart,xyzh,vxyzu,x0=xyzmh_ptmass_in(1:3,i),& - v0=vxyz_ptmass_in(1:3,i),itype=i,corotate=add_spin) - else - nptmass = nptmass + 1 - xyzmh_ptmass(:,nptmass) = xyzmh_ptmass_in(:,i) - vxyz_ptmass(:,nptmass) = vxyz_ptmass_in(:,i) - endif - enddo + call shift_stars(nstar,star,xyzmh_ptmass_in,vxyz_ptmass_in,xyzh,vxyzu,& + xyzmh_ptmass,vxyz_ptmass,npart,nptmass,corotate=add_spin) ! !--restore options ! @@ -212,6 +177,7 @@ end subroutine setpart subroutine write_setupfile(filename) 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 :: iunit @@ -223,14 +189,7 @@ subroutine write_setupfile(filename) call write_options_units(iunit,gr) call write_options_stars(star,relax,iunit) call write_inopt(corotate,'corotate','set stars in corotation',iunit) - - write(iunit,"(/,a)") '# orbit settings' - call write_inopt(semi_major_axis,'a','semi-major axis (e.g. 1 au), period (e.g. 10*days) or rp if e=1',iunit) - call write_inopt(ecc,'ecc','eccentricity',iunit) - call write_inopt(inc,'inc','inclination (deg)',iunit) - call write_inopt(O,'O','position angle of ascending node (deg)',iunit) - call write_inopt(w,'w','argument of periapsis (deg)',iunit) - call write_inopt(f,'f','initial true anomaly (180=apoastron)',iunit) + call write_options_orbit(orbit,iunit) close(iunit) end subroutine write_setupfile @@ -244,6 +203,7 @@ subroutine read_setupfile(filename,ieos,polyk,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 + use setorbit, only:read_options_orbit use setunits, only:read_options_and_set_units character(len=*), intent(in) :: filename integer, intent(inout) :: ieos @@ -260,15 +220,9 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) call read_options_stars(star,need_iso,ieos,polyk,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_inopt(semi_major_axis,'a',db,errcount=nerr) - call read_inopt(ecc,'ecc',db,min=0.,errcount=nerr) - call read_inopt(inc,'inc',db,errcount=nerr) - call read_inopt(O,'O',db,errcount=nerr) - call read_inopt(w,'w',db,errcount=nerr) - call read_inopt(f,'f',db,errcount=nerr) - + call read_options_orbit(orbit,db,nerr) call close_db(db) + if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' ierr = nerr diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index 760ccc7be..7987343f3 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -33,15 +33,18 @@ module setup ! io, kernel, metric, options, part, physcon, prompting, setdisc, ! timestep, units ! - use options, only:alpha - use setstar, only:star_t + use options, only:alpha + use setstar, only:star_t + use setorbit, only:orbit_t implicit none public :: setpart 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 - type(star_t), private :: star(1) + integer, parameter :: max_stars = 10 + type(star_t), private :: star(max_stars) + type(orbit_t),private :: orbit(max_stars) private @@ -54,10 +57,10 @@ module setup !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) use setdisc, only:set_disc - use part, only:igas + use part, only:igas,nsinkproperties,eos_vars,rad,xyzmh_ptmass,vxyz_ptmass,nptmass use io, only:master use externalforces, only:accradius1,accradius1_hard - use options, only:iexternalforce,alphau,iexternalforce + use options, only:iexternalforce,alphau,iexternalforce,ipdv_heating,ishock_heating use units, only:set_units,umass use physcon, only:solarm,pi #ifdef GR @@ -68,10 +71,13 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, #endif use prompting, only:prompt use timestep, only:tmax,dtmax - use eos, only:ieos + use eos, only:ieos,use_var_comp,X_in,Z_in use kernel, only:hfact_default - use setstar, only:set_defaults_stars + use setstar, only:shift_star,set_stars + use setorbit, only:set_defaults_orbit,set_orbit use setunits, only:mass_unit + use mpidomain, only:i_belong + use setup_params, only:rhozero integer, intent(in) :: id integer, intent(out) :: npart integer, intent(out) :: npartoftype(:) @@ -82,13 +88,16 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real, intent(inout) :: time character(len=20), intent(in) :: fileprefix character(len=120) :: filename - integer :: ierr - logical :: iexist + integer :: ierr,nptmass_in,i + integer(kind=8) :: npart_total + logical :: iexist,write_profile real :: cs2 + 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 @@ -116,15 +125,19 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, theta = 3. ! inclination angle (degrees) p_index= 1.5 q_index= 0.75 - gamma_ad= 1.001 + gamma_ad= 5./3. np = 1e6 accrad = 4. ! (GM/c^2) accradius1 = accrad gamma = gamma_ad + ! default units + call set_units(G=1.,c=1.,mass=mhole*solarm) ! Set central mass to M=1 in code units ! stars nstars = 0 - call set_defaults_stars(star) + do i=1,size(orbit) + call set_defaults_orbit(orbit(i)) + enddo relax = .true. ! @@ -197,6 +210,36 @@ 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,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 **' + end subroutine setpart @@ -206,10 +249,12 @@ end subroutine setpart subroutine write_setupfile(filename) use infile_utils, only:write_inopt use setstar, only:write_options_stars + use setorbit, only:write_options_orbit use dim, only:gr use setunits, only:write_options_units 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') @@ -234,7 +279,9 @@ subroutine write_setupfile(filename) write(iunit,"(/,a)") '# stars' call write_options_stars(star,relax,iunit,nstar=nstars) - !call write_options_orbit(orbit,iunit) + do i=1,nstars + call write_options_orbit(orbit(i),iunit,label=achar(i+48)) + enddo close(iunit) end subroutine write_setupfile @@ -243,13 +290,14 @@ 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_stars + use setorbit, only:read_options_orbit use eos, only:ieos,polyk use dim, only:gr use setunits, only:read_options_and_set_units character(len=*), intent(in) :: filename integer, intent(out) :: ierr integer, parameter :: iunit = 21 - integer :: nerr,need_iso + integer :: nerr,need_iso,i type(inopts), allocatable :: db(:) print "(a)",'reading setup options from '//trim(filename) @@ -273,6 +321,9 @@ subroutine read_setupfile(filename,ierr) 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) + do i=1,nstars + call read_options_orbit(orbit(i),db,nerr,label=achar(i+48)) + enddo call close_db(db) if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' From ad06f249e0c4ec319940289214bfad99d89c2f79 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 07:38:46 +1000 Subject: [PATCH 556/814] (buildbot) fix bash error in if statement --- scripts/buildbot.sh | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/scripts/buildbot.sh b/scripts/buildbot.sh index d5cf4a26f..09a1c8e19 100755 --- a/scripts/buildbot.sh +++ b/scripts/buildbot.sh @@ -13,7 +13,7 @@ # # Written by Daniel Price, 2012-2023, daniel.price@monash.edu # -if [ X$SYSTEM == X ]; then +if [ "X$SYSTEM" == "X" ]; then echo "Error: Need SYSTEM environment variable set to check PHANTOM build"; echo "Usage: $0 [max idim to check] [url]"; exit; @@ -77,7 +77,6 @@ listofcomponents='main setup analysis utils'; # 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 )) From 458960a5f8ed351772c9681de367bb6f3ef78f07 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 07:45:38 +1000 Subject: [PATCH 557/814] (github) attempted fix for gfortran installation on macos-latest --- .github/workflows/mcfost.yml | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/.github/workflows/mcfost.yml b/.github/workflows/mcfost.yml index d74956d36..74eba9c75 100644 --- a/.github/workflows/mcfost.yml +++ b/.github/workflows/mcfost.yml @@ -23,9 +23,22 @@ jobs: # Steps represent a sequence of tasks that will be executed as part of the job steps: - - uses: fortran-lang/setup-fortran@v1 - with: - compiler: gcc + - name: install gfortran + run: brew install gfortran + + - name: soft link gfortran and check version + run: | + brew link gfortran + + #ls $PREFIX/bin/gfortran-* + #ln -s `ls "$PREFIX/bin/gfortran-*" | tail -1` $PREFIX/bin/gfortran + #gfortran -v + + - name: Check gfortran version + run: gfortran --version + #- uses: fortran-lang/setup-fortran@v1 + # with: + # compiler: gcc - name: Check gfortran version run: gfortran --version From 87a1a0639db91aa1991924ada9c38975f735d54a Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 08:00:36 +1000 Subject: [PATCH 558/814] (github) workaround for broken setup-fortran --- .github/workflows/krome.yml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/.github/workflows/krome.yml b/.github/workflows/krome.yml index 336c8144a..393224ad0 100644 --- a/.github/workflows/krome.yml +++ b/.github/workflows/krome.yml @@ -27,10 +27,21 @@ jobs: toolchain: {compiler: intel-classic} steps: - - uses: fortran-lang/setup-fortran@v1 + # Install the Fortran compiler (workaround for broken setup-fortran action on macOS) + - name: install Fortran compiler + if: matrix.os == 'ubuntu-latest' + uses: fortran-lang/setup-fortran@v1 with: compiler: ${{ matrix.toolchain.compiler }} + - name: install Fortran compiler on macOS + if: matrix.os == 'macos-latest' + run: brew install gfortran + + #- uses: fortran-lang/setup-fortran@v1 + # with: + # compiler: ${{ matrix.toolchain.compiler }} + - name: "Clone phantom" uses: actions/checkout@v4 From c36e70a2d265fead6c5c026e22679f9ba4328417 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 08:01:21 +1000 Subject: [PATCH 559/814] [format-bot] obsolete .gt. .lt. .ge. .le. .eq. .ne. replaced --- src/main/inject_sim.f90 | 2 +- src/utils/analysis_radiotde.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index 4a60e71d6..5bfa198c4 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -315,7 +315,7 @@ subroutine write_options_inject(iunit) real, parameter :: r_inject_default = 5.e14 ! write something meaningful in infile - if (r_inject_cgs .le. 0.) then + if (r_inject_cgs <= 0.) then start_dump = start_dump_default r_inject_cgs = r_inject_default final_dump = final_dump_default diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index ac228be09..d5f4dedb6 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -286,7 +286,7 @@ subroutine outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all) vr_accum_max = vri r_accum_maxv = r endif - if (r-rad_cap < drad_cap .and. (v .ge. v_min .and. v .le. v_max)) then + if (r-rad_cap < drad_cap .and. (v >= v_min .and. v <= v_max)) then thetai = atan2d(y,x) phii = atan2d(z,sqrt(x**2+y**2)) if ((thetai >= theta_min .and. thetai <= theta_max) .and. (phii >= phi_min .and. phii <= phi_max)) then From 1ab6a04f2158f98206c299a3e37271c6386e18b3 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 08:03:04 +1000 Subject: [PATCH 560/814] [header-bot] updated file headers --- src/main/energies.F90 | 4 ++-- src/main/initial.F90 | 2 +- src/main/inject_sim.f90 | 14 ++++++-------- src/main/ionization.f90 | 3 ++- src/main/subgroup.f90 | 12 +++++++++++- src/main/substepping.F90 | 2 +- src/main/utils_kepler.f90 | 17 +++++++++++++++++ src/main/utils_subgroup.f90 | 17 +++++++++++++++++ src/main/wind_equations.f90 | 2 +- src/setup/set_orbit.f90 | 15 +++++++++++++++ src/setup/set_star.f90 | 4 +++- src/setup/setup_binary.f90 | 13 +++---------- src/setup/setup_grdisc.F90 | 5 +++-- src/setup/setup_grtde.f90 | 2 +- src/setup/setup_wind.f90 | 2 +- src/tests/test_wind.f90 | 7 ++++--- src/utils/analysis_common_envelope.f90 | 2 +- src/utils/analysis_radiotde.f90 | 3 ++- src/utils/analysis_tdeoutflow.f90 | 17 +++++++---------- src/utils/moddump_radiotde.f90 | 6 ++++-- 20 files changed, 102 insertions(+), 47 deletions(-) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index f3728d0a8..e0255209f 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -18,8 +18,8 @@ module energies ! ! :Dependencies: boundary_dyn, centreofmass, dim, dust, eos, eos_piecewise, ! externalforces, gravwaveutils, io, kernel, metric_tools, mpiutils, -! nicil, options, part, ptmass, timestep, units, utils_gr, vectorutils, -! viscosity +! nicil, options, part, ptmass, subgroup, timestep, units, utils_gr, +! vectorutils, viscosity ! use dim, only:maxdusttypes,maxdustsmall use units, only:utime diff --git a/src/main/initial.F90 b/src/main/initial.F90 index f009025d2..46426bceb 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -22,7 +22,7 @@ module initial ! krome_interface, linklist, metric_tools, mf_write, mpibalance, ! mpidomain, mpimemory, mpitree, mpiutils, nicil, nicil_sup, omputils, ! options, part, partinject, porosity, ptmass, radiation_utils, -! readwrite_dumps, readwrite_infile, timestep, timestep_ind, +! readwrite_dumps, readwrite_infile, subgroup, timestep, timestep_ind, ! timestep_sts, timing, tmunu2grid, units, writeheader ! diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index 5bfa198c4..a3ef5d934 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -1,8 +1,8 @@ !--------------------------------------------------------------------------! ! 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.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inject ! @@ -10,15 +10,13 @@ module inject ! ! :References: None ! -! :Owner: Fitz Hu +! :Owner: Fitz) Hu ! ! :Runtime parameters: -! - start_dump : *dump to start looking for particles to inject* -! - r_inject : *radius to inject particles* -! - final_dump : *stop injection after reaching this dump* +! - r_inject : *radius to inject tde outflow (in cm)* ! -! :Dependencies: fileutils, io, timestep, units, dump_utils, part, -! readwrite_dumps_fortran, readwrite_dumps_common, partinject, infile_utils +! :Dependencies: dump_utils, fileutils, infile_utils, io, part, partinject, +! readwrite_dumps_common, readwrite_dumps_fortran, timestep, units ! use fileutils, only:getnextfilename diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index 2ebad8398..02691af62 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -14,7 +14,8 @@ module ionization_mod ! ! :Runtime parameters: None ! -! :Dependencies: eos_idealplusrad, io, part, physcon, units, vectorutils +! :Dependencies: dim, eos_idealplusrad, io, part, physcon, units, +! vectorutils ! implicit none diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index c2c0ed649..39ef10697 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -1,3 +1,9 @@ +!--------------------------------------------------------------------------! +! 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 subgroup ! ! this module contains everything to identify @@ -5,7 +11,11 @@ module subgroup ! ! :References: Makkino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 ! -! :Owner: Yann BERNARD +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: io, mpiutils, part, utils_kepler, utils_subgroup ! use utils_subgroup implicit none diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 67bdda3df..76f712e30 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -28,7 +28,7 @@ module substepping ! :Dependencies: chem, cons2primsolver, cooling, cooling_ism, damping, dim, ! dust_formation, eos, extern_gr, externalforces, io, io_summary, ! krome_interface, metric_tools, mpiutils, options, part, ptmass, -! ptmass_radiation, timestep, timestep_sts +! ptmass_radiation, subgroup, timestep, timestep_sts ! implicit none diff --git a/src/main/utils_kepler.f90 b/src/main/utils_kepler.f90 index e7eb8d5a4..deb5de94b 100644 --- a/src/main/utils_kepler.f90 +++ b/src/main/utils_kepler.f90 @@ -1,4 +1,21 @@ +!--------------------------------------------------------------------------! +! 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 utils_kepler +! +! utils_kepler +! +! :References: None +! +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: physcon +! use physcon,only: pi implicit none diff --git a/src/main/utils_subgroup.f90 b/src/main/utils_subgroup.f90 index ffbecf1a1..913a57606 100644 --- a/src/main/utils_subgroup.f90 +++ b/src/main/utils_subgroup.f90 @@ -1,4 +1,21 @@ +!--------------------------------------------------------------------------! +! 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 utils_subgroup +! +! utils_subgroup +! +! :References: None +! +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: None +! implicit none integer, parameter :: ck_size = 8 real,dimension(8),parameter :: cks=(/0.3922568052387800,0.5100434119184585,-0.4710533854097566,& diff --git a/src/main/wind_equations.f90 b/src/main/wind_equations.f90 index 589e9edd8..db79e9431 100644 --- a/src/main/wind_equations.f90 +++ b/src/main/wind_equations.f90 @@ -14,7 +14,7 @@ module wind_equations ! ! :Runtime parameters: None ! -! :Dependencies: dust_formation, eos, options, physcon +! :Dependencies: dim, dust_formation, eos, options, physcon ! implicit none diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index 9ab67178a..bb7d74a2f 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -14,6 +14,21 @@ module setorbit ! 1) Flyby parameters (periapsis, initial separation, argument of periapsis, inclination) ! 2) position and velocity for both bodies +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils, physcon, setbinary, setflyby, units +! + ! While Campbell elements can be used for unbound orbits, they require ! specifying the true anomaly at the start of the simulation. This is ! not always easy to determine, so the flyby option is provided as an diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 3978b7263..9eaccea82 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -15,7 +15,9 @@ module setstar ! ! :Owner: Daniel Price ! -! :Runtime parameters: None +! :Runtime parameters: +! - nstars : *number of stars to add (0-'//achar(size(star)+48)//')* +! - relax : *relax stars into equilibrium* ! ! :Dependencies: centreofmass, dim, eos, extern_densprofile, infile_utils, ! io, mpiutils, part, physcon, prompting, radiation_utils, relaxstar, diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 6305df51f..405759790 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -13,18 +13,11 @@ module setup ! :Owner: Daniel Price ! ! :Runtime parameters: -! - O : *position angle of ascending node (deg)* -! - a : *semi-major axis (e.g. 1 au), period (e.g. 10*days) or rp if e=1* -! - corotate : *set stars in corotation* -! - eccentricity : *eccentricity* -! - f : *initial true anomaly (180=apoastron)* -! - inc : *inclination (deg)* -! - relax : *relax stars into equilibrium* -! - w : *argument of periapsis (deg)* +! - corotate : *set stars in corotation* ! ! :Dependencies: centreofmass, dim, eos, externalforces, infile_utils, io, -! kernel, mpidomain, options, part, physcon, relaxstar, setbinary, -! setstar, setunits, setup_params, units +! kernel, mpidomain, options, part, physcon, setorbit, setstar, setunits, +! setup_params ! use setstar, only:star_t use setorbit, only:orbit_t diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index 7987343f3..6bd0d7953 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -29,8 +29,9 @@ module setup ! - spin : *spin parameter of black hole |a|<1* ! - theta : *inclination of disc (degrees)* ! -! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, -! io, kernel, metric, options, part, physcon, prompting, setdisc, +! :Dependencies: dim, eos, extern_lensethirring, externalforces, +! infile_utils, io, kernel, metric, mpidomain, options, part, physcon, +! prompting, setdisc, setorbit, setstar, setunits, setup_params, ! timestep, units ! use options, only:alpha diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index 897b244f9..275bdcc02 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -23,7 +23,7 @@ module setup ! ! :Dependencies: eos, externalforces, gravwaveutils, infile_utils, io, ! kernel, metric, mpidomain, part, physcon, relaxstar, setbinary, -! setstar, setup_params, timestep, units, vectorutils +! setstar, setup_params, systemutils, timestep, units, vectorutils ! use setstar, only:star_t implicit none diff --git a/src/setup/setup_wind.f90 b/src/setup/setup_wind.f90 index 99d2f364c..e41b19227 100644 --- a/src/setup/setup_wind.f90 +++ b/src/setup/setup_wind.f90 @@ -46,7 +46,7 @@ module setup ! - wind_gamma : *adiabatic index (initial if Krome chemistry used)* ! ! :Dependencies: dim, eos, infile_utils, inject, io, part, physcon, -! prompting, setbinary, sethierarchical, spherical, timestep, units +! prompting, setbinary, sethierarchical, spherical, units ! use dim, only:isothermal implicit none diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index 62ddefb1b..c89b2278a 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -14,9 +14,10 @@ module testwind ! ! :Runtime parameters: None ! -! :Dependencies: boundary, checksetup, dim, eos, inject, io, options, part, -! partinject, physcon, step_lf_global, testutils, timestep, timestep_ind, -! units, wind +! :Dependencies: allocutils, boundary, checksetup, dim, dust_formation, +! eos, inject, io, options, part, partinject, physcon, ptmass, +! ptmass_radiation, readwrite_infile, step_lf_global, testutils, +! timestep, timestep_ind, units, wind ! implicit none public :: test_wind diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index a7ec86cff..889d945bd 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -14,7 +14,7 @@ module analysis ! ! :Runtime parameters: None ! -! :Dependencies: centreofmass, dust_formation, energies, eos, +! :Dependencies: centreofmass, dim, dust_formation, energies, eos, ! eos_gasradrec, eos_mesa, extern_corotate, io, ionization_mod, kernel, ! mesa_microphysics, part, physcon, prompting, ptmass, setbinary, ! sortutils, table_utils, units, vectorutils diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index d5f4dedb6..21ef34315 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -14,6 +14,7 @@ module analysis ! ! :Runtime parameters: ! - drad_cap : *capture thickness (in cm) (-ve for all particles at outer radius)* +! - npart_tde : *npart in tde sims (-ve=10*npart of cnm)* ! - phi_max : *max phi (in deg)* ! - phi_min : *min phi (in deg)* ! - rad_cap : *capture inner radius (in cm)* @@ -22,7 +23,7 @@ module analysis ! - v_max : *max velocity (in c)* ! - v_min : *min velocity (in c)* ! -! :Dependencies: infile_utils, io, physcon, readwrite_dumps, units +! :Dependencies: infile_utils, io, part, physcon, readwrite_dumps, units ! implicit none character(len=8), parameter, public :: analysistype = 'radiotde' diff --git a/src/utils/analysis_tdeoutflow.f90 b/src/utils/analysis_tdeoutflow.f90 index e0a0265fc..d0c149577 100644 --- a/src/utils/analysis_tdeoutflow.f90 +++ b/src/utils/analysis_tdeoutflow.f90 @@ -10,19 +10,16 @@ module analysis ! ! :References: None ! -! :Owner: Fitz Hu +! :Owner: Fitz) Hu ! ! :Runtime parameters: -! - drad_cap : *capture thickness (in cm) (-ve for all particles at outer radius)* -! - phi_max : *max phi (in deg)* -! - phi_min : *min phi (in deg)* -! - rad_cap : *capture inner radius (in cm)* -! - theta_max : *max theta (in deg)* -! - theta_min : *min theta (in deg)* -! - v_max : *max velocity (in c)* -! - v_min : *min velocity (in c)* +! - phi_max : *max phi (in deg) (-ve = ignore)* +! - phi_min : *min phi (in deg) (-ve = ignore)* +! - r_in : *radius to count outflow (in cm)* +! - theta_max : *max theta (in deg) (-ve = ignore)* +! - theta_min : *min theta (in deg) (-ve = ignore)* ! -! :Dependencies: infile_utils, io, physcon, readwrite_dumps, units +! :Dependencies: infile_utils, io, part, physcon, readwrite_dumps, units ! implicit none character(len=10), parameter, public :: analysistype = 'tdeoutflow' diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index c28eff047..215620613 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -14,7 +14,9 @@ module moddump ! ! :Runtime parameters: ! - ieos : *equation of state used* -! - ignore_radius : *tde particle inside this radius will be ignored* +! - ignore_radius : *ignore tde particle inside this radius (-ve = ignore all for injection)* +! - m_target : *target mass in circumnuclear gas cloud (in Msun) (-ve = ignore and use rho0)* +! - m_threshold : *threshold in solving rho0 for m_target (in Msun)* ! - mu : *mean molecular density of the cloud* ! - nbreak : *number of broken power laws* ! - nprof : *number of data points in the cloud profile* @@ -23,7 +25,7 @@ module moddump ! - rad_min : *inner radius of the circumnuclear gas cloud* ! - remove_overlap : *remove outflow particles overlap with circum particles* ! - rhof_n_1 : *power law index of the section* -! - rhof_rho0 : *density at rad_min (in g/cm^3)* +! - rhof_rho0 : *density at rad_min (in g/cm^3) (-ve = ignore and calc for m_target)* ! - temperature : *temperature of the gas cloud (-ve = read from file)* ! - use_func : *if use broken power law for density profile* ! From 430eda59f839732ae7a28b7f44b3c808024f6df0 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 08:03:18 +1000 Subject: [PATCH 561/814] [space-bot] whitespace at end of lines removed --- src/main/inject_sim.f90 | 12 ++++++------ src/setup/set_orbit.f90 | 2 +- src/utils/analysis_radiotde.f90 | 22 +++++++++++----------- src/utils/analysis_tdeoutflow.f90 | 10 +++++----- src/utils/moddump_radiotde.f90 | 10 +++++----- 5 files changed, 28 insertions(+), 28 deletions(-) diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index a3ef5d934..f2f97dd05 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -31,7 +31,7 @@ module inject ! ! global variables - + character(len=120) :: start_dump,final_dump,pre_dump,next_dump integer :: npart_sim real :: r_inject,r_inject_cgs=-1,next_time!,e_inject @@ -65,7 +65,7 @@ subroutine init_inject(ierr) call get_dump_time_npart(trim(next_dump),next_time,ierr,npart_out=npart_sim) ierr = 0 niter = 0 - + do while (next_time < time .and. niter < max_niter) niter = niter + 1 pre_dump = next_dump @@ -78,7 +78,7 @@ subroutine init_inject(ierr) endif enddo start_dump = next_dump - + write(*,'(a,1x,es10.2)') ' Start read sims and inject particle from '//trim(next_dump)//' at t =',next_time r_inject = r_inject_cgs/udist ! to code unit @@ -123,8 +123,8 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& call find_next_dump(next_dump,next_time,ierr) start_dump = next_dump - write(*,'(i10,1x,a27,1x,a)') npart-npart_old, 'particles are injected from', trim(pre_dump) - + write(*,'(i10,1x,a27,1x,a)') npart-npart_old, 'particles are injected from', trim(pre_dump) + if (pre_dump == final_dump) then write(*,'(a)') ' Reach the final dumpfile. Stop injecting ...' next_time = huge(0.) @@ -256,7 +256,7 @@ subroutine read_injected_par() integer, parameter :: iunit=242 logical :: iexist integer :: nread,i - + inquire(file=trim(injected_filename),exist=iexist) if (iexist) then diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index bb7d74a2f..4d927fc71 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -8,7 +8,7 @@ module setorbit ! ! Generic procedure for setting up two body orbits with ! different parameter sets for the orbital elements -! +! ! The current options are: ! 0) Campbell elements for bound or unbound orbit (aeiOwf) ! 1) Flyby parameters (periapsis, initial separation, argument of periapsis, inclination) diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 21ef34315..5d3429272 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -35,7 +35,7 @@ module analysis real, dimension(:), allocatable :: rad_all,vr_all,v_all real, dimension(:), allocatable :: theta,plot_theta,phi,vr,vtheta,vphi logical, dimension(:), allocatable :: cap - real :: m_accum, m_cap + real :: m_accum, m_cap real :: vr_accum_mean, vr_accum_max, vr_cap_mean, vr_cap_max real :: r_accum_maxv, r_cap_maxv real :: v_accum_mean, v_cap_mean @@ -107,10 +107,10 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) endif ! read background entropy - if (npart_cnm < 0) then + if (npart_cnm < 0) then if (npart_tde_reserve < 0) npart_tde_reserve = 10*npart allocate(ent_bg(npart_tde_reserve+npart)) ! save more memory for later injection - npart_cnm = npart + npart_cnm = npart call record_background(pxyzu(4,:),0,npart,ent_bg) write(*,'(I9,1x,a16)') npart_cnm, 'particles in CNM' endif @@ -141,7 +141,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) allocate(theta(npart),plot_theta(npart),phi(npart),vr(npart),vtheta(npart), & vphi(npart),cap(npart)) cap = .false. - + call outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all) if (n_cap > 0) then @@ -194,14 +194,14 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) v_cap_mean, & e_accum*unit_energ, & e_cap*unit_energ - close(iunit) + close(iunit) write(*,'(I8,1X,A2,1X,I8,1X,A34)') n_cap, 'of', npart, 'particles are in the capture shell' write(*,'(I8,1X,A2,1X,I8,1X,A40)') n_accum, 'of', npart, 'particles are outside the capture radius' case ('shock') write(*,'(a)') ' Analysing the shock ...' - + call shock_analysis(npart,pmass,rad_all,vr_all,pxyzu(4,:)) deallocate(rad_all,vr_all,v_all) @@ -283,7 +283,7 @@ subroutine outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all) vri = vr_all(i) vr_accum_add = vr_accum_add + vri v_accum_add = v_accum_add + v - if (vri > vr_accum_max) then + if (vri > vr_accum_max) then vr_accum_max = vri r_accum_maxv = r endif @@ -303,7 +303,7 @@ subroutine outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all) e_cap = e_cap + 0.5*pmass*v**2 vr_cap_add = vr_cap_add + vri v_cap_add = v_cap_add + v - if (vri > vr_cap_max) then + if (vri > vr_cap_max) then vr_cap_max = vri r_cap_maxv = r endif @@ -326,9 +326,9 @@ subroutine record_background(ent,npart_old,npart_new,ent_bg) integer :: i print*, 'Record background entropy of ', npart_new, ' particles' - + do i=1,npart_new - ent_bg(npart_old+i) = ent(npart_old+i)*1.1 ! give some range for self evolution + ent_bg(npart_old+i) = ent(npart_old+i)*1.1 ! give some range for self evolution !(is there a reasonable choice instead of arbitrary?) enddo @@ -341,7 +341,7 @@ subroutine shock_analysis(npart,pmass,rad_all,vr_all,ent) real, intent(in) :: pmass,rad_all(:),vr_all(:),ent(:) integer :: i,n,n_cnm,n_tde real :: ri,half_m,ei,vi - ! + ! !------Determine the shock ! n = 0 diff --git a/src/utils/analysis_tdeoutflow.f90 b/src/utils/analysis_tdeoutflow.f90 index d0c149577..3012ee514 100644 --- a/src/utils/analysis_tdeoutflow.f90 +++ b/src/utils/analysis_tdeoutflow.f90 @@ -31,7 +31,7 @@ module analysis real, dimension(:), allocatable :: rad_all,vr_all,v_all real, dimension(:), allocatable :: theta,plot_theta,phi,vr,vtheta,vphi logical, dimension(:), allocatable :: cap - real :: m_accum, m_cap + real :: m_accum, m_cap real :: vr_accum_mean, vr_accum_max, vr_cap_mean, vr_cap_max real :: r_accum_maxv, r_cap_maxv real :: v_accum_mean, v_cap_mean @@ -119,7 +119,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) vout = 0. macc = 0. dt = 1. - else + else call outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all,mout,vrout,vout,macc) dt = time - told endif @@ -134,7 +134,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) else open(iunit,file=outfile,status='new') endif - + if (first) then write(iunit,"('#',5(1x,'[',i2.2,1x,a11,']',2x))") & 1,'time [s]', & @@ -149,7 +149,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) mout/dt*umass/utime, & vrout, & vout, & - macc/dt*umass/utime + macc/dt*umass/utime close(iunit) first = .false. @@ -205,7 +205,7 @@ subroutine outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all,mout,vro if (theta_max < theta_min .or. theta_max > 180.) theta_max = 180. if (phi_min < -90. .or. phi_min > 90.) phi_min = -90. if (phi_max < phi_min .or. phi_max > 90.) phi_max = 90. - + x = xyzh(1,i) y = xyzh(2,i) z = xyzh(3,i) diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 215620613..28af40a44 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -58,7 +58,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) use physcon, only:solarm,years,mass_proton_cgs,kb_on_mh,kboltz,radconst use setup_params, only:npart_total use part, only:igas,set_particle_type,pxyzu,delete_particles_inside_radius, & - delete_particles_outside_sphere,kill_particle,shuffle_part, & + delete_particles_outside_sphere,kill_particle,shuffle_part, & eos_vars,itemp,igamma,igasP use io, only:fatal,master,id use units, only:umass,udist,utime,set_units,unit_density @@ -109,7 +109,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) rhof_rbreak = rad_min m_target = dot_product(npartoftype,massoftype)*umass/solarm m_threshold = 1.e-3 - + !--Profile default setups read_temp = .false. profile_filename = default_name @@ -199,7 +199,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) else call fatal('moddump','Must give rho0 or m_target') endif - endif + endif !--remove unwanted particles if (ignore_radius > 0) then @@ -235,7 +235,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call set_particle_type(i,igas) r = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) rhofr = rhof(r) - if (read_temp) temperature = get_temp_r(r,rad_prof,temp_prof) + if (read_temp) temperature = get_temp_r(r,rad_prof,temp_prof) vxyzu(4,i) = uerg(rhofr,temperature,ieos) vxyzu(1:3,i) = 0. ! stationary for now pxyzu(4,i) = entropy(rhofr,temperature,ieos) @@ -390,7 +390,7 @@ subroutine calc_rho0(rhof) procedure(rho), pointer, intent(in) :: rhof real :: rho0_min,rho0_max,totmass integer :: iter - + rho0_min = 0. rho0_max = 1. totmass = -1. From fd5edb1d78e14f950e4ac75e294c6d14ec2b3b4d Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 08:03:18 +1000 Subject: [PATCH 562/814] [author-bot] updated AUTHORS file --- AUTHORS | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/AUTHORS b/AUTHORS index b139408e6..f236e7dc4 100644 --- a/AUTHORS +++ b/AUTHORS @@ -21,10 +21,10 @@ Rebecca Nealon Elisabeth Borchert Ward Homan Christophe Pinte +Yrisch Terrence Tricco Stephane Michoulier Simone Ceppi -Yrisch Spencer Magnall Enrico Ragusa Caitlyn Hardiman @@ -32,41 +32,42 @@ Sergei Biriukov Cristiano Longarini Giovanni Dipierro Roberto Iaconi -Amena Faruqi Hauke Worpel +Amena Faruqi Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi -Simon Glover -Sahl Rowther Thomas Reichardt +Sahl Rowther +Simon Glover Jean-François Gonzalez Christopher Russell +Phantom benchmark bot +Jolien Malfait Alex Pettitt Alessia Franchini -Jolien Malfait -Phantom benchmark bot -Nicole Rodrigues Kieran Hirsh -Farzana Meru +Nicole Rodrigues +Mike Lau Nicolás Cuello +Farzana Meru David Trevascus -Mike Lau -Miguel Gonzalez-Bolivar Chris Nixon -Orsola De Marco +Miguel Gonzalez-Bolivar Maxime Lombart Joe Fisher Giulia Ballabio -Benoit Commercon Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> -Steven Rieder -Taj Jankovič -Chunliang Mu +Benoit Commercon +Orsola De Marco MICHOULIER Stephane -Jorge Cuadra +Stéven Toupin +Taj Jankovič Cox, Samuel Jeremy Smallwood -Stéven Toupin +Hugh Griffiths +Chunliang Mu +Jorge Cuadra +Steven Rieder From 1fe67ef1d62a1dcc43d6def26e560d942a0723c0 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 08:03:35 +1000 Subject: [PATCH 563/814] [format-bot] end if -> endif; end do -> enddo; if( -> if ( --- src/main/ptmass.F90 | 2 +- src/main/subgroup.f90 | 28 ++++++++++++++-------------- src/main/substepping.F90 | 14 +++++++------- src/setup/set_hierarchical.f90 | 4 ++-- 4 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index cd8a5f2b7..49833bc4d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -384,7 +384,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin else i = k endif - if (extrap)then + if (extrap) then xi = xyzmh_ptmass(1,i) + extrapfac*fsink_old(1,i) yi = xyzmh_ptmass(2,i) + extrapfac*fsink_old(2,i) zi = xyzmh_ptmass(3,i) + extrapfac*fsink_old(3,i) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 39ef10697..a754e8d61 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -71,10 +71,10 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) visited = .false. group_info(igcum,1) = 0 do i=1,nptmass - if(.not.visited(i)) then + if (.not.visited(i)) then n_ingroup = n_ingroup + 1 call dfs(i,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) - if (ncg>1)then + if (ncg>1) then n_group = n_group + 1 group_info(igcum,n_group+1) = (ncg) + group_info(igcum,n_group) else @@ -154,7 +154,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) vyi = vxyz_ptmass(2,i) vzi = vxyz_ptmass(3,i) do j=1,nptmass - if(i==j) cycle + if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) @@ -163,7 +163,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) if (rr_search) then + elseif (r>r_search) then nmatrix(i,j) = 0 cycle endif @@ -206,7 +206,7 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz real, intent(in) :: tnext,time integer :: i,start_id,end_id,gsize if (n_group>0) then - if(id==master) then + if (id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& !$omp shared(tnext,time,group_info,gtgrad,n_group)& @@ -249,7 +249,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ismultiple = gsize > 2 - if(ismultiple) then + if (ismultiple) then call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,W,start_id,end_id,ds_init=ds_init) else prim = group_info(igarg,start_id) @@ -294,7 +294,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ step_count_int = step_count_int + 1 - if(step_count_int > max_step) then + if (step_count_int > max_step) then print*,"MAX STEP NUMBER, ABORT !!!" call abort endif @@ -319,7 +319,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ step_modif = min(max(step_modif,0.0625),0.5) ds(switch) = ds(switch)*step_modif ds(3-switch) = ds(switch) - else if ((n_step_end > 1) .and. (dt<0.3*dt_end)) then + elseif ((n_step_end > 1) .and. (dt<0.3*dt_end)) then ds(3-switch) = ds(switch) * dt_end/dt else n_step_end = n_step_end + 1 @@ -333,7 +333,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ backup_flag = .false. endif - else if (tcoord > tnext + time_error) then + elseif (tcoord > tnext + time_error) then t_end_flag = .true. backup_flag = .false. n_step_end = 0 @@ -377,7 +377,7 @@ subroutine new_ds_sync_sup(ds,time_table,tnext,switch) real :: tp,dtc,dstmp do i=1,ck_size k = cck_sorted_id(i) - if(tnext0) then - if(id==master) then + if (id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,fxyz_ptmass)& !$omp shared(group_info,gtgrad,n_group)& diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 76f712e30..f02386e49 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -607,9 +607,9 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx !$omp end parallel do ! Drift sink particles - if(nptmass>0) then - if(id==master) then - if(present(n_ingroup)) then + if (nptmass>0) then + if (id==master) then + if (present(n_ingroup)) then call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,group_info,n_ingroup) else call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) @@ -859,7 +859,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, extrap = .false. endif - if(present(group_info)) then + if (present(group_info)) then wsub = .true. else wsub = .false. @@ -888,7 +888,7 @@ 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 + if (wsub) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & extrapfac,fsink_old,group_info) @@ -910,7 +910,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, endif endif else - if(wsub) 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=group_info) if (merge_n > 0) then @@ -1012,7 +1012,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! Radiation pressure force with isink_radiation ! if (nptmass > 0 .and. isink_radiation > 0) then - if(extrap) then + 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) diff --git a/src/setup/set_hierarchical.f90 b/src/setup/set_hierarchical.f90 index b30dc1229..72d4aa0a1 100644 --- a/src/setup/set_hierarchical.f90 +++ b/src/setup/set_hierarchical.f90 @@ -496,10 +496,10 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & if (present(subst)) then if (subst>10) then if (iexist) then - open(1, file = trim(filename), status = 'old') + open(1,file=trim(filename),status='old') lines=0 do - read(1, *, iostat=io) data(lines+1,:) + read(1, *,iostat=io) data(lines+1,:) if (io/=0) exit lines = lines + 1 enddo From d9ddae07e44168b6044276fdf4dcb0d26d3cac20 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 08:03:54 +1000 Subject: [PATCH 564/814] [indent-bot] standardised indentation --- src/main/checkconserved.f90 | 8 +- src/main/inject_sim.f90 | 282 ++++++++++++------------ src/setup/set_hierarchical.f90 | 284 ++++++++++++------------- src/setup/set_orbit.f90 | 60 +++--- src/setup/set_star.f90 | 2 +- src/tests/test_wind.f90 | 54 ++--- src/utils/analysis_common_envelope.f90 | 2 +- src/utils/analysis_radiotde.f90 | 8 +- 8 files changed, 350 insertions(+), 350 deletions(-) diff --git a/src/main/checkconserved.f90 b/src/main/checkconserved.f90 index a5538d537..9fb43c454 100644 --- a/src/main/checkconserved.f90 +++ b/src/main/checkconserved.f90 @@ -132,10 +132,10 @@ subroutine check_magnetic_stability(hdivBonB_ave,hdivBonB_max) real, intent(in) :: hdivBonB_ave,hdivBonB_max if (hdivBonB_max > 100 .or. hdivBonB_ave > 0.1) then - ! Tricco, Price & Bate (2016) suggest the average should remain lower than 0.01, - ! but we will increase it here due to the nature of the exiting the code - ! The suggestion of 512 was empirically determined in Dobbs & Wurster (2021) - call do_not_publish_crap('evolve','h|divb|/b is too large; recommend to increase the overcleanfac') + ! Tricco, Price & Bate (2016) suggest the average should remain lower than 0.01, + ! but we will increase it here due to the nature of the exiting the code + ! The suggestion of 512 was empirically determined in Dobbs & Wurster (2021) + call do_not_publish_crap('evolve','h|divb|/b is too large; recommend to increase the overcleanfac') endif end subroutine check_magnetic_stability diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index f2f97dd05..a305b8dc8 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -137,168 +137,168 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& dtinject = tfac*(next_time - time) end subroutine inject_particles - subroutine read_dump(filename,xyzh_dump,ierr,vxyzu_dump,pxyzu_dump) - use dump_utils, only: read_array_from_file - character(len=*), intent(in) :: filename - real, intent(out) :: xyzh_dump(:,:) - integer, intent(out) :: ierr - real, intent(out), optional :: vxyzu_dump(:,:),pxyzu_dump(:,:) - integer, parameter :: iunit = 578 - real(kind=4) :: h(npart_sim) - - ! - !--read xyzh - ! - call read_array_from_file(iunit,filename,'x',xyzh_dump(1,:),ierr,iprint_in=.false.) - call read_array_from_file(iunit,filename,'y',xyzh_dump(2,:),ierr,iprint_in=.false.) - call read_array_from_file(iunit,filename,'z',xyzh_dump(3,:),ierr,iprint_in=.false.) - call read_array_from_file(iunit,filename,'h',h,ierr,iprint_in=.false.) - xyzh_dump(4,:) = h - - ! - !--read vxyzu - ! - if (present(vxyzu_dump)) then - call read_array_from_file(iunit,filename,'vx',vxyzu_dump(1,:),ierr,iprint_in=.false.) - call read_array_from_file(iunit,filename,'vy',vxyzu_dump(2,:),ierr,iprint_in=.false.) - call read_array_from_file(iunit,filename,'vz',vxyzu_dump(3,:),ierr,iprint_in=.false.) - call read_array_from_file(iunit,filename,'u',vxyzu_dump(4,:),ierr,iprint_in=.false.) - endif +subroutine read_dump(filename,xyzh_dump,ierr,vxyzu_dump,pxyzu_dump) + use dump_utils, only: read_array_from_file + character(len=*), intent(in) :: filename + real, intent(out) :: xyzh_dump(:,:) + integer, intent(out) :: ierr + real, intent(out), optional :: vxyzu_dump(:,:),pxyzu_dump(:,:) + integer, parameter :: iunit = 578 + real(kind=4) :: h(npart_sim) - ! - !--read vxyzu - ! - if (present(pxyzu_dump)) then - call read_array_from_file(iunit,filename,'px',pxyzu_dump(1,:),ierr,iprint_in=.false.) - call read_array_from_file(iunit,filename,'py',pxyzu_dump(2,:),ierr,iprint_in=.false.) - call read_array_from_file(iunit,filename,'pz',pxyzu_dump(3,:),ierr,iprint_in=.false.) - call read_array_from_file(iunit,filename,'entropy',pxyzu_dump(4,:),ierr,iprint_in=.false.) - endif + ! + !--read xyzh + ! + call read_array_from_file(iunit,filename,'x',xyzh_dump(1,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'y',xyzh_dump(2,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'z',xyzh_dump(3,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'h',h,ierr,iprint_in=.false.) + xyzh_dump(4,:) = h + + ! + !--read vxyzu + ! + if (present(vxyzu_dump)) then + call read_array_from_file(iunit,filename,'vx',vxyzu_dump(1,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'vy',vxyzu_dump(2,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'vz',vxyzu_dump(3,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'u',vxyzu_dump(4,:),ierr,iprint_in=.false.) + endif + + ! + !--read vxyzu + ! + if (present(pxyzu_dump)) then + call read_array_from_file(iunit,filename,'px',pxyzu_dump(1,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'py',pxyzu_dump(2,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'pz',pxyzu_dump(3,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'entropy',pxyzu_dump(4,:),ierr,iprint_in=.false.) + endif - end subroutine read_dump - - subroutine get_dump_time_npart(filename,time,ierr,npart_out) - use io, only:iprint,id,nprocs - use dump_utils, only:dump_h,open_dumpfile_r,read_header,free_header - use part, only:maxtypes - use readwrite_dumps_fortran, only:unfill_header - use readwrite_dumps_common, only:get_options_from_fileid - - character(len=*), intent(in) :: filename - real, intent(out) :: time - integer, intent(out) :: ierr - integer, intent(out), optional :: npart_out - integer, parameter :: idisk=389 - character(len=120) :: fileid - logical :: tagged,phantomdump,smalldump,use_dustfrac - type(dump_h) :: hdr - integer(kind=8) :: nparttot - integer :: nblocks,npartoftype(maxtypes),npart - real :: hfactfile,alphafile - - call open_dumpfile_r(idisk,filename,fileid,ierr) - call get_options_from_fileid(fileid,tagged,phantomdump,smalldump,use_dustfrac,ierr) - call read_header(idisk,hdr,ierr,tagged=tagged) - call unfill_header(hdr,phantomdump,tagged,nparttot, & +end subroutine read_dump + +subroutine get_dump_time_npart(filename,time,ierr,npart_out) + use io, only:iprint,id,nprocs + use dump_utils, only:dump_h,open_dumpfile_r,read_header,free_header + use part, only:maxtypes + use readwrite_dumps_fortran, only:unfill_header + use readwrite_dumps_common, only:get_options_from_fileid + + character(len=*), intent(in) :: filename + real, intent(out) :: time + integer, intent(out) :: ierr + integer, intent(out), optional :: npart_out + integer, parameter :: idisk=389 + character(len=120) :: fileid + logical :: tagged,phantomdump,smalldump,use_dustfrac + type(dump_h) :: hdr + integer(kind=8) :: nparttot + integer :: nblocks,npartoftype(maxtypes),npart + real :: hfactfile,alphafile + + call open_dumpfile_r(idisk,filename,fileid,ierr) + call get_options_from_fileid(fileid,tagged,phantomdump,smalldump,use_dustfrac,ierr) + call read_header(idisk,hdr,ierr,tagged=tagged) + call unfill_header(hdr,phantomdump,tagged,nparttot, & nblocks,npart,npartoftype, & time,hfactfile,alphafile,iprint,id,nprocs,ierr) - call free_header(hdr,ierr) - close(idisk) + call free_header(hdr,ierr) + close(idisk) - if (present(npart_out)) npart_out = npart + if (present(npart_out)) npart_out = npart - end subroutine get_dump_time_npart +end subroutine get_dump_time_npart - subroutine find_next_dump(next_dump,next_time,ierr) - character(len=*), intent(inout) :: next_dump - real, intent(out) :: next_time - integer, intent(out) :: ierr +subroutine find_next_dump(next_dump,next_time,ierr) + character(len=*), intent(inout) :: next_dump + real, intent(out) :: next_time + integer, intent(out) :: ierr - next_dump = getnextfilename(next_dump) - call get_dump_time_npart(next_dump,next_time,ierr) - - end subroutine find_next_dump - - subroutine inject_required_part_tde(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next,pxyzu_next) - use part, only:igas,pxyzu,isdead_or_accreted - use partinject, only:add_or_update_particle - integer, intent(inout) :: npart, npartoftype(:) - real, intent(inout) :: xyzh(:,:), vxyzu(:,:) - real, intent(in) :: xyzh_pre(:,:), xyzh_next(:,:), vxyzu_next(:,:), pxyzu_next(:,:) - integer :: i,partid - real :: r_next,r_pre,vr_next!,e_next - - ! - !--check all the particles - ! - do i=1,npart_sim - if (.not. isdead_or_accreted(xyzh_next(4,i)) .and. .not. injected(i)) then - r_next = sqrt(dot_product(xyzh_next(1:3,i),xyzh_next(1:3,i))) - r_pre = sqrt(dot_product(xyzh_pre(1:3,i),xyzh_pre(1:3,i))) - vr_next = (dot_product(xyzh_next(1:3,i),vxyzu_next(1:3,i)))/r_next - !e_next = 0.5*vr_next**2 - 1./r_next - - if (r_next > r_inject .and. r_pre < r_inject .and. vr_next > 0.) then! .and. e_next > e_inject) then - ! inject particle by copy the data into position - partid = npart+1 - call add_or_update_particle(igas,xyzh_next(1:3,i),vxyzu_next(1:3,i),xyzh_next(4,i), & + next_dump = getnextfilename(next_dump) + call get_dump_time_npart(next_dump,next_time,ierr) + +end subroutine find_next_dump + +subroutine inject_required_part_tde(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next,pxyzu_next) + use part, only:igas,pxyzu,isdead_or_accreted + use partinject, only:add_or_update_particle + integer, intent(inout) :: npart, npartoftype(:) + real, intent(inout) :: xyzh(:,:), vxyzu(:,:) + real, intent(in) :: xyzh_pre(:,:), xyzh_next(:,:), vxyzu_next(:,:), pxyzu_next(:,:) + integer :: i,partid + real :: r_next,r_pre,vr_next!,e_next + + ! + !--check all the particles + ! + do i=1,npart_sim + if (.not. isdead_or_accreted(xyzh_next(4,i)) .and. .not. injected(i)) then + r_next = sqrt(dot_product(xyzh_next(1:3,i),xyzh_next(1:3,i))) + r_pre = sqrt(dot_product(xyzh_pre(1:3,i),xyzh_pre(1:3,i))) + vr_next = (dot_product(xyzh_next(1:3,i),vxyzu_next(1:3,i)))/r_next + !e_next = 0.5*vr_next**2 - 1./r_next + + if (r_next > r_inject .and. r_pre < r_inject .and. vr_next > 0.) then! .and. e_next > e_inject) then + ! inject particle by copy the data into position + partid = npart+1 + call add_or_update_particle(igas,xyzh_next(1:3,i),vxyzu_next(1:3,i),xyzh_next(4,i), & vxyzu_next(4,i),partid,npart,npartoftype,xyzh,vxyzu) - pxyzu(:,partid) = pxyzu_next(:,i) - injected(i) = .true. - endif + pxyzu(:,partid) = pxyzu_next(:,i) + injected(i) = .true. endif - enddo + endif + enddo - end subroutine inject_required_part_tde +end subroutine inject_required_part_tde - subroutine read_injected_par() - use io, only:fatal,warning - integer, parameter :: iunit=242 - logical :: iexist - integer :: nread,i +subroutine read_injected_par() + use io, only:fatal,warning + integer, parameter :: iunit=242 + logical :: iexist + integer :: nread,i - inquire(file=trim(injected_filename),exist=iexist) + inquire(file=trim(injected_filename),exist=iexist) - if (iexist) then - open(iunit,file=trim(injected_filename),status='old') - read(iunit,*) nread + if (iexist) then + open(iunit,file=trim(injected_filename),status='old') + read(iunit,*) nread - ! check if npart in file is the same as npart_sim - if (nread /= npart_sim) call fatal('inject_sim','npart in '//trim(injected_filename)// & + ! check if npart in file is the same as npart_sim + if (nread /= npart_sim) call fatal('inject_sim','npart in '//trim(injected_filename)// & ' does not match npart_sim') - do i=1,nread - read(iunit,*) injected(i) - enddo - close(iunit) - else - call warning('inject_sim',trim(injected_filename)//' not found, assume no particles are injected') - injected = .false. - endif - - end subroutine + do i=1,nread + read(iunit,*) injected(i) + enddo + close(iunit) + else + call warning('inject_sim',trim(injected_filename)//' not found, assume no particles are injected') + injected = .false. + endif - subroutine update_injected_par() - use io, only:error - integer, parameter :: iunit=284 - logical :: iexist - integer :: i +end subroutine - if (allocated(injected)) then - inquire(file=trim(injected_filename),exist=iexist) - if (iexist) then - open(iunit,file=trim(injected_filename),status='replace') - else - open(iunit,file=trim(injected_filename),status='new') - endif +subroutine update_injected_par() + use io, only:error + integer, parameter :: iunit=284 + logical :: iexist + integer :: i - write(iunit,*) npart_sim - do i=1,npart_sim - write(iunit,*) injected(i) - enddo - close(iunit) + if (allocated(injected)) then + inquire(file=trim(injected_filename),exist=iexist) + if (iexist) then + open(iunit,file=trim(injected_filename),status='replace') + else + open(iunit,file=trim(injected_filename),status='new') endif - end subroutine + + write(iunit,*) npart_sim + do i=1,npart_sim + write(iunit,*) injected(i) + enddo + close(iunit) + endif +end subroutine !----------------------------------------------------------------------- !+ diff --git a/src/setup/set_hierarchical.f90 b/src/setup/set_hierarchical.f90 index 72d4aa0a1..bb2fc7733 100644 --- a/src/setup/set_hierarchical.f90 +++ b/src/setup/set_hierarchical.f90 @@ -539,74 +539,74 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & !--- Checks to avoid bad substitutions if (present(subst)) then if (subst>10) then - write(hier_prefix, *) subst - io=0 - mtot = 0. - do i=1,lines - if (data(i,2)==abs(subst)) then ! Check that star to be substituted exists in HIERARCHY file - if (data(i,1)==0) then ! Check that star to be substituted has not already been substituted - print "(1x,a)",'ERROR: set_multiple: star '//trim(hier_prefix)//' substituted yet.' - ierr = ierr_subststar - endif - subst_index = int(data(i,1)) - data(i,1) = 0 - - if (subst>0) then - rel_posang_ascnode = data(i, 10) - - if (rel_posang_ascnode /= 0) then - print "(1x,a)",'ERROR: set_multiple: at the moment phantom can subst only Omega=0 binaries.' - ierr = ierr_Omegasubst + write(hier_prefix, *) subst + io=0 + mtot = 0. + do i=1,lines + if (data(i,2)==abs(subst)) then ! Check that star to be substituted exists in HIERARCHY file + if (data(i,1)==0) then ! Check that star to be substituted has not already been substituted + print "(1x,a)",'ERROR: set_multiple: star '//trim(hier_prefix)//' substituted yet.' + ierr = ierr_subststar + endif + subst_index = int(data(i,1)) + data(i,1) = 0 + + if (subst>0) then + rel_posang_ascnode = data(i, 10) + + if (rel_posang_ascnode /= 0) then + print "(1x,a)",'ERROR: set_multiple: at the moment phantom can subst only Omega=0 binaries.' + ierr = ierr_Omegasubst + endif + + rel_arg_peri= data(i, 9) + rel_incl = data(i, 8) + else + rel_posang_ascnode = posang_ascnode + rel_arg_peri = arg_peri + rel_incl = incl endif - rel_arg_peri= data(i, 9) - rel_incl = data(i, 8) - else - rel_posang_ascnode = posang_ascnode - rel_arg_peri = arg_peri - rel_incl = incl - endif + mtot = data(i, 3) + m_comp = data(i, 4) + a_comp = data(i, 5) + e_comp = data(i, 6) - mtot = data(i, 3) - m_comp = data(i, 4) - a_comp = data(i, 5) - e_comp = data(i, 6) + q_comp = mtot/m_comp + if (q_comp>1) q_comp=q_comp**(-1) - q_comp = mtot/m_comp - if (q_comp>1) q_comp=q_comp**(-1) + ! Mardling&Aarseth (2001) criterion check - ! Mardling&Aarseth (2001) criterion check + period_ratio = sqrt((a_comp*a_comp*a_comp)/(m_comp+mtot)/(semimajoraxis*semimajoraxis*semimajoraxis)*(mtot)) ! Po/Pi + criterion = 4.7*(1-e_comp)**(-1.8)*(1+e_comp)**(0.6)*(1+q_comp)**(0.1) - period_ratio = sqrt((a_comp*a_comp*a_comp)/(m_comp+mtot)/(semimajoraxis*semimajoraxis*semimajoraxis)*(mtot)) ! Po/Pi - criterion = 4.7*(1-e_comp)**(-1.8)*(1+e_comp)**(0.6)*(1+q_comp)**(0.1) + if (criterion > period_ratio) then + print "(1x,a)",'WARNING: set_multiple: orbital parameters does not satisfy Mardling and Aarseth stability criterion.' + endif - if (criterion > period_ratio) then - print "(1x,a)",'WARNING: set_multiple: orbital parameters does not satisfy Mardling and Aarseth stability criterion.' - endif + q2=m2/m1 + mprimary = mtot/(1+q2) + msecondary = mtot*q2/(1+q2) - q2=m2/m1 - mprimary = mtot/(1+q2) - msecondary = mtot*q2/(1+q2) + io=1 + exit + endif + enddo - io=1 - exit + if (io == 0) then + print "(1x,a)",'ERROR: set_multiple: star '//trim(hier_prefix)//' not present in HIERARCHY file.' + ierr = ierr_missstar endif - enddo - if (io == 0) then - print "(1x,a)",'ERROR: set_multiple: star '//trim(hier_prefix)//' not present in HIERARCHY file.' - ierr = ierr_missstar - endif - - if (subst_index > 0 .and. subst_index <= size(xyzmh_ptmass(1,:))) then ! check for seg fault - x_subst(:)=xyzmh_ptmass(1:3,subst_index) - v_subst(:)=vxyz_ptmass(:,subst_index) - endif - !i1 = subst_index - !i2 = nptmass + 1 - !nptmass = nptmass + 1 + if (subst_index > 0 .and. subst_index <= size(xyzmh_ptmass(1,:))) then ! check for seg fault + x_subst(:)=xyzmh_ptmass(1:3,subst_index) + v_subst(:)=vxyz_ptmass(:,subst_index) + endif + !i1 = subst_index + !i2 = nptmass + 1 + !nptmass = nptmass + 1 - period = sqrt(4.*pi**2*semimajoraxis**3/mtot) + period = sqrt(4.*pi**2*semimajoraxis**3/mtot) endif else mprimary = m1 @@ -626,110 +626,110 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & if (present(subst)) then if (subst>10) then - !--- lower nptmass, copy one of the new sinks to the subst star - nptmass = nptmass-1 - i1 = subst_index - i2 = nptmass + !--- lower nptmass, copy one of the new sinks to the subst star + nptmass = nptmass-1 + i1 = subst_index + i2 = nptmass - ! positions and accretion radii - xyzmh_ptmass(1:6,i1) = xyzmh_ptmass(1:6,nptmass+1) + ! positions and accretion radii + xyzmh_ptmass(1:6,i1) = xyzmh_ptmass(1:6,nptmass+1) - ! test Jolien + ! test Jolien ! print "(5(2x,a,g12.3,/),2x,a,g12.3)", & ! 'i1 :',i1, & ! 'mass i1:',xyzmh_ptmass(4,i1), & ! 'i2 :',i2, & ! 'mass i2:',xyzmh_ptmass(4,i2) - ! velocities - vxyz_ptmass(:,i1) = vxyz_ptmass(:,nptmass+1) - - !--- - ! Rotate the substituting binary with orientational parameters - ! referring to the substituted star's orbital plane - if (subst>0) then - - omega = rel_arg_peri*pi/180. - !big_omega = rel_posang_ascnode*pi/180.! + 0.5*pi - inc = rel_incl*pi/180. - - ! Retrieve eulerian angles of the substituted star orbit's semi-major axis (y axis) - if (omega <= pi/2) then - beta_y = omega - sign_alpha=-1 - if (inc <= pi) then - sign_gamma=1 + ! velocities + vxyz_ptmass(:,i1) = vxyz_ptmass(:,nptmass+1) + + !--- + ! Rotate the substituting binary with orientational parameters + ! referring to the substituted star's orbital plane + if (subst>0) then + + omega = rel_arg_peri*pi/180. + !big_omega = rel_posang_ascnode*pi/180.! + 0.5*pi + inc = rel_incl*pi/180. + + ! Retrieve eulerian angles of the substituted star orbit's semi-major axis (y axis) + if (omega <= pi/2) then + beta_y = omega + sign_alpha=-1 + if (inc <= pi) then + sign_gamma=1 + else + sign_gamma=-1 + endif else - sign_gamma=-1 + beta_y = 2*pi-omega + sign_alpha=1 + if (inc <= pi) then + sign_gamma=-1 + else + sign_gamma=1 + endif endif - else - beta_y = 2*pi-omega - sign_alpha=1 + gamma_y=acos(sign_gamma*sin(beta_y)*sin(inc)) + alpha_y=acos(sign_alpha*sqrt(abs(sin(beta_y)**2-cos(gamma_y)**2))) ! Needs abs cause float approx for cos + + ! Retrieve eulerian angles of the axis perpendicular to the substituted star orbital plane (z axis) + beta_z = pi/2. + gamma_z = inc + alpha_z = pi/2. - inc if (inc <= pi) then - sign_gamma=-1 - else - sign_gamma=1 + gamma_z=inc + if (inc <= pi/2.) then + alpha_z = pi/2.-inc + elseif (inc > pi/2.) then + alpha_z = inc-pi/2. + endif + elseif (inc < 2.*pi .and. inc > pi) then + gamma_z = 2.*pi-inc + if (inc <= 3.*pi/2.) then + alpha_z = inc-pi/2 + elseif (inc > 3.*pi/2.) then + alpha_z = 5.*pi/2.-inc + endif endif - endif - gamma_y=acos(sign_gamma*sin(beta_y)*sin(inc)) - alpha_y=acos(sign_alpha*sqrt(abs(sin(beta_y)**2-cos(gamma_y)**2))) ! Needs abs cause float approx for cos - ! Retrieve eulerian angles of the axis perpendicular to the substituted star orbital plane (z axis) - beta_z = pi/2. - gamma_z = inc - alpha_z = pi/2. - inc - if (inc <= pi) then - gamma_z=inc - if (inc <= pi/2.) then - alpha_z = pi/2.-inc - elseif (inc > pi/2.) then - alpha_z = inc-pi/2. - endif - elseif (inc < 2.*pi .and. inc > pi) then - gamma_z = 2.*pi-inc - if (inc <= 3.*pi/2.) then - alpha_z = inc-pi/2 - elseif (inc > 3.*pi/2.) then - alpha_z = 5.*pi/2.-inc - endif + ! Rotate substituting sinks by argument of pericenter around the z axis + call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, arg_peri*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, arg_peri*pi/180) + call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, arg_peri*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, arg_peri*pi/180) + + ! Rotate substituting sinks by inclination around the y axis + call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_y,beta_y,gamma_y, incl*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i1),alpha_y,beta_y,gamma_y, incl*pi/180) + call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_y,beta_y,gamma_y, incl*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i2),alpha_y,beta_y,gamma_y, incl*pi/180) + + ! Rotate substituting sinks by ascending node longitude around the z axis + call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) + call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) endif - ! Rotate substituting sinks by argument of pericenter around the z axis - call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, arg_peri*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, arg_peri*pi/180) - call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, arg_peri*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, arg_peri*pi/180) - - ! Rotate substituting sinks by inclination around the y axis - call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_y,beta_y,gamma_y, incl*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i1),alpha_y,beta_y,gamma_y, incl*pi/180) - call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_y,beta_y,gamma_y, incl*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i2),alpha_y,beta_y,gamma_y, incl*pi/180) - - ! Rotate substituting sinks by ascending node longitude around the z axis - call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) - call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) - endif - - ! Move the substituting binary's center of mass in the substituted star position - xyzmh_ptmass(1:3,i1) = xyzmh_ptmass(1:3,i1)+x_subst - xyzmh_ptmass(1:3,i2) = xyzmh_ptmass(1:3,i2)+x_subst - ! Set the substituting binary's center of mass velocity - vxyz_ptmass(:,i1) = vxyz_ptmass(:,i1)+v_subst - vxyz_ptmass(:,i2) = vxyz_ptmass(:,i2)+v_subst + ! Move the substituting binary's center of mass in the substituted star position + xyzmh_ptmass(1:3,i1) = xyzmh_ptmass(1:3,i1)+x_subst + xyzmh_ptmass(1:3,i2) = xyzmh_ptmass(1:3,i2)+x_subst + ! Set the substituting binary's center of mass velocity + vxyz_ptmass(:,i1) = vxyz_ptmass(:,i1)+v_subst + vxyz_ptmass(:,i2) = vxyz_ptmass(:,i2)+v_subst - ! Write updated HIERARCHY file with the two new stars and the substituted one - open(1,file=trim(filename),status='old') - do i=1,lines - write(1,*) int(data(i,1)), int(data(i,2)), data(i,3:) - enddo - write(1,*) i1, trim(hier_prefix)//"1", mprimary, msecondary, semimajoraxis, eccentricity, & + ! Write updated HIERARCHY file with the two new stars and the substituted one + open(1,file=trim(filename),status='old') + do i=1,lines + write(1,*) int(data(i,1)), int(data(i,2)), data(i,3:) + enddo + write(1,*) i1, trim(hier_prefix)//"1", mprimary, msecondary, semimajoraxis, eccentricity, & period, incl, arg_peri, posang_ascnode - write(1,*) i2, trim(hier_prefix)//"2", msecondary, mprimary, semimajoraxis, eccentricity, & + write(1,*) i2, trim(hier_prefix)//"2", msecondary, mprimary, semimajoraxis, eccentricity, & period, incl, arg_peri, posang_ascnode - close(1) + close(1) endif endif diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index 4d927fc71..6940ad2aa 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -52,36 +52,36 @@ module setorbit ! to setup an orbit ! type campbell_elems - character(len=20) :: semi_major_axis ! string because can specific units - real :: e ! eccentricity - real :: i ! inclination - real :: O ! position angle of the ascending node - real :: w ! argument of periapsis - real :: f ! initial true anomaly + character(len=20) :: semi_major_axis ! string because can specific units + real :: e ! eccentricity + real :: i ! inclination + real :: O ! position angle of the ascending node + real :: w ! argument of periapsis + real :: f ! initial true anomaly 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 + 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 end type posvel_elems type flyby_elems - character(len=20) :: rp ! pericentre distance in arbitrary units - real :: d ! initial separation - real :: O ! position angle of the ascending node - real :: i ! inclination + character(len=20) :: rp ! pericentre distance in arbitrary units + real :: d ! initial separation + real :: O ! position angle of the ascending node + real :: i ! inclination end type flyby_elems ! ! generic type handling all options ! type orbit_t - integer :: itype - type(campbell_elems) :: elems - type(flyby_elems) :: flyby - type(posvel_elems) :: posvel + integer :: itype + type(campbell_elems) :: elems + type(flyby_elems) :: flyby + type(posvel_elems) :: posvel end type orbit_t private @@ -142,16 +142,16 @@ subroutine set_orbit(orbit,m1,m2,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ve ierr = 0 select case(orbit%itype) case(2) - ! body 1 - xyzmh_ptmass(1:3,nptmass+1) = orbit%posvel%x1(1:3) - xyzmh_ptmass(4,nptmass+1) = m1 - xyzmh_ptmass(5,nptmass+1) = hacc1 - vxyz_ptmass(1:3,nptmass+1) = orbit%posvel%v1(1:3) - ! body 2 - xyzmh_ptmass(1:3,nptmass+2) = orbit%posvel%x2(1:3) - xyzmh_ptmass(4,nptmass+2) = m2 - xyzmh_ptmass(5,nptmass+2) = hacc2 - vxyz_ptmass(1:3,nptmass+2) = orbit%posvel%v2(1:3) + ! body 1 + xyzmh_ptmass(1:3,nptmass+1) = orbit%posvel%x1(1:3) + xyzmh_ptmass(4,nptmass+1) = m1 + xyzmh_ptmass(5,nptmass+1) = hacc1 + vxyz_ptmass(1:3,nptmass+1) = orbit%posvel%v1(1:3) + ! body 2 + xyzmh_ptmass(1:3,nptmass+2) = orbit%posvel%x2(1:3) + xyzmh_ptmass(4,nptmass+2) = m2 + xyzmh_ptmass(5,nptmass+2) = hacc2 + vxyz_ptmass(1:3,nptmass+2) = orbit%posvel%v2(1:3) case(1) rp = in_code_units(orbit%flyby%rp,ierr) @@ -181,7 +181,7 @@ subroutine set_orbit(orbit,m1,m2,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ve posang_ascnode=orbit%elems%O,arg_peri=orbit%elems%w,& incl=orbit%elems%i,f=orbit%elems%f,verbose=verbose) endif - end select + end select end subroutine set_orbit @@ -282,4 +282,4 @@ subroutine read_options_orbit(orbit,db,nerr,label) end subroutine read_options_orbit -end module setorbit \ No newline at end of file +end module setorbit diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 9eaccea82..cea8982c8 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -62,7 +62,7 @@ module setstar public :: need_polyk integer, parameter :: istar_offset = 3 ! offset for particle type to distinguish particles - ! placed in stars from other particles in the simulation + ! placed in stars from other particles in the simulation private diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index c89b2278a..65de7fb84 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -26,7 +26,7 @@ module testwind logical :: vb = .false. - contains +contains !---------------------------------------------------------- !+ ! Unit tests of timestepping and boundary crossing @@ -106,7 +106,7 @@ subroutine test_wind(ntests,npass) call allocate_array('dust_temp',dust_temp,maxTdust) call init_testwind(2,ntests,npass,npart_old,istepfrac,dtinject) - !if (id==master) call write_infile('w2.in','w2.log','w2.ev','w2_00000',iwritein,iprint) + !if (id==master) call write_infile('w2.in','w2.log','w2.ev','w2_00000',iwritein,iprint) call integrate_wind(npart_old,istepfrac,dtinject) nfailed(:) = 0 eint = sum(vxyzu(4,1:npart)) @@ -228,38 +228,38 @@ subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) npart_old = npart !trans-sonic wind - no radiation -if (icase == 1) then - ! check particle's mass - call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + if (icase == 1) then + ! check particle's mass + call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& npart,npart_old,npartoftype,dtinject) - call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) + call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) ! check 1D wind profile - i = size(trvurho_1D(1,:)) - if (vb) print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) - call checkval(massoftype(igas),1.490822861042279E-9,epsilon(0.),nfailed(1),'setting particle mass') - call checkval(trvurho_1D(2,i),7.058624412798283E+13,epsilon(0.),nfailed(2),'1D wind terminal radius') - call checkval(trvurho_1D(3,i),1.112160584479353E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') - call checkval(trvurho_1D(4,i),2.031820842001706E+12,epsilon(0.),nfailed(4),'1D wind internal energy') - call checkval(trvurho_1D(5,i),8.878887149408118E-15,epsilon(0.),nfailed(5),'1D wind terminal density') - call update_test_scores(ntests,nfailed,npass) + i = size(trvurho_1D(1,:)) + if (vb) print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) + call checkval(massoftype(igas),1.490822861042279E-9,epsilon(0.),nfailed(1),'setting particle mass') + call checkval(trvurho_1D(2,i),7.058624412798283E+13,epsilon(0.),nfailed(2),'1D wind terminal radius') + call checkval(trvurho_1D(3,i),1.112160584479353E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') + call checkval(trvurho_1D(4,i),2.031820842001706E+12,epsilon(0.),nfailed(4),'1D wind internal energy') + call checkval(trvurho_1D(5,i),8.878887149408118E-15,epsilon(0.),nfailed(5),'1D wind terminal density') + call update_test_scores(ntests,nfailed,npass) endif !wind + radiation if (icase == 2) then - ! check particle's mass - call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) - call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) - - ! check 1D wind profile - i = size(trvurho_1D(1,:)) - if (vb) print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) - call checkval(massoftype(igas),6.820748526700016E-10,epsilon(0.),nfailed(1),'setting particle mass') - call checkval(trvurho_1D(2,i), 1.546371444697654E+14,epsilon(0.),nfailed(2),'1D wind terminal radius') - call checkval(trvurho_1D(3,i), 4.298693548460183E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') - call checkval(trvurho_1D(4,i), 4.318674031561777E+10,epsilon(0.),nfailed(4),'1D wind internal energy') - call checkval(trvurho_1D(5,i), 4.879641694552266E-16,epsilon(0.),nfailed(5),'1D wind terminal density') - call update_test_scores(ntests,nfailed,npass) + ! check particle's mass + call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) + call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) + + ! check 1D wind profile + i = size(trvurho_1D(1,:)) + if (vb) print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) + call checkval(massoftype(igas),6.820748526700016E-10,epsilon(0.),nfailed(1),'setting particle mass') + call checkval(trvurho_1D(2,i), 1.546371444697654E+14,epsilon(0.),nfailed(2),'1D wind terminal radius') + call checkval(trvurho_1D(3,i), 4.298693548460183E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') + call checkval(trvurho_1D(4,i), 4.318674031561777E+10,epsilon(0.),nfailed(4),'1D wind internal energy') + call checkval(trvurho_1D(5,i), 4.879641694552266E-16,epsilon(0.),nfailed(5),'1D wind terminal density') + call update_test_scores(ntests,nfailed,npass) endif end subroutine init_testwind diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 889d945bd..a527f4b41 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -2029,7 +2029,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) ' # HeI', & ' # HeII', & ' # HeIII' /) - case(5) ! Sound speed + case(5) ! Sound speed filename = ' grid_cs.ev' headerline = '# cs profile ' end select diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index 5d3429272..918e8473b 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -216,7 +216,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) 'rad_min_cnm[cm]', 'rad_max_cnm[cm]', 'vel_cnm[c]', 'mass_cnm[Msun]', 'ene_cnm[erg]' endif if (rad_max > 0.) then - write(iunit,'(16(es18.10,1x))') & + write(iunit,'(16(es18.10,1x))') & time*todays, & rad_min*udist, rad_max*udist, shock_v, shock_m*umass/solarm, shock_e*unit_energ, & rad_min_tde*udist, rad_max_tde*udist, shock_v_tde, shock_m_tde*umass/solarm, shock_e_tde*unit_energ, & @@ -224,10 +224,10 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) endif close(iunit) - case default + case default write(*,'(a)') " Unknown analysis type. Do 'outflow' or 'shock'" stop - end select + end select end subroutine do_analysis @@ -329,7 +329,7 @@ subroutine record_background(ent,npart_old,npart_new,ent_bg) do i=1,npart_new ent_bg(npart_old+i) = ent(npart_old+i)*1.1 ! give some range for self evolution - !(is there a reasonable choice instead of arbitrary?) + !(is there a reasonable choice instead of arbitrary?) enddo end subroutine record_background From 113767f5527911837e86ca3e2f764f7d4e046e63 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 08:12:34 +1000 Subject: [PATCH 565/814] (github) further bug fix in macOS fortran installation workaround --- .github/workflows/krome.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/krome.yml b/.github/workflows/krome.yml index 393224ad0..08e106672 100644 --- a/.github/workflows/krome.yml +++ b/.github/workflows/krome.yml @@ -37,6 +37,8 @@ jobs: - name: install Fortran compiler on macOS if: matrix.os == 'macos-latest' run: brew install gfortran + env: + FC: gfortran #- uses: fortran-lang/setup-fortran@v1 # with: From cfdbddb5ee14d515384064c59da7db9950081fe1 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 08:15:57 +1000 Subject: [PATCH 566/814] (github) further bug fix in macOS fortran installation workaround --- .github/workflows/krome.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.github/workflows/krome.yml b/.github/workflows/krome.yml index 08e106672..5aa8200ce 100644 --- a/.github/workflows/krome.yml +++ b/.github/workflows/krome.yml @@ -12,6 +12,7 @@ env: PREFIX: /usr/local/ PHANTOM_DIR: ${{ github.workspace }} KROMEPATH: ${{ github.workspace }}/krome + FC: gfortran # default if not overwritten by matrix # A workflow run is made up of one or more jobs that can run sequentially or in parallel jobs: @@ -37,8 +38,6 @@ jobs: - name: install Fortran compiler on macOS if: matrix.os == 'macos-latest' run: brew install gfortran - env: - FC: gfortran #- uses: fortran-lang/setup-fortran@v1 # with: From 70ee53b0cfb4691468d4dc9ea0747885d330315c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 18 May 2024 08:45:45 +1000 Subject: [PATCH 567/814] (build) bug fix with line truncation in gfortran v14 --- src/setup/set_hierarchical.f90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/setup/set_hierarchical.f90 b/src/setup/set_hierarchical.f90 index bb2fc7733..c52aeabd6 100644 --- a/src/setup/set_hierarchical.f90 +++ b/src/setup/set_hierarchical.f90 @@ -575,13 +575,14 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & q_comp = mtot/m_comp if (q_comp>1) q_comp=q_comp**(-1) - ! Mardling&Aarseth (2001) criterion check - - period_ratio = sqrt((a_comp*a_comp*a_comp)/(m_comp+mtot)/(semimajoraxis*semimajoraxis*semimajoraxis)*(mtot)) ! Po/Pi + ! Mardling & Aarseth (2001) criterion check + period_ratio = sqrt((a_comp*a_comp*a_comp)/(m_comp+mtot)/& + (semimajoraxis*semimajoraxis*semimajoraxis)*(mtot)) ! Po/Pi criterion = 4.7*(1-e_comp)**(-1.8)*(1+e_comp)**(0.6)*(1+q_comp)**(0.1) if (criterion > period_ratio) then - print "(1x,a)",'WARNING: set_multiple: orbital parameters does not satisfy Mardling and Aarseth stability criterion.' + print "(1x,a)",'WARNING: set_multiple: orbital parameters do not satisfy '//& + 'Mardling & Aarseth stability criterion.' endif q2=m2/m1 From 153d82dcabde91aee129a876185e1dd26262f4a1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 21 May 2024 09:05:18 +0200 Subject: [PATCH 568/814] try to fix corrupted data by specifying length of the dptmass pointer --- src/main/ptmass.F90 | 12 +++++++----- src/main/substepping.F90 | 4 ++-- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index d9463ca98..19e5c1c87 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -753,7 +753,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & dptmass,time,facc,nbinmax,ibin_wakei,nfaili) !$ use omputils, only:ipart_omp_lock - use part, only: ihacc,itbirth + use part, only: ihacc,itbirth,ndptmass use kernel, only: radkern2 use io, only: iprint,iverbose,fatal use io_summary, only: iosum_ptmass,maxisink,print_acc @@ -763,7 +763,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(in) :: vxyz_ptmass(3,nptmass) logical, intent(out) :: accreted - real, intent(inout) :: dptmass(:,:) + real, intent(inout) :: dptmass(ndptmass,nptmass) integer(kind=1), intent(in) :: nbinmax integer(kind=1), intent(inout) :: ibin_wakei integer, optional, intent(out) :: nfaili @@ -939,11 +939,13 @@ end subroutine ptmass_accrete !+ !----------------------------------------------------------------------- subroutine update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) - real, intent(in) :: dptmass(:,:) + use part, only: ndptmass + integer, intent(in) :: nptmass + real, intent(in) :: dptmass(ndptmass,nptmass) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(inout) :: vxyz_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:) - integer, intent(in) :: nptmass + real :: newptmass(nptmass),newptmass1(nptmass) @@ -1026,7 +1028,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote real, intent(in) :: vxyzu(:,:),fxyzu(:,:),fext(:,:),massoftype(:) real(4), intent(in) :: divcurlv(:,:),poten(:) real, intent(inout) :: xyzmh_ptmass(:,:) - real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:),dptmass(ndptmass,nptmass+1) + real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:),dptmass(ndptmass,maxptmass) integer, intent(inout) :: linklist_ptmass(:) real, intent(in) :: time integer(kind=1) :: iphasei,ibin_wakei,ibin_itest diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 8b042cde0..ccc196ad8 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -430,7 +430,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & nmatrix,n_group,n_ingroup,n_sing) use io, only:iverbose,id,master,iprint,fatal use options, only:iexternalforce - use part, only:fxyz_ptmass_sinksink + use part, only:fxyz_ptmass_sinksink,ndptmass use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent use ptmass, only:use_fourthorder,use_regnbody,ck,dk @@ -442,7 +442,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, intent(inout) :: dptmass(:,:),fsink_old(:,:),gtgrad(:,:) + real, intent(inout) :: dptmass(ndptmass,nptmass),fsink_old(:,:),gtgrad(:,:) integer(kind=1), intent(in) :: nbinmax integer , intent(inout) :: linklist_ptmass(:) integer(kind=1), intent(inout) :: ibin_wake(:),nmatrix(nptmass,nptmass) From 5072390d38393977818fd5bc2f10990b3070515e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 21 May 2024 15:48:08 +0200 Subject: [PATCH 569/814] fix warning compilation --- src/setup/set_star_utils.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 73a5d7017..4be4dbe7e 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -397,7 +397,8 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ real :: rho_cgs,p_cgs integer :: i1 - i1 = 0 + i1 = 0 + eni = 0. if (present(npin)) i1 = npin ! starting position in particle array if (do_radiation) then From 3e029f141afbca42e16532606e135ef97835b7d2 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 21 May 2024 16:55:28 +0200 Subject: [PATCH 570/814] fix bad init of dsdt_ptmass that can introduce NaN in ptmass spins --- src/main/initial.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index f009025d2..5693ea330 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -546,6 +546,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) if (r_merge_uncond < 2.0*h_acc) then write(iprint,*) ' WARNING! Sink creation is on, but but merging is off! Suggest setting r_merge_uncond >= 2.0*h_acc' endif + dsdt_ptmass = 0. ! could introduce NaN in ptmass spins if not initialised (no get_accel done before creating sink) + fxyz_ptmass = 0. endif if (abs(time) <= tiny(0.)) then !initialize nucleation array at the start of the run only From 42503e5d0a8fcd85b8c97b39d0c9ca8030c9664a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 21 May 2024 17:07:00 +0200 Subject: [PATCH 571/814] specify the right size for dptmass --- src/main/ptmass.F90 | 12 +++++++----- src/main/substepping.F90 | 4 ++-- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index cd8a5f2b7..0a051f3e9 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -752,7 +752,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & dptmass,time,facc,nbinmax,ibin_wakei,nfaili) !$ use omputils, only:ipart_omp_lock - use part, only: ihacc + use part, only: ihacc,ndptmass use kernel, only: radkern2 use io, only: iprint,iverbose,fatal use io_summary, only: iosum_ptmass,maxisink,print_acc @@ -762,7 +762,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(in) :: vxyz_ptmass(3,nptmass) logical, intent(out) :: accreted - real, intent(inout) :: dptmass(:,:) + real, intent(inout) :: dptmass(ndptmass,nptmass) integer(kind=1), intent(in) :: nbinmax integer(kind=1), intent(inout) :: ibin_wakei integer, optional, intent(out) :: nfaili @@ -936,11 +936,13 @@ end subroutine ptmass_accrete !+ !----------------------------------------------------------------------- subroutine update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) - real, intent(in) :: dptmass(:,:) + use part ,only:ndptmass + integer, intent(in) :: nptmass + real, intent(in) :: dptmass(ndptmass,nptmass) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(inout) :: vxyz_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:) - integer, intent(in) :: nptmass + real :: newptmass(nptmass),newptmass1(nptmass) @@ -1023,7 +1025,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote real, intent(in) :: vxyzu(:,:),fxyzu(:,:),fext(:,:),massoftype(:) real(4), intent(in) :: divcurlv(:,:),poten(:) real, intent(inout) :: xyzmh_ptmass(:,:) - real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:),dptmass(ndptmass,nptmass+1) + real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:),dptmass(ndptmass,maxptmass) real, intent(in) :: time integer(kind=1) :: iphasei,ibin_wakei,ibin_itest integer :: nneigh diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 67bdda3df..77f278d30 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -430,7 +430,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & n_group,n_ingroup,n_sing) use io, only:iverbose,id,master,iprint,fatal use options, only:iexternalforce - use part, only:fxyz_ptmass_sinksink + use part, only:fxyz_ptmass_sinksink,ndptmass use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent use ptmass, only:use_fourthorder,use_regnbody,ck,dk @@ -442,7 +442,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, intent(inout) :: dptmass(:,:),fsink_old(:,:),gtgrad(:,:) + real, intent(inout) :: dptmass(ndptmass,nptmass),fsink_old(:,:),gtgrad(:,:) integer(kind=1), intent(in) :: nbinmax integer(kind=1), intent(inout) :: ibin_wake(:),nmatrix(nptmass,nptmass) logical :: extf_vdep_flag,done,last_step,accreted From 88dfb2a5edd609db9ce24fcd0ea935be97952e11 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 21 May 2024 17:32:26 +0200 Subject: [PATCH 572/814] set unit was called before prompting.... --- src/setup/setup_cluster.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index cd3e60944..36b0d137d 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -112,9 +112,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, dist_fac = 1.0 ! distance code unit: dist_fac * pc endif - !--Set units - call set_units(dist=dist_fac*pc,mass=mass_fac*solarm,G=1.) - if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state !--Read values from .setup @@ -131,6 +128,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call write_setupfile(fileset) endif + !--Set units + call set_units(dist=dist_fac*pc,mass=mass_fac*solarm,G=1.) + !--Define remaining variables using the inputs polyk = kboltz*Temperature/(mu*mass_proton_cgs)*(utime/udist)**2 rmax = Rcloud_pc*(pc/udist) From e16337b89684cfd2803089eddb74d092564b8f20 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 22 May 2024 09:28:19 +0200 Subject: [PATCH 573/814] change ambiguous name of variable in allocate_header --- src/main/utils_dumpfiles.f90 | 52 ++++++++++++++++++------------------ 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/src/main/utils_dumpfiles.f90 b/src/main/utils_dumpfiles.f90 index aef612992..12b15a51d 100644 --- a/src/main/utils_dumpfiles.f90 +++ b/src/main/utils_dumpfiles.f90 @@ -1358,56 +1358,56 @@ function allocate_header(nint,nint1,nint2,nint4,nint8,nreal,nreal4,nreal8,err) r integer, intent(in), optional :: nint,nint1,nint2,nint4,nint8,nreal,nreal4,nreal8 integer, intent(out), optional :: err type(dump_h) :: hdr - integer :: size(ndatatypes) + integer :: size_type(ndatatypes) integer :: ierrs(ndatatypes) integer :: ierr ! make sure header is deallocated first call free_header(hdr,ierr) - size(:) = maxphead - if (present(nint)) size(i_int) = nint - if (present(nint1)) size(i_int1) = nint1 - if (present(nint2)) size(i_int2) = nint2 - if (present(nint4)) size(i_int4) = nint4 - if (present(nint8)) size(i_int8) = nint8 - if (present(nreal)) size(i_real) = nreal - if (present(nreal4)) size(i_real4) = nreal4 - if (present(nreal8)) size(i_real8) = nreal8 + size_type(:) = maxphead + if (present(nint)) size_type(i_int) = nint + if (present(nint1)) size_type(i_int1) = nint1 + if (present(nint2)) size_type(i_int2) = nint2 + if (present(nint4)) size_type(i_int4) = nint4 + if (present(nint8)) size_type(i_int8) = nint8 + if (present(nreal)) size_type(i_real) = nreal + if (present(nreal4)) size_type(i_real4) = nreal4 + if (present(nreal8)) size_type(i_real8) = nreal8 if (present(err)) err = 0 ierrs(:) = 0 hdr%nums(:) = 0 - if (size(i_int) > 0) then - allocate(hdr%inttags(size(i_int)),hdr%intvals(size(i_int)),stat=ierrs(1)) + if (size_type(i_int) > 0) then + allocate(hdr%inttags(size_type(i_int)),hdr%intvals(size_type(i_int)),stat=ierrs(1)) if (ierrs(1)==0) hdr%inttags(:) = '' endif - if (size(i_int1) > 0) then - allocate(hdr%int1tags(size(i_int1)),hdr%int1vals(size(i_int1)),stat=ierrs(2)) + if (size_type(i_int1) > 0) then + allocate(hdr%int1tags(size_type(i_int1)),hdr%int1vals(size_type(i_int1)),stat=ierrs(2)) if (ierrs(2)==0) hdr%int1tags(:) = '' endif - if (size(i_int2) > 0) then - allocate(hdr%int2tags(size(i_int2)),hdr%int2vals(size(i_int2)),stat=ierrs(3)) + if (size_type(i_int2) > 0) then + allocate(hdr%int2tags(size_type(i_int2)),hdr%int2vals(size_type(i_int2)),stat=ierrs(3)) if (ierrs(3)==0) hdr%int2tags(:) = '' endif - if (size(i_int4) > 0) then - allocate(hdr%int4tags(size(i_int4)),hdr%int4vals(size(i_int4)),stat=ierrs(4)) + if (size_type(i_int4) > 0) then + allocate(hdr%int4tags(size_type(i_int4)),hdr%int4vals(size_type(i_int4)),stat=ierrs(4)) if (ierrs(4)==0) hdr%int4tags(:) = '' endif - if (size(i_int8) > 0) then - allocate(hdr%int8tags(size(i_int8)),hdr%int8vals(size(i_int8)),stat=ierrs(5)) + if (size_type(i_int8) > 0) then + allocate(hdr%int8tags(size_type(i_int8)),hdr%int8vals(size_type(i_int8)),stat=ierrs(5)) if (ierrs(5)==0) hdr%int8tags(:) = '' endif - if (size(i_real) > 0) then - allocate(hdr%realtags(size(i_real)),hdr%realvals(size(i_real)),stat=ierrs(6)) + if (size_type(i_real) > 0) then + allocate(hdr%realtags(size_type(i_real)),hdr%realvals(size_type(i_real)),stat=ierrs(6)) if (ierrs(6)==0) hdr%realtags(:) = '' endif - if (size(i_real4) > 0) then - allocate(hdr%real4tags(size(i_real4)),hdr%real4vals(size(i_real4)),stat=ierrs(7)) + if (size_type(i_real4) > 0) then + allocate(hdr%real4tags(size_type(i_real4)),hdr%real4vals(size_type(i_real4)),stat=ierrs(7)) if (ierrs(7)==0) hdr%real4tags(:) = '' endif - if (size(i_real8) > 0) then - allocate(hdr%real8tags(size(i_real8)),hdr%real8vals(size(i_real8)),stat=ierrs(8)) + if (size_type(i_real8) > 0) then + allocate(hdr%real8tags(size_type(i_real8)),hdr%real8vals(size_type(i_real8)),stat=ierrs(8)) if (ierrs(8)==0) hdr%real8tags(:) = '' endif From e9bef8bae8146f0baa15a2ea89709916428896b0 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 22 May 2024 15:15:39 +0200 Subject: [PATCH 574/814] fix bad initialisation of fxyz_sinksink in ptmass_create --- src/main/evolve.F90 | 2 +- src/main/initial.F90 | 3 ++- src/main/ptmass.F90 | 12 ++++++------ src/tests/test_ptmass.f90 | 4 ++-- 4 files changed, 11 insertions(+), 10 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index c96f339c1..92c22f776 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -276,7 +276,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! creation of new sink particles ! call ptmass_create(nptmass,npart,ipart_rhomax,xyzh,vxyzu,fxyzu,fext,divcurlv,& - poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) + poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,dptmass,time) endif ! ! Strang splitting: implicit update for half step diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 5693ea330..8741e49b7 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -127,7 +127,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,Bevol,dBevol,tau, tau_lucy, & npartoftype,maxtypes,ndusttypes,alphaind,ntot,ndim,update_npartoftypetot,& maxphase,iphase,isetphase,iamtype,igas,idust,imu,igamma,massoftype, & - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& + 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, & Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx, & @@ -548,6 +548,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif dsdt_ptmass = 0. ! could introduce NaN in ptmass spins if not initialised (no get_accel done before creating sink) fxyz_ptmass = 0. + fxyz_ptmass_sinksink = 0. endif if (abs(time) <= tiny(0.)) then !initialize nucleation array at the start of the run only diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 0a051f3e9..a1465c3fa 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -998,9 +998,9 @@ end subroutine update_ptmass !+ !------------------------------------------------------------------------- subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& - massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) + massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,dptmass,time) use part, only:ihacc,ihsoft,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & - ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP,igamma,ndptmass + ispinx,ispiny,ispinz,eos_vars,igasP,igamma,ndptmass use dim, only:maxp,maxneigh,maxvxyzu,maxptmass,ind_timesteps use kdtree, only:getneigh use kernel, only:kernel_softening,radkern @@ -1024,8 +1024,8 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote real, intent(inout) :: xyzh(:,:) real, intent(in) :: vxyzu(:,:),fxyzu(:,:),fext(:,:),massoftype(:) real(4), intent(in) :: divcurlv(:,:),poten(:) - real, intent(inout) :: xyzmh_ptmass(:,:) - real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:),dptmass(ndptmass,maxptmass) + real, intent(inout) :: xyzmh_ptmass(:,:),dptmass(ndptmass,maxptmass) + real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(4,maxptmass),fxyz_ptmass_sinksink(4,maxptmass) real, intent(in) :: time integer(kind=1) :: iphasei,ibin_wakei,ibin_itest integer :: nneigh @@ -1535,8 +1535,8 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote nacc = int(reduceall_mpi('+', nacc)) ! update ptmass position, spin, velocity, acceleration, and mass - fxyz_ptmass(:,nptmass) = 0.0 - fxyz_ptmass_sinksink(:,nptmass) = 0.0 + fxyz_ptmass(1:4,n) = 0.0 + fxyz_ptmass_sinksink(1:4,n) = 0.0 call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) if (id==id_rhomax) then diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 7272f1276..966a77727 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -766,7 +766,7 @@ subroutine test_createsink(ntests,npass) use part, only:init_part,npart,npartoftype,igas,xyzh,massoftype,hfact,rhoh,& iphase,isetphase,fext,divcurlv,vxyzu,fxyzu,poten, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,ndptmass, & - dptmass + dptmass,fxyz_ptmass_sinksink use ptmass, only:ptmass_accrete,update_ptmass,icreate_sinks,& ptmass_create,finish_ptmass,ipart_rhomax,h_acc,rho_crit,rho_crit_cgs use energies, only:compute_energies,angtot,etot,totmom @@ -886,7 +886,7 @@ subroutine test_createsink(ntests,npass) call reduceloc_mpi('max',ipart_rhomax_global,id_rhomax) endif call ptmass_create(nptmass,npart,itestp,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& - massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,0.) + massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,dptmass,0.) ! ! check that creation succeeded ! From 170823e488b8300e872a7a179709c6adf3079a63 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 22 May 2024 17:14:30 +0100 Subject: [PATCH 575/814] bugfixes --- src/main/cooling_radapprox.f90 | 61 +++++++++++++++++----------------- src/main/deriv.F90 | 10 +++--- src/main/eos_stamatellos.f90 | 17 ++++++++++ src/main/step_leapfrog.F90 | 20 +++++++---- src/main/substepping.F90 | 2 ++ 5 files changed, 69 insertions(+), 41 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index d646111df..e13f97ff2 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -20,7 +20,7 @@ module cooling_radapprox ! implicit none - real, public :: Lstar=0.0 ! in units of L_sun + real :: Lstar = 0d0 ! in units of L_sun 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 @@ -73,8 +73,7 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) integer,intent(in) :: npart real,intent(in) :: xyzh(:,:),dt,Tfloor real,intent(inout) :: energ(:),dudt_sph(:) - real :: dudti_cool,ui,rhoi - real :: coldensi,kappaBari,kappaParti,ri2 + real :: ui,rhoi,coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot real :: cs2,Om2,Hmod2 real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi @@ -84,20 +83,22 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) ! write (temp,'(E5.2)') dt write (filename, 11) dt 11 format("coolrate_", E7.2,".dat") - + + print *, "In cooling" ratefile = 34 open(unit=ratefile,file=filename,status="replace",form="formatted") !$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,dt,dudt_sph,utime,udist,umass,unit_ergg,gradP_cool) & + !$omp shared(opac_store,Tfloor,dt,dudt_sph,utime,udist,umass,unit_ergg,gradP_cool,Lstar) & !$omp private(i,poti,du_FLDi,ui,rhoi,ri2,coldensi,kappaBari,Ti) & !$omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot) & - !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb,Lstar,dudti_cool) + !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb) overpart: do i=1,npart 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 @@ -145,8 +146,6 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) 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 @@ -154,7 +153,6 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) ! 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 @@ -164,8 +162,8 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) opac_store(i) = opaci dudti_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/opaci/unit_ergg*utime! code units +! if (mod(i,100) == 0) print *, "dudt_sph", dudt_sph(i) if (doFLD) then - ! include term from FLD Teqi = (du_FLDi + dudt_sph(i)) *opaci*unit_ergg/utime ! physical units du_tot = dudt_sph(i) + dudti_rad + du_FLDi else @@ -181,14 +179,19 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) Teqi = Teqi**(1.0/4.0) endif teqi_store(i) = Teqi + + if (Teqi > 1e6) then + print *, "dudt_sph(i)=", dudt_sph(i), "duradi=", dudti_rad, "Ti=", Ti, & + "Tmini=", Tmini4**(1.0/4.0),du_tot,Hcomb + endif + 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 -> in form where it'll work as dudtcool + ! calculate thermalization timescale if ((du_tot) == 0.d0) then tthermi = 0d0 else @@ -196,40 +199,36 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) endif ttherm_store(i) = tthermi - + + ! evolve energy if (tthermi == 0d0) then - dudti_cool = 0.d0 ! condition if denominator above is zero + energ(i) = ui ! condition if denominator above is zero + elseif ( (dt/tthermi) < TINY(ui) ) then + energ(i) = ui else - dudti_cool = (ui*exp(-dt/tthermi) + ueqi*(1.d0-exp(-dt/tthermi)) -ui)/dt !code units + energ(i) = ui*exp(-dt/tthermi) + ueqi*(1.d0-exp(-dt/tthermi)) !code units endif - if (isnan(dudti_cool)) then + if (isnan(energ(i)) .or. energ(i) < epsilon(ui)) then ! print *, "kappaBari=",kappaBari, "kappaParti=",kappaParti - print *, "rhoi=",rhoi, "Ti=", Ti + 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=",dt,"tthermi=", tthermi,"umini=", umini print *, "dudti_rad=", dudti_rad ,"dudt_fld=",du_fldi,"ueqi=",ueqi,"ui=",ui - call warning("In Stamatellos cooling","dudticool=NaN. ui",val=ui) + call warning("In Stamatellos cooling","energ=NaN or 0. ui",val=ui) stop -! else if (dudti_cool < 0.d0 .and. abs(dudti_cool) > ui/dt) then - ! dudti_cool = (umini - ui)/dt endif - ! evolve energy - energ(i) = ui + dudti_cool * dt - - !set fxyzu(4,i) for timestepping - or don't... - if (dudti_cool == 0d0) then - dudt_sph(i) = tiny(dudti_cool) - else - dudt_sph(i) = dudti_cool + if (abs(dudt_sph(i)) >1.) then + !$omp critical + write (ratefile,'(I6,1X,E15.4)') i, (ui - energ(i))/dt + !$omp end critical endif - ! !$omp critical - ! write (ratefile,'(I6,1X,E15.4,E15.4)') i, dudt_sph(i), (ui - energ(i))/dt - ! !$omp end critical enddo overpart !$omp end parallel do close(ratefile) +! print *, "min/max dudt_sph():", minval(dudt_sph), maxval(dudt_sph) end subroutine radcool_update_energ diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index a5e3654ee..2c72225da 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -146,6 +146,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& call do_timing('dens',tlast,tcpulast) endif + print *, "calling eos from deriv" if (gr) then call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) else @@ -165,7 +166,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& ! ! update energy if using radiative cooling approx (icooling=9) ! - if (icooling == 9 .and. dt > 0.0) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) +! if (icooling == 9 .and. dt > 0.0) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) ! @@ -191,8 +192,9 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& ! ! update energy if using radiative cooling approx (icooling=9) and set fxyzu(4,:) to zero -! -! if (icooling == 9 .and. dt > 0.0) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) + ! + print *, "min,max energy", minval(vxyzu(4,1:npart)), maxval(vxyzu(4,1:npart)) + if (icooling == 9 .and. dt > 0.0 .and. icall==1) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) ! @@ -211,7 +213,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& !$omp end parallel do endif - if (icooling == 9) then + if (icooling == 9 .and. icall==1) then !$omp parallel do shared(fxyzu,npart) private(i) do i=1,npart fxyzu(4,i) = 0. diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index d97e0227a..9611f9685 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -100,6 +100,7 @@ end subroutine read_optab ! Main subroutine for interpolating tables to get EOS values ! subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) + use io, only:fatal real, intent(in) :: ui,rhoi real, intent(out) :: kappaBar,kappaPart,Ti,gmwi @@ -115,6 +116,13 @@ subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) umin = OPTABLE(1,1,3) ! interpolate through OPTABLE to find corresponding kappaBar, kappaPart and T + ! check values are in range of tables + if (rhoi > OPTABLE(nx,1,1) .or. rhoi < OPTABLE(1,1,1)) then + call fatal('getopac_opdep','rhoi out of range',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) + endif + if (rhoi < rhomin) then rhoi_ = rhomin else @@ -204,6 +212,7 @@ subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) end subroutine getopac_opdep subroutine getintenerg_opdep(Teqi, rhoi, ueqi) + use io, only:fatal real, intent(out) :: ueqi real, intent(in) :: Teqi,rhoi @@ -212,6 +221,13 @@ subroutine getintenerg_opdep(Teqi, rhoi, ueqi) integer i, j real rhoi_ + if (rhoi > OPTABLE(nx,1,1) .or. rhoi < OPTABLE(1,1,1)) then + call fatal('getintenerg_opdep','rhoi out of range',var='rhoi',val=rhoi) + elseif (Teqi > OPTABLE(1,ny,2) .or. Teqi < OPTABLE(1,1,2)) then + call fatal('getintenerg_opdep','Ti out of range',var='Ti',val=Teqi) + endif + + ! interpolate through OPTABLE to obtain equilibrium internal energy if (rhoi < 1.0e-24) then @@ -230,6 +246,7 @@ subroutine getintenerg_opdep(Teqi, rhoi, ueqi) j = j + 1 enddo + m = (OPTABLE(i-1,j-1,3) - OPTABLE(i-1,j,3))/(OPTABLE(i-1,j-1,2) - OPTABLE(i-1,j,2)) c = OPTABLE(i-1,j,3) - m*OPTABLE(i-1,j,2) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 6fafd8703..c0f5c83f4 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -198,6 +198,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif + !Alison + if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L202", fxyzu(4,i) !--floor the thermal energy if requested and required if (ufloor > 0. .and. icooling /= 9) then @@ -271,7 +273,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) & +!$omp shared(eos_vars,ufloor,icooling) & !$omp shared(twas,timei) & !$omp shared(rad,drad,radpred)& !$omp private(hi,rhoi,tdecay1,source,ddenom,hdti) & @@ -318,9 +320,11 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else vpred(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif + !Alison + if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L324", fxyzu(4,i) !--floor the thermal energy if requested and required - if (ufloor > 0.) then + if (ufloor > 0. .and. icooling /= 9) then if (vpred(4,i) < ufloor) then vpred(4,i) = ufloor nvfloorps = nvfloorps + 1 @@ -476,10 +480,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) pxyzu(:,i) = pxyzu(:,i) + dti*fxyzu(:,i) else vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) - if (fxyzu(4,i) > TINY(fxyzu(4,i))) then - print *, "In step du/dt not zero" - endif endif + !Alison + if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L488", fxyzu(4,i) if (use_dustgrowth .and. itype==idust) dustprop(:,i) = dustprop(:,i) + dti*ddustprop(:,i) if (itype==igas) then @@ -502,6 +505,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif + !Alison + if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L509", fxyzu(4,i) !--floor the thermal energy if requested and required if (ufloor > 0. .and. icooling /= 9) then @@ -559,7 +564,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) 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) - + !Alison + if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L488", fxyzu(4,i) erri = (vxi - vpred(1,i))**2 + (vyi - vpred(2,i))**2 + (vzi - vpred(3,i))**2 errmax = max(errmax,erri) @@ -652,6 +658,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) endif + !Alison + if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L662", fxyzu(4,i) if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) - hdtsph*ddustprop(:,i) if (itype==igas) then if (mhd) Bevol(:,i) = Bevol(:,i) - hdtsph*dBevol(:,i) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 1df9d19a9..4df15c4d8 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -943,10 +943,12 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! ! temperature and abundances update (only done during the last force calculation of the substep) ! + 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) endif + endif enddo !$omp enddo From f905cbf7a02a613b9e74762c4d5bda311b9f67f2 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 24 May 2024 09:23:41 +1000 Subject: [PATCH 576/814] (github) workflow actions use fortran-lang/setup-fortran@v1 instead of manually installing ifort --- .github/workflows/build.yml | 63 ++---------------------------------- .github/workflows/krome.yml | 12 +------ .github/workflows/mcfost.yml | 20 +++--------- .github/workflows/test.yml | 33 ++----------------- 4 files changed, 10 insertions(+), 118 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 54435883e..06cf95e96 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -11,8 +11,6 @@ on: paths-ignore: - 'docs/**' - 'README.md' -# schedule: -# - cron: "0 0 * * *" env: OMP_STACKSIZE: 512M @@ -22,13 +20,10 @@ env: WEB_SERVER: data.phantom.cloud.edu.au WEB_HTML_DIR: /var/www/html BUILD_LOG_DIR: /ci/build/logs - RSYNC_RSH: ssh -o "StrictHostKeyChecking=no" -o "UserKnownHostsFile=/dev/null" NPARALLEL: 32 jobs: matrix_prep: - # Skip scheduled runs on forks - if: ${{ github.event_name != 'schedule' || github.repository == 'danieljprice/phantom' }} runs-on: ubuntu-latest outputs: batch: ${{ steps.set-sequence.outputs.batch }} @@ -70,40 +65,11 @@ jobs: - name: Update package list run: sudo apt-get update - - name: Setup Intel repo + - name: Setup Intel compiler if: matrix.system == 'ifort' - id: intel-repo - run: | - wget https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - rm GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - sudo echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list - sudo apt-get update - INTELVERSION=$(apt-cache show intel-oneapi-compiler-fortran | grep Version | head -1) - echo "::set-output name=intelversion::$INTELVERSION" - - - name: Cache intel installation - if: matrix.system == 'ifort' - id: cache-intel - uses: actions/cache@v4 + uses: fortran-lang/setup-fortran@v1 with: - path: | - /opt/intel - key: ${{ steps.intel-repo.outputs.intelversion }} - - - name: Install Intel compilers - if: ${{ steps.cache-intel.outputs.cache-hit != 'true' && matrix.system == 'ifort' }} - run: | - sudo apt-get install -y intel-oneapi-common-vars - sudo apt-get install -y intel-oneapi-compiler-fortran - sudo apt-get install -y intel-oneapi-mpi - sudo apt-get install -y intel-oneapi-mpi-devel - - - name: Setup Intel oneAPI environment - if: matrix.system == 'ifort' - run: | - source /opt/intel/oneapi/setvars.sh - printenv >> $GITHUB_ENV + compiler: intel-classic - name: Install numpy and matplotlib for analysis unit tests run: | @@ -123,12 +89,6 @@ jobs: if: github.event_name == 'schedule' run: mkdir logs -# - name: "Grab previous build logs from web server" -# if: github.event_name == 'schedule' -# env: -# WGET: wget --recursive --no-parent --reject "index.html*" --cut-dirs=2 --no-host-directories -# run: ${WGET} -A '*${{ matrix.system[1] }}.txt' http://${WEB_SERVER}${BUILD_LOG_DIR}/ || true - - name: "Run buildbot.sh" run: ./buildbot.sh --maxdim 17000000 --url http://${WEB_SERVER}/${BUILD_LOG_DIR} --parallel ${{ matrix.batch }} ${{ env.NPARALLEL }} working-directory: scripts @@ -136,23 +96,6 @@ jobs: SYSTEM: ${{ matrix.system }} RETURN_ERR: yes -# - name: "Install SSH Key" -# if: github.event_name == 'schedule' -# uses: webfactory/ssh-agent@v0.5.3 -# with: -# ssh-private-key: ${{ secrets.RUNNER_PRIVATE_KEY }} - -# - name: "Copy new build logs to web server" -# if: ${{ (success() || failure()) && github.event_name == 'schedule' }} -# run: rsync -vau logs/*.txt ${WEB_USER}@${WEB_SERVER}:${WEB_HTML_DIR}/${BUILD_LOG_DIR} - -# - name: "Copy HTML files to web server" -# if: ${{ (success() || failure()) && github.event_name == 'schedule' }} -# run: | -# export WEB_BUILD_DIR=${WEB_HTML_DIR}/nightly/build/$(date "+%Y%m%d") -# ssh -o "StrictHostKeyChecking=no" -o "UserKnownHostsFile=/dev/null" ${WEB_USER}@${WEB_SERVER} -- mkdir -p ${WEB_BUILD_DIR} -# rsync -vau logs/*.html ${WEB_USER}@${WEB_SERVER}:${WEB_BUILD_DIR}/ - - name: logs/build-failures-${{ matrix.system }}.txt if: always() run: cat logs/build-failures-${{ matrix.system }}.txt || true diff --git a/.github/workflows/krome.yml b/.github/workflows/krome.yml index 5aa8200ce..9aa573f2f 100644 --- a/.github/workflows/krome.yml +++ b/.github/workflows/krome.yml @@ -28,21 +28,11 @@ jobs: toolchain: {compiler: intel-classic} steps: - # Install the Fortran compiler (workaround for broken setup-fortran action on macOS) - - name: install Fortran compiler - if: matrix.os == 'ubuntu-latest' + - name: "Install gfortran compiler" uses: fortran-lang/setup-fortran@v1 with: compiler: ${{ matrix.toolchain.compiler }} - - name: install Fortran compiler on macOS - if: matrix.os == 'macos-latest' - run: brew install gfortran - - #- uses: fortran-lang/setup-fortran@v1 - # with: - # compiler: ${{ matrix.toolchain.compiler }} - - name: "Clone phantom" uses: actions/checkout@v4 diff --git a/.github/workflows/mcfost.yml b/.github/workflows/mcfost.yml index 74eba9c75..1aac9e0ef 100644 --- a/.github/workflows/mcfost.yml +++ b/.github/workflows/mcfost.yml @@ -23,22 +23,10 @@ jobs: # Steps represent a sequence of tasks that will be executed as part of the job steps: - - name: install gfortran - run: brew install gfortran - - - name: soft link gfortran and check version - run: | - brew link gfortran - - #ls $PREFIX/bin/gfortran-* - #ln -s `ls "$PREFIX/bin/gfortran-*" | tail -1` $PREFIX/bin/gfortran - #gfortran -v - - - name: Check gfortran version - run: gfortran --version - #- uses: fortran-lang/setup-fortran@v1 - # with: - # compiler: gcc + - name: install gfortran compiler + uses: fortran-lang/setup-fortran@v1 + with: + compiler: gcc - name: Check gfortran version run: gfortran --version diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 1c2349f1a..3c7a977e0 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -53,38 +53,9 @@ jobs: - name: Setup Intel repo if: matrix.system == 'ifort' - id: intel-repo - run: | - wget https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - rm GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - sudo echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list - sudo apt-get update - INTELVERSION=$(apt-cache show intel-oneapi-compiler-fortran | grep Version | head -1) - echo "::set-output name=intelversion::$INTELVERSION" - - - name: Cache intel installation - if: matrix.system == 'ifort' - id: cache-intel - uses: actions/cache@v4 + uses: fortran-lang/setup-fortran@v1 with: - path: | - /opt/intel - key: ${{ steps.intel-repo.outputs.intelversion }} - - - name: Install Intel compilers - if: ${{ steps.cache-intel.outputs.cache-hit != 'true' && matrix.system == 'ifort' }} - run: | - sudo apt-get install -y intel-oneapi-common-vars - sudo apt-get install -y intel-oneapi-compiler-fortran - sudo apt-get install -y intel-oneapi-mpi - sudo apt-get install -y intel-oneapi-mpi-devel - - - name: Setup Intel oneAPI environment - if: matrix.system == 'ifort' - run: | - source /opt/intel/oneapi/setvars.sh - printenv >> $GITHUB_ENV + compiler: intel-classic - name: "Clone phantom" uses: actions/checkout@v4 From 9586c4fc0029654950c6d25b897681c1b8c947c1 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 24 May 2024 15:38:12 +1000 Subject: [PATCH 577/814] (#457) attempt to properly track accreted energy in the .ev file --- src/main/energies.F90 | 431 ++++++++++++++++++-------------- src/utils/analysis_energies.f90 | 63 +++++ src/utils/phantomanalysis.f90 | 3 + 3 files changed, 306 insertions(+), 191 deletions(-) create mode 100644 src/utils/analysis_energies.f90 diff --git a/src/main/energies.F90 b/src/main/energies.F90 index e0255209f..721b6a1be 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -26,11 +26,12 @@ module energies implicit none logical, public :: gas_only,track_mass,track_lum - real, public :: ekin,etherm,emag,epot,etot,totmom,angtot,mtot,xyzcom(3) + real, public :: ekin,etherm,emag,epot,etot,eacc,totmom,angtot,mtot,xyzcom(3) + real, public :: ekinacc,ethermacc,emagacc,epotacc,eradacc,etotall real, public :: hdivBonB_ave,hdivBonB_max real, public :: vrms,rmsmach,accretedmass,mdust(maxdusttypes),mgas - real, public :: xmom,ymom,zmom - real, public :: totlum + real, public :: xcom,ycom,zcom,xmom,ymom,zmom,angx,angy,angz + real, public :: totlum,angxall,angyall,angzall,angall real, public :: hx(4),hp(4),ddq_xy(3,3) integer, public :: iquantities integer(kind=8), public :: ndead,npartall,np_cs_eq_0,np_e_eq_0 @@ -98,10 +99,10 @@ subroutine compute_energies(t) real, intent(in) :: t integer :: iregime,idusttype,ierr real :: ev_data_thread(4,0:inumev) - real :: xi,yi,zi,hi,vxi,vyi,vzi,v2i,Bxi,Byi,Bzi,Bi,B2i,rhoi,angx,angy,angz - real :: xmomacc,ymomacc,zmomacc,angaccx,angaccy,angaccz,xcom,ycom,zcom,dm + real :: xi,yi,zi,hi,vxi,vyi,vzi,v2i,Bxi,Byi,Bzi,Bi,B2i,rhoi + real :: xmomacc,ymomacc,zmomacc,angaccx,angaccy,angaccz,dm real :: epoti,pmassi,dnptot,dnpgas,tsi - real :: xmomall,ymomall,zmomall,angxall,angyall,angzall,rho1i,vsigi + real :: xmomall,ymomall,zmomall,rho1i,vsigi real :: ponrhoi,spsoundi,dumx,dumy,dumz,gammai real :: divBi,hdivBonBi,alphai,valfven2i,betai real :: n_total,n_total1,n_ion,shearparam_art,shearparam_phys,ratio_phys_to_av @@ -109,13 +110,13 @@ subroutine compute_energies(t) real :: etaohm,etahall,etaambi,vhall,vion real :: curlBi(3),vhalli(3),vioni(3),data_out(n_data_out) real :: erotxi,erotyi,erotzi,fdum(3),x0(3),v0(3),a0(3),xyz_x_all(3),xyz_n_all(3) - real :: ethermi + real :: ekini,ethermi,epottmpi,eradi,emagi real :: pdotv,bigvi(1:3),alpha_gr,beta_gr_UP(1:3),lorentzi,pxi,pyi,pzi real :: gammaijdown(1:3,1:3),angi(1:3),fourvel_space(3) integer :: i,j,itype,iu integer :: ierrlist(n_warn) integer(kind=8) :: np,npgas,nptot,np_rho(maxtypes),np_rho_thread(maxtypes) - !real, allocatable :: axyz(:,:) + logical :: was_not_accreted ! initialise values itype = igas @@ -149,6 +150,11 @@ subroutine compute_energies(t) angaccx = 0. angaccy = 0. angaccz = 0. + ekinacc = 0. + ethermacc = 0. + emagacc = 0. + epotacc = 0. + eradacc = 0. mgas = 0. mdust = 0. mgas = 0. @@ -178,20 +184,22 @@ subroutine compute_energies(t) !$omp shared(iev_dtg,iev_ts,iev_macc,iev_totlum,iev_erot,iev_viscrat) & !$omp shared(eos_vars,grainsize,graindens,ndustsmall,metrics) & !$omp private(i,j,xi,yi,zi,hi,rhoi,vxi,vyi,vzi,Bxi,Byi,Bzi,Bi,B2i,epoti,vsigi,v2i) & -!$omp private(ponrhoi,spsoundi,gammai,ethermi,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & +!$omp private(ponrhoi,spsoundi,gammai,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & !$omp private(rho1i,shearparam_art,shearparam_phys,ratio_phys_to_av,betai) & !$omp private(gasfrac,rhogasi,dustfracisum,dustfraci,dust_to_gas,n_total,n_total1,n_ion) & !$omp private(etaohm,etahall,etaambi,vhalli,vhall,vioni,vion,data_out) & +!$omp private(ekini,ethermi,emagi,eradi,epottmpi) & !$omp private(erotxi,erotyi,erotzi,fdum) & !$omp private(ev_data_thread,np_rho_thread) & !$omp firstprivate(alphai,itype,pmassi) & !$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) & +!$omp private(tsi,iregime,idusttype,was_not_accreted) & !$omp shared(luminosity,track_lum) & !$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) & +!$omp reduction(+:ekinacc,ethermacc,emagacc,epotacc,eradacc) & !$omp reduction(+:ekin,etherm,emag,epot,erad,vrms,rmsmach,ierrlist) call initialise_ev_data(ev_data_thread) np_rho_thread = 0 @@ -201,7 +209,8 @@ subroutine compute_energies(t) yi = xyzh(2,i) zi = xyzh(3,i) hi = xyzh(4,i) - if (.not.isdead_or_accreted(hi)) then + was_not_accreted = .not.was_accreted(iexternalforce,hi) + if (.not.isdead_or_accreted(hi) .or. .not. was_not_accreted) then if (maxphase==maxp) then itype = iamtype(iphase(i)) if (itype <= 0) call fatal('energies','particle type <= 0') @@ -209,32 +218,33 @@ subroutine compute_energies(t) endif rhoi = rhoh(hi,pmassi) - call ev_data_update(ev_data_thread,iev_rho,rhoi) - if (.not.gas_only) then - select case(itype) - case(igas) - call ev_data_update(ev_data_thread,iev_rhop(1), rhoi) - np_rho_thread(igas) = np_rho_thread(igas) + 1 - case(idust) - call ev_data_update(ev_data_thread,iev_rhop(2),rhoi) - np_rho_thread(idust) = np_rho_thread(idust) + 1 - case(iboundary) - call ev_data_update(ev_data_thread,iev_rhop(3), rhoi) - np_rho_thread(iboundary) = np_rho_thread(iboundary) + 1 - case(istar) - call ev_data_update(ev_data_thread,iev_rhop(4),rhoi) - np_rho_thread(istar) = np_rho_thread(istar) + 1 - case(idarkmatter) - call ev_data_update(ev_data_thread,iev_rhop(5), rhoi) - np_rho_thread(idarkmatter) = np_rho_thread(idarkmatter) + 1 - case(ibulge) - call ev_data_update(ev_data_thread,iev_rhop(6), rhoi) - np_rho_thread(ibulge) = np_rho_thread(ibulge) + 1 - end select + if (was_not_accreted) then + call ev_data_update(ev_data_thread,iev_rho,rhoi) + if (.not.gas_only) then + select case(itype) + case(igas) + call ev_data_update(ev_data_thread,iev_rhop(1), rhoi) + np_rho_thread(igas) = np_rho_thread(igas) + 1 + case(idust) + call ev_data_update(ev_data_thread,iev_rhop(2),rhoi) + np_rho_thread(idust) = np_rho_thread(idust) + 1 + case(iboundary) + call ev_data_update(ev_data_thread,iev_rhop(3), rhoi) + np_rho_thread(iboundary) = np_rho_thread(iboundary) + 1 + case(istar) + call ev_data_update(ev_data_thread,iev_rhop(4),rhoi) + np_rho_thread(istar) = np_rho_thread(istar) + 1 + case(idarkmatter) + call ev_data_update(ev_data_thread,iev_rhop(5), rhoi) + np_rho_thread(idarkmatter) = np_rho_thread(idarkmatter) + 1 + case(ibulge) + call ev_data_update(ev_data_thread,iev_rhop(6), rhoi) + np_rho_thread(ibulge) = np_rho_thread(ibulge) + 1 + end select + endif + np = np + 1 endif - np = np + 1 - vxi = vxyzu(1,i) vyi = vxyzu(2,i) vzi = vxyzu(3,i) @@ -244,11 +254,6 @@ subroutine compute_energies(t) pyi = pxyzu(2,i) pzi = pxyzu(3,i) - ! linear momentum - xmom = xmom + pmassi*pxi - ymom = ymom + pmassi*pyi - zmom = zmom + pmassi*pzi - call unpack_metric(metrics(:,:,:,i),betaUP=beta_gr_UP,alpha=alpha_gr,gammaijdown=gammaijdown) bigvi = (vxyzu(1:3,i)+beta_gr_UP)/alpha_gr v2i = dot_product_gr(bigvi,bigvi,gammaijdown) @@ -258,99 +263,142 @@ subroutine compute_energies(t) ! angular momentum fourvel_space = (lorentzi/alpha_gr)*vxyzu(1:3,i) call cross_product3D(xyzh(1:3,i),fourvel_space,angi) ! position cross with four-velocity - angx = angx + pmassi*angi(1) - angy = angy + pmassi*angi(2) - angz = angz + pmassi*angi(3) ! kinetic energy - ekin = ekin + pmassi*(pdotv + alpha_gr/lorentzi - 1.) ! The 'kinetic term' in total specific energy, minus rest mass - mtot = mtot + pmassi + ekini = pmassi*(pdotv + alpha_gr/lorentzi - 1.) ! The 'kinetic term' in total specific energy, minus rest mass else + pxi = vxi + pyi = vyi + pzi = vzi + ! centre of mass xcom = xcom + pmassi*xi ycom = ycom + pmassi*yi zcom = zcom + pmassi*zi + + ! angular momentum + angi(1) = (yi*vzi - zi*vyi) + angi(2) = (zi*vxi - xi*vzi) + angi(3) = (xi*vyi - yi*vxi) + + ! kinetic energy and rms velocity + v2i = vxi*vxi + vyi*vyi + vzi*vzi + ekini = pmassi*v2i + endif + + if (was_not_accreted) then + ! total mass mtot = mtot + pmassi ! linear momentum - xmom = xmom + pmassi*vxi - ymom = ymom + pmassi*vyi - zmom = zmom + pmassi*vzi + xmom = xmom + pmassi*pxi + ymom = ymom + pmassi*pyi + zmom = zmom + pmassi*pzi ! angular momentum - angx = angx + pmassi*(yi*vzi - zi*vyi) - angy = angy + pmassi*(zi*vxi - xi*vzi) - angz = angz + pmassi*(xi*vyi - yi*vxi) + angx = angx + pmassi*angi(1) + angy = angy + pmassi*angi(2) + angz = angz + pmassi*angi(3) ! kinetic energy & rms velocity - v2i = vxi*vxi + vyi*vyi + vzi*vzi - ekin = ekin + pmassi*v2i - endif + ekin = ekin + ekini + vrms = vrms + v2i + else + call ev_data_update(ev_data_thread,iev_macc,pmassi) - vrms = vrms + v2i + ! linear momentum (accreted particles) + xmomacc = xmomacc + pmassi*pxi + ymomacc = ymomacc + pmassi*pyi + zmomacc = zmomacc + pmassi*pzi + + ! angular momentum (accreted particles) + angaccx = angaccx + pmassi*angi(1) + angaccy = angaccy + pmassi*angi(2) + angaccz = angaccz + pmassi*angi(3) + + ! kinetic energy (accreted particles + ekinacc = ekinacc + ekini + endif ! rotational energy around each axis through the Centre of mass ! note: for efficiency, centre of mass is from the previous time energies was called - if (calc_erot) then + if (calc_erot .and. was_not_accreted) then call get_erot(xi,yi,zi,vxi,vyi,vzi,xyzcom,pmassi,erotxi,erotyi,erotzi) call ev_data_update(ev_data_thread,iev_erot(1),erotxi) call ev_data_update(ev_data_thread,iev_erot(2),erotyi) call ev_data_update(ev_data_thread,iev_erot(3),erotzi) endif - if (iexternalforce > 0) then + ! potential energy + epoti = 0. + if (iexternalforce > 0 .and. .not.gr) then dumx = 0. dumy = 0. dumz = 0. -#ifdef GR - epoti = 0. -#else + epottmpi = 0. call externalforce(iexternalforce,xi,yi,zi,hi,t,dumx,dumy,dumz,epoti,ii=i) - call externalforce_vdependent(iexternalforce,xyzh(1:3,i),vxyzu(1:3,i),fdum,epoti) -#endif - epot = epot + pmassi*epoti + call externalforce_vdependent(iexternalforce,xyzh(1:3,i),vxyzu(1:3,i),fdum,epottmpi) + epoti = pmassi*epottmpi endif if (nptmass > 0) then dumx = 0. dumy = 0. dumz = 0. - call get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,dumx,dumy,dumz,epoti) - epot = epot + pmassi*epoti + epottmpi = 0. + call get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,dumx,dumy,dumz,epottmpi) + epoti = epoti + pmassi*epottmpi endif - if (gravity) epot = epot + poten(i) + if (gravity) epoti = epoti + poten(i) + if (was_not_accreted) then + epot = epot + epoti + else + epotacc = epotacc + epoti + endif ! ! total dust mass for each species ! - if (use_dust) then + if (use_dust .and. was_not_accreted) then if (iamdust(iphase(i))) then idusttype = ndustsmall + itype - idust + 1 mdust(idusttype) = mdust(idusttype) + pmassi endif endif - if (do_radiation) erad = erad + pmassi*rad(iradxi,i) + if (do_radiation) then + eradi = pmassi*rad(iradxi,i) + if (was_not_accreted) then + erad = erad + eradi + else + eradacc = eradacc + eradi + endif + endif + ! ! the following apply ONLY to gas particles ! isgas: if (itype==igas) then - npgas = npgas + 1 if (use_dustfrac) then dustfraci = dustfrac(:,i) dustfracisum = sum(dustfraci) gasfrac = 1. - dustfracisum dust_to_gas = dustfraci(:)/gasfrac - do j=1,ndustsmall - call ev_data_update(ev_data_thread,iev_dtg,dust_to_gas(j)) - enddo - mdust(1:ndustsmall) = mdust(1:ndustsmall) + pmassi*dustfraci(1:ndustsmall) + if (was_not_accreted) then + do j=1,ndustsmall + call ev_data_update(ev_data_thread,iev_dtg,dust_to_gas(j)) + enddo + mdust(1:ndustsmall) = mdust(1:ndustsmall) + pmassi*dustfraci(1:ndustsmall) + endif else dustfraci = 0. dustfracisum = 0. gasfrac = 1. endif - mgas = mgas + pmassi*gasfrac + if (was_not_accreted) then + npgas = npgas + 1 + mgas = mgas + pmassi*gasfrac + endif ! thermal energy ponrhoi = eos_vars(igasP,i)/rhoi @@ -360,60 +408,68 @@ subroutine compute_energies(t) ethermi = pmassi*vxyzu(4,i)*gasfrac if (gr) ethermi = (alpha_gr/lorentzi)*ethermi - etherm = etherm + ethermi - - if (vxyzu(iu,i) < tiny(vxyzu(iu,i))) np_e_eq_0 = np_e_eq_0 + 1 - if (spsoundi < tiny(spsoundi) .and. vxyzu(iu,i) > 0. ) np_cs_eq_0 = np_cs_eq_0 + 1 + if (was_not_accreted) then + if (vxyzu(iu,i) < tiny(vxyzu(iu,i))) np_e_eq_0 = np_e_eq_0 + 1 + if (spsoundi < tiny(spsoundi) .and. vxyzu(iu,i) > 0. ) np_cs_eq_0 = np_cs_eq_0 + 1 + endif else if ((ieos==2 .or. ieos == 5 .or. ieos == 17) .and. gammai > 1.001) then !--thermal energy using polytropic equation of state - etherm = etherm + pmassi*ponrhoi/(gammai-1.)*gasfrac + ethermi = pmassi*ponrhoi/(gammai-1.)*gasfrac elseif (ieos==9) then !--thermal energy using piecewise polytropic equation of state - etherm = etherm + pmassi*ponrhoi/(gamma_pwp(rhoi)-1.)*gasfrac + ethermi = pmassi*ponrhoi/(gamma_pwp(rhoi)-1.)*gasfrac endif - if (spsoundi < tiny(spsoundi)) np_cs_eq_0 = np_cs_eq_0 + 1 + if (spsoundi < tiny(spsoundi) .and. was_not_accreted) np_cs_eq_0 = np_cs_eq_0 + 1 endif vsigi = spsoundi - ! entropy - call ev_data_update(ev_data_thread,iev_entrop,pmassi*ponrhoi*rhoi**(1.-gammai)) - - ! gas temperature - if (eos_is_non_ideal(ieos) .or. eos_outputs_gasP(ieos)) then - call ev_data_update(ev_data_thread,iev_temp,eos_vars(itemp,i)) + if (was_not_accreted) then + etherm = etherm + ethermi + else + ethermacc = ethermacc + ethermi endif - ! min and mean stopping time - if (use_dustfrac) then - rhogasi = rhoi*gasfrac - do j=1,ndustsmall - call get_ts(idrag,j,grainsize(j),graindens(j),rhogasi,rhoi*dustfracisum,spsoundi,0.,tsi,iregime) - call ev_data_update(ev_data_thread,iev_ts,tsi) - enddo - endif + if (was_not_accreted) then + ! entropy + call ev_data_update(ev_data_thread,iev_entrop,pmassi*ponrhoi*rhoi**(1.-gammai)) - if (track_lum .and. lightcurve) call ev_data_update(ev_data_thread,iev_totlum,real(luminosity(i))) + ! gas temperature + if (eos_is_non_ideal(ieos) .or. eos_outputs_gasP(ieos)) then + call ev_data_update(ev_data_thread,iev_temp,eos_vars(itemp,i)) + endif - ! rms mach number - if (spsoundi > 0.) rmsmach = rmsmach + v2i/spsoundi**2 + ! min and mean stopping time + if (use_dustfrac) then + rhogasi = rhoi*gasfrac + do j=1,ndustsmall + call get_ts(idrag,j,grainsize(j),graindens(j),rhogasi,rhoi*dustfracisum,spsoundi,0.,tsi,iregime) + call ev_data_update(ev_data_thread,iev_ts,tsi) + enddo + endif - ! max of dissipation parameters - if (maxalpha==maxp) then - alphai = alphaind(1,i) - call ev_data_update(ev_data_thread,iev_alpha,alphai) - endif + if (track_lum .and. lightcurve) call ev_data_update(ev_data_thread,iev_totlum,real(luminosity(i))) - ! physical viscosity - if (irealvisc /= 0) then - shearparam_art = 0.1*alphai*hi*vsigi - shearparam_phys = shearfunc(xi,yi,zi,spsoundi) - if (shearparam_art > 0.) then - ratio_phys_to_av = shearparam_phys/shearparam_art - else - ratio_phys_to_av = 0. + ! rms mach number + if (spsoundi > 0.) rmsmach = rmsmach + v2i/spsoundi**2 + + ! max of dissipation parameters + if (maxalpha==maxp) then + alphai = alphaind(1,i) + call ev_data_update(ev_data_thread,iev_alpha,alphai) + endif + + ! physical viscosity + if (irealvisc /= 0) then + shearparam_art = 0.1*alphai*hi*vsigi + shearparam_phys = shearfunc(xi,yi,zi,spsoundi) + if (shearparam_art > 0.) then + ratio_phys_to_av = shearparam_phys/shearparam_art + else + ratio_phys_to_av = 0. + endif + call ev_data_update(ev_data_thread,iev_viscrat,ratio_phys_to_av) endif - call ev_data_update(ev_data_thread,iev_viscrat,ratio_phys_to_av) endif ! mhd parameters @@ -426,88 +482,70 @@ subroutine compute_energies(t) rho1i = 1./rhoi valfven2i = B2i*rho1i vsigi = sqrt(valfven2i + spsoundi*spsoundi) - emag = emag + pmassi*B2i*rho1i - - divBi = abs(divcurlB(1,i)) - if (B2i > 0.) then - hdivBonBi = hi*divBi/Bi - betai = 2.0*ponrhoi*rhoi/B2i ! plasma beta - else - hdivBonBi = 0. - betai = 0. - endif - call ev_data_update(ev_data_thread,iev_B, Bi ) - call ev_data_update(ev_data_thread,iev_divB, divBi ) - call ev_data_update(ev_data_thread,iev_hdivB,hdivBonBi) - call ev_data_update(ev_data_thread,iev_beta, betai ) + emagi = pmassi*B2i*rho1i + + if (was_not_accreted) then + emag = emag + emagi + divBi = abs(divcurlB(1,i)) + if (B2i > 0.) then + hdivBonBi = hi*divBi/Bi + betai = 2.0*ponrhoi*rhoi/B2i ! plasma beta + else + hdivBonBi = 0. + betai = 0. + endif + call ev_data_update(ev_data_thread,iev_B, Bi ) + call ev_data_update(ev_data_thread,iev_divB, divBi ) + call ev_data_update(ev_data_thread,iev_hdivB,hdivBonBi) + call ev_data_update(ev_data_thread,iev_beta, betai ) - if ( mhd_nonideal ) then - call nicil_update_nimhd(0,etaohm,etahall,etaambi,Bi,rhoi, & + if ( mhd_nonideal ) then + call nicil_update_nimhd(0,etaohm,etahall,etaambi,Bi,rhoi, & eos_vars(itemp,i),nden_nimhd(:,i),ierrlist,data_out) - curlBi = divcurlB(2:4,i) - if (use_ohm) then - call ev_data_update(ev_data_thread,iev_etao, etaohm ) - endif - if (use_hall) then - call nicil_get_halldrift(etahall,Bxi,Byi,Bzi,curlBi,vhalli) - vhall = sqrt( dot_product(vhalli,vhalli) ) - call ev_data_update(ev_data_thread,iev_etah(1),etahall ) - call ev_data_update(ev_data_thread,iev_etah(2),abs(etahall)) - call ev_data_update(ev_data_thread,iev_vhall ,vhall ) - endif - if (use_ambi) then - call nicil_get_ambidrift(etaambi,Bxi,Byi,Bzi,curlBi,vioni) - vion = sqrt( dot_product(vioni, vioni ) ) - call ev_data_update(ev_data_thread,iev_etaa, etaambi ) - call ev_data_update(ev_data_thread,iev_vel, sqrt(v2i) ) - call ev_data_update(ev_data_thread,iev_vion, vion ) - endif - if (.not.eta_constant) then - n_ion = 0 - do j = 9,21 - n_ion = n_ion + data_out(j) - enddo - n_total = data_out(5) - if (n_total > 0.) then - n_total1 = 1.0/n_total - else - n_total1 = 0.0 ! only possible if eta_constant = .true. + curlBi = divcurlB(2:4,i) + if (use_ohm) then + call ev_data_update(ev_data_thread,iev_etao, etaohm ) + endif + if (use_hall) then + call nicil_get_halldrift(etahall,Bxi,Byi,Bzi,curlBi,vhalli) + vhall = sqrt( dot_product(vhalli,vhalli) ) + call ev_data_update(ev_data_thread,iev_etah(1),etahall ) + call ev_data_update(ev_data_thread,iev_etah(2),abs(etahall)) + call ev_data_update(ev_data_thread,iev_vhall ,vhall ) + endif + if (use_ambi) then + call nicil_get_ambidrift(etaambi,Bxi,Byi,Bzi,curlBi,vioni) + vion = sqrt( dot_product(vioni, vioni ) ) + call ev_data_update(ev_data_thread,iev_etaa, etaambi ) + call ev_data_update(ev_data_thread,iev_vel, sqrt(v2i) ) + call ev_data_update(ev_data_thread,iev_vion, vion ) + endif + if (.not.eta_constant) then + n_ion = 0 + do j = 9,21 + n_ion = n_ion + data_out(j) + enddo + n_total = data_out(5) + if (n_total > 0.) then + n_total1 = 1.0/n_total + else + n_total1 = 0.0 ! only possible if eta_constant = .true. + endif + eta_nimhd(iion,i) = n_ion*n_total1 ! Save ionisation fraction for the dump file + call ev_data_update(ev_data_thread,iev_n(1),n_ion*n_total1) + call ev_data_update(ev_data_thread,iev_n(2),data_out( 8)*n_total1) + call ev_data_update(ev_data_thread,iev_n(3),data_out( 8)) + call ev_data_update(ev_data_thread,iev_n(4),n_total-n_ion) + call ev_data_update(ev_data_thread,iev_n(5),data_out(24)) + call ev_data_update(ev_data_thread,iev_n(6),data_out(23)) + call ev_data_update(ev_data_thread,iev_n(7),data_out(22)) endif - eta_nimhd(iion,i) = n_ion*n_total1 ! Save ionisation fraction for the dump file - call ev_data_update(ev_data_thread,iev_n(1),n_ion*n_total1) - call ev_data_update(ev_data_thread,iev_n(2),data_out( 8)*n_total1) - call ev_data_update(ev_data_thread,iev_n(3),data_out( 8)) - call ev_data_update(ev_data_thread,iev_n(4),n_total-n_ion) - call ev_data_update(ev_data_thread,iev_n(5),data_out(24)) - call ev_data_update(ev_data_thread,iev_n(6),data_out(23)) - call ev_data_update(ev_data_thread,iev_n(7),data_out(22)) endif + else + emagacc = emagacc + emagi endif endif endif isgas - - elseif (was_accreted(iexternalforce,hi)) then -! -!--count accretion onto fixed potentials (external forces) separately -! - vxi = vxyzu(1,i) - vyi = vxyzu(2,i) - vzi = vxyzu(3,i) - if (maxphase==maxp) then - pmassi = massoftype(iamtype(iphase(i))) - else - pmassi = massoftype(igas) - endif - xmomacc = xmomacc + pmassi*vxi - ymomacc = ymomacc + pmassi*vyi - zmomacc = zmomacc + pmassi*vzi - - angaccx = angaccx + pmassi*(yi*vzi - zi*vyi) - angaccy = angaccy + pmassi*(zi*vxi - xi*vzi) - angaccz = angaccz + pmassi*(xi*vyi - yi*vxi) - - call ev_data_update(ev_data_thread,iev_macc,pmassi) - endif enddo !$omp enddo @@ -609,9 +647,8 @@ subroutine compute_energies(t) epot = epot + epot_sinksink endif - - etot = ekin + etherm + emag + epot + erad + etotall = etot xcom = reduceall_mpi('+',xcom) ycom = reduceall_mpi('+',ycom) @@ -702,12 +739,24 @@ subroutine compute_energies(t) angxall = angx + angaccx angyall = angy + angaccy angzall = angz + angaccz - ev_data(iev_sum,iev_angall) = sqrt(angxall*angxall + angyall*angyall + angzall*angzall) + angall = sqrt(angxall*angxall + angyall*angyall + angzall*angzall) + ev_data(iev_sum,iev_angall) = angall + + ekinacc = reduceall_mpi('+',ekinacc) + epotacc = reduceall_mpi('+',epotacc) + ethermacc = reduceall_mpi('+',ethermacc) + emagacc = reduceall_mpi('+',emagacc) + eradacc = reduceall_mpi('+',eradacc) + eacc = ekinacc + ethermacc + emagacc + epotacc + eradacc + etotall = etotall + eacc endif if (track_mass) then accretedmass = ev_data(iev_sum,iev_macc) - if (accradius1 > 0.) ev_data(iev_sum,iev_eacc) = accretedmass/accradius1 ! total accretion energy + if (accradius1 > 0.) then + !eacc = accretedmass/accradius1 + ev_data(iev_sum,iev_eacc) = eacc ! total accretion energy + endif endif if (track_lum) totlum = ev_data(iev_sum,iev_totlum) diff --git a/src/utils/analysis_energies.f90 b/src/utils/analysis_energies.f90 new file mode 100644 index 000000000..c242b2a31 --- /dev/null +++ b/src/utils/analysis_energies.f90 @@ -0,0 +1,63 @@ +!--------------------------------------------------------------------------! +! 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 analysis +! +! Analysis routine computing the energy accounting for accreted +! particles +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: None +! + implicit none + character(len=20), parameter, public :: analysistype = 'energies' + public :: do_analysis + + logical, private :: first = .true. + private + +contains + +subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) + use energies, only:compute_energies,track_mass,ekin,emag,etherm,epot,etot,& + eacc,etotall,totmom,angtot,angall + use metric_tools, only:init_metric + use part, only:metrics,metricderivs,gr + use evwrite, only:init_evfile + use options, only:iexternalforce + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: num,npart,iunit + real, intent(in) :: xyzh(:,:),vxyzu(:,:) + real, intent(in) :: particlemass,time + + if (gr) then + call init_metric(npart,xyzh,metrics,metricderivs) + iexternalforce = 1 + endif + if (first) then + call init_evfile(1,'crap.ev',open_file=.false.) + endif + track_mass = .true. + call compute_energies(time) + + if (first) then + open(unit=1,file='energies.ev',status='new',action='write') + write(1,"(a)") '# time,ekin,etherm,emag,epot,etot,eacc,etot+eacc,totmom,angtot,etotall,angall' + first = .false. + endif + write(1,*) time,ekin,etherm,emag,epot,etot,eacc,etot+eacc,totmom,angtot,etotall,angall + + print*,' TOTAL ENERGY IS: ',etot + print*,' TOTAL ENERGY INCLUDING ACCRETION: ',etotall + +end subroutine do_analysis + +end module analysis diff --git a/src/utils/phantomanalysis.f90 b/src/utils/phantomanalysis.f90 index a0b88c2d2..49d3b5123 100644 --- a/src/utils/phantomanalysis.f90 +++ b/src/utils/phantomanalysis.f90 @@ -26,6 +26,7 @@ program phantomanalysis use analysis, only:do_analysis,analysistype use eos, only:ieos use kernel, only:hfact_default + use externalforces, only:mass1,accradius1 implicit none integer :: nargs,iloc,ierr,iarg,i,idust_opacity real :: time @@ -76,6 +77,8 @@ program phantomanalysis do_nucleation = .true. inucleation = 1 endif + call read_inopt(mass1,'mass1',db,ierr) + call read_inopt(accradius1,'accradius1',db,ierr) call close_db(db) close(ianalysis) endif From 36521a3da8dfdb6b0bd7d32087b17d74bccab1dd Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 24 May 2024 17:59:43 +1000 Subject: [PATCH 578/814] (eacc) bug fix in epotacc calculation; also turn iexternalforce=1 for grtde setup with GR=no --- src/main/energies.F90 | 4 ++-- src/setup/setup_grtde.f90 | 5 ++++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 721b6a1be..df16588e6 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -336,7 +336,7 @@ subroutine compute_energies(t) dumy = 0. dumz = 0. epottmpi = 0. - call externalforce(iexternalforce,xi,yi,zi,hi,t,dumx,dumy,dumz,epoti,ii=i) + call externalforce(iexternalforce,xi,yi,zi,hi,t,dumx,dumy,dumz,epottmpi,ii=i) call externalforce_vdependent(iexternalforce,xyzh(1:3,i),vxyzu(1:3,i),fdum,epottmpi) epoti = pmassi*epottmpi endif @@ -353,7 +353,7 @@ subroutine compute_energies(t) epot = epot + epoti else epotacc = epotacc + epoti - endif + endif ! ! total dust mass for each species diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index 275bdcc02..0e73d1e72 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -45,7 +45,7 @@ module setup !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas,& - gravity,eos_vars,rad + gravity,eos_vars,rad,gr use setbinary, only:set_binary use setstar, only:set_star,shift_star use units, only:set_units,umass,udist @@ -61,6 +61,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use gravwaveutils, only:theta_gw,calc_gravitwaves use setup_params, only:rhozero,npart_total use systemutils, only:get_command_option + use options, only:iexternalforce integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -228,6 +229,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, theta_gw = -theta*180./pi endif + if (.not.gr) iexternalforce = 1 + if (npart == 0) call fatal('setup','no particles setup') if (ierr /= 0) call fatal('setup','ERROR during setup') From 0f10f4db4ca4c023c8448ad6237bc015c1adc456 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 24 May 2024 11:55:27 +0100 Subject: [PATCH 579/814] edits so it passes tests again --- src/main/step_leapfrog.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index c0f5c83f4..3e78ba2c3 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -199,7 +199,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif !Alison - if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L202", fxyzu(4,i) + if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L202", fxyzu(4,i) !--floor the thermal energy if requested and required if (ufloor > 0. .and. icooling /= 9) then @@ -321,7 +321,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vpred(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif !Alison - if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L324", fxyzu(4,i) + if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L324", fxyzu(4,i) !--floor the thermal energy if requested and required if (ufloor > 0. .and. icooling /= 9) then @@ -482,7 +482,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) endif !Alison - if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L488", fxyzu(4,i) + if (icooling==9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L488", fxyzu(4,i) if (use_dustgrowth .and. itype==idust) dustprop(:,i) = dustprop(:,i) + dti*ddustprop(:,i) if (itype==igas) then @@ -565,7 +565,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vzi = vxyzu(3,i) + hdtsph*fxyzu(3,i) if (maxvxyzu >= 4) eni = vxyzu(4,i) + hdtsph*fxyzu(4,i) !Alison - if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L488", fxyzu(4,i) + if (icooling==9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L568", fxyzu(4,i) erri = (vxi - vpred(1,i))**2 + (vyi - vpred(2,i))**2 + (vzi - vpred(3,i))**2 errmax = max(errmax,erri) @@ -659,7 +659,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) endif !Alison - if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L662", fxyzu(4,i) + if (icooling ==9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L662", fxyzu(4,i) if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) - hdtsph*ddustprop(:,i) if (itype==igas) then if (mhd) Bevol(:,i) = Bevol(:,i) - hdtsph*dBevol(:,i) From 95f132096cdefaff3d4963956c7227403f39ff7e Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 May 2024 12:37:15 +1000 Subject: [PATCH 580/814] (eacc) uninitialised variable warning fixed if ISOTHERMAL=yes --- src/main/energies.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index df16588e6..eec6576a3 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -419,6 +419,8 @@ subroutine compute_energies(t) elseif (ieos==9) then !--thermal energy using piecewise polytropic equation of state ethermi = pmassi*ponrhoi/(gamma_pwp(rhoi)-1.)*gasfrac + else + ethermi = 0. endif if (spsoundi < tiny(spsoundi) .and. was_not_accreted) np_cs_eq_0 = np_cs_eq_0 + 1 endif From 9ec6ba5e52e86ab7f37325db9846e4467e47b9f7 Mon Sep 17 00:00:00 2001 From: Cristiano Longarini <81079965+crislong@users.noreply.github.com> Date: Mon, 27 May 2024 16:55:28 +1000 Subject: [PATCH 581/814] New module to inject particles at a given radius in a disc with Keplerian velocity --- build/Makefile_setups | 4 +- src/main/inject_keplerian.f90 | 247 ++++++++++++++++++++++++++++++++++ 2 files changed, 249 insertions(+), 2 deletions(-) create mode 100644 src/main/inject_keplerian.f90 diff --git a/build/Makefile_setups b/build/Makefile_setups index 88ae6cac6..bcd038494 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -925,8 +925,8 @@ ifeq ($(SETUP), isosgdisc) IND_TIMESTEPS=yes ANALYSIS=analysis_dustydisc.f90 ISOTHERMAL=yes - DISC_VISCOSITY=yes KNOWN_SETUP=yes + SRCINJECT= inject_keplerian.f90 endif ifeq ($(SETUP), dustyisosgdisc) @@ -937,7 +937,7 @@ ifeq ($(SETUP), dustyisosgdisc) IND_TIMESTEPS=yes ANALYSIS=analysis_dustydisc.f90 ISOTHERMAL=yes - DISC_VISCOSITY=yes + SRCINJECT= inject_keplerian.f90 KNOWN_SETUP=yes endif diff --git a/src/main/inject_keplerian.f90 b/src/main/inject_keplerian.f90 new file mode 100644 index 000000000..9564bfb1c --- /dev/null +++ b/src/main/inject_keplerian.f90 @@ -0,0 +1,247 @@ +!--------------------------------------------------------------------------! +! 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 inject +! +! Injection of material at keplerian speed in an accretion disc +! +! :References: +! +! :Owner: Daniel Price +! +! :Runtime parameters: +! - datafile : *name of data file for wind injection* +! - outer_boundary : *kill gas particles outside this radius* +! +! :Dependencies: dim, eos, infile_utils, io, part, partinject, physcon, +! random, units +! + implicit none + character(len=*), parameter, public :: inject_type = 'keplerian' + + public :: init_inject,inject_particles,write_options_inject,read_options_inject,& + set_default_options_inject,update_injected_par + + real :: mdot = 0. + real :: rinj = 25. + real :: HonR_inj = 0.05 + integer, private :: iseed=-888 + +contains +!----------------------------------------------------------------------- +!+ +! Initialize global variables or arrays needed for injection routine +!+ +!----------------------------------------------------------------------- +subroutine init_inject(ierr) + use io, only:warning + use part, only:nptmass + integer, intent(out) :: ierr + ! + ! return without error + ! + ierr = 0 + if (nptmass > 1) call warning(inject_type,'Using first sink particle to compute Keplerian velocity') + +end subroutine init_inject + +!----------------------------------------------------------------------- +!+ +! set defaults +!+ +!----------------------------------------------------------------------- +subroutine set_default_options_inject(flag) + integer, optional, intent(in) :: flag + +end subroutine set_default_options_inject + +!----------------------------------------------------------------------- +!+ +! Main routine handling injection at a given radius rinj +!+ +!----------------------------------------------------------------------- +subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + npart,npart_old,npartoftype,dtinject) + use io, only:fatal,iverbose,warning + use part, only:massoftype,igas,nptmass,isdead_or_accreted,maxvxyzu + use partinject, only:add_or_update_particle + use physcon, only:pi,solarm,years + use units, only:umass,utime + use random, only:ran2,gauss_random + use options, only:iexternalforce,ieos + use externalforces, only:mass1 + use eos, only:equationofstate,gamma + real, intent(in) :: time, dtlast + real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) + integer, intent(inout) :: npart, npart_old + integer, intent(inout) :: npartoftype(:) + real, intent(out) :: dtinject + real :: Minject,Mdot_code + real :: frac_extra,deltat + real :: x0(3),v0(3),mstar,r2min,dr2,hguess,phi,cosphi,sinphi,r2,xyzi(3),vxyz(3),u + real :: vkep,vphi,zi,cs,bigH + real :: dum_ponrho,dum_rho,dum_temp + integer :: i,k,i_part,ninject + ! + ! convert mass loss rate from Msun/yr to code units + ! + Mdot_code = Mdot*(solarm/umass)*(utime/years) + + ! + ! get central mass + ! + x0 = 0. + v0 = 0. + if (iexternalforce > 0) then + mstar = mass1 + elseif (nptmass >= 1) then + x0 = xyzmh_ptmass(1:3,1) + v0 = vxyz_ptmass(1:3,1) + mstar = xyzmh_ptmass(4,1) + else + mstar = 1. + call fatal(inject_type,'no central object to compute Keplerian velocity') + endif + + ! for the smoothing length, take it from the closest existing particle to the injection radius + hguess = 1. + r2min = huge(r2min) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + r2 = xyzh(1,i)**2 + xyzh(2,i)**2 + dr2 = abs(r2 - rinj*rinj) + if (dr2 < r2min) then + hguess = xyzh(4,i) + r2min = dr2 + endif + endif + enddo + + vkep = sqrt(mstar/rinj) + + ! for the temperature, call equation of state to get cs at this radius + if (maxvxyzu >= 4) then + ! use HonR parameter + cs = HonR_inj * vkep + else + dum_rho = 1. + dum_temp = 0. + if (gamma > 1.001) then + call warning(inject_type,'cannot get temp at r=rinj without knowing density, injecting at z=0') + cs = 0. + else + call equationofstate(ieos,dum_ponrho,cs,dum_rho,rinj,0.,0.,dum_temp) + endif + endif + + ! + ! calculate how much mass to inject based on + ! time interval since last injection + ! + deltat = dtlast + Minject = Mdot_code*deltat + ! + ! work out number of particles by divide by mass of gas particles + ! + ninject = int(Minject/massoftype(igas)) + ! + ! for the residual, roll the dice + ! + frac_extra = Minject/massoftype(igas) - ninject + if (ran2(iseed) < frac_extra) ninject = ninject + 1 + + if (iverbose >= 2) print*,' injecting ',& + ninject,Minject/massoftype(igas),massoftype(igas) + + if (ninject > 0) then + do k=1,ninject + ! + ! get random position on ring + ! + phi = 2.*pi*(ran2(iseed) - 0.5) + + cosphi = cos(phi) + sinphi = sin(phi) + + bigH = cs*rinj/vkep + zi = gauss_random(iseed)*bigH + + vphi = vkep*(1. - (zi/rinj)**2)**(-0.75) ! see Martire et al. (2024) + + xyzi = (/rinj*cosphi,rinj*sinphi,zi/) + x0 + vxyz = (/-vphi*sinphi, vphi*cosphi, 0./) + v0 + + u = 1.5*cs**2 + + i_part = npart + 1 ! all particles are new + call add_or_update_particle(igas, xyzi, vxyz, hguess, u, i_part, npart, npartoftype, xyzh, vxyzu) + enddo + endif + + if (iverbose >= 2) then + print*,'npart = ',npart + endif + ! + !-- no constraint on timestep + ! + dtinject = huge(dtinject) + +end subroutine inject_particles + +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + +!----------------------------------------------------------------------- +!+ +! Writes input options to the input file. +!+ +!----------------------------------------------------------------------- +subroutine write_options_inject(iunit) + use infile_utils, only:write_inopt + use part, only:maxvxyzu + integer, intent(in) :: iunit + + call write_inopt(mdot,'mdot','mass injection rate [msun/yr]',iunit) + call write_inopt(rinj,'rinj','injection radius',iunit) + if (maxvxyzu >= 4) then + call write_inopt(HonR_inj,'HonR_inj','aspect ratio to give temperature at rinj',iunit) +endif + +end subroutine write_options_inject + +!----------------------------------------------------------------------- +!+ +! Reads input options from the input file. +!+ +!----------------------------------------------------------------------- +subroutine read_options_inject(name,valstring,imatch,igotall,ierr) + use io, only:fatal,error,warning + use physcon, only:solarm,years + 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_inject' + + imatch = .true. + select case(trim(name)) + case('mdot') + read(valstring,*,iostat=ierr) mdot + case('rinj') + read(valstring,*,iostat=ierr) rinj + case('HonR_inj') + read(valstring,*,iostat=ierr) HonR_inj + case default + imatch = .false. + end select + + igotall = (ngot >= 0) + +end subroutine read_options_inject + +end module inject From e3b41c24b8bd2d6d1d8f160577fa682b7584fa7a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 30 May 2024 08:43:56 +0200 Subject: [PATCH 582/814] attempt to fix the head buffer overflow --- src/main/ptmass.F90 | 39 ++++++++++++++++++++------------------- src/main/substepping.F90 | 8 ++++---- 2 files changed, 24 insertions(+), 23 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index c8cfeafd7..c85fe830e 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1046,7 +1046,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote real :: q2i,qi,psofti,psoftj,psoftk,fsoft,epot_mass,epot_rad,pmassgas1 real :: hcheck,hcheck2,f_acc_local real(4) :: divvi,potenj_min,poteni - integer :: ifail,nacc,j,k,n,nk,itype,itypej,itypek,ifail_array(inosink_max),id_rhomax,nneigh_act + integer :: ifail,nacc,j,k,n,nk,itype,itypej,itypek,ifail_array(inosink_max),id_rhomax,nneigh_act,new_nptmass logical :: accreted,iactivej,isgasj,isdustj,calc_exact_epot,ForceCreation ifail = 0 @@ -1500,16 +1500,15 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote ! create new point mass, at position of original particle but with zero mass. Then accrete particles within hacc to form sink ! if (ifail==0) then - nptmass = nptmass + 1 - if (nptmass > maxptmass) call fatal('ptmass_create','nptmass > maxptmass') - n = nptmass - xyzmh_ptmass(:,n) = 0. ! zero all quantities by default - xyzmh_ptmass(1:3,n) = (/xi,yi,zi/) - xyzmh_ptmass(4,n) = 0. ! zero mass - xyzmh_ptmass(ihacc,n) = h_acc - xyzmh_ptmass(ihsoft,n) = h_soft_sinkgas - xyzmh_ptmass(itbirth,n) = time - vxyz_ptmass(:,n) = 0. ! zero velocity, get this by accreting + new_nptmass = nptmass + 1 + if (new_nptmass > maxptmass) call fatal('ptmass_create','nptmass > maxptmass') + xyzmh_ptmass(:,new_nptmass) = 0. ! zero all quantities by default + xyzmh_ptmass(1:3,new_nptmass) = (/xi,yi,zi/) + xyzmh_ptmass(4,new_nptmass) = 0. ! zero mass + xyzmh_ptmass(ihacc,new_nptmass) = h_acc + xyzmh_ptmass(ihsoft,new_nptmass) = h_soft_sinkgas + xyzmh_ptmass(itbirth,new_nptmass) = time + vxyz_ptmass(:,new_nptmass) = 0. ! zero velocity, get this by accreting itypej = igas ! default particle type to be accreted pmassj = massoftype(igas) ! default particle mass to be accreted ! @@ -1527,7 +1526,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote fxj = fxyzu(1,j) + fext(1,j) fyj = fxyzu(2,j) + fext(2,j) fzj = fxyzu(3,j) + fext(3,j) - call ptmass_accrete(n,n,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),& + call ptmass_accrete(new_nptmass,new_nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),& vxyzu(1,j),vxyzu(2,j),vxyzu(3,j),fxj,fyj,fzj, & itypej,pmassj,xyzmh_ptmass,vxyz_ptmass,accreted, & dptmass,time,f_acc_local,ibin_wakei,ibin_wakei) @@ -1536,21 +1535,23 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote enddo ! perform reduction just for this sink - dptmass(:,n) = reduceall_mpi('+',dptmass(:,n)) + dptmass(:,new_nptmass) = reduceall_mpi('+',dptmass(:,new_nptmass)) nacc = int(reduceall_mpi('+', nacc)) ! update ptmass position, spin, velocity, acceleration, and mass - fxyz_ptmass(1:4,n) = 0.0 - fxyz_ptmass_sinksink(1:4,n) = 0.0 - call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,n) + fxyz_ptmass(1:4,new_nptmass) = 0.0 + write(iprint,*) ubound(fxyz_ptmass_sinksink,dim=2),fxyz_ptmass(1:4,new_nptmass),fxyz_ptmass_sinksink(1:4,new_nptmass) + fxyz_ptmass_sinksink(1:4,new_nptmass) = 0.0 + call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,new_nptmass) - if (icreate_sinks > 1) call ptmass_create_seeds(n,xyzmh_ptmass,linklist_ptmass,time) + if (icreate_sinks > 1) call ptmass_create_seeds(new_nptmass,xyzmh_ptmass,linklist_ptmass,time) if (id==id_rhomax) then - write(iprint,"(a,i3,a,4(es10.3,1x),a,i6,a,es10.3)") ' created ptmass #',n,& - ' at (x,y,z,t)=(',xyzmh_ptmass(1:3,n),time,') by accreting ',nacc,' particles: M=',xyzmh_ptmass(4,n) + write(iprint,"(a,i3,a,4(es10.3,1x),a,i6,a,es10.3)") ' created ptmass #',new_nptmass,& + ' at (x,y,z,t)=(',xyzmh_ptmass(1:3,new_nptmass),time,') by accreting ',nacc,' particles: M=',xyzmh_ptmass(4,new_nptmass) endif if (nacc <= 0) call fatal('ptmass_create',' created ptmass but failed to accrete anything') + nptmass = new_nptmass ! ! open new file to track new sink particle details & and update all sink-tracking files; ! fxyz_ptmass, fxyz_ptmass_sinksink are total force on sinks and sink-sink forces. diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 743ada2c5..1ed29030b 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -923,10 +923,10 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, 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) - fxyz_ptmass_sinksink = fxyz_ptmass - dsdt_ptmass_sinksink = dsdt_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif + fxyz_ptmass_sinksink(:,1:nptmass+1) = fxyz_ptmass (:,1:nptmass+1) + dsdt_ptmass_sinksink(:,1:nptmass+1) = dsdt_ptmass (:,1:nptmass+1) else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) @@ -934,10 +934,10 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, 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) - fxyz_ptmass_sinksink = fxyz_ptmass - dsdt_ptmass_sinksink = dsdt_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif + fxyz_ptmass_sinksink(:,1:nptmass+1) = fxyz_ptmass (:,1:nptmass+1) + dsdt_ptmass_sinksink(:,1:nptmass+1) = dsdt_ptmass (:,1:nptmass+1) endif endif else From d2c9b5180b20ca91e03df38ae37e8254a7e561ae Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 31 May 2024 15:20:48 +0200 Subject: [PATCH 583/814] (ptmass) print tests for seed generation --- src/main/ptmass.F90 | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index c85fe830e..05e1d7ec7 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1544,14 +1544,17 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote fxyz_ptmass_sinksink(1:4,new_nptmass) = 0.0 call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,new_nptmass) - if (icreate_sinks > 1) call ptmass_create_seeds(new_nptmass,xyzmh_ptmass,linklist_ptmass,time) - if (id==id_rhomax) then write(iprint,"(a,i3,a,4(es10.3,1x),a,i6,a,es10.3)") ' created ptmass #',new_nptmass,& ' at (x,y,z,t)=(',xyzmh_ptmass(1:3,new_nptmass),time,') by accreting ',nacc,' particles: M=',xyzmh_ptmass(4,new_nptmass) endif if (nacc <= 0) call fatal('ptmass_create',' created ptmass but failed to accrete anything') nptmass = new_nptmass + + if (icreate_sinks == 2) then + call ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) + write(iprint,"(a,i3)") ' Star formation prescription : created seeds #',(nptmass-new_nptmass) + endif ! ! open new file to track new sink particle details & and update all sink-tracking files; ! fxyz_ptmass, fxyz_ptmass_sinksink are total force on sinks and sink-sink forces. @@ -1583,20 +1586,21 @@ subroutine ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) integer, intent(inout) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: time - integer :: i, nseed + integer :: i, nseed, n ! !-- Draw the number of star seeds in the core ! nseed = floor(5*rand()) + n = nptmass do i=1,nseed - nptmass = nptmass + 1 - xyzmh_ptmass(itbirth,nptmass) = time - xyzmh_ptmass(4,nptmass) = -1. - xyzmh_ptmass(ihacc,nptmass) = -1. - linklist_ptmass(nptmass) = nptmass + 1 !! link this new seed to the next one + n = n + 1 + xyzmh_ptmass(itbirth,n) = time + xyzmh_ptmass(4,n) = -1. + xyzmh_ptmass(ihacc,n) = -1. + linklist_ptmass(n) = n + 1 !! link this new seed to the next one enddo - linklist_ptmass(nptmass) = -1 !! null pointer to end the link list - + linklist_ptmass(n) = -1 !! null pointer to end the link list + nptmass = n end subroutine ptmass_create_seeds subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) From 9fa15bf3797756ebe5d8204a989473a30596c626 Mon Sep 17 00:00:00 2001 From: Cristiano Longarini <81079965+crislong@users.noreply.github.com> Date: Mon, 3 Jun 2024 11:47:50 +1000 Subject: [PATCH 584/814] Update inject.f90 When injecting particles at rinj with Keplerian velocity, we do not take into account the velocity and position of the central object --- src/main/inject_keplerian.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/inject_keplerian.f90 b/src/main/inject_keplerian.f90 index 9564bfb1c..d9f821532 100644 --- a/src/main/inject_keplerian.f90 +++ b/src/main/inject_keplerian.f90 @@ -171,8 +171,8 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& vphi = vkep*(1. - (zi/rinj)**2)**(-0.75) ! see Martire et al. (2024) - xyzi = (/rinj*cosphi,rinj*sinphi,zi/) + x0 - vxyz = (/-vphi*sinphi, vphi*cosphi, 0./) + v0 + xyzi = (/rinj*cosphi,rinj*sinphi,zi/) + vxyz = (/-vphi*sinphi, vphi*cosphi, 0./) u = 1.5*cs**2 From aa2a034cf08c0e98861abce96e1c0ba04adeac97 Mon Sep 17 00:00:00 2001 From: Cristiano Longarini <81079965+crislong@users.noreply.github.com> Date: Mon, 3 Jun 2024 18:12:10 +1000 Subject: [PATCH 585/814] update inject_keplerian.f90 - flag to follow the sink - adding 2 simmetric particles to better conserve momentum and avoid shift of com --- src/main/inject_keplerian.f90 | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/src/main/inject_keplerian.f90 b/src/main/inject_keplerian.f90 index d9f821532..7ade9b7b0 100644 --- a/src/main/inject_keplerian.f90 +++ b/src/main/inject_keplerian.f90 @@ -28,6 +28,7 @@ module inject real :: mdot = 0. real :: rinj = 25. real :: HonR_inj = 0.05 + logical :: follow_sink = .true. integer, private :: iseed=-888 contains @@ -98,8 +99,10 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& if (iexternalforce > 0) then mstar = mass1 elseif (nptmass >= 1) then - x0 = xyzmh_ptmass(1:3,1) - v0 = vxyz_ptmass(1:3,1) + if (follow_sink) then + x0 = xyzmh_ptmass(1:3,1) + v0 = vxyz_ptmass(1:3,1) + endif mstar = xyzmh_ptmass(4,1) else mstar = 1. @@ -111,7 +114,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& r2min = huge(r2min) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then - r2 = xyzh(1,i)**2 + xyzh(2,i)**2 + r2 = (xyzh(1,i)-x0(1))**2 + (xyzh(2,i)-x0(2))**2 dr2 = abs(r2 - rinj*rinj) if (dr2 < r2min) then hguess = xyzh(4,i) @@ -150,14 +153,14 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& ! ! for the residual, roll the dice ! - frac_extra = Minject/massoftype(igas) - ninject - if (ran2(iseed) < frac_extra) ninject = ninject + 1 + frac_extra = Minject/massoftype(igas) - 2*(ninject/2) + if (ran2(iseed) < 0.5*frac_extra) ninject = ninject + 2 if (iverbose >= 2) print*,' injecting ',& ninject,Minject/massoftype(igas),massoftype(igas) if (ninject > 0) then - do k=1,ninject + do k=1,ninject/2 ! ! get random position on ring ! @@ -176,8 +179,10 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& u = 1.5*cs**2 - i_part = npart + 1 ! all particles are new - call add_or_update_particle(igas, xyzi, vxyz, hguess, u, i_part, npart, npartoftype, xyzh, vxyzu) + i_part = npart + 1! all particles are new + call add_or_update_particle(igas, xyzi+x0, vxyz+v0, hguess, u, i_part, npart, npartoftype, xyzh, vxyzu) + i_part = npart + 1! all particles are new + call add_or_update_particle(igas, -xyzi+x0, -vxyz+v0, hguess, u, i_part, npart, npartoftype, xyzh, vxyzu) enddo endif @@ -203,7 +208,7 @@ subroutine update_injected_par !----------------------------------------------------------------------- subroutine write_options_inject(iunit) use infile_utils, only:write_inopt - use part, only:maxvxyzu + use part, only:maxvxyzu,nptmass integer, intent(in) :: iunit call write_inopt(mdot,'mdot','mass injection rate [msun/yr]',iunit) @@ -211,6 +216,9 @@ subroutine write_options_inject(iunit) if (maxvxyzu >= 4) then call write_inopt(HonR_inj,'HonR_inj','aspect ratio to give temperature at rinj',iunit) endif +if (nptmass >= 1) then + call write_inopt(follow_sink,'follow_sink','injection radius is relative to sink particle 1',iunit) +endif end subroutine write_options_inject @@ -236,6 +244,8 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) rinj case('HonR_inj') read(valstring,*,iostat=ierr) HonR_inj + case('follow_sink') + read(valstring,*,iostat=ierr) follow_sink case default imatch = .false. end select From fabbdb37734b489297a9671f5091a620272c4490 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 3 Jun 2024 13:51:35 +0200 Subject: [PATCH 586/814] (ptmass) new check for stars to allow cores to form nearby and no merge of stars --- src/main/evolve.F90 | 2 +- src/main/force.F90 | 7 +-- src/main/ptmass.F90 | 77 +++++++++++++++------------- src/main/random.f90 | 39 +++++++++++++- src/main/readwrite_dumps_fortran.f90 | 4 +- src/main/utils_sampling.f90 | 59 --------------------- 6 files changed, 87 insertions(+), 101 deletions(-) delete mode 100644 src/main/utils_sampling.f90 diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 7f7237613..ab34a98a4 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -278,7 +278,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! 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) - if (icreate_sinks > 1) call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) + if (icreate_sinks == 2) call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) endif ! ! Strang splitting: implicit update for half step diff --git a/src/main/force.F90 b/src/main/force.F90 index 00e00fbff..494f00186 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -213,8 +213,8 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& use kernel, only:kernel_softening use kdtree, only:expand_fgrav_in_taylor_series use linklist, only:get_distance_from_centre_of_mass - use part, only:xyzmh_ptmass,nptmass,massoftype,maxphase,is_accretable - use ptmass, only:icreate_sinks,rho_crit,r_crit2 + use part, only:xyzmh_ptmass,nptmass,massoftype,maxphase,is_accretable,ihacc + use ptmass, only:icreate_sinks,rho_crit,r_crit2,h_acc use units, only:unit_density #endif #ifdef DUST @@ -435,7 +435,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& !$omp private(iactivei,iamdusti,iamtypei) & !$omp private(dx,dy,dz,poti,fxi,fyi,fzi,potensoft0,dum,epoti) & !$omp shared(xyzmh_ptmass,nptmass) & -!$omp shared(rhomax,ipart_rhomax,icreate_sinks,rho_crit,r_crit2) & +!$omp shared(rhomax,ipart_rhomax,icreate_sinks,rho_crit,r_crit2,h_acc) & !$omp private(rhomax_thread,ipart_rhomax_thread,use_part,j) & #endif !$omp shared(id) & @@ -682,6 +682,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& ! use_part = .true. over_ptmass: do j=1,nptmass + if (icreate_sinks==2 .and. xyzmh_ptmass(ihacc,j) 0. .and. & (xyzh(1,i) - xyzmh_ptmass(1,j))**2 & + (xyzh(2,i) - xyzmh_ptmass(2,j))**2 & diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 05e1d7ec7..3300469c8 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -321,7 +321,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real, optional, intent(in) :: extrapfac real, optional, intent(in) :: fsink_old(4,nptmass) integer, optional, intent(in) :: group_info(3,nptmass) - real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii + real :: 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 real :: fextx,fexty,fextz,phiext !,hsofti @@ -368,8 +368,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info,subsys) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & - !$omp shared(extrapfac,extrap,fsink_old) & - !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & + !$omp shared(extrapfac,extrap,fsink_old,h_acc) & + !$omp private(i,j,xi,yi,zi,pmassi,pmassj,hacci,haccj) & !$omp private(gidi,gidj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & @@ -395,7 +395,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin zi = xyzmh_ptmass(3,i) endif pmassi = xyzmh_ptmass(4,i) - !hsofti = xyzmh_ptmass(5,i) + hacci = xyzmh_ptmass(5,i) if (pmassi < 0.) cycle J2i = xyzmh_ptmass(iJ2,i) @@ -425,7 +425,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dz = zi - xyzmh_ptmass(3,j) endif pmassj = xyzmh_ptmass(4,j) - !hsoftj = xyzmh_ptmass(5,j) + haccj = xyzmh_ptmass(5,j) if (pmassj < 0.) cycle J2j = xyzmh_ptmass(iJ2,j) @@ -478,17 +478,19 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin call get_geopot_force(dx,dy,dz,ddr,f1,rsinki,J2i,shati,fxi,fyi,fzi,phii,dsx,dsy,dsz) endif endif - if (rr2 < r_merge2) then - if (merge_ij(i)==0) then - merge_n = merge_n + 1 - merge_ij(i) = j - else - ! if we have already identified a nearby sink, replace the tag with the nearest sink - dx = xi - xyzmh_ptmass(1,merge_ij(i)) - dy = yi - xyzmh_ptmass(2,merge_ij(i)) - dz = zi - xyzmh_ptmass(3,merge_ij(i)) - rr2j = dx*dx + dy*dy + dz*dz + epsilon(rr2j) - if (rr2 < rr2j) merge_ij(i) = j + if (hacci>h_acc .or. haccj>h_acc) then + if (rr2 < r_merge2) then + if (merge_ij(i)==0) then + merge_n = merge_n + 1 + merge_ij(i) = j + else + ! if we have already identified a nearby sink, replace the tag with the nearest sink + dx = xi - xyzmh_ptmass(1,merge_ij(i)) + dy = yi - xyzmh_ptmass(2,merge_ij(i)) + dz = zi - xyzmh_ptmass(3,merge_ij(i)) + rr2j = dx*dx + dy*dy + dz*dz + epsilon(rr2j) + if (rr2 < rr2j) merge_ij(i) = j + endif endif endif enddo @@ -1540,7 +1542,6 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote ! update ptmass position, spin, velocity, acceleration, and mass fxyz_ptmass(1:4,new_nptmass) = 0.0 - write(iprint,*) ubound(fxyz_ptmass_sinksink,dim=2),fxyz_ptmass(1:4,new_nptmass),fxyz_ptmass_sinksink(1:4,new_nptmass) fxyz_ptmass_sinksink(1:4,new_nptmass) = 0.0 call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,new_nptmass) @@ -1553,7 +1554,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote if (icreate_sinks == 2) then call ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) - write(iprint,"(a,i3)") ' Star formation prescription : created seeds #',(nptmass-new_nptmass) + write(iprint,"(a,i3)") ' Star formation prescription : created seeds #',(nptmass + 1 - new_nptmass) endif ! ! open new file to track new sink particle details & and update all sink-tracking files; @@ -1582,16 +1583,19 @@ end subroutine ptmass_create subroutine ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) use part, only:itbirth,ihacc + use random, only:ran2 integer, intent(inout) :: nptmass integer, intent(inout) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: time - integer :: i, nseed, n + integer :: i,nseed,iseed,n ! !-- Draw the number of star seeds in the core ! - nseed = floor(5*rand()) + iseed=-834 + nseed = floor(5*ran2(iseed))-1 n = nptmass + linklist_ptmass(n) = n + 1 !! link the core to the seeds do i=1,nseed n = n + 1 xyzmh_ptmass(itbirth,n) = time @@ -1609,24 +1613,26 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, use io, only:iprint use units, only:umass use part, only:itbirth,ihacc - use utils_sampling, only:divide_unit_seg + use random , only:ran2,gauss_random,divide_unit_seg integer, intent(in) :: nptmass integer, intent(in) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(in) :: time real, allocatable :: masses(:) real :: xi(3),vi(3) - integer :: i,k,n + integer :: i,k,n,iseed real :: tbirthi,mi,hacci,minmass,minmonmi real :: xk,yk,zk,d,cs + iseed = -3541 + do i=1,nptmass mi = xyzmh_ptmass(4,i) hacci = xyzmh_ptmass(ihacc,i) tbirthi = xyzmh_ptmass(itbirth,i) if (mi<0.) cycle - if (time>tbirthi+tmax_acc .and. hacci>0. ) then - write(iprint,"(i8,i8)") time, tbirthi+tmax_acc + if (time>=tbirthi+tmax_acc .and. hacci==h_acc ) then + write(iprint,"(a,es18.10)") "ptmass_create_stars : new stars formed at : ",time !! save xcom and vcom before placing stars xi(1) = xyzmh_ptmass(1,i) xi(2) = xyzmh_ptmass(2,i) @@ -1648,20 +1654,20 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, !! do some clever stuff d = huge(mi) do while (d>1.) - xk = rand() - yk = rand() - zk = rand() + xk = ran2(iseed) + yk = ran2(iseed) + zk = ran2(iseed) d = xk**2+yk**2+zk**2 enddo cs = sqrt(polyk) - xyzmh_ptmass(ihacc,i) = -1. - xyzmh_ptmass(4,i) = masses(n) + xyzmh_ptmass(ihacc,k) = hacci*1.e-3 + xyzmh_ptmass(4,k) = masses(n) xyzmh_ptmass(1,k) = xi(1) + xk*hacci xyzmh_ptmass(2,k) = xi(2) + yk*hacci xyzmh_ptmass(3,k) = xi(3) + zk*hacci - vxyz_ptmass(1,k) = vi(1) + cs*(-2.*log10(rand()))*cos(2*pi**rand()) - vxyz_ptmass(2,k) = vi(2) + cs*(-2.*log10(rand()))*cos(2*pi**rand()) - vxyz_ptmass(3,k) = vi(3) + cs*(-2.*log10(rand()))*cos(2*pi**rand()) + vxyz_ptmass(1,k) = vi(1) + cs*gauss_random(iseed) + vxyz_ptmass(2,k) = vi(2) + cs*gauss_random(iseed) + vxyz_ptmass(3,k) = vi(3) + cs*gauss_random(iseed) k = linklist_ptmass(k) n = n - 1 enddo @@ -1772,7 +1778,7 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklis - mij*(xyzmh_ptmass(1,k)*vxyz_ptmass(2,k) - xyzmh_ptmass(2,k)*vxyz_ptmass(1,k)) ! Kill sink j by setting negative mass xyzmh_ptmass(4,j) = -abs(mj) - if(icreate_sinks>1) then + if (icreate_sinks == 2) then ! Connect linked list of the merged sink to the survivor call ptmass_end_lklist(k,l,linklist_ptmass) linklist_ptmass(l) = j @@ -2081,8 +2087,9 @@ subroutine write_options_ptmass(iunit) call write_inopt(r_crit,'r_crit','critical radius for point mass creation (no new sinks < r_crit from existing sink)', & iunit) call write_inopt(h_acc, 'h_acc' ,'accretion radius for new sink particles',iunit) - !if (icreate_sinks>1) - call write_inopt(tmax_acc, "tmax_acc", "Maximum accretion time for star formation scheme", iunit) + if (icreate_sinks==2) then + call write_inopt(tmax_acc, "tmax_acc", "Maximum accretion time for star formation scheme", iunit) + endif if (f_crit_override > 0. .or. l_crit_override) then call write_inopt(f_crit_override,'f_crit_override' ,'unconditional sink formation if rho > f_crit_override*rho_crit',& iunit) diff --git a/src/main/random.f90 b/src/main/random.f90 index e77444401..ac9dd88b5 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -19,7 +19,7 @@ module random ! implicit none public :: ran2,get_random,rayleigh_deviate - public :: get_random_pos_on_sphere,gauss_random + public :: get_random_pos_on_sphere,gauss_random,divide_unit_seg real, parameter :: pi = 4.*atan(1.) private @@ -167,4 +167,41 @@ real function gauss_random(iseed) end function gauss_random + +subroutine divide_unit_seg(lengths,mindist,nlengths) + integer, intent(in) :: nlengths + real, intent(inout) :: lengths(nlengths) + real, intent(in) :: mindist + integer :: i,j,iseed + logical :: close,lower + real :: points(nlengths+1),tmp,dist + points(nlengths+1) = 1. + points(1) = 0. + tmp = 0. + iseed = -3421 + + do i=2,nlengths + close = .true. + lower = .true. + dist = huge(tmp) + do while (close .or. lower) + tmp = ran2(iseed) + dist = huge(tmp) + do j=1,i-1 + dist = min(abs(points(j)-tmp),dist) + enddo + dist = min(abs(points(nlengths+1)-tmp),dist) + close = dist>mindist + lower = tmp < points(i-1) + enddo + points(i) = tmp + enddo + + do i=2,nlengths+1 + lengths(i-1) = points(i) - points(i-1) + enddo + +end subroutine divide_unit_seg + + end module random diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 57ad86a05..56c7bf61e 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -306,7 +306,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ilen(2) = int(nptmass,kind=8) call write_array(2,xyzmh_ptmass,xyzmh_ptmass_label,nsinkproperties,nptmass,k,ipass,idump,nums,nerr) call write_array(2,vxyz_ptmass,vxyz_ptmass_label,3,nptmass,k,ipass,idump,nums,nerr) - if (icreate_sinks > 1) then + if (icreate_sinks == 2) then call write_array(2,linklist_ptmass,"linklist_ptmass",nptmass,k,ipass,idump,nums,nerr) endif if (nerr > 0) call error('write_dump','error writing sink particle arrays') @@ -1122,7 +1122,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto case(2) call read_array(xyzmh_ptmass,xyzmh_ptmass_label,got_sink_data,ik,1,nptmass,0,idisk1,tag,match,ierr) call read_array(vxyz_ptmass, vxyz_ptmass_label, got_sink_vels,ik,1,nptmass,0,idisk1,tag,match,ierr) - if (icreate_sinks > 1) then + if (icreate_sinks == 2) then call read_array(linklist_ptmass,'linklist_ptmass',got_sink_llist,ik,1,nptmass,0,idisk1,tag,match,ierr) endif end select diff --git a/src/main/utils_sampling.f90 b/src/main/utils_sampling.f90 deleted file mode 100644 index b959ba76a..000000000 --- a/src/main/utils_sampling.f90 +++ /dev/null @@ -1,59 +0,0 @@ -!--------------------------------------------------------------------------! -! 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 utils_sampling -! -! Contains simple routine to sample variable using specific distributions -! -! :References: None -! -! :Owner: Yann Bernard -! -! :Runtime parameters: None -! -! :Dependencies: None -! - implicit none - public :: divide_unit_seg - -contains - -subroutine divide_unit_seg(lengths,mindist,nlengths) - integer, intent(in) :: nlengths - real, intent(inout) :: lengths(nlengths) - real, intent(in) :: mindist - integer :: i,j - logical :: far - real :: points(nlengths+1),tmp,dist - points(nlengths+1) = 1. - points(1) = 0. - tmp = 0. - - do i=2,nlengths - far = .false. - dist = huge(tmp) - do while (far) - tmp = rand() - dist = min(abs(points(1)-tmp),dist) - dist = min(abs(points(nlengths+1)-tmp),dist) - do j=2,i-1 - dist = min(abs(points(j)-tmp),dist) - enddo - far = mindist Date: Mon, 3 Jun 2024 13:52:07 +0200 Subject: [PATCH 587/814] (ptmass) add new test for star formation scheme --- src/tests/test_ptmass.f90 | 35 +++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 84d754071..1480f1a18 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -768,15 +768,16 @@ subroutine test_createsink(ntests,npass) nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,ndptmass, & dptmass,fxyz_ptmass_sinksink,linklist_ptmass use ptmass, only:ptmass_accrete,update_ptmass,icreate_sinks,& - ptmass_create,finish_ptmass,ipart_rhomax,h_acc,rho_crit,rho_crit_cgs + ptmass_create,finish_ptmass,ipart_rhomax,h_acc,rho_crit,rho_crit_cgs, & + ptmass_create_stars,tmax_acc use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceloc_mpi,reduceall_mpi use spherical, only:set_sphere use stretchmap, only:rho_func integer, intent(inout) :: ntests,npass - integer :: i,itest,itestp,nfailed(3),imin(1) + integer :: i,itest,itestp,nfailed(4),imin(1) integer :: id_rhomax,ipart_rhomax_global - real :: psep,totmass,r2min,r2,t + real :: psep,totmass,r2min,r2,t,coremass,starsmass real :: etotin,angmomin,totmomin,rhomax,rhomax_test procedure(rho_func), pointer :: density_func @@ -785,8 +786,10 @@ subroutine test_createsink(ntests,npass) iverbose = 1 rho_crit = rho_crit_cgs - do itest=1,2 + do itest=1,3 select case(itest) + case(3) + if (id==master) write(*,"(/,a)") '--> testing sink particle creation (cores and stars prescription)' case(2) if (id==master) write(*,"(/,a)") '--> testing sink particle creation (sin)' case default @@ -827,7 +830,13 @@ subroutine test_createsink(ntests,npass) ! and make sure that gravitational potential energy has been computed ! tree_accuracy = 0. - icreate_sinks = 1 + if (itest==3) then + icreate_sinks = 2 + linklist_ptmass = -1 + tmax_acc = 0. + else + icreate_sinks = 1 + endif call get_derivs_global() @@ -887,11 +896,25 @@ subroutine test_createsink(ntests,npass) endif call ptmass_create(nptmass,npart,itestp,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,dptmass,0.) + if (itest==3) then + coremass = 0. + starsmass = 0. + coremass = xyzmh_ptmass(4,1) + call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,0.) + do i=1,nptmass + starsmass = starsmass + xyzmh_ptmass(4,i) + enddo + endif ! ! check that creation succeeded ! nfailed(:) = 0 - call checkval(nptmass,1,0,nfailed(1),'nptmass=1') + if (itest == 3) then + call checkval(nptmass,3,3,nfailed(1),'nptmass=nseeds') + call checkval(starsmass-coremass,0.,0.,nfailed(4),'Mass conservation') + else + call checkval(nptmass,1,0,nfailed(1),'nptmass=1') + endif call update_test_scores(ntests,nfailed,npass) ! ! check that linear and angular momentum and energy is conserved From 9b9ce6f063a87621dbc224919488e1b7dab0f7bc Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 3 Jun 2024 18:28:25 +0200 Subject: [PATCH 588/814] (ptmass) minor refactory --- src/main/ptmass.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 3300469c8..819d33cf3 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1662,12 +1662,12 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, cs = sqrt(polyk) xyzmh_ptmass(ihacc,k) = hacci*1.e-3 xyzmh_ptmass(4,k) = masses(n) - xyzmh_ptmass(1,k) = xi(1) + xk*hacci - xyzmh_ptmass(2,k) = xi(2) + yk*hacci - xyzmh_ptmass(3,k) = xi(3) + zk*hacci - vxyz_ptmass(1,k) = vi(1) + cs*gauss_random(iseed) - vxyz_ptmass(2,k) = vi(2) + cs*gauss_random(iseed) - vxyz_ptmass(3,k) = vi(3) + cs*gauss_random(iseed) + xyzmh_ptmass(1,k) = xi(1) + xk*hacci + xyzmh_ptmass(2,k) = xi(2) + yk*hacci + xyzmh_ptmass(3,k) = xi(3) + zk*hacci + vxyz_ptmass(1,k) = vi(1) + cs*gauss_random(iseed) + vxyz_ptmass(2,k) = vi(2) + cs*gauss_random(iseed) + vxyz_ptmass(3,k) = vi(3) + cs*gauss_random(iseed) k = linklist_ptmass(k) n = n - 1 enddo From d91e4be48f32c1dcc3fd05dcd306afccca1b5502 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 3 Jun 2024 18:29:50 +0200 Subject: [PATCH 589/814] (subgroups) condition with nptmass = 0 --- src/main/subgroup.f90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index a754e8d61..96a7c7344 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -49,9 +49,10 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm n_group = 0 n_ingroup = 0 n_sing = 0 - - call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) - call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + if (nptmass > 0) then + call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) + call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + endif if (id==master .and. iverbose>1) then write(iprint,"(i6,a,i6,a,i6,a)") n_group," groups identified, ",n_ingroup," in a group, ",n_sing," singles..." From e0179252bc48f0afb51c6d7cc16ff11c40941644 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 4 Jun 2024 10:14:06 +0200 Subject: [PATCH 590/814] (h2region) import previous version, need to be cleaned up --- src/main/H2regions.f90 | 402 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 402 insertions(+) create mode 100644 src/main/H2regions.f90 diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 new file mode 100644 index 000000000..1975da2d4 --- /dev/null +++ b/src/main/H2regions.f90 @@ -0,0 +1,402 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2021 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.bitbucket.io/ ! +! Module proposed By Yann BERNARD to implement stellar feedbacks in cluster! +! simulations ! +!--------------------------------------------------------------------------! + +module HIIRegion + ! + ! + ! contains routine for Stromgren radius calculation and Radiative pressure velocity kick + ! routine originally made by Fujii et al 2021 + ! adapted in Phantom by Yann BERNARD + ! reference : Fujii et al. 2021 SIRIUS Project Paper III + ! + ! + use part, only:nbpart,npart + + implicit none + + public :: update_fbsource, update_Q_list, HII_feedback,initialize_fb,search_connected_HII,check_ionized_sinks + public :: allocate_fb,deallocate_fb + + integer, public :: nbfbmax = 300 + integer, public :: nbfbs = 0 + integer, public :: iFb = 0 + real, private, parameter :: a = -39.3178 + real, private, parameter :: b = 221.997 + real, private, parameter :: c = -227.456 + real, private, parameter :: d = 117.410 + real, private, parameter :: e = -30.1511 + real, private, parameter :: f = 3.06810 + real, private, parameter :: ar_cgs = 2.6d-13 + real, private, parameter :: sigd_cgs = 1.d-21 + real, private :: ar + real, private :: sigd + real, private :: hv_on_c + real, private :: mu = 2.38 + real, private :: mH + real, private :: T_ion + real, private :: u_to_t + real, private :: Rst2_max + logical, private :: overlapping =.false. + integer, allocatable :: source_id(:) + real, allocatable :: Qsource(:) + real, allocatable :: dxyz (:,:,:) + real, allocatable :: r2(:) + real, allocatable :: overlap_e(:) + real, allocatable :: Rst_source(:) + integer, allocatable :: arg_r2(:,:) + logical, public, allocatable :: isionised(:) + private + +contains + + !----------------------------------------------------------------------- + !+ + ! Initialise stellar feedbacks + !+ + !----------------------------------------------------------------------- +subroutine initialize_fb + use units, only:udist,umass,utime + use physcon, only:mass_proton_cgs,kboltz,atomic_mass_unit,pc,eV + use eos , only:gamma,gmw + call allocate_fb(nbfbmax) + isionised(:)=.false. + source_id(:)= 0 + !calculate the useful constant in code units + mH = gmw*mass_proton_cgs + u_to_t = (3./2)*(kboltz/mH)*(utime/udist)**2 + mH = mH/umass + T_ion = 1.d4 + ar = ar_cgs*utime/udist**3 + sigd = sigd_cgs*udist**2 + hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) + Rst2_max = ((15*pc)/udist)**2 + print*,"feedback constants mH,u_to_t,T_ion,u_to_t*T_ion,gmw : ",mH,u_to_t,T_ion,u_to_t*T_ion,gmw + !open(20,file="Rst.dat") + return +end subroutine initialize_fb + + !----------------------------------------------------------------------- + !+ + ! subroutine that gives the number of sources + !+ + !----------------------------------------------------------------------- + +subroutine update_fbsource(pmass,i) + use part, only: nbpart + real, intent(in) :: pmass + integer, intent(in) :: i + ! select feedback source with a minimum mass of 8 Msun + if(pmass>8) then + nbfbs = nbfbs + 1 + source_id(nbfbs) = i + call update_Q_list(pmass) + endif + return +end subroutine update_fbsource + + !----------------------------------------------------------------------- + !+ + ! Calculation of the the ionizing photon rate + !+ + !----------------------------------------------------------------------- + +subroutine update_Q_list(pmass) + use units, only:utime + use part, only:xyzmh_bpart + real, intent(in) :: pmass + real :: log_pmassj,log_Q + ! caluclation of the ionizing photon rate of each sources + ! this calculation uses Fujii's formula derived from OSTAR2002 databases + log_pmassj = log10(pmass) + log_Q = (a+b*log_pmassj+c*log_pmassj**2+d*log_pmassj**3+e*log_pmassj**4+f*log_pmassj**5) + Qsource(nbfbs) = (10.**log_Q)*utime + print*,"New source detected : Log Q : ",log_Q + print*,"nb_feedback sources : ",nbfbs + return +end subroutine update_Q_list + + !----------------------------------------------------------------------- + !+ + ! Main subroutine : Application of the HII feedback using Hopkins's like prescription + !+ + !----------------------------------------------------------------------- + +subroutine HII_feedback(dt) + use part, only:xyzh,xyzmh_bpart,vxyzu,rhoh,massoftype + use units, only:unit_density,udist,umass + use physcon,only:pc,pi + use utils_stellarfb,only:merge_argsort,print_fblog_time + use timing, only: get_timings + real(kind=4) :: t1,t2,tcpu1,tcpu2 + real, intent(in) :: dt + integer :: i,j,l,k,n + real :: pmass,Ndot,DNdot,R_stop,eps,taud_on_r,taud,mHII,v_kick,r + pmass = massoftype(1) + ! at each new kick we reset all the particles status + isionised(:) = .false. + Rst_source(:) = 0. + overlap_e(:) = 0. + eps = xyzmh_bpart(5,1) + ! + !!!!!!! Rst derivation and thermal feedback + ! + call get_timings(t1,tcpu1) + do i=1,nbfbs + n=size(r2) + j=source_id(i) + ! for each source we compute the distances of each particles and sort to have a Knn list + ! Patch : We need to be aware of dead particles that will pollute the scheme if not taking into account. + ! The simpliest way is to put enormous distance for dead particle to be at the very end of the knn list. + do l=1,npart + if (xyzh(4,l)<0.) then + dxyz(:,l,i) = huge(pmass) + else + dxyz(1,l,i) = xyzh(1,l)-xyzmh_bpart(1,j) + dxyz(2,l,i) = xyzh(2,l)-xyzmh_bpart(2,j) + dxyz(3,l,i) = xyzh(3,l)-xyzmh_bpart(3,j) + endif + enddo + r2(:) = dxyz(1,:,i)**2+dxyz(2,:,i)**2+dxyz(3,:,i)**2 + call merge_argsort(r2,arg_r2(:,i)) + k = arg_r2(n,i) + ! calculation of the ionised mass + Ndot = Qsource(i) + DNdot = (pmass*ar*rhoh(xyzh(4,k),pmass))/(mH**2) + !print*,"Ndot : DNdot : local rho : ",Ndot,DNdot,rhoh(xyzh(4,k),pmass)*unit_density + if (Ndot>DNdot) then + ! iteration on the Knn until we used all the source photons + if (r2(k)DNdot .and. n/=0 .and. r2(k)DNdot .and. n/=0 .and. r2(k)3*pmass) then + do while (r 1.97) taud=1.97 + v_kick = (1.+1.5*exp(-taud))*(Qsource(i)/mHII)*hv_on_c*(dxyz(j,k,i)/r) + vxyzu(j,k) = vxyzu(j,k) + v_kick*dt + enddo + n=n-1 + k = arg_r2(n,i) + r = sqrt(dxyz(1,k,i)**2 + dxyz(2,k,i)**2 + dxyz(3,k,i)**2) + enddo + !print*, "real MHII", (size(r2)-n)*pmass + endif + enddo + + + + ! resetting overlap flag for the next step. + overlapping = .false. + call get_timings(t2,tcpu2) + call print_fblog_time(nbfbs,tcpu2-tcpu1) + return +end subroutine HII_feedback + + +subroutine search_connected_HII(nb) + use part, only: xyzmh_bpart + use utils_stellarfb, only:jacobi_eigenvalue + integer, intent(in) :: nb + real :: LapMatrix(nb,nb) + real :: EigenVec(nb,nb) + real :: EigenV(nb) + integer :: i,j,k,l,nb_region,nb_node + real :: dist,dx,dy,dz + real :: region_ov_e + ! construct laplacian matrix to identify unconnected components of the graph + LapMatrix = 0. + do i=1,nbfbs + do j=1,nbfbs + k = source_id(i) + l = source_id(j) + dx =(xyzmh_bpart(1,k)-xyzmh_bpart(1,l)) + dy =(xyzmh_bpart(2,k)-xyzmh_bpart(2,l)) + dz =(xyzmh_bpart(3,k)-xyzmh_bpart(3,l)) + dist = sqrt(dx**2+dy**2+dz**2) + !print*,dist,Rst_source(i)+Rst_source(j) + ! ici il faut résoudre le soucis de la connexion sur des sources non résolues ou coupées car trop loin + if (Rst_source(i)/=0.0 .and. Rst_source(j)/=0.0) then + if (dist< Rst_source(i)+Rst_source(j) .and. i/=j) then + LapMatrix(i,j)= - 1 + endif + endif + enddo + LapMatrix(i,i) = abs(sum(LapMatrix(i,:))) + !print*,LapMatrix(i,:) + enddo + ! compute egeinvalues and vectors of the Laplacian matrix + call jacobi_eigenvalue(nb,LapMatrix,1000,EigenVec,EigenV) + nb_region = count(EigenV<0.000001) + !print*,EigenV + do i=1, nb_region + !print*,"region : ",i + region_ov_e=0 + nb_node=0 + do j=1, nbfbs + if (EigenVec(j,i)/=0.)then + region_ov_e = region_ov_e + overlap_e(j) + nb_node = nb_node + 1 + !print*,"member : ",j + endif + enddo + do j=1, nbfbs + if (EigenVec(j,i)/=0.)then + overlap_e(j) = region_ov_e/nb_node + endif + enddo + enddo + +end subroutine search_connected_HII + + !----------------------------------------------------------------------- + !+ + ! The aim of this subroutine is to warned if a sink has been ionized by + ! a massive star. One star can only ionized one sink, beacause it can be only in one sink. + ! Thus these check need to collect m_acc t_mean to compute the ionizing criterion. + !+ + !----------------------------------------------------------------------- + +subroutine check_ionized_sinks(msflag,merged_ptmass) + use part, only: nptmass,xyzmh_ptmass,xyzmh_bpart,ihacc,icmpast,itcreate,t_acc + use physcon, only: pi + logical, intent(out) :: msflag(nptmass) + integer, intent(in) :: merged_ptmass(:) + integer :: i,j,k,kmax,nmerged + real :: rsquare,h2,tmean,macc,rhos,rst + msflag(:)=.false. + ! Check if any MS are in the vinicity of a sink + do i = 1, nbfbs + if (xyzmh_bpart(4,i)<15.)cycle + kmax = 0 + tmean = 0. + macc = 0. + do j = 1, nptmass + if (xyzmh_ptmass(ihacc,j)<0.) cycle + if (xyzmh_ptmass(4,j)<0.)cycle + if (msflag(j)) cycle + h2 = xyzmh_ptmass(ihacc,i)**2 + rsquare = (xyzmh_ptmass(1,j)-xyzmh_bpart(1,i))**2+(xyzmh_ptmass(2,j)-xyzmh_bpart(2,i))**2& + +(xyzmh_ptmass(3,j)-xyzmh_bpart(3,i))**2 + if (rsquare0.5*(xyzmh_ptmass(ihacc,kmax))) then + msflag(kmax) = .true. + endif + endif + enddo +end subroutine check_ionized_sinks + +subroutine allocate_fb(n) + use allocutils, only:allocate_array + integer, intent(in) :: n + call allocate_array("Qsource" , Qsource , n) + call allocate_array("Rst_source" , Rst_source , n) + call allocate_array("overlap_e", overlap_e, n) + call allocate_array("dxyz", dxyz, 3,npart, n) + call allocate_array("r2", r2, npart) + call allocate_array("arg_r2", arg_r2, npart,n) + call allocate_array("isionised", isionised, npart) + call allocate_array('source_id', source_id, n) +end subroutine allocate_fb + +subroutine deallocate_fb + deallocate(source_id) + deallocate(Qsource) + deallocate(overlap_e) + deallocate(Rst_source) + deallocate(dxyz) + deallocate(r2) + deallocate(arg_r2) + deallocate(isionised) +end subroutine deallocate_fb + + +end module HIIRegion From a741c10aa9a37e7d3a95a6866d60608825d90d93 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 4 Jun 2024 10:53:26 +0200 Subject: [PATCH 591/814] (ptmass) add initial seed in runtime parameters --- src/main/ptmass.F90 | 28 +++++++++++++++------------- src/main/random.f90 | 7 +++---- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 819d33cf3..d65e9238c 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -59,6 +59,7 @@ module ptmass ! settings affecting routines in module (read from/written to input file) integer, public :: icreate_sinks = 0 ! 1-standard sink creation scheme 2-Star formation scheme using core prescription + integer, public :: iseed_sf = 313 ! seed used to sample random value for icreate == 2 prescription... real, public :: rho_crit_cgs = 1.e-10 real, public :: r_crit = 5.e-3 real, public :: h_acc = 1.e-3 @@ -1588,12 +1589,11 @@ subroutine ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) integer, intent(inout) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: time - integer :: i,nseed,iseed,n + integer :: i,nseed,n ! !-- Draw the number of star seeds in the core ! - iseed=-834 - nseed = floor(5*ran2(iseed))-1 + nseed = floor(5*ran2(iseed_sf))-1 n = nptmass linklist_ptmass(n) = n + 1 !! link the core to the seeds do i=1,nseed @@ -1620,12 +1620,10 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, real, intent(in) :: time real, allocatable :: masses(:) real :: xi(3),vi(3) - integer :: i,k,n,iseed + integer :: i,k,n real :: tbirthi,mi,hacci,minmass,minmonmi real :: xk,yk,zk,d,cs - iseed = -3541 - do i=1,nptmass mi = xyzmh_ptmass(4,i) hacci = xyzmh_ptmass(ihacc,i) @@ -1646,7 +1644,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, allocate(masses(n)) minmass = (0.08*solarm)/umass minmonmi = minmass/mi - call divide_unit_seg(masses,minmonmi,n) + call divide_unit_seg(masses,minmonmi,n,iseed_sf) masses = masses*mi k=i @@ -1654,9 +1652,9 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, !! do some clever stuff d = huge(mi) do while (d>1.) - xk = ran2(iseed) - yk = ran2(iseed) - zk = ran2(iseed) + xk = ran2(iseed_sf) + yk = ran2(iseed_sf) + zk = ran2(iseed_sf) d = xk**2+yk**2+zk**2 enddo cs = sqrt(polyk) @@ -1665,9 +1663,9 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, xyzmh_ptmass(1,k) = xi(1) + xk*hacci xyzmh_ptmass(2,k) = xi(2) + yk*hacci xyzmh_ptmass(3,k) = xi(3) + zk*hacci - vxyz_ptmass(1,k) = vi(1) + cs*gauss_random(iseed) - vxyz_ptmass(2,k) = vi(2) + cs*gauss_random(iseed) - vxyz_ptmass(3,k) = vi(3) + cs*gauss_random(iseed) + vxyz_ptmass(1,k) = vi(1) + cs*gauss_random(iseed_sf) + vxyz_ptmass(2,k) = vi(2) + cs*gauss_random(iseed_sf) + vxyz_ptmass(3,k) = vi(3) + cs*gauss_random(iseed_sf) k = linklist_ptmass(k) n = n - 1 enddo @@ -2089,6 +2087,7 @@ subroutine write_options_ptmass(iunit) call write_inopt(h_acc, 'h_acc' ,'accretion radius for new sink particles',iunit) if (icreate_sinks==2) then call write_inopt(tmax_acc, "tmax_acc", "Maximum accretion time for star formation scheme", iunit) + call write_inopt(iseed_sf, "iseed_sf", "Initial radom seed for star formation scheme", iunit) endif if (f_crit_override > 0. .or. l_crit_override) then call write_inopt(f_crit_override,'f_crit_override' ,'unconditional sink formation if rho > f_crit_override*rho_crit',& @@ -2178,6 +2177,9 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) case('tmax_acc') read(valstring,*,iostat=ierr) tmax_acc ngot = ngot + 1 + case('iseed_sf') + read(valstring,*,iostat=ierr) iseed_sf + ngot = ngot + 1 case default imatch = .false. end select diff --git a/src/main/random.f90 b/src/main/random.f90 index ac9dd88b5..466782763 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -168,17 +168,16 @@ real function gauss_random(iseed) end function gauss_random -subroutine divide_unit_seg(lengths,mindist,nlengths) - integer, intent(in) :: nlengths +subroutine divide_unit_seg(lengths,mindist,nlengths,iseed) + integer, intent(in) :: nlengths,iseed real, intent(inout) :: lengths(nlengths) real, intent(in) :: mindist - integer :: i,j,iseed + integer :: i,j logical :: close,lower real :: points(nlengths+1),tmp,dist points(nlengths+1) = 1. points(1) = 0. tmp = 0. - iseed = -3421 do i=2,nlengths close = .true. From 1c1f3fe49fe9cd408a31caf629d81422e5e117ed Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 5 Jun 2024 12:06:07 +0200 Subject: [PATCH 592/814] (HIIRegion) First implementation. Needs tests... --- src/main/H2regions.f90 | 517 +++++++++++++--------------------- src/main/checksetup.f90 | 15 + src/main/cons2prim.f90 | 5 +- src/main/eos.f90 | 32 ++- src/main/initial.F90 | 4 +- src/main/part.F90 | 11 +- src/main/readwrite_infile.F90 | 7 +- 7 files changed, 263 insertions(+), 328 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 1975da2d4..cec5835b8 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -16,22 +16,21 @@ module HIIRegion ! reference : Fujii et al. 2021 SIRIUS Project Paper III ! ! - use part, only:nbpart,npart implicit none - public :: update_fbsource, update_Q_list, HII_feedback,initialize_fb,search_connected_HII,check_ionized_sinks - public :: allocate_fb,deallocate_fb + public :: update_ionrate, HII_feedback,initialize_H2R - integer, public :: nbfbmax = 300 - integer, public :: nbfbs = 0 - integer, public :: iFb = 0 - real, private, parameter :: a = -39.3178 - real, private, parameter :: b = 221.997 - real, private, parameter :: c = -227.456 - real, private, parameter :: d = 117.410 - real, private, parameter :: e = -30.1511 - real, private, parameter :: f = 3.06810 + integer, public :: iH2R = 0 + real , public :: Rmax = 15 ! Maximum HII region radius (pc) to avoid artificial expansion... + real , public :: Mmin = 8 ! Minimum mass (Msun) to produce HII region + + real, private, parameter :: a = -39.3178 ! + real, private, parameter :: b = 221.997 !fitted parameters to compute + real, private, parameter :: c = -227.456 !ionisation rate for massive + real, private, parameter :: d = 117.410 !extracted from Fujii et al. (2021). + real, private, parameter :: e = -30.1511 ! + real, private, parameter :: f = 3.06810 ! real, private, parameter :: ar_cgs = 2.6d-13 real, private, parameter :: sigd_cgs = 1.d-21 real, private :: ar @@ -42,15 +41,9 @@ module HIIRegion real, private :: T_ion real, private :: u_to_t real, private :: Rst2_max + real, private :: Rst_max logical, private :: overlapping =.false. - integer, allocatable :: source_id(:) - real, allocatable :: Qsource(:) - real, allocatable :: dxyz (:,:,:) - real, allocatable :: r2(:) - real, allocatable :: overlap_e(:) - real, allocatable :: Rst_source(:) - integer, allocatable :: arg_r2(:,:) - logical, public, allocatable :: isionised(:) + private contains @@ -60,13 +53,13 @@ module HIIRegion ! Initialise stellar feedbacks !+ !----------------------------------------------------------------------- -subroutine initialize_fb +subroutine initialize_H2R + use io, only:iprint,iverbose + use part, only:isionised use units, only:udist,umass,utime - use physcon, only:mass_proton_cgs,kboltz,atomic_mass_unit,pc,eV - use eos , only:gamma,gmw - call allocate_fb(nbfbmax) + use physcon, only:mass_proton_cgs,kboltz,pc,eV + use eos , only:gmw isionised(:)=.false. - source_id(:)= 0 !calculate the useful constant in code units mH = gmw*mass_proton_cgs u_to_t = (3./2)*(kboltz/mH)*(utime/udist)**2 @@ -75,51 +68,57 @@ subroutine initialize_fb ar = ar_cgs*utime/udist**3 sigd = sigd_cgs*udist**2 hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) - Rst2_max = ((15*pc)/udist)**2 - print*,"feedback constants mH,u_to_t,T_ion,u_to_t*T_ion,gmw : ",mH,u_to_t,T_ion,u_to_t*T_ion,gmw - !open(20,file="Rst.dat") - return -end subroutine initialize_fb - - !----------------------------------------------------------------------- - !+ - ! subroutine that gives the number of sources - !+ - !----------------------------------------------------------------------- - -subroutine update_fbsource(pmass,i) - use part, only: nbpart - real, intent(in) :: pmass - integer, intent(in) :: i - ! select feedback source with a minimum mass of 8 Msun - if(pmass>8) then - nbfbs = nbfbs + 1 - source_id(nbfbs) = i - call update_Q_list(pmass) + Rst2_max = ((Rmax*pc)/udist)**2 + Rst_max = sqrt(Rst_max) + Mmin = (Mmin*solarm)/umass + if (iverbose > 1) then + write(iprint,"(/a,es18.10,es18.10/)") "feedback constants mH, u_to_t : ", mH, u_to_t endif return -end subroutine update_fbsource +end subroutine initialize_H2R - !----------------------------------------------------------------------- - !+ - ! Calculation of the the ionizing photon rate - !+ - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!+ +! Calculation of the the ionizing photon rate +!+ +!----------------------------------------------------------------------- -subroutine update_Q_list(pmass) - use units, only:utime - use part, only:xyzmh_bpart - real, intent(in) :: pmass - real :: log_pmassj,log_Q - ! caluclation of the ionizing photon rate of each sources - ! this calculation uses Fujii's formula derived from OSTAR2002 databases - log_pmassj = log10(pmass) - log_Q = (a+b*log_pmassj+c*log_pmassj**2+d*log_pmassj**3+e*log_pmassj**4+f*log_pmassj**5) - Qsource(nbfbs) = (10.**log_Q)*utime - print*,"New source detected : Log Q : ",log_Q - print*,"nb_feedback sources : ",nbfbs +subroutine update_ionrate(nptmass,xyzmh_ptmass) + use io, only:iprint,iverbose + use units, only:utime + use part, only:irateion,ihacc + use ptmass, only: h_acc + integer, intent(in) :: nptmass + real, intent(inout) :: xyzmh_ptmass + real :: logmi,log_Q,mi,hi + integer :: i,n + !$omp parallel do default(none) & + !$omp shared(xyzmh_ptmass,nptmass,iprint,iverbose)& + !$omp private(logmi,log_Q,mi,hi)& + !$omp reduction(+:n) + do i=1,nptmass + mi = xyzmh_ptmass(4,i) + hi = xyzmh_ptmass(ihacc,i) + if(mi > Mmin .or. hi > h_acc)then + xyzmh_ptmass(irateion,i) = -1. + else + logmi = log10(mi) + ! caluclation of the ionizing photon rate of each sources + ! this calculation uses Fujii's formula derived from OSTAR2002 databases + log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) + xyzmh_ptmass(irateion,i) = (10.**log_Q)*utime + n = n + 1 + if (iverbose > 1) then + write(iprint,"(/a,es18.10/)")"HII region detected : Log Q : ",log_Q + endif + endif + enddo + !$omp end parallel do + if (iverbose > 1) then + wirte(iprint,"(/a,i8/)") "nb_feedback sources : ",n + endif return -end subroutine update_Q_list +end subroutine update_ionrate !----------------------------------------------------------------------- !+ @@ -127,276 +126,158 @@ end subroutine update_Q_list !+ !----------------------------------------------------------------------- -subroutine HII_feedback(dt) - use part, only:xyzh,xyzmh_bpart,vxyzu,rhoh,massoftype - use units, only:unit_density,udist,umass - use physcon,only:pc,pi - use utils_stellarfb,only:merge_argsort,print_fblog_time - use timing, only: get_timings - real(kind=4) :: t1,t2,tcpu1,tcpu2 - real, intent(in) :: dt - integer :: i,j,l,k,n - real :: pmass,Ndot,DNdot,R_stop,eps,taud_on_r,taud,mHII,v_kick,r - pmass = massoftype(1) +subroutine HII_feedback(dt,nptmass,npart,xyzh,xyzmh_ptmass,vxyzu) + use part, only:rhoh,massoftype,ihsoft,igas,irateion,isdead_or_accreted,& + irstrom,ioverlap + use linklist, only:getneigh_pos,ifirstincell,listneigh=>listneigh_global + use utils_sort, only:indexxfunc,set_r2func_origin,r2func_origin + use units, only:unit_density,udist,umass + use physcon, only:pc,pi + use timing, only: get_timings + integer, intent(in) :: nptmass,npart + real, intent(in) :: dt + real, intent(in) :: xyzh(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyzu(:,:) + integer, parameter :: maxcache = 12000 + real, save :: xyzcache(maxcache,3) + integer :: i,k,j,npartin,nneigh + real(kind=4) :: t1,t2,tcpu1,tcpu2 + real :: pmass,Ndot,DNdot,R_stop,taud,mHII,r,hcheck + real :: dx,dy,dz,vkx,vky,vkz + ! at each new kick we reset all the particles status isionised(:) = .false. - Rst_source(:) = 0. - overlap_e(:) = 0. - eps = xyzmh_bpart(5,1) + pmass = massoftype(igas) ! - !!!!!!! Rst derivation and thermal feedback + !-- Rst derivation and thermal feedback ! call get_timings(t1,tcpu1) - do i=1,nbfbs - n=size(r2) - j=source_id(i) + do i=1,nptmass + npartin=0 + Qi = xyzmh_ptmass(irateion,i) + if (Qi <=0.) cycle + Ndot = Qi + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + rsti_old = xyzmh_ptmass(irstrom,i) + if (rsti_old > 0.) then + hcheck = Rst_max + elseif (rsti_old > 0.8*Rst_max) then + hcheck = Rst_max + else + hcheck = rsti_old*1.3 + endif ! for each source we compute the distances of each particles and sort to have a Knn list ! Patch : We need to be aware of dead particles that will pollute the scheme if not taking into account. ! The simpliest way is to put enormous distance for dead particle to be at the very end of the knn list. - do l=1,npart - if (xyzh(4,l)<0.) then - dxyz(:,l,i) = huge(pmass) - else - dxyz(1,l,i) = xyzh(1,l)-xyzmh_bpart(1,j) - dxyz(2,l,i) = xyzh(2,l)-xyzmh_bpart(2,j) - dxyz(3,l,i) = xyzh(3,l)-xyzmh_bpart(3,j) - endif - enddo - r2(:) = dxyz(1,:,i)**2+dxyz(2,:,i)**2+dxyz(3,:,i)**2 - call merge_argsort(r2,arg_r2(:,i)) - k = arg_r2(n,i) - ! calculation of the ionised mass - Ndot = Qsource(i) - DNdot = (pmass*ar*rhoh(xyzh(4,k),pmass))/(mH**2) - !print*,"Ndot : DNdot : local rho : ",Ndot,DNdot,rhoh(xyzh(4,k),pmass)*unit_density - if (Ndot>DNdot) then - ! iteration on the Knn until we used all the source photons - if (r2(k)DNdot .and. n/=0 .and. r2(k)DNdot) then + ! iteration on the Knn until we used all the source photons + if (.not.(isionised(j))) then Ndot = Ndot - DNdot - overlap_e(i) = overlap_e(i) + DNdot - overlapping = .true. + vxyzu(4,j) = u_to_t*T_ion + isionised(j)=.true. endif - n = n-1 - k = arg_r2(n,i) - DNdot = (pmass*ar*rhoh(xyzh(4,k),pmass))/(mH**2) - enddo - Rst_source(i) = sqrt(r2(k)) - else - Rst_source(i) = sqrt(Rst2_max) - endif - !write(20,*) Rst_source(i),Rst - !print*,"remaining ionization Energy: ",(Ndot)/Qsource(i),(Ndot/DNdot)*T_ion - !print*,"ionised particles, Rst : ",npart-n,Rst_source(i) - else - ! unresolved cased... - !print*,"source unresolved" - vxyzu(4,k) = (Ndot/DNdot)*u_to_t*T_ion - Rst_source(i) = 0. - endif - enddo - ! - !!!!!!!! overlap regulartization - ! - if(overlapping) then - !print*,"overlapping detection : regularization of the ionization front" - call search_connected_HII(nbfbs) - do i=1,nbfbs - n=size(r2) - k = arg_r2(n,i) - Ndot = overlap_e(i) - DNdot = (pmass*ar*rhoh(xyzh(4,k),pmass))/(mH**2) - ! iteration on the Knn until we used all the source photons - do while (Ndot>DNdot .and. n/=0 .and. r2(k) 1) then + ! end of the HII region + r = ((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) + else + ! unresolved case + r = 0. + endif + exit endif - n = n-1 - k = arg_r2(n,i) - DNdot = (pmass*ar*rhoh(xyzh(4,k),pmass))/(mH**2) - enddo + endif enddo - endif - ! - !!!!!!!! momentum feedback - ! - !print*, "Adding momentum feedback in HII region" - do i=1, nbfbs - if (Rst_source(i)< 2*eps) then - R_stop = 2*eps - else - R_stop = Rst_source(i) - endif - n=size(r2) - k = arg_r2(n,i) - r = sqrt(dxyz(1,k,i)**2 + dxyz(2,k,i)**2 + dxyz(3,k,i)**2) - taud_on_r = (rhoh(xyzh(4,k),pmass)/mH)*sigd - mHII = ((4.*pi*(R_stop**3-r**3)*rhoh(xyzh(4,k),pmass))/3) - !print*,"MHII and Momentum prefactor :",mHII,(Qsource(i)/mHII)*hv_on_c,R_stop,Rst_source(i) + npartin = k + xyzmh_ptmass(irstrom,i) = r + ! + !-- Momentum feedback + ! + j = listneigh(1) + mHII = ((4.*pi*(R_stop**3-r**3)*rhoh(xyzh(4,j),pmass))/3) if (mHII>3*pmass) then - do while (r 1.97) taud=1.97 - v_kick = (1.+1.5*exp(-taud))*(Qsource(i)/mHII)*hv_on_c*(dxyz(j,k,i)/r) - vxyzu(j,k) = vxyzu(j,k) + v_kick*dt - enddo - n=n-1 - k = arg_r2(n,i) - r = sqrt(dxyz(1,k,i)**2 + dxyz(2,k,i)**2 + dxyz(3,k,i)**2) - enddo - !print*, "real MHII", (size(r2)-n)*pmass - endif - enddo - - - - ! resetting overlap flag for the next step. - overlapping = .false. - call get_timings(t2,tcpu2) - call print_fblog_time(nbfbs,tcpu2-tcpu1) - return -end subroutine HII_feedback - - -subroutine search_connected_HII(nb) - use part, only: xyzmh_bpart - use utils_stellarfb, only:jacobi_eigenvalue - integer, intent(in) :: nb - real :: LapMatrix(nb,nb) - real :: EigenVec(nb,nb) - real :: EigenV(nb) - integer :: i,j,k,l,nb_region,nb_node - real :: dist,dx,dy,dz - real :: region_ov_e - ! construct laplacian matrix to identify unconnected components of the graph - LapMatrix = 0. - do i=1,nbfbs - do j=1,nbfbs - k = source_id(i) - l = source_id(j) - dx =(xyzmh_bpart(1,k)-xyzmh_bpart(1,l)) - dy =(xyzmh_bpart(2,k)-xyzmh_bpart(2,l)) - dz =(xyzmh_bpart(3,k)-xyzmh_bpart(3,l)) - dist = sqrt(dx**2+dy**2+dz**2) - !print*,dist,Rst_source(i)+Rst_source(j) - ! ici il faut résoudre le soucis de la connexion sur des sources non résolues ou coupées car trop loin - if (Rst_source(i)/=0.0 .and. Rst_source(j)/=0.0) then - if (dist< Rst_source(i)+Rst_source(j) .and. i/=j) then - LapMatrix(i,j)= - 1 +!$omp parallel do default(none) & +!$omp shared(mHII,listneigh,xyzcache,xyzh,sigd,dt,Qi,hv_on_c) & +!$omp private(j,dx,dy,dz,vkx,vky,vkz,xj,yj,zj,r,taud) + do k=1,npartin + j = listneigh(1) + if (k <= maxcache) then + xj = xyzcache(k,1) + yj = xyzcache(k,2) + zj = xyzcache(k,3) + else + xj = xyzh(1,j) + yj = xyzh(2,j) + zj = xyzh(3,j) endif - endif - enddo - LapMatrix(i,i) = abs(sum(LapMatrix(i,:))) - !print*,LapMatrix(i,:) - enddo - ! compute egeinvalues and vectors of the Laplacian matrix - call jacobi_eigenvalue(nb,LapMatrix,1000,EigenVec,EigenV) - nb_region = count(EigenV<0.000001) - !print*,EigenV - do i=1, nb_region - !print*,"region : ",i - region_ov_e=0 - nb_node=0 - do j=1, nbfbs - if (EigenVec(j,i)/=0.)then - region_ov_e = region_ov_e + overlap_e(j) - nb_node = nb_node + 1 - !print*,"member : ",j - endif - enddo - do j=1, nbfbs - if (EigenVec(j,i)/=0.)then - overlap_e(j) = region_ov_e/nb_node - endif - enddo - enddo - -end subroutine search_connected_HII + dx = xi - xj + dy = yi - yj + dz = zi - zj + r = dx**2 + dy**2 + dz**2 - !----------------------------------------------------------------------- - !+ - ! The aim of this subroutine is to warned if a sink has been ionized by - ! a massive star. One star can only ionized one sink, beacause it can be only in one sink. - ! Thus these check need to collect m_acc t_mean to compute the ionizing criterion. - !+ - !----------------------------------------------------------------------- - -subroutine check_ionized_sinks(msflag,merged_ptmass) - use part, only: nptmass,xyzmh_ptmass,xyzmh_bpart,ihacc,icmpast,itcreate,t_acc - use physcon, only: pi - logical, intent(out) :: msflag(nptmass) - integer, intent(in) :: merged_ptmass(:) - integer :: i,j,k,kmax,nmerged - real :: rsquare,h2,tmean,macc,rhos,rst - msflag(:)=.false. - ! Check if any MS are in the vinicity of a sink - do i = 1, nbfbs - if (xyzmh_bpart(4,i)<15.)cycle - kmax = 0 - tmean = 0. - macc = 0. - do j = 1, nptmass - if (xyzmh_ptmass(ihacc,j)<0.) cycle - if (xyzmh_ptmass(4,j)<0.)cycle - if (msflag(j)) cycle - h2 = xyzmh_ptmass(ihacc,i)**2 - rsquare = (xyzmh_ptmass(1,j)-xyzmh_bpart(1,i))**2+(xyzmh_ptmass(2,j)-xyzmh_bpart(2,i))**2& - +(xyzmh_ptmass(3,j)-xyzmh_bpart(3,i))**2 - if (rsquare 1.97) taud=1.97 + vkx = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dx/r) + vky = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dy/r) + vkz = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dz/r) + vxyzu(1,j) = vxyzu(1,j) + vkx*dt + vxyzu(2,j) = vxyzu(2,j) + vky*dt + vxyzu(3,j) = vxyzu(3,j) + vkz*dt enddo - tmean = tmean/(nmerged*t_acc) - macc = xyzmh_ptmass(4,kmax)-macc - rhos = (tmean*macc)/(4*pi*(xyzmh_ptmass(ihacc,kmax)**3)/3) - rst = ((3*Qsource(i))/(4*pi*(rhos/mH)**2))**(1./3) - if (rst>0.5*(xyzmh_ptmass(ihacc,kmax))) then - msflag(kmax) = .true. - endif - endif - enddo -end subroutine check_ionized_sinks - -subroutine allocate_fb(n) - use allocutils, only:allocate_array - integer, intent(in) :: n - call allocate_array("Qsource" , Qsource , n) - call allocate_array("Rst_source" , Rst_source , n) - call allocate_array("overlap_e", overlap_e, n) - call allocate_array("dxyz", dxyz, 3,npart, n) - call allocate_array("r2", r2, npart) - call allocate_array("arg_r2", arg_r2, npart,n) - call allocate_array("isionised", isionised, npart) - call allocate_array('source_id', source_id, n) -end subroutine allocate_fb +!$omp end parallel do + enddo + endif +enddo +call get_timings(t2,tcpu2) +return +end subroutine HII_feedback -subroutine deallocate_fb - deallocate(source_id) - deallocate(Qsource) - deallocate(overlap_e) - deallocate(Rst_source) - deallocate(dxyz) - deallocate(r2) - deallocate(arg_r2) - deallocate(isionised) -end subroutine deallocate_fb +subroutine write_options_H2R(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + write(iunit,"(/,a)") '# options controlling HII region expansion feedback' + if(iH2R>0) then + call write_inopt(IH2R, 'IH2R', "unable the HII region expansion feedback in star forming reigon", iunit) + call write_inopt(Mmin, 'Mmin', "Minimum star mass to trigger HII region (MSun)", iunit) + call write_inopt(Rmax, 'Rmax', "Maximum radius for HII region (pc)", iunit) + endif +end subroutine write_options_H2R +subroutine read_options_H2R(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_H2R' + imatch = .true. + select case(trim(name)) + case('H2R') + read(valstring,*,iostat=ierr) iH2R + if (iH2R < 0) call fatal(label,'HII region option out of range') + ngot = ngot + 1 + case('Mmin') + read(valstring,*,iostat=ierr) Mmin + if (Mmin < 8.) call fatal(label,'Minimimum mass can not be inferior to 8 solar masses') + ngot = ngot + 1 + case('Rmax') + read(valstring,*,iostat=ierr) Rmax + if (Rmax < 10.) call fatal(label,'Maximum radius can not be inferior to 10 pc') + ngot = ngot + 1 + case default + imatch = .true. + end select + igotall = (ngotall >= 3) +end subroutine read_options_H2R end module HIIRegion diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 9ab68cacf..5af6d6712 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -1045,5 +1045,20 @@ subroutine check_regnbody (nerror) endif end subroutine check_regnbody +subroutine check_HIIRegion(nerror) + use HIIRegion, only:iH2R + use eos, only:ieos + use dim, only:gr + integer, intent(inout) :: nerror + if(iH2R>0 .and. ieos/=21) then + print "(/,a,/)", "Error: If HII activated, eos == 21 is mandatory..." + nerror = nerror + 1 + endif + if(iH2R>0 .and. gr) then + print "(/,a,/)", "Error: Gr is not compatible with HII Region" + nerror = nerror + 1 + endif +end subroutine check_HIIRegion + end module checksetup diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 18d054644..0a2f8cbc7 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -175,7 +175,7 @@ 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 + ndustsmall,itemp,ikappa,idmu,idgamma,icv,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 @@ -277,7 +277,8 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& gamma_local=gammai,mu_local=mui,Xlocal=X_i,Zlocal=Z_i) else !isothermal - call equationofstate(ieos,p_on_rhogas,spsound,rhogas,xi,yi,zi,temperaturei,mu_local=mui) + call equationofstate(ieos,p_on_rhogas,spsound,rhogas,xi,yi,zi,temperaturei,mu_local=mui, & + isionised=isionised(i)) endif eos_vars(igasP,i) = p_on_rhogas*rhogas diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 10f619129..32e1849ab 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -49,7 +49,7 @@ module eos use part, only:ien_etotal,ien_entropy,ien_type use dim, only:gr implicit none - integer, parameter, public :: maxeos = 20 + integer, parameter, public :: maxeos = 21 real, public :: polyk, polyk2, gamma real, public :: qfacdisc = 0.75, qfacdisc2 = 0.75 logical, public :: extract_eos_from_hdr = .false. @@ -103,7 +103,7 @@ module eos ! (and position in the case of the isothermal disc) !+ !---------------------------------------------------------------- -subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gamma_local,mu_local,Xlocal,Zlocal) +subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gamma_local,mu_local,Xlocal,Zlocal,isionised) use io, only:fatal,error,warning use part, only:xyzmh_ptmass, nptmass use units, only:unit_density,unit_pressure,unit_ergg,unit_velocity @@ -120,9 +120,10 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam real, intent(in) :: rhoi,xi,yi,zi real, intent(out) :: ponrhoi,spsoundi real, intent(inout) :: tempi - real, intent(in), optional :: eni - real, intent(inout), optional :: mu_local,gamma_local - real, intent(in) , optional :: Xlocal,Zlocal + real, intent(in), optional :: eni + real, intent(inout), optional :: mu_local,gamma_local + real, intent(in) , optional :: Xlocal,Zlocal + logical(kind=1), intent(in), optional :: isionised integer :: ierr, i real :: r1,r2 real :: mass_r, mass ! defined for generalised Farris prescription @@ -130,6 +131,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam real :: cgsrhoi,cgseni,cgspresi,presi,gam1,cgsspsoundi real :: uthermconst real :: enthi,pondensi + logical :: ionisedi ! ! Check to see if equation of state is compatible with GR cons2prim routines ! @@ -147,6 +149,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam if (present(mu_local)) mui = mu_local if (present(Xlocal)) X_i = Xlocal if (present(Zlocal)) Z_i = Zlocal + if (present(isionised)) ionisedi = isionised select case(eos_type) case(1) @@ -423,6 +426,25 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam tempi = temperaturei if (present(mu_local)) mu_local = 1./imui if (present(gamma_local)) gamma_local = gammai + case(21) + ! + !--dual medium isothermal eos + ! + ! :math:`P = c_s^2 \rho` + ! + ! where :math:`c_s^2 \equiv K` is a constant stored in the dump file header + ! + if(isionised) then + ponrhoi = polyk + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + else + ponrhoi = polyk + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + endif + + case default spsoundi = 0. ! avoids compiler warnings diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 4c9a97aa2..ed75b5ff3 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -212,7 +212,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use fileutils, only:make_tags_unique use damping, only:idamp - use subgroup, only:group_identify + use subgroup, only:group_identify + use HIIRegion, only:iH2R,initialize_H2R character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile logical, intent(in), optional :: noread @@ -498,6 +499,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass + if (iH2R > 0) call initialize_H2R() ! compute initial sink-sink forces and get timestep if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) diff --git a/src/main/part.F90 b/src/main/part.F90 index 5b5ae5f18..8831ecd5f 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -204,6 +204,8 @@ module part integer, parameter :: i_mlast = 17 ! accreted mass of last time integer, parameter :: imassenc = 18 ! mass enclosed in sink softening radius integer, parameter :: iJ2 = 19 ! 2nd gravity moment due to oblateness + integer, parameter :: irstrom = 20 ! Stromgren radius of the stars (icreate_sinks == 2) + integer, parameter :: irateion = 21 ! overlapped energy between two HII regions (icreate_sinks == 2) integer, parameter :: ndptmass = 13 ! number of properties to conserve after a accretion phase or merge real, allocatable :: xyzmh_ptmass(:,:) real, allocatable :: vxyz_ptmass(:,:) @@ -216,7 +218,8 @@ module part (/'x ','y ','z ','m ','h ',& 'hsoft ','maccreted','spinx ','spiny ','spinz ',& 'tlast ','lum ','Teff ','Reff ','mdotloss ',& - 'mdotav ','mprev ','massenc ','J2 '/) + 'mdotav ','mprev ','massenc ','J2 ','Rstrom ',& + 'rate_ion'/) character(len=*), parameter :: vxyz_ptmass_label(3) = (/'vx','vy','vz'/) ! !--self-gravity @@ -304,6 +307,10 @@ module part integer :: n_sing = 0 ! Gradient of the time transformation function real, allocatable :: gtgrad(:,:) + ! +!-- Regularisation algorithm allocation +! + logical(kind=1), allocatable :: isionised(:) ! !--derivatives (only needed if derivs is called) ! @@ -497,6 +504,7 @@ subroutine allocate_part call allocate_array('group_info', group_info, 3, maxptmass) call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) call allocate_array("gtgrad", gtgrad, 3, maxptmass) + call allocate_array('isionised', isionised, maxp) end subroutine allocate_part @@ -580,6 +588,7 @@ subroutine deallocate_part if (allocated(group_info)) deallocate(group_info) if (allocated(nmatrix)) deallocate(nmatrix) if (allocated(gtgrad)) deallocate(gtgrad) + if (allocated(isionised)) deallocate(isionised) end subroutine deallocate_part diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 8523dbdd2..b1e879a87 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -123,6 +123,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) use dim, only:maxvxyzu,maxptmass,gravity,sink_radiation,gr,nalpha use part, only:maxp,mhd,maxalpha,nptmass use boundary_dyn, only:write_options_boundary + use HIIRegion, only:write_options_H2R character(len=*), intent(in) :: infile,logfile,evfile,dumpfile integer, intent(in) :: iwritein,iprint integer :: ierr @@ -303,6 +304,7 @@ 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) + call write_options_H2R(iwritein) if (iwritein /= iprint) close(unit=iwritein) if (iwritein /= iprint) write(iprint,"(/,a)") ' input file '//trim(infile)//' written successfully.' @@ -346,6 +348,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) use damping, only:read_options_damping use gravwaveutils, only:read_options_gravitationalwaves use boundary_dyn, only:read_options_boundary + use HIIRegion, only:read_options_H2R character(len=*), parameter :: label = 'read_infile' character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile @@ -358,7 +361,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) logical :: imatch,igotallrequired,igotallturb,igotalllink,igotloops logical :: igotallbowen,igotallcooling,igotalldust,igotallextern,igotallinject,igotallgrowth,igotallporosity logical :: igotallionise,igotallnonideal,igotalleos,igotallptmass,igotalldamping - logical :: igotallprad,igotalldustform,igotallgw,igotallgr,igotallbdy + logical :: igotallprad,igotalldustform,igotallgw,igotallgr,igotallbdy,igotallH2R integer, parameter :: nrequired = 1 ireaderr = 0 @@ -390,6 +393,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) igotallgw = .true. igotallgr = .true. igotallbdy = .true. + igotallH2R = .true. use_Voronoi_limits_file = .false. open(unit=ireadin,err=999,file=infile,status='old',form='formatted') @@ -569,6 +573,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) endif if (.not.imatch) call read_options_gravitationalwaves(name,valstring,imatch,igotallgw,ierr) if (.not.imatch) call read_options_boundary(name,valstring,imatch,igotallbdy,ierr) + if (.not.imatch) call read_options_H2R(name,valstring,imatch,igotallH2R,ierr) if (len_trim(name) /= 0 .and. .not.imatch) then call warn('read_infile','unknown variable '//trim(adjustl(name))// & ' in input file, value = '//trim(adjustl(valstring))) From feb9f7c4ad44ad1eb4df7f818a5c5b094c3bc52c Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 5 Jun 2024 17:06:00 +0200 Subject: [PATCH 593/814] (HIIregion) Patch and beginning of a test... --- build/Makefile | 2 +- src/main/H2regions.f90 | 113 +++++++++++++++++++------------------ src/main/checksetup.f90 | 4 ++ src/main/config.F90 | 2 +- src/main/eos.f90 | 8 +-- src/main/initial.F90 | 9 ++- src/main/part.F90 | 4 +- src/main/step_leapfrog.F90 | 8 ++- src/tests/test_ptmass.f90 | 79 ++++++++++++++++++++++++++ 9 files changed, 160 insertions(+), 69 deletions(-) diff --git a/build/Makefile b/build/Makefile index 646826dca..c1bbd787b 100644 --- a/build/Makefile +++ b/build/Makefile @@ -536,7 +536,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} ${SRCINJECT} \ utils_subgroup.f90 utils_kepler.f90 subgroup.f90\ - quitdump.f90 ptmass.F90 \ + quitdump.f90 ptmass.F90 H2regions.f90\ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ mf_write.f90 evolve.F90 utils_orbits.f90 utils_linalg.f90 \ diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index cec5835b8..82201ebab 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -19,7 +19,7 @@ module HIIRegion implicit none - public :: update_ionrate, HII_feedback,initialize_H2R + public :: update_ionrate, HII_feedback,initialize_H2R,read_options_H2R,write_options_H2R integer, public :: iH2R = 0 real , public :: Rmax = 15 ! Maximum HII region radius (pc) to avoid artificial expansion... @@ -36,13 +36,11 @@ module HIIRegion real, private :: ar real, private :: sigd real, private :: hv_on_c - real, private :: mu = 2.38 real, private :: mH real, private :: T_ion real, private :: u_to_t real, private :: Rst2_max real, private :: Rst_max - logical, private :: overlapping =.false. private @@ -57,7 +55,7 @@ subroutine initialize_H2R use io, only:iprint,iverbose use part, only:isionised use units, only:udist,umass,utime - use physcon, only:mass_proton_cgs,kboltz,pc,eV + use physcon, only:mass_proton_cgs,kboltz,pc,eV,solarm use eos , only:gmw isionised(:)=.false. !calculate the useful constant in code units @@ -89,12 +87,13 @@ subroutine update_ionrate(nptmass,xyzmh_ptmass) use part, only:irateion,ihacc use ptmass, only: h_acc integer, intent(in) :: nptmass - real, intent(inout) :: xyzmh_ptmass - real :: logmi,log_Q,mi,hi + real, intent(inout) :: xyzmh_ptmass(:,:) + real :: logmi,log_Q,mi,hi,Q integer :: i,n + n = 0 !$omp parallel do default(none) & - !$omp shared(xyzmh_ptmass,nptmass,iprint,iverbose)& - !$omp private(logmi,log_Q,mi,hi)& + !$omp shared(xyzmh_ptmass,nptmass,iprint,iverbose,utime,Mmin,h_acc)& + !$omp private(logmi,log_Q,Q,mi,hi)& !$omp reduction(+:n) do i=1,nptmass mi = xyzmh_ptmass(4,i) @@ -106,7 +105,8 @@ subroutine update_ionrate(nptmass,xyzmh_ptmass) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) - xyzmh_ptmass(irateion,i) = (10.**log_Q)*utime + Q = (10.**log_Q)*utime + xyzmh_ptmass(irateion,i) = Q n = n + 1 if (iverbose > 1) then write(iprint,"(/a,es18.10/)")"HII region detected : Log Q : ",log_Q @@ -115,7 +115,7 @@ subroutine update_ionrate(nptmass,xyzmh_ptmass) enddo !$omp end parallel do if (iverbose > 1) then - wirte(iprint,"(/a,i8/)") "nb_feedback sources : ",n + write(iprint,"(/a,i8/)") "nb_feedback sources : ",n endif return end subroutine update_ionrate @@ -126,24 +126,29 @@ end subroutine update_ionrate !+ !----------------------------------------------------------------------- -subroutine HII_feedback(dt,nptmass,npart,xyzh,xyzmh_ptmass,vxyzu) +subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) use part, only:rhoh,massoftype,ihsoft,igas,irateion,isdead_or_accreted,& - irstrom,ioverlap - use linklist, only:getneigh_pos,ifirstincell,listneigh=>listneigh_global - use utils_sort, only:indexxfunc,set_r2func_origin,r2func_origin - use units, only:unit_density,udist,umass + irstrom + use linklist, only:listneigh=>listneigh_global + use sortutils, only:indexxfunc,set_r2func_origin,r2func_origin use physcon, only:pc,pi use timing, only: get_timings - integer, intent(in) :: nptmass,npart - real, intent(in) :: dt - real, intent(in) :: xyzh(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyzu(:,:) - integer, parameter :: maxcache = 12000 - real, save :: xyzcache(maxcache,3) - integer :: i,k,j,npartin,nneigh + integer, intent(in) :: nptmass,npart + real, intent(in) :: xyzh(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyzu(:,:) + logical, intent(inout) :: isionised(:) + real, optional, intent(in) :: dt + integer :: i,k,j,npartin real(kind=4) :: t1,t2,tcpu1,tcpu2 - real :: pmass,Ndot,DNdot,R_stop,taud,mHII,r,hcheck - real :: dx,dy,dz,vkx,vky,vkz + real :: pmass,Ndot,DNdot,taud,mHII,r,r_in,hcheck,rsti_old + real :: xi,yi,zi,Qi,xj,yj,zj,dx,dy,dz,vkx,vky,vkz + logical :: momflag + + momflag = .false. + r = 0. + r_in = 0. + + if (present(dt)) momflag = .true. ! at each new kick we reset all the particles status isionised(:) = .false. @@ -203,43 +208,39 @@ subroutine HII_feedback(dt,nptmass,npart,xyzh,xyzmh_ptmass,vxyzu) ! !-- Momentum feedback ! - j = listneigh(1) - mHII = ((4.*pi*(R_stop**3-r**3)*rhoh(xyzh(4,j),pmass))/3) - if (mHII>3*pmass) then + if(momflag) then + j = listneigh(1) + r_in = ((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) + mHII = ((4.*pi*(r**3-r_in**3)*rhoh(xyzh(4,j),pmass))/3) + if (mHII>3*pmass) then !$omp parallel do default(none) & -!$omp shared(mHII,listneigh,xyzcache,xyzh,sigd,dt,Qi,hv_on_c) & +!$omp shared(mHII,listneigh,xyzh,sigd,dt) & +!$omp shared(mH,vxyzu,Qi,hv_on_c,npartin,pmass,xi,yi,zi) & !$omp private(j,dx,dy,dz,vkx,vky,vkz,xj,yj,zj,r,taud) - do k=1,npartin - j = listneigh(1) - if (k <= maxcache) then - xj = xyzcache(k,1) - yj = xyzcache(k,2) - zj = xyzcache(k,3) - else + do k=1,npartin + j = listneigh(1) xj = xyzh(1,j) yj = xyzh(2,j) zj = xyzh(3,j) - endif - dx = xi - xj - dy = yi - yj - dz = zi - zj - r = dx**2 + dy**2 + dz**2 - - taud = (rhoh(xyzh(4,j),pmass)/mH)*sigd*r - if (taud > 1.97) taud=1.97 - vkx = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dx/r) - vky = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dy/r) - vkz = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dz/r) - vxyzu(1,j) = vxyzu(1,j) + vkx*dt - vxyzu(2,j) = vxyzu(2,j) + vky*dt - vxyzu(3,j) = vxyzu(3,j) + vkz*dt - enddo + dx = xj - xi + dy = yj - yi + dz = zj - zi + r = dx**2 + dy**2 + dz**2 + taud = (rhoh(xyzh(4,j),pmass)/mH)*sigd*r + if (taud > 1.97) taud=1.97 + vkx = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dx/r) + vky = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dy/r) + vkz = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dz/r) + vxyzu(1,j) = vxyzu(1,j) + vkx*dt + vxyzu(2,j) = vxyzu(2,j) + vky*dt + vxyzu(3,j) = vxyzu(3,j) + vkz*dt + enddo !$omp end parallel do - enddo - endif -enddo -call get_timings(t2,tcpu2) -return + endif + endif + enddo + call get_timings(t2,tcpu2) + return end subroutine HII_feedback subroutine write_options_H2R(iunit) @@ -277,7 +278,7 @@ subroutine read_options_H2R(name,valstring,imatch,igotall,ierr) case default imatch = .true. end select - igotall = (ngotall >= 3) + igotall = (ngot >= 3) end subroutine read_options_H2R end module HIIRegion diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 5af6d6712..4a2510d87 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -437,6 +437,10 @@ subroutine check_setup(nerror,nwarn,restart) !--check Regularization imcompatibility ! call check_regnbody (nerror) +! +!--check HII region expansion feedback +! + call check_HIIRegion (nerror) if (.not.h2chemistry .and. maxvxyzu >= 4 .and. icooling == 3 .and. iexternalforce/=iext_corotate .and. nptmass==0) then if (dot_product(xcom,xcom) > 1.e-2) then diff --git a/src/main/config.F90 b/src/main/config.F90 index 5acb64234..3d9307782 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -42,7 +42,7 @@ module dim #else integer, parameter :: maxptmass = 1000 #endif - integer, parameter :: nsinkproperties = 19 + integer, parameter :: nsinkproperties = 21 ! storage of thermal energy or not #ifdef ISOTHERMAL diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 32e1849ab..995a318a9 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -120,10 +120,10 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam real, intent(in) :: rhoi,xi,yi,zi real, intent(out) :: ponrhoi,spsoundi real, intent(inout) :: tempi - real, intent(in), optional :: eni - real, intent(inout), optional :: mu_local,gamma_local - real, intent(in) , optional :: Xlocal,Zlocal - logical(kind=1), intent(in), optional :: isionised + real, intent(in), optional :: eni + real, intent(inout), optional :: mu_local,gamma_local + real, intent(in) , optional :: Xlocal,Zlocal + logical, intent(in), optional :: isionised integer :: ierr, i real :: r1,r2 real :: mass_r, mass ! defined for generalised Farris prescription diff --git a/src/main/initial.F90 b/src/main/initial.F90 index ed75b5ff3..e4728cba0 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -131,7 +131,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& nden_nimhd,dustevol,rhoh,gradh, & Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx, & - n_group,n_ingroup,n_sing,nmatrix,group_info + n_group,n_ingroup,n_sing,nmatrix,group_info,isionised use part, only:pxyzu,dens,metrics,rad,radprop,drad,ithick use densityforce, only:densityiterate use linklist, only:set_linklist @@ -213,7 +213,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use fileutils, only:make_tags_unique use damping, only:idamp use subgroup, only:group_identify - use HIIRegion, only:iH2R,initialize_H2R + use HIIRegion, only:iH2R,initialize_H2R,HII_feedback character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile logical, intent(in), optional :: noread @@ -499,7 +499,10 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass - if (iH2R > 0) call initialize_H2R() + if (iH2R > 0) then + call initialize_H2R + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) + endif ! compute initial sink-sink forces and get timestep if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) diff --git a/src/main/part.F90 b/src/main/part.F90 index 8831ecd5f..825bb703e 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -219,7 +219,7 @@ module part 'hsoft ','maccreted','spinx ','spiny ','spinz ',& 'tlast ','lum ','Teff ','Reff ','mdotloss ',& 'mdotav ','mprev ','massenc ','J2 ','Rstrom ',& - 'rate_ion'/) + 'rate_ion '/) character(len=*), parameter :: vxyz_ptmass_label(3) = (/'vx','vy','vz'/) ! !--self-gravity @@ -310,7 +310,7 @@ module part ! !-- Regularisation algorithm allocation ! - logical(kind=1), allocatable :: isionised(:) + logical, allocatable :: isionised(:) ! !--derivatives (only needed if derivs is called) ! diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index f130073f4..e02f6df18 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -98,7 +98,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) iamboundary,get_ntypes,npartoftypetot,& dustfrac,dustevol,ddustevol,eos_vars,alphaind,nptmass,& dustprop,ddustprop,dustproppred,pxyzu,dens,metrics,ics,& - filfac,filfacpred,mprev,filfacprev + filfac,filfacpred,mprev,filfacprev,isionised use options, only:avdecayconst,alpha,ieos,alphamax use deriv, only:derivs use timestep, only:dterr,bignumber,tolv @@ -126,7 +126,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate use substepping, only:substep,substep_gr, & - substep_sph_gr,substep_sph + substep_sph_gr,substep_sph + use HIIRegion, only:HII_feedback,iH2R integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -262,6 +263,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) timei = timei + dtsph nvfloorps = 0 + + if (iH2R > 0) call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dtsph) + !---------------------------------------------------- ! interpolation of SPH quantities needed in the SPH ! force evaluations, using dtsph diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 966a77727..7599a7262 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -1111,6 +1111,85 @@ subroutine test_merger(ntests,npass) end subroutine test_merger +subroutine test_HIIregion(ntests,npass) + use io, only:id,master,iverbose + use eos, only:gmw,ieos + use deriv, only:get_derivs_global + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fext & + npart,ihacc,irstrom,xyzh,vxyzu,hfact,igas, & + npartoftype,fxyzu,massoftype,isionised + use ptmass, only:h_acc + use step_lf_global, only:init_step,step + use timestep, only:dtmax + use energies, only:compute_energies,angtot,totmom,mtot + use spherical, only:set_sphere + use units, only:set_units,utime,unit_velocity + use physcon, only:pc,solarm,years + use HIIRegion, only:initialize_H2R,update_ionrate,HII_feedback + integer, intent(inout) :: ntests,npass + integer(kind=8) :: ncloud + real :: totmass,tmax,t,dt,dtext,dtnew,psep + real :: Rsp,Rspi,ci,k + if (id==master) write(*,"(/,a)") '--> testing HII region expansion around massive stars (coin)' + + call set_units(dist=pc,mass=solarm,G=1.d0) + + ! + ! initialise arrays to zero + ! + call init_part() + vxyzu(:,:) = 0. + fxyzu(:,:) = 0. + fext(:,:) = 0. + + gmw = 1.0 + ieos = 21 + + xyzmh_ptmass(:,:) = 0. + vxyz_ptmass(:,:) = 0. + + h_acc = 0.002 + + xyzmh_ptmass(4,1) = 40. + xyzmh_ptmass(5,1) = 1e-3*h_acc + nptmass = 1 + + ncloud = 1e6 + psep = 0.05 + call set_sphere('random',id,master,0.,2.91,psep,hfact,npartoftype(igas),xyzh,nptot=ncloud) + + totmass = 8.e3 + massoftype(igas) = totmass / npartoftype(igas) + npart = npartoftype(igas) + + + call initialize_H2R + call update_ionrate(nptmass,xyzmh_ptmass) + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) + + Rspi = 0.314 + ci = 12850./unit_velocity + k = 0.005 + Rsp = Rspi + + call get_derivs_global(dt_new=dt) + + tmax = (3.e6*years)/utime + t = 0. + dtmax = dt*100 + dtext = dt + + call init_step(npart,t,dtmax) + do while (t < tmax) + call step(npart,npart,t,dt,dtext,dtnew) + xyzmh_ptmass(1:3,1) = 0. + vxyz_ptmass(1:3,1) = 0. + Rsp = (ci*((Rspi/Rsp)**(3./4.) - k*(Rspi/Rsp)**(-3./4.)))*dt + print*,Rsp - xyzmh_ptmass(irstrom,1) + enddo + +end subroutine test_HIIregion + !----------------------------------------------------------------------- !+ ! Helper function used in sink particle creation test From 848a6044dcb3118ea232fcbf3628e734b1dc5baa Mon Sep 17 00:00:00 2001 From: Cristiano Longarini <81079965+crislong@users.noreply.github.com> Date: Thu, 6 Jun 2024 11:57:53 +1000 Subject: [PATCH 594/814] Update analysis_disc_stresses --- build/Makefile_setups | 3 +- src/utils/analysis_disc_stresses.f90 | 56 ++++++++++++++-------------- 2 files changed, 31 insertions(+), 28 deletions(-) diff --git a/build/Makefile_setups b/build/Makefile_setups index bcd038494..d5f34b9a5 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -923,10 +923,11 @@ ifeq ($(SETUP), isosgdisc) SETUPFILE= setup_disc.f90 GRAVITY=yes IND_TIMESTEPS=yes - ANALYSIS=analysis_dustydisc.f90 + #ANALYSIS=analysis_dustydisc.f90 ISOTHERMAL=yes KNOWN_SETUP=yes SRCINJECT= inject_keplerian.f90 + ANALYSIS = utils_getneighbours.F90 utils_omp.F90 analysis_disc_stresses.f90 endif ifeq ($(SETUP), dustyisosgdisc) diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index 006fa7d65..16d247cd4 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -103,43 +103,47 @@ end subroutine do_analysis !+ !------------------------------------------- subroutine read_analysis_options - - use prompting, only:prompt - - implicit none - + use prompting, only:prompt + use infile_utils, only:open_db_from_file,inopts,read_inopt,write_inopt,close_db + use io, only:fatal + type(inopts), allocatable :: db(:) + integer :: ierr,nerr logical :: inputexist character(len=21) :: inputfile + integer, parameter :: iunit = 10 ! Check for existence of input file - inputfile = 'disc_stresses.options' + inputfile = trim(analysistype)//'.options' inquire(file=inputfile, exist=inputexist) if (inputexist) then - + nerr = 0 print '(a,a,a)', "Parameter file ",inputfile, " found: reading analysis options" - - open(10,file=inputfile,form='formatted') - read(10,*) nbins - read(10,*) rin - read(10,*) rout - close(10) + call open_db_from_file(db,inputfile,iunit,ierr) + call read_inopt(nbins,'nbins',db,errcount=nerr) + call read_inopt(rin,'rin',db,errcount=nerr) + call read_inopt(rout,'rout',db,errcount=nerr) + call close_db(db) + if (nerr > 0) then + call fatal(trim(analysistype),'Error in reading '//trim(inputfile)) + endif else print '(a,a,a)', "Parameter file ",inputfile, " NOT found" - + nbins = 128; rin = 1.; rout = 100. call prompt('Enter the number of radial bins: ', nbins) call prompt('Enter the disc inner radius: ', rin) call prompt('Enter the disc outer radius: ', rout) ! Write choices to new inputfile - open(10,file=inputfile,status='new',form='formatted') - write(10,*) nbins, " Number of radial bins" - write(10,*) rin, " Inner Disc Radius" - write(10,*) rout, " Outer Disc Radius" - close(10) + open(unit=iunit,file=inputfile,status='new',form='formatted') + write(iunit,"(a)") '# parameter options for analysis of '//trim(analysistype) + call write_inopt(nbins,'nbins','Number of radial bins',iunit) + call write_inopt(rin,'rin','Inner Disc Radius',iunit) + call write_inopt(rout,'rout','Outer Disc Radius',iunit) + close(iunit) endif @@ -162,8 +166,6 @@ subroutine calc_gravitational_forces(dumpfile,npart,xyzh,vxyzu) use part, only:poten,igas,iphase,maxphase,rhoh,massoftype,iamgas use kernel, only: get_kernel,get_kernel_grav1,cnormk - implicit none - character(len=*),intent(in) :: dumpfile real,intent(in) :: xyzh(:,:),vxyzu(:,:) integer,intent(in) :: npart @@ -352,16 +354,15 @@ end subroutine transform_to_cylindrical subroutine radial_binning(npart,xyzh,vxyzu,pmass) use physcon, only:pi - use eos, only: gamma - - implicit none + use eos, only:get_spsound,ieos + use part, only:rhoh,isdead_or_accreted integer,intent(in) :: npart real,intent(in) :: pmass real,intent(in) :: xyzh(:,:),vxyzu(:,:) integer :: ibin,ipart,nbinned - real :: area + real :: area,csi print '(a,I4)', 'Carrying out radial binning, number of bins: ',nbins @@ -395,7 +396,7 @@ subroutine radial_binning(npart,xyzh,vxyzu,pmass) do ipart=1,npart ! i refers to particle, ii refers to bin - if (xyzh(4,ipart) > tiny(xyzh)) then ! IF ACTIVE + if (.not.isdead_or_accreted(xyzh(4,ipart))) then ! IF ACTIVE ibin = int((rpart(ipart)-rad(1))/dr + 1) @@ -410,7 +411,8 @@ 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)) + csi = get_spsound(ieos,xyzh(1:3,ipart),rhoh(xyzh(4,ipart),pmass),vxyzu(:,ipart)) + csbin(ibin) = csbin(ibin) + csi area = pi*((rad(ibin)+0.5*dr)**2-(rad(ibin)- 0.5*dr)**2) sigma(ibin) = sigma(ibin) + pmass/area From 8333f061cc1f62bc2ba1d0e4dc38392ba86088a1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 7 Jun 2024 09:30:34 +0200 Subject: [PATCH 595/814] (HIIregion) Tests seems successful, but needs to be parallel... --- src/main/H2regions.f90 | 163 ++++++++++++++++++------------------- src/main/checksetup.f90 | 10 ++- src/main/cons2prim.f90 | 2 +- src/main/deriv.F90 | 1 + src/main/eos.f90 | 4 +- src/main/evolve.F90 | 7 +- src/main/initial.F90 | 2 +- src/main/step_leapfrog.F90 | 5 +- src/tests/phantomtest.f90 | 2 +- src/tests/test_ptmass.f90 | 114 ++++++++++++++++++-------- 10 files changed, 180 insertions(+), 130 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 82201ebab..9a23f9187 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -24,14 +24,15 @@ module HIIRegion integer, public :: iH2R = 0 real , public :: Rmax = 15 ! Maximum HII region radius (pc) to avoid artificial expansion... real , public :: Mmin = 8 ! Minimum mass (Msun) to produce HII region + real , public :: nHIIsources = 0 real, private, parameter :: a = -39.3178 ! real, private, parameter :: b = 221.997 !fitted parameters to compute real, private, parameter :: c = -227.456 !ionisation rate for massive real, private, parameter :: d = 117.410 !extracted from Fujii et al. (2021). - real, private, parameter :: e = -30.1511 ! + real, private, parameter :: e = -30.1511 ! (Expressed in log(solar masses)) real, private, parameter :: f = 3.06810 ! - real, private, parameter :: ar_cgs = 2.6d-13 + real, private, parameter :: ar_cgs = 2.7d-13 real, private, parameter :: sigd_cgs = 1.d-21 real, private :: ar real, private :: sigd @@ -63,7 +64,7 @@ subroutine initialize_H2R u_to_t = (3./2)*(kboltz/mH)*(utime/udist)**2 mH = mH/umass T_ion = 1.d4 - ar = ar_cgs*utime/udist**3 + ar = ar_cgs*(utime/udist**3) sigd = sigd_cgs*udist**2 hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) Rst2_max = ((Rmax*pc)/udist)**2 @@ -89,8 +90,7 @@ subroutine update_ionrate(nptmass,xyzmh_ptmass) integer, intent(in) :: nptmass real, intent(inout) :: xyzmh_ptmass(:,:) real :: logmi,log_Q,mi,hi,Q - integer :: i,n - n = 0 + integer :: i !$omp parallel do default(none) & !$omp shared(xyzmh_ptmass,nptmass,iprint,iverbose,utime,Mmin,h_acc)& !$omp private(logmi,log_Q,Q,mi,hi)& @@ -98,19 +98,19 @@ subroutine update_ionrate(nptmass,xyzmh_ptmass) do i=1,nptmass mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) - if(mi > Mmin .or. hi > h_acc)then - xyzmh_ptmass(irateion,i) = -1. - else + if(mi > Mmin .and. hi < h_acc)then logmi = log10(mi) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) Q = (10.**log_Q)*utime xyzmh_ptmass(irateion,i) = Q - n = n + 1 + nHIIsources = nHIIsources + 1 if (iverbose > 1) then - write(iprint,"(/a,es18.10/)")"HII region detected : Log Q : ",log_Q + write(iprint,"(/a,es18.10/)")"Massive stars detected : Log Q : ",log_Q endif + else + xyzmh_ptmass(irateion,i) = -1. endif enddo !$omp end parallel do @@ -133,6 +133,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) use sortutils, only:indexxfunc,set_r2func_origin,r2func_origin use physcon, only:pc,pi use timing, only: get_timings + use units, only: unit_density integer, intent(in) :: nptmass,npart real, intent(in) :: xyzh(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyzu(:,:) @@ -140,7 +141,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) real, optional, intent(in) :: dt integer :: i,k,j,npartin real(kind=4) :: t1,t2,tcpu1,tcpu2 - real :: pmass,Ndot,DNdot,taud,mHII,r,r_in,hcheck,rsti_old + real :: pmass,Ndot,DNdot,taud,mHII,r,r_in real :: xi,yi,zi,Qi,xj,yj,zj,dx,dy,dz,vkx,vky,vkz logical :: momflag @@ -157,89 +158,83 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) !-- Rst derivation and thermal feedback ! call get_timings(t1,tcpu1) - do i=1,nptmass - npartin=0 - Qi = xyzmh_ptmass(irateion,i) - if (Qi <=0.) cycle - Ndot = Qi - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) - rsti_old = xyzmh_ptmass(irstrom,i) - if (rsti_old > 0.) then - hcheck = Rst_max - elseif (rsti_old > 0.8*Rst_max) then - hcheck = Rst_max - else - hcheck = rsti_old*1.3 - endif - ! for each source we compute the distances of each particles and sort to have a Knn list - ! Patch : We need to be aware of dead particles that will pollute the scheme if not taking into account. - ! The simpliest way is to put enormous distance for dead particle to be at the very end of the knn list. - call set_r2func_origin(xi,yi,zi) - call indexxfunc(npart,r2func_origin,xyzh,listneigh) - do k=1,npart - j = listneigh(k) - if (.not. isdead_or_accreted(xyzh(4,j))) then - ! calculation of the ionised mass - DNdot = (pmass*ar*rhoh(xyzh(4,j),pmass))/(mH**2) - if (Ndot>DNdot) then - ! iteration on the Knn until we used all the source photons - if (.not.(isionised(j))) then - Ndot = Ndot - DNdot - vxyzu(4,j) = u_to_t*T_ion - isionised(j)=.true. - endif - else - vxyzu(4,j) = (Ndot/DNdot)*u_to_t*T_ion - if (k > 1) then - ! end of the HII region - r = ((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) + if (nHIIsources > 0) then + do i=1,nptmass + npartin=0 + Qi = xyzmh_ptmass(irateion,i) + if (Qi <=0.) cycle + Ndot = Qi + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + ! for each source we compute the distances of each particles and sort to have a Knn list + ! Patch : We need to be aware of dead particles that will pollute the scheme if not taking into account. + ! The simpliest way is to put enormous distance for dead particle to be at the very end of the knn list. + call set_r2func_origin(xi,yi,zi) + call indexxfunc(npart,r2func_origin,xyzh,listneigh) + do k=1,npart + j = listneigh(k) + if (.not. isdead_or_accreted(xyzh(4,j))) then + ! calculation of the ionised mass + DNdot = (pmass*ar*rhoh(xyzh(4,j),pmass))/(mH**2) + if (Ndot>DNdot) then + ! iteration on the Knn until we used all the source photons + if (.not.(isionised(j))) then + Ndot = Ndot - DNdot + isionised(j)=.true. + endif else - ! unresolved case - r = 0. + if (k > 1) then + ! end of the HII region + r = sqrt((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) + j = listneigh(1) + else + ! unresolved case + r = 0. + endif + exit endif - exit endif - endif - enddo - npartin = k - xyzmh_ptmass(irstrom,i) = r - ! - !-- Momentum feedback - ! - if(momflag) then - j = listneigh(1) - r_in = ((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) - mHII = ((4.*pi*(r**3-r_in**3)*rhoh(xyzh(4,j),pmass))/3) - if (mHII>3*pmass) then + enddo + npartin = k + xyzmh_ptmass(irstrom,i) = r + ! + !-- Momentum feedback + ! + if(momflag) then + j = listneigh(1) + r_in = sqrt((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) + mHII = ((4.*pi*(r**3-r_in**3)*rhoh(xyzh(4,j),pmass))/3) + if (mHII>3*pmass) then !$omp parallel do default(none) & !$omp shared(mHII,listneigh,xyzh,sigd,dt) & !$omp shared(mH,vxyzu,Qi,hv_on_c,npartin,pmass,xi,yi,zi) & !$omp private(j,dx,dy,dz,vkx,vky,vkz,xj,yj,zj,r,taud) - do k=1,npartin - j = listneigh(1) - xj = xyzh(1,j) - yj = xyzh(2,j) - zj = xyzh(3,j) - dx = xj - xi - dy = yj - yi - dz = zj - zi - r = dx**2 + dy**2 + dz**2 - taud = (rhoh(xyzh(4,j),pmass)/mH)*sigd*r - if (taud > 1.97) taud=1.97 - vkx = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dx/r) - vky = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dy/r) - vkz = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dz/r) - vxyzu(1,j) = vxyzu(1,j) + vkx*dt - vxyzu(2,j) = vxyzu(2,j) + vky*dt - vxyzu(3,j) = vxyzu(3,j) + vkz*dt - enddo + do k=1,npartin + j = listneigh(1) + xj = xyzh(1,j) + yj = xyzh(2,j) + zj = xyzh(3,j) + dx = xj - xi + dy = yj - yi + dz = zj - zi + r = dx**2 + dy**2 + dz**2 + taud = (rhoh(xyzh(4,j),pmass)/mH)*sigd*r + if (taud > 1.97) taud=1.97 + vkx = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dx/r) + vky = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dy/r) + vkz = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dz/r) + vxyzu(1,j) = vxyzu(1,j) + vkx*dt + vxyzu(2,j) = vxyzu(2,j) + vky*dt + vxyzu(3,j) = vxyzu(3,j) + vkz*dt + enddo !$omp end parallel do + endif endif - endif - enddo + enddo + endif call get_timings(t2,tcpu2) + return end subroutine HII_feedback diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 4a2510d87..ccaad8eda 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -1052,16 +1052,20 @@ end subroutine check_regnbody subroutine check_HIIRegion(nerror) use HIIRegion, only:iH2R use eos, only:ieos - use dim, only:gr + use dim, only:gr,mpi integer, intent(inout) :: nerror - if(iH2R>0 .and. ieos/=21) then + if(iH2R > 0 .and. ieos/=21) then print "(/,a,/)", "Error: If HII activated, eos == 21 is mandatory..." nerror = nerror + 1 endif - if(iH2R>0 .and. gr) then + if(iH2R > 0 .and. gr) then print "(/,a,/)", "Error: Gr is not compatible with HII Region" nerror = nerror + 1 endif + if(iH2R > 0 .and. mpi) then + print "(/,a,/)", "Error: MPI is not compatible with HII Region" + nerror = nerror + 1 + endif end subroutine check_HIIRegion diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 0a2f8cbc7..3c05a5213 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -215,7 +215,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& !$omp parallel do default (none) & !$omp shared(xyzh,vxyzu,npart,rad,eos_vars,radprop,Bevol,Bxyz) & !$omp shared(ieos,nucleation,nden_nimhd,eta_nimhd) & -!$omp shared(alpha,alphamax,iphase,maxphase,maxp,massoftype) & +!$omp shared(alpha,alphamax,iphase,maxphase,maxp,massoftype,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) & diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index 4bbab4bdf..d11d5ae4b 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -122,6 +122,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& call do_timing('link',tlast,tcpulast,start=.true.) + ! ! compute disruption of dust particles ! diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 995a318a9..779314263 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -435,9 +435,9 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam ! where :math:`c_s^2 \equiv K` is a constant stored in the dump file header ! if(isionised) then - ponrhoi = polyk + ponrhoi = (12850000./unit_velocity)**2 spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi + tempi = temperature_coef*0.5*ponrhoi else ponrhoi = polyk spsoundi = sqrt(ponrhoi) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 92c22f776..623eb6315 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -89,13 +89,15 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) #endif 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, & + isionised use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & set_integration_precision use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries + use HIIRegion, only:HII_feedback,iH2R #ifdef MFLOW use mf_write, only:mflow_write #endif @@ -284,6 +286,9 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (do_radiation .and. exchange_radiation_energy .and. .not.implicit_radiation) then call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) endif + + if (iH2R > 0 .and. id==master) call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) + nsteps = nsteps + 1 ! !--evolve data for one timestep diff --git a/src/main/initial.F90 b/src/main/initial.F90 index e4728cba0..b83036b97 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -499,7 +499,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass - if (iH2R > 0) then + if (iH2R > 0 .and. id==master) then call initialize_H2R call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) endif diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index e02f6df18..6fa4e575a 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -98,7 +98,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) iamboundary,get_ntypes,npartoftypetot,& dustfrac,dustevol,ddustevol,eos_vars,alphaind,nptmass,& dustprop,ddustprop,dustproppred,pxyzu,dens,metrics,ics,& - filfac,filfacpred,mprev,filfacprev,isionised + filfac,filfacpred,mprev,filfacprev use options, only:avdecayconst,alpha,ieos,alphamax use deriv, only:derivs use timestep, only:dterr,bignumber,tolv @@ -127,7 +127,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use eos, only:equationofstate use substepping, only:substep,substep_gr, & substep_sph_gr,substep_sph - use HIIRegion, only:HII_feedback,iH2R integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -264,7 +263,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) timei = timei + dtsph nvfloorps = 0 - if (iH2R > 0) call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dtsph) + !---------------------------------------------------- ! interpolation of SPH quantities needed in the SPH diff --git a/src/tests/phantomtest.f90 b/src/tests/phantomtest.f90 index dd310aa6f..e3a942874 100644 --- a/src/tests/phantomtest.f90 +++ b/src/tests/phantomtest.f90 @@ -24,7 +24,7 @@ program phantomtest implicit none integer :: nargs,i,ntests,npass,nfail character(len=120) :: string - integer(kind=8), parameter :: maxp_test = 1000000 + integer(kind=8), parameter :: maxp_test = 10000000 ntests = 0 npass = 0 diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 7599a7262..44f2ed6df 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -40,7 +40,7 @@ subroutine test_ptmass(ntests,npass,string) integer, intent(inout) :: ntests,npass integer :: itmp,ierr,itest,istart logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening - logical :: do_test_chinese_coin,do_test_merger + logical :: do_test_chinese_coin,do_test_merger,do_test_HII logical :: testall if (id==master) write(*,"(/,a,/)") '--> TESTING PTMASS MODULE' @@ -51,6 +51,7 @@ subroutine test_ptmass(ntests,npass,string) do_test_softening = .false. do_test_merger = .false. do_test_chinese_coin = .false. + do_test_HII = .false. testall = .false. istart = 1 select case(trim(string)) @@ -71,6 +72,9 @@ subroutine test_ptmass(ntests,npass,string) do_test_binary = .true. do_test_softening = .true. do_test_merger = .true. + case('ptmassHII') + do_test_HII = .true. + case default testall = .true. end select @@ -123,6 +127,8 @@ subroutine test_ptmass(ntests,npass,string) ! if (do_test_createsink .or. testall) call test_createsink(ntests,npass) + if (do_test_HII) call test_HIIregion(ntests,npass) + !reset stuff and clean up temporary files itmp = 201 nptmass = 0 @@ -1112,80 +1118,120 @@ subroutine test_merger(ntests,npass) end subroutine test_merger subroutine test_HIIregion(ntests,npass) - use io, only:id,master,iverbose - use eos, only:gmw,ieos + use dim, only:maxp,maxphase + use io, only:id,master,iverbose,iprint + use eos, only:gmw,ieos,polyk,gamma use deriv, only:get_derivs_global - use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fext & + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fext, & npart,ihacc,irstrom,xyzh,vxyzu,hfact,igas, & - npartoftype,fxyzu,massoftype,isionised + npartoftype,fxyzu,massoftype,isionised,init_part,& + iphase,isetphase,irateion use ptmass, only:h_acc use step_lf_global, only:init_step,step use timestep, only:dtmax use energies, only:compute_energies,angtot,totmom,mtot use spherical, only:set_sphere - use units, only:set_units,utime,unit_velocity - use physcon, only:pc,solarm,years - use HIIRegion, only:initialize_H2R,update_ionrate,HII_feedback + use units, only:set_units,utime,unit_velocity,udist + use physcon, only:pc,solarm,years,pi,kboltz,mass_proton_cgs + use kernel, only: hfact_default + use kdtree, only:tree_accuracy + use HIIRegion, only:initialize_H2R,update_ionrate,HII_feedback,iH2R,nHIIsources integer, intent(inout) :: ntests,npass - integer(kind=8) :: ncloud + integer :: np,i real :: totmass,tmax,t,dt,dtext,dtnew,psep real :: Rsp,Rspi,ci,k - if (id==master) write(*,"(/,a)") '--> testing HII region expansion around massive stars (coin)' - - call set_units(dist=pc,mass=solarm,G=1.d0) + real :: totvol,nx,rmin,rmax,temp + if (id==master) write(*,"(/,a)") '--> testing HII region expansion around massive stars...' + call set_units(dist=1.*pc,mass=1.*solarm,G=1.d0) + iverbose = 1 ! ! initialise arrays to zero ! call init_part() - vxyzu(:,:) = 0. - fxyzu(:,:) = 0. - fext(:,:) = 0. - gmw = 1.0 - ieos = 21 + ieos = 1 xyzmh_ptmass(:,:) = 0. vxyz_ptmass(:,:) = 0. h_acc = 0.002 - xyzmh_ptmass(4,1) = 40. + xyzmh_ptmass(4,1) = -1 xyzmh_ptmass(5,1) = 1e-3*h_acc + xyzmh_ptmass(irateion,1) = (10.**49.)*utime nptmass = 1 + nHIIsources = 1 - ncloud = 1e6 - psep = 0.05 - call set_sphere('random',id,master,0.,2.91,psep,hfact,npartoftype(igas),xyzh,nptot=ncloud) + t = 0. + hfact = 1.2 + gamma = 1. + rmin = 0. + rmax = 2.91 + ieos = 21 + tree_accuracy = 0.5 + temp = 1000 +! +!--setup particles +! + np = 1000000 + totvol = 4./3.*pi*rmax**3 + nx = int(np**(1./3.)) + psep = totvol**(1./3.)/real(nx) + npart = 0 + ! only set up particles on master, otherwise we will end up with n duplicates + if (id==master) then + call set_sphere('cubic',id,master,rmin,rmax,psep,hfact,npart,xyzh,np_requested=np) + endif + np = npart - totmass = 8.e3 - massoftype(igas) = totmass / npartoftype(igas) - npart = npartoftype(igas) +! +!--set particle properties +! + totmass = 8.e3 + npartoftype(:) = 0 + npartoftype(igas) = npart + massoftype(:) = 0.0 + massoftype(igas) = totmass/npartoftype(igas) + if (maxphase==maxp) then + do i=1,npart + iphase(i) = isetphase(igas,iactive=.true.) + enddo + endif - call initialize_H2R - call update_ionrate(nptmass,xyzmh_ptmass) - call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) - Rspi = 0.314 - ci = 12850./unit_velocity + iH2R = 1 + if (id==master) then + call initialize_H2R + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) + endif + + Rspi = xyzmh_ptmass(irstrom,1) + ci = 12850000./unit_velocity k = 0.005 Rsp = Rspi - call get_derivs_global(dt_new=dt) + polyk = kboltz*temp/(gmw*mass_proton_cgs)*((utime/udist)**2) + vxyzu(:,:) = 0. + fxyzu(:,:) = 0. + call get_derivs_global() + tmax = (3.e6*years)/utime t = 0. + dt = 0.000001 dtmax = dt*100 dtext = dt + dtnew = dt call init_step(npart,t,dtmax) do while (t < tmax) + t = t + dt + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) call step(npart,npart,t,dt,dtext,dtnew) - xyzmh_ptmass(1:3,1) = 0. - vxyz_ptmass(1:3,1) = 0. - Rsp = (ci*((Rspi/Rsp)**(3./4.) - k*(Rspi/Rsp)**(-3./4.)))*dt - print*,Rsp - xyzmh_ptmass(irstrom,1) + Rsp = Rsp + (ci*((Rspi/Rsp)**(3./4.) - k*(Rspi/Rsp)**(-3./4.)))*dt + print*,"R stromgren (analytic,prescription)",Rsp , xyzmh_ptmass(irstrom,1) enddo end subroutine test_HIIregion From 0749b9c99d589324eaafb88815341e5700930992 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 7 Jun 2024 09:45:08 +0200 Subject: [PATCH 596/814] (HIIRegion) quick fix --- src/main/H2regions.f90 | 2 +- src/tests/phantomtest.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 9a23f9187..1ea91bb1e 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -115,7 +115,7 @@ subroutine update_ionrate(nptmass,xyzmh_ptmass) enddo !$omp end parallel do if (iverbose > 1) then - write(iprint,"(/a,i8/)") "nb_feedback sources : ",n + write(iprint,"(/a,i8/)") "nb_feedback sources : ",nHIIsources endif return end subroutine update_ionrate diff --git a/src/tests/phantomtest.f90 b/src/tests/phantomtest.f90 index e3a942874..dd310aa6f 100644 --- a/src/tests/phantomtest.f90 +++ b/src/tests/phantomtest.f90 @@ -24,7 +24,7 @@ program phantomtest implicit none integer :: nargs,i,ntests,npass,nfail character(len=120) :: string - integer(kind=8), parameter :: maxp_test = 10000000 + integer(kind=8), parameter :: maxp_test = 1000000 ntests = 0 npass = 0 From 0dd7a62f0d94b3245f98269b781b72cd7a4c0622 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 7 Jun 2024 20:39:12 +0200 Subject: [PATCH 597/814] (HIIRegion) Knn optimiztaiton and few tweaks in the test --- src/main/H2regions.f90 | 30 +++++++---- src/main/utils_sort.f90 | 102 +++++++++++++++++++++++++++++++++++++- src/tests/test_ptmass.f90 | 19 ++++--- 3 files changed, 133 insertions(+), 18 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 1ea91bb1e..7a56ed5f9 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -91,10 +91,11 @@ subroutine update_ionrate(nptmass,xyzmh_ptmass) real, intent(inout) :: xyzmh_ptmass(:,:) real :: logmi,log_Q,mi,hi,Q integer :: i + nHIIsources = 0 !$omp parallel do default(none) & !$omp shared(xyzmh_ptmass,nptmass,iprint,iverbose,utime,Mmin,h_acc)& !$omp private(logmi,log_Q,Q,mi,hi)& - !$omp reduction(+:n) + !$omp reduction(+:nHIIsources) do i=1,nptmass mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) @@ -129,20 +130,21 @@ end subroutine update_ionrate subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) use part, only:rhoh,massoftype,ihsoft,igas,irateion,isdead_or_accreted,& irstrom - use linklist, only:listneigh=>listneigh_global - use sortutils, only:indexxfunc,set_r2func_origin,r2func_origin + use linklist, only:listneigh=>listneigh_global,getneigh_pos,ifirstincell + use sortutils, only:Knnfunc,set_r2func_origin,r2func_origin use physcon, only:pc,pi use timing, only: get_timings - use units, only: unit_density integer, intent(in) :: nptmass,npart real, intent(in) :: xyzh(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyzu(:,:) logical, intent(inout) :: isionised(:) real, optional, intent(in) :: dt - integer :: i,k,j,npartin + integer, parameter :: maxcache = 12000 + real, save :: xyzcache(maxcache,3) + integer :: i,k,j,npartin,nneigh real(kind=4) :: t1,t2,tcpu1,tcpu2 - real :: pmass,Ndot,DNdot,taud,mHII,r,r_in - real :: xi,yi,zi,Qi,xj,yj,zj,dx,dy,dz,vkx,vky,vkz + real :: pmass,Ndot,DNdot,taud,mHII,r,r_in,hcheck + real :: xi,yi,zi,Qi,stromi,xj,yj,zj,dx,dy,dz,vkx,vky,vkz logical :: momflag momflag = .false. @@ -157,7 +159,6 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) ! !-- Rst derivation and thermal feedback ! - call get_timings(t1,tcpu1) if (nHIIsources > 0) then do i=1,nptmass npartin=0 @@ -167,11 +168,20 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) + stromi = xyzmh_ptmass(irstrom,i) ! for each source we compute the distances of each particles and sort to have a Knn list ! Patch : We need to be aware of dead particles that will pollute the scheme if not taking into account. ! The simpliest way is to put enormous distance for dead particle to be at the very end of the knn list. + if(stromi > 0 ) then + hcheck = 2.*stromi + if (hcheck > Rmax) hcheck = Rmax + else + hcheck = Rmax + endif + call get_timings(t1,tcpu1) + call getneigh_pos((/xi,yi,zi/),0.,hcheck,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) call set_r2func_origin(xi,yi,zi) - call indexxfunc(npart,r2func_origin,xyzh,listneigh) + call Knnfunc(nneigh,r2func_origin,xyzh,listneigh) do k=1,npart j = listneigh(k) if (.not. isdead_or_accreted(xyzh(4,j))) then @@ -234,7 +244,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) enddo endif call get_timings(t2,tcpu2) - + print*, "HII feedback CPU time : ",t2-t1 return end subroutine HII_feedback diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index 97031f2d2..432f98fe8 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -17,7 +17,7 @@ module sortutils ! :Dependencies: None ! implicit none - public :: indexx,indexxfunc,find_rank,r2func,r2func_origin,set_r2func_origin + public :: indexx,indexxfunc,Knnfunc,find_rank,r2func,r2func_origin,set_r2func_origin interface indexx module procedure indexx_r4, indexx_i8 end interface indexx @@ -352,6 +352,106 @@ subroutine indexxfunc(n, func, xyzh, indx) end subroutine indexxfunc + +!---------------------------------------------------------------- +!+ +! customised low-memory sorting routine using Quicksort +! sort key value on-the-fly by calling the function func +! which can be any function of the particle positions. +! (Tweaked version of the original one to sort a list of +! neighbours founded using the KD tree) +!+ +!---------------------------------------------------------------- +subroutine Knnfunc(n, func, xyzh, indx) + integer, parameter :: m=7, nstack=500 + integer, intent(in) :: n + real, external :: func + real, intent(in) :: xyzh(:,:) + integer, intent(out) :: indx(n) + + integer :: i,j,k,l,ir,jstack,indxt,itemp + integer :: istack(nstack) + real :: a + + jstack = 0 + l = 1 + ir = n + +1 if (ir - l < m) then + do j = l + 1, ir + indxt = indx(j) + a = func(xyzh(:,indxt)) + do i = j - 1, 1, -1 + if (func(xyzh(:,indx(i))) <= a) goto 2 + indx(i + 1) = indx(i) + enddo + i = 0 +2 indx(i + 1) = indxt + enddo + if (jstack==0) return + ir = istack(jstack) + l = istack(jstack - 1) + jstack = jstack - 2 + else + k = (l + ir)/2 + itemp = indx(k) + indx(k) = indx(l + 1) + indx(l + 1) = itemp + if (func(xyzh(:,indx(l+1))) > func(xyzh(:,indx(ir)))) then + itemp = indx(l + 1) + indx(l + 1) = indx(ir) + indx(ir) = itemp + endif + if (func(xyzh(:,indx(l))) > func(xyzh(:,indx(ir)))) then + itemp = indx(l) + indx(l) = indx(ir) + indx(ir) = itemp + endif + if (func(xyzh(:,indx(l+1))) > func(xyzh(:,indx(l)))) then + itemp = indx(l + 1) + indx(l + 1) = indx(l) + indx(l) = itemp + endif + i = l + 1 + j = ir + indxt = indx(l) + a = func(xyzh(:,indxt)) + +3 continue + i = i + 1 + if (func(xyzh(:,indx(i))) < a) goto 3 +4 continue + j = j - 1 + if (func(xyzh(:,indx(j))) > a) goto 4 + if (j < i) goto 5 + itemp = indx(i) + indx(i) = indx(j) + indx(j) = itemp + goto 3 + +5 indx(l) = indx(j) + indx(j) = indxt + jstack = jstack + 2 + if (jstack > nstack) then + print*,'fatal error!!! stacksize exceeded in sort' + print*,'need to set parameter nstack higher in subroutine indexxfunc ' + stop + endif + if (ir - i + 1 >= j - l) then + istack(jstack) = ir + istack(jstack - 1) = i + ir = j - 1 + else + istack(jstack) = j - 1 + istack(jstack - 1) = l + l = i + endif + endif + + goto 1 +end subroutine Knnfunc + + !---------------------------------------------------------------- !+ ! Same as indexxfunc, except two particles can have the same diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 44f2ed6df..f646abf4d 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -1134,13 +1134,15 @@ subroutine test_HIIregion(ntests,npass) use units, only:set_units,utime,unit_velocity,udist use physcon, only:pc,solarm,years,pi,kboltz,mass_proton_cgs use kernel, only: hfact_default - use kdtree, only:tree_accuracy + use kdtree, only:tree_accuracy use HIIRegion, only:initialize_H2R,update_ionrate,HII_feedback,iH2R,nHIIsources + use timing, only:get_timings integer, intent(inout) :: ntests,npass - integer :: np,i - real :: totmass,tmax,t,dt,dtext,dtnew,psep - real :: Rsp,Rspi,ci,k - real :: totvol,nx,rmin,rmax,temp + integer :: np,i + real :: totmass,tmax,t,dt,dtext,dtnew,psep + real :: Rsp,Rspi,ci,k + real :: totvol,nx,rmin,rmax,temp + real(kind=4) :: t1,t2,tcpu1,tcpu2 if (id==master) write(*,"(/,a)") '--> testing HII region expansion around massive stars...' call set_units(dist=1.*pc,mass=1.*solarm,G=1.d0) @@ -1204,10 +1206,10 @@ subroutine test_HIIregion(ntests,npass) iH2R = 1 if (id==master) then call initialize_H2R - call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) + !call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) endif - Rspi = xyzmh_ptmass(irstrom,1) + Rspi = 0.310 !xyzmh_ptmass(irstrom,1) ci = 12850000./unit_velocity k = 0.005 Rsp = Rspi @@ -1229,7 +1231,10 @@ subroutine test_HIIregion(ntests,npass) do while (t < tmax) t = t + dt call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) + call get_timings(t1,tcpu1) call step(npart,npart,t,dt,dtext,dtnew) + call get_timings(t2,tcpu2) + print*, "STEP CPU time : ",t2-t1 Rsp = Rsp + (ci*((Rspi/Rsp)**(3./4.) - k*(Rspi/Rsp)**(-3./4.)))*dt print*,"R stromgren (analytic,prescription)",Rsp , xyzmh_ptmass(irstrom,1) enddo From d13ff9411b2333a1bbcbd56824ec02c945e2ee5f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 10 Jun 2024 10:16:31 +0200 Subject: [PATCH 598/814] (HIIRegion) new update ionrate --- src/main/H2regions.f90 | 47 +++++++++++++++++++++++++++++++++++------- 1 file changed, 39 insertions(+), 8 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 7a56ed5f9..03c4d3f24 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -11,7 +11,7 @@ module HIIRegion ! ! ! contains routine for Stromgren radius calculation and Radiative pressure velocity kick - ! routine originally made by Fujii et al 2021 + ! routine originally made by Hopkins et al. (2012) Fujii et al. (2021) ! adapted in Phantom by Yann BERNARD ! reference : Fujii et al. 2021 SIRIUS Project Paper III ! @@ -19,7 +19,7 @@ module HIIRegion implicit none - public :: update_ionrate, HII_feedback,initialize_H2R,read_options_H2R,write_options_H2R + public :: update_ionrates,update_ionrate, HII_feedback,initialize_H2R,read_options_H2R,write_options_H2R integer, public :: iH2R = 0 real , public :: Rmax = 15 ! Maximum HII region radius (pc) to avoid artificial expansion... @@ -27,10 +27,10 @@ module HIIRegion real , public :: nHIIsources = 0 real, private, parameter :: a = -39.3178 ! - real, private, parameter :: b = 221.997 !fitted parameters to compute - real, private, parameter :: c = -227.456 !ionisation rate for massive - real, private, parameter :: d = 117.410 !extracted from Fujii et al. (2021). - real, private, parameter :: e = -30.1511 ! (Expressed in log(solar masses)) + real, private, parameter :: b = 221.997 ! fitted parameters to compute + real, private, parameter :: c = -227.456 ! ionisation rate for massive + real, private, parameter :: d = 117.410 ! extracted from Fujii et al. (2021). + real, private, parameter :: e = -30.1511 ! (Expressed in function of log(solar masses) and s) real, private, parameter :: f = 3.06810 ! real, private, parameter :: ar_cgs = 2.7d-13 real, private, parameter :: sigd_cgs = 1.d-21 @@ -78,11 +78,11 @@ end subroutine initialize_H2R !----------------------------------------------------------------------- !+ -! Calculation of the the ionizing photon rate +! Calculation of the the ionizing photon rate of all stars (Only for restart) !+ !----------------------------------------------------------------------- -subroutine update_ionrate(nptmass,xyzmh_ptmass) +subroutine update_ionrates(nptmass,xyzmh_ptmass) use io, only:iprint,iverbose use units, only:utime use part, only:irateion,ihacc @@ -115,6 +115,37 @@ subroutine update_ionrate(nptmass,xyzmh_ptmass) endif enddo !$omp end parallel do + if (iverbose > 1) then + write(iprint,"(/a,i8/)") "nb_feedback sources : ",nHIIsources + endif + return +end subroutine update_ionrates + +subroutine update_ionrate(i,nptmass,xyzmh_ptmass) + use io, only:iprint,iverbose + use units, only:utime + use part, only:irateion,ihacc + use ptmass, only: h_acc + integer, intent(in) :: nptmass,i + real, intent(inout) :: xyzmh_ptmass(:,:) + real :: logmi,log_Q,mi,hi,Q + mi = xyzmh_ptmass(4,i) + hi = xyzmh_ptmass(ihacc,i) + if(mi > Mmin .and. hi < h_acc)then + logmi = log10(mi) + ! caluclation of the ionizing photon rate of each sources + ! this calculation uses Fujii's formula derived from OSTAR2002 databases + log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) + Q = (10.**log_Q)*utime + xyzmh_ptmass(irateion,i) = Q + nHIIsources = nHIIsources + 1 + if (iverbose > 1) then + write(iprint,"(/a,es18.10/)")"(HII region) Massive stars detected : Log Q : ",log_Q + endif + else + xyzmh_ptmass(irateion,i) = -1. + endif + if (iverbose > 1) then write(iprint,"(/a,i8/)") "nb_feedback sources : ",nHIIsources endif From d7d25174b2db8193c0e36bfe9886dbe2a87b3653 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 10 Jun 2024 10:59:18 +0200 Subject: [PATCH 599/814] (ptmass) now update ionrate when creating star --- src/main/H2regions.f90 | 4 ++-- src/main/ptmass.F90 | 15 ++++++++------- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 03c4d3f24..958d32807 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -121,12 +121,12 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass) return end subroutine update_ionrates -subroutine update_ionrate(i,nptmass,xyzmh_ptmass) +subroutine update_ionrate(i,xyzmh_ptmass) use io, only:iprint,iverbose use units, only:utime use part, only:irateion,ihacc use ptmass, only: h_acc - integer, intent(in) :: nptmass,i + integer, intent(in) :: i real, intent(inout) :: xyzmh_ptmass(:,:) real :: logmi,log_Q,mi,hi,Q mi = xyzmh_ptmass(4,i) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index d65e9238c..2e1deefa8 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1608,12 +1608,13 @@ subroutine ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) end subroutine ptmass_create_seeds subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) - use physcon, only:solarm,pi - use eos, only:polyk - use io, only:iprint - use units, only:umass - use part, only:itbirth,ihacc - use random , only:ran2,gauss_random,divide_unit_seg + use physcon, only:solarm,pi + use eos, only:polyk + use io, only:iprint + use units, only:umass + use part, only:itbirth,ihacc + use random , only:ran2,gauss_random,divide_unit_seg + use HIIRegion, only:update_ionrate integer, intent(in) :: nptmass integer, intent(in) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) @@ -1671,9 +1672,9 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, enddo deallocate(masses) endif + call update_ionrate(k,xyzmh_ptmass) enddo - end subroutine ptmass_create_stars !----------------------------------------------------------------------- From 80bcc1a86773be3daa59493036d3bd857fb55037 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 10 Jun 2024 11:45:42 +0200 Subject: [PATCH 600/814] (setup_cluster) add embedded cluster type --- src/main/initial.F90 | 10 ++++---- src/setup/setup_cluster.f90 | 46 +++++++++++++++++++++++++++++-------- 2 files changed, 42 insertions(+), 14 deletions(-) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index b83036b97..1de2e0599 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -213,7 +213,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use fileutils, only:make_tags_unique use damping, only:idamp use subgroup, only:group_identify - use HIIRegion, only:iH2R,initialize_H2R,HII_feedback + use HIIRegion, only:iH2R,initialize_H2R,update_ionrates character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile logical, intent(in), optional :: noread @@ -497,12 +497,12 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) else rhofinal1 = 0.0 endif + if (iH2R > 0 .and. id==master) then + call initialize_H2R + endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass - if (iH2R > 0 .and. id==master) then - call initialize_H2R - call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) - endif + call update_ionrates(nptmass,xyzmh_ptmass) ! compute initial sink-sink forces and get timestep if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 35481b839..ff49eebf1 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -55,11 +55,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use setvfield, only:normalise_vfield use timestep, only:dtmax,tmax use centreofmass, only:reset_centreofmass - use ptmass, only:h_acc,r_crit,rho_crit_cgs,icreate_sinks,tmax_acc + use ptmass, only:h_acc,r_crit,rho_crit_cgs,icreate_sinks,tmax_acc,h_soft_sinkgas use datafiles, only:find_phantom_datafile use eos, only:ieos,gmw use kernel, only:hfact_default use mpidomain, only:i_belong + use HIIRegion, only:iH2R integer, intent(in) :: id integer, intent(out) :: npart integer, intent(out) :: npartoftype(:) @@ -77,7 +78,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, character(len=16) :: lattice character(len=120) :: filex,filey,filez,filein,fileset logical :: inexists,setexists - logical :: BBB03 = .false. ! use the BB03 defaults, else that of a YMC (S. Jaffa) + integer :: icluster = 3 ! BBBO3 = 1, (S. Jaffa) = 2, Embedded = 3 !--Ensure this is pure hydro if (mhd) call fatal('setup_cluster','This setup is not consistent with MHD.') @@ -94,7 +95,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, Temperature = 10.0 ! Temperature in Kelvin (required for polyK only) Rsink_au = 5. ! Sink radius [au] mu = 2.46 ! Mean molecular weight (required for polyK only) - if (BBB03) then + select case (icluster) + case (1) ! from Bate, Bonnell & Bromm (2003) default_cluster = "Bate, Bonnell & Bromm (2003)" Rcloud_pc = 0.1875 ! Input radius [pc] @@ -102,7 +104,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ieos_in = 8 ! Barotropic equation of state mass_fac = 1.0 ! mass code unit: mass_fac * solarm dist_fac = 0.1 ! distance code unit: dist_fac * pc - else + case(2) ! Young Massive Cluster (S. Jaffa, University of Hertfordshire) default_cluster = "Young Massive Cluster" Rcloud_pc = 5.0 ! Input radius [pc] @@ -110,7 +112,25 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ieos_in = 1 ! Isothermal equation of state mass_fac = 1.0d5 ! mass code unit: mass_fac * solarm dist_fac = 1.0 ! distance code unit: dist_fac * pc - endif + case(3) + ! Young Massive Cluster (Yann Bernard, IPAG) + default_cluster = "Embedded cluster" + Rcloud_pc = 10.0 ! Input radius [pc] + Mcloud_msun = 1.0d4 ! Input mass [Msun] + ieos_in = 21 ! Isothermal equation of state + mass_fac = 1.0d4 ! mass code unit: mass_fac * solarm + dist_fac = 1.0 ! distance code unit: dist_fac * pc + case default + ! from Bate, Bonnell & Bromm (2003) + default_cluster = "Bate, Bonnell & Bromm (2003)" + Rcloud_pc = 0.1875 ! Input radius [pc] + Mcloud_msun = 50. ! Input mass [Msun] + ieos_in = 8 ! Barotropic equation of state + mass_fac = 1.0 ! mass code unit: mass_fac * solarm + dist_fac = 0.1 ! distance code unit: dist_fac * pc + iH2R = 1 + end select + if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state @@ -141,7 +161,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, t_ff = sqrt(3.*pi/(32.*rhozero)) ! free-fall time (the characteristic timescale) epotgrav = 3./5.*totmass**2/rmax ! Gravitational potential energy lattice = 'random' - tmax_acc = 30*(myr/utime) !--Set positions call set_sphere(trim(lattice),id,master,0.,rmax,psep,hfact,npart,xyzh,nptot=npart_total, & @@ -176,9 +195,18 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, tmax = 2.*t_ff dtmax = 0.002*t_ff h_acc = Rsink_au*au/udist - r_crit = 2.*h_acc - icreate_sinks = 1 - rho_crit_cgs = 1.d-10 + if (icluster == 3) then + r_crit = h_acc + icreate_sinks = 2 + rho_crit_cgs = 1.d-18 + h_soft_sinkgas = 2.*h_acc + tmax_acc = 1*(myr/utime) + else + r_crit = 2.*h_acc + icreate_sinks = 1 + rho_crit_cgs = 1.d-10 + endif + ieos = ieos_in gmw = mu ! for consistency; gmw will never actually be used endif From 7e199403864109a5f5c75fe15ef508365ed35ca9 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 10 Jun 2024 11:47:43 +0200 Subject: [PATCH 601/814] (evolve) fix if for HII region --- src/main/evolve.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 9d4eeaf75..717e55df4 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -288,7 +288,9 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) endif - if (iH2R > 0 .and. id==master) call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) + if (iH2R > 0 .and. id==master) then + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) + endif nsteps = nsteps + 1 ! From ba5f6a87e3dc9e7c6c4441aa6d838d79041408e8 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 10 Jun 2024 12:59:01 +0200 Subject: [PATCH 602/814] fix compilation issues --- build/Makefile | 4 ++-- src/main/H2regions.f90 | 8 ++++---- src/main/initial.F90 | 2 +- src/main/ptmass.F90 | 2 +- src/main/random.f90 | 3 ++- src/setup/setup_cluster.f90 | 6 ++++-- 6 files changed, 14 insertions(+), 11 deletions(-) diff --git a/build/Makefile b/build/Makefile index 188a62424..3168e3766 100644 --- a/build/Makefile +++ b/build/Makefile @@ -534,8 +534,8 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ partinject.F90 utils_inject.f90 dust_formation.f90 ptmass_radiation.f90 ptmass_heating.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ - ${SRCKROME} memory.f90 utils_sampling.f90 ptmass.F90 ${SRCREADWRITE_DUMPS}\ - utils_subgroup.f90 utils_kepler.f90 subgroup.f90 quitdump.f90 H2regions.f90\ + ${SRCKROME} memory.f90 H2regions.f90 ptmass.F90 ${SRCREADWRITE_DUMPS}\ + utils_subgroup.f90 utils_kepler.f90 subgroup.f90 quitdump.f90\ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ mf_write.f90 evolve.F90 utils_orbits.f90 utils_linalg.f90 \ diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 958d32807..39d885f7d 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -82,13 +82,13 @@ end subroutine initialize_H2R !+ !----------------------------------------------------------------------- -subroutine update_ionrates(nptmass,xyzmh_ptmass) +subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose use units, only:utime use part, only:irateion,ihacc - use ptmass, only: h_acc integer, intent(in) :: nptmass real, intent(inout) :: xyzmh_ptmass(:,:) + real, intent(in) :: h_acc real :: logmi,log_Q,mi,hi,Q integer :: i nHIIsources = 0 @@ -121,13 +121,13 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass) return end subroutine update_ionrates -subroutine update_ionrate(i,xyzmh_ptmass) +subroutine update_ionrate(i,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose use units, only:utime use part, only:irateion,ihacc - use ptmass, only: h_acc integer, intent(in) :: i real, intent(inout) :: xyzmh_ptmass(:,:) + real, intent(in) :: h_acc real :: logmi,log_Q,mi,hi,Q mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 1de2e0599..063299a6f 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -502,7 +502,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass - call update_ionrates(nptmass,xyzmh_ptmass) + call update_ionrates(nptmass,xyzmh_ptmass,h_acc) ! compute initial sink-sink forces and get timestep if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 2e1deefa8..3cda28bc3 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1672,7 +1672,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, enddo deallocate(masses) endif - call update_ionrate(k,xyzmh_ptmass) + call update_ionrate(k,xyzmh_ptmass,h_acc) enddo end subroutine ptmass_create_stars diff --git a/src/main/random.f90 b/src/main/random.f90 index 466782763..c5950a9ce 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -169,7 +169,8 @@ end function gauss_random subroutine divide_unit_seg(lengths,mindist,nlengths,iseed) - integer, intent(in) :: nlengths,iseed + integer, intent(in) :: nlengths + integer, intent(inout) :: iseed real, intent(inout) :: lengths(nlengths) real, intent(in) :: mindist integer :: i,j diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index ff49eebf1..429129bdf 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -55,7 +55,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use setvfield, only:normalise_vfield use timestep, only:dtmax,tmax use centreofmass, only:reset_centreofmass - use ptmass, only:h_acc,r_crit,rho_crit_cgs,icreate_sinks,tmax_acc,h_soft_sinkgas + use ptmass, only:h_acc,r_crit,rho_crit_cgs,icreate_sinks,tmax_acc,h_soft_sinkgas, & + r_merge_uncond use datafiles, only:find_phantom_datafile use eos, only:ieos,gmw use kernel, only:hfact_default @@ -201,6 +202,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, rho_crit_cgs = 1.d-18 h_soft_sinkgas = 2.*h_acc tmax_acc = 1*(myr/utime) + r_merge_uncond = h_acc else r_crit = 2.*h_acc icreate_sinks = 1 @@ -240,7 +242,7 @@ subroutine get_input_from_prompts() call prompt('Enter the radius of the sink particles (in au)',Rsink_au) call prompt('Enter the Temperature of the cloud (used for initial sound speed)',Temperature) call prompt('Enter the mean molecular mass (used for initial sound speed)',mu) - if (maxvxyzu < 4) call prompt('Enter the EOS id (1: isothermal, 8: barotropic)',ieos_in) + if (maxvxyzu < 4) call prompt('Enter the EOS id (1: isothermal, 8: barotropic, 21: HII region expansion)',ieos_in) end subroutine get_input_from_prompts !---------------------------------------------------------------- From 0566ffe6a2ffcf765cfd0ab4d8187705ee0f3a35 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 10 Jun 2024 13:36:17 +0200 Subject: [PATCH 603/814] minor fixes in setup --- src/main/initial.F90 | 2 +- src/setup/setup_cluster.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 063299a6f..250dd0c4a 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -131,7 +131,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& nden_nimhd,dustevol,rhoh,gradh, & Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx, & - n_group,n_ingroup,n_sing,nmatrix,group_info,isionised + n_group,n_ingroup,n_sing,nmatrix,group_info use part, only:pxyzu,dens,metrics,rad,radprop,drad,ithick use densityforce, only:densityiterate use linklist, only:set_linklist diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 429129bdf..44504009f 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -121,6 +121,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ieos_in = 21 ! Isothermal equation of state mass_fac = 1.0d4 ! mass code unit: mass_fac * solarm dist_fac = 1.0 ! distance code unit: dist_fac * pc + iH2R = 1 case default ! from Bate, Bonnell & Bromm (2003) default_cluster = "Bate, Bonnell & Bromm (2003)" @@ -129,7 +130,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ieos_in = 8 ! Barotropic equation of state mass_fac = 1.0 ! mass code unit: mass_fac * solarm dist_fac = 0.1 ! distance code unit: dist_fac * pc - iH2R = 1 end select From 1921fab0997c8fd58b70c83921d3301dc30c0e90 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 10 Jun 2024 19:08:23 +0200 Subject: [PATCH 604/814] (ptmass) fix star creation routine --- src/main/ptmass.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 3cda28bc3..7a75ca9b4 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1671,8 +1671,8 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, n = n - 1 enddo deallocate(masses) + call update_ionrate(k,xyzmh_ptmass,h_acc) endif - call update_ionrate(k,xyzmh_ptmass,h_acc) enddo end subroutine ptmass_create_stars From 591d582668535f55f06328b9602e490413380193 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 10 Jun 2024 23:53:32 +0200 Subject: [PATCH 605/814] typos... --- src/main/H2regions.f90 | 2 +- src/main/ptmass.F90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 39d885f7d..57dcdd0c9 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -284,7 +284,7 @@ subroutine write_options_H2R(iunit) integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling HII region expansion feedback' if(iH2R>0) then - call write_inopt(IH2R, 'IH2R', "unable the HII region expansion feedback in star forming reigon", iunit) + call write_inopt(IH2R, 'IH2R', "enable the HII region expansion feedback in star forming reigon", iunit) call write_inopt(Mmin, 'Mmin', "Minimum star mass to trigger HII region (MSun)", iunit) call write_inopt(Rmax, 'Rmax', "Maximum radius for HII region (pc)", iunit) endif diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 7a75ca9b4..9470a8600 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1614,7 +1614,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, use units, only:umass use part, only:itbirth,ihacc use random , only:ran2,gauss_random,divide_unit_seg - use HIIRegion, only:update_ionrate + use HIIRegion, only:update_ionrate,iH2R integer, intent(in) :: nptmass integer, intent(in) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) @@ -1671,7 +1671,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, n = n - 1 enddo deallocate(masses) - call update_ionrate(k,xyzmh_ptmass,h_acc) + if (iH2R > 0) call update_ionrate(k,xyzmh_ptmass,h_acc) endif enddo From e02c2b2ff3ef33551ce371be6b14fa5aac9a8ed3 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 10 Jun 2024 23:58:06 +0200 Subject: [PATCH 606/814] (HII region) fix typo in write/read options --- src/main/H2regions.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 57dcdd0c9..438acdb39 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -284,7 +284,7 @@ subroutine write_options_H2R(iunit) integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling HII region expansion feedback' if(iH2R>0) then - call write_inopt(IH2R, 'IH2R', "enable the HII region expansion feedback in star forming reigon", iunit) + call write_inopt(iH2R, 'iH2R', "enable the HII region expansion feedback in star forming reigon", iunit) call write_inopt(Mmin, 'Mmin', "Minimum star mass to trigger HII region (MSun)", iunit) call write_inopt(Rmax, 'Rmax', "Maximum radius for HII region (pc)", iunit) endif @@ -299,7 +299,7 @@ subroutine read_options_H2R(name,valstring,imatch,igotall,ierr) character(len=30), parameter :: label = 'read_options_H2R' imatch = .true. select case(trim(name)) - case('H2R') + case('iH2R') read(valstring,*,iostat=ierr) iH2R if (iH2R < 0) call fatal(label,'HII region option out of range') ngot = ngot + 1 From 464773c01c7db29bbdf9be1dec2ee4873f3dc6ba Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 11 Jun 2024 09:26:13 +0200 Subject: [PATCH 607/814] (ptmass) fix merging --- src/main/H2regions.f90 | 6 ++++-- src/main/ptmass.F90 | 3 ++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 438acdb39..6a2211c59 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -275,17 +275,19 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) enddo endif call get_timings(t2,tcpu2) - print*, "HII feedback CPU time : ",t2-t1 + !print*, "HII feedback CPU time : ",t2-t1 return end subroutine HII_feedback subroutine write_options_H2R(iunit) use infile_utils, only:write_inopt + use physcon, only:solarm + use units, only:umass integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling HII region expansion feedback' if(iH2R>0) then call write_inopt(iH2R, 'iH2R', "enable the HII region expansion feedback in star forming reigon", iunit) - call write_inopt(Mmin, 'Mmin', "Minimum star mass to trigger HII region (MSun)", iunit) + call write_inopt((Mmin*umass)/solarm, 'Mmin', "Minimum star mass to trigger HII region (MSun)", iunit) call write_inopt(Rmax, 'Rmax', "Maximum radius for HII region (pc)", iunit) endif end subroutine write_options_H2R diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 9470a8600..044cec6ad 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -479,7 +479,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin call get_geopot_force(dx,dy,dz,ddr,f1,rsinki,J2i,shati,fxi,fyi,fzi,phii,dsx,dsy,dsz) endif endif - if (hacci>h_acc .or. haccj>h_acc) then + if (hacci==h_acc .and. haccj==h_acc) then if (rr2 < r_merge2) then if (merge_ij(i)==0) then merge_n = merge_n + 1 @@ -1777,6 +1777,7 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklis - mij*(xyzmh_ptmass(1,k)*vxyz_ptmass(2,k) - xyzmh_ptmass(2,k)*vxyz_ptmass(1,k)) ! Kill sink j by setting negative mass xyzmh_ptmass(4,j) = -abs(mj) + xyzmh_ptmass(ihacc,j) = -1. if (icreate_sinks == 2) then ! Connect linked list of the merged sink to the survivor call ptmass_end_lklist(k,l,linklist_ptmass) From e0656ba013b03fb08a8044b22a4f7fea041a8484 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 11 Jun 2024 12:09:12 +0200 Subject: [PATCH 608/814] (ptmass) resolve bug in special merging conditions with icreatesink==2 --- src/main/ptmass.F90 | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 044cec6ad..c1ac38dcf 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -310,7 +310,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec - use part, only:igarg,igid + use part, only:igarg,igid,ihacc integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(out) :: fxyz_ptmass(4,nptmass) @@ -396,7 +396,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin zi = xyzmh_ptmass(3,i) endif pmassi = xyzmh_ptmass(4,i) - hacci = xyzmh_ptmass(5,i) + hacci = xyzmh_ptmass(ihacc,i) if (pmassi < 0.) cycle J2i = xyzmh_ptmass(iJ2,i) @@ -426,7 +426,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dz = zi - xyzmh_ptmass(3,j) endif pmassj = xyzmh_ptmass(4,j) - haccj = xyzmh_ptmass(5,j) + haccj = xyzmh_ptmass(ihacc,j) if (pmassj < 0.) cycle J2j = xyzmh_ptmass(iJ2,j) @@ -479,8 +479,22 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin call get_geopot_force(dx,dy,dz,ddr,f1,rsinki,J2i,shati,fxi,fyi,fzi,phii,dsx,dsy,dsz) endif endif - if (hacci==h_acc .and. haccj==h_acc) then - if (rr2 < r_merge2) then + if (rr2 < r_merge2) then + if (icreate_sinks == 2) then + if (hacci==h_acc .and. haccj==h_acc) then + if (merge_ij(i)==0) then + merge_n = merge_n + 1 + merge_ij(i) = j + else + ! if we have already identified a nearby sink, replace the tag with the nearest sink + dx = xi - xyzmh_ptmass(1,merge_ij(i)) + dy = yi - xyzmh_ptmass(2,merge_ij(i)) + dz = zi - xyzmh_ptmass(3,merge_ij(i)) + rr2j = dx*dx + dy*dy + dz*dz + epsilon(rr2j) + if (rr2 < rr2j) merge_ij(i) = j + endif + endif + else if (merge_ij(i)==0) then merge_n = merge_n + 1 merge_ij(i) = j From 10fc06547cc29e15e4be4c8d6ae69427af15c3e8 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 11 Jun 2024 14:10:37 +0200 Subject: [PATCH 609/814] (ptmass) fix parallel compilation error --- src/main/ptmass.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index c1ac38dcf..03268ff21 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -369,7 +369,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info,subsys) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & - !$omp shared(extrapfac,extrap,fsink_old,h_acc) & + !$omp shared(extrapfac,extrap,fsink_old,h_acc,icreate_sinks) & !$omp private(i,j,xi,yi,zi,pmassi,pmassj,hacci,haccj) & !$omp private(gidi,gidj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & From a2dbbcc35d7e092c55e0c45101d74cfea8cbb877 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 11 Jun 2024 14:42:08 +0200 Subject: [PATCH 610/814] (ptmass) fix linklist merging --- src/main/ptmass.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 03268ff21..9c5c808d1 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1816,10 +1816,11 @@ subroutine ptmass_end_lklist(i,k,linklist_ptmass) integer, intent(in) :: linklist_ptmass(:) integer, intent(in) :: i integer, intent(out) :: k - integer :: l - l=i - do while (l>0) - l = linklist_ptmass(l) + integer :: l,g + g=i + do while (g>0) + l = g + g = linklist_ptmass(l) enddo k=l end subroutine ptmass_end_lklist From 20522acc7d158da857bcb5d4bf709a5fba4ba536 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 11 Jun 2024 14:51:43 +0200 Subject: [PATCH 611/814] (HIIRegion) add condition to trigger momentum fb --- src/main/H2regions.f90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 6a2211c59..781b88d1d 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -107,7 +107,7 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) Q = (10.**log_Q)*utime xyzmh_ptmass(irateion,i) = Q nHIIsources = nHIIsources + 1 - if (iverbose > 1) then + if (iverbose > 0) then write(iprint,"(/a,es18.10/)")"Massive stars detected : Log Q : ",log_Q endif else @@ -139,7 +139,7 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) Q = (10.**log_Q)*utime xyzmh_ptmass(irateion,i) = Q nHIIsources = nHIIsources + 1 - if (iverbose > 1) then + if (iverbose > 0) then write(iprint,"(/a,es18.10/)")"(HII region) Massive stars detected : Log Q : ",log_Q endif else @@ -232,6 +232,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) else ! unresolved case r = 0. + k = 0 endif exit endif @@ -242,7 +243,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) ! !-- Momentum feedback ! - if(momflag) then + if(momflag .and. npartin > 3) then j = listneigh(1) r_in = sqrt((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) mHII = ((4.*pi*(r**3-r_in**3)*rhoh(xyzh(4,j),pmass))/3) From e895d12456112ee729eef78dbbd6dae3f1dab27f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 11 Jun 2024 14:58:38 +0200 Subject: [PATCH 612/814] (ptmass) change sink creation overriding limit --- src/main/ptmass.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 9c5c808d1..6fe5fe533 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -2163,7 +2163,7 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) case('f_crit_override') read(valstring,*,iostat=ierr) f_crit_override if (f_crit_override < 0.) f_crit_override = 0. ! reset to zero since a negative value does not make sense - if (f_crit_override > 0. .and. f_crit_override < 100. ) call fatal(label,'Give star formation a chance! Reset to > 100') + if (f_crit_override > 0. .and. f_crit_override < 10. ) call fatal(label,'Give star formation a chance! Reset to > 10') l_crit_override = .true. case('h_soft') ! to ensure backwards compatibility read(valstring,*,iostat=ierr) h_soft From 74f4afc06e51cd7262e71b64b2361fb7988c9c7e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 11 Jun 2024 15:00:51 +0200 Subject: [PATCH 613/814] (HIIRegion) wrong var assignment --- src/main/H2regions.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 781b88d1d..6df04b88f 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -232,7 +232,6 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) else ! unresolved case r = 0. - k = 0 endif exit endif From 3fdffb12937a4b069593db4f76da8e06ef9a6bc0 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 11 Jun 2024 23:41:01 +0200 Subject: [PATCH 614/814] (HIIRegion) homogenization of runtime variable and add prints --- src/main/H2regions.f90 | 15 +++++++-------- src/main/checksetup.f90 | 3 ++- src/main/initial.F90 | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 6df04b88f..e241e83cf 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -40,8 +40,8 @@ module HIIRegion real, private :: mH real, private :: T_ion real, private :: u_to_t - real, private :: Rst2_max real, private :: Rst_max + real, private :: Minmass private @@ -67,9 +67,8 @@ subroutine initialize_H2R ar = ar_cgs*(utime/udist**3) sigd = sigd_cgs*udist**2 hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) - Rst2_max = ((Rmax*pc)/udist)**2 - Rst_max = sqrt(Rst_max) - Mmin = (Mmin*solarm)/umass + Rst_max = sqrt(((Rmax*pc)/udist)**2) + Minmass = (Mmin*solarm)/umass if (iverbose > 1) then write(iprint,"(/a,es18.10,es18.10/)") "feedback constants mH, u_to_t : ", mH, u_to_t endif @@ -93,13 +92,13 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) integer :: i nHIIsources = 0 !$omp parallel do default(none) & - !$omp shared(xyzmh_ptmass,nptmass,iprint,iverbose,utime,Mmin,h_acc)& + !$omp shared(xyzmh_ptmass,nptmass,iprint,iverbose,utime,Minmass,h_acc)& !$omp private(logmi,log_Q,Q,mi,hi)& !$omp reduction(+:nHIIsources) do i=1,nptmass mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) - if(mi > Mmin .and. hi < h_acc)then + if(mi > Minmass .and. hi < h_acc)then logmi = log10(mi) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases @@ -131,7 +130,7 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) real :: logmi,log_Q,mi,hi,Q mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) - if(mi > Mmin .and. hi < h_acc)then + if(mi > Minmass .and. hi < h_acc)then logmi = log10(mi) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases @@ -287,7 +286,7 @@ subroutine write_options_H2R(iunit) write(iunit,"(/,a)") '# options controlling HII region expansion feedback' if(iH2R>0) then call write_inopt(iH2R, 'iH2R', "enable the HII region expansion feedback in star forming reigon", iunit) - call write_inopt((Mmin*umass)/solarm, 'Mmin', "Minimum star mass to trigger HII region (MSun)", iunit) + call write_inopt(Mmin, 'Mmin', "Minimum star mass to trigger HII region (MSun)", iunit) call write_inopt(Rmax, 'Rmax', "Maximum radius for HII region (pc)", iunit) endif end subroutine write_options_H2R diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index ccaad8eda..9cc02878e 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -532,7 +532,7 @@ end function in_range subroutine check_setup_ptmass(nerror,nwarn,hmin) use dim, only:maxptmass use part, only:nptmass,xyzmh_ptmass,ihacc,ihsoft,gr,iTeff,sinks_have_luminosity,& - ilum,iJ2,ispinx,ispinz,iReff + ilum,iJ2,ispinx,ispinz,iReff,linklist_ptmass use ptmass_radiation, only:isink_radiation use ptmass, only:use_fourthorder integer, intent(inout) :: nerror,nwarn @@ -591,6 +591,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) print*,' ERROR: sink ',i,' mass = ',xyzmh_ptmass(4,i) elseif (xyzmh_ptmass(4,i) < 0.) then print*,' Sink ',i,' has previously merged with another sink' + print*,' Connected to sink : ',linklist_ptmass(i) n = n + 1 endif enddo diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 250dd0c4a..506caecd8 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -502,7 +502,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass - call update_ionrates(nptmass,xyzmh_ptmass,h_acc) + if (iH2R > 0) call update_ionrates(nptmass,xyzmh_ptmass,h_acc) ! compute initial sink-sink forces and get timestep if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) From e36458e550052b3b1d8664914d60b8a5c95a0a5d Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 11 Jun 2024 23:53:20 +0200 Subject: [PATCH 615/814] (HIIRegion) add initial print --- src/main/H2regions.f90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index e241e83cf..7d11f3b9e 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -69,8 +69,10 @@ subroutine initialize_H2R hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) Rst_max = sqrt(((Rmax*pc)/udist)**2) Minmass = (Mmin*solarm)/umass - if (iverbose > 1) then - write(iprint,"(/a,es18.10,es18.10/)") "feedback constants mH, u_to_t : ", mH, u_to_t + if (iverbose > 0) then + write(iprint,"(/a,es18.10,es18.10/)") "feedback constants mH, u_to_t : ", mH, u_to_t + write(iprint,"(/a,es18.10,es18.10/)") "Max strögrem radius (code/pc) : ", Rst_max, Rmax + write(iprint,"(/a,es18.10,es18.10/)") "Min feedback mass (code/Msun) : ", Minmass, Mmin endif return end subroutine initialize_H2R @@ -281,7 +283,6 @@ end subroutine HII_feedback subroutine write_options_H2R(iunit) use infile_utils, only:write_inopt use physcon, only:solarm - use units, only:umass integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling HII region expansion feedback' if(iH2R>0) then From 12f008afacc2492c6d556fcdcb6454d61635f49b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 17 Jun 2024 15:35:35 +0200 Subject: [PATCH 616/814] (HIIRegion) fix printing --- src/main/H2regions.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 7d11f3b9e..84aacbf9b 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -53,7 +53,7 @@ module HIIRegion !+ !----------------------------------------------------------------------- subroutine initialize_H2R - use io, only:iprint,iverbose + use io, only:iprint,iverbose,id,master use part, only:isionised use units, only:udist,umass,utime use physcon, only:mass_proton_cgs,kboltz,pc,eV,solarm @@ -69,7 +69,7 @@ subroutine initialize_H2R hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) Rst_max = sqrt(((Rmax*pc)/udist)**2) Minmass = (Mmin*solarm)/umass - if (iverbose > 0) then + if (id == master .and. iverbose > 0) then write(iprint,"(/a,es18.10,es18.10/)") "feedback constants mH, u_to_t : ", mH, u_to_t write(iprint,"(/a,es18.10,es18.10/)") "Max strögrem radius (code/pc) : ", Rst_max, Rmax write(iprint,"(/a,es18.10,es18.10/)") "Min feedback mass (code/Msun) : ", Minmass, Mmin From 2f642d4137961cd2df520a47f0f53668eb5ed243 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 17 Jun 2024 15:36:42 +0200 Subject: [PATCH 617/814] (ptmass) new star creation method (Plummer like) --- src/main/ptmass.F90 | 76 ++++++++++++++++++++++++++++++++------------- 1 file changed, 55 insertions(+), 21 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 6fe5fe533..8f2d3a9e9 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1621,9 +1621,9 @@ subroutine ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) nptmass = n end subroutine ptmass_create_seeds -subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) +subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time) + use dim, only:maxptmass use physcon, only:solarm,pi - use eos, only:polyk use io, only:iprint use units, only:umass use part, only:itbirth,ihacc @@ -1632,12 +1632,13 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, integer, intent(in) :: nptmass integer, intent(in) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(inout) :: fxyz_ptmass(4,maxptmass),fxyz_ptmass_sinksink(4,maxptmass) real, intent(in) :: time real, allocatable :: masses(:) real :: xi(3),vi(3) integer :: i,k,n real :: tbirthi,mi,hacci,minmass,minmonmi - real :: xk,yk,zk,d,cs + real :: a(8),velk,rk,xk(3),vk(3),rvir do i=1,nptmass mi = xyzmh_ptmass(4,i) @@ -1664,28 +1665,56 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass, k=i do while(k>0) - !! do some clever stuff - d = huge(mi) - do while (d>1.) - xk = ran2(iseed_sf) - yk = ran2(iseed_sf) - zk = ran2(iseed_sf) - d = xk**2+yk**2+zk**2 + !! Position and velocity sampling methods + a(:) = 0. + rvir = 0.7*h_acc + + ! + !-- Positions + ! + do while (a(1) < 1.e-10 .and. a(1)>0.55) ! avoid stars to be concentrated too much in the center + a(1) = ran2(iseed_sf) + enddo + rk = rvir/sqrt((a(1)**(-2./3.)-1.0)) + a(2) = ran2(iseed_sf) + a(3) = ran2(iseed_sf) + xk(3) = (1.0-2.0*a(2))*rk + xk(2) = sqrt(rk**2-xk(3)**2)*sin(2*pi*a(3)) + xk(1) = sqrt(rk**2-xk(3)**2)*cos(2*pi*a(3)) + ! + !-- Velocities + ! + do while(0.1*a(5)> a(6)) + a(4) = ran2(iseed_sf) + a(5) = ran2(iseed_sf) + a(6) = a(4)**2*(1.0 - a(4)**2)**3.5 enddo - cs = sqrt(polyk) - xyzmh_ptmass(ihacc,k) = hacci*1.e-3 - xyzmh_ptmass(4,k) = masses(n) - xyzmh_ptmass(1,k) = xi(1) + xk*hacci - xyzmh_ptmass(2,k) = xi(2) + yk*hacci - xyzmh_ptmass(3,k) = xi(3) + zk*hacci - vxyz_ptmass(1,k) = vi(1) + cs*gauss_random(iseed_sf) - vxyz_ptmass(2,k) = vi(2) + cs*gauss_random(iseed_sf) - vxyz_ptmass(3,k) = vi(3) + cs*gauss_random(iseed_sf) - k = linklist_ptmass(k) + + velk = a(4)*sqrt(2.0)*(1.0 + rk**2)**(-0.25)*sqrt(2.0*mi/rvir) + a(7) = ran2(iseed_sf) + a(8) = ran2(iseed_sf) + vk(3) = (1.0-2.0*a(7))*velk + vk(2) = sqrt(velk**2-vk(3)**2)*sin(2*pi*a(8)) + vk(1) = sqrt(velk**2-vk(3)**2)*cos(2*pi*a(8)) + + ! + !-- Star creation + ! + xyzmh_ptmass(ihacc,k) = hacci*1.e-3 + xyzmh_ptmass(4,k) = masses(n) + xyzmh_ptmass(3,k) = xi(3) + xk(3) + xyzmh_ptmass(2,k) = xi(2) + xk(2) + xyzmh_ptmass(1,k) = xi(1) + xk(1) + vxyz_ptmass(1,k) = vi(1) + vk(1) + vxyz_ptmass(2,k) = vi(2) + vk(2) + vxyz_ptmass(3,k) = vi(3) + vk(3) + fxyz_ptmass(1:4,k) = 0. + fxyz_ptmass_sinksink(1:4,k) = 0. + k = linklist_ptmass(k) ! acces to the next point mass in the linked list n = n - 1 + if (iH2R > 0) call update_ionrate(k,xyzmh_ptmass,h_acc) enddo deallocate(masses) - if (iH2R > 0) call update_ionrate(k,xyzmh_ptmass,h_acc) endif enddo @@ -2092,6 +2121,7 @@ end subroutine ptmass_calc_enclosed_mass !----------------------------------------------------------------------- subroutine write_options_ptmass(iunit) use infile_utils, only:write_inopt + use subgroup, only:r_neigh integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling sink particles' @@ -2113,6 +2143,10 @@ subroutine write_options_ptmass(iunit) call write_inopt(h_soft_sinkgas,'h_soft_sinkgas','softening length for new sink particles', iunit) endif endif + if(use_regnbody) then + call write_inopt(use_regnbody, 'use_regnbody', 'allow subgroup integration method', iunit) + call write_inopt(r_neigh, 'r_neigh', 'searching radius to detect subgroups', iunit) + endif call write_inopt(h_soft_sinksink,'h_soft_sinksink','softening length between sink particles',iunit) call write_inopt(f_acc,'f_acc','particles < f_acc*h_acc accreted without checks',iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) From dd2b22497a935fe0c7a4d914445f93b73c77e969 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 17 Jun 2024 15:37:53 +0200 Subject: [PATCH 618/814] (subgroups) r_neigh is now a runtime param + group init after star creation --- build/Makefile | 4 +-- src/main/evolve.F90 | 21 +++++++++--- src/main/initial.F90 | 3 +- src/main/subgroup.f90 | 67 ++++++++++++++++++++++++++----------- src/main/substepping.F90 | 1 + src/setup/setup_cluster.f90 | 14 +++++--- 6 files changed, 79 insertions(+), 31 deletions(-) diff --git a/build/Makefile b/build/Makefile index 3168e3766..0dda2d243 100644 --- a/build/Makefile +++ b/build/Makefile @@ -534,8 +534,8 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ partinject.F90 utils_inject.f90 dust_formation.f90 ptmass_radiation.f90 ptmass_heating.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ - ${SRCKROME} memory.f90 H2regions.f90 ptmass.F90 ${SRCREADWRITE_DUMPS}\ - utils_subgroup.f90 utils_kepler.f90 subgroup.f90 quitdump.f90\ + ${SRCKROME} memory.f90 H2regions.f90 utils_subgroup.f90 utils_kepler.f90 subgroup.f90 ptmass.F90 \ + ${SRCREADWRITE_DUMPS} quitdump.f90\ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ mf_write.f90 evolve.F90 utils_orbits.f90 utils_linalg.f90 \ diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 717e55df4..1941825bc 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -90,14 +90,17 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) 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,& - linklist_ptmass,isionised + linklist_ptmass,isionised,dsdt_ptmass + use part, only:n_group,n_ingroup,n_sing,group_info,nmatrix use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & - set_integration_precision,ptmass_create_stars + set_integration_precision,ptmass_create_stars,use_regnbody use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries - use HIIRegion, only:HII_feedback,iH2R + use HIIRegion, only:HII_feedback,iH2R + use subgroup, only:group_identify + use substepping, only:get_force #ifdef MFLOW use mf_write, only:mflow_write #endif @@ -139,6 +142,9 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) logical :: use_global_dt integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold character(len=120) :: dumpfile_orig + integer :: dummy + + dummy = 0 tprint = 0. nsteps = 0 @@ -279,7 +285,14 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! 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) - if (icreate_sinks == 2) call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,time) + if (icreate_sinks == 2) then + call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time) + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& + fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,group_info=group_info) + endif + endif endif ! ! Strang splitting: implicit update for half step diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 506caecd8..a958074cc 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -212,7 +212,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use fileutils, only:make_tags_unique use damping, only:idamp - use subgroup, only:group_identify + use subgroup, only:group_identify,init_subgroup use HIIRegion, only:iH2R,initialize_H2R,update_ionrates character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile @@ -505,6 +505,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) if (iH2R > 0) call update_ionrates(nptmass,xyzmh_ptmass,h_acc) ! compute initial sink-sink forces and get timestep if (use_regnbody) then + call init_subgroup call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& iexternalforce,time,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 96a7c7344..94d214d89 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -22,35 +22,56 @@ module subgroup public :: group_identify public :: evolve_groups public :: get_pot_subsys - ! parameters for group identification - real, parameter :: eta_pert = 20 + public :: init_subgroup + ! + !-- parameters for group identification + ! real, parameter :: time_error = 2.5e-14 - real, parameter :: max_step = 100000000 - real, parameter, public :: r_neigh = 0.001 - real, public :: t_crit = 1.e-9 - real, public :: C_bin = 0.02 - real, public :: r_search = 100.*r_neigh + real, parameter :: max_step = 1000000 + real, parameter :: C_bin = 0.02 + real, public :: r_neigh = 0.001 ! default value assume udist = 1 pc + real :: r_search private contains +!----------------------------------------------- +! +! Initialisation routine +! +!----------------------------------------------- +subroutine init_subgroup + use units, only:udist + + r_neigh = r_neigh/udist + r_search = 100.*r_neigh + +end subroutine init_subgroup !----------------------------------------------- ! ! Group identification routines ! !----------------------------------------------- -subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) +subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix,dtext) use io ,only:id,master,iverbose,iprint - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, intent(inout) :: group_info(3,nptmass) + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(inout) :: group_info(3,nptmass) + integer, intent(inout) :: n_group,n_ingroup,n_sing integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) - integer, intent(inout) :: n_group,n_ingroup,n_sing + real, optional, intent(in) :: dtext + logical :: large_search + + large_search = present(dtext) n_group = 0 n_ingroup = 0 n_sing = 0 if (nptmass > 0) then - call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) + if(large_search) then + call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) + else + call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) + endif call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) endif @@ -125,22 +146,28 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) end subroutine dfs -subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) +subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) use utils_kepler, only: Espec,extract_a,extract_e,extract_ea - integer, intent(in) :: nptmass + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(in) :: vxyz_ptmass(:,:) integer(kind=1), intent(out):: nmatrix(nptmass,nptmass) - real, intent(in) :: xyzmh_ptmass(:,:) - real, intent(in) :: vxyz_ptmass(:,:) + real, optional, intent(in) :: dtext real :: xi,yi,zi,vxi,vyi,vzi,mi real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu - real :: aij,eij,B,rperi + real :: aij,eij,B,rperi,dtexti integer :: i,j + if (present(dtext)) then + dtexti = dtext + else + dtexti = 0. + endif ! !!TODO MPI Proof version of the matrix construction ! !$omp parallel do default(none) & - !$omp shared(nptmass,C_bin,t_crit,nmatrix) & + !$omp shared(nptmass,dtexti,nmatrix,r_neigh) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,r_search) & !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & !$omp private(dx,dy,dz,r,r2) & @@ -182,7 +209,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) else call extract_e(dx,dy,dz,dvx,dvy,dvz,mu,r,eij) rperi = aij*(1-eij) - if (rperi Date: Mon, 17 Jun 2024 15:41:22 +0200 Subject: [PATCH 619/814] (evolve) forgot an else condition after star creation --- src/main/evolve.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 1941825bc..1193f1023 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -291,7 +291,11 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) 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,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) endif + endif endif ! From 4dfffc328be568ad6b0272d3a575c968e130348e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 18 Jun 2024 09:45:55 +0200 Subject: [PATCH 620/814] (ptmass) use_regnbody case in read_options --- src/main/ptmass.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 8f2d3a9e9..9f013bd30 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -2161,6 +2161,7 @@ end subroutine write_options_ptmass !----------------------------------------------------------------------- subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) use io, only:warning,fatal + use subgroup, only:r_neigh character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr @@ -2231,6 +2232,10 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) case('iseed_sf') read(valstring,*,iostat=ierr) iseed_sf ngot = ngot + 1 + case('use_regnbody') + read(valstring,*,iostat=ierr) use_regnbody + case('r_neigh') + read(valstring,*,iostat=ierr) r_neigh case default imatch = .false. end select From e32bf4c8a45b6aca7a975af4fa70f264eeba73d3 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 18 Jun 2024 11:00:10 +0200 Subject: [PATCH 621/814] (HIIRegion) refactor new eos for HII region expansion --- build/Makefile | 2 +- src/main/eos.f90 | 28 +++++--------- src/main/eos_HIIR.f90 | 80 +++++++++++++++++++++++++++++++++++++++ src/tests/test_ptmass.f90 | 12 +++--- 4 files changed, 98 insertions(+), 24 deletions(-) create mode 100644 src/main/eos_HIIR.f90 diff --git a/build/Makefile b/build/Makefile index 0dda2d243..3a2fd4082 100644 --- a/build/Makefile +++ b/build/Makefile @@ -505,7 +505,7 @@ SRCCHEM= fs_data.f90 mol_data.f90 utils_spline.f90 \ # equations of state # 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.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_HIIR.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 diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 779314263..df5ea8115 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -116,6 +116,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam use eos_stratified, only:get_eos_stratified use eos_barotropic, only:get_eos_barotropic use eos_piecewise, only:get_eos_piecewise + use eos_HIIR, only:get_eos_HIIR integer, intent(in) :: eos_type real, intent(in) :: rhoi,xi,yi,zi real, intent(out) :: ponrhoi,spsoundi @@ -131,7 +132,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam real :: cgsrhoi,cgseni,cgspresi,presi,gam1,cgsspsoundi real :: uthermconst real :: enthi,pondensi - logical :: ionisedi + logical :: isionisedi ! ! Check to see if equation of state is compatible with GR cons2prim routines ! @@ -149,7 +150,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam if (present(mu_local)) mui = mu_local if (present(Xlocal)) X_i = Xlocal if (present(Zlocal)) Z_i = Zlocal - if (present(isionised)) ionisedi = isionised + if (present(isionised)) isionisedi = isionised select case(eos_type) case(1) @@ -427,22 +428,8 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam if (present(mu_local)) mu_local = 1./imui if (present(gamma_local)) gamma_local = gammai case(21) - ! - !--dual medium isothermal eos - ! - ! :math:`P = c_s^2 \rho` - ! - ! where :math:`c_s^2 \equiv K` is a constant stored in the dump file header - ! - if(isionised) then - ponrhoi = (12850000./unit_velocity)**2 - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*0.5*ponrhoi - else - ponrhoi = polyk - spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*mui*ponrhoi - endif + + call get_eos_HIIR(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) @@ -470,6 +457,7 @@ subroutine init_eos(eos_type,ierr) use eos_barotropic, only:init_eos_barotropic use eos_shen, only:init_eos_shen_NL3 use eos_gasradrec, only:init_eos_gasradrec + use eos_HIIR, only:init_eos_HIIR use dim, only:maxvxyzu,do_radiation integer, intent(in) :: eos_type integer, intent(out) :: ierr @@ -547,6 +535,10 @@ subroutine init_eos(eos_type,ierr) ierr = ierr_option_conflict endif + case(21) + + call init_eos_HIIR() + end select done_init_eos = .true. diff --git a/src/main/eos_HIIR.f90 b/src/main/eos_HIIR.f90 new file mode 100644 index 000000000..279c29e1d --- /dev/null +++ b/src/main/eos_HIIR.f90 @@ -0,0 +1,80 @@ +!--------------------------------------------------------------------------! +! 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 eos_HIIR + ! + ! Implements Two temperature eos for HII region expansion + ! + ! :References: None + ! + ! :Owner: Yann Bernard + ! + ! :Runtime parameters: None + ! + ! :Dependencies: None + ! + implicit none + + public :: get_eos_HIIR,init_eos_HIIR + + real, parameter :: Tion = 10000. + real, parameter :: muioninv = 2. + real, parameter :: muion = 0.5 + + real, public :: polykion + + private + +contains + + !----------------------------------------------------------------------- + !+ + ! Init eos routine + !+ + !----------------------------------------------------------------------- + +subroutine init_eos_HIIR + use physcon, only:kb_on_mh + use units, only:unit_velocity + + polykion = (muioninv*kb_on_mh*Tion)/(unit_velocity**2) + + +end subroutine init_eos_HIIR + + + !----------------------------------------------------------------------- + !+ + ! Main eos routine + !+ + !----------------------------------------------------------------------- +subroutine get_eos_HIIR(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) + real, intent(in) :: polyk,temperature_coef + real, intent(out) :: ponrhoi,spsoundi,mui,tempi + logical, intent(in) :: isionisedi + + ! + !--dual medium isothermal eos + ! + ! :math:`P = c_s^2 \rho` + ! + ! where :math:`c_s^2 \equiv K` is a constant stored in the dump file header + ! + if(isionisedi) then + ponrhoi = polykion + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*muion*ponrhoi + else + ponrhoi = polyk + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + endif + + +end subroutine get_eos_HIIR + +end module eos_HIIR + diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 30b46e923..40396532e 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -906,7 +906,7 @@ subroutine test_createsink(ntests,npass) coremass = 0. starsmass = 0. coremass = xyzmh_ptmass(4,1) - call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,linklist_ptmass,0.) + call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,0.) do i=1,nptmass starsmass = starsmass + xyzmh_ptmass(4,i) enddo @@ -1143,6 +1143,7 @@ end subroutine test_merger subroutine test_HIIregion(ntests,npass) use dim, only:maxp,maxphase use io, only:id,master,iverbose,iprint + use eos_HIIR, only:polykion,init_eos_HIIR use eos, only:gmw,ieos,polyk,gamma use deriv, only:get_derivs_global use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fext, & @@ -1169,6 +1170,7 @@ subroutine test_HIIregion(ntests,npass) if (id==master) write(*,"(/,a)") '--> testing HII region expansion around massive stars...' call set_units(dist=1.*pc,mass=1.*solarm,G=1.d0) + call init_eos_HIIR() iverbose = 1 ! ! initialise arrays to zero @@ -1206,7 +1208,7 @@ subroutine test_HIIregion(ntests,npass) npart = 0 ! only set up particles on master, otherwise we will end up with n duplicates if (id==master) then - call set_sphere('cubic',id,master,rmin,rmax,psep,hfact,npart,xyzh,np_requested=np) + call set_sphere('random',id,master,rmin,rmax,psep,hfact,npart,xyzh,np_requested=np) endif np = npart @@ -1232,8 +1234,8 @@ subroutine test_HIIregion(ntests,npass) !call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) endif - Rspi = 0.310 !xyzmh_ptmass(irstrom,1) - ci = 12850000./unit_velocity + Rspi = 0.310278984 !xyzmh_ptmass(irstrom,1) + ci = sqrt(polykion) k = 0.005 Rsp = Rspi @@ -1245,7 +1247,7 @@ subroutine test_HIIregion(ntests,npass) tmax = (3.e6*years)/utime t = 0. - dt = 0.000001 + dt = 0.00001 dtmax = dt*100 dtext = dt dtnew = dt From 53c5eadce8bf04175187cc5308c1bf042f6224ff Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 18 Jun 2024 17:02:15 +0200 Subject: [PATCH 622/814] (ptmass) rework on mass sampling sf prescription --- src/main/ptmass.F90 | 2 ++ src/main/random.f90 | 27 +++++++++++++++++---------- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 9f013bd30..431b2bea9 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1662,6 +1662,8 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz minmonmi = minmass/mi call divide_unit_seg(masses,minmonmi,n,iseed_sf) masses = masses*mi + write(iprint,"(a,es18.10)") "Mass sharing : ", masses*umass/solarm + k=i do while(k>0) diff --git a/src/main/random.f90 b/src/main/random.f90 index c5950a9ce..c5b083b6a 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -169,37 +169,44 @@ end function gauss_random subroutine divide_unit_seg(lengths,mindist,nlengths,iseed) + use sortutils, only:indexx integer, intent(in) :: nlengths integer, intent(inout) :: iseed real, intent(inout) :: lengths(nlengths) real, intent(in) :: mindist - integer :: i,j - logical :: close,lower - real :: points(nlengths+1),tmp,dist + real, allocatable :: points(:) + integer, allocatable :: idx(:) + integer :: i,j + logical :: close + real :: tmp,dist + + allocate(points(nlengths+1)) + allocate(idx(nlengths+1)) points(nlengths+1) = 1. points(1) = 0. tmp = 0. do i=2,nlengths close = .true. - lower = .true. - dist = huge(tmp) - do while (close .or. lower) + do while (close) tmp = ran2(iseed) - dist = huge(tmp) - do j=1,i-1 + dist = tmp + do j=2,i-1 dist = min(abs(points(j)-tmp),dist) enddo dist = min(abs(points(nlengths+1)-tmp),dist) close = dist>mindist - lower = tmp < points(i-1) enddo points(i) = tmp enddo + call indexx(nlengths+1,points,idx) + do i=2,nlengths+1 - lengths(i-1) = points(i) - points(i-1) + lengths(i-1) = points(idx(i)) - points(idx(i-1)) enddo + deallocate(points) + deallocate(idx) end subroutine divide_unit_seg From 324c1a1cf73450e75a08578e49951602fee3a11a Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 18 Jun 2024 16:21:38 +0100 Subject: [PATCH 623/814] debug printouts --- src/main/cooling_radapprox.f90 | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index e13f97ff2..c7e9e055b 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -68,8 +68,8 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) 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 - + use part, only:xyzmh_ptmass,rhoh,massoftype,igas,iactive,isdead_or_accreted + use part, only:iphase integer,intent(in) :: npart real,intent(in) :: xyzh(:,:),dt,Tfloor real,intent(inout) :: energ(:),dudt_sph(:) @@ -91,10 +91,11 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) !$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,dt,dudt_sph,utime,udist,umass,unit_ergg,gradP_cool,Lstar) & - !$omp private(i,poti,du_FLDi,ui,rhoi,ri2,coldensi,kappaBari,Ti) & + !$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) overpart: do i=1,npart + if (.not. iactive(iphase(i)) .or. isdead_or_accreted(xyzh(4,i))) cycle poti = Gpot_cool(i) du_FLDi = duFLD(i) ui = energ(i) @@ -106,7 +107,7 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) + (xyzh(2,i)-xyzmh_ptmass(2,isink_star))**2d0 & + (xyzh(3,i)-xyzmh_ptmass(3,isink_star))**2d0 endif - + if (rhoi*unit_density > 1d0) print *, "rhoi > 1.", rhoi,i,sqrt(ri2) ! get opacities & Ti for ui call getopac_opdep(ui*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,& Ti,gmwi) @@ -181,8 +182,9 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) teqi_store(i) = Teqi if (Teqi > 1e6) then - print *, "dudt_sph(i)=", dudt_sph(i), "duradi=", dudti_rad, "Ti=", Ti, & - "Tmini=", Tmini4**(1.0/4.0),du_tot,Hcomb + 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 * dt=", dudt_sph(i)*dt endif call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) From ad622253323ba33d3413e6f383f1ac99c170e031 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 18 Jun 2024 22:41:34 +0200 Subject: [PATCH 624/814] (ptmass) wrong min mass in create stars --- src/main/ptmass.F90 | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 431b2bea9..666329921 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1637,7 +1637,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz real, allocatable :: masses(:) real :: xi(3),vi(3) integer :: i,k,n - real :: tbirthi,mi,hacci,minmass,minmonmi + real :: tbirthi,mi,hacci,minmass real :: a(8),velk,rk,xk(3),vk(3),rvir do i=1,nptmass @@ -1658,11 +1658,10 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz !! masses sampling method call ptmass_size_lklist(i,n,linklist_ptmass) allocate(masses(n)) - minmass = (0.08*solarm)/umass - minmonmi = minmass/mi - call divide_unit_seg(masses,minmonmi,n,iseed_sf) + minmass = 0.08/(mi*(umass/solarm)) + call divide_unit_seg(masses,minmass,n,iseed_sf) masses = masses*mi - write(iprint,"(a,es18.10)") "Mass sharing : ", masses*umass/solarm + write(iprint,*) "Mass sharing : ", masses*umass/solarm k=i @@ -1670,7 +1669,6 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz !! Position and velocity sampling methods a(:) = 0. rvir = 0.7*h_acc - ! !-- Positions ! @@ -1698,7 +1696,6 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz vk(3) = (1.0-2.0*a(7))*velk vk(2) = sqrt(velk**2-vk(3)**2)*sin(2*pi*a(8)) vk(1) = sqrt(velk**2-vk(3)**2)*cos(2*pi*a(8)) - ! !-- Star creation ! From c45a5f10a0e78d81059f8e70fa7eb6a42aec39d7 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 18 Jun 2024 23:02:34 +0200 Subject: [PATCH 625/814] (random) wrong exit condition in divide func... --- src/main/random.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/random.f90 b/src/main/random.f90 index c5b083b6a..32d1e7d53 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -195,7 +195,7 @@ subroutine divide_unit_seg(lengths,mindist,nlengths,iseed) dist = min(abs(points(j)-tmp),dist) enddo dist = min(abs(points(nlengths+1)-tmp),dist) - close = dist>mindist + close = dist Date: Thu, 20 Jun 2024 11:46:39 +0200 Subject: [PATCH 626/814] (ptmass) avoid killed sink to be in subgroups... --- src/main/ptmass.F90 | 12 ++++++------ src/main/subgroup.f90 | 1 + 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 666329921..b58e4872b 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1624,7 +1624,7 @@ end subroutine ptmass_create_seeds subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time) use dim, only:maxptmass use physcon, only:solarm,pi - use io, only:iprint + use io, only:iprint,verbose use units, only:umass use part, only:itbirth,ihacc use random , only:ran2,gauss_random,divide_unit_seg @@ -1637,7 +1637,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz real, allocatable :: masses(:) real :: xi(3),vi(3) integer :: i,k,n - real :: tbirthi,mi,hacci,minmass + real :: tbirthi,mi,hacci,minmass,mcutoff real :: a(8),velk,rk,xk(3),vk(3),rvir do i=1,nptmass @@ -1661,7 +1661,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz minmass = 0.08/(mi*(umass/solarm)) call divide_unit_seg(masses,minmass,n,iseed_sf) masses = masses*mi - write(iprint,*) "Mass sharing : ", masses*umass/solarm + if(verbose > 1) write(iprint,*) "Mass sharing : ", masses*umass/solarm k=i @@ -1669,12 +1669,11 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz !! Position and velocity sampling methods a(:) = 0. rvir = 0.7*h_acc + mcutoff = 0.55 ! !-- Positions ! - do while (a(1) < 1.e-10 .and. a(1)>0.55) ! avoid stars to be concentrated too much in the center - a(1) = ran2(iseed_sf) - enddo + a(1) = ran2(iseed_sf)*mcutoff rk = rvir/sqrt((a(1)**(-2./3.)-1.0)) a(2) = ran2(iseed_sf) a(3) = ran2(iseed_sf) @@ -1684,6 +1683,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz ! !-- Velocities ! + a(5) = 1. do while(0.1*a(5)> a(6)) a(4) = ran2(iseed_sf) a(5) = ran2(iseed_sf) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 94d214d89..ef8bee205 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -181,6 +181,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) vxi = vxyz_ptmass(1,i) vyi = vxyz_ptmass(2,i) vzi = vxyz_ptmass(3,i) + if(mi < 0 ) cycle do j=1,nptmass if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) From 6e05b5d6ac01d18e6b5ba80e7bc1adfa73575da0 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 20 Jun 2024 14:27:43 +0200 Subject: [PATCH 627/814] (ptmass) add hsoft to stars --- src/main/ptmass.F90 | 15 ++++++++------- src/main/subgroup.f90 | 3 ++- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index b58e4872b..9f6ee9c24 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1624,9 +1624,9 @@ end subroutine ptmass_create_seeds subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time) use dim, only:maxptmass use physcon, only:solarm,pi - use io, only:iprint,verbose + use io, only:iprint,iverbose use units, only:umass - use part, only:itbirth,ihacc + use part, only:itbirth,ihacc,ihsoft use random , only:ran2,gauss_random,divide_unit_seg use HIIRegion, only:update_ionrate,iH2R integer, intent(in) :: nptmass @@ -1661,7 +1661,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz minmass = 0.08/(mi*(umass/solarm)) call divide_unit_seg(masses,minmass,n,iseed_sf) masses = masses*mi - if(verbose > 1) write(iprint,*) "Mass sharing : ", masses*umass/solarm + if(iverbose > 1) write(iprint,*) "Mass sharing : ", masses*umass/solarm k=i @@ -1700,6 +1700,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz !-- Star creation ! xyzmh_ptmass(ihacc,k) = hacci*1.e-3 + xyzmh_ptmass(ihsoft,k) = h_soft_sinkgas xyzmh_ptmass(4,k) = masses(n) xyzmh_ptmass(3,k) = xi(3) + xk(3) xyzmh_ptmass(2,k) = xi(2) + xk(2) @@ -2142,14 +2143,14 @@ subroutine write_options_ptmass(iunit) call write_inopt(h_soft_sinkgas,'h_soft_sinkgas','softening length for new sink particles', iunit) endif endif - if(use_regnbody) then - call write_inopt(use_regnbody, 'use_regnbody', 'allow subgroup integration method', iunit) - call write_inopt(r_neigh, 'r_neigh', 'searching radius to detect subgroups', iunit) - endif call write_inopt(h_soft_sinksink,'h_soft_sinksink','softening length between sink particles',iunit) call write_inopt(f_acc,'f_acc','particles < f_acc*h_acc accreted without checks',iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) + if(use_regnbody) then + call write_inopt(use_regnbody, 'use_regnbody', 'allow subgroup integration method', iunit) + call write_inopt(r_neigh, 'r_neigh', 'searching radius to detect subgroups', iunit) + endif end subroutine write_options_ptmass diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index ef8bee205..fa1bb4361 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -40,8 +40,9 @@ module subgroup !----------------------------------------------- subroutine init_subgroup use units, only:udist + use physcon, only:pc - r_neigh = r_neigh/udist + r_neigh = r_neigh*(pc/udist) r_search = 100.*r_neigh end subroutine init_subgroup From 289049b08cf40832baf17b589ede9fe7add793fe Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 20 Jun 2024 16:02:36 +0200 Subject: [PATCH 628/814] (subgroups) fix an ugly mistake --- src/main/subgroup.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index fa1bb4361..3a60035bd 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -326,7 +326,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ if (step_count_int > max_step) then print*,"MAX STEP NUMBER, ABORT !!!" - call abort + call abort() endif if ((.not.t_end_flag).and.(dt<0.)) then @@ -612,7 +612,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id integer :: i,j,k,l logical :: init om = 0. - dt_init = 0. + dt_init = huge(om) if (present(ds_init)) then @@ -677,7 +677,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id enddo om = om*0.5 - if (init) ds_init = dt_init/om + if (init) ds_init = dt_init*om end subroutine get_force_TTL From 780d7c45243b204feb877024bc3c3441d7a43e62 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 20 Jun 2024 16:14:07 +0100 Subject: [PATCH 629/814] edit to when cooling called --- src/main/deriv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index 2c72225da..ef9375311 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -194,7 +194,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& ! update energy if using radiative cooling approx (icooling=9) and set fxyzu(4,:) to zero ! print *, "min,max energy", minval(vxyzu(4,1:npart)), maxval(vxyzu(4,1:npart)) - if (icooling == 9 .and. dt > 0.0 .and. icall==1) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) + if (icooling == 9 .and. dt > 0.0 .and. icall==2) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) ! From 1f4a2c6a64030b7c086871c2601feba83704c107 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 21 Jun 2024 09:46:39 +0200 Subject: [PATCH 630/814] (setup) change default values --- src/setup/setup_cluster.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index f3677ce62..6e607921b 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -204,8 +204,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, r_crit = h_acc icreate_sinks = 2 rho_crit_cgs = 1.d-18 - h_soft_sinkgas = 2.*h_acc - tmax_acc = 1*(myr/utime) + h_soft_sinkgas = h_acc + tmax_acc = 0.5*(myr/utime) r_merge_uncond = h_acc use_regnbody = .true. r_neigh = 5e-2*h_acc From 0aea57b7e4c354a1b496df5f2ccd7968824451b9 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 21 Jun 2024 10:25:35 +0200 Subject: [PATCH 631/814] (timing) add timer for subgroups and HII regions --- src/main/H2regions.f90 | 7 ++++--- src/main/subgroup.f90 | 32 +++++++++++++++++++++++++------- src/main/utils_timing.f90 | 12 +++++++++--- 3 files changed, 38 insertions(+), 13 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 84aacbf9b..3b9e5b7ba 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -165,7 +165,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) use linklist, only:listneigh=>listneigh_global,getneigh_pos,ifirstincell use sortutils, only:Knnfunc,set_r2func_origin,r2func_origin use physcon, only:pc,pi - use timing, only: get_timings + use timing, only:get_timings,increment_timer,itimer_HII integer, intent(in) :: nptmass,npart real, intent(in) :: xyzh(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyzu(:,:) @@ -188,6 +188,8 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) ! at each new kick we reset all the particles status isionised(:) = .false. pmass = massoftype(igas) + + call get_timings(t1,tcpu1) ! !-- Rst derivation and thermal feedback ! @@ -210,7 +212,6 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) else hcheck = Rmax endif - call get_timings(t1,tcpu1) call getneigh_pos((/xi,yi,zi/),0.,hcheck,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) call set_r2func_origin(xi,yi,zi) call Knnfunc(nneigh,r2func_origin,xyzh,listneigh) @@ -276,7 +277,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) enddo endif call get_timings(t2,tcpu2) - !print*, "HII feedback CPU time : ",t2-t1 + call increment_timer(itimer_HII,t2-t1,tcpu2-tcpu1) return end subroutine HII_feedback diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 3a60035bd..d575642e9 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -53,17 +53,21 @@ end subroutine init_subgroup ! !----------------------------------------------- subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix,dtext) - use io ,only:id,master,iverbose,iprint + use io, only:id,master,iverbose,iprint + use timing, only:get_timings,increment_timer,itimer_sg_id integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer, intent(inout) :: group_info(3,nptmass) integer, intent(inout) :: n_group,n_ingroup,n_sing integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) real, optional, intent(in) :: dtext - logical :: large_search + real(kind=4) :: t1,t2,tcpu1,tcpu2 + logical :: large_search + - large_search = present(dtext) + large_search = present(dtext) + call get_timings(t1,tcpu1) n_group = 0 n_ingroup = 0 n_sing = 0 @@ -80,6 +84,11 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm write(iprint,"(i6,a,i6,a,i6,a)") n_group," groups identified, ",n_ingroup," in a group, ",n_sing," singles..." endif + call get_timings(t2,tcpu2) + call increment_timer(itimer_sg_id,t2-t1,tcpu2-tcpu1) + + + end subroutine group_identify @@ -227,14 +236,20 @@ end subroutine matrix_construction !--------------------------------------------- subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - use part, only: igarg,igcum - use io, only: id,master - use mpiutils,only:bcast_mpi + use part, only:igarg,igcum + use io, only:id,master + use mpiutils, only:bcast_mpi + use timing, only:get_timings,increment_timer,itimer_sg_evol integer, intent(in) :: n_group,nptmass real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) real, intent(in) :: tnext,time - integer :: i,start_id,end_id,gsize + integer :: i,start_id,end_id,gsize + real(kind=4) :: t1,t2,tcpu1,tcpu2 + + + call get_timings(t1,tcpu1) + if (n_group>0) then if (id==master) then !$omp parallel do default(none)& @@ -254,6 +269,9 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + call get_timings(t2,tcpu2) + call increment_timer(itimer_sg_evol,t2-t1,tcpu2-tcpu1) + end subroutine evolve_groups diff --git a/src/main/utils_timing.f90 b/src/main/utils_timing.f90 index c9ec91558..850c0450e 100644 --- a/src/main/utils_timing.f90 +++ b/src/main/utils_timing.f90 @@ -61,9 +61,12 @@ module timing itimer_rad_store = 20, & itimer_cons2prim = 21, & itimer_extf = 22, & - itimer_ev = 23, & - itimer_io = 24 - integer, public, parameter :: ntimers = 24 ! should be equal to the largest itimer index + itimer_sg_id = 23, & + itimer_sg_evol = 24, & + itimer_HII = 25, & + itimer_ev = 26, & + itimer_io = 27 + integer, public, parameter :: ntimers = 27 ! should be equal to the largest itimer index type(timer), public :: timers(ntimers) private @@ -92,6 +95,7 @@ subroutine setup_timers call init_timer(itimer_force , 'force', itimer_step ) call init_timer(itimer_force_local , 'local', itimer_force ) call init_timer(itimer_force_remote, 'remote', itimer_force ) + call init_timer(itimer_HII , 'HII_regions', itimer_step ) call init_timer(itimer_radiation , 'radiation', itimer_step ) call init_timer(itimer_rad_save , 'save', itimer_radiation ) call init_timer(itimer_rad_neighlist,'neighlist', itimer_radiation ) @@ -103,6 +107,8 @@ subroutine setup_timers call init_timer(itimer_rad_store , 'store', itimer_radiation ) call init_timer(itimer_cons2prim , 'cons2prim', itimer_step ) call init_timer(itimer_extf , 'extf', itimer_step ) + call init_timer(itimer_sg_id , 'subg_id', itimer_extf ) + call init_timer(itimer_sg_evol , 'subg_evol', itimer_extf ) call init_timer(itimer_ev , 'write_ev', 0 ) call init_timer(itimer_io , 'write_dump', 0 ) From 72f7f1ef3a4129bce80b70a5291c1539fd15f0fe Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 21 Jun 2024 13:43:58 +0200 Subject: [PATCH 632/814] implement new intel ifx compiler setup --- build/MakeKrome | 3 +++ build/Makefile | 1 + build/Makefile_defaults_ifx | 17 +++++++++++++++++ build/Makefile_systems | 5 +++++ 4 files changed, 26 insertions(+) create mode 100644 build/Makefile_defaults_ifx diff --git a/build/MakeKrome b/build/MakeKrome index 0171e2408..ffa537545 100644 --- a/build/MakeKrome +++ b/build/MakeKrome @@ -6,6 +6,9 @@ KROME_BUILD_DIR = ${KROMEPATH}/build KFLAGS=$(filter-out -std=f2008, $(FFLAGS)) ifeq ($(SYSTEM), ifort) KFLAGS += -O3 -ipo -ip -unroll -xHost -g -fp-model precise +else +ifeq ($(SYSTEM), ifx) + KFLAGS += -O3 -ipo -ip -unroll -xHost -g -fp-model precise else KFLAGS += -ffree-line-length-none -w -fallow-argument-mismatch endif diff --git a/build/Makefile b/build/Makefile index 646826dca..a6a52c554 100644 --- a/build/Makefile +++ b/build/Makefile @@ -1286,6 +1286,7 @@ giza-fortran.o : $(SPLASH_DIR)/giza/interface/giza-fortran.F90 $(SPLASH_DIR)/giz compilers: @echo "I suggest one of the following, based on detected Fortran compilers..."; echo; + @if type -p ifx > /dev/null; then echo "make SYSTEM=ifx"; fi; @if type -p ifort > /dev/null; then echo "make SYSTEM=ifort"; fi; @if type -p pathf90 > /dev/null; then echo "make SYSTEM=pathf90"; fi; @if type -p pgf90 > /dev/null; then echo "make SYSTEM=pgf90"; fi; diff --git a/build/Makefile_defaults_ifx b/build/Makefile_defaults_ifx new file mode 100644 index 000000000..1e00e3918 --- /dev/null +++ b/build/Makefile_defaults_ifx @@ -0,0 +1,17 @@ +# default settings for ifx compiler +# override these in the Makefile +FC= ifx +#FFLAGS= -O3 -inline-factor=500 -shared-intel -warn uninitialized -warn unused -warn truncated_source -no-wrap-margin +FFLAGS= -O3 -shared-intel -warn uninitialized -warn unused -warn truncated_source -no-wrap-margin +DBLFLAG= -r8 +DEBUGFLAG= -check all -WB -traceback -g -debug all # -fpe0 -fp-stack-check -debug all -noarg_temp_created +#DEBUGFLAG= -g -traceback -check all -check bounds -check uninit -ftrapuv -debug all -warn all,nodec,interfaces,nousage -fpe0 -fp-stack-check -WB -no-diag-error-limit -no-wrap-margin -O0 -noarg_temp_created +ENDIANFLAGBIG= -convert big_endian +ENDIANFLAGLITTLE= -convert little_endian +# or use setenv F_UFMTENDIAN=big:45 at runtime (e.g. for unit 45 only) +CC = icc +CCFLAGS = -O3 +LIBCXX = -cxxlib +KNOWN_SYSTEM=yes + +OMPFLAGS= -qopenmp diff --git a/build/Makefile_systems b/build/Makefile_systems index d38bd096e..4a3c950f3 100644 --- a/build/Makefile_systems +++ b/build/Makefile_systems @@ -179,6 +179,11 @@ ifeq ($(SYSTEM), ifort) include Makefile_defaults_ifort endif +ifeq ($(SYSTEM), ifx) +# default settings for the new Intel Fortran Compiler + include Makefile_defaults_ifx +endif + ifeq ($(SYSTEM), ifortmac) # default settings for the Intel Fortran Compiler on Mac OS include Makefile_defaults_ifort From 9393ed11e06148dd3df126a260d694144d70db98 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Fri, 21 Jun 2024 14:21:04 +0200 Subject: [PATCH 633/814] stupid bug fix --- build/MakeKrome | 1 + 1 file changed, 1 insertion(+) diff --git a/build/MakeKrome b/build/MakeKrome index ffa537545..7de5d0c75 100644 --- a/build/MakeKrome +++ b/build/MakeKrome @@ -12,6 +12,7 @@ ifeq ($(SYSTEM), ifx) else KFLAGS += -ffree-line-length-none -w -fallow-argument-mismatch endif +endif FFLAGS+= -I$(KROME_BUILD_DIR) PASSED=0 From 88c14f01e553b2b2a7fa17dbd6be905172bfcfa1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 21 Jun 2024 15:03:41 +0200 Subject: [PATCH 634/814] (test_ptmass) add a unit test for HII region feedback --- src/main/H2regions.f90 | 38 +++++++++++------------- src/tests/test_ptmass.f90 | 62 ++++++++++++++------------------------- 2 files changed, 39 insertions(+), 61 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 3b9e5b7ba..661ba91c4 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -25,23 +25,23 @@ module HIIRegion real , public :: Rmax = 15 ! Maximum HII region radius (pc) to avoid artificial expansion... real , public :: Mmin = 8 ! Minimum mass (Msun) to produce HII region real , public :: nHIIsources = 0 + real , public :: ar + real , public :: mH - real, private, parameter :: a = -39.3178 ! - real, private, parameter :: b = 221.997 ! fitted parameters to compute - real, private, parameter :: c = -227.456 ! ionisation rate for massive - real, private, parameter :: d = 117.410 ! extracted from Fujii et al. (2021). - real, private, parameter :: e = -30.1511 ! (Expressed in function of log(solar masses) and s) - real, private, parameter :: f = 3.06810 ! - real, private, parameter :: ar_cgs = 2.7d-13 - real, private, parameter :: sigd_cgs = 1.d-21 - real, private :: ar - real, private :: sigd - real, private :: hv_on_c - real, private :: mH - real, private :: T_ion - real, private :: u_to_t - real, private :: Rst_max - real, private :: Minmass + real, parameter :: a = -39.3178 ! + real, parameter :: b = 221.997 ! fitted parameters to compute + real, parameter :: c = -227.456 ! ionisation rate for massive + real, parameter :: d = 117.410 ! extracted from Fujii et al. (2021). + real, parameter :: e = -30.1511 ! (Expressed in function of log(solar masses) and s) + real, parameter :: f = 3.06810 ! + real, parameter :: ar_cgs = 2.7d-13 + real, parameter :: sigd_cgs = 1.d-21 + real :: sigd + real :: hv_on_c + real :: T_ion + real :: u_to_t + real :: Rst_max + real :: Minmass private @@ -203,9 +203,6 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) stromi = xyzmh_ptmass(irstrom,i) - ! for each source we compute the distances of each particles and sort to have a Knn list - ! Patch : We need to be aware of dead particles that will pollute the scheme if not taking into account. - ! The simpliest way is to put enormous distance for dead particle to be at the very end of the knn list. if(stromi > 0 ) then hcheck = 2.*stromi if (hcheck > Rmax) hcheck = Rmax @@ -218,10 +215,9 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) do k=1,npart j = listneigh(k) if (.not. isdead_or_accreted(xyzh(4,j))) then - ! calculation of the ionised mass + ! ionising photons needed to fully ionise the current particle DNdot = (pmass*ar*rhoh(xyzh(4,j),pmass))/(mH**2) if (Ndot>DNdot) then - ! iteration on the Knn until we used all the source photons if (.not.(isionised(j))) then Ndot = Ndot - DNdot isionised(j)=.true. diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 40396532e..f40791f8f 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -1146,30 +1146,27 @@ subroutine test_HIIregion(ntests,npass) use eos_HIIR, only:polykion,init_eos_HIIR use eos, only:gmw,ieos,polyk,gamma use deriv, only:get_derivs_global - use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fext, & + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass, & npart,ihacc,irstrom,xyzh,vxyzu,hfact,igas, & npartoftype,fxyzu,massoftype,isionised,init_part,& - iphase,isetphase,irateion + iphase,isetphase,irateion,irstrom use ptmass, only:h_acc use step_lf_global, only:init_step,step - use timestep, only:dtmax - use energies, only:compute_energies,angtot,totmom,mtot use spherical, only:set_sphere - use units, only:set_units,utime,unit_velocity,udist + use units, only:set_units,utime,unit_velocity,udist,umass use physcon, only:pc,solarm,years,pi,kboltz,mass_proton_cgs use kernel, only: hfact_default use kdtree, only:tree_accuracy - use HIIRegion, only:initialize_H2R,update_ionrate,HII_feedback,iH2R,nHIIsources - use timing, only:get_timings + use testutils, only: checkval,update_test_scores + use HIIRegion, only:initialize_H2R,update_ionrate,HII_feedback,iH2R,nHIIsources,ar,mH integer, intent(inout) :: ntests,npass - integer :: np,i - real :: totmass,tmax,t,dt,dtext,dtnew,psep - real :: Rsp,Rspi,ci,k + integer :: np,i,nfailed(1) + real :: totmass,psep + real :: Rstrom,ci,k,rho0 real :: totvol,nx,rmin,rmax,temp - real(kind=4) :: t1,t2,tcpu1,tcpu2 if (id==master) write(*,"(/,a)") '--> testing HII region expansion around massive stars...' - call set_units(dist=1.*pc,mass=1.*solarm,G=1.d0) + call set_units(dist=pc,mass=solarm,G=1.d0) call init_eos_HIIR() iverbose = 1 ! @@ -1177,7 +1174,6 @@ subroutine test_HIIregion(ntests,npass) ! call init_part() gmw = 1.0 - ieos = 1 xyzmh_ptmass(:,:) = 0. vxyz_ptmass(:,:) = 0. @@ -1185,19 +1181,17 @@ subroutine test_HIIregion(ntests,npass) h_acc = 0.002 xyzmh_ptmass(4,1) = -1 - xyzmh_ptmass(5,1) = 1e-3*h_acc - xyzmh_ptmass(irateion,1) = (10.**49.)*utime + xyzmh_ptmass(irateion,1) = (10.**49.)*utime ! rate_ion [s^-1] nptmass = 1 nHIIsources = 1 - t = 0. hfact = 1.2 gamma = 1. rmin = 0. - rmax = 2.91 + rmax = 2.91*pc/udist ieos = 21 tree_accuracy = 0.5 - temp = 1000 + temp = 1000. ! !--setup particles ! @@ -1208,7 +1202,7 @@ subroutine test_HIIregion(ntests,npass) npart = 0 ! only set up particles on master, otherwise we will end up with n duplicates if (id==master) then - call set_sphere('random',id,master,rmin,rmax,psep,hfact,npart,xyzh,np_requested=np) + call set_sphere('cubic',id,master,rmin,rmax,psep,hfact,npart,xyzh,np_requested=np) endif np = npart @@ -1216,7 +1210,7 @@ subroutine test_HIIregion(ntests,npass) ! !--set particle properties ! - totmass = 8.e3 + totmass = 8.e3*solarm/umass npartoftype(:) = 0 npartoftype(igas) = npart massoftype(:) = 0.0 @@ -1234,35 +1228,23 @@ subroutine test_HIIregion(ntests,npass) !call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) endif - Rspi = 0.310278984 !xyzmh_ptmass(irstrom,1) + rho0 = totmass/totvol + + Rstrom = ((3*xyzmh_ptmass(irateion,1)*mH**2)/(4*pi*ar*rho0**2))**(1./3.) ci = sqrt(polykion) k = 0.005 - Rsp = Rspi - polyk = kboltz*temp/(gmw*mass_proton_cgs)*((utime/udist)**2) + polyk = (kboltz*temp)/(gmw*mass_proton_cgs)*((unit_velocity)**2) vxyzu(:,:) = 0. fxyzu(:,:) = 0. + call get_derivs_global() + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) - tmax = (3.e6*years)/utime - t = 0. - dt = 0.00001 - dtmax = dt*100 - dtext = dt - dtnew = dt + call checkval(xyzmh_ptmass(irstrom,1),Rstrom,1.e-2,nfailed(1),'Initial strömgren radius') - call init_step(npart,t,dtmax) - do while (t < tmax) - t = t + dt - call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) - call get_timings(t1,tcpu1) - call step(npart,npart,t,dt,dtext,dtnew) - call get_timings(t2,tcpu2) - print*, "STEP CPU time : ",t2-t1 - Rsp = Rsp + (ci*((Rspi/Rsp)**(3./4.) - k*(Rspi/Rsp)**(-3./4.)))*dt - print*,"R stromgren (analytic,prescription)",Rsp , xyzmh_ptmass(irstrom,1) - enddo + call update_test_scores(ntests,nfailed,npass) end subroutine test_HIIregion From f0eab6a7dd2aa0e8df40553b99ee0b0569102d81 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 21 Jun 2024 15:04:46 +0200 Subject: [PATCH 635/814] (timing) rename extf timer to substep to be more consistent --- src/main/evolve.F90 | 2 +- src/main/step_leapfrog.F90 | 4 ++-- src/main/subgroup.f90 | 20 ++++++++++++++------ src/main/utils_deriv.f90 | 2 +- src/main/utils_timing.f90 | 8 ++++---- 5 files changed, 22 insertions(+), 14 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 1193f1023..b92643c1b 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -666,7 +666,7 @@ subroutine print_timinginfo(iprint,nsteps,nsteplast) use io, only:formatreal use timing, only:timer,timers,print_timer,itimer_fromstart,itimer_lastdump,& itimer_step,itimer_link,itimer_balance,itimer_dens,& - itimer_force,itimer_extf,itimer_ev,itimer_io,ntimers + itimer_force,itimer_ev,itimer_io,ntimers integer, intent(in) :: iprint,nsteps,nsteplast real :: dfrac,fracinstep real(kind=4) :: time_fullstep diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index f9feba8b0..4aa06ab7b 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -118,7 +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 - use timing, only:increment_timer,get_timings,itimer_extf + use timing, only:increment_timer,get_timings,itimer_substep use growth, only:check_dustprop use options, only:use_porosity use porosity, only:get_filfac @@ -258,7 +258,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif endif call get_timings(t2,tcpu2) - call increment_timer(itimer_extf,t2-t1,tcpu2-tcpu1) + call increment_timer(itimer_substep,t2-t1,tcpu2-tcpu1) timei = timei + dtsph nvfloorps = 0 diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index d575642e9..b46786532 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -67,25 +67,29 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm large_search = present(dtext) - call get_timings(t1,tcpu1) n_group = 0 n_ingroup = 0 n_sing = 0 if (nptmass > 0) then + + call get_timings(t1,tcpu1) + if(large_search) then call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) else call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) endif call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + + call get_timings(t2,tcpu2) + call increment_timer(itimer_sg_id,t2-t1,tcpu2-tcpu1) + endif if (id==master .and. iverbose>1) then write(iprint,"(i6,a,i6,a,i6,a)") n_group," groups identified, ",n_ingroup," in a group, ",n_sing," singles..." endif - call get_timings(t2,tcpu2) - call increment_timer(itimer_sg_id,t2-t1,tcpu2-tcpu1) @@ -248,9 +252,11 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz real(kind=4) :: t1,t2,tcpu1,tcpu2 - call get_timings(t1,tcpu1) if (n_group>0) then + + call get_timings(t1,tcpu1) + if (id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& @@ -264,13 +270,15 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz enddo !$omp end parallel do endif + + call get_timings(t2,tcpu2) + call increment_timer(itimer_sg_evol,t2-t1,tcpu2-tcpu1) + endif call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) call bcast_mpi(vxyz_ptmass(:,1:nptmass)) - call get_timings(t2,tcpu2) - call increment_timer(itimer_sg_evol,t2-t1,tcpu2-tcpu1) end subroutine evolve_groups diff --git a/src/main/utils_deriv.f90 b/src/main/utils_deriv.f90 index 29fcb1ecc..d45676930 100644 --- a/src/main/utils_deriv.f90 +++ b/src/main/utils_deriv.f90 @@ -16,7 +16,7 @@ module derivutils ! ! :Dependencies: io, mpiutils, timing ! - use timing, only: timers,itimer_dens,itimer_force,itimer_link,itimer_extf,itimer_balance,itimer_cons2prim,& + use timing, only: timers,itimer_dens,itimer_force,itimer_link,itimer_balance,itimer_cons2prim,& itimer_radiation,itimer_rad_save,itimer_rad_neighlist,itimer_rad_arrays,itimer_rad_its,& itimer_rad_flux,itimer_rad_diff,itimer_rad_update,itimer_rad_store diff --git a/src/main/utils_timing.f90 b/src/main/utils_timing.f90 index 850c0450e..e45c44178 100644 --- a/src/main/utils_timing.f90 +++ b/src/main/utils_timing.f90 @@ -60,7 +60,7 @@ module timing itimer_rad_update = 19, & itimer_rad_store = 20, & itimer_cons2prim = 21, & - itimer_extf = 22, & + itimer_substep = 22, & itimer_sg_id = 23, & itimer_sg_evol = 24, & itimer_HII = 25, & @@ -106,9 +106,9 @@ subroutine setup_timers call init_timer(itimer_rad_update , 'update', itimer_rad_its ) call init_timer(itimer_rad_store , 'store', itimer_radiation ) call init_timer(itimer_cons2prim , 'cons2prim', itimer_step ) - call init_timer(itimer_extf , 'extf', itimer_step ) - call init_timer(itimer_sg_id , 'subg_id', itimer_extf ) - call init_timer(itimer_sg_evol , 'subg_evol', itimer_extf ) + call init_timer(itimer_substep , 'substep', itimer_step ) + call init_timer(itimer_sg_id , 'subg_id', itimer_substep ) + call init_timer(itimer_sg_evol , 'subg_evol', itimer_substep ) call init_timer(itimer_ev , 'write_ev', 0 ) call init_timer(itimer_io , 'write_dump', 0 ) From 0b88f51630adca6978ff7876458b3ba8bcc049ae Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 21 Jun 2024 16:04:44 +0200 Subject: [PATCH 636/814] (setup_cluster) relax the particles in cluster setup --- src/main/H2regions.f90 | 2 +- src/setup/setup_cluster.f90 | 6 +++++- src/tests/test_ptmass.f90 | 2 +- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 661ba91c4..cd52890d1 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -69,7 +69,7 @@ subroutine initialize_H2R hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) Rst_max = sqrt(((Rmax*pc)/udist)**2) Minmass = (Mmin*solarm)/umass - if (id == master .and. iverbose > 0) then + if (id == master .and. iverbose > 1) then write(iprint,"(/a,es18.10,es18.10/)") "feedback constants mH, u_to_t : ", mH, u_to_t write(iprint,"(/a,es18.10,es18.10/)") "Max strögrem radius (code/pc) : ", Rst_max, Rmax write(iprint,"(/a,es18.10,es18.10/)") "Min feedback mass (code/Msun) : ", Minmass, Mmin diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 6e607921b..65efb4f1f 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -50,7 +50,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use setup_params, only:rmax,rhozero,npart_total use spherical, only:set_sphere use part, only:igas,set_particle_type - use io, only:fatal,master + use io, only:fatal,master,iprint use units, only:umass,udist,utime,set_units use setvfield, only:normalise_vfield use timestep, only:dtmax,tmax @@ -63,6 +63,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use mpidomain, only:i_belong use HIIRegion, only:iH2R use subgroup, only:r_neigh + use utils_shuffleparticles, only:shuffleparticles integer, intent(in) :: id integer, intent(out) :: npart integer, intent(out) :: npartoftype(:) @@ -178,6 +179,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_particle_type(i,igas) enddo + call shuffleparticles(iprint,npart,xyzh,massoftype(1),rsphere=rmax,dsphere=rhozero,dmedium=0.,& + is_setup=.true.,prefix=trim(fileprefix)) + !--Set velocities (from pre-made velocity cubes) write(*,"(1x,a)") 'Setting up velocity field on the particles...' vxyzu(:,:) = 0. diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index f40791f8f..55ba7ad67 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -1168,7 +1168,7 @@ subroutine test_HIIregion(ntests,npass) call set_units(dist=pc,mass=solarm,G=1.d0) call init_eos_HIIR() - iverbose = 1 + iverbose = 0 ! ! initialise arrays to zero ! From 79466cbbad61c55cfe078d1de00da8a4b61f1498 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 21 Jun 2024 16:17:31 +0100 Subject: [PATCH 637/814] Batch 1 of upstream changes added --- .github/workflows/build.yml | 67 +-- .github/workflows/krome.yml | 4 +- .github/workflows/mcfost.yml | 16 +- .github/workflows/release.yml | 2 +- .github/workflows/test.yml | 33 +- .gitignore | 4 + AUTHORS | 35 +- build/Makefile | 7 +- build/Makefile_setups | 13 +- docs/inject_sim.rst | 73 ++++ scripts/buildbot.sh | 10 +- src/main/checkconserved.f90 | 8 +- src/main/checksetup.f90 | 32 +- src/main/cooling.f90 | 19 +- src/main/cooling_radapprox.f90 | 4 + src/main/deriv.F90 | 37 +- src/main/dust_formation.f90 | 10 +- src/main/evolve.F90 | 2 +- src/main/inject_keplerian.f90 | 257 +++++++++++ src/main/part.F90 | 20 + src/main/ptmass.F90 | 93 ++-- src/main/subgroup.f90 | 756 +++++++++++++++++++++++++++++++++ src/main/substepping.F90 | 223 +++++++--- src/main/utils_dumpfiles.f90 | 86 ++-- src/main/utils_infiles.f90 | 20 +- src/main/utils_kepler.f90 | 139 ++++++ src/main/utils_subgroup.f90 | 35 ++ src/main/wind.F90 | 20 +- src/main/wind_equations.f90 | 5 +- src/setup/set_orbit.f90 | 285 +++++++++++++ 30 files changed, 1989 insertions(+), 326 deletions(-) create mode 100644 docs/inject_sim.rst create mode 100644 src/main/inject_keplerian.f90 create mode 100644 src/main/subgroup.f90 create mode 100644 src/main/utils_kepler.f90 create mode 100644 src/main/utils_subgroup.f90 create mode 100644 src/setup/set_orbit.f90 diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index dccaebd65..06cf95e96 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -11,8 +11,6 @@ on: paths-ignore: - 'docs/**' - 'README.md' -# schedule: -# - cron: "0 0 * * *" env: OMP_STACKSIZE: 512M @@ -22,13 +20,10 @@ env: WEB_SERVER: data.phantom.cloud.edu.au WEB_HTML_DIR: /var/www/html BUILD_LOG_DIR: /ci/build/logs - RSYNC_RSH: ssh -o "StrictHostKeyChecking=no" -o "UserKnownHostsFile=/dev/null" NPARALLEL: 32 jobs: matrix_prep: - # Skip scheduled runs on forks - if: ${{ github.event_name != 'schedule' || github.repository == 'danieljprice/phantom' }} runs-on: ubuntu-latest outputs: batch: ${{ steps.set-sequence.outputs.batch }} @@ -70,40 +65,11 @@ jobs: - name: Update package list run: sudo apt-get update - - name: Setup Intel repo + - name: Setup Intel compiler if: matrix.system == 'ifort' - id: intel-repo - run: | - wget https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - rm GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - sudo echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list - sudo apt-get update - INTELVERSION=$(apt-cache show intel-oneapi-compiler-fortran | grep Version | head -1) - echo "::set-output name=intelversion::$INTELVERSION" - - - name: Cache intel installation - if: matrix.system == 'ifort' - id: cache-intel - uses: actions/cache@v3 + uses: fortran-lang/setup-fortran@v1 with: - path: | - /opt/intel - key: ${{ steps.intel-repo.outputs.intelversion }} - - - name: Install Intel compilers - if: ${{ steps.cache-intel.outputs.cache-hit != 'true' && matrix.system == 'ifort' }} - run: | - sudo apt-get install -y intel-oneapi-common-vars - sudo apt-get install -y intel-oneapi-compiler-fortran - sudo apt-get install -y intel-oneapi-mpi - sudo apt-get install -y intel-oneapi-mpi-devel - - - name: Setup Intel oneAPI environment - if: matrix.system == 'ifort' - run: | - source /opt/intel/oneapi/setvars.sh - printenv >> $GITHUB_ENV + compiler: intel-classic - name: Install numpy and matplotlib for analysis unit tests run: | @@ -111,10 +77,10 @@ jobs: sudo apt-get install -y python3-matplotlib - name: "Clone phantom" - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: "Grab a copy of splash source code" - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: repository: danieljprice/splash path: splash @@ -123,12 +89,6 @@ jobs: if: github.event_name == 'schedule' run: mkdir logs -# - name: "Grab previous build logs from web server" -# if: github.event_name == 'schedule' -# env: -# WGET: wget --recursive --no-parent --reject "index.html*" --cut-dirs=2 --no-host-directories -# run: ${WGET} -A '*${{ matrix.system[1] }}.txt' http://${WEB_SERVER}${BUILD_LOG_DIR}/ || true - - name: "Run buildbot.sh" run: ./buildbot.sh --maxdim 17000000 --url http://${WEB_SERVER}/${BUILD_LOG_DIR} --parallel ${{ matrix.batch }} ${{ env.NPARALLEL }} working-directory: scripts @@ -136,23 +96,6 @@ jobs: SYSTEM: ${{ matrix.system }} RETURN_ERR: yes -# - name: "Install SSH Key" -# if: github.event_name == 'schedule' -# uses: webfactory/ssh-agent@v0.5.3 -# with: -# ssh-private-key: ${{ secrets.RUNNER_PRIVATE_KEY }} - -# - name: "Copy new build logs to web server" -# if: ${{ (success() || failure()) && github.event_name == 'schedule' }} -# run: rsync -vau logs/*.txt ${WEB_USER}@${WEB_SERVER}:${WEB_HTML_DIR}/${BUILD_LOG_DIR} - -# - name: "Copy HTML files to web server" -# if: ${{ (success() || failure()) && github.event_name == 'schedule' }} -# run: | -# export WEB_BUILD_DIR=${WEB_HTML_DIR}/nightly/build/$(date "+%Y%m%d") -# ssh -o "StrictHostKeyChecking=no" -o "UserKnownHostsFile=/dev/null" ${WEB_USER}@${WEB_SERVER} -- mkdir -p ${WEB_BUILD_DIR} -# rsync -vau logs/*.html ${WEB_USER}@${WEB_SERVER}:${WEB_BUILD_DIR}/ - - name: logs/build-failures-${{ matrix.system }}.txt if: always() run: cat logs/build-failures-${{ matrix.system }}.txt || true diff --git a/.github/workflows/krome.yml b/.github/workflows/krome.yml index 51302f869..9aa573f2f 100644 --- a/.github/workflows/krome.yml +++ b/.github/workflows/krome.yml @@ -12,6 +12,7 @@ env: PREFIX: /usr/local/ PHANTOM_DIR: ${{ github.workspace }} KROMEPATH: ${{ github.workspace }}/krome + FC: gfortran # default if not overwritten by matrix # A workflow run is made up of one or more jobs that can run sequentially or in parallel jobs: @@ -27,7 +28,8 @@ jobs: toolchain: {compiler: intel-classic} steps: - - uses: awvwgk/setup-fortran@v1 + - name: "Install gfortran compiler" + uses: fortran-lang/setup-fortran@v1 with: compiler: ${{ matrix.toolchain.compiler }} diff --git a/.github/workflows/mcfost.yml b/.github/workflows/mcfost.yml index 4860e7ed8..1aac9e0ef 100644 --- a/.github/workflows/mcfost.yml +++ b/.github/workflows/mcfost.yml @@ -9,7 +9,7 @@ on: - 'README.md' env: - PREFIX: /usr/local/ + PREFIX: /opt/homebrew MCFOST_GIT: 1 SYSTEM: gfortran HOMEBREW_NO_INSTALL_CLEANUP: 1 @@ -23,13 +23,13 @@ jobs: # Steps represent a sequence of tasks that will be executed as part of the job steps: - - name: install gfortran - run: brew install gfortran + - name: install gfortran compiler + uses: fortran-lang/setup-fortran@v1 + with: + compiler: gcc - - name: soft link gfortran and check version - run: | - ln -s `ls $PREFIX/bin/gfortran-* | tail -1` $PREFIX/bin/gfortran - gfortran -v + - name: Check gfortran version + run: gfortran --version - name: tap the homebrew repo run: brew tap danieljprice/all @@ -38,7 +38,7 @@ jobs: run: brew install mcfost - name: "Clone phantom" - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: "Compile phantom and link with mcfost" run: make SETUP=disc MCFOST=yes PREFIX=${PREFIX} LIBCXX=-lc++ diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index bdba8393f..ca868d95d 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -20,7 +20,7 @@ jobs: # Steps represent a sequence of tasks that will be executed as part of the job steps: - name: checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index d78ab7eb4..3c7a977e0 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -53,38 +53,9 @@ jobs: - name: Setup Intel repo if: matrix.system == 'ifort' - id: intel-repo - run: | - wget https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - rm GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB - sudo echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list - sudo apt-get update - INTELVERSION=$(apt-cache show intel-oneapi-compiler-fortran | grep Version | head -1) - echo "::set-output name=intelversion::$INTELVERSION" - - - name: Cache intel installation - if: matrix.system == 'ifort' - id: cache-intel - uses: actions/cache@v3 + uses: fortran-lang/setup-fortran@v1 with: - path: | - /opt/intel - key: ${{ steps.intel-repo.outputs.intelversion }} - - - name: Install Intel compilers - if: ${{ steps.cache-intel.outputs.cache-hit != 'true' && matrix.system == 'ifort' }} - run: | - sudo apt-get install -y intel-oneapi-common-vars - sudo apt-get install -y intel-oneapi-compiler-fortran - sudo apt-get install -y intel-oneapi-mpi - sudo apt-get install -y intel-oneapi-mpi-devel - - - name: Setup Intel oneAPI environment - if: matrix.system == 'ifort' - run: | - source /opt/intel/oneapi/setvars.sh - printenv >> $GITHUB_ENV + compiler: intel-classic - name: "Clone phantom" uses: actions/checkout@v4 diff --git a/.gitignore b/.gitignore index 992380c36..4b9ae030f 100644 --- a/.gitignore +++ b/.gitignore @@ -23,3 +23,7 @@ build/phantom-version.h *.tar .DS_Store _build +*.cmdx +*.cmod +*.ilm +*.stb diff --git a/AUTHORS b/AUTHORS index b139408e6..f236e7dc4 100644 --- a/AUTHORS +++ b/AUTHORS @@ -21,10 +21,10 @@ Rebecca Nealon Elisabeth Borchert Ward Homan Christophe Pinte +Yrisch Terrence Tricco Stephane Michoulier Simone Ceppi -Yrisch Spencer Magnall Enrico Ragusa Caitlyn Hardiman @@ -32,41 +32,42 @@ Sergei Biriukov Cristiano Longarini Giovanni Dipierro Roberto Iaconi -Amena Faruqi Hauke Worpel +Amena Faruqi Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi -Simon Glover -Sahl Rowther Thomas Reichardt +Sahl Rowther +Simon Glover Jean-François Gonzalez Christopher Russell +Phantom benchmark bot +Jolien Malfait Alex Pettitt Alessia Franchini -Jolien Malfait -Phantom benchmark bot -Nicole Rodrigues Kieran Hirsh -Farzana Meru +Nicole Rodrigues +Mike Lau Nicolás Cuello +Farzana Meru David Trevascus -Mike Lau -Miguel Gonzalez-Bolivar Chris Nixon -Orsola De Marco +Miguel Gonzalez-Bolivar Maxime Lombart Joe Fisher Giulia Ballabio -Benoit Commercon Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> -Steven Rieder -Taj Jankovič -Chunliang Mu +Benoit Commercon +Orsola De Marco MICHOULIER Stephane -Jorge Cuadra +Stéven Toupin +Taj Jankovič Cox, Samuel Jeremy Smallwood -Stéven Toupin +Hugh Griffiths +Chunliang Mu +Jorge Cuadra +Steven Rieder diff --git a/build/Makefile b/build/Makefile index 6a833e926..96454f9b3 100644 --- a/build/Makefile +++ b/build/Makefile @@ -534,8 +534,9 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ mpi_memory.f90 mpi_derivs.F90 mpi_tree.F90 kdtree.F90 linklist_kdtree.F90 utils_healpix.f90 utils_raytracer.f90 \ partinject.F90 utils_inject.f90 dust_formation.f90 ptmass_radiation.f90 ptmass_heating.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ - ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ - ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} \ + ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 \ + ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} ${SRCINJECT} \ + utils_subgroup.f90 utils_kepler.f90 subgroup.f90\ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ @@ -653,7 +654,7 @@ phantomsetup: setup SRCSETUP= prompting.f90 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_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 \ set_vfield.f90 set_Bfield.f90 \ diff --git a/build/Makefile_setups b/build/Makefile_setups index 55347ffb0..d5f34b9a5 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -186,6 +186,7 @@ ifeq ($(SETUP), radiotde) IND_TIMESTEPS=no ANALYSIS=analysis_radiotde.f90 MODFILE=moddump_radiotde.f90 + SRCINJECT=inject_sim.f90 SYSTEM=gfortran endif @@ -455,7 +456,6 @@ ifeq ($(SETUP), nimhdshock) NONIDEALMHD=yes KERNEL=WendlandC4 ISOTHERMAL=yes - MAXP=6000000 KNOWN_SETUP=yes endif @@ -738,7 +738,6 @@ ifeq ($(SETUP), star) MODFILE= utils_binary.f90 set_binary.f90 moddump_binary.f90 ANALYSIS= ${SRCNIMHD} utils_summary.o utils_omp.o ptmass.o energies.o analysis_common_envelope.f90 KNOWN_SETUP=yes - MAXP=10000000 GRAVITY=yes endif @@ -751,7 +750,6 @@ ifeq ($(SETUP), grstar) MODFILE= moddump_tidal.f90 ANALYSIS= ${SRCNIMHD} utils_summary.o utils_omp.o ptmass.o energies.o analysis_common_envelope.f90 KNOWN_SETUP=yes - MAXP=100000000 GRAVITY=yes endif @@ -761,7 +759,6 @@ ifeq ($(SETUP), radstar) MODFILE= utils_binary.f90 set_binary.f90 moddump_binary.f90 ANALYSIS= ${SRCNIMHD} utils_summary.o utils_omp.o ptmass.o energies.o analysis_common_envelope.f90 KNOWN_SETUP=yes - MAXP=10000000 GRAVITY=yes RADIATION=yes endif @@ -773,7 +770,6 @@ ifeq ($(SETUP), dustystar) MODFILE= utils_binary.f90 set_binary.f90 moddump_binary.f90 ANALYSIS= ${SRCNIMHD} utils_summary.o utils_omp.o ptmass.o energies.o analysis_common_envelope.f90 dust_formation.f90 KNOWN_SETUP=yes - MAXP=10000000 GRAVITY=yes SINK_RADIATION=yes endif @@ -927,10 +923,11 @@ ifeq ($(SETUP), isosgdisc) SETUPFILE= setup_disc.f90 GRAVITY=yes IND_TIMESTEPS=yes - ANALYSIS=analysis_dustydisc.f90 + #ANALYSIS=analysis_dustydisc.f90 ISOTHERMAL=yes - DISC_VISCOSITY=yes KNOWN_SETUP=yes + SRCINJECT= inject_keplerian.f90 + ANALYSIS = utils_getneighbours.F90 utils_omp.F90 analysis_disc_stresses.f90 endif ifeq ($(SETUP), dustyisosgdisc) @@ -941,7 +938,7 @@ ifeq ($(SETUP), dustyisosgdisc) IND_TIMESTEPS=yes ANALYSIS=analysis_dustydisc.f90 ISOTHERMAL=yes - DISC_VISCOSITY=yes + SRCINJECT= inject_keplerian.f90 KNOWN_SETUP=yes endif diff --git a/docs/inject_sim.rst b/docs/inject_sim.rst new file mode 100644 index 000000000..392cc783e --- /dev/null +++ b/docs/inject_sim.rst @@ -0,0 +1,73 @@ + +Injecting particles from existing simulations to new simulations +========================================================= + +Initial setup +------------- + +To ensure the particle mass and units are consistent in both existing & new simulations, + it is recommended to use 'phantommoddump' with existing simulations to setup new simulations + +:: + + make SRCINJECT=inject_sim.f90; make moddump SRCINJECT=inject_sim.f90 + ./phantommoddump YOUR_EXISTING_SIMULATION YOUR_NEW_SIMULATION TIME + +'phantommodump' might produce a parameter file depending on the setup, + in that case one would need to run +:: + + ./phantommoddump YOUR_EXISTING_SIMULATION YOUR_NEW_SIMULATION TIME' + +one more time after setting up the parameters + +At the end of these instructions, an initial dump of the new simulaton and a .in file are created. + +:: + +Content of the .in file +-------------------------- + +Options controlling particle injection +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +:: + + # options controlling particle injection + start_dump = 'dump_00000' ! dumpfile to start for injection + r_inject = 5.000E+14 ! radius to inject tde outflow (in cm) + final_dump = 'dump_02000' ! stop injection after this dump + +Here’s a brief description of each of them + +:: + + start_dump = 'dump_00000' ! dumpfile to start for injection + +set the dump start to inject. The code will check the start_dump time and start injection when the time is reached in new simulations +Once a dump is used by injection, the dump number will automatically increased by 1. The new dump is written to .in file once a full dump is saved + +If the dumps are in a different directory, + +:: + + start_dump = 'PATH/TO/YOUR/OTHER/DIR/dump_00000' ! dumpfile to start for injection + +can read dumps from other directory. The path needs to be the RELATIVE path to the working directory +!!!--------------------------------------!!! +NOTE: qotation marks are NECESSARY with path +!!!--------------------------------------!!! + +:: + + r_inject = 5.000E+14 ! radius to inject tde outflow (in cm) + +set the radius for inject. For TDE outflow specifically, once a particle pass this radius from inside to outside in the existing simulations, it is injected to the new simulations + +:: + + final_dump = 'dump_02000' ! stop injection after this dump + +set the dump to stop injection. The injection dump number keep increasing by 1 after each injection and will stop once reaching this set final_dump. +If there is a PATH in start_dump, it is NECESSARY in final_dump as well. + diff --git a/scripts/buildbot.sh b/scripts/buildbot.sh index 0b503882c..09a1c8e19 100755 --- a/scripts/buildbot.sh +++ b/scripts/buildbot.sh @@ -13,7 +13,7 @@ # # Written by Daniel Price, 2012-2023, daniel.price@monash.edu # -if [ X$SYSTEM == X ]; then +if [ "X$SYSTEM" == "X" ]; then echo "Error: Need SYSTEM environment variable set to check PHANTOM build"; echo "Usage: $0 [max idim to check] [url]"; exit; @@ -77,7 +77,6 @@ listofcomponents='main setup analysis utils'; # 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 )) @@ -184,9 +183,10 @@ check_phantomsetup () # myinput="\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"; prefix="myrun"; + flags="--np=1000" echo -e "$myinput" > myinput.txt; sed '/-e/d' myinput.txt > mycleanin.txt - ./phantomsetup $prefix < mycleanin.txt > /dev/null; err=$?; + ./phantomsetup $prefix $flags < mycleanin.txt > /dev/null; err=$?; if [ $err -eq 0 ]; then print_result "runs" $pass; else @@ -197,8 +197,8 @@ check_phantomsetup () # run phantomsetup up to 3 times to successfully create/rewrite the .setup file # infile="${prefix}.in" - ./phantomsetup $prefix < myinput.txt > /dev/null; - ./phantomsetup $prefix < myinput.txt > /dev/null; + ./phantomsetup $prefix $flags < myinput.txt > /dev/null; + ./phantomsetup $prefix $flags < myinput.txt > /dev/null; if [ -e "$prefix.setup" ]; then print_result "creates .setup file" $pass; #test_setupfile_options "$prefix" "$prefix.setup" $infile; diff --git a/src/main/checkconserved.f90 b/src/main/checkconserved.f90 index a5538d537..9fb43c454 100644 --- a/src/main/checkconserved.f90 +++ b/src/main/checkconserved.f90 @@ -132,10 +132,10 @@ subroutine check_magnetic_stability(hdivBonB_ave,hdivBonB_max) real, intent(in) :: hdivBonB_ave,hdivBonB_max if (hdivBonB_max > 100 .or. hdivBonB_ave > 0.1) then - ! Tricco, Price & Bate (2016) suggest the average should remain lower than 0.01, - ! but we will increase it here due to the nature of the exiting the code - ! The suggestion of 512 was empirically determined in Dobbs & Wurster (2021) - call do_not_publish_crap('evolve','h|divb|/b is too large; recommend to increase the overcleanfac') + ! Tricco, Price & Bate (2016) suggest the average should remain lower than 0.01, + ! but we will increase it here due to the nature of the exiting the code + ! The suggestion of 512 was empirically determined in Dobbs & Wurster (2021) + call do_not_publish_crap('evolve','h|divb|/b is too large; recommend to increase the overcleanfac') endif end subroutine check_magnetic_stability diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 39ac95b9b..9ab68cacf 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -105,7 +105,7 @@ subroutine check_setup(nerror,nwarn,restart) nerror = nerror + 1 endif else - if (polyk < tiny(0.) .and. ieos /= 2 .and. ieos /= 5) then + if (polyk < tiny(0.) .and. ieos /= 2 .and. ieos /= 5 .and. ieos /= 17) then print*,'WARNING! polyk = ',polyk,' in setup, speed of sound will be zero in equation of state' nwarn = nwarn + 1 endif @@ -239,7 +239,7 @@ subroutine check_setup(nerror,nwarn,restart) nerror = nerror + 1 endif else - if (abs(gamma-1.) > tiny(gamma) .and. (ieos /= 2 .and. ieos /= 5 .and. ieos /=9)) then + if (abs(gamma-1.) > tiny(gamma) .and. (ieos /= 2 .and. ieos /= 5 .and. ieos /=9 .and. ieos /= 17)) then print*,'*** ERROR: using isothermal EOS, but gamma = ',gamma gamma = 1. print*,'*** Resetting gamma to 1, gamma = ',gamma @@ -433,6 +433,10 @@ subroutine check_setup(nerror,nwarn,restart) !--check Forward symplectic integration method imcompatiblity ! call check_vdep_extf (nwarn,iexternalforce) +! +!--check Regularization imcompatibility +! + call check_regnbody (nerror) if (.not.h2chemistry .and. maxvxyzu >= 4 .and. icooling == 3 .and. iexternalforce/=iext_corotate .and. nptmass==0) then if (dot_product(xcom,xcom) > 1.e-2) then @@ -1016,16 +1020,30 @@ subroutine check_setup_radiation(npart,nerror,nwarn,radprop,rad) end subroutine check_setup_radiation subroutine check_vdep_extf(nwarn,iexternalforce) - use externalforces, only: is_velocity_dependent - use ptmass, only : use_fourthorder + use externalforces, only:is_velocity_dependent + use ptmass, only:use_fourthorder + use dim, only:gr integer, intent(inout) :: nwarn integer, intent(in) :: iexternalforce - if (is_velocity_dependent(iexternalforce) .and. use_fourthorder) then - print "(/,a,/)","Warning: velocity dependant external forces are not compatible with FSI switch back to Leapfrog..." - nwarn = nwarn + 1 + + if (iexternalforce > 0 .and. is_velocity_dependent(iexternalforce) .and. use_fourthorder) then + if (.not.gr) then ! do not give the warning in GR, just do it... + print "(/,1x,a,/)"," Warning: Switching to Leapfrog integrator for velocity-dependent external forces..." + nwarn = nwarn + 1 + endif use_fourthorder = .false. endif end subroutine check_vdep_extf +subroutine check_regnbody (nerror) + use ptmass, only:use_regnbody,use_fourthorder + integer, intent(inout) :: nerror + if (use_regnbody .and. .not.(use_fourthorder)) then + print "(/,a,/)","Error: TTL integration and regularization tools are not available without FSI. Turn off TTL..." + nerror = nerror + 1 + endif +end subroutine check_regnbody + + end module checksetup diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 67fec4e62..d333810e8 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -70,7 +70,7 @@ subroutine init_cooling(id,master,iprint,ierr) 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 cooling_radapprox, only:init_star,od_method use viscosity, only:irealvisc integer, intent(in) :: id,master,iprint @@ -86,7 +86,7 @@ subroutine init_cooling(id,master,iprint,ierr) call init_cooling_ism() if (icooling==8) cooling_in_step = .false. case(9) - if (ieos /= 21 .and. ieos /=2) call fatal('cooling','icooling=9 requires ieos=21',& + if (ieos /= 21 ) call fatal('cooling','icooling=9 requires ieos=21',& 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) @@ -132,7 +132,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,dudti_sph,part_id) +subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2_in,kappa_in,abund_in) use io, only:fatal use dim, only:nabundances use eos, only:gmw,gamma,ieos,get_temperature_from_u @@ -147,8 +147,6 @@ subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2 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 :: dudti_sph ! in code units - integer, intent(in),optional :: part_id real, intent(in), optional :: abund_in(nabn) real, intent(out) :: dudt ! in code units real :: mui,gammai,Tgas,Tdust,K2,kappa @@ -176,9 +174,6 @@ subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2 if (present(Tdust_in)) Tdust = Tdust_in select case (icooling) - case (9) - ! should not occur! - call fatal('energ_cooling','cooling_S07 called from cooling.f90') case (6) call cooling_KoyamaInutsuka_implicit(ui,rho,dt,dudt) case (5) @@ -249,7 +244,7 @@ subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr integer, save :: ngot = 0 - logical :: igotallism,igotallmol,igotallgammie,igotallgammiePL,igotallfunc,igotallstam + logical :: igotallism,igotallmol,igotallgammie,igotallgammiePL,igotallfunc,igotallradapp imatch = .true. igotall = .false. ! cooling options are compulsory @@ -257,7 +252,7 @@ subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) igotallmol = .true. igotallgammie = .true. igotallfunc = .true. - igotallstam = .true. + igotallradapp = .true. select case(trim(name)) case('icooling') @@ -281,13 +276,13 @@ subroutine read_options_cooling(name,valstring,imatch,igotall,ierr) case(7) call read_options_cooling_gammie_PL(name,valstring,imatch,igotallgammiePL,ierr) case(9) - call read_options_cooling_radapprox(name,valstring,imatch,igotallstam,ierr) + call read_options_cooling_radapprox(name,valstring,imatch,igotallradapp,ierr) case default call read_options_cooling_solver(name,valstring,imatch,igotallfunc,ierr) end select end select ierr = 0 - if (icooling >= 0 .and. ngot >= 2 .and. igotallgammie .and. igotallfunc .and. igotallism .and. igotallstam) then + if (icooling >= 0 .and. ngot >= 2 .and. igotallgammie .and. igotallfunc .and. igotallism .and. igotallradapp) then igotall = .true. else igotall = .false. diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index c7e9e055b..b7ea939e4 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -254,6 +254,7 @@ subroutine read_options_cooling_radapprox(name,valstring,imatch,igotallstam,ierr character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotallstam integer, intent(out) :: ierr + integer :: ieosread integer, save :: ngot = 0 imatch = .true. @@ -281,6 +282,9 @@ subroutine read_options_cooling_radapprox(name,valstring,imatch,igotallstam,ierr doFLD = .true. endif ngot = ngot + 1 + case('ieos') + read(valstring,*,iostat=ierr) ieosread + if (ieosread /= 21) call fatal('ieosread','For icooling=9, you need ieos=21') case default imatch = .false. end select diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index ef9375311..c66d27e5c 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -58,7 +58,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& use forces, only:force use part, only:mhd,gradh,alphaind,igas,iradxi,ifluxx,ifluxy,ifluxz,ithick use derivutils, only:do_timing - use cons2prim, only:cons2primall,cons2prim_everything,prim2consall + use cons2prim, only:cons2primall,cons2prim_everything use metric_tools, only:init_metric use radiation_implicit, only:do_radiation_implicit,ierr_failed_to_converge use options, only:implicit_radiation,implicit_radiation_store_drad,use_porosity,icooling @@ -117,7 +117,6 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& if (gr) then ! Recalculate the metric after moving particles to their new tasks call init_metric(npart,xyzh,metrics) - !call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) endif if (nptmass > 0 .and. periodic) call ptmass_boundary_crossing(nptmass,xyzmh_ptmass) @@ -146,7 +145,6 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& call do_timing('dens',tlast,tcpulast) endif - print *, "calling eos from deriv" if (gr) then call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) else @@ -163,12 +161,6 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& call do_timing('radiation',tlast,tcpulast) endif -! -! update energy if using radiative cooling approx (icooling=9) -! -! if (icooling == 9 .and. dt > 0.0) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) - - ! ! compute forces ! @@ -191,12 +183,11 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& endif ! -! update energy if using radiative cooling approx (icooling=9) and set fxyzu(4,:) to zero - ! +! update energy if using radiative cooling approx (icooling=9) +! print *, "min,max energy", minval(vxyzu(4,1:npart)), maxval(vxyzu(4,1:npart)) - if (icooling == 9 .and. dt > 0.0 .and. icall==2) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) + if (icooling == 9 .and. dt > 0.0 .and. icall==1) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) - ! ! compute dust temperature ! @@ -213,6 +204,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& !$omp end parallel do endif +! Set dudt to zero because we evolved energy already for icooling=9 if (icooling == 9 .and. icall==1) then !$omp parallel do shared(fxyzu,npart) private(i) do i=1,npart @@ -246,11 +238,13 @@ 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 - use timing, only:printused,getused - use io, only:id,master + 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 + use timing, only:printused,getused + use io, only:id,master + use cons2prim, only:prim2consall + use metric_tools, only:init_metric real(kind=4), intent(out), optional :: tused real, intent(out), optional :: dt_new real, intent(in), optional :: dt ! optional argument needed to test implicit radiation routine @@ -262,6 +256,13 @@ subroutine get_derivs_global(tused,dt_new,dt) dti = 0. if (present(dt)) dti = dt call getused(t1) + ! update conserved quantities in the GR code + if (gr) then + call init_metric(npart,xyzh,metrics) + call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) + endif + + ! 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) diff --git a/src/main/dust_formation.f90 b/src/main/dust_formation.f90 index 5598f85fb..f32754011 100644 --- a/src/main/dust_formation.f90 +++ b/src/main/dust_formation.f90 @@ -372,7 +372,8 @@ end subroutine evol_K !---------------------------------------- subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) ! all quantities are in cgs - use io, only:fatal + use io, only:fatal + use eos, only:ieos real, intent(in) :: rho_cgs real, intent(inout) :: T, mu, gamma @@ -388,8 +389,8 @@ subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) T_old = T if (T > 1.d4) then mu = (1.+4.*eps(iHe))/(1.+eps(iHe)) - gamma = 5./3. pH = pH_tot + if (ieos /= 17) gamma = 5./3. elseif (T > 450.) then ! iterate to get consistently pH, T, mu and gamma tol = 1.d-3 @@ -404,6 +405,7 @@ subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) pH = solve_q(2.*KH2, 1., -pH_tot) pH2 = KH2*pH**2 mu = (1.+4.*eps(iHe))/(.5+eps(iHe)+0.5*pH/pH_tot) + if (ieos == 17) exit !only update mu, keep gamma constant x = 2.*(1.+4.*eps(iHe))/mu gamma = (3.*x+4.+4.*eps(iHe))/(x+4.+4.*eps(iHe)) converged = (abs(T-T_old)/T_old) < tol @@ -411,7 +413,7 @@ subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) mu_old = mu gamma_old = gamma else - T = 2.*T_old*mu/mu_old/(gamma_old-1.)*(x-eps(iHe))/(x+4.-eps(iHe)) + T = T_old*mu/mu_old/(gamma_old-1.)*2.*x/(x+4.+4.*eps(iHe)) if (i>=itermax .and. .not.converged) then if (isolve==0) then isolve = isolve+1 @@ -431,7 +433,7 @@ subroutine calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) pH2 = pH_tot/2. pH = 0. mu = (1.+4.*eps(iHe))/(0.5+eps(iHe)) - gamma = (5.*eps(iHe)+3.5)/(3.*eps(iHe)+2.5) + if (ieos /= 17) gamma = (5.*eps(iHe)+3.5)/(3.*eps(iHe)+2.5) endif end subroutine calc_muGamma diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index c96f339c1..92c22f776 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -276,7 +276,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! creation of new sink particles ! call ptmass_create(nptmass,npart,ipart_rhomax,xyzh,vxyzu,fxyzu,fext,divcurlv,& - poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) + poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,dptmass,time) endif ! ! Strang splitting: implicit update for half step diff --git a/src/main/inject_keplerian.f90 b/src/main/inject_keplerian.f90 new file mode 100644 index 000000000..7ade9b7b0 --- /dev/null +++ b/src/main/inject_keplerian.f90 @@ -0,0 +1,257 @@ +!--------------------------------------------------------------------------! +! 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 inject +! +! Injection of material at keplerian speed in an accretion disc +! +! :References: +! +! :Owner: Daniel Price +! +! :Runtime parameters: +! - datafile : *name of data file for wind injection* +! - outer_boundary : *kill gas particles outside this radius* +! +! :Dependencies: dim, eos, infile_utils, io, part, partinject, physcon, +! random, units +! + implicit none + character(len=*), parameter, public :: inject_type = 'keplerian' + + public :: init_inject,inject_particles,write_options_inject,read_options_inject,& + set_default_options_inject,update_injected_par + + real :: mdot = 0. + real :: rinj = 25. + real :: HonR_inj = 0.05 + logical :: follow_sink = .true. + integer, private :: iseed=-888 + +contains +!----------------------------------------------------------------------- +!+ +! Initialize global variables or arrays needed for injection routine +!+ +!----------------------------------------------------------------------- +subroutine init_inject(ierr) + use io, only:warning + use part, only:nptmass + integer, intent(out) :: ierr + ! + ! return without error + ! + ierr = 0 + if (nptmass > 1) call warning(inject_type,'Using first sink particle to compute Keplerian velocity') + +end subroutine init_inject + +!----------------------------------------------------------------------- +!+ +! set defaults +!+ +!----------------------------------------------------------------------- +subroutine set_default_options_inject(flag) + integer, optional, intent(in) :: flag + +end subroutine set_default_options_inject + +!----------------------------------------------------------------------- +!+ +! Main routine handling injection at a given radius rinj +!+ +!----------------------------------------------------------------------- +subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + npart,npart_old,npartoftype,dtinject) + use io, only:fatal,iverbose,warning + use part, only:massoftype,igas,nptmass,isdead_or_accreted,maxvxyzu + use partinject, only:add_or_update_particle + use physcon, only:pi,solarm,years + use units, only:umass,utime + use random, only:ran2,gauss_random + use options, only:iexternalforce,ieos + use externalforces, only:mass1 + use eos, only:equationofstate,gamma + real, intent(in) :: time, dtlast + real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) + integer, intent(inout) :: npart, npart_old + integer, intent(inout) :: npartoftype(:) + real, intent(out) :: dtinject + real :: Minject,Mdot_code + real :: frac_extra,deltat + real :: x0(3),v0(3),mstar,r2min,dr2,hguess,phi,cosphi,sinphi,r2,xyzi(3),vxyz(3),u + real :: vkep,vphi,zi,cs,bigH + real :: dum_ponrho,dum_rho,dum_temp + integer :: i,k,i_part,ninject + ! + ! convert mass loss rate from Msun/yr to code units + ! + Mdot_code = Mdot*(solarm/umass)*(utime/years) + + ! + ! get central mass + ! + x0 = 0. + v0 = 0. + if (iexternalforce > 0) then + mstar = mass1 + elseif (nptmass >= 1) then + if (follow_sink) then + x0 = xyzmh_ptmass(1:3,1) + v0 = vxyz_ptmass(1:3,1) + endif + mstar = xyzmh_ptmass(4,1) + else + mstar = 1. + call fatal(inject_type,'no central object to compute Keplerian velocity') + endif + + ! for the smoothing length, take it from the closest existing particle to the injection radius + hguess = 1. + r2min = huge(r2min) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + r2 = (xyzh(1,i)-x0(1))**2 + (xyzh(2,i)-x0(2))**2 + dr2 = abs(r2 - rinj*rinj) + if (dr2 < r2min) then + hguess = xyzh(4,i) + r2min = dr2 + endif + endif + enddo + + vkep = sqrt(mstar/rinj) + + ! for the temperature, call equation of state to get cs at this radius + if (maxvxyzu >= 4) then + ! use HonR parameter + cs = HonR_inj * vkep + else + dum_rho = 1. + dum_temp = 0. + if (gamma > 1.001) then + call warning(inject_type,'cannot get temp at r=rinj without knowing density, injecting at z=0') + cs = 0. + else + call equationofstate(ieos,dum_ponrho,cs,dum_rho,rinj,0.,0.,dum_temp) + endif + endif + + ! + ! calculate how much mass to inject based on + ! time interval since last injection + ! + deltat = dtlast + Minject = Mdot_code*deltat + ! + ! work out number of particles by divide by mass of gas particles + ! + ninject = int(Minject/massoftype(igas)) + ! + ! for the residual, roll the dice + ! + frac_extra = Minject/massoftype(igas) - 2*(ninject/2) + if (ran2(iseed) < 0.5*frac_extra) ninject = ninject + 2 + + if (iverbose >= 2) print*,' injecting ',& + ninject,Minject/massoftype(igas),massoftype(igas) + + if (ninject > 0) then + do k=1,ninject/2 + ! + ! get random position on ring + ! + phi = 2.*pi*(ran2(iseed) - 0.5) + + cosphi = cos(phi) + sinphi = sin(phi) + + bigH = cs*rinj/vkep + zi = gauss_random(iseed)*bigH + + vphi = vkep*(1. - (zi/rinj)**2)**(-0.75) ! see Martire et al. (2024) + + xyzi = (/rinj*cosphi,rinj*sinphi,zi/) + vxyz = (/-vphi*sinphi, vphi*cosphi, 0./) + + u = 1.5*cs**2 + + i_part = npart + 1! all particles are new + call add_or_update_particle(igas, xyzi+x0, vxyz+v0, hguess, u, i_part, npart, npartoftype, xyzh, vxyzu) + i_part = npart + 1! all particles are new + call add_or_update_particle(igas, -xyzi+x0, -vxyz+v0, hguess, u, i_part, npart, npartoftype, xyzh, vxyzu) + enddo + endif + + if (iverbose >= 2) then + print*,'npart = ',npart + endif + ! + !-- no constraint on timestep + ! + dtinject = huge(dtinject) + +end subroutine inject_particles + +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + +!----------------------------------------------------------------------- +!+ +! Writes input options to the input file. +!+ +!----------------------------------------------------------------------- +subroutine write_options_inject(iunit) + use infile_utils, only:write_inopt + use part, only:maxvxyzu,nptmass + integer, intent(in) :: iunit + + call write_inopt(mdot,'mdot','mass injection rate [msun/yr]',iunit) + call write_inopt(rinj,'rinj','injection radius',iunit) + if (maxvxyzu >= 4) then + call write_inopt(HonR_inj,'HonR_inj','aspect ratio to give temperature at rinj',iunit) +endif +if (nptmass >= 1) then + call write_inopt(follow_sink,'follow_sink','injection radius is relative to sink particle 1',iunit) +endif + +end subroutine write_options_inject + +!----------------------------------------------------------------------- +!+ +! Reads input options from the input file. +!+ +!----------------------------------------------------------------------- +subroutine read_options_inject(name,valstring,imatch,igotall,ierr) + use io, only:fatal,error,warning + use physcon, only:solarm,years + 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_inject' + + imatch = .true. + select case(trim(name)) + case('mdot') + read(valstring,*,iostat=ierr) mdot + case('rinj') + read(valstring,*,iostat=ierr) rinj + case('HonR_inj') + read(valstring,*,iostat=ierr) HonR_inj + case('follow_sink') + read(valstring,*,iostat=ierr) follow_sink + case default + imatch = .false. + end select + + igotall = (ngot >= 0) + +end subroutine read_options_inject + +end module inject diff --git a/src/main/part.F90 b/src/main/part.F90 index 362587bc2..5b5ae5f18 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -291,6 +291,20 @@ module part ! real(kind=4), allocatable :: luminosity(:) ! +!-- Regularisation algorithm allocation +! + integer, allocatable :: group_info(:,:) + integer(kind=1), allocatable :: nmatrix(:,:) + integer, parameter :: igarg = 1 ! idx of the particle member of a group + integer, parameter :: igcum = 2 ! cumulative sum of the indices to find the starting and ending point of a group + integer, parameter :: igid = 3 ! id of the group, correspond to the root of the group in the dfs/union find construction + ! needed for group identification and sorting + integer :: n_group = 0 + integer :: n_ingroup = 0 + integer :: n_sing = 0 + ! Gradient of the time transformation function + real, allocatable :: gtgrad(:,:) +! !--derivatives (only needed if derivs is called) ! real, allocatable :: fxyzu(:,:) @@ -480,6 +494,9 @@ subroutine allocate_part call allocate_array('abundance', abundance, nabundances, maxp_h2) endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) + call allocate_array('group_info', group_info, 3, maxptmass) + call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) + call allocate_array("gtgrad", gtgrad, 3, maxptmass) end subroutine allocate_part @@ -560,6 +577,9 @@ subroutine deallocate_part if (allocated(ibelong)) deallocate(ibelong) if (allocated(istsactive)) deallocate(istsactive) if (allocated(ibin_sts)) deallocate(ibin_sts) + if (allocated(group_info)) deallocate(group_info) + if (allocated(nmatrix)) deallocate(nmatrix) + if (allocated(gtgrad)) deallocate(gtgrad) end subroutine deallocate_part diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 9d536862e..65dab95a1 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -65,11 +65,12 @@ module ptmass real, public :: f_acc = 0.8 real, public :: h_soft_sinkgas = 0.0 real, public :: h_soft_sinksink = 0.0 - real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch - real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius - real, public :: f_crit_override = 0.0 ! 1000. + real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch + real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius + real, public :: f_crit_override = 0.0 ! 1000. + logical, public :: use_regnbody = .false. ! subsystems switch logical, public :: use_fourthorder = .true. integer, public :: n_force_order = 3 real, public, parameter :: dk2(3) = (/0.5,0.5,0.0/) @@ -299,7 +300,7 @@ end subroutine get_accel_sink_gas !+ !---------------------------------------------------------------- subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,& - iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass,extrapfac,fsink_old) + iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass,extrapfac,fsink_old,group_info) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -307,6 +308,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec + use part, only:igarg,igid integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(out) :: fxyz_ptmass(4,nptmass) @@ -317,6 +319,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real, intent(out) :: dsdt_ptmass(3,nptmass) real, optional, intent(in) :: extrapfac real, optional, intent(in) :: fsink_old(4,nptmass) + integer, optional, intent(in) :: group_info(3,nptmass) real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii real :: ddr,dx,dy,dz,rr2,rr2j,dr3,f1,f2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft @@ -324,8 +327,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real :: fterm,pterm,potensoft0,dsx,dsy,dsz real :: J2i,rsinki,shati(3) real :: J2j,rsinkj,shatj(3) - integer :: i,j - logical :: extrap + integer :: k,l,i,j,gidi,gidj + logical :: extrap,subsys dtsinksink = huge(dtsinksink) fxyz_ptmass(:,:) = 0. @@ -340,6 +343,12 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin else extrap = .false. endif + + if (present(group_info)) then + subsys = .true. + else + subsys = .false. + endif ! !--get self-contribution to the potential if sink-sink softening is used ! @@ -356,10 +365,11 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !--compute N^2 forces on point mass particles due to each other ! !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info,subsys) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & !$omp shared(extrapfac,extrap,fsink_old) & - !$omp private(i,xi,yi,zi,pmassi,pmassj) & + !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & + !$omp private(gidi,gidj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & !$omp private(fextx,fexty,fextz,phiext) & @@ -367,7 +377,13 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp private(fterm,pterm,J2i,J2j,shati,shatj,rsinki,rsinkj) & !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) - do i=1,nptmass + do k=1,nptmass + if (subsys) then + i = group_info(igarg,k) + gidi = group_info(igid,k) + else + i = k + endif if (extrap) then xi = xyzmh_ptmass(1,i) + extrapfac*fsink_old(1,i) yi = xyzmh_ptmass(2,i) + extrapfac*fsink_old(2,i) @@ -389,7 +405,14 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dsx = 0. dsy = 0. dsz = 0. - do j=1,nptmass + do l=1,nptmass + if (subsys) then + j = group_info(igarg,l) + gidj = group_info(igid,l) + if (gidi==gidj) cycle + else + j = l + endif if (i==j) cycle if (extrap) then dx = xi - (xyzmh_ptmass(1,j) + extrapfac*fsink_old(1,j)) @@ -552,17 +575,35 @@ end subroutine ptmass_boundary_crossing ! (called from inside a parallel section) !+ !---------------------------------------------------------------- -subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) +subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,group_info,n_ingroup) + use part,only:igarg integer, intent(in) :: nptmass real, intent(in) :: ckdt real, intent(inout) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: vxyz_ptmass(3,nptmass) - integer :: i + integer, optional, intent(in) :: n_ingroup + integer, optional, intent(in) :: group_info(:,:) + integer :: i,k,istart_ptmass + logical :: woutsub + + if (present(n_ingroup)) then + istart_ptmass = n_ingroup + 1 + woutsub = .true. + else + istart_ptmass = 1 + woutsub = .false. + endif !$omp parallel do schedule(static) default(none) & !$omp shared(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) & - !$omp private(i) - do i=1,nptmass + !$omp shared(n_ingroup,group_info,woutsub,istart_ptmass) & + !$omp private(i,k) + do k=istart_ptmass,nptmass + if (woutsub) then + i = group_info(igarg,k) + else + i = k + endif if (xyzmh_ptmass(4,i) > 0.) then xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ckdt*vxyz_ptmass(1,i) xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ckdt*vxyz_ptmass(2,i) @@ -711,7 +752,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & dptmass,time,facc,nbinmax,ibin_wakei,nfaili) !$ use omputils, only:ipart_omp_lock - use part, only: ihacc + use part, only: ihacc,ndptmass use kernel, only: radkern2 use io, only: iprint,iverbose,fatal use io_summary, only: iosum_ptmass,maxisink,print_acc @@ -721,7 +762,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(in) :: vxyz_ptmass(3,nptmass) logical, intent(out) :: accreted - real, intent(inout) :: dptmass(:,:) + real, intent(inout) :: dptmass(ndptmass,nptmass) integer(kind=1), intent(in) :: nbinmax integer(kind=1), intent(inout) :: ibin_wakei integer, optional, intent(out) :: nfaili @@ -895,11 +936,13 @@ end subroutine ptmass_accrete !+ !----------------------------------------------------------------------- subroutine update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) - real, intent(in) :: dptmass(:,:) + use part ,only:ndptmass + integer, intent(in) :: nptmass + real, intent(in) :: dptmass(ndptmass,nptmass) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(inout) :: vxyz_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:) - integer, intent(in) :: nptmass + real :: newptmass(nptmass),newptmass1(nptmass) @@ -955,9 +998,9 @@ end subroutine update_ptmass !+ !------------------------------------------------------------------------- subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& - massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,time) + massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,dptmass,time) use part, only:ihacc,ihsoft,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & - ispinx,ispiny,ispinz,fxyz_ptmass_sinksink,eos_vars,igasP,igamma,ndptmass + ispinx,ispiny,ispinz,eos_vars,igasP,igamma,ndptmass use dim, only:maxp,maxneigh,maxvxyzu,maxptmass,ind_timesteps use kdtree, only:getneigh use kernel, only:kernel_softening,radkern @@ -981,8 +1024,8 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote real, intent(inout) :: xyzh(:,:) real, intent(in) :: vxyzu(:,:),fxyzu(:,:),fext(:,:),massoftype(:) real(4), intent(in) :: divcurlv(:,:),poten(:) - real, intent(inout) :: xyzmh_ptmass(:,:) - real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(:,:),dptmass(ndptmass,nptmass+1) + real, intent(inout) :: xyzmh_ptmass(:,:),dptmass(ndptmass,maxptmass) + real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(4,maxptmass),fxyz_ptmass_sinksink(4,maxptmass) real, intent(in) :: time integer(kind=1) :: iphasei,ibin_wakei,ibin_itest integer :: nneigh @@ -1212,7 +1255,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote if (maxvxyzu >= 4) then etherm = etherm + pmassj*vxyzu(4,j) else - if (ieos==2 .and. gamma > 1.001) then + if ((ieos==2 .or. ieos==17) .and. gamma > 1.001) then etherm = etherm + pmassj*(eos_vars(igasP,j)/rhoj)/(gamma - 1.) elseif (ieos==5 .and. gamma > 1.001) then etherm = etherm + pmassj*(eos_vars(igasP,j)/rhoj)/(eos_vars(igamma,j) - 1.) @@ -1492,8 +1535,8 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote nacc = int(reduceall_mpi('+', nacc)) ! update ptmass position, spin, velocity, acceleration, and mass - fxyz_ptmass(:,nptmass) = 0.0 - fxyz_ptmass_sinksink(:,nptmass) = 0.0 + fxyz_ptmass(1:4,n) = 0.0 + fxyz_ptmass_sinksink(1:4,n) = 0.0 call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) if (id==id_rhomax) then diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 new file mode 100644 index 000000000..a754e8d61 --- /dev/null +++ b/src/main/subgroup.f90 @@ -0,0 +1,756 @@ +!--------------------------------------------------------------------------! +! 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 subgroup +! +! this module contains everything to identify +! and integrate regularized groups... +! +! :References: Makkino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 +! +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: io, mpiutils, part, utils_kepler, utils_subgroup +! + use utils_subgroup + implicit none + public :: group_identify + public :: evolve_groups + public :: get_pot_subsys + ! parameters for group identification + real, parameter :: eta_pert = 20 + real, parameter :: time_error = 2.5e-14 + real, parameter :: max_step = 100000000 + real, parameter, public :: r_neigh = 0.001 + real, public :: t_crit = 1.e-9 + real, public :: C_bin = 0.02 + real, public :: r_search = 100.*r_neigh + private +contains + +!----------------------------------------------- +! +! Group identification routines +! +!----------------------------------------------- +subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + use io ,only:id,master,iverbose,iprint + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(inout) :: group_info(3,nptmass) + integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) + integer, intent(inout) :: n_group,n_ingroup,n_sing + + n_group = 0 + n_ingroup = 0 + n_sing = 0 + + call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) + call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + + if (id==master .and. iverbose>1) then + write(iprint,"(i6,a,i6,a,i6,a)") n_group," groups identified, ",n_ingroup," in a group, ",n_sing," singles..." + endif + +end subroutine group_identify + + +subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + use part, only : igarg,igcum,igid + integer, intent(in) :: nptmass + integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) + integer, intent(inout) :: group_info(3,nptmass) + integer, intent(inout) :: n_group,n_ingroup,n_sing + integer :: i,ncg + logical :: visited(nptmass) + visited = .false. + group_info(igcum,1) = 0 + do i=1,nptmass + if (.not.visited(i)) then + n_ingroup = n_ingroup + 1 + call dfs(i,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) + if (ncg>1) then + n_group = n_group + 1 + group_info(igcum,n_group+1) = (ncg) + group_info(igcum,n_group) + else + n_ingroup = n_ingroup - 1 + group_info(igarg,nptmass-n_sing) = i + group_info(igid,nptmass-n_sing) = i + n_sing = n_sing + 1 + endif + endif + enddo +end subroutine form_group + +subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) + use part, only : igarg,igid + integer, intent(in) :: nptmass,iroot + integer, intent(out) :: ncg + integer(kind=1), intent(in) :: nmatrix(nptmass,nptmass) + integer, intent(inout) :: group_info(3,nptmass) + integer, intent(inout) :: n_ingroup + logical, intent(inout) :: visited(nptmass) + integer :: stack(nptmass) + integer :: j,stack_top,inode + + stack_top = 0 + ncg = 1 + inode = iroot + group_info(igarg,n_ingroup) = inode + group_info(igid,n_ingroup) = iroot + stack_top = stack_top + 1 + stack(stack_top) = inode + visited(inode) = .true. + do while(stack_top>0) + inode = stack(stack_top) + stack_top = stack_top - 1 + do j= 1,nptmass + if (nmatrix(inode,j)==1 .and. .not.(visited(j))) then + n_ingroup = n_ingroup + 1 + ncg = ncg + 1 + stack_top = stack_top + 1 + stack(stack_top) = j + visited(j) = .true. + group_info(igarg,n_ingroup) = j + group_info(igid,n_ingroup) = iroot + endif + enddo + enddo +end subroutine dfs + + +subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) + use utils_kepler, only: Espec,extract_a,extract_e,extract_ea + integer, intent(in) :: nptmass + integer(kind=1), intent(out):: nmatrix(nptmass,nptmass) + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(in) :: vxyz_ptmass(:,:) + real :: xi,yi,zi,vxi,vyi,vzi,mi + real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu + real :: aij,eij,B,rperi + integer :: i,j +! +!!TODO MPI Proof version of the matrix construction +! + + !$omp parallel do default(none) & + !$omp shared(nptmass,C_bin,t_crit,nmatrix) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,r_search) & + !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & + !$omp private(dx,dy,dz,r,r2) & + !$omp private(dvx,dvy,dvz,v2) & + !$omp private(mu,aij,eij,B,rperi) + do i=1,nptmass + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + mi = xyzmh_ptmass(4,i) + vxi = vxyz_ptmass(1,i) + vyi = vxyz_ptmass(2,i) + vzi = vxyz_ptmass(3,i) + do j=1,nptmass + if (i==j) cycle + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) + if (rr_search) then + nmatrix(i,j) = 0 + cycle + endif + mu = mi + xyzmh_ptmass(4,j) + dvx = vxi - vxyz_ptmass(1,j) + dvy = vyi - vxyz_ptmass(2,j) + dvz = vzi - vxyz_ptmass(3,j) + v2 = dvx**2+dvy**2+dvz**2 + call Espec(v2,r,mu,B) + call extract_a(r,mu,v2,aij) + if (B<0) then + if (aij0) then + if (id==master) then + !$omp parallel do default(none)& + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& + !$omp shared(tnext,time,group_info,gtgrad,n_group)& + !$omp private(i,start_id,end_id,gsize) + do i=1,n_group + start_id = group_info(igcum,i) + 1 + end_id = group_info(igcum,i+1) + gsize = (end_id - start_id) + 1 + call integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) + enddo + !$omp end parallel do + endif + endif + + call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + + +end subroutine evolve_groups + +subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) + use part, only: igarg + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & + fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: group_info(:,:) + integer, intent(in) :: start_id,end_id,gsize + real, intent(in) :: tnext,time + real, allocatable :: bdata(:) + real :: ds(2) + real :: time_table(ck_size) + integer :: switch + integer :: step_count_int,step_count_tsyn,n_step_end + real :: dt,ds_init,dt_end,step_modif,t_old,W_old + real :: W,tcoord + logical :: t_end_flag,backup_flag,ismultiple + integer :: i,prim,sec + + + tcoord = time + + ismultiple = gsize > 2 + + if (ismultiple) then + call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,W,start_id,end_id,ds_init=ds_init) + else + prim = group_info(igarg,start_id) + sec = group_info(igarg,end_id) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,W,prim,sec,ds_init=ds_init) + endif + + + allocate(bdata(gsize*6)) + + step_count_int = 0 + step_count_tsyn = 0 + n_step_end = 0 + t_end_flag = .false. + backup_flag = .true. + ds(:) = ds_init + switch = 1 + + !print*,ds_init, tcoord,tnext,W + + do while (.true.) + + if (backup_flag) then + call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bdata) + else + call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) + endif + t_old = tcoord + W_old = W + if (ismultiple) then + do i=1,ck_size + call drift_TTL (tcoord,W,ds(switch)*cks(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) + time_table(i) = tcoord + call kick_TTL (ds(switch)*dks(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,start_id,end_id) + enddo + else + prim = group_info(igarg,start_id) + sec = group_info(igarg,end_id) + call oneStep_bin(tcoord,W,ds(switch),xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,prim,sec) + endif + dt = tcoord - t_old + + step_count_int = step_count_int + 1 + + if (step_count_int > max_step) then + print*,"MAX STEP NUMBER, ABORT !!!" + call abort + endif + + if ((.not.t_end_flag).and.(dt<0.)) then + !print*,"neg dt !!!",tnext,dt + call regularstepfactor((abs(tnext/dt))**(1./6.),step_modif) + step_modif = min(max(step_modif,0.0625),0.5) + ds(switch) = ds(switch)*step_modif + ds(3-switch) = ds(switch) + + backup_flag = .false. + continue + endif + + if (tcoord < tnext - time_error) then + if (t_end_flag .and. (ds(switch)==ds(3-switch))) then + step_count_tsyn = step_count_tsyn + 1 + dt_end = tnext - tcoord + if (dt<0.) then + call regularstepfactor((abs(tnext/dt))**(1./6.),step_modif) + step_modif = min(max(step_modif,0.0625),0.5) + ds(switch) = ds(switch)*step_modif + ds(3-switch) = ds(switch) + elseif ((n_step_end > 1) .and. (dt<0.3*dt_end)) then + ds(3-switch) = ds(switch) * dt_end/dt + else + n_step_end = n_step_end + 1 + endif + endif + ds(switch) = ds(3-switch) + switch = 3 - switch + if (dt>0) then + backup_flag = .true. + else + backup_flag = .false. + endif + + elseif (tcoord > tnext + time_error) then + t_end_flag = .true. + backup_flag = .false. + n_step_end = 0 + step_count_tsyn = step_count_tsyn + 1 + + call new_ds_sync_sup(ds,time_table,tnext,switch) + else + exit + endif + enddo + + !print*,step_count_int,tcoord,tnext,ds_init + + deallocate(bdata) + +end subroutine integrate_to_time + + +subroutine regularstepfactor(fac_in,fac_out) + real, intent(in) :: fac_in + real, intent(out):: fac_out + fac_out = 1.0 + if (fac_in<1) then + do while (fac_out>fac_in) + fac_out = fac_out*0.5 + enddo + else + do while(fac_out<=fac_in) + fac_out = fac_out *2 + enddo + fac_out = fac_out*0.5 + endif +end subroutine regularstepfactor + +subroutine new_ds_sync_sup(ds,time_table,tnext,switch) + real, intent(inout) :: ds(:) + real, intent(in) :: time_table(:) + real, intent(in) :: tnext + integer, intent(in) :: switch + integer :: i,k + real :: tp,dtc,dstmp + do i=1,ck_size + k = cck_sorted_id(i) + if (tnext 0.) then + dt_init = min(dt_init,0.00002*sqrt(abs(gtki)/f2)) + endif + endif + om = om + gtki*mi + enddo + + om = om*0.5 + if (init) ds_init = dt_init/om + +end subroutine get_force_TTL + +subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j,potonly,ds_init) + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: i,j + real, intent(out) :: om + logical, optional, intent(in) :: potonly + real, optional, intent(out) :: ds_init + real :: dx,dy,dz,r2,ddr,ddr3,mi,mj,dsi,dsj + real :: gravfi,gravfj,gtki,gtkj,fxi,fyi,fzi,fxj,fyj,fzj,f2i,f2j + + mi = xyzmh_ptmass(4,i) + mj = xyzmh_ptmass(4,j) + dx = xyzmh_ptmass(1,i) - xyzmh_ptmass(1,j) + dy = xyzmh_ptmass(2,i) - xyzmh_ptmass(2,j) + dz = xyzmh_ptmass(3,i) - xyzmh_ptmass(3,j) + r2 = dx**2+dy**2+dz**2 + ddr = 1./sqrt(r2) + ddr3 = ddr*ddr*ddr + gravfi = mj*ddr3 + gravfj = mi*ddr3 + gtki = mj*ddr + gtkj = mi*ddr + + + fxyz_ptmass(4,i) = -gtki + fxyz_ptmass(4,j) = -gtkj + if (.not.present(potonly)) then + fxi = -dx*gravfi + fyi = -dy*gravfi + fzi = -dz*gravfi + fxj = dx*gravfj + fyj = dy*gravfj + fzj = dz*gravfj + fxyz_ptmass(1,i) = fxi + fxyz_ptmass(2,i) = fyi + fxyz_ptmass(3,i) = fzi + fxyz_ptmass(1,j) = fxj + fxyz_ptmass(2,j) = fyj + fxyz_ptmass(3,j) = fzj + gtgrad(1,i) = -dx*gravfi*mi + gtgrad(2,i) = -dy*gravfi*mi + gtgrad(3,i) = -dz*gravfi*mi + gtgrad(1,j) = dx*gravfj*mj + gtgrad(2,j) = dy*gravfj*mj + gtgrad(3,j) = dz*gravfj*mj + endif + + om = gtki*mi + + if (present(ds_init) .and. .not.present(potonly)) then + f2i = fxi**2+fyi**2+fzi**2 + f2j = fxj**2+fyj**2+fzj**2 + dsi = sqrt(abs(gtki)/f2i) + dsj = sqrt(abs(gtkj)/f2j) + ds_init = 0.000125*min(dsi,dsj)*om + endif + + +end subroutine get_force_TTL_bin + + +subroutine get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + use part, only: igarg,igcum + use io, only: id,master + integer, intent(in) :: n_group + real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: group_info(:,:) + real, intent(inout) :: epot_sinksink + integer :: i,start_id,end_id,gsize,prim,sec + real :: phitot,phigroup + phitot = 0. + if (n_group>0) then + if (id==master) then + !$omp parallel do default(none)& + !$omp shared(xyzmh_ptmass,fxyz_ptmass)& + !$omp shared(group_info,gtgrad,n_group)& + !$omp private(i,start_id,end_id,gsize,prim,sec,phigroup)& + !$omp reduction(+:phitot) + do i=1,n_group + start_id = group_info(igcum,i) + 1 + end_id = group_info(igcum,i+1) + gsize = (end_id - start_id) + 1 + if (gsize>2) then + call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,phigroup,start_id,end_id,.true.) + else + prim = group_info(igarg,start_id) + sec = group_info(igarg,end_id) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phigroup,prim,sec,.true.) + endif + phitot = phitot + phigroup + enddo + !$omp end parallel do + endif + endif + + epot_sinksink = epot_sinksink - phitot + + + +end subroutine get_pot_subsys + + +end module subgroup diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 4df15c4d8..1040fe6fd 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -28,10 +28,11 @@ module substepping ! :Dependencies: chem, cons2primsolver, cooling, cooling_ism, damping, dim, ! dust_formation, eos, extern_gr, externalforces, io, io_summary, ! krome_interface, metric_tools, mpiutils, options, part, ptmass, -! ptmass_radiation, timestep, timestep_sts +! ptmass_radiation, subgroup, timestep, timestep_sts ! implicit none + public :: substep_gr public :: substep_sph public :: substep_sph_gr @@ -425,21 +426,25 @@ end subroutine substep_sph !---------------------------------------------------------------- subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & - fsink_old,nbinmax,ibin_wake) + fsink_old,nbinmax,ibin_wake,gtgrad,group_info,nmatrix, & + n_group,n_ingroup,n_sing) use io, only:iverbose,id,master,iprint,fatal use options, only:iexternalforce - use part, only:fxyz_ptmass_sinksink + use part, only:fxyz_ptmass_sinksink,ndptmass use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent - use ptmass, only:use_fourthorder,ck,dk + use ptmass, only:use_fourthorder,use_regnbody,ck,dk + use subgroup, only:group_identify,evolve_groups integer, intent(in) :: npart,ntypes,nptmass + integer, intent(inout) :: n_group,n_ingroup,n_sing + integer, intent(inout) :: group_info(:,:) real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, intent(inout) :: dptmass(:,:),fsink_old(:,:) + real, intent(inout) :: dptmass(ndptmass,nptmass),fsink_old(:,:),gtgrad(:,:) integer(kind=1), intent(in) :: nbinmax - integer(kind=1), intent(inout) :: ibin_wake(:) + integer(kind=1), intent(inout) :: ibin_wake(:),nmatrix(nptmass,nptmass) logical :: extf_vdep_flag,done,last_step,accreted integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step @@ -462,6 +467,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & nsubsteps = 0 dtextforce_min = huge(dt) done = .false. + accreted = .false. substeps: do while (timei <= t_end_step .and. .not.done) force_count = 0 @@ -475,34 +481,61 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! ! Main integration scheme ! - call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) + + if (use_regnbody) then + call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) - 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,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, & + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag) + endif if (use_fourthorder) then !! FSI 4th order scheme ! FSI extrapolation method (Omelyan 2006) - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + if (use_regnbody) then + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old,group_info) - call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) - ! the last kick phase of the scheme will perform the accretion loop after velocity update - call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) - if (accreted) then + call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,group_info=group_info) + else call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,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) + ! the last kick phase of the scheme will perform the accretion loop after velocity update endif - else !! standard leapfrog scheme + call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,group_info=group_info) + elseif (accreted) then + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + endif + else !! standard leapfrog scheme ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) @@ -510,7 +543,6 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag) endif - endif dtextforce_min = min(dtextforce_min,dtextforce) @@ -537,25 +569,26 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & end subroutine substep - !---------------------------------------------------------------- !+ ! drift routine for the whole system (part and ptmass) !+ !---------------------------------------------------------------- -subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) - use part, only:isdead_or_accreted +subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) + use part, only: isdead_or_accreted,ispinx,ispiny,ispinz,igarg use ptmass, only:ptmass_drift 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(:,:) - real :: ckdt + 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(:,:) integer :: i + real :: ckdt ckdt = cki*dt @@ -576,7 +609,11 @@ 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 - call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) + if (present(n_ingroup)) then + call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,group_info,n_ingroup) + else + call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) + endif endif call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) endif @@ -585,7 +622,6 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx end subroutine drift - !---------------------------------------------------------------- !+ ! kick routine for the whole system (part and ptmass) @@ -594,7 +630,7 @@ end subroutine drift subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) - use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas + use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas,ndptmass use ptmass, only:f_acc,ptmass_accrete,pt_write_sinkev,update_ptmass,ptmass_kick use externalforces, only:accrete_particles use options, only:iexternalforce @@ -608,7 +644,8 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, real, intent(inout) :: xyzh(:,:) real, intent(inout) :: vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, optional, intent(inout) :: dptmass(:,:),fxyz_ptmass_sinksink(:,:) + real, intent(inout) :: dptmass(ndptmass,nptmass) + real, optional, intent(inout) :: fxyz_ptmass_sinksink(:,:) real, optional, intent(in) :: timei integer(kind=1), optional, intent(inout) :: ibin_wake(:) integer(kind=1), optional, intent(in) :: nbinmax @@ -619,7 +656,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, integer :: naccreted,nfail,nlive real :: dkdt,pmassi,fxi,fyi,fzi,accretedmass - if (present(dptmass) .and. present(timei) .and. present(ibin_wake) .and. present(nbinmax)) then + if (present(timei) .and. present(ibin_wake) .and. present(nbinmax)) then is_accretion = .true. else is_accretion = .false. @@ -671,17 +708,19 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. - !$omp parallel default(none) & + !$omp parallel do default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & !$omp shared(iexternalforce) & !$omp shared(nbinmax,ibin_wake) & - !$omp reduction(+:dptmass) & !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & !$omp firstprivate(itype,pmassi,ibin_wakei) & - !$omp reduction(+:accretedmass,nfail,naccreted,nlive) - !$omp do + !$omp reduction(+:accretedmass) & + !$omp reduction(+:nfail) & + !$omp reduction(+:naccreted) & + !$omp reduction(+:nlive) & + !$omp reduction(+:dptmass) accreteloop: do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then if (ntypes > 1 .and. maxphase==maxp) then @@ -728,8 +767,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = nlive + 1 endif enddo accreteloop - !$omp enddo - !$omp end parallel + !$omp end parallel do if (npart > 2 .and. nlive < 2) then call fatal('step','all particles accreted',var='nlive',ival=nlive) @@ -779,7 +817,7 @@ 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,fsink_old) + force_count,extf_vdep_flag,fsink_old,group_info) use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & @@ -803,6 +841,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real, intent(in) :: timei,dki,dt logical, intent(in) :: extf_vdep_flag real, optional, intent(inout) :: fsink_old(4,nptmass) + integer, optional, intent(in) :: group_info(:,:) integer :: merge_ij(nptmass) integer :: merge_n integer :: i,itype @@ -811,7 +850,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real :: fextx,fexty,fextz,xi,yi,zi,pmassi,damp_fac real :: fonrmaxi,phii,dtphi2i real :: dkdt,extrapfac - logical :: extrap,last + logical :: extrap,last,wsub if (present(fsink_old)) then fsink_old = fxyz_ptmass @@ -820,6 +859,13 @@ 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 @@ -842,25 +888,50 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (nptmass > 0) then if (id==master) then if (extrap) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + if (wsub) then + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & + extrapfac,fsink_old,group_info) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & + extrapfac,fsink_old,group_info) + endif + else + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n, & dsdt_ptmass,extrapfac,fsink_old) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n, & dsdt_ptmass,extrapfac,fsink_old) + endif endif else - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + if (wsub) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + endif + else + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + endif endif endif else @@ -873,7 +944,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, endif ! - !-- Forces on gas particles (Sink/gas,extf,damp,cooling) + !-- Forces on gas particles (Sink/gas,extf,damp,cooling,rad pressure) ! !$omp parallel default(none) & @@ -883,6 +954,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$omp shared(dkdt,dt,timei,iexternalforce,extf_vdep_flag,last) & !$omp shared(divcurlv,dphotflag,dphot0,nucleation,extrap) & !$omp shared(abundc,abundo,abundsi,abunde,extrapfac,fsink_old) & + !$omp shared(isink_radiation,itau_alloc,tau) & !$omp private(fextx,fexty,fextz,xi,yi,zi) & !$omp private(i,fonrmaxi,dtphi2i,phii,dtf) & !$omp firstprivate(pmassi,itype) & @@ -936,6 +1008,26 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (idamp > 0) then call apply_damp(fextx, fexty, fextz, vxyzu(1:3,i), (/xi,yi,zi/), damp_fac) endif + ! + ! Radiation pressure force with isink_radiation + ! + if (nptmass > 0 .and. isink_radiation > 0) then + 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) + else + call get_rad_accel_from_ptmass(nptmass,npart,i,xi,yi,zi,xyzmh_ptmass,fextx,fexty,fextz, & + fsink_old=fsink_old,extrapfac=extrapfac) + endif + else + if (itau_alloc == 1) then + call get_rad_accel_from_ptmass(nptmass,npart,i,xi,yi,zi,xyzmh_ptmass,fextx,fexty,fextz,tau) + else + call get_rad_accel_from_ptmass(nptmass,npart,i,xi,yi,zi,xyzmh_ptmass,fextx,fexty,fextz) + endif + endif + endif fext(1,i) = fextx fext(2,i) = fexty @@ -943,24 +1035,15 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! ! temperature and abundances update (only done during the last force calculation of the substep) ! - 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) endif - endif enddo !$omp enddo !$omp end parallel - if (nptmass > 0 .and. isink_radiation > 0 .and. .not.extrap) then - if (itau_alloc == 1) then - call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) - else - call get_rad_accel_from_ptmass(nptmass,npart,xyzh,xyzmh_ptmass,fext) - endif - endif if (nptmass > 0) then call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) @@ -1002,7 +1085,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl use cooling_ism, only:nabn,dphotflag use options, only:icooling use chem, only:update_abundances,get_dphot - use dust_formation, only:evolve_dust + use dust_formation, only:evolve_dust,calc_muGamma use cooling, only:energ_cooling,cooling_in_step use part, only:rhoh #ifdef KROME @@ -1019,7 +1102,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl real, intent(in) :: dt,pmassi integer, intent(in) :: i - real :: dudtcool,rhoi,dphot + real :: dudtcool,rhoi,dphot,pH,pH_tot real :: abundi(nabn) dudtcool = 0. @@ -1047,6 +1130,8 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl call evolve_dust(dt, xyzh(:,i), vxyzu(4,i), nucleation(:,i), dust_temp(i), rhoi) eos_vars(imu,i) = nucleation(idmu,i) eos_vars(igamma,i) = nucleation(idgamma,i) + elseif (update_muGamma) then + call calc_muGamma(rhoi, dust_temp(i),eos_vars(imu,i),eos_vars(igamma,i), pH, pH_tot) endif ! ! COOLING @@ -1076,7 +1161,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl endif endif #endif - ! update internal energy + ! update internal energy if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool diff --git a/src/main/utils_dumpfiles.f90 b/src/main/utils_dumpfiles.f90 index aef612992..81b669cc8 100644 --- a/src/main/utils_dumpfiles.f90 +++ b/src/main/utils_dumpfiles.f90 @@ -155,7 +155,7 @@ module dump_utils ! generic interface for reading arrays from dumpfile interface read_array_from_file - module procedure read_array_from_file_r8, read_array_from_file_r4 + module procedure read_array_from_file_r4, read_array_from_file_r8 end interface read_array_from_file private @@ -1358,56 +1358,56 @@ function allocate_header(nint,nint1,nint2,nint4,nint8,nreal,nreal4,nreal8,err) r integer, intent(in), optional :: nint,nint1,nint2,nint4,nint8,nreal,nreal4,nreal8 integer, intent(out), optional :: err type(dump_h) :: hdr - integer :: size(ndatatypes) + integer :: size_type(ndatatypes) integer :: ierrs(ndatatypes) integer :: ierr ! make sure header is deallocated first call free_header(hdr,ierr) - size(:) = maxphead - if (present(nint)) size(i_int) = nint - if (present(nint1)) size(i_int1) = nint1 - if (present(nint2)) size(i_int2) = nint2 - if (present(nint4)) size(i_int4) = nint4 - if (present(nint8)) size(i_int8) = nint8 - if (present(nreal)) size(i_real) = nreal - if (present(nreal4)) size(i_real4) = nreal4 - if (present(nreal8)) size(i_real8) = nreal8 + size_type(:) = maxphead + if (present(nint)) size_type(i_int) = nint + if (present(nint1)) size_type(i_int1) = nint1 + if (present(nint2)) size_type(i_int2) = nint2 + if (present(nint4)) size_type(i_int4) = nint4 + if (present(nint8)) size_type(i_int8) = nint8 + if (present(nreal)) size_type(i_real) = nreal + if (present(nreal4)) size_type(i_real4) = nreal4 + if (present(nreal8)) size_type(i_real8) = nreal8 if (present(err)) err = 0 ierrs(:) = 0 hdr%nums(:) = 0 - if (size(i_int) > 0) then - allocate(hdr%inttags(size(i_int)),hdr%intvals(size(i_int)),stat=ierrs(1)) + if (size_type(i_int) > 0) then + allocate(hdr%inttags(size_type(i_int)),hdr%intvals(size_type(i_int)),stat=ierrs(1)) if (ierrs(1)==0) hdr%inttags(:) = '' endif - if (size(i_int1) > 0) then - allocate(hdr%int1tags(size(i_int1)),hdr%int1vals(size(i_int1)),stat=ierrs(2)) + if (size_type(i_int1) > 0) then + allocate(hdr%int1tags(size_type(i_int1)),hdr%int1vals(size_type(i_int1)),stat=ierrs(2)) if (ierrs(2)==0) hdr%int1tags(:) = '' endif - if (size(i_int2) > 0) then - allocate(hdr%int2tags(size(i_int2)),hdr%int2vals(size(i_int2)),stat=ierrs(3)) + if (size_type(i_int2) > 0) then + allocate(hdr%int2tags(size_type(i_int2)),hdr%int2vals(size_type(i_int2)),stat=ierrs(3)) if (ierrs(3)==0) hdr%int2tags(:) = '' endif - if (size(i_int4) > 0) then - allocate(hdr%int4tags(size(i_int4)),hdr%int4vals(size(i_int4)),stat=ierrs(4)) + if (size_type(i_int4) > 0) then + allocate(hdr%int4tags(size_type(i_int4)),hdr%int4vals(size_type(i_int4)),stat=ierrs(4)) if (ierrs(4)==0) hdr%int4tags(:) = '' endif - if (size(i_int8) > 0) then - allocate(hdr%int8tags(size(i_int8)),hdr%int8vals(size(i_int8)),stat=ierrs(5)) + if (size_type(i_int8) > 0) then + allocate(hdr%int8tags(size_type(i_int8)),hdr%int8vals(size_type(i_int8)),stat=ierrs(5)) if (ierrs(5)==0) hdr%int8tags(:) = '' endif - if (size(i_real) > 0) then - allocate(hdr%realtags(size(i_real)),hdr%realvals(size(i_real)),stat=ierrs(6)) + if (size_type(i_real) > 0) then + allocate(hdr%realtags(size_type(i_real)),hdr%realvals(size_type(i_real)),stat=ierrs(6)) if (ierrs(6)==0) hdr%realtags(:) = '' endif - if (size(i_real4) > 0) then - allocate(hdr%real4tags(size(i_real4)),hdr%real4vals(size(i_real4)),stat=ierrs(7)) + if (size_type(i_real4) > 0) then + allocate(hdr%real4tags(size_type(i_real4)),hdr%real4vals(size_type(i_real4)),stat=ierrs(7)) if (ierrs(7)==0) hdr%real4tags(:) = '' endif - if (size(i_real8) > 0) then - allocate(hdr%real8tags(size(i_real8)),hdr%real8vals(size(i_real8)),stat=ierrs(8)) + if (size_type(i_real8) > 0) then + allocate(hdr%real8tags(size_type(i_real8)),hdr%real8vals(size_type(i_real8)),stat=ierrs(8)) if (ierrs(8)==0) hdr%real8tags(:) = '' endif @@ -2412,17 +2412,19 @@ end subroutine open_dumpfile_rh ! in the file !+ !----------------------------------------------------- -subroutine read_array_from_file_r8(iunit,filename,tag,array,ierr,use_block) +subroutine read_array_from_file_r8(iunit,filename,tag,array,ierr,use_block,iprint_in) integer, intent(in) :: iunit character(len=*), intent(in) :: filename character(len=*), intent(in) :: tag real(kind=8), intent(out) :: array(:) integer, intent(out) :: ierr integer, intent(in), optional :: use_block + logical, intent(in), optional :: iprint_in integer, parameter :: maxarraylengths = 12 integer(kind=8) :: number8(maxarraylengths) integer :: i,j,k,iblock,nums(ndatatypes,maxarraylengths) integer :: nblocks,narraylengths,my_block + logical :: iprint character(len=lentag) :: mytag @@ -2431,6 +2433,14 @@ subroutine read_array_from_file_r8(iunit,filename,tag,array,ierr,use_block) else my_block = 1 ! match from block 1 by default endif + + ! if printing the tags + if (present(iprint_in)) then + iprint = iprint_in + else + iprint = .true. + endif + array = 0. ! open file for read and get minimal information from header @@ -2448,9 +2458,9 @@ subroutine read_array_from_file_r8(iunit,filename,tag,array,ierr,use_block) read(iunit,iostat=ierr) mytag if (trim(mytag)==trim(tag)) then read(iunit,iostat=ierr) array(1:min(int(number8(j)),size(array))) - print*,'->',mytag + if (iprint) print*,'->',mytag else - print*,' ',mytag + if (iprint) print*,' ',mytag read(iunit,iostat=ierr) endif else @@ -2474,24 +2484,34 @@ end subroutine read_array_from_file_r8 ! in the file !+ !----------------------------------------------------- -subroutine read_array_from_file_r4(iunit,filename,tag,array,ierr,use_block) +subroutine read_array_from_file_r4(iunit,filename,tag,array,ierr,use_block,iprint_in) integer, intent(in) :: iunit character(len=*), intent(in) :: filename character(len=*), intent(in) :: tag real(kind=4), intent(out) :: array(:) integer, intent(out) :: ierr integer, intent(in), optional :: use_block + logical, intent(in), optional :: iprint_in integer, parameter :: maxarraylengths = 12 integer(kind=8) :: number8(maxarraylengths) integer :: i,j,k,iblock,nums(ndatatypes,maxarraylengths) integer :: nblocks,narraylengths,my_block character(len=lentag) :: mytag + logical :: iprint if (present(use_block)) then my_block = use_block else my_block = 1 ! match from block 1 by default endif + + ! if printing the tags + if (present(iprint_in)) then + iprint = iprint_in + else + iprint = .true. + endif + array = 0. ! open file for read @@ -2509,9 +2529,9 @@ subroutine read_array_from_file_r4(iunit,filename,tag,array,ierr,use_block) read(iunit,iostat=ierr) mytag if (trim(mytag)==trim(tag)) then read(iunit,iostat=ierr) array(1:min(int(number8(j)),size(array))) - print*,'->',mytag + if (iprint) print*,'->',mytag else - print*,' ',mytag + if (iprint) print*,' ',mytag read(iunit,iostat=ierr) endif else diff --git a/src/main/utils_infiles.f90 b/src/main/utils_infiles.f90 index c40332b25..1a5259b6c 100644 --- a/src/main/utils_infiles.f90 +++ b/src/main/utils_infiles.f90 @@ -443,11 +443,17 @@ subroutine read_inopt_int(ival,tag,db,err,errcount,min,max) if (ierr==0) then if (present(min)) then write(chmin,"(g10.0)") min - if (ival < min) ierr = ierr_rangemin + if (ival < min) then + ierr = ierr_rangemin + ival = min + endif endif if (present(max)) then write(chmax,"(g10.0)") max - if (ival > max) ierr = ierr_rangemax + if (ival > max) then + ierr = ierr_rangemax + ival = max + endif endif endif @@ -493,11 +499,17 @@ subroutine read_inopt_real(val,tag,db,err,errcount,min,max) if (ierr==0) then if (present(min)) then write(chmin,"(g13.4)") min - if (val < min) ierr = ierr_rangemin + if (val < min) then + ierr = ierr_rangemin + val = min + endif endif if (present(max)) then write(chmax,"(g13.4)") max - if (val > max) ierr = ierr_rangemax + if (val > max) then + ierr = ierr_rangemax + val = max + endif endif endif if (present(err)) then diff --git a/src/main/utils_kepler.f90 b/src/main/utils_kepler.f90 new file mode 100644 index 000000000..deb5de94b --- /dev/null +++ b/src/main/utils_kepler.f90 @@ -0,0 +1,139 @@ +!--------------------------------------------------------------------------! +! 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 utils_kepler +! +! utils_kepler +! +! :References: None +! +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: physcon +! + use physcon,only: pi + implicit none + +contains +subroutine Espec(v2,r,mu,B) + real, intent(in) :: v2,r,mu + real, intent(out) :: B + + B = 0.5*v2 - mu/r + +end subroutine Espec + +subroutine extract_a(r,mu,v2,aij) + real, intent(in) :: r,mu,v2 + real, intent(out):: aij + aij = (r*mu)/(2.*mu-r*v2) + +end subroutine extract_a + +subroutine extract_a_dot(r2,r,mu,v2,v,acc,adot) + real, intent(in) :: r2,r,mu,v2,v,acc + real, intent(out) :: adot + real :: mu2 + mu2 = mu**2 + adot = 2.*(mu2*v+r2*v*acc)/((2.*mu-r*v2)**2) +end subroutine extract_a_dot + +subroutine extract_e(x,y,z,vx,vy,vz,mu,r,eij) + real, intent(in) :: x,y,z,vx,vy,vz,mu,r + real, intent(out):: eij + real :: eijx,eijy,eijz + real :: hx,hy,hz + + hx = y*vz-z*vy + hy = z*vx-x*vz + hz = x*vy-y*vx + + eijx = (vy*hz-vz*hy)/mu - x/r + eijy = (vz*hx-vx*hz)/mu - y/r + eijz = (vx*hy-hx*vy)/mu - z/r + + eij = sqrt(eijx**2+eijy**2+eijz**2) + +end subroutine extract_e + +subroutine extract_ea(x,y,z,vx,vy,vz,mu,aij,eij) + real, intent(in) :: x,y,z,vx,vy,vz,mu,aij + real, intent(out):: eij + real :: hx,hy,hz,h2,neg_e + + hx = y*vz-z*vy + hy = z*vx-x*vz + hz = x*vy-y*vx + + h2 = hx**2+hy**2+hz**2 + + neg_e = h2/(mu*aij) + print*,neg_e + if (neg_e>=1) then + eij = 0. + else + eij = sqrt(1-neg_e) + endif + +end subroutine extract_ea + +subroutine extract_kep_elmt(x,y,z,vx,vy,vz,mu,r,a,e,i,argp,longi,M) + real, intent(in) :: x,y,z,vx,vy,vz,mu,r + real, intent(out):: a,e,i,argp,longi,M + real :: hx,hy,hz,ex,ey,ez,v2,h,anoE,nu + real :: rdote,n,ndote + + v2 = vx**2+vy**2+vz**2 + + a = (r*mu)/(2*mu-r*v2) + + hx = y*vz-z*vy + hy = z*vx-x*vz + hz = x*vy-y*vx + + h = sqrt(hx*2+hy**2+hz**2) + i = acos(hz/h) + + ex = (vy*hz-vz*hy)/mu - x/r + ey = (vz*hx-vx*hz)/mu - y/r + ez = (vx*hy-hx*vy)/mu - z/r + + e = sqrt(ex**2+ey**2+ez**2) + + rdote = x*ex+y*ey+z*ez + + if (x*vx+y*vy+z*vz>=0) then + nu = acos(rdote/(e*r)) + else + nu = 2*pi - acos(rdote/(e*r)) + endif + anoE = tan(nu*0.5)/sqrt((1+e)/(1-e)) + anoE = 2*atan(anoE) + + M = E-e*sin(E) + + n = sqrt(hy**2+hx**2) + if (hx>=0) then + longi = acos(-hy/n) + else + longi = 2*pi - acos(-hy/n) + endif + + ndote = -hy*ex + hx*ey + if (ez>=0) then + argp = acos(ndote/(n*e)) + else + argp = 2*pi - acos(ndote/(n*e)) + endif + +end subroutine extract_kep_elmt + + + + +end module utils_kepler diff --git a/src/main/utils_subgroup.f90 b/src/main/utils_subgroup.f90 new file mode 100644 index 000000000..913a57606 --- /dev/null +++ b/src/main/utils_subgroup.f90 @@ -0,0 +1,35 @@ +!--------------------------------------------------------------------------! +! 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 utils_subgroup +! +! utils_subgroup +! +! :References: None +! +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: None +! + implicit none + integer, parameter :: ck_size = 8 + real,dimension(8),parameter :: cks=(/0.3922568052387800,0.5100434119184585,-0.4710533854097566,& + 0.0687531682525181,0.0687531682525181,-0.4710533854097566,& + 0.5100434119184585,0.3922568052387800/) + real,dimension(8),parameter :: cck_sorted=(/0.0976997828427615,0.3922568052387800,0.4312468317474820,& + 0.5000000000000000,0.5687531682525181,0.6077431947612200,& + 0.9023002171572385,1.0000000000000000/) + real,dimension(8),parameter :: dks=(/0.7845136104775600,0.2355732133593570,-1.1776799841788701,& + 1.3151863206839063,-1.1776799841788701,0.2355732133593570,& + 0.7845136104775600,0.0000000000000000/) + integer,dimension(8),parameter :: cck_sorted_id=(/6,1,3,4,5,7,2,8/) + + +contains + +end module utils_subgroup diff --git a/src/main/wind.F90 b/src/main/wind.F90 index 259e21e5c..3bb364228 100644 --- a/src/main/wind.F90 +++ b/src/main/wind.F90 @@ -207,8 +207,7 @@ subroutine wind_step(state) use cooling_solver, only:calc_cooling_rate use options, only:icooling use units, only:unit_ergg,unit_density - use dim, only:itau_alloc - use eos, only:ieos + use dim, only:itau_alloc,update_muGamma type(wind_state), intent(inout) :: state real :: rvT(3), dt_next, v_old, dlnQ_dlnT, Q_code, pH, pH_tot @@ -241,9 +240,9 @@ subroutine wind_step(state) state%gamma = state%JKmuS(idgamma) state%kappa = calc_kappa_dust(state%JKmuS(idK3), state%Tdust, state%rho) state%JKmuS(idalpha) = state%alpha_Edd+alpha_rad - elseif (idust_opacity == 1) then - state%kappa = calc_kappa_bowen(state%Tdust) - if (ieos == 5) call calc_muGamma(state%rho, state%Tg,state%mu, state%gamma, pH, pH_tot) + else + if (idust_opacity == 1) state%kappa = calc_kappa_bowen(state%Tdust) + if (update_muGamma) call calc_muGamma(state%rho, state%Tg,state%mu, state%gamma, pH, pH_tot) endif if (itau_alloc == 1) then @@ -345,13 +344,12 @@ subroutine wind_step(state) use ptmass_radiation, only:alpha_rad,iget_tdust,tdust_exp, isink_radiation use physcon, only:pi,Rg use dust_formation, only:evolve_chem,calc_kappa_dust,calc_kappa_bowen,& - calc_Eddington_factor,idust_opacity, calc_mugamma + calc_Eddington_factor,idust_opacity, calc_muGamma use part, only:idK3,idmu,idgamma,idsat,idkappa use cooling_solver, only:calc_cooling_rate use options, only:icooling use units, only:unit_ergg,unit_density - use dim, only:itau_alloc - use eos, only:ieos + use dim, only:itau_alloc,update_muGamma type(wind_state), intent(inout) :: state real :: rvT(3), dt_next, v_old, dlnQ_dlnT, Q_code, pH,pH_tot @@ -365,9 +363,9 @@ subroutine wind_step(state) state%mu = state%JKmuS(idmu) state%gamma = state%JKmuS(idgamma) state%kappa = calc_kappa_dust(state%JKmuS(idK3), state%Tdust, state%rho) - elseif (idust_opacity == 1) then - state%kappa = calc_kappa_bowen(state%Tdust) - if (ieos == 5 ) call calc_muGamma(state%rho, state%Tg,state%mu, state%gamma, pH, pH_tot) + else + if (idust_opacity == 1) state%kappa = calc_kappa_bowen(state%Tdust) + if (update_muGamma) call calc_muGamma(state%rho, state%Tg,state%mu, state%gamma, pH, pH_tot) endif if (itau_alloc == 1) then diff --git a/src/main/wind_equations.f90 b/src/main/wind_equations.f90 index ac0a78922..db79e9431 100644 --- a/src/main/wind_equations.f90 +++ b/src/main/wind_equations.f90 @@ -14,7 +14,7 @@ module wind_equations ! ! :Runtime parameters: None ! -! :Dependencies: dust_formation, eos, options, physcon +! :Dependencies: dim, dust_formation, eos, options, physcon ! implicit none @@ -290,6 +290,7 @@ end subroutine RK4_step_dr subroutine calc_dvT_dr(r, v, T0, Rstar_cgs, Mdot_cgs, mu0, gamma0, alpha, dalpha_dr, Q, dQ_dr, dv_dr, dT_dr, numerator, denominator) !all quantities in cgs use physcon, only:Gg,Rg,pi + use dim, only:update_muGamma use options, only:icooling,ieos use dust_formation, only:calc_muGamma,idust_opacity real, intent(in) :: r, v, T0, mu0, gamma0, alpha, dalpha_dr, Q, dQ_dr, Rstar_cgs, Mdot_cgs @@ -302,7 +303,7 @@ subroutine calc_dvT_dr(r, v, T0, Rstar_cgs, Mdot_cgs, mu0, gamma0, alpha, dalpha T = T0 mu = mu0 gamma = gamma0 - if (idust_opacity == 2) then + if (update_muGamma .or. idust_opacity == 2) then rho_cgs = Mdot_cgs/(4.*pi*r**2*v) call calc_muGamma(rho_cgs, T, mu, gamma, pH, pH_tot) endif diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 new file mode 100644 index 000000000..6940ad2aa --- /dev/null +++ b/src/setup/set_orbit.f90 @@ -0,0 +1,285 @@ +!--------------------------------------------------------------------------! +! 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 setorbit +! +! Generic procedure for setting up two body orbits with +! different parameter sets for the orbital elements +! +! The current options are: +! 0) Campbell elements for bound or unbound orbit (aeiOwf) +! 1) Flyby parameters (periapsis, initial separation, argument of periapsis, inclination) +! 2) position and velocity for both bodies + +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils, physcon, setbinary, setflyby, units +! + +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: physcon +! + implicit none + public :: set_orbit + public :: set_defaults_orbit,write_options_orbit,read_options_orbit + public :: orbit_t +! + ! define data types with options needed + ! to setup an orbit + ! + type campbell_elems + character(len=20) :: semi_major_axis ! string because can specific units + real :: e ! eccentricity + real :: i ! inclination + real :: O ! position angle of the ascending node + real :: w ! argument of periapsis + real :: f ! initial true anomaly + 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 + end type posvel_elems + + type flyby_elems + character(len=20) :: rp ! pericentre distance in arbitrary units + real :: d ! initial separation + real :: O ! position angle of the ascending node + real :: i ! inclination + end type flyby_elems + + ! + ! generic type handling all options + ! + type orbit_t + integer :: itype + type(campbell_elems) :: elems + type(flyby_elems) :: flyby + type(posvel_elems) :: posvel + end type orbit_t + + private + +contains + +!---------------------------------------------------------------- +!+ +! default parameters for orbit type +!+ +!---------------------------------------------------------------- +subroutine set_defaults_orbit(orbit) + type(orbit_t), intent(out) :: orbit + + orbit%itype = 0 + orbit%elems%semi_major_axis = '10.' + orbit%elems%e = 0.0 + orbit%elems%i = 0.0 + orbit%elems%O = 0.0 + orbit%elems%w = 270. ! argument of periapsis + orbit%elems%f = 180. ! start orbit at apocentre + + orbit%flyby%rp = '10.' + 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 + +end subroutine set_defaults_orbit + +!---------------------------------------------------------------- +!+ +! setup for two body orbit +!+ +!---------------------------------------------------------------- +subroutine set_orbit(orbit,m1,m2,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,verbose,ierr,omega_corotate) + use physcon, only:days + use units, only:in_code_units,is_time_unit,utime + use setbinary, only:set_binary,get_a_from_period + use setflyby, only:set_flyby + type(orbit_t), intent(in) :: orbit + real, intent(in) :: m1,m2,hacc1,hacc2 + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(inout) :: nptmass + logical, intent(in) :: verbose + integer, intent(out) :: ierr + real, intent(out), optional :: omega_corotate + real :: rp,a + + ierr = 0 + select case(orbit%itype) + case(2) + ! body 1 + xyzmh_ptmass(1:3,nptmass+1) = orbit%posvel%x1(1:3) + xyzmh_ptmass(4,nptmass+1) = m1 + xyzmh_ptmass(5,nptmass+1) = hacc1 + vxyz_ptmass(1:3,nptmass+1) = orbit%posvel%v1(1:3) + ! body 2 + xyzmh_ptmass(1:3,nptmass+2) = orbit%posvel%x2(1:3) + xyzmh_ptmass(4,nptmass+2) = m2 + xyzmh_ptmass(5,nptmass+2) = hacc2 + vxyz_ptmass(1:3,nptmass+2) = orbit%posvel%v2(1:3) + case(1) + rp = in_code_units(orbit%flyby%rp,ierr) + + call set_flyby(m1,m2,rp,orbit%flyby%d,hacc1,hacc2,xyzmh_ptmass, & + vxyz_ptmass,nptmass,ierr,orbit%flyby%O,orbit%flyby%i,verbose=verbose) + case default + ! + !--if a is negative or is given time units, interpret this as a period + ! + a = in_code_units(orbit%elems%semi_major_axis,ierr) + if (is_time_unit(orbit%elems%semi_major_axis) .and. ierr == 0) then + a = -abs(a) + print "(a,g0,a,g0,a)",' Using PERIOD = ',abs(a),' = ',abs(a)*utime/days,' days' + endif + if (a < 0.) a = get_a_from_period(m1,m2,abs(a)) + ! + !--now setup orbit using sink particles + ! + if (present(omega_corotate)) then + call set_binary(m1,m2,a,orbit%elems%e,hacc1,hacc2,& + xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,omega_corotate,& + posang_ascnode=orbit%elems%O,arg_peri=orbit%elems%w,& + incl=orbit%elems%i,f=orbit%elems%f,verbose=verbose) + else + call set_binary(m1,m2,a,orbit%elems%e,hacc1,hacc2,& + xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,& + posang_ascnode=orbit%elems%O,arg_peri=orbit%elems%w,& + incl=orbit%elems%i,f=orbit%elems%f,verbose=verbose) + endif + end select + +end subroutine set_orbit + +!---------------------------------------------------------------- +!+ +! write options to .setup file +!+ +!---------------------------------------------------------------- +subroutine write_options_orbit(orbit,iunit,label) + use infile_utils, only:write_inopt + type(orbit_t), intent(in) :: orbit + integer, intent(in) :: iunit + character(len=*), intent(in), optional :: label + character(len=10) :: c + + ! append optional label e.g. '1', '2' + c = '' + if (present(label)) c = trim(adjustl(label)) + + write(iunit,"(/,a)") '# orbit '//trim(c) + 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) + 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%O,'O'//trim(c),'position angle of the ascending node',iunit) + call write_inopt(orbit%flyby%i,'i'//trim(c),'inclination',iunit) + case default + call write_inopt(orbit%elems%semi_major_axis,'a'//trim(c),& + 'semi-major axis (e.g. 1 au), period (e.g. 10*days) or rp if e=1',iunit) + call write_inopt(orbit%elems%e,'ecc'//trim(c),'eccentricity',iunit) + call write_inopt(orbit%elems%i,'inc'//trim(c),'inclination (deg)',iunit) + call write_inopt(orbit%elems%O,'O'//trim(c),'position angle of ascending node (deg)',iunit) + call write_inopt(orbit%elems%w,'w'//trim(c),'argument of periapsis (deg)',iunit) + call write_inopt(orbit%elems%f,'f'//trim(c),'initial true anomaly (180=apoastron)',iunit) + end select + +end subroutine write_options_orbit + +!---------------------------------------------------------------- +!+ +! read options from .setup file +!+ +!---------------------------------------------------------------- +subroutine read_options_orbit(orbit,db,nerr,label) + use infile_utils, only:inopts,read_inopt + type(orbit_t), intent(out) :: orbit + type(inopts), allocatable, intent(inout) :: db(:) + integer, intent(inout) :: nerr + character(len=*), intent(in), optional :: label + character(len=10) :: c + + ! append optional label e.g. '1', '2' + c = '' + if (present(label)) c = trim(adjustl(label)) + + call read_inopt(orbit%itype,'itype'//trim(c),db,errcount=nerr,min=0,max=2) + select case(orbit%itype) + case(2) + call read_inopt(orbit%posvel%x1(1),'x1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%x1(2),'y1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%x1(3),'z1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v1(1),'vx1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v1(2),'vy1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v1(3),'vz1'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%x2(1),'x2'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%x2(2),'y2'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%x2(3),'z2'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v2(1),'vx2'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v2(2),'vy2'//trim(c),db,errcount=nerr) + call read_inopt(orbit%posvel%v2(3),'vz2'//trim(c),db,errcount=nerr) + case(1) + call read_inopt(orbit%flyby%rp,'rp'//trim(c),db,errcount=nerr) + call read_inopt(orbit%flyby%d,'d'//trim(c),db,errcount=nerr) + call read_inopt(orbit%flyby%O,'O'//trim(c),db,errcount=nerr) + call read_inopt(orbit%flyby%i,'i'//trim(c),db,errcount=nerr) + case default + call read_inopt(orbit%elems%semi_major_axis,'a'//trim(c),db,errcount=nerr) + call read_inopt(orbit%elems%e,'ecc'//trim(c),db,min=0.,errcount=nerr) + call read_inopt(orbit%elems%i,'inc'//trim(c),db,errcount=nerr) + call read_inopt(orbit%elems%O,'O'//trim(c),db,errcount=nerr) + call read_inopt(orbit%elems%w,'w'//trim(c),db,errcount=nerr) + call read_inopt(orbit%elems%f,'f'//trim(c),db,errcount=nerr) + end select + +end subroutine read_options_orbit + +end module setorbit From d9cf540964d56ebf9f6c621d5be26e91c478fd64 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 24 Jun 2024 09:30:19 +0200 Subject: [PATCH 638/814] (HIIRegion) forgot to scale rate coefficients to code units... --- src/main/H2regions.f90 | 39 +++++++++++++++++++++++++++++---------- 1 file changed, 29 insertions(+), 10 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index cd52890d1..5c68b40a7 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -24,18 +24,24 @@ module HIIRegion integer, public :: iH2R = 0 real , public :: Rmax = 15 ! Maximum HII region radius (pc) to avoid artificial expansion... real , public :: Mmin = 8 ! Minimum mass (Msun) to produce HII region - real , public :: nHIIsources = 0 + integer, public :: nHIIsources = 0 real , public :: ar real , public :: mH - real, parameter :: a = -39.3178 ! - real, parameter :: b = 221.997 ! fitted parameters to compute - real, parameter :: c = -227.456 ! ionisation rate for massive - real, parameter :: d = 117.410 ! extracted from Fujii et al. (2021). - real, parameter :: e = -30.1511 ! (Expressed in function of log(solar masses) and s) - real, parameter :: f = 3.06810 ! + real, parameter :: a_u = -39.3178 ! + real, parameter :: b_u = 221.997 ! fitted parameters to compute + real, parameter :: c_u = -227.456 ! ionisation rate for massive + real, parameter :: d_u = 117.410 ! extracted from Fujii et al. (2021). + real, parameter :: e_u = -30.1511 ! (Expressed in function of log(solar masses) and s) + real, parameter :: f_u = 3.06810 ! real, parameter :: ar_cgs = 2.7d-13 real, parameter :: sigd_cgs = 1.d-21 + real :: a + real :: b + real :: c + real :: d + real :: e + real :: f real :: sigd real :: hv_on_c real :: T_ion @@ -58,6 +64,7 @@ subroutine initialize_H2R use units, only:udist,umass,utime use physcon, only:mass_proton_cgs,kboltz,pc,eV,solarm use eos , only:gmw + real :: logumass,logumass2,logumass3 isionised(:)=.false. !calculate the useful constant in code units mH = gmw*mass_proton_cgs @@ -69,10 +76,22 @@ subroutine initialize_H2R hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) Rst_max = sqrt(((Rmax*pc)/udist)**2) Minmass = (Mmin*solarm)/umass + logumass = log10(umass) + logumass2 = logumass**2 + logumass3 = logumass2*logumass + + a = a_u*utime + b = b_u*utime*(solarm/logumass) + c = c_u*utime*(solarm/logumass2) + d = d_u*utime*(solarm/logumass3) + e = e_u*utime*(solarm/(logumass2**2)) + f = f_u*utime*(solarm/(logumass3*logumass2)) + if (id == master .and. iverbose > 1) then write(iprint,"(/a,es18.10,es18.10/)") "feedback constants mH, u_to_t : ", mH, u_to_t write(iprint,"(/a,es18.10,es18.10/)") "Max strögrem radius (code/pc) : ", Rst_max, Rmax write(iprint,"(/a,es18.10,es18.10/)") "Min feedback mass (code/Msun) : ", Minmass, Mmin + write(iprint,"(/a,es18.10,es18.10/)") "Rate coefficient (code) : ", a,b,c,d,e,f endif return end subroutine initialize_H2R @@ -105,11 +124,11 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) - Q = (10.**log_Q)*utime + Q = (10.**log_Q) xyzmh_ptmass(irateion,i) = Q nHIIsources = nHIIsources + 1 if (iverbose > 0) then - write(iprint,"(/a,es18.10/)")"Massive stars detected : Log Q : ",log_Q + write(iprint,"(/a,es18.10,es18.10/)")"Massive stars detected : Log Q, Mass : ",log_Q,mi endif else xyzmh_ptmass(irateion,i) = -1. @@ -141,7 +160,7 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) xyzmh_ptmass(irateion,i) = Q nHIIsources = nHIIsources + 1 if (iverbose > 0) then - write(iprint,"(/a,es18.10/)")"(HII region) Massive stars detected : Log Q : ",log_Q + write(iprint,"(/a,es18.10,es18.10/)")"Massive stars detected : Log Q, Mass : ",log_Q,mi endif else xyzmh_ptmass(irateion,i) = -1. From ec262886d66d7461269a6edb5a6a44e5b61fd87c Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 24 Jun 2024 09:50:47 +0200 Subject: [PATCH 639/814] (HIIRegion) still wrong rate coeffs --- src/main/H2regions.f90 | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 5c68b40a7..d7fb80aa5 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -64,7 +64,7 @@ subroutine initialize_H2R use units, only:udist,umass,utime use physcon, only:mass_proton_cgs,kboltz,pc,eV,solarm use eos , only:gmw - real :: logumass,logumass2,logumass3 + real :: logumass,logumass2,logumass3,logutime isionised(:)=.false. !calculate the useful constant in code units mH = gmw*mass_proton_cgs @@ -79,19 +79,20 @@ subroutine initialize_H2R logumass = log10(umass) logumass2 = logumass**2 logumass3 = logumass2*logumass + logutime = log10(utime) - a = a_u*utime - b = b_u*utime*(solarm/logumass) - c = c_u*utime*(solarm/logumass2) - d = d_u*utime*(solarm/logumass3) - e = e_u*utime*(solarm/(logumass2**2)) - f = f_u*utime*(solarm/(logumass3*logumass2)) + a = a_u*logutime + b = b_u*logutime*(solarm/logumass) + c = c_u*logutime*(solarm/logumass2) + d = d_u*logutime*(solarm/logumass3) + e = e_u*logutime*(solarm/(logumass2**2)) + f = f_u*logutime*(solarm/(logumass3*logumass2)) if (id == master .and. iverbose > 1) then write(iprint,"(/a,es18.10,es18.10/)") "feedback constants mH, u_to_t : ", mH, u_to_t write(iprint,"(/a,es18.10,es18.10/)") "Max strögrem radius (code/pc) : ", Rst_max, Rmax write(iprint,"(/a,es18.10,es18.10/)") "Min feedback mass (code/Msun) : ", Minmass, Mmin - write(iprint,"(/a,es18.10,es18.10/)") "Rate coefficient (code) : ", a,b,c,d,e,f + write(iprint,"(/a,6(es18.10)/)") "Rate coefficient (code) : ", a,b,c,d,e,f endif return end subroutine initialize_H2R @@ -113,7 +114,8 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) integer :: i nHIIsources = 0 !$omp parallel do default(none) & - !$omp shared(xyzmh_ptmass,nptmass,iprint,iverbose,utime,Minmass,h_acc)& + !$omp shared(xyzmh_ptmass,nptmass,iprint,iverbose)& + !$omp shared(utime,Minmass,h_acc,a,b,c,d,e,f)& !$omp private(logmi,log_Q,Q,mi,hi)& !$omp reduction(+:nHIIsources) do i=1,nptmass From 4c9c8bab2666a6f62b2e5376e4d474ea73ccb6d3 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 24 Jun 2024 13:17:20 +0200 Subject: [PATCH 640/814] (HIIRegion) back to SI unit to compute Q... --- src/main/H2regions.f90 | 43 ++++++++++++------------------------------ 1 file changed, 12 insertions(+), 31 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index d7fb80aa5..449b24c71 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -28,20 +28,14 @@ module HIIRegion real , public :: ar real , public :: mH - real, parameter :: a_u = -39.3178 ! - real, parameter :: b_u = 221.997 ! fitted parameters to compute - real, parameter :: c_u = -227.456 ! ionisation rate for massive - real, parameter :: d_u = 117.410 ! extracted from Fujii et al. (2021). - real, parameter :: e_u = -30.1511 ! (Expressed in function of log(solar masses) and s) - real, parameter :: f_u = 3.06810 ! + real, parameter :: a = -39.3178 ! + real, parameter :: b = 221.997 ! fitted parameters to compute + real, parameter :: c = -227.456 ! ionisation rate for massive + real, parameter :: d = 117.410 ! extracted from Fujii et al. (2021). + real, parameter :: e = -30.1511 ! (Expressed in function of log(solar masses) and s) + real, parameter :: f = 3.06810 ! real, parameter :: ar_cgs = 2.7d-13 real, parameter :: sigd_cgs = 1.d-21 - real :: a - real :: b - real :: c - real :: d - real :: e - real :: f real :: sigd real :: hv_on_c real :: T_ion @@ -64,7 +58,6 @@ subroutine initialize_H2R use units, only:udist,umass,utime use physcon, only:mass_proton_cgs,kboltz,pc,eV,solarm use eos , only:gmw - real :: logumass,logumass2,logumass3,logutime isionised(:)=.false. !calculate the useful constant in code units mH = gmw*mass_proton_cgs @@ -76,23 +69,11 @@ subroutine initialize_H2R hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) Rst_max = sqrt(((Rmax*pc)/udist)**2) Minmass = (Mmin*solarm)/umass - logumass = log10(umass) - logumass2 = logumass**2 - logumass3 = logumass2*logumass - logutime = log10(utime) - - a = a_u*logutime - b = b_u*logutime*(solarm/logumass) - c = c_u*logutime*(solarm/logumass2) - d = d_u*logutime*(solarm/logumass3) - e = e_u*logutime*(solarm/(logumass2**2)) - f = f_u*logutime*(solarm/(logumass3*logumass2)) if (id == master .and. iverbose > 1) then write(iprint,"(/a,es18.10,es18.10/)") "feedback constants mH, u_to_t : ", mH, u_to_t write(iprint,"(/a,es18.10,es18.10/)") "Max strögrem radius (code/pc) : ", Rst_max, Rmax write(iprint,"(/a,es18.10,es18.10/)") "Min feedback mass (code/Msun) : ", Minmass, Mmin - write(iprint,"(/a,6(es18.10)/)") "Rate coefficient (code) : ", a,b,c,d,e,f endif return end subroutine initialize_H2R @@ -114,19 +95,19 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) integer :: i nHIIsources = 0 !$omp parallel do default(none) & - !$omp shared(xyzmh_ptmass,nptmass,iprint,iverbose)& - !$omp shared(utime,Minmass,h_acc,a,b,c,d,e,f)& + !$omp shared(xyzmh_ptmass,iprint,iverbose)& + !$omp shared(utime,Minmass,h_acc,nptmass)& !$omp private(logmi,log_Q,Q,mi,hi)& !$omp reduction(+:nHIIsources) do i=1,nptmass mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) if(mi > Minmass .and. hi < h_acc)then - logmi = log10(mi) + logmi = log10(mi*(umass/solarm)) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) - Q = (10.**log_Q) + Q = (10.**log_Q)*utime xyzmh_ptmass(irateion,i) = Q nHIIsources = nHIIsources + 1 if (iverbose > 0) then @@ -145,7 +126,7 @@ end subroutine update_ionrates subroutine update_ionrate(i,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose - use units, only:utime + use units, only:utime,umass use part, only:irateion,ihacc integer, intent(in) :: i real, intent(inout) :: xyzmh_ptmass(:,:) @@ -154,7 +135,7 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) if(mi > Minmass .and. hi < h_acc)then - logmi = log10(mi) + logmi = log10(mi*(umass/solarm)) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) From bc20f7c13efa1aea04bd0716045b05f0100d892a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 24 Jun 2024 13:19:49 +0200 Subject: [PATCH 641/814] (HIIRegion) quick fix --- src/main/H2regions.f90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 449b24c71..54cf47c77 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -86,8 +86,9 @@ end subroutine initialize_H2R subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose - use units, only:utime + use units, only:utime,umass use part, only:irateion,ihacc + use physcon,only:solarm integer, intent(in) :: nptmass real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: h_acc @@ -95,7 +96,7 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) integer :: i nHIIsources = 0 !$omp parallel do default(none) & - !$omp shared(xyzmh_ptmass,iprint,iverbose)& + !$omp shared(xyzmh_ptmass,iprint,iverbose,umass)& !$omp shared(utime,Minmass,h_acc,nptmass)& !$omp private(logmi,log_Q,Q,mi,hi)& !$omp reduction(+:nHIIsources) @@ -128,6 +129,7 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose use units, only:utime,umass use part, only:irateion,ihacc + use physcon,only:solarm integer, intent(in) :: i real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: h_acc From f9fbf1b18dc00173ff50d60bdf272537a6cec338 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 24 Jun 2024 16:20:02 +0200 Subject: [PATCH 642/814] (ptmass) add test falg to skip force calc if no new stars is formed --- src/main/evolve.F90 | 17 ++++++++++------- src/main/ptmass.F90 | 6 +++++- src/tests/test_ptmass.f90 | 3 ++- 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index b92643c1b..450affe97 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -140,6 +140,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) logical :: should_conserve_energy,should_conserve_momentum,should_conserve_angmom logical :: should_conserve_dustmass logical :: use_global_dt + logical :: star_formed integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold character(len=120) :: dumpfile_orig integer :: dummy @@ -286,16 +287,18 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) 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) if (icreate_sinks == 2) then - call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time) - if (use_regnbody) then - call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& + call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink, & + linklist_ptmass,time,star_formed) + if(star_formed) then + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,group_info=group_info) - else - call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& + 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) + endif endif - endif endif ! diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 9f6ee9c24..6d259733d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1621,7 +1621,7 @@ subroutine ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) nptmass = n end subroutine ptmass_create_seeds -subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time) +subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time,formed) use dim, only:maxptmass use physcon, only:solarm,pi use io, only:iprint,iverbose @@ -1634,18 +1634,22 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(4,maxptmass),fxyz_ptmass_sinksink(4,maxptmass) real, intent(in) :: time + logical, intent(out) :: formed real, allocatable :: masses(:) real :: xi(3),vi(3) integer :: i,k,n real :: tbirthi,mi,hacci,minmass,mcutoff real :: a(8),velk,rk,xk(3),vk(3),rvir + formed = .false. + do i=1,nptmass mi = xyzmh_ptmass(4,i) hacci = xyzmh_ptmass(ihacc,i) tbirthi = xyzmh_ptmass(itbirth,i) if (mi<0.) cycle if (time>=tbirthi+tmax_acc .and. hacci==h_acc ) then + formed = .true. write(iprint,"(a,es18.10)") "ptmass_create_stars : new stars formed at : ",time !! save xcom and vcom before placing stars xi(1) = xyzmh_ptmass(1,i) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 55ba7ad67..2831d8315 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -785,6 +785,7 @@ subroutine test_createsink(ntests,npass) integer :: id_rhomax,ipart_rhomax_global real :: psep,totmass,r2min,r2,t,coremass,starsmass real :: etotin,angmomin,totmomin,rhomax,rhomax_test + logical :: formed procedure(rho_func), pointer :: density_func density_func => gaussianr @@ -906,7 +907,7 @@ subroutine test_createsink(ntests,npass) coremass = 0. starsmass = 0. coremass = xyzmh_ptmass(4,1) - call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,0.) + call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,0.,formed) do i=1,nptmass starsmass = starsmass + xyzmh_ptmass(4,i) enddo From e9e5bba8a8c23258677f5bdf9dad1c6c0cd4afda Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 24 Jun 2024 15:35:23 +0100 Subject: [PATCH 643/814] Merged Phantom upstream updates --- src/main/cooling_radapprox.f90 | 1 - src/main/deriv.F90 | 1 - src/main/energies.F90 | 451 +++++++++++++++++++-------------- src/main/ptmass_radiation.f90 | 102 ++++---- src/main/step_leapfrog.F90 | 6 +- 5 files changed, 311 insertions(+), 250 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index b7ea939e4..95217989d 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -84,7 +84,6 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) write (filename, 11) dt 11 format("coolrate_", E7.2,".dat") - print *, "In cooling" ratefile = 34 open(unit=ratefile,file=filename,status="replace",form="formatted") !$omp parallel do default(none) schedule(runtime) & diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index c66d27e5c..0294d04f8 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -185,7 +185,6 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& ! ! update energy if using radiative cooling approx (icooling=9) ! - print *, "min,max energy", minval(vxyzu(4,1:npart)), maxval(vxyzu(4,1:npart)) if (icooling == 9 .and. dt > 0.0 .and. icall==1) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) ! diff --git a/src/main/energies.F90 b/src/main/energies.F90 index d71e70db1..eec6576a3 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -18,19 +18,20 @@ module energies ! ! :Dependencies: boundary_dyn, centreofmass, dim, dust, eos, eos_piecewise, ! externalforces, gravwaveutils, io, kernel, metric_tools, mpiutils, -! nicil, options, part, ptmass, timestep, units, utils_gr, vectorutils, -! viscosity +! nicil, options, part, ptmass, subgroup, timestep, units, utils_gr, +! vectorutils, viscosity ! use dim, only:maxdusttypes,maxdustsmall use units, only:utime implicit none logical, public :: gas_only,track_mass,track_lum - real, public :: ekin,etherm,emag,epot,etot,totmom,angtot,mtot,xyzcom(3) + real, public :: ekin,etherm,emag,epot,etot,eacc,totmom,angtot,mtot,xyzcom(3) + real, public :: ekinacc,ethermacc,emagacc,epotacc,eradacc,etotall real, public :: hdivBonB_ave,hdivBonB_max real, public :: vrms,rmsmach,accretedmass,mdust(maxdusttypes),mgas - real, public :: xmom,ymom,zmom - real, public :: totlum + real, public :: xcom,ycom,zcom,xmom,ymom,zmom,angx,angy,angz + real, public :: totlum,angxall,angyall,angzall,angall real, public :: hx(4),hp(4),ddq_xy(3,3) integer, public :: iquantities integer(kind=8), public :: ndead,npartall,np_cs_eq_0,np_e_eq_0 @@ -71,7 +72,7 @@ subroutine compute_energies(t) isdead_or_accreted,epot_sinksink,imacc,ispinx,ispiny,& ispinz,mhd,gravity,poten,dustfrac,eos_vars,itemp,igasP,ics,& nden_nimhd,eta_nimhd,iion,ndustsmall,graindens,grainsize,& - iamdust,ndusttypes,rad,iradxi + iamdust,ndusttypes,rad,iradxi,gtgrad,group_info,n_group use part, only:pxyzu,fxyzu,fext use gravwaveutils, only:calculate_strain,calc_gravitwaves use centreofmass, only:get_centreofmass_accel @@ -81,7 +82,8 @@ subroutine compute_energies(t) use externalforces, only:externalforce,externalforce_vdependent,was_accreted,accradius1 use options, only:iexternalforce,calc_erot,alpha,ieos,use_dustfrac use mpiutils, only:reduceall_mpi - use ptmass, only:get_accel_sink_gas + use ptmass, only:get_accel_sink_gas,use_regnbody + use subgroup, only:get_pot_subsys use viscosity, only:irealvisc,shearfunc use nicil, only:nicil_update_nimhd,nicil_get_halldrift,nicil_get_ambidrift, & use_ohm,use_hall,use_ambi,n_data_out,n_warn,eta_constant @@ -97,10 +99,10 @@ subroutine compute_energies(t) real, intent(in) :: t integer :: iregime,idusttype,ierr real :: ev_data_thread(4,0:inumev) - real :: xi,yi,zi,hi,vxi,vyi,vzi,v2i,Bxi,Byi,Bzi,Bi,B2i,rhoi,angx,angy,angz - real :: xmomacc,ymomacc,zmomacc,angaccx,angaccy,angaccz,xcom,ycom,zcom,dm + real :: xi,yi,zi,hi,vxi,vyi,vzi,v2i,Bxi,Byi,Bzi,Bi,B2i,rhoi + real :: xmomacc,ymomacc,zmomacc,angaccx,angaccy,angaccz,dm real :: epoti,pmassi,dnptot,dnpgas,tsi - real :: xmomall,ymomall,zmomall,angxall,angyall,angzall,rho1i,vsigi + real :: xmomall,ymomall,zmomall,rho1i,vsigi real :: ponrhoi,spsoundi,dumx,dumy,dumz,gammai real :: divBi,hdivBonBi,alphai,valfven2i,betai real :: n_total,n_total1,n_ion,shearparam_art,shearparam_phys,ratio_phys_to_av @@ -108,13 +110,13 @@ subroutine compute_energies(t) real :: etaohm,etahall,etaambi,vhall,vion real :: curlBi(3),vhalli(3),vioni(3),data_out(n_data_out) real :: erotxi,erotyi,erotzi,fdum(3),x0(3),v0(3),a0(3),xyz_x_all(3),xyz_n_all(3) - real :: ethermi + real :: ekini,ethermi,epottmpi,eradi,emagi real :: pdotv,bigvi(1:3),alpha_gr,beta_gr_UP(1:3),lorentzi,pxi,pyi,pzi real :: gammaijdown(1:3,1:3),angi(1:3),fourvel_space(3) integer :: i,j,itype,iu integer :: ierrlist(n_warn) integer(kind=8) :: np,npgas,nptot,np_rho(maxtypes),np_rho_thread(maxtypes) - !real, allocatable :: axyz(:,:) + logical :: was_not_accreted ! initialise values itype = igas @@ -148,6 +150,11 @@ subroutine compute_energies(t) angaccx = 0. angaccy = 0. angaccz = 0. + ekinacc = 0. + ethermacc = 0. + emagacc = 0. + epotacc = 0. + eradacc = 0. mgas = 0. mdust = 0. mgas = 0. @@ -177,20 +184,22 @@ subroutine compute_energies(t) !$omp shared(iev_dtg,iev_ts,iev_macc,iev_totlum,iev_erot,iev_viscrat) & !$omp shared(eos_vars,grainsize,graindens,ndustsmall,metrics) & !$omp private(i,j,xi,yi,zi,hi,rhoi,vxi,vyi,vzi,Bxi,Byi,Bzi,Bi,B2i,epoti,vsigi,v2i) & -!$omp private(ponrhoi,spsoundi,gammai,ethermi,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & +!$omp private(ponrhoi,spsoundi,gammai,dumx,dumy,dumz,valfven2i,divBi,hdivBonBi,curlBi) & !$omp private(rho1i,shearparam_art,shearparam_phys,ratio_phys_to_av,betai) & !$omp private(gasfrac,rhogasi,dustfracisum,dustfraci,dust_to_gas,n_total,n_total1,n_ion) & !$omp private(etaohm,etahall,etaambi,vhalli,vhall,vioni,vion,data_out) & +!$omp private(ekini,ethermi,emagi,eradi,epottmpi) & !$omp private(erotxi,erotyi,erotzi,fdum) & !$omp private(ev_data_thread,np_rho_thread) & !$omp firstprivate(alphai,itype,pmassi) & !$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) & +!$omp private(tsi,iregime,idusttype,was_not_accreted) & !$omp shared(luminosity,track_lum) & !$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) & +!$omp reduction(+:ekinacc,ethermacc,emagacc,epotacc,eradacc) & !$omp reduction(+:ekin,etherm,emag,epot,erad,vrms,rmsmach,ierrlist) call initialise_ev_data(ev_data_thread) np_rho_thread = 0 @@ -200,7 +209,8 @@ subroutine compute_energies(t) yi = xyzh(2,i) zi = xyzh(3,i) hi = xyzh(4,i) - if (.not.isdead_or_accreted(hi)) then + was_not_accreted = .not.was_accreted(iexternalforce,hi) + if (.not.isdead_or_accreted(hi) .or. .not. was_not_accreted) then if (maxphase==maxp) then itype = iamtype(iphase(i)) if (itype <= 0) call fatal('energies','particle type <= 0') @@ -208,32 +218,33 @@ subroutine compute_energies(t) endif rhoi = rhoh(hi,pmassi) - call ev_data_update(ev_data_thread,iev_rho,rhoi) - if (.not.gas_only) then - select case(itype) - case(igas) - call ev_data_update(ev_data_thread,iev_rhop(1), rhoi) - np_rho_thread(igas) = np_rho_thread(igas) + 1 - case(idust) - call ev_data_update(ev_data_thread,iev_rhop(2),rhoi) - np_rho_thread(idust) = np_rho_thread(idust) + 1 - case(iboundary) - call ev_data_update(ev_data_thread,iev_rhop(3), rhoi) - np_rho_thread(iboundary) = np_rho_thread(iboundary) + 1 - case(istar) - call ev_data_update(ev_data_thread,iev_rhop(4),rhoi) - np_rho_thread(istar) = np_rho_thread(istar) + 1 - case(idarkmatter) - call ev_data_update(ev_data_thread,iev_rhop(5), rhoi) - np_rho_thread(idarkmatter) = np_rho_thread(idarkmatter) + 1 - case(ibulge) - call ev_data_update(ev_data_thread,iev_rhop(6), rhoi) - np_rho_thread(ibulge) = np_rho_thread(ibulge) + 1 - end select + if (was_not_accreted) then + call ev_data_update(ev_data_thread,iev_rho,rhoi) + if (.not.gas_only) then + select case(itype) + case(igas) + call ev_data_update(ev_data_thread,iev_rhop(1), rhoi) + np_rho_thread(igas) = np_rho_thread(igas) + 1 + case(idust) + call ev_data_update(ev_data_thread,iev_rhop(2),rhoi) + np_rho_thread(idust) = np_rho_thread(idust) + 1 + case(iboundary) + call ev_data_update(ev_data_thread,iev_rhop(3), rhoi) + np_rho_thread(iboundary) = np_rho_thread(iboundary) + 1 + case(istar) + call ev_data_update(ev_data_thread,iev_rhop(4),rhoi) + np_rho_thread(istar) = np_rho_thread(istar) + 1 + case(idarkmatter) + call ev_data_update(ev_data_thread,iev_rhop(5), rhoi) + np_rho_thread(idarkmatter) = np_rho_thread(idarkmatter) + 1 + case(ibulge) + call ev_data_update(ev_data_thread,iev_rhop(6), rhoi) + np_rho_thread(ibulge) = np_rho_thread(ibulge) + 1 + end select + endif + np = np + 1 endif - np = np + 1 - vxi = vxyzu(1,i) vyi = vxyzu(2,i) vzi = vxyzu(3,i) @@ -243,11 +254,6 @@ subroutine compute_energies(t) pyi = pxyzu(2,i) pzi = pxyzu(3,i) - ! linear momentum - xmom = xmom + pmassi*pxi - ymom = ymom + pmassi*pyi - zmom = zmom + pmassi*pzi - call unpack_metric(metrics(:,:,:,i),betaUP=beta_gr_UP,alpha=alpha_gr,gammaijdown=gammaijdown) bigvi = (vxyzu(1:3,i)+beta_gr_UP)/alpha_gr v2i = dot_product_gr(bigvi,bigvi,gammaijdown) @@ -257,99 +263,142 @@ subroutine compute_energies(t) ! angular momentum fourvel_space = (lorentzi/alpha_gr)*vxyzu(1:3,i) call cross_product3D(xyzh(1:3,i),fourvel_space,angi) ! position cross with four-velocity - angx = angx + pmassi*angi(1) - angy = angy + pmassi*angi(2) - angz = angz + pmassi*angi(3) ! kinetic energy - ekin = ekin + pmassi*(pdotv + alpha_gr/lorentzi - 1.) ! The 'kinetic term' in total specific energy, minus rest mass - mtot = mtot + pmassi + ekini = pmassi*(pdotv + alpha_gr/lorentzi - 1.) ! The 'kinetic term' in total specific energy, minus rest mass else + pxi = vxi + pyi = vyi + pzi = vzi + ! centre of mass xcom = xcom + pmassi*xi ycom = ycom + pmassi*yi zcom = zcom + pmassi*zi + + ! angular momentum + angi(1) = (yi*vzi - zi*vyi) + angi(2) = (zi*vxi - xi*vzi) + angi(3) = (xi*vyi - yi*vxi) + + ! kinetic energy and rms velocity + v2i = vxi*vxi + vyi*vyi + vzi*vzi + ekini = pmassi*v2i + endif + + if (was_not_accreted) then + ! total mass mtot = mtot + pmassi ! linear momentum - xmom = xmom + pmassi*vxi - ymom = ymom + pmassi*vyi - zmom = zmom + pmassi*vzi + xmom = xmom + pmassi*pxi + ymom = ymom + pmassi*pyi + zmom = zmom + pmassi*pzi ! angular momentum - angx = angx + pmassi*(yi*vzi - zi*vyi) - angy = angy + pmassi*(zi*vxi - xi*vzi) - angz = angz + pmassi*(xi*vyi - yi*vxi) + angx = angx + pmassi*angi(1) + angy = angy + pmassi*angi(2) + angz = angz + pmassi*angi(3) ! kinetic energy & rms velocity - v2i = vxi*vxi + vyi*vyi + vzi*vzi - ekin = ekin + pmassi*v2i - endif + ekin = ekin + ekini + vrms = vrms + v2i + else + call ev_data_update(ev_data_thread,iev_macc,pmassi) - vrms = vrms + v2i + ! linear momentum (accreted particles) + xmomacc = xmomacc + pmassi*pxi + ymomacc = ymomacc + pmassi*pyi + zmomacc = zmomacc + pmassi*pzi + + ! angular momentum (accreted particles) + angaccx = angaccx + pmassi*angi(1) + angaccy = angaccy + pmassi*angi(2) + angaccz = angaccz + pmassi*angi(3) + + ! kinetic energy (accreted particles + ekinacc = ekinacc + ekini + endif ! rotational energy around each axis through the Centre of mass ! note: for efficiency, centre of mass is from the previous time energies was called - if (calc_erot) then + if (calc_erot .and. was_not_accreted) then call get_erot(xi,yi,zi,vxi,vyi,vzi,xyzcom,pmassi,erotxi,erotyi,erotzi) call ev_data_update(ev_data_thread,iev_erot(1),erotxi) call ev_data_update(ev_data_thread,iev_erot(2),erotyi) call ev_data_update(ev_data_thread,iev_erot(3),erotzi) endif - if (iexternalforce > 0) then + ! potential energy + epoti = 0. + if (iexternalforce > 0 .and. .not.gr) then dumx = 0. dumy = 0. dumz = 0. -#ifdef GR - epoti = 0. -#else - call externalforce(iexternalforce,xi,yi,zi,hi,t,dumx,dumy,dumz,epoti,ii=i) - call externalforce_vdependent(iexternalforce,xyzh(1:3,i),vxyzu(1:3,i),fdum,epoti) -#endif - epot = epot + pmassi*epoti + epottmpi = 0. + call externalforce(iexternalforce,xi,yi,zi,hi,t,dumx,dumy,dumz,epottmpi,ii=i) + call externalforce_vdependent(iexternalforce,xyzh(1:3,i),vxyzu(1:3,i),fdum,epottmpi) + epoti = pmassi*epottmpi endif if (nptmass > 0) then dumx = 0. dumy = 0. dumz = 0. - call get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,dumx,dumy,dumz,epoti) - epot = epot + pmassi*epoti + epottmpi = 0. + call get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,dumx,dumy,dumz,epottmpi) + epoti = epoti + pmassi*epottmpi + endif + if (gravity) epoti = epoti + poten(i) + if (was_not_accreted) then + epot = epot + epoti + else + epotacc = epotacc + epoti endif - if (gravity) epot = epot + poten(i) ! ! total dust mass for each species ! - if (use_dust) then + if (use_dust .and. was_not_accreted) then if (iamdust(iphase(i))) then idusttype = ndustsmall + itype - idust + 1 mdust(idusttype) = mdust(idusttype) + pmassi endif endif - if (do_radiation) erad = erad + pmassi*rad(iradxi,i) + if (do_radiation) then + eradi = pmassi*rad(iradxi,i) + if (was_not_accreted) then + erad = erad + eradi + else + eradacc = eradacc + eradi + endif + endif + ! ! the following apply ONLY to gas particles ! isgas: if (itype==igas) then - npgas = npgas + 1 if (use_dustfrac) then dustfraci = dustfrac(:,i) dustfracisum = sum(dustfraci) gasfrac = 1. - dustfracisum dust_to_gas = dustfraci(:)/gasfrac - do j=1,ndustsmall - call ev_data_update(ev_data_thread,iev_dtg,dust_to_gas(j)) - enddo - mdust(1:ndustsmall) = mdust(1:ndustsmall) + pmassi*dustfraci(1:ndustsmall) + if (was_not_accreted) then + do j=1,ndustsmall + call ev_data_update(ev_data_thread,iev_dtg,dust_to_gas(j)) + enddo + mdust(1:ndustsmall) = mdust(1:ndustsmall) + pmassi*dustfraci(1:ndustsmall) + endif else dustfraci = 0. dustfracisum = 0. gasfrac = 1. endif - mgas = mgas + pmassi*gasfrac + if (was_not_accreted) then + npgas = npgas + 1 + mgas = mgas + pmassi*gasfrac + endif ! thermal energy ponrhoi = eos_vars(igasP,i)/rhoi @@ -359,60 +408,70 @@ subroutine compute_energies(t) ethermi = pmassi*vxyzu(4,i)*gasfrac if (gr) ethermi = (alpha_gr/lorentzi)*ethermi - etherm = etherm + ethermi - - if (vxyzu(iu,i) < tiny(vxyzu(iu,i))) np_e_eq_0 = np_e_eq_0 + 1 - if (spsoundi < tiny(spsoundi) .and. vxyzu(iu,i) > 0. ) np_cs_eq_0 = np_cs_eq_0 + 1 + if (was_not_accreted) then + if (vxyzu(iu,i) < tiny(vxyzu(iu,i))) np_e_eq_0 = np_e_eq_0 + 1 + if (spsoundi < tiny(spsoundi) .and. vxyzu(iu,i) > 0. ) np_cs_eq_0 = np_cs_eq_0 + 1 + endif else - if ((ieos==2 .or. ieos == 5) .and. gammai > 1.001) then + if ((ieos==2 .or. ieos == 5 .or. ieos == 17) .and. gammai > 1.001) then !--thermal energy using polytropic equation of state - etherm = etherm + pmassi*ponrhoi/(gammai-1.)*gasfrac + ethermi = pmassi*ponrhoi/(gammai-1.)*gasfrac elseif (ieos==9) then !--thermal energy using piecewise polytropic equation of state - etherm = etherm + pmassi*ponrhoi/(gamma_pwp(rhoi)-1.)*gasfrac + ethermi = pmassi*ponrhoi/(gamma_pwp(rhoi)-1.)*gasfrac + else + ethermi = 0. endif - if (spsoundi < tiny(spsoundi)) np_cs_eq_0 = np_cs_eq_0 + 1 + if (spsoundi < tiny(spsoundi) .and. was_not_accreted) np_cs_eq_0 = np_cs_eq_0 + 1 endif vsigi = spsoundi - ! entropy - call ev_data_update(ev_data_thread,iev_entrop,pmassi*ponrhoi*rhoi**(1.-gammai)) - - ! gas temperature - if (eos_is_non_ideal(ieos) .or. eos_outputs_gasP(ieos)) then - call ev_data_update(ev_data_thread,iev_temp,eos_vars(itemp,i)) + if (was_not_accreted) then + etherm = etherm + ethermi + else + ethermacc = ethermacc + ethermi endif - ! min and mean stopping time - if (use_dustfrac) then - rhogasi = rhoi*gasfrac - do j=1,ndustsmall - call get_ts(idrag,j,grainsize(j),graindens(j),rhogasi,rhoi*dustfracisum,spsoundi,0.,tsi,iregime) - call ev_data_update(ev_data_thread,iev_ts,tsi) - enddo - endif + if (was_not_accreted) then + ! entropy + call ev_data_update(ev_data_thread,iev_entrop,pmassi*ponrhoi*rhoi**(1.-gammai)) - if (track_lum .and. lightcurve) call ev_data_update(ev_data_thread,iev_totlum,real(luminosity(i))) + ! gas temperature + if (eos_is_non_ideal(ieos) .or. eos_outputs_gasP(ieos)) then + call ev_data_update(ev_data_thread,iev_temp,eos_vars(itemp,i)) + endif - ! rms mach number - if (spsoundi > 0.) rmsmach = rmsmach + v2i/spsoundi**2 + ! min and mean stopping time + if (use_dustfrac) then + rhogasi = rhoi*gasfrac + do j=1,ndustsmall + call get_ts(idrag,j,grainsize(j),graindens(j),rhogasi,rhoi*dustfracisum,spsoundi,0.,tsi,iregime) + call ev_data_update(ev_data_thread,iev_ts,tsi) + enddo + endif - ! max of dissipation parameters - if (maxalpha==maxp) then - alphai = alphaind(1,i) - call ev_data_update(ev_data_thread,iev_alpha,alphai) - endif + if (track_lum .and. lightcurve) call ev_data_update(ev_data_thread,iev_totlum,real(luminosity(i))) - ! physical viscosity - if (irealvisc /= 0) then - shearparam_art = 0.1*alphai*hi*vsigi - shearparam_phys = shearfunc(xi,yi,zi,spsoundi) - if (shearparam_art > 0.) then - ratio_phys_to_av = shearparam_phys/shearparam_art - else - ratio_phys_to_av = 0. + ! rms mach number + if (spsoundi > 0.) rmsmach = rmsmach + v2i/spsoundi**2 + + ! max of dissipation parameters + if (maxalpha==maxp) then + alphai = alphaind(1,i) + call ev_data_update(ev_data_thread,iev_alpha,alphai) + endif + + ! physical viscosity + if (irealvisc /= 0) then + shearparam_art = 0.1*alphai*hi*vsigi + shearparam_phys = shearfunc(xi,yi,zi,spsoundi) + if (shearparam_art > 0.) then + ratio_phys_to_av = shearparam_phys/shearparam_art + else + ratio_phys_to_av = 0. + endif + call ev_data_update(ev_data_thread,iev_viscrat,ratio_phys_to_av) endif - call ev_data_update(ev_data_thread,iev_viscrat,ratio_phys_to_av) endif ! mhd parameters @@ -425,88 +484,70 @@ subroutine compute_energies(t) rho1i = 1./rhoi valfven2i = B2i*rho1i vsigi = sqrt(valfven2i + spsoundi*spsoundi) - emag = emag + pmassi*B2i*rho1i - - divBi = abs(divcurlB(1,i)) - if (B2i > 0.) then - hdivBonBi = hi*divBi/Bi - betai = 2.0*ponrhoi*rhoi/B2i ! plasma beta - else - hdivBonBi = 0. - betai = 0. - endif - call ev_data_update(ev_data_thread,iev_B, Bi ) - call ev_data_update(ev_data_thread,iev_divB, divBi ) - call ev_data_update(ev_data_thread,iev_hdivB,hdivBonBi) - call ev_data_update(ev_data_thread,iev_beta, betai ) + emagi = pmassi*B2i*rho1i + + if (was_not_accreted) then + emag = emag + emagi + divBi = abs(divcurlB(1,i)) + if (B2i > 0.) then + hdivBonBi = hi*divBi/Bi + betai = 2.0*ponrhoi*rhoi/B2i ! plasma beta + else + hdivBonBi = 0. + betai = 0. + endif + call ev_data_update(ev_data_thread,iev_B, Bi ) + call ev_data_update(ev_data_thread,iev_divB, divBi ) + call ev_data_update(ev_data_thread,iev_hdivB,hdivBonBi) + call ev_data_update(ev_data_thread,iev_beta, betai ) - if ( mhd_nonideal ) then - call nicil_update_nimhd(0,etaohm,etahall,etaambi,Bi,rhoi, & + if ( mhd_nonideal ) then + call nicil_update_nimhd(0,etaohm,etahall,etaambi,Bi,rhoi, & eos_vars(itemp,i),nden_nimhd(:,i),ierrlist,data_out) - curlBi = divcurlB(2:4,i) - if (use_ohm) then - call ev_data_update(ev_data_thread,iev_etao, etaohm ) - endif - if (use_hall) then - call nicil_get_halldrift(etahall,Bxi,Byi,Bzi,curlBi,vhalli) - vhall = sqrt( dot_product(vhalli,vhalli) ) - call ev_data_update(ev_data_thread,iev_etah(1),etahall ) - call ev_data_update(ev_data_thread,iev_etah(2),abs(etahall)) - call ev_data_update(ev_data_thread,iev_vhall ,vhall ) - endif - if (use_ambi) then - call nicil_get_ambidrift(etaambi,Bxi,Byi,Bzi,curlBi,vioni) - vion = sqrt( dot_product(vioni, vioni ) ) - call ev_data_update(ev_data_thread,iev_etaa, etaambi ) - call ev_data_update(ev_data_thread,iev_vel, sqrt(v2i) ) - call ev_data_update(ev_data_thread,iev_vion, vion ) - endif - if (.not.eta_constant) then - n_ion = 0 - do j = 9,21 - n_ion = n_ion + data_out(j) - enddo - n_total = data_out(5) - if (n_total > 0.) then - n_total1 = 1.0/n_total - else - n_total1 = 0.0 ! only possible if eta_constant = .true. + curlBi = divcurlB(2:4,i) + if (use_ohm) then + call ev_data_update(ev_data_thread,iev_etao, etaohm ) + endif + if (use_hall) then + call nicil_get_halldrift(etahall,Bxi,Byi,Bzi,curlBi,vhalli) + vhall = sqrt( dot_product(vhalli,vhalli) ) + call ev_data_update(ev_data_thread,iev_etah(1),etahall ) + call ev_data_update(ev_data_thread,iev_etah(2),abs(etahall)) + call ev_data_update(ev_data_thread,iev_vhall ,vhall ) + endif + if (use_ambi) then + call nicil_get_ambidrift(etaambi,Bxi,Byi,Bzi,curlBi,vioni) + vion = sqrt( dot_product(vioni, vioni ) ) + call ev_data_update(ev_data_thread,iev_etaa, etaambi ) + call ev_data_update(ev_data_thread,iev_vel, sqrt(v2i) ) + call ev_data_update(ev_data_thread,iev_vion, vion ) + endif + if (.not.eta_constant) then + n_ion = 0 + do j = 9,21 + n_ion = n_ion + data_out(j) + enddo + n_total = data_out(5) + if (n_total > 0.) then + n_total1 = 1.0/n_total + else + n_total1 = 0.0 ! only possible if eta_constant = .true. + endif + eta_nimhd(iion,i) = n_ion*n_total1 ! Save ionisation fraction for the dump file + call ev_data_update(ev_data_thread,iev_n(1),n_ion*n_total1) + call ev_data_update(ev_data_thread,iev_n(2),data_out( 8)*n_total1) + call ev_data_update(ev_data_thread,iev_n(3),data_out( 8)) + call ev_data_update(ev_data_thread,iev_n(4),n_total-n_ion) + call ev_data_update(ev_data_thread,iev_n(5),data_out(24)) + call ev_data_update(ev_data_thread,iev_n(6),data_out(23)) + call ev_data_update(ev_data_thread,iev_n(7),data_out(22)) endif - eta_nimhd(iion,i) = n_ion*n_total1 ! Save ionisation fraction for the dump file - call ev_data_update(ev_data_thread,iev_n(1),n_ion*n_total1) - call ev_data_update(ev_data_thread,iev_n(2),data_out( 8)*n_total1) - call ev_data_update(ev_data_thread,iev_n(3),data_out( 8)) - call ev_data_update(ev_data_thread,iev_n(4),n_total-n_ion) - call ev_data_update(ev_data_thread,iev_n(5),data_out(24)) - call ev_data_update(ev_data_thread,iev_n(6),data_out(23)) - call ev_data_update(ev_data_thread,iev_n(7),data_out(22)) endif + else + emagacc = emagacc + emagi endif endif endif isgas - - elseif (was_accreted(iexternalforce,hi)) then -! -!--count accretion onto fixed potentials (external forces) separately -! - vxi = vxyzu(1,i) - vyi = vxyzu(2,i) - vzi = vxyzu(3,i) - if (maxphase==maxp) then - pmassi = massoftype(iamtype(iphase(i))) - else - pmassi = massoftype(igas) - endif - xmomacc = xmomacc + pmassi*vxi - ymomacc = ymomacc + pmassi*vyi - zmomacc = zmomacc + pmassi*vzi - - angaccx = angaccx + pmassi*(yi*vzi - zi*vyi) - angaccy = angaccy + pmassi*(zi*vxi - xi*vzi) - angaccz = angaccz + pmassi*(xi*vyi - yi*vxi) - - call ev_data_update(ev_data_thread,iev_macc,pmassi) - endif enddo !$omp enddo @@ -601,9 +642,15 @@ subroutine compute_energies(t) emag = reduceall_mpi('+',emag) epot = reduceall_mpi('+',epot) erad = reduceall_mpi('+',erad) - if (nptmass > 1) epot = epot + epot_sinksink + if (nptmass > 1) then + if (use_regnbody) then + call get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + endif + epot = epot + epot_sinksink + endif etot = ekin + etherm + emag + epot + erad + etotall = etot xcom = reduceall_mpi('+',xcom) ycom = reduceall_mpi('+',ycom) @@ -694,12 +741,24 @@ subroutine compute_energies(t) angxall = angx + angaccx angyall = angy + angaccy angzall = angz + angaccz - ev_data(iev_sum,iev_angall) = sqrt(angxall*angxall + angyall*angyall + angzall*angzall) + angall = sqrt(angxall*angxall + angyall*angyall + angzall*angzall) + ev_data(iev_sum,iev_angall) = angall + + ekinacc = reduceall_mpi('+',ekinacc) + epotacc = reduceall_mpi('+',epotacc) + ethermacc = reduceall_mpi('+',ethermacc) + emagacc = reduceall_mpi('+',emagacc) + eradacc = reduceall_mpi('+',eradacc) + eacc = ekinacc + ethermacc + emagacc + epotacc + eradacc + etotall = etotall + eacc endif if (track_mass) then accretedmass = ev_data(iev_sum,iev_macc) - if (accradius1 > 0.) ev_data(iev_sum,iev_eacc) = accretedmass/accradius1 ! total accretion energy + if (accradius1 > 0.) then + !eacc = accretedmass/accradius1 + ev_data(iev_sum,iev_eacc) = eacc ! total accretion energy + endif endif if (track_lum) totlum = ev_data(iev_sum,iev_totlum) diff --git a/src/main/ptmass_radiation.f90 b/src/main/ptmass_radiation.f90 index 18954ec84..dc175ff8d 100644 --- a/src/main/ptmass_radiation.f90 +++ b/src/main/ptmass_radiation.f90 @@ -58,16 +58,25 @@ end subroutine init_radiation_ptmass ! compute radiative acceleration from ALL sink particles !+ !----------------------------------------------------------------------- -subroutine get_rad_accel_from_ptmass (nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) +subroutine get_rad_accel_from_ptmass (nptmass,npart,i,xi,yi,zi,xyzmh_ptmass,fextx,fexty,fextz,tau,fsink_old,extrapfac) use part, only:ilum use units, only:umass,unit_luminosity - integer, intent(in) :: nptmass,npart - real, intent(in) :: xyzh(:,:) - real, intent(in) :: xyzmh_ptmass(:,:) - real, intent(in), optional :: tau(:) - real, intent(inout) :: fext(:,:) - real :: xa,ya,za,Mstar_cgs,Lstar_cgs + integer, intent(in) :: nptmass,npart,i + real, intent(in) :: xi,yi,zi + real, intent(in) :: xyzmh_ptmass(:,:) + real, optional, intent(in) :: tau(:) + real, intent(inout) :: fextx,fexty,fextz + real, optional, intent(in) :: fsink_old(:,:) + real, optional, intent(in) :: extrapfac + real :: dx,dy,dz,Mstar_cgs,Lstar_cgs integer :: j + logical :: extrap + + if (present(fsink_old)) then + extrap = .true. + else + extrap = .false. + endif do j=1,nptmass if (xyzmh_ptmass(4,j) < 0.) cycle @@ -75,10 +84,16 @@ subroutine get_rad_accel_from_ptmass (nptmass,npart,xyzh,xyzmh_ptmass,fext,tau) Lstar_cgs = xyzmh_ptmass(ilum,j)*unit_luminosity !compute radiative acceleration if sink particle is assigned a non-zero luminosity if (Lstar_cgs > 0.d0) then - xa = xyzmh_ptmass(1,j) - ya = xyzmh_ptmass(2,j) - za = xyzmh_ptmass(3,j) - call calc_rad_accel_from_ptmass(npart,xa,ya,za,Lstar_cgs,Mstar_cgs,xyzh,fext,tau) + if (extrap) then + dx = xi - xyzmh_ptmass(1,j) + extrapfac*fsink_old(1,j) + dy = yi - xyzmh_ptmass(2,j) + extrapfac*fsink_old(2,j) + dz = zi - xyzmh_ptmass(3,j) + extrapfac*fsink_old(3,j) + else + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + endif + call calc_rad_accel_from_ptmass(npart,i,dx,dy,dz,Lstar_cgs,Mstar_cgs,fextx,fexty,fextz,tau) endif enddo @@ -89,53 +104,40 @@ end subroutine get_rad_accel_from_ptmass ! compute radiative acceleration on all particles !+ !----------------------------------------------------------------------- -subroutine calc_rad_accel_from_ptmass(npart,xa,ya,za,Lstar_cgs,Mstar_cgs,xyzh,fext,tau) +subroutine calc_rad_accel_from_ptmass(npart,i,dx,dy,dz,Lstar_cgs,Mstar_cgs,fextx,fexty,fextz,tau) use part, only:isdead_or_accreted,dust_temp,nucleation,idkappa,idalpha use dim, only:do_nucleation,itau_alloc use dust_formation, only:calc_kappa_bowen - integer, intent(in) :: npart - real, intent(in) :: xyzh(:,:) - real, intent(in), optional :: tau(:) - real, intent(in) :: xa,ya,za,Lstar_cgs,Mstar_cgs - real, intent(inout) :: fext(:,:) - real :: dx,dy,dz,r,ax,ay,az,alpha,kappa - integer :: i - - !$omp parallel do default(none) & - !$omp shared(nucleation,do_nucleation,itau_alloc)& - !$omp shared(dust_temp) & - !$omp shared(npart,xa,ya,za,Mstar_cgs,Lstar_cgs,xyzh,fext,tau) & - !$omp private(i,dx,dy,dz,ax,ay,az,r,alpha,kappa) - do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then - dx = xyzh(1,i) - xa - dy = xyzh(2,i) - ya - dz = xyzh(3,i) - za - r = sqrt(dx**2 + dy**2 + dz**2) - if (do_nucleation) then - if (itau_alloc == 1) then - call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& + integer, intent(in) :: npart,i + real, optional, intent(in) :: tau(:) + real, intent(in) :: dx,dy,dz,Lstar_cgs,Mstar_cgs + real, intent(inout) :: fextx,fexty,fextz + real :: r,ax,ay,az,alpha,kappa + + + r = sqrt(dx**2 + dy**2 + dz**2) + if (do_nucleation) then + if (itau_alloc == 1) then + call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& nucleation(idkappa,i),ax,ay,az,nucleation(idalpha,i),tau(i)) - else - call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& + else + call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& nucleation(idkappa,i),ax,ay,az,nucleation(idalpha,i)) - endif - else - kappa = calc_kappa_bowen(dust_temp(i)) - if (itau_alloc == 1) then - call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& + endif + else + kappa = calc_kappa_bowen(dust_temp(i)) + if (itau_alloc == 1) then + call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& kappa,ax,ay,az,alpha,tau(i)) - else - call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& + else + call get_radiative_acceleration_from_star(r,dx,dy,dz,Mstar_cgs,Lstar_cgs,& kappa,ax,ay,az,alpha) - endif - endif - fext(1,i) = fext(1,i) + ax - fext(2,i) = fext(2,i) + ay - fext(3,i) = fext(3,i) + az endif - enddo - !$omp end parallel do + endif + fextx = fextx + ax + fexty = fexty + ay + fextz = fextz + az + end subroutine calc_rad_accel_from_ptmass diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 3e78ba2c3..56ec50dc3 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -105,6 +105,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use mpiutils, only:reduceall_mpi use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & dsdt_ptmass,fsink_old,ibin_wake,dptmass + use part, only:n_group,n_ingroup,n_sing,gtgrad,group_info,nmatrix use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax @@ -250,8 +251,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) 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,fsink_old,nbinmax,ibin_wake) + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& + dptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info, & + nmatrix,n_group,n_ingroup,n_sing) else call substep_sph(dtsph,npart,xyzh,vxyzu) endif From df38a9e251b6a2a213001f4605fe24859026f30f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 25 Jun 2024 09:20:03 +0200 Subject: [PATCH 644/814] (ptmass) fix issue on update ion rate in star creation routine --- src/main/H2regions.f90 | 2 +- src/main/ptmass.F90 | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 54cf47c77..38da05f53 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -111,7 +111,7 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) Q = (10.**log_Q)*utime xyzmh_ptmass(irateion,i) = Q nHIIsources = nHIIsources + 1 - if (iverbose > 0) then + if (iverbose >= 0) then write(iprint,"(/a,es18.10,es18.10/)")"Massive stars detected : Log Q, Mass : ",log_Q,mi endif else diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 6d259733d..a91a2d1c4 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1714,9 +1714,10 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz vxyz_ptmass(3,k) = vi(3) + vk(3) fxyz_ptmass(1:4,k) = 0. fxyz_ptmass_sinksink(1:4,k) = 0. + if (iH2R > 0) call update_ionrate(k,xyzmh_ptmass,h_acc) + k = linklist_ptmass(k) ! acces to the next point mass in the linked list n = n - 1 - if (iH2R > 0) call update_ionrate(k,xyzmh_ptmass,h_acc) enddo deallocate(masses) endif From b8e86262630aa3d2d0fe1dcaf6fe1660188a043d Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 25 Jun 2024 11:06:45 +0200 Subject: [PATCH 645/814] (HIIRegion) unresolved case doesn't need to have hcheck=Rmax --- src/main/H2regions.f90 | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 38da05f53..e4d789d97 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -87,7 +87,7 @@ end subroutine initialize_H2R subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose use units, only:utime,umass - use part, only:irateion,ihacc + use part, only:irateion,ihacc,irstrom use physcon,only:solarm integer, intent(in) :: nptmass real, intent(inout) :: xyzmh_ptmass(:,:) @@ -110,12 +110,14 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) Q = (10.**log_Q)*utime xyzmh_ptmass(irateion,i) = Q + xyzmh_ptmass(irstrom,i) = -1. nHIIsources = nHIIsources + 1 if (iverbose >= 0) then write(iprint,"(/a,es18.10,es18.10/)")"Massive stars detected : Log Q, Mass : ",log_Q,mi endif else xyzmh_ptmass(irateion,i) = -1. + xyzmh_ptmass(irstrom,i) = -1. endif enddo !$omp end parallel do @@ -128,7 +130,7 @@ end subroutine update_ionrates subroutine update_ionrate(i,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose use units, only:utime,umass - use part, only:irateion,ihacc + use part, only:irateion,ihacc,irstrom use physcon,only:solarm integer, intent(in) :: i real, intent(inout) :: xyzmh_ptmass(:,:) @@ -142,13 +144,15 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) ! this calculation uses Fujii's formula derived from OSTAR2002 databases log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) Q = (10.**log_Q)*utime - xyzmh_ptmass(irateion,i) = Q + xyzmh_ptmass(irateion,i) = Q + xyzmh_ptmass(irstrom,i) = -1. nHIIsources = nHIIsources + 1 - if (iverbose > 0) then + if (iverbose >= 0) then write(iprint,"(/a,es18.10,es18.10/)")"Massive stars detected : Log Q, Mass : ",log_Q,mi endif else xyzmh_ptmass(irateion,i) = -1. + xyzmh_ptmass(irstrom,i) = -1. endif if (iverbose > 1) then @@ -207,8 +211,8 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) stromi = xyzmh_ptmass(irstrom,i) - if(stromi > 0 ) then - hcheck = 2.*stromi + if(stromi >= 0 ) then + hcheck = 2.*stromi + 0.01*Rmax ! additive term to allow unresolved case to open if (hcheck > Rmax) hcheck = Rmax else hcheck = Rmax From 13f8f580cd067c44ca4fec20126b48dc5ce3aa6e Mon Sep 17 00:00:00 2001 From: Ana Lourdes Juarez Date: Tue, 25 Jun 2024 17:30:52 +0200 Subject: [PATCH 646/814] Add cases to write_options_eos --- src/main/eos.f90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 10f619129..5426c7e8a 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -1444,6 +1444,8 @@ subroutine write_options_eos(iunit) endif select case(ieos) + case(2) + call write_inopt(gamma,'gamma','Adiabatic index',iunit) case(8) call write_options_eos_barotropic(iunit) case(9) @@ -1451,6 +1453,8 @@ subroutine write_options_eos(iunit) case(10) call write_inopt(X_in,'X','hydrogen mass fraction',iunit) call write_inopt(Z_in,'Z','metallicity',iunit) + case(12) + call write_inopt(gamma,'gamma','Adiabatic index',iunit) case(15) ! helmholtz eos call eos_helmholtz_write_inopt(iunit) case(20) From b90461be3001bcb2e530d08f4c2e78461e3db9d3 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 25 Jun 2024 18:02:28 +0200 Subject: [PATCH 647/814] (ptmass) try to avoid NaN value in angular mom after star creation... --- src/main/ptmass.F90 | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index a91a2d1c4..4a5183139 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -638,6 +638,7 @@ end subroutine ptmass_drift !+ !---------------------------------------------------------------- subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass) + use part, only:iJ2 integer, intent(in) :: nptmass real, intent(in) :: dkdt real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) @@ -647,16 +648,18 @@ subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_pt !$omp parallel do schedule(static) default(none) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dkdt,nptmass) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dkdt,nptmass,iJ2) & !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dkdt*fxyz_ptmass(1,i) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dkdt*fxyz_ptmass(2,i) vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dkdt*fxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) + if(xyzmh_ptmass(iJ2,i) > 0.) then + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) + endif endif enddo !$omp end parallel do @@ -1626,7 +1629,7 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz use physcon, only:solarm,pi use io, only:iprint,iverbose use units, only:umass - use part, only:itbirth,ihacc,ihsoft + use part, only:itbirth,ihacc,ihsoft,ispinx,ispiny,ispinz use random , only:ran2,gauss_random,divide_unit_seg use HIIRegion, only:update_ionrate,iH2R integer, intent(in) :: nptmass @@ -1709,6 +1712,9 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz xyzmh_ptmass(3,k) = xi(3) + xk(3) xyzmh_ptmass(2,k) = xi(2) + xk(2) xyzmh_ptmass(1,k) = xi(1) + xk(1) + xyzmh_ptmass(ispinx,k) = 0. ! + xyzmh_ptmass(ispiny,k) = 0. ! -- No spin for the instant + xyzmh_ptmass(ispinz,k) = 0. ! vxyz_ptmass(1,k) = vi(1) + vk(1) vxyz_ptmass(2,k) = vi(2) + vk(2) vxyz_ptmass(3,k) = vi(3) + vk(3) From 311bf81a43d9feef756dd1f0b869482ab83f2231 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 25 Jun 2024 18:04:24 +0200 Subject: [PATCH 648/814] (HIIRegion) add a security for unresolved HII regions --- src/main/H2regions.f90 | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index e4d789d97..0d1774c37 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -211,15 +211,18 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) stromi = xyzmh_ptmass(irstrom,i) - if(stromi >= 0 ) then - hcheck = 2.*stromi + 0.01*Rmax ! additive term to allow unresolved case to open - if (hcheck > Rmax) hcheck = Rmax + if(stromi >= 0. ) then + hcheck = 2.*stromi else hcheck = Rmax endif - call getneigh_pos((/xi,yi,zi/),0.,hcheck,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) - call set_r2func_origin(xi,yi,zi) - call Knnfunc(nneigh,r2func_origin,xyzh,listneigh) + do while(nneigh < 0) + hcheck = hcheck + 0.01*Rmax ! additive term to allow unresolved case to open + if (hcheck > Rmax) hcheck = Rmax + call getneigh_pos((/xi,yi,zi/),0.,hcheck,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) + call set_r2func_origin(xi,yi,zi) + call Knnfunc(nneigh,r2func_origin,xyzh,listneigh) + enddo do k=1,npart j = listneigh(k) if (.not. isdead_or_accreted(xyzh(4,j))) then From be3c68555c2707f6ba394a47b0c1c1142456898d Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 25 Jun 2024 17:29:33 +0100 Subject: [PATCH 649/814] fixed bug in cooling_radapprox.f90 (does not skip inactive particles now) --- src/main/cooling_radapprox.f90 | 2 +- src/main/eos.f90 | 28 +- src/main/eos_stamatellos.f90 | 13 +- src/setup/setup_sphere.f90 | 848 +++++++++++++++++++++++++++++++++ 4 files changed, 869 insertions(+), 22 deletions(-) create mode 100644 src/setup/setup_sphere.f90 diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index 95217989d..8582e570b 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -94,7 +94,7 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) !$omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot) & !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb) overpart: do i=1,npart - if (.not. iactive(iphase(i)) .or. isdead_or_accreted(xyzh(4,i))) cycle +! if (.not. iactive(iphase(i)) .or. isdead_or_accreted(xyzh(4,i))) cycle poti = Gpot_cool(i) du_FLDi = duFLD(i) ui = energ(i) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index f23945122..a698fe23d 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -12,7 +12,7 @@ module eos ! 2 = adiabatic/polytropic eos ! 3 = eos for a locally isothermal disc as in Lodato & Pringle (2007) ! 4 = GR isothermal -! 5 = polytropic EOS with vary mu and gamma depending on H2 formation +! 5 = polytropic EOS with varying mu and gamma depending on H2 formation ! 6 = eos for a locally isothermal disc as in Lodato & Pringle (2007), ! centered on a sink particle ! 7 = z-dependent locally isothermal eos @@ -25,6 +25,7 @@ module eos ! 14 = locally isothermal prescription from Farris et al. (2014) for binary system ! 15 = Helmholtz free energy eos ! 16 = Shen eos +! 17 = polytropic EOS with varying mu (depending on H2 formation) ! 20 = Ideal gas + radiation + various forms of recombination energy from HORMONE (Hirai et al., 2020) ! 21 = read tabulated eos (for use with icooling == 8) ! @@ -162,7 +163,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam spsoundi = sqrt(ponrhoi) tempi = temperature_coef*mui*ponrhoi - case(2,5) + case(2,5,17) ! !--Adiabatic equation of state (code default) ! @@ -440,7 +441,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam ponrhoi = presi/rhoi gammai = 1.d0 + presi/(eni*rhoi) spsoundi = sqrt(gammai*ponrhoi) - + case default spsoundi = 0. ! avoids compiler warnings ponrhoi = 0. @@ -565,9 +566,8 @@ end subroutine init_eos !+ !----------------------------------------------------------------------- subroutine finish_eos(eos_type,ierr) - use eos_mesa, only: finish_eos_mesa - use eos_stamatellos, only: finish_S07cool - + use eos_mesa, only: finish_eos_mesa + use eos_stamatellos, only: finish_S07cool integer, intent(in) :: eos_type integer, intent(out) :: ierr @@ -846,7 +846,7 @@ end subroutine calc_rec_ene ! pressure and density. Inputs and outputs are in cgs units. ! ! Note on composition: -! For ieos=2, 5 and 12, mu_local is an input, X & Z are not used +! For ieos=2, 5, 12 and 17, mu_local is an input, X & Z are not used ! For ieos=10, mu_local is not used ! For ieos=20, mu_local is not used but available as an output !+ @@ -872,7 +872,7 @@ subroutine calc_temp_and_ene(eos_type,rho,pres,ene,temp,ierr,guesseint,mu_local, if (present(X_local)) X = X_local if (present(Z_local)) Z = Z_local select case(eos_type) - case(2,5) ! Ideal gas + case(2,5,17) ! Ideal gas temp = pres / (rho * kb_on_mh) * mu ene = pres / ( (gamma-1.) * rho) case(12) ! Ideal gas + radiation @@ -895,7 +895,7 @@ end subroutine calc_temp_and_ene ! are in cgs units. ! ! Note on composition: -! For ieos=2 and 12, mu_local is an input, X & Z are not used +! For ieos=2, 5, 12 and 17, mu_local is an input, X & Z are not used ! For ieos=10, mu_local is not used ! For ieos=20, mu_local is not used but available as an output !+ @@ -1070,7 +1070,7 @@ subroutine get_p_from_rho_s(ieos,S,rho,mu,P,temp) niter = 0 select case (ieos) - case (2,5) + case (2,5,17) temp = (cgsrho * exp(mu*cgss*mass_proton_cgs))**(2./3.) cgsP = cgsrho*kb_on_mh*temp / mu case (12) @@ -1175,7 +1175,7 @@ subroutine setpolyk(eos_type,iprint,utherm,xyzhi,npart) write(iprint,*) 'WARNING! different utherms but run is isothermal' endif - case(2,5) + case(2,5,17) ! !--adiabatic/polytropic eos ! this routine is ONLY called if utherm is NOT stored, so polyk matters @@ -1332,11 +1332,11 @@ subroutine eosinfo(eos_type,iprint) endif case(3) write(iprint,"(/,a,f10.6,a,f10.6)") ' Locally isothermal eq of state (R_sph): cs^2_0 = ',polyk,' qfac = ',qfacdisc - case(5) + case(5,17) if (maxvxyzu >= 4) then write(iprint,"(' Adiabatic equation of state: P = (gamma-1)*rho*u, where gamma & mu depend on the formation of H2')") else - stop '[stop eos] eos = 5 cannot assume isothermal conditions' + stop '[stop eos] eos = 5,17 cannot assume isothermal conditions' endif case(6) write(iprint,"(/,a,i2,a,f10.6,a,f10.6)") ' Locally (on sink ',isink, & @@ -1528,7 +1528,7 @@ subroutine read_options_eos(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) ieos ngot = ngot + 1 if (ieos <= 0 .or. ieos > maxeos) call fatal(label,'equation of state choice out of range') - if (ieos == 5) then + if (ieos == 5 .or. ieos == 17) then store_dust_temperature = .true. update_muGamma = .true. endif diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index 9611f9685..5b60a7a86 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -93,14 +93,13 @@ subroutine read_optab(eos_file,ierr) OPTABLE(i,j,4),OPTABLE(i,j,5),OPTABLE(i,j,6) enddo enddo -! print *, 'nx,ny=', nx, ny end subroutine read_optab ! ! Main subroutine for interpolating tables to get EOS values ! subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) - use io, only:fatal + use io, only:warning real, intent(in) :: ui,rhoi real, intent(out) :: kappaBar,kappaPart,Ti,gmwi @@ -118,9 +117,9 @@ 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 - call fatal('getopac_opdep','rhoi out of range',var='rhoi',val=rhoi) + call warning('getopac_opdep','rhoi out of range',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) + call warning('getopac_opdep','ui out of range',var='ui',val=ui) endif if (rhoi < rhomin) then @@ -212,7 +211,7 @@ subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) end subroutine getopac_opdep subroutine getintenerg_opdep(Teqi, rhoi, ueqi) - use io, only:fatal + use io, only:warning real, intent(out) :: ueqi real, intent(in) :: Teqi,rhoi @@ -222,9 +221,9 @@ subroutine getintenerg_opdep(Teqi, rhoi, ueqi) real rhoi_ if (rhoi > OPTABLE(nx,1,1) .or. rhoi < OPTABLE(1,1,1)) then - call fatal('getintenerg_opdep','rhoi out of range',var='rhoi',val=rhoi) + call warning('getintenerg_opdep','rhoi out of range',var='rhoi',val=rhoi) elseif (Teqi > OPTABLE(1,ny,2) .or. Teqi < OPTABLE(1,1,2)) then - call fatal('getintenerg_opdep','Ti out of range',var='Ti',val=Teqi) + call warning('getintenerg_opdep','Ti out of range',var='Ti',val=Teqi) endif diff --git a/src/setup/setup_sphere.f90 b/src/setup/setup_sphere.f90 new file mode 100644 index 000000000..c297a13b5 --- /dev/null +++ b/src/setup/setup_sphere.f90 @@ -0,0 +1,848 @@ +!--------------------------------------------------------------------------! +! 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 a32a5813f4ca0f9556ffa129e985218c7adfeada Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 26 Jun 2024 16:05:15 +1000 Subject: [PATCH 650/814] (#517) increase maxdensits to converge on density even with bad guess for h after splitting --- src/main/dens.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/dens.F90 b/src/main/dens.F90 index 4c2ddf816..65ad2c82f 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -99,7 +99,7 @@ module densityforce !real, parameter :: cnormk = 1./pi, wab0 = 1., gradh0 = -3.*wab0, radkern2 = 4F.0 integer, parameter :: isizecellcache = 1000 integer, parameter :: isizeneighcache = 0 - integer, parameter :: maxdensits = 50 + integer, parameter :: maxdensits = 100 !--statistics which can be queried later integer, private :: maxneighact,nrelink From bfbed92b6392bf36ecc938807bc36dc3a0ee6b57 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 26 Jun 2024 16:11:20 +1000 Subject: [PATCH 651/814] [header-bot] updated file headers --- src/main/inject_keplerian.f90 | 12 +++++++----- src/setup/set_orbit.f90 | 15 +++++++++++++++ src/setup/setup_grtde.f90 | 5 +++-- src/utils/analysis_disc_stresses.f90 | 9 ++++++--- src/utils/analysis_energies.f90 | 2 +- src/utils/phantomanalysis.f90 | 4 ++-- 6 files changed, 34 insertions(+), 13 deletions(-) diff --git a/src/main/inject_keplerian.f90 b/src/main/inject_keplerian.f90 index 7ade9b7b0..36c9965df 100644 --- a/src/main/inject_keplerian.f90 +++ b/src/main/inject_keplerian.f90 @@ -10,14 +10,16 @@ module inject ! ! :References: ! -! :Owner: Daniel Price +! :Owner: Cristiano Longarini ! ! :Runtime parameters: -! - datafile : *name of data file for wind injection* -! - outer_boundary : *kill gas particles outside this radius* +! - HonR_inj : *aspect ratio to give temperature at rinj* +! - follow_sink : *injection radius is relative to sink particle 1* +! - mdot : *mass injection rate [msun/yr]* +! - rinj : *injection radius* ! -! :Dependencies: dim, eos, infile_utils, io, part, partinject, physcon, -! random, units +! :Dependencies: eos, externalforces, infile_utils, io, options, part, +! partinject, physcon, random, units ! implicit none character(len=*), parameter, public :: inject_type = 'keplerian' diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index 6940ad2aa..23a25885d 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -29,6 +29,21 @@ module setorbit ! :Dependencies: infile_utils, physcon, setbinary, setflyby, units ! +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils, physcon, setbinary, setflyby, units +! + ! While Campbell elements can be used for unbound orbits, they require ! specifying the true anomaly at the start of the simulation. This is ! not always easy to determine, so the flyby option is provided as an diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index 0e73d1e72..65df28533 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -22,8 +22,9 @@ module setup ! - theta : *inclination of orbit (degrees)* ! ! :Dependencies: eos, externalforces, gravwaveutils, infile_utils, io, -! kernel, metric, mpidomain, part, physcon, relaxstar, setbinary, -! setstar, setup_params, systemutils, timestep, units, vectorutils +! kernel, metric, mpidomain, options, part, physcon, relaxstar, +! setbinary, setstar, setup_params, systemutils, timestep, units, +! vectorutils ! use setstar, only:star_t implicit none diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index 16d247cd4..5a0113c1e 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -12,10 +12,13 @@ module analysis ! ! :Owner: Daniel Price ! -! :Runtime parameters: None +! :Runtime parameters: +! - nbins : *Number of radial bins* +! - rin : *Inner Disc Radius* +! - rout : *Outer Disc Radius* ! -! :Dependencies: dim, eos, getneighbours, io, kernel, part, physcon, -! prompting, units +! :Dependencies: dim, eos, getneighbours, infile_utils, io, kernel, part, +! physcon, prompting, units ! use getneighbours, only:generate_neighbour_lists, read_neighbours, write_neighbours, & neighcount,neighb,neighmax diff --git a/src/utils/analysis_energies.f90 b/src/utils/analysis_energies.f90 index c242b2a31..7a20402c5 100644 --- a/src/utils/analysis_energies.f90 +++ b/src/utils/analysis_energies.f90 @@ -15,7 +15,7 @@ module analysis ! ! :Runtime parameters: None ! -! :Dependencies: None +! :Dependencies: energies, evwrite, metric_tools, options, part ! implicit none character(len=20), parameter, public :: analysistype = 'energies' diff --git a/src/utils/phantomanalysis.f90 b/src/utils/phantomanalysis.f90 index 49d3b5123..94ccc3695 100644 --- a/src/utils/phantomanalysis.f90 +++ b/src/utils/phantomanalysis.f90 @@ -14,8 +14,8 @@ program phantomanalysis ! ! :Usage: phantomanalysis dumpfile(s) ! -! :Dependencies: analysis, dim, eos, fileutils, infile_utils, io, kernel, -! part, readwrite_dumps +! :Dependencies: analysis, dim, eos, externalforces, fileutils, +! infile_utils, io, kernel, part, readwrite_dumps ! use dim, only:tagline,do_nucleation,inucleation use part, only:xyzh,hfact,massoftype,vxyzu,npart !,npartoftype From dea2f665390746c82074b9075dab80e1e90783d3 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 26 Jun 2024 16:11:50 +1000 Subject: [PATCH 652/814] [space-bot] whitespace at end of lines removed --- src/main/inject_keplerian.f90 | 10 +++++----- src/utils/analysis_energies.f90 | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/main/inject_keplerian.f90 b/src/main/inject_keplerian.f90 index 36c9965df..b8f4fb37c 100644 --- a/src/main/inject_keplerian.f90 +++ b/src/main/inject_keplerian.f90 @@ -8,7 +8,7 @@ module inject ! ! Injection of material at keplerian speed in an accretion disc ! -! :References: +! :References: ! ! :Owner: Cristiano Longarini ! @@ -116,7 +116,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& r2min = huge(r2min) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then - r2 = (xyzh(1,i)-x0(1))**2 + (xyzh(2,i)-x0(2))**2 + r2 = (xyzh(1,i)-x0(1))**2 + (xyzh(2,i)-x0(2))**2 dr2 = abs(r2 - rinj*rinj) if (dr2 < r2min) then hguess = xyzh(4,i) @@ -176,8 +176,8 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& vphi = vkep*(1. - (zi/rinj)**2)**(-0.75) ! see Martire et al. (2024) - xyzi = (/rinj*cosphi,rinj*sinphi,zi/) - vxyz = (/-vphi*sinphi, vphi*cosphi, 0./) + xyzi = (/rinj*cosphi,rinj*sinphi,zi/) + vxyz = (/-vphi*sinphi, vphi*cosphi, 0./) u = 1.5*cs**2 @@ -220,7 +220,7 @@ subroutine write_options_inject(iunit) endif if (nptmass >= 1) then call write_inopt(follow_sink,'follow_sink','injection radius is relative to sink particle 1',iunit) -endif +endif end subroutine write_options_inject diff --git a/src/utils/analysis_energies.f90 b/src/utils/analysis_energies.f90 index 7a20402c5..4d4288b74 100644 --- a/src/utils/analysis_energies.f90 +++ b/src/utils/analysis_energies.f90 @@ -37,7 +37,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) integer, intent(in) :: num,npart,iunit real, intent(in) :: xyzh(:,:),vxyzu(:,:) real, intent(in) :: particlemass,time - + if (gr) then call init_metric(npart,xyzh,metrics,metricderivs) iexternalforce = 1 From 78480ce67d6558683a0ca5ed7fb1b01537ac3ecf Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 26 Jun 2024 16:11:51 +1000 Subject: [PATCH 653/814] [author-bot] updated AUTHORS file --- AUTHORS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/AUTHORS b/AUTHORS index f236e7dc4..9f44811cf 100644 --- a/AUTHORS +++ b/AUTHORS @@ -18,18 +18,18 @@ Arnaud Vericel Mark Hutchison Mats Esseldeurs Rebecca Nealon +Yrisch Elisabeth Borchert Ward Homan Christophe Pinte -Yrisch Terrence Tricco Stephane Michoulier Simone Ceppi Spencer Magnall Enrico Ragusa Caitlyn Hardiman -Sergei Biriukov Cristiano Longarini +Sergei Biriukov Giovanni Dipierro Roberto Iaconi Hauke Worpel From 615102c5852579ec2b9e6004763b12ddd5d540eb Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 26 Jun 2024 16:13:04 +1000 Subject: [PATCH 654/814] [indent-bot] standardised indentation --- src/main/inject_keplerian.f90 | 10 +++++----- src/utils/analysis_disc_stresses.f90 | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/main/inject_keplerian.f90 b/src/main/inject_keplerian.f90 index b8f4fb37c..7e4f8e221 100644 --- a/src/main/inject_keplerian.f90 +++ b/src/main/inject_keplerian.f90 @@ -216,11 +216,11 @@ subroutine write_options_inject(iunit) call write_inopt(mdot,'mdot','mass injection rate [msun/yr]',iunit) call write_inopt(rinj,'rinj','injection radius',iunit) if (maxvxyzu >= 4) then - call write_inopt(HonR_inj,'HonR_inj','aspect ratio to give temperature at rinj',iunit) -endif -if (nptmass >= 1) then - call write_inopt(follow_sink,'follow_sink','injection radius is relative to sink particle 1',iunit) -endif + call write_inopt(HonR_inj,'HonR_inj','aspect ratio to give temperature at rinj',iunit) + endif + if (nptmass >= 1) then + call write_inopt(follow_sink,'follow_sink','injection radius is relative to sink particle 1',iunit) + endif end subroutine write_options_inject diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index 5a0113c1e..7751c4da0 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -128,7 +128,7 @@ subroutine read_analysis_options call read_inopt(rout,'rout',db,errcount=nerr) call close_db(db) if (nerr > 0) then - call fatal(trim(analysistype),'Error in reading '//trim(inputfile)) + call fatal(trim(analysistype),'Error in reading '//trim(inputfile)) endif else From 9973d4f2b844915e1ebaae67b4f80f154b86ccf5 Mon Sep 17 00:00:00 2001 From: Ana Lourdes Juarez Date: Wed, 26 Jun 2024 10:07:41 +0200 Subject: [PATCH 655/814] Add masstransfer setup to make_setup file --- build/Makefile_setups | 9 ++ src/setup/setup_masstransfer.f90 | 205 +++++++++++++++++++++++++++++++ 2 files changed, 214 insertions(+) create mode 100644 src/setup/setup_masstransfer.f90 diff --git a/build/Makefile_setups b/build/Makefile_setups index d5f34b9a5..020c978d4 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -845,6 +845,15 @@ ifeq ($(SETUP), windtunnel) ANALYSIS=analysis_common_envelope.f90 endif +ifeq ($(SETUP), masstransfer) +# Wind tunnel setup + SETUPFILE= setup_masstransfer.f90 + GRAVITY=yes + KNOWN_SETUP=yes + IND_TIMESTEPS=yes + ANALYSIS=analysis_common_envelope.f90 +endif + ifeq ($(SETUP), jet) # Jet simulation from Price, Tricco & Bate (2012) SETUPFILE= velfield_fromcubes.f90 setup_sphereinbox.f90 diff --git a/src/setup/setup_masstransfer.f90 b/src/setup/setup_masstransfer.f90 new file mode 100644 index 000000000..ef811f661 --- /dev/null +++ b/src/setup/setup_masstransfer.f90 @@ -0,0 +1,205 @@ +!--------------------------------------------------------------------------! +! 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 setup +! +! Setup of two stars or sink particles in a binary +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: +! - O : *position angle of ascending node (deg)* +! - a : *semi-major axis (e.g. 1 au), period (e.g. 10*days) or rp if e=1* +! - corotate : *set stars in corotation* +! - eccentricity : *eccentricity* +! - f : *initial true anomaly (180=apoastron)* +! - inc : *inclination (deg)* +! - relax : *relax stars into equilibrium* +! - w : *argument of periapsis (deg)* +! +! :Dependencies: centreofmass, dim, eos, externalforces, infile_utils, io, +! mpidomain, options, part, physcon, relaxstar, setbinary, setstar, +! setunits, setup_params, units +! + + implicit none + public :: setpart + real :: a,mdon,macc,hacc,hdon + + private + +contains + +!---------------------------------------------------------------- +!+ +! setup for binary star simulations (with or without gas) +!+ +!---------------------------------------------------------------- +subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& + polyk,gamma,hfact,time,fileprefix) + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc + use setbinary, only:set_binary,get_period_from_a + use options, only:iexternalforce + use externalforces, only:iext_corotate,omega_corotate + use io, only:master,fatal + use eos, only:ieos, gmw + use setunits, only:mass_unit,dist_unit + use timestep, only:tmax,dtmax + integer, intent(in) :: id + integer, intent(inout) :: npart + integer, intent(out) :: npartoftype(:) + real, intent(out) :: xyzh(:,:) + real, intent(out) :: massoftype(:) + real, intent(out) :: polyk,gamma,hfact + real, intent(inout) :: time + character(len=20), intent(in) :: fileprefix + real, intent(out) :: vxyzu(:,:) + character(len=120) :: filename + integer :: ierr + logical :: iexist + real :: period,ecc +! +!--general parameters +! + dist_unit = 'solarr' + mass_unit = 'solarm' + iexternalforce = iext_corotate + time = 0. + polyk = 0. + gamma = 5./3. +! +!--space available for injected gas particles +! in case only sink particles are used +! + npart = 0 + npartoftype(:) = 0 + massoftype = 0. + + xyzh(:,:) = 0. + vxyzu(:,:) = 0. + nptmass = 0 + a = 266.34 + mdon = 6.97 + macc = 1.41 + hacc = 10. + ieos = 2 + gmw = 0.6 + ecc = 0. + hdon = 0. + + 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 (.not. iexist .or. ierr /= 0) then + if (id==master) then + call write_setupfile(filename) + print*,' Edit '//trim(filename)//' and rerun phantomsetup' + endif + stop + endif + ! + ! + !--if a is negative or is given time units, interpret this as a period + ! + + period = get_period_from_a(mdon,macc,a) + tmax = 10.*period + dtmax = tmax/20. + ! + !--now setup orbit using fake sink particles + ! + call set_binary(mdon,macc,a,ecc,hdon,hacc,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,omega_corotate,& + verbose=(id==master)) + + + + if (ierr /= 0) call fatal ('setup_binary','error in call to set_binary') + ! + !--delete donor sink + ! + nptmass=1 + xyzmh_ptmass(:,1) = xyzmh_ptmass(:,2) + vxyz_ptmass(:,1) = vxyz_ptmass(:,2) + + ! + !--restore options + ! + + +end subroutine setpart + +!---------------------------------------------------------------- +!+ +! write options to .setup file +!+ +!---------------------------------------------------------------- +subroutine write_setupfile(filename) + use infile_utils, only:write_inopt + use setunits, only:write_options_units + use eos, only:write_options_eos + 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 binary setup routines' + + call write_options_units(iunit) + call write_options_eos(iunit) + + write(iunit,"(/,a)") '# orbit settings' + call write_inopt(a,'a','semi-major axis',iunit) + call write_inopt(mdon,'mdon','mass of the donor star',iunit) + call write_inopt(macc,'macc','mass of the companion star',iunit) + call write_inopt(hacc,'hacc','accretion radius of the companion star',iunit) + + close(iunit) + +end subroutine write_setupfile + +!---------------------------------------------------------------- +!+ +! read options from .setup file +!+ +!---------------------------------------------------------------- +subroutine read_setupfile(filename,ieos,polyk,ierr) + use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db + use io, only:error,fatal + 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 + 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) + + call read_inopt(ieos,'ieos',db,errcount=nerr) ! equation of state + call read_inopt(a,'a',db,errcount=nerr) + call read_inopt(mdon,'mdon',db,errcount=nerr) + call read_inopt(macc,'macc',db,errcount=nerr) + call read_inopt(hacc,'hacc',db,errcount=nerr) + call close_db(db) + + + if (nerr > 0) then + print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' + ierr = nerr + endif + +end subroutine read_setupfile + +end module setup From 5d4e5215b45fc79fd49a2d9fc55b23f3cd85260c Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 26 Jun 2024 11:10:38 +0100 Subject: [PATCH 656/814] Updated test suite from upstream --- src/tests/test_ptmass.f90 | 4 +- src/tests/test_wind.f90 | 262 +++++++++++++++++++++++++++++--------- src/tests/testsuite.F90 | 2 + 3 files changed, 207 insertions(+), 61 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 7272f1276..966a77727 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -766,7 +766,7 @@ subroutine test_createsink(ntests,npass) use part, only:init_part,npart,npartoftype,igas,xyzh,massoftype,hfact,rhoh,& iphase,isetphase,fext,divcurlv,vxyzu,fxyzu,poten, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,ndptmass, & - dptmass + dptmass,fxyz_ptmass_sinksink use ptmass, only:ptmass_accrete,update_ptmass,icreate_sinks,& ptmass_create,finish_ptmass,ipart_rhomax,h_acc,rho_crit,rho_crit_cgs use energies, only:compute_energies,angtot,etot,totmom @@ -886,7 +886,7 @@ subroutine test_createsink(ntests,npass) call reduceloc_mpi('max',ipart_rhomax_global,id_rhomax) endif call ptmass_create(nptmass,npart,itestp,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& - massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,0.) + massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,dptmass,0.) ! ! check that creation succeeded ! diff --git a/src/tests/test_wind.f90 b/src/tests/test_wind.f90 index ffd72aea9..65de7fb84 100644 --- a/src/tests/test_wind.f90 +++ b/src/tests/test_wind.f90 @@ -14,15 +14,18 @@ module testwind ! ! :Runtime parameters: None ! -! :Dependencies: boundary, checksetup, dim, eos, inject, io, options, part, -! partinject, physcon, step_lf_global, testutils, timestep, timestep_ind, -! units, wind +! :Dependencies: allocutils, boundary, checksetup, dim, dust_formation, +! eos, inject, io, options, part, partinject, physcon, ptmass, +! ptmass_radiation, readwrite_infile, step_lf_global, testutils, +! timestep, timestep_ind, units, wind ! implicit none public :: test_wind private + logical :: vb = .false. + contains !---------------------------------------------------------- !+ @@ -30,29 +33,24 @@ module testwind !+ !---------------------------------------------------------- subroutine test_wind(ntests,npass) - use io, only:iprint,id,master,iverbose!,iwritein - use boundary, only:set_boundary - use options, only:ieos!,icooling - use physcon, only:au,solarm,solarl - use units, only:umass,set_units,utime,unit_energ,udist - use inject, only:init_inject,inject_particles,set_default_options_inject,inject_type - use eos, only:gmw,ieos,init_eos,gamma,polyk - use part, only:npart,init_part,nptmass,xyzmh_ptmass,vxyz_ptmass,xyzh,vxyzu,& - nptmass,npartoftype,igas,iTeff,iLum,iReff,massoftype,ntot - use timestep, only:time,tmax,dt,dtmax,nsteps,dtrad,dtforce,dtcourant,dterr,print_dtlog - use step_lf_global, only:step,init_step - use testutils, only:checkval,update_test_scores - use dim, only:isothermal,inject_parts,mpi - use partinject, only:update_injected_particles - use timestep_ind, only:nbinmax - use wind, only:trvurho_1D - use checksetup, only:check_setup - !use readwrite_infile, only:read_infile,write_infile + use io, only:id,master,iprint,iwritein + use inject, only:inject_type + use boundary, only:set_boundary + use physcon, only:au,solarm,solarl + use units, only:set_units + use part, only:npart,xyzmh_ptmass,vxyzu,dust_temp + use testutils, only:checkval,update_test_scores + use dim, only:mpi,maxTdust,maxp,sink_radiation,nucleation,ind_timesteps + use allocutils, only:allocate_array + use options, only:alphamax + use readwrite_infile, only:read_infile,write_infile integer, intent(inout) :: ntests,npass - integer :: i,ierr,nerror,istepfrac,npart_old,nfailed(9),nwarn - real :: dtinject,dtlast,t,default_particle_mass,dtext,dtnew,dtprint,dtmaxold,tprint + real, parameter :: eps_sum = 1e-14 + integer :: npart_old,nfailed(5),istepfrac + real :: dtinject,eint,ekin + logical :: testkd,testcyl,test2 if (mpi) then if (id==master) write(*,"(/,a,/)") '--> SKIPPING WIND TEST (currently not working with MPI)' @@ -67,13 +65,116 @@ subroutine test_wind(ntests,npass) call set_units(dist=au,mass=solarm,G=1.d0) call set_boundary(-50.,50.,-50.,50.,-50.,50.) + testkd = sink_radiation .and. nucleation .and. alphamax == 1. .and. ind_timesteps + test2 = .not.sink_radiation .and. .not.nucleation .and. alphamax == 1. .and. .not.ind_timesteps + testcyl = .not.sink_radiation .and. .not.nucleation .and. alphamax == 1. .and. ind_timesteps + +! test trans-sonic wind - no radiation, no dust + + call init_testwind(1,ntests,npass,npart_old,istepfrac,dtinject) + if (id==master) call write_infile('w.in','w.log','w.ev','w_00000',iwritein,iprint) + call integrate_wind(npart_old,istepfrac,dtinject) + nfailed(:) = 0 + eint = sum(vxyzu(4,1:npart)) + ekin = sqrt(sum(vxyzu(1,1:npart)**2+vxyzu(2,1:npart)**2+vxyzu(3,1:npart)**2)) + if (vb) print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart + call checkval(xyzmh_ptmass(4,1),1.199987894518367E+00,epsilon(0.),nfailed(1),'sink particle mass') + call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') + call checkval(npart,12180,0,nfailed(3),'number of ejected particles') + if (testcyl) then + call checkval(eint,3.360686893182378E+03,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,5.605632523862468E+01,eps_sum,nfailed(5),'total kinetic energy') + elseif (testkd) then + call checkval(eint,3.164153170427767E+03,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,6.101010545772693E+01,eps_sum,nfailed(5),'total kinetic energy') + elseif (test2) then + call checkval(eint,3.367417540822784E+03,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,5.524867074648306E+01,eps_sum,nfailed(5),'total kinetic energy') + else + call checkval(eint,3.179016341424608E+03,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,6.005124961952793E+01,eps_sum,nfailed(5),'total kinetic energy') + endif + call update_test_scores(ntests,nfailed,npass) + + + if (sink_radiation) then + +! test wind with bowen dust + radiative acceleration + + maxTdust = maxp + if (allocated(dust_temp)) deallocate(dust_temp) + call allocate_array('dust_temp',dust_temp,maxTdust) + + call init_testwind(2,ntests,npass,npart_old,istepfrac,dtinject) + !if (id==master) call write_infile('w2.in','w2.log','w2.ev','w2_00000',iwritein,iprint) + call integrate_wind(npart_old,istepfrac,dtinject) + nfailed(:) = 0 + eint = sum(vxyzu(4,1:npart)) + ekin = sqrt(sum(vxyzu(1,1:npart)**2+vxyzu(2,1:npart)**2+vxyzu(3,1:npart)**2)) + if (vb) print '(5(1x,es22.15),i8)',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),eint,ekin,npart + call checkval(xyzmh_ptmass(4,1),1.199987815414834E+00,epsilon(0.),nfailed(1),'sink particle mass') + call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(2),'mass accreted') + call checkval(npart,21924,0,nfailed(3),'number of ejected particles') + if (testkd) then + call checkval(eint,2.187465510809545E+02,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,1.709063901093157E+02,eps_sum,nfailed(5),'total kinetic energy') + else + call checkval(eint,2.218461223513102E+02,eps_sum,nfailed(4),'total internal energy') + call checkval(ekin,1.709669096834302E+02,eps_sum,nfailed(5),'total kinetic energy') + endif + else + if (id==master) write(*,"(/,a,/)") ' SKIPPING SINK RADIATION TEST' + endif + call update_test_scores(ntests,nfailed,npass) + + if (id==master) write(*,"(/,a)") '<-- WIND TEST COMPLETE' + +end subroutine test_wind + +!----------------------------------------------------------------------- +! +subroutine init_testwind(icase,ntests,npass,npart_old,istepfrac,dtinject) +! +!----------------------------------------------------------------------- + + use io, only:iverbose + use inject, only:init_inject,inject_particles,set_default_options_inject + use units, only:umass,utime,unit_energ,udist + use physcon, only:au,solarm,solarl + use eos, only:gmw,ieos,init_eos,gamma,polyk + use part, only:npart,init_part,nptmass,xyzmh_ptmass,vxyz_ptmass,xyzh,vxyzu,& + npartoftype,igas,iTeff,iLum,iReff,massoftype + use timestep, only:tmax,dt,dtmax,dtrad + use wind, only:trvurho_1D + use timestep_ind, only:nbinmax + use dim, only:isothermal + use checksetup, only:check_setup + use partinject, only:update_injected_particles + use testutils, only:checkval,update_test_scores + use ptmass, only:set_integration_precision + use ptmass_radiation, only:alpha_rad,isink_radiation + use dust_formation, only:idust_opacity + + integer, intent(in) :: icase + integer, intent(inout) :: ntests,npass + integer, intent(out) :: npart_old,istepfrac + real, intent(out) :: dtinject + + integer :: i,ierr,nerror,nwarn,nfailed(5) + real :: t,default_particle_mass,dtnew + call init_part() + call set_integration_precision() ! set properties of mass-losing sink particle nptmass = 1 - xyzmh_ptmass(4,1) = 1.2*solarm/umass - xyzmh_ptmass(5,1) = au/udist - xyzmh_ptmass(iTeff,1) = 50000. + xyzmh_ptmass(4,1) = 1.2*solarm/umass + xyzmh_ptmass(5,1) = au/udist + if (icase == 1) then + xyzmh_ptmass(iTeff,1) = 50000. + elseif (icase == 2) then + xyzmh_ptmass(iTeff,1) = 3000. + endif xyzmh_ptmass(iReff,1) = au/udist xyzmh_ptmass(iLum,1) = 2e4 *solarl * utime / unit_energ @@ -97,10 +198,20 @@ subroutine test_wind(ntests,npass) call init_eos(ieos,ierr) iverbose = 0 - !icooling = 0 - dtmax = 1. - tmax = 8. - tprint = tmax + dtmax = 1. + tmax = 8. + !wind + bowen dust + radiation force + if (icase == 1) then + alpha_rad = 0. + isink_radiation = 0 !radiation + alpha_rad + idust_opacity = 0 !bowen opacity + elseif (icase == 2) then + alpha_rad = 1. + isink_radiation = 3 !radiation + alpha_rad + idust_opacity = 1 !bowen opacity + else + stop '[test wind] unknown test ' + endif dt = 0. dtinject = huge(dtinject) dtrad = huge(dtrad) @@ -108,34 +219,76 @@ subroutine test_wind(ntests,npass) dtnew = 0. ! trans-sonic wind - call set_default_options_inject(1) + call set_default_options_inject(icase) call check_setup(nerror,nwarn) - istepfrac = 0 nfailed(:) = 0 + istepfrac = 0 call init_inject(nerror) + npart_old = npart - !debug if (id==master) call write_infile('w.in','w.log','w.ev','w_00000',iwritein,iprint) +!trans-sonic wind - no radiation + if (icase == 1) then + ! check particle's mass + call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + npart,npart_old,npartoftype,dtinject) + call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) - ! check particle's mass - call checkval(massoftype(igas),1.490822861042279E-09,epsilon(0.),& - nfailed(1),'no errors in setting particle mass') - npart_old = npart - call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npart_old,npartoftype,dtinject) - call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) - - ! check 1D wind profile - i = size(trvurho_1D(1,:)) - !print '((5(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) - call checkval(trvurho_1D(2,i),7.058624412798283E+13,epsilon(0.),nfailed(2),'outer wind radius') - call checkval(trvurho_1D(3,i),1.112160584479353E+06,epsilon(0.),nfailed(3),'outer wind velocity') - call checkval(trvurho_1D(4,i),2.031820842001706E+12,epsilon(0.),nfailed(4),'outer wind internal energy') - call checkval(trvurho_1D(5,i),8.878887149408118E-15,epsilon(0.),nfailed(5),'outer wind density') + ! check 1D wind profile + i = size(trvurho_1D(1,:)) + if (vb) print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) + call checkval(massoftype(igas),1.490822861042279E-9,epsilon(0.),nfailed(1),'setting particle mass') + call checkval(trvurho_1D(2,i),7.058624412798283E+13,epsilon(0.),nfailed(2),'1D wind terminal radius') + call checkval(trvurho_1D(3,i),1.112160584479353E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') + call checkval(trvurho_1D(4,i),2.031820842001706E+12,epsilon(0.),nfailed(4),'1D wind internal energy') + call checkval(trvurho_1D(5,i),8.878887149408118E-15,epsilon(0.),nfailed(5),'1D wind terminal density') + call update_test_scores(ntests,nfailed,npass) + endif + + !wind + radiation + if (icase == 2) then + ! check particle's mass + call inject_particles(t,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) + call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) + + ! check 1D wind profile + i = size(trvurho_1D(1,:)) + if (vb) print '((6(1x,es22.15)))',trvurho_1D(:,i),massoftype(igas) + call checkval(massoftype(igas),6.820748526700016E-10,epsilon(0.),nfailed(1),'setting particle mass') + call checkval(trvurho_1D(2,i), 1.546371444697654E+14,epsilon(0.),nfailed(2),'1D wind terminal radius') + call checkval(trvurho_1D(3,i), 4.298693548460183E+06,epsilon(0.),nfailed(3),'1D wind terminal velocity') + call checkval(trvurho_1D(4,i), 4.318674031561777E+10,epsilon(0.),nfailed(4),'1D wind internal energy') + call checkval(trvurho_1D(5,i), 4.879641694552266E-16,epsilon(0.),nfailed(5),'1D wind terminal density') + call update_test_scores(ntests,nfailed,npass) + endif + +end subroutine init_testwind + + +!----------------------------------------------------------------------- +! +subroutine integrate_wind(npart_old,istepfrac,dtinject) +! +!----------------------------------------------------------------------- + + use io, only:id,iprint,master + use timestep, only:time,tmax,dt,dtmax,nsteps,dtrad,dtforce,dtcourant,dterr,print_dtlog + use part, only:npart,init_part,xyzmh_ptmass,vxyz_ptmass,xyzh,vxyzu,npartoftype,ntot + use timestep_ind, only:nbinmax + use step_lf_global, only:step,init_step + use partinject, only:update_injected_particles + use inject, only:inject_particles + + integer, intent(inout) :: istepfrac,npart_old + real, intent(inout) :: dtinject + + real :: dtlast,t,dtext,dtnew,dtprint,dtmaxold,tprint dt = dtinject dtlast = 0. time = 0. + tprint = tmax + t = 0. call init_step(npart_old,time,dtmax) @@ -145,7 +298,7 @@ subroutine test_wind(ntests,npass) ! ! injection of new particles into simulation ! - npart_old=npart + npart_old = npart call inject_particles(t,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinject) call update_injected_particles(npart_old,npart,istepfrac,nbinmax,t,dtmax,dt,dtinject) dtmaxold = dtmax @@ -164,15 +317,6 @@ subroutine test_wind(ntests,npass) enddo - !print '((3(1x,es22.15),i8))',xyzmh_ptmass(4,1),xyzmh_ptmass(7,1),xyzmh_ptmass(15,1),npart - call checkval(xyzmh_ptmass(4,1),1.199987894518367E+00,epsilon(0.),nfailed(6),'sink particle mass') - call checkval(xyzmh_ptmass(7,1),0.,epsilon(0.),nfailed(7),'mass accreted') - call checkval(npart,12180,0,nfailed(8),'number of ejected particles') - call checkval(xyzmh_ptmass(15,1),1.591640703559762E-06,epsilon(0.),nfailed(9),'wind mass loss rate') - call update_test_scores(ntests,nfailed,npass) - - if (id==master) write(*,"(/,a)") '<-- WIND TEST COMPLETE' - -end subroutine test_wind +end subroutine integrate_wind end module testwind diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index d3bf32d13..a5c129f0d 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -97,6 +97,8 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) write(*,"(14x,a,/)") '-- Richard West (former UKAFF manager)' write(*,"(2x,a)") '"Trace, test and treat"' write(*,"(14x,a,/)") '-- South Korea' + write(*,"(2x,a)") '"Testing a program demonstrates that it contains errors, never that it is correct"' + write(*,"(14x,a,/)") '-- E. W. Dijkstra' endif ntests = 0 npass = 0 From 91b5345818f8e37283d1fe522f2cf1119cabf7da Mon Sep 17 00:00:00 2001 From: Ana Lourdes Juarez Date: Wed, 26 Jun 2024 16:59:58 +0200 Subject: [PATCH 657/814] New setup mass transfer with companion gravitational potential --- src/setup/set_binary.f90 | 13 ++++++++++- src/setup/setup_masstransfer.f90 | 40 ++++++++++++++++++++------------ 2 files changed, 37 insertions(+), 16 deletions(-) diff --git a/src/setup/set_binary.f90 b/src/setup/set_binary.f90 index 3027f47d7..fa05d3c78 100644 --- a/src/setup/set_binary.f90 +++ b/src/setup/set_binary.f90 @@ -25,7 +25,7 @@ module setbinary ! :Dependencies: binaryutils ! implicit none - public :: set_binary,Rochelobe_estimate,L1_point,get_a_from_period + public :: set_binary,Rochelobe_estimate,L1_point,get_a_from_period,get_period_from_a public :: get_mean_angmom_vector,get_eccentricity_vector private @@ -406,6 +406,17 @@ function get_a_from_period(m1,m2,period) result(a) end function get_a_from_period +!------------------------------------------------------------- +! Function to determine the period given the semi-major axis +!------------------------------------------------------------- +function get_period_from_a(m1,m2,a) result(period) + real, intent(in) :: m1,m2,a + real :: period + +period= sqrt(((2.*pi)**2*a**3)/(m1 + m2)) + +end function get_period_from_a + !---------------------------------------------------- ! Eccentricity vector, for second body ! https://en.wikipedia.org/wiki/Eccentricity_vector diff --git a/src/setup/setup_masstransfer.f90 b/src/setup/setup_masstransfer.f90 index ef811f661..43cc861a8 100644 --- a/src/setup/setup_masstransfer.f90 +++ b/src/setup/setup_masstransfer.f90 @@ -13,8 +13,9 @@ module setup ! :Owner: Daniel Price ! ! :Runtime parameters: -! - O : *position angle of ascending node (deg)* -! - a : *semi-major axis (e.g. 1 au), period (e.g. 10*days) or rp if e=1* +! - a : *semi-major axis* +! - mdon : *donor/primary star mass* +! - macc : *accretor/companion star mass* ! - corotate : *set stars in corotation* ! - eccentricity : *eccentricity* ! - f : *initial true anomaly (180=apoastron)* @@ -29,7 +30,7 @@ module setup implicit none public :: setpart - real :: a,mdon,macc,hacc,hdon + real :: a,mdon,macc,hacc private @@ -44,8 +45,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& polyk,gamma,hfact,time,fileprefix) use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc use setbinary, only:set_binary,get_period_from_a +use centreofmass, only:reset_centreofmass use options, only:iexternalforce use externalforces, only:iext_corotate,omega_corotate + use extern_corotate, only:icompanion_grav,companion_xpos,companion_mass,hsoft use io, only:master,fatal use eos, only:ieos, gmw use setunits, only:mass_unit,dist_unit @@ -62,13 +65,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& character(len=120) :: filename integer :: ierr logical :: iexist - real :: period,ecc + real :: period,ecc,hdon,mass_ratio ! !--general parameters ! dist_unit = 'solarr' mass_unit = 'solarm' - iexternalforce = iext_corotate time = 0. polyk = 0. gamma = 5./3. @@ -80,17 +82,19 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& npartoftype(:) = 0 massoftype = 0. + iexternalforce = iext_corotate + icompanion_grav = 1 xyzh(:,:) = 0. vxyzu(:,:) = 0. nptmass = 0 a = 266.34 mdon = 6.97 macc = 1.41 - hacc = 10. + hacc = 1. ieos = 2 gmw = 0.6 ecc = 0. - hdon = 0. + hdon = 1. if (id==master) print "(/,65('-'),1(/,a),/,65('-'),/)",& ' Welcome to the Ultimate Binary Setup' @@ -112,24 +116,30 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& period = get_period_from_a(mdon,macc,a) tmax = 10.*period - dtmax = tmax/20. + dtmax = tmax/200. ! !--now setup orbit using fake sink particles ! call set_binary(mdon,macc,a,ecc,hdon,hacc,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,omega_corotate,& verbose=(id==master)) + call reset_centreofmass(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) if (ierr /= 0) call fatal ('setup_binary','error in call to set_binary') + + companion_mass = mdon + companion_xpos = xyzmh_ptmass(1,1) + mass_ratio = mdon / macc + hsoft = 0.1 * 0.49 * mass_ratio**(2./3.) / (0.6*mass_ratio**(2./3.) + & + log( 1. + mass_ratio**(1./3.) ) ) * a ! !--delete donor sink ! nptmass=1 xyzmh_ptmass(:,1) = xyzmh_ptmass(:,2) - vxyz_ptmass(:,1) = vxyz_ptmass(:,2) - - ! + vxyz_ptmass(1:3,1) = 0. + !--restore options ! @@ -174,7 +184,7 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db use io, only:error,fatal use setunits, only:read_options_and_set_units - character(len=*), intent(in) :: filename + character(len=*), intent(in) :: filename integer, intent(inout) :: ieos real, intent(inout) :: polyk integer, intent(out) :: ierr @@ -183,7 +193,8 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) type(inopts), allocatable :: db(:) nerr = 0 - ierr = 0 + ierr = 0 + call open_db_from_file(db,filename,iunit,ierr) call read_options_and_set_units(db,nerr) @@ -194,8 +205,7 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) call read_inopt(hacc,'hacc',db,errcount=nerr) call close_db(db) - - if (nerr > 0) then + if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' ierr = nerr endif From 25092cd851564d5d0e8cb00c6d10ff3887fa5b5a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 27 Jun 2024 15:47:25 +0200 Subject: [PATCH 658/814] (timing) correct wrong timer parent --- src/main/utils_timing.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/utils_timing.f90 b/src/main/utils_timing.f90 index e45c44178..9e2de5d71 100644 --- a/src/main/utils_timing.f90 +++ b/src/main/utils_timing.f90 @@ -87,6 +87,7 @@ subroutine setup_timers call init_timer(itimer_fromstart , 'all', 0 ) call init_timer(itimer_lastdump , 'last', 0 ) call init_timer(itimer_step , 'step', 0 ) + call init_timer(itimer_HII , 'HII_regions', 0 ) call init_timer(itimer_link , 'tree', itimer_step ) call init_timer(itimer_balance , 'balance', itimer_link ) call init_timer(itimer_dens , 'density', itimer_step ) @@ -95,7 +96,6 @@ subroutine setup_timers call init_timer(itimer_force , 'force', itimer_step ) call init_timer(itimer_force_local , 'local', itimer_force ) call init_timer(itimer_force_remote, 'remote', itimer_force ) - call init_timer(itimer_HII , 'HII_regions', itimer_step ) call init_timer(itimer_radiation , 'radiation', itimer_step ) call init_timer(itimer_rad_save , 'save', itimer_radiation ) call init_timer(itimer_rad_neighlist,'neighlist', itimer_radiation ) From 20b58692ce99fd0ca5b414675f01f9a6eaee0b72 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 27 Jun 2024 15:48:56 +0200 Subject: [PATCH 659/814] (HIIRegion) optimisation of the feedback scheme --- src/main/H2regions.f90 | 6 +++--- src/main/evolve.F90 | 10 ++++++++-- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 0d1774c37..834a02cc4 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -212,18 +212,18 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) zi = xyzmh_ptmass(3,i) stromi = xyzmh_ptmass(irstrom,i) if(stromi >= 0. ) then - hcheck = 2.*stromi + hcheck = 1.4*stromi else hcheck = Rmax endif - do while(nneigh < 0) + do while(nneigh < 0 .and. hcheck/=Rmax) hcheck = hcheck + 0.01*Rmax ! additive term to allow unresolved case to open if (hcheck > Rmax) hcheck = Rmax call getneigh_pos((/xi,yi,zi/),0.,hcheck,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) call set_r2func_origin(xi,yi,zi) call Knnfunc(nneigh,r2func_origin,xyzh,listneigh) enddo - do k=1,npart + do k=1,nneigh j = listneigh(k) if (.not. isdead_or_accreted(xyzh(4,j))) then ! ionising photons needed to fully ionise the current particle diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 450affe97..85378ae4b 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -90,7 +90,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) 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,& - linklist_ptmass,isionised,dsdt_ptmass + linklist_ptmass,isionised,dsdt_ptmass,isdead_or_accreted use part, only:n_group,n_ingroup,n_sing,group_info,nmatrix use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & @@ -289,7 +289,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (icreate_sinks == 2) then call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink, & linklist_ptmass,time,star_formed) - if(star_formed) then + if(star_formed .or. isdead_or_accreted(xyzh(4,ipart_rhomax))) then if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& @@ -309,7 +309,13 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) endif if (iH2R > 0 .and. id==master) then +#ifdef IND_TIMESTEPS + if(mod(istepfrac,(2**(nbinmax-3))==0).or. istepfrac==1) then + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) + endif +#else call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) +#endif endif nsteps = nsteps + 1 From bb35c00ab8709fe9b540a99ec93d52cf6d2b4bea Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 27 Jun 2024 15:49:42 +0200 Subject: [PATCH 660/814] add f_crit_override to setup cluster --- src/setup/setup_cluster.f90 | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 65efb4f1f..3de560ba9 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -56,7 +56,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use timestep, only:dtmax,tmax use centreofmass, only:reset_centreofmass use ptmass, only:h_acc,r_crit,rho_crit_cgs,icreate_sinks,tmax_acc,h_soft_sinkgas, & - r_merge_uncond,use_regnbody + r_merge_uncond,use_regnbody,f_crit_override use datafiles, only:find_phantom_datafile use eos, only:ieos,gmw use kernel, only:hfact_default @@ -205,14 +205,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, dtmax = 0.002*t_ff h_acc = Rsink_au*au/udist if (icluster == 3) then - r_crit = h_acc - icreate_sinks = 2 - rho_crit_cgs = 1.d-18 - h_soft_sinkgas = h_acc - tmax_acc = 0.5*(myr/utime) - r_merge_uncond = h_acc - use_regnbody = .true. - r_neigh = 5e-2*h_acc + r_crit = h_acc + icreate_sinks = 2 + rho_crit_cgs = 1.d-18 + h_soft_sinkgas = h_acc + tmax_acc = 0.5*(myr/utime) + r_merge_uncond = h_acc + use_regnbody = .true. + r_neigh = 5e-2*h_acc + f_crit_override = 100. else r_crit = 2.*h_acc icreate_sinks = 1 From 7096229208d7f42e6d87d47f74922dc5ae3ed21c Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 27 Jun 2024 16:56:53 +0200 Subject: [PATCH 661/814] (ptmass) adding a time to reach before creating seeds into sinks --- src/main/evolve.F90 | 14 ++++++++-- src/main/ptmass.F90 | 52 ++++++++++++++++++++++++------------- src/setup/setup_cluster.f90 | 1 + 3 files changed, 47 insertions(+), 20 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 85378ae4b..9b5ffae41 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -94,7 +94,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) use part, only:n_group,n_ingroup,n_sing,group_info,nmatrix use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & - set_integration_precision,ptmass_create_stars,use_regnbody + set_integration_precision,ptmass_create_stars,use_regnbody,ptmass_create_seeds use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries @@ -287,8 +287,17 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) 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) if (icreate_sinks == 2) then + ! + ! creation of new seeds into evolved sinks + ! + call ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) + ! + ! creation of new stars from sinks (cores) + ! call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink, & linklist_ptmass,time,star_formed) + + ! Need to recompute the force when sink or stars are created if(star_formed .or. isdead_or_accreted(xyzh(4,ipart_rhomax))) then if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) @@ -299,6 +308,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass) endif endif + endif endif ! @@ -310,7 +320,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (iH2R > 0 .and. id==master) then #ifdef IND_TIMESTEPS - if(mod(istepfrac,(2**(nbinmax-3))==0).or. istepfrac==1) then + if(mod(istepfrac,2**(nbinmax-3))==0 .or. istepfrac==1) then call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) endif #else diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 4a5183139..9632d3a0f 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -49,7 +49,8 @@ module ptmass public :: merge_sinks public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured - public :: ptmass_accrete, ptmass_create,ptmass_create_stars + public :: ptmass_accrete, ptmass_create + public :: ptmass_create_stars,ptmass_create_seeds public :: write_options_ptmass, read_options_ptmass public :: update_ptmass public :: calculate_mdot @@ -65,6 +66,7 @@ module ptmass real, public :: h_acc = 1.e-3 real, public :: f_acc = 0.8 real, public :: tmax_acc = huge(f_acc) + real, public :: tseeds = huge(f_acc) real, public :: h_soft_sinkgas = 0.0 real, public :: h_soft_sinksink = 0.0 real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch @@ -648,7 +650,7 @@ subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_pt !$omp parallel do schedule(static) default(none) & - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dkdt,nptmass,iJ2) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dkdt,nptmass) & !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then @@ -1569,10 +1571,9 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote endif if (nacc <= 0) call fatal('ptmass_create',' created ptmass but failed to accrete anything') nptmass = new_nptmass - + ! link the new sink to nothing (waiting for age > tseeds) if (icreate_sinks == 2) then - call ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) - write(iprint,"(a,i3)") ' Star formation prescription : created seeds #',(nptmass + 1 - new_nptmass) + linklist_ptmass(nptmass) = -1 endif ! ! open new file to track new sink particle details & and update all sink-tracking files; @@ -1600,28 +1601,39 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote end subroutine ptmass_create subroutine ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) - use part, only:itbirth,ihacc + use part, only:itbirth,ihacc use random, only:ran2 + use io, only:iprint integer, intent(inout) :: nptmass integer, intent(inout) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: time - integer :: i,nseed,n + real :: mi,hi,tbirthi + integer :: i,j,nseed,n ! !-- Draw the number of star seeds in the core ! - nseed = floor(5*ran2(iseed_sf))-1 - n = nptmass - linklist_ptmass(n) = n + 1 !! link the core to the seeds - do i=1,nseed - n = n + 1 - xyzmh_ptmass(itbirth,n) = time - xyzmh_ptmass(4,n) = -1. - xyzmh_ptmass(ihacc,n) = -1. - linklist_ptmass(n) = n + 1 !! link this new seed to the next one + do i=1,nptmass + mi = xyzmh_ptmass(4,i) + hi = xyzmh_ptmass(ihacc,i) + tbirthi = xyzmh_ptmass(itbirth,i) + if (linklist_ptmass(i)/=-1 .or. mi < 0 .or. hi=tbirthi+tseeds) then + nseed = floor(5*ran2(iseed_sf))-1 + n = nptmass + linklist_ptmass(i) = n + 1 !! link the core to the seeds + do j=1,nseed + n = n + 1 + xyzmh_ptmass(itbirth,n) = time + xyzmh_ptmass(4,n) = -1. + xyzmh_ptmass(ihacc,n) = -1. + linklist_ptmass(n) = n + 1 !! link this new seed to the next one + enddo + linklist_ptmass(n) = -1 !! null pointer to end the link list + write(iprint,"(a,i3,a,i3)") ' Star formation prescription : creation of :', nseed, ' seeds in sink n° :', i + nptmass = n + endif enddo - linklist_ptmass(n) = -1 !! null pointer to end the link list - nptmass = n end subroutine ptmass_create_seeds subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time,formed) @@ -2145,6 +2157,7 @@ subroutine write_options_ptmass(iunit) call write_inopt(h_acc, 'h_acc' ,'accretion radius for new sink particles',iunit) if (icreate_sinks==2) then call write_inopt(tmax_acc, "tmax_acc", "Maximum accretion time for star formation scheme", iunit) + call write_inopt(tseeds, "tseeds", "delay between sink creation and its seeds", iunit) call write_inopt(iseed_sf, "iseed_sf", "Initial radom seed for star formation scheme", iunit) endif if (f_crit_override > 0. .or. l_crit_override) then @@ -2240,6 +2253,9 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) case('tmax_acc') read(valstring,*,iostat=ierr) tmax_acc ngot = ngot + 1 + case('tseeds') + read(valstring,*,iostat=ierr) tseeds + ngot = ngot + 1 case('iseed_sf') read(valstring,*,iostat=ierr) iseed_sf ngot = ngot + 1 diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 3de560ba9..f1707e1e9 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -210,6 +210,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, rho_crit_cgs = 1.d-18 h_soft_sinkgas = h_acc tmax_acc = 0.5*(myr/utime) + tseeds = 0.1*(myr/utime) r_merge_uncond = h_acc use_regnbody = .true. r_neigh = 5e-2*h_acc From 84403bb2fffa1070656888fa5fa6b19cbdf0434c Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 28 Jun 2024 10:19:17 +0200 Subject: [PATCH 662/814] (sortutils) add a parallel quicksort --- src/main/utils_sort.f90 | 160 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 159 insertions(+), 1 deletion(-) diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index 432f98fe8..54732c7c3 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -17,7 +17,7 @@ module sortutils ! :Dependencies: None ! implicit none - public :: indexx,indexxfunc,Knnfunc,find_rank,r2func,r2func_origin,set_r2func_origin + public :: indexx,indexxfunc,Knnfunc,parqsort,find_rank,r2func,r2func_origin,set_r2func_origin interface indexx module procedure indexx_r4, indexx_i8 end interface indexx @@ -452,6 +452,164 @@ subroutine Knnfunc(n, func, xyzh, indx) end subroutine Knnfunc +!---------------------------------------------------------------- +!+ +! customised low-memory sorting routine using Quicksort +! sort key value on-the-fly by calling the function func +! which can be any function of the particle positions. +! (Tweaked version of the original one to sort a list of +! neighbours founded using the KD tree) (Parallel scheme, approx 2 times faster) +!+ +!---------------------------------------------------------------- +subroutine parqsort(n, arr,func, indx) + use omp_lib,only:omp_get_num_threads + implicit none + integer, parameter :: m=8, nstack=500 + integer(kind=8), intent(in) :: n + real, intent(in) :: arr(n) + integer, intent(inout) :: indx(n) + real, external :: func + integer :: i,j,k,il,ir,jstack,jqueue,indxt,itemp,nthreads,t,spt,nquick + integer, save :: istack(nstack) + !$omp threadprivate(istack) + integer :: iqueue(nstack) + real :: a + + nthreads = 1 + + !$omp parallel default(none) shared(nthreads) +!$ nthreads = omp_get_num_threads() + !$omp end parallel + + + spt = n/nthreads + + jstack = 0 + jqueue = 0 + iqueue = 0 + istack = 0 + il = 1 + ir = n + + do while (.true.) + + if (ir - il <= spt) then + jqueue = jqueue + 2 + iqueue(jqueue) = ir + iqueue(jqueue - 1) = il + if (jstack==0) exit + ir = istack(jstack) + il = istack(jstack - 1) + jstack = jstack - 2 + else + k = (il + ir)/2 + i = il + j = ir + indxt = indx(k) + a = func(arr(indxt)) + + do while (j>i) + do while(func(arr(indx(i))) < a) + i = i + 1 + enddo + do while (func(arr(indx(j))) > a) + j = j - 1 + enddo + if(j>i) then + itemp = indx(i) + indx(i) = indx(j) + indx(j) = itemp + endif + enddo + jstack = jstack + 2 + if (jstack > nstack) then + print*,'fatal error!!! stacksize exceeded in sort' + print*,'need to set parameter nstack higher in subroutine indexx ' + stop + endif + if (ir - i + 1 >= j - il) then + istack(jstack) = ir + istack(jstack - 1) = i + ir = j - 1 + else + istack(jstack) = j - 1 + istack(jstack - 1) = il + il = i + endif + endif + enddo + + istack = 0 + nquick = jqueue/2 + + + !$omp parallel do default(none) & + !$omp shared(indx,arr,nquick,iqueue)& + !$omp private(i,j,k,il,ir,a,jstack,indxt,itemp) + do t=1,nquick + ir = iqueue(2*t) + il = iqueue(2*t - 1) + jstack = 0 + + do while (.true.) + if (ir - il < m) then + !print*,il,ir + do j = il , ir + indxt = indx(j) + a = func(arr(indxt)) + do i = j - 1, il, -1 + if (func(arr(indx(i))) <= a) goto 5 + indx(i + 1) = indx(i) + enddo + i = il-1 +5 indx(i + 1) = indxt + enddo + if (jstack==0) exit + ir = istack(jstack) + il = istack(jstack - 1) + jstack = jstack - 2 + else + k = (il + ir)/2 + i = il + j = ir + indxt = indx(k) + a = func(arr(indxt)) + + do while (j>i) + do while(func(arr(indx(i))) < a) + i = i + 1 + enddo + do while (func(arr(indx(j))) > a) + j = j - 1 + enddo + if(j>i) then + itemp = indx(i) + indx(i) = indx(j) + indx(j) = itemp + endif + enddo + jstack = jstack + 2 + if (jstack > nstack) then + print*,'fatal error!!! stacksize exceeded in sort' + print*,'need to set parameter nstack higher in subroutine indexx ' + stop + endif + if (ir - i + 1 >= j - il) then + istack(jstack) = ir + istack(jstack - 1) = i + ir = j - 1 + else + istack(jstack) = j - 1 + istack(jstack - 1) = il + il = i + endif + endif + enddo + enddo + +end subroutine parqsort + + !---------------------------------------------------------------- !+ ! Same as indexxfunc, except two particles can have the same From b074a23db4c69032929f88e80511e93fdd5b0a35 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 28 Jun 2024 11:53:29 +0200 Subject: [PATCH 663/814] (ptmass) refactor ptmass create stars and seeds to clear loops in them --- src/main/evolve.F90 | 52 ++++---- src/main/part.F90 | 2 +- src/main/ptmass.F90 | 260 ++++++++++++++++++++-------------------- src/main/utils_sort.f90 | 2 +- 4 files changed, 160 insertions(+), 156 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 9b5ffae41..5a900ee9d 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -94,7 +94,8 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) use part, only:n_group,n_ingroup,n_sing,group_info,nmatrix use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & - set_integration_precision,ptmass_create_stars,use_regnbody,ptmass_create_seeds + set_integration_precision,ptmass_create_stars,use_regnbody,ptmass_create_seeds,& + ipart_createseeds,ipart_createstars use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries @@ -286,29 +287,38 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! 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) - if (icreate_sinks == 2) then - ! - ! creation of new seeds into evolved sinks - ! - call ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) - ! - ! creation of new stars from sinks (cores) - ! - call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink, & - linklist_ptmass,time,star_formed) - ! Need to recompute the force when sink or stars are created - if(star_formed .or. isdead_or_accreted(xyzh(4,ipart_rhomax))) then - if (use_regnbody) then - call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& - fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,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) - endif + if(isdead_or_accreted(xyzh(4,ipart_rhomax))) then + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& + fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,group_info=group_info) endif + endif + endif + if (icreate_sinks == 2) then + ! + ! creation of new seeds into evolved sinks + ! + if (ipart_createseeds /= 0) then + call ptmass_create_seeds(nptmass,ipart_createseeds,xyzmh_ptmass,linklist_ptmass,time) + endif + ! + ! creation of new stars from sinks (cores) + ! + if(ipart_createstars /= 0) then + call ptmass_create_stars(nptmass,ipart_createseeds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink, & + linklist_ptmass,time) + ! Need to recompute the force when sink or stars are created + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& + fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,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) + endif endif endif ! diff --git a/src/main/part.F90 b/src/main/part.F90 index 70988bbcd..9f14cb966 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -206,7 +206,7 @@ module part integer, parameter :: iJ2 = 19 ! 2nd gravity moment due to oblateness integer, parameter :: irstrom = 20 ! Stromgren radius of the stars (icreate_sinks == 2) integer, parameter :: irateion = 21 ! overlapped energy between two HII regions (icreate_sinks == 2) - integer, parameter :: itbirth = 22 + integer, parameter :: itbirth = 22 ! birth time of the new sink integer, parameter :: ndptmass = 13 ! number of properties to conserve after a accretion phase or merge integer, allocatable :: linklist_ptmass(:) real, allocatable :: xyzmh_ptmass(:,:) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 9632d3a0f..11940de2e 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -61,6 +61,8 @@ module ptmass ! settings affecting routines in module (read from/written to input file) integer, public :: icreate_sinks = 0 ! 1-standard sink creation scheme 2-Star formation scheme using core prescription integer, public :: iseed_sf = 313 ! seed used to sample random value for icreate == 2 prescription... + integer, public :: ipart_createstars = 0 ! particle id that needs to create stars after reaching tmax_acc + integer, public :: ipart_createseeds = 0 ! particle id that needs to create seeds after reaching tseeds real, public :: rho_crit_cgs = 1.e-10 real, public :: r_crit = 5.e-3 real, public :: h_acc = 1.e-3 @@ -775,7 +777,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & dptmass,time,facc,nbinmax,ibin_wakei,nfaili) !$ use omputils, only:ipart_omp_lock - use part, only: ihacc,itbirth,ndptmass + use part, only: ihacc,itbirth,ndptmass,linklist_ptmass use kernel, only: radkern2 use io, only: iprint,iverbose,fatal use io_summary, only: iosum_ptmass,maxisink,print_acc @@ -793,7 +795,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & real :: dx,dy,dz,r2,dvx,dvy,dvz,v2,hacc logical, parameter :: iofailreason=.false. integer :: j - real :: mpt,age,drdv,angmom2,angmomh2,epart,dxj,dyj,dzj,dvxj,dvyj,dvzj,rj2,vj2,epartj + real :: mpt,tbirthi,drdv,angmom2,angmomh2,epart,dxj,dyj,dzj,dvxj,dvyj,dvzj,rj2,vj2,epartj logical :: mostbound !$ external :: omp_set_lock,omp_unset_lock @@ -811,9 +813,18 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & sinkloop : do i=is,nptmass hacc = xyzmh_ptmass(ihacc,i) mpt = xyzmh_ptmass(4,i) - age = xyzmh_ptmass(itbirth,i) + tbirthi = xyzmh_ptmass(itbirth,i) if (mpt < 0.) cycle - if (age + tmax_acc < time) cycle + if(icreate_sinks==2) then + if (hacc < h_acc ) cycle + if (tbirthi + tmax_acc < time) then + if(ipart_createstars == 0) ipart_createstars = i + cycle + endif + if (tbirthi + tseeds < time .and. linklist_ptmass(i) /= -1) then + if(ipart_createstars == 0) ipart_createseeds = i + endif + endif dx = xi - xyzmh_ptmass(1,i) dy = yi - xyzmh_ptmass(2,i) dz = zi - xyzmh_ptmass(3,i) @@ -1600,43 +1611,42 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote end subroutine ptmass_create -subroutine ptmass_create_seeds(nptmass,xyzmh_ptmass,linklist_ptmass,time) +subroutine ptmass_create_seeds(nptmass,itest,xyzmh_ptmass,linklist_ptmass,time) use part, only:itbirth,ihacc use random, only:ran2 use io, only:iprint integer, intent(inout) :: nptmass + integer, intent(in) :: itest integer, intent(inout) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: time - real :: mi,hi,tbirthi - integer :: i,j,nseed,n + integer :: j,nseed,n ! !-- Draw the number of star seeds in the core ! - do i=1,nptmass - mi = xyzmh_ptmass(4,i) - hi = xyzmh_ptmass(ihacc,i) - tbirthi = xyzmh_ptmass(itbirth,i) - if (linklist_ptmass(i)/=-1 .or. mi < 0 .or. hi=tbirthi+tseeds) then - nseed = floor(5*ran2(iseed_sf))-1 - n = nptmass - linklist_ptmass(i) = n + 1 !! link the core to the seeds - do j=1,nseed - n = n + 1 - xyzmh_ptmass(itbirth,n) = time - xyzmh_ptmass(4,n) = -1. - xyzmh_ptmass(ihacc,n) = -1. - linklist_ptmass(n) = n + 1 !! link this new seed to the next one - enddo - linklist_ptmass(n) = -1 !! null pointer to end the link list - write(iprint,"(a,i3,a,i3)") ' Star formation prescription : creation of :', nseed, ' seeds in sink n° :', i - nptmass = n - endif - enddo + nseed = floor(4*ran2(iseed_sf)) + if(nseed > 0) then + n = nptmass + linklist_ptmass(itest) = n + 1 !! link the core to the seeds + do j=1,nseed-1 + n = n + 1 + xyzmh_ptmass(4,n) = -1. + xyzmh_ptmass(ihacc,n) = -1. + linklist_ptmass(n) = n + 1 !! link this new seed to the next one + enddo + linklist_ptmass(n) = -1 !! null pointer to end the link list + write(iprint,"(a,i3,a,i3)") ' Star formation prescription : creation of :', nseed, ' seeds in sink n° :', itest + nptmass = n + else + write(iprint,"(a,i3,a,i3)") ' Star formation prescription : creation of :', 1, ' seeds in sink n° :', itest + linklist_ptmass(itest) = -2 !! special null pointer to differentiate mono seed to gas clump + endif + + ipart_createseeds = 0 ! reset pointer to zero + end subroutine ptmass_create_seeds -subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time,formed) +subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time) use dim, only:maxptmass use physcon, only:solarm,pi use io, only:iprint,iverbose @@ -1644,103 +1654,97 @@ subroutine ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz use part, only:itbirth,ihacc,ihsoft,ispinx,ispiny,ispinz use random , only:ran2,gauss_random,divide_unit_seg use HIIRegion, only:update_ionrate,iH2R - integer, intent(in) :: nptmass + integer, intent(in) :: nptmass,itest integer, intent(in) :: linklist_ptmass(:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(4,maxptmass),fxyz_ptmass_sinksink(4,maxptmass) real, intent(in) :: time - logical, intent(out) :: formed real, allocatable :: masses(:) real :: xi(3),vi(3) - integer :: i,k,n - real :: tbirthi,mi,hacci,minmass,mcutoff + integer :: k,n,l + real :: mi,hacci,minmass,mcutoff real :: a(8),velk,rk,xk(3),vk(3),rvir - formed = .false. - do i=1,nptmass - mi = xyzmh_ptmass(4,i) - hacci = xyzmh_ptmass(ihacc,i) - tbirthi = xyzmh_ptmass(itbirth,i) - if (mi<0.) cycle - if (time>=tbirthi+tmax_acc .and. hacci==h_acc ) then - formed = .true. - write(iprint,"(a,es18.10)") "ptmass_create_stars : new stars formed at : ",time - !! save xcom and vcom before placing stars - xi(1) = xyzmh_ptmass(1,i) - xi(2) = xyzmh_ptmass(2,i) - xi(3) = xyzmh_ptmass(3,i) - vi(1) = vxyz_ptmass(1,i) - vi(2) = vxyz_ptmass(2,i) - vi(3) = vxyz_ptmass(3,i) - - !! masses sampling method - call ptmass_size_lklist(i,n,linklist_ptmass) - allocate(masses(n)) - minmass = 0.08/(mi*(umass/solarm)) - call divide_unit_seg(masses,minmass,n,iseed_sf) - masses = masses*mi - if(iverbose > 1) write(iprint,*) "Mass sharing : ", masses*umass/solarm - - - k=i - do while(k>0) - !! Position and velocity sampling methods - a(:) = 0. - rvir = 0.7*h_acc - mcutoff = 0.55 - ! - !-- Positions - ! - a(1) = ran2(iseed_sf)*mcutoff - rk = rvir/sqrt((a(1)**(-2./3.)-1.0)) - a(2) = ran2(iseed_sf) - a(3) = ran2(iseed_sf) - xk(3) = (1.0-2.0*a(2))*rk - xk(2) = sqrt(rk**2-xk(3)**2)*sin(2*pi*a(3)) - xk(1) = sqrt(rk**2-xk(3)**2)*cos(2*pi*a(3)) - ! - !-- Velocities - ! - a(5) = 1. - do while(0.1*a(5)> a(6)) - a(4) = ran2(iseed_sf) - a(5) = ran2(iseed_sf) - a(6) = a(4)**2*(1.0 - a(4)**2)**3.5 - enddo - - velk = a(4)*sqrt(2.0)*(1.0 + rk**2)**(-0.25)*sqrt(2.0*mi/rvir) - a(7) = ran2(iseed_sf) - a(8) = ran2(iseed_sf) - vk(3) = (1.0-2.0*a(7))*velk - vk(2) = sqrt(velk**2-vk(3)**2)*sin(2*pi*a(8)) - vk(1) = sqrt(velk**2-vk(3)**2)*cos(2*pi*a(8)) - ! - !-- Star creation - ! - xyzmh_ptmass(ihacc,k) = hacci*1.e-3 - xyzmh_ptmass(ihsoft,k) = h_soft_sinkgas - xyzmh_ptmass(4,k) = masses(n) - xyzmh_ptmass(3,k) = xi(3) + xk(3) - xyzmh_ptmass(2,k) = xi(2) + xk(2) - xyzmh_ptmass(1,k) = xi(1) + xk(1) - xyzmh_ptmass(ispinx,k) = 0. ! - xyzmh_ptmass(ispiny,k) = 0. ! -- No spin for the instant - xyzmh_ptmass(ispinz,k) = 0. ! - vxyz_ptmass(1,k) = vi(1) + vk(1) - vxyz_ptmass(2,k) = vi(2) + vk(2) - vxyz_ptmass(3,k) = vi(3) + vk(3) - fxyz_ptmass(1:4,k) = 0. - fxyz_ptmass_sinksink(1:4,k) = 0. - if (iH2R > 0) call update_ionrate(k,xyzmh_ptmass,h_acc) - - k = linklist_ptmass(k) ! acces to the next point mass in the linked list - n = n - 1 - enddo - deallocate(masses) - endif + write(iprint,"(a,es18.10)") "ptmass_create_stars : new stars formed at : ",time + !! save xcom and vcom before placing stars + xi(1) = xyzmh_ptmass(1,itest) + xi(2) = xyzmh_ptmass(2,itest) + xi(3) = xyzmh_ptmass(3,itest) + mi = xyzmh_ptmass(4,itest) + hacci = xyzmh_ptmass(ihacc,itest) + vi(1) = vxyz_ptmass(1,itest) + vi(2) = vxyz_ptmass(2,itest) + vi(3) = vxyz_ptmass(3,itest) + + !! masses sampling method + call ptmass_endsize_lklist(itest,l,n,linklist_ptmass) + allocate(masses(n)) + minmass = 0.08/(mi*(umass/solarm)) + call divide_unit_seg(masses,minmass,n,iseed_sf) + masses = masses*mi + if(iverbose > 1) write(iprint,*) "Mass sharing : ", masses*umass/solarm + + + k=itest + do while(k>0) + !! Position and velocity sampling methods + a(:) = 0. + rvir = 0.7*h_acc + mcutoff = 0.55 + ! + !-- Positions + ! + a(1) = ran2(iseed_sf)*mcutoff + rk = rvir/sqrt((a(1)**(-2./3.)-1.0)) + a(2) = ran2(iseed_sf) + a(3) = ran2(iseed_sf) + xk(3) = (1.0-2.0*a(2))*rk + xk(2) = sqrt(rk**2-xk(3)**2)*sin(2*pi*a(3)) + xk(1) = sqrt(rk**2-xk(3)**2)*cos(2*pi*a(3)) + ! + !-- Velocities + ! + a(5) = 1. + do while(0.1*a(5)> a(6)) + a(4) = ran2(iseed_sf) + a(5) = ran2(iseed_sf) + a(6) = a(4)**2*(1.0 - a(4)**2)**3.5 + enddo + + velk = a(4)*sqrt(2.0)*(1.0 + rk**2)**(-0.25)*sqrt(2.0*mi/rvir) + a(7) = ran2(iseed_sf) + a(8) = ran2(iseed_sf) + vk(3) = (1.0-2.0*a(7))*velk + vk(2) = sqrt(velk**2-vk(3)**2)*sin(2*pi*a(8)) + vk(1) = sqrt(velk**2-vk(3)**2)*cos(2*pi*a(8)) + ! + !-- Star creation + ! + xyzmh_ptmass(ihacc,k) = hacci*1.e-3 + xyzmh_ptmass(ihsoft,k) = h_soft_sinkgas + xyzmh_ptmass(4,k) = masses(n) + xyzmh_ptmass(3,k) = xi(3) + xk(3) + xyzmh_ptmass(2,k) = xi(2) + xk(2) + xyzmh_ptmass(1,k) = xi(1) + xk(1) + xyzmh_ptmass(ispinx,k) = 0. ! + xyzmh_ptmass(ispiny,k) = 0. ! -- No spin for the instant + xyzmh_ptmass(ispinz,k) = 0. ! + vxyz_ptmass(1,k) = vi(1) + vk(1) + vxyz_ptmass(2,k) = vi(2) + vk(2) + vxyz_ptmass(3,k) = vi(3) + vk(3) + fxyz_ptmass(1:4,k) = 0. + fxyz_ptmass_sinksink(1:4,k) = 0. + if (iH2R > 0) call update_ionrate(k,xyzmh_ptmass,h_acc) + + k = linklist_ptmass(k) ! acces to the next point mass in the linked list + n = n - 1 enddo + deallocate(masses) + ipart_createstars = 0 ! reset pointer to zero + + end subroutine ptmass_create_stars !----------------------------------------------------------------------- @@ -1774,7 +1778,7 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklis integer, intent(inout) :: linklist_ptmass(nptmass) real, intent(inout) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: vxyz_ptmass(3,nptmass),fxyz_ptmass(4,nptmass) - integer :: i,j,k,l + integer :: i,j,k,l,n real :: rr2,xi,yi,zi,mi,vxi,vyi,vzi,xj,yj,zj,mj,vxj,vyj,vzj,Epot,Ekin real :: mij,mij1,tbirthi,tbirthj logical :: lmerge @@ -1846,8 +1850,8 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklis xyzmh_ptmass(ihacc,j) = -1. if (icreate_sinks == 2) then ! Connect linked list of the merged sink to the survivor - call ptmass_end_lklist(k,l,linklist_ptmass) - linklist_ptmass(l) = j + call ptmass_endsize_lklist(k,l,n,linklist_ptmass) + if(.not.(linklist_ptmass(l)/=-1 .and. n == 1)) linklist_ptmass(l) = j endif ! print success write(iprint,"(/,1x,3a,I8,a,I8,a,F10.4)") 'merge_sinks: ',typ,' merged sinks ',k,' & ',j,' at time = ',time @@ -1864,31 +1868,21 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklis end subroutine merge_sinks -subroutine ptmass_end_lklist(i,k,linklist_ptmass) +subroutine ptmass_endsize_lklist(i,k,n,linklist_ptmass) integer, intent(in) :: linklist_ptmass(:) integer, intent(in) :: i - integer, intent(out) :: k + integer, intent(out) :: k,n integer :: l,g g=i + n = 0 do while (g>0) l = g g = linklist_ptmass(l) + n = n + 1 enddo k=l -end subroutine ptmass_end_lklist +end subroutine ptmass_endsize_lklist -subroutine ptmass_size_lklist(i,n,linklist_ptmass) - integer, intent(in) :: linklist_ptmass(:) - integer, intent(in) :: i - integer, intent(out) :: n - integer :: l - l=i - n = 0 - do while (l>0) - l = linklist_ptmass(l) - n = n + 1 - enddo -end subroutine ptmass_size_lklist subroutine set_integration_precision diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index 54732c7c3..d20d793b2 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -465,7 +465,7 @@ subroutine parqsort(n, arr,func, indx) use omp_lib,only:omp_get_num_threads implicit none integer, parameter :: m=8, nstack=500 - integer(kind=8), intent(in) :: n + integer, intent(in) :: n real, intent(in) :: arr(n) integer, intent(inout) :: indx(n) real, external :: func From 59f1db6b8e4ead878adf6718cff2eb75998a3911 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 28 Jun 2024 16:05:51 +0200 Subject: [PATCH 664/814] (HIIRegion) new adiab equation + cooling for HII feedback --- src/main/eos.f90 | 11 +++++--- src/main/eos_HIIR.f90 | 56 ++++++++++++++++++++++++++++++++++---- src/main/initial.F90 | 4 ++- src/main/step_leapfrog.F90 | 4 +-- src/main/substepping.F90 | 20 +++++++++----- 5 files changed, 76 insertions(+), 19 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index df5ea8115..6d3094f1b 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -49,7 +49,7 @@ module eos use part, only:ien_etotal,ien_entropy,ien_type use dim, only:gr implicit none - integer, parameter, public :: maxeos = 21 + integer, parameter, public :: maxeos = 22 real, public :: polyk, polyk2, gamma real, public :: qfacdisc = 0.75, qfacdisc2 = 0.75 logical, public :: extract_eos_from_hdr = .false. @@ -116,7 +116,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam use eos_stratified, only:get_eos_stratified use eos_barotropic, only:get_eos_barotropic use eos_piecewise, only:get_eos_piecewise - use eos_HIIR, only:get_eos_HIIR + use eos_HIIR, only:get_eos_HIIR_iso,get_eos_HIIR_adiab integer, intent(in) :: eos_type real, intent(in) :: rhoi,xi,yi,zi real, intent(out) :: ponrhoi,spsoundi @@ -429,7 +429,10 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam if (present(gamma_local)) gamma_local = gammai case(21) - call get_eos_HIIR(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) + call get_eos_HIIR_iso(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) + case(22) + + call get_eos_HIIR_adiab(polyk,temperature_coef,mui,tempi,ponrhoi,rhoi,eni,gammai,spsoundi,isionisedi) @@ -535,7 +538,7 @@ subroutine init_eos(eos_type,ierr) ierr = ierr_option_conflict endif - case(21) + case(21,22) call init_eos_HIIR() diff --git a/src/main/eos_HIIR.f90 b/src/main/eos_HIIR.f90 index 279c29e1d..1f836ed44 100644 --- a/src/main/eos_HIIR.f90 +++ b/src/main/eos_HIIR.f90 @@ -18,7 +18,7 @@ module eos_HIIR ! implicit none - public :: get_eos_HIIR,init_eos_HIIR + public :: get_eos_HIIR_iso,get_eos_HIIR_adiab,init_eos_HIIR real, parameter :: Tion = 10000. real, parameter :: muioninv = 2. @@ -48,10 +48,10 @@ end subroutine init_eos_HIIR !----------------------------------------------------------------------- !+ - ! Main eos routine + ! Main eos routine (isothermal) !+ !----------------------------------------------------------------------- -subroutine get_eos_HIIR(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) +subroutine get_eos_HIIR_iso(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) real, intent(in) :: polyk,temperature_coef real, intent(out) :: ponrhoi,spsoundi,mui,tempi logical, intent(in) :: isionisedi @@ -66,7 +66,7 @@ subroutine get_eos_HIIR(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isioni if(isionisedi) then ponrhoi = polykion spsoundi = sqrt(ponrhoi) - tempi = temperature_coef*muion*ponrhoi + tempi = Tion else ponrhoi = polyk spsoundi = sqrt(ponrhoi) @@ -74,7 +74,53 @@ subroutine get_eos_HIIR(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isioni endif -end subroutine get_eos_HIIR +end subroutine get_eos_HIIR_iso + + + !----------------------------------------------------------------------- + !+ + ! Main eos routine (adiabatic) + !+ + !----------------------------------------------------------------------- +subroutine get_eos_HIIR_adiab(polyk,temperature_coef,mui,tempi,ponrhoi,rhoi,eni,gammai,spsoundi,isionisedi) + use io, only:fatal + real, intent(in) :: polyk,temperature_coef,rhoi,gammai + real, intent(out) :: ponrhoi,spsoundi,mui,tempi + real, intent(in), optional :: eni + + logical, intent(in) :: isionisedi + + + if (gammai < tiny(gammai)) call fatal('eos','gamma not set for adiabatic eos',var='gamma',val=gammai) + + + if(isionisedi) then + ponrhoi = polykion + spsoundi = sqrt(ponrhoi) + tempi = Tion + else + if (present(eni)) then + if (eni < 0.) then + !write(iprint,'(a,Es18.4,a,4Es18.4)')'Warning: eos: u = ',eni,' < 0 at {x,y,z,rho} = ',xi,yi,zi,rhoi + call fatal('eos','utherm < 0',var='u',val=eni) + endif + if (gammai > 1.0001) then + ponrhoi = (gammai-1.)*eni ! use this if en is thermal energy + else + ponrhoi = 2./3.*eni ! en is thermal energy and gamma = 1 + endif + else + ponrhoi = polyk*rhoi**(gammai-1.) + endif + spsoundi = sqrt(gammai*ponrhoi) + + tempi = temperature_coef*mui*ponrhoi + endif + + +end subroutine get_eos_HIIR_adiab + + end module eos_HIIR diff --git a/src/main/initial.F90 b/src/main/initial.F90 index a958074cc..79d8379d6 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -131,7 +131,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& nden_nimhd,dustevol,rhoh,gradh, & Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx, & - n_group,n_ingroup,n_sing,nmatrix,group_info + n_group,n_ingroup,n_sing,nmatrix,group_info,isionised use part, only:pxyzu,dens,metrics,rad,radprop,drad,ithick use densityforce, only:densityiterate use linklist, only:set_linklist @@ -499,6 +499,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif if (iH2R > 0 .and. id==master) then call initialize_H2R + else + isionised = .false. endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 4aa06ab7b..14f8baa04 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -98,7 +98,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) iamboundary,get_ntypes,npartoftypetot,& dustfrac,dustevol,ddustevol,eos_vars,alphaind,nptmass,& dustprop,ddustprop,dustproppred,pxyzu,dens,metrics,ics,& - filfac,filfacpred,mprev,filfacprev + filfac,filfacpred,mprev,filfacprev,isionised use options, only:avdecayconst,alpha,ieos,alphamax use deriv, only:derivs use timestep, only:dterr,bignumber,tolv @@ -252,7 +252,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) 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, & - group_info,nmatrix,n_group,n_ingroup,n_sing) + group_info,nmatrix,n_group,n_ingroup,n_sing,isionised) else call substep_sph(dtsph,npart,xyzh,vxyzu) endif diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index fdde4210d..8219e33a2 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -428,7 +428,7 @@ end subroutine substep_sph subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & linklist_ptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info, & - nmatrix,n_group,n_ingroup,n_sing) + nmatrix,n_group,n_ingroup,n_sing,isionised) use io, only:iverbose,id,master,iprint,fatal use options, only:iexternalforce use part, only:fxyz_ptmass_sinksink,ndptmass @@ -447,6 +447,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & integer(kind=1), intent(in) :: nbinmax integer , intent(inout) :: linklist_ptmass(:) integer(kind=1), intent(inout) :: ibin_wake(:),nmatrix(nptmass,nptmass) + logical, intent(in) :: isionised(:) logical :: extf_vdep_flag,done,last_step,accreted integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step @@ -515,7 +516,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass, & - group_info=group_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,& @@ -525,7 +526,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & 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) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass,& + isionised=isionised) ! the last kick phase of the scheme will perform the accretion loop after velocity update endif @@ -823,7 +825,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,fsink_old,group_info) + force_count,extf_vdep_flag,linklist_ptmass,fsink_old,group_info,& + isionised) use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & @@ -849,6 +852,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, logical, intent(in) :: extf_vdep_flag 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 integer :: i,itype @@ -961,7 +965,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$omp shared(dkdt,dt,timei,iexternalforce,extf_vdep_flag,last) & !$omp shared(divcurlv,dphotflag,dphot0,nucleation,extrap) & !$omp shared(abundc,abundo,abundsi,abunde,extrapfac,fsink_old) & - !$omp shared(isink_radiation,itau_alloc,tau) & + !$omp shared(isink_radiation,itau_alloc,tau,isionised) & !$omp private(fextx,fexty,fextz,xi,yi,zi) & !$omp private(i,fonrmaxi,dtphi2i,phii,dtf) & !$omp firstprivate(pmassi,itype) & @@ -1044,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) + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,isionised(i)) endif endif enddo @@ -1086,7 +1090,7 @@ end subroutine get_force !+ !------------------------------------------------------------------------------------ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & - divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0) + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,isionisedi) use dim, only:h2chemistry,do_nucleation,use_krome,update_muGamma,store_dust_temperature use part, only:idK2,idmu,idkappa,idgamma,imu,igamma,nabundances use cooling_ism, only:nabn,dphotflag @@ -1107,6 +1111,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl real, intent(inout) :: abundc,abunde,abundo,abundsi real(kind=8), intent(in) :: dphot0 real, intent(in) :: dt,pmassi + logical, intent(in) :: isionisedi integer, intent(in) :: i real :: dudtcool,rhoi,dphot,pH,pH_tot @@ -1169,6 +1174,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl endif #endif ! update internal energy + if (isionisedi) dudtcool = 0. if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool From 5b195ebfa457f99464f69ab7aa643b2a11d5ac00 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 1 Jul 2024 10:15:08 +0200 Subject: [PATCH 665/814] (setup_binary) fix bug with co-rotating frame not set correctly --- src/setup/setup_binary.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 405759790..0b6c87bd5 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -122,7 +122,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& rhozero,npart_total,i_belong,ierr) nptmass_in = 0 - if (iexternalforce==iext_corotate) then + 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) add_spin = .false. From 1894665757a64ca59ff81ef38c3e2628ea7ed92c Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 1 Jul 2024 10:59:33 +0200 Subject: [PATCH 666/814] (ptmass) pass linklist_ptmass via the interface in ptmass_accrete --- src/main/ptmass.F90 | 7 ++++--- src/main/substepping.F90 | 25 ++++++++++++++++--------- src/tests/test_ptmass.f90 | 5 +++-- 3 files changed, 23 insertions(+), 14 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 11940de2e..2cb6007df 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -774,10 +774,10 @@ end function ptmass_not_obscured !---------------------------------------------------------------- subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & itypei,pmassi,xyzmh_ptmass,vxyz_ptmass,accreted, & - dptmass,time,facc,nbinmax,ibin_wakei,nfaili) + dptmass,linklist_ptmass,time,facc,nbinmax,ibin_wakei,nfaili) !$ use omputils, only:ipart_omp_lock - use part, only: ihacc,itbirth,ndptmass,linklist_ptmass + use part, only: ihacc,itbirth,ndptmass use kernel, only: radkern2 use io, only: iprint,iverbose,fatal use io_summary, only: iosum_ptmass,maxisink,print_acc @@ -786,6 +786,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & real, intent(inout) :: hi real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(in) :: vxyz_ptmass(3,nptmass) + integer, intent(in) :: linklist_ptmass(nptmass) logical, intent(out) :: accreted real, intent(inout) :: dptmass(ndptmass,nptmass) integer(kind=1), intent(in) :: nbinmax @@ -1562,7 +1563,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote call ptmass_accrete(new_nptmass,new_nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),& vxyzu(1,j),vxyzu(2,j),vxyzu(3,j),fxj,fyj,fzj, & itypej,pmassj,xyzmh_ptmass,vxyz_ptmass,accreted, & - dptmass,time,f_acc_local,ibin_wakei,ibin_wakei) + dptmass,linklist_ptmass,time,f_acc_local,ibin_wakei,ibin_wakei) if (accreted) nacc = nacc + 1 enddo diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 8219e33a2..348d86e06 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -484,7 +484,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! ! Main integration scheme ! - call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) + call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & + fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass) if (use_regnbody) then call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) @@ -508,7 +509,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass, & fsink_old,group_info) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass) call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) @@ -521,7 +523,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,& fsink_old) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass) call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) @@ -532,7 +535,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & endif call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass,ibin_wake,nbinmax,timei, & + fxyz_ptmass_sinksink,accreted) if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) @@ -546,7 +550,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & else !! standard leapfrog scheme ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass,ibin_wake,nbinmax,timei, & + fxyz_ptmass_sinksink,accreted) 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) @@ -637,7 +642,8 @@ end subroutine drift !---------------------------------------------------------------- subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & - fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass,ibin_wake, & + nbinmax,timei,fxyz_ptmass_sinksink,accreted) use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas,ndptmass use ptmass, only:f_acc,ptmass_accrete,pt_write_sinkev,update_ptmass,ptmass_kick use externalforces, only:accrete_particles @@ -653,6 +659,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, real, intent(inout) :: vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) real, intent(inout) :: dptmass(ndptmass,nptmass) + integer, intent(in) :: linklist_ptmass(:) real, optional, intent(inout) :: fxyz_ptmass_sinksink(:,:) real, optional, intent(in) :: timei integer(kind=1), optional, intent(inout) :: ibin_wake(:) @@ -719,7 +726,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,linklist_ptmass,f_acc) & !$omp shared(iexternalforce) & !$omp shared(nbinmax,ibin_wake) & !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & @@ -762,8 +769,8 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxi,fyi,fzi,& - itype,pmassi,xyzmh_ptmass,vxyz_ptmass,& - accreted,dptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) + itype,pmassi,xyzmh_ptmass,vxyz_ptmass,accreted, & + dptmass,linklist_ptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) if (accreted) then naccreted = naccreted + 1 cycle accreteloop diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 2831d8315..a3c822d77 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -627,7 +627,8 @@ subroutine test_accretion(ntests,npass,itest) use io, only:id,master use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,massoftype, & npart,npartoftype,xyzh,vxyzu,fxyzu,igas,ihacc,& - isdead_or_accreted,set_particle_type,ndptmass,hfact + isdead_or_accreted,set_particle_type,ndptmass,hfact,& + linklist_ptmass use ptmass, only:ptmass_accrete,update_ptmass use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi @@ -707,7 +708,7 @@ subroutine test_accretion(ntests,npass,itest) call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxyzu(1,i),fxyzu(2,i),fxyzu(3,i), & igas,massoftype(igas),xyzmh_ptmass,vxyz_ptmass, & - accreted,dptmass_thread,t,1.0,ibin_wakei,ibin_wakei) + accreted,dptmass_thread,linklist_ptmass,t,1.0,ibin_wakei,ibin_wakei) endif enddo !$omp enddo From 12367c0b8866ad34ab8c5b0ab44dfaaba1437a49 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 1 Jul 2024 11:45:31 +0100 Subject: [PATCH 667/814] Improve error handling in radapprox cooling --- src/main/cooling_radapprox.f90 | 16 ++++++++-------- src/main/eos_stamatellos.f90 | 12 ++++++------ 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index 8582e570b..4b14a0641 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -94,7 +94,8 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) !$omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot) & !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb) overpart: do i=1,npart -! if (.not. iactive(iphase(i)) .or. isdead_or_accreted(xyzh(4,i))) cycle +! if (.not. iactive(iphase(i)) ) cycle + if (isdead_or_accreted(xyzh(4,i)) ) cycle poti = Gpot_cool(i) du_FLDi = duFLD(i) ui = energ(i) @@ -106,7 +107,7 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) + (xyzh(2,i)-xyzmh_ptmass(2,isink_star))**2d0 & + (xyzh(3,i)-xyzmh_ptmass(3,isink_star))**2d0 endif - if (rhoi*unit_density > 1d0) print *, "rhoi > 1.", rhoi,i,sqrt(ri2) + ! get opacities & Ti for ui call getopac_opdep(ui*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,& Ti,gmwi) @@ -162,7 +163,6 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) opac_store(i) = opaci dudti_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/opaci/unit_ergg*utime! code units -! if (mod(i,100) == 0) print *, "dudt_sph", dudt_sph(i) if (doFLD) then Teqi = (du_FLDi + dudt_sph(i)) *opaci*unit_ergg/utime ! physical units du_tot = dudt_sph(i) + dudti_rad + du_FLDi @@ -180,11 +180,11 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) endif teqi_store(i) = Teqi - if (Teqi > 1e6) 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 * dt=", dudt_sph(i)*dt - endif +! if (Teqi > 1e6) 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 * dt=", dudt_sph(i)*dt +! endif call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) ueqi = ueqi/unit_ergg diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index 5b60a7a86..59c9449a9 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -99,7 +99,7 @@ end subroutine read_optab ! Main subroutine for interpolating tables to get EOS values ! subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) - use io, only:warning + use io, only:fatal real, intent(in) :: ui,rhoi real, intent(out) :: kappaBar,kappaPart,Ti,gmwi @@ -117,9 +117,9 @@ 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 - call warning('getopac_opdep','rhoi out of range',var='rhoi',val=rhoi) + 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 warning('getopac_opdep','ui out of range',var='ui',val=ui) + call fatal('getopac_opdep','ui out of range',var='ui',val=ui) endif if (rhoi < rhomin) then @@ -211,7 +211,7 @@ subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) end subroutine getopac_opdep subroutine getintenerg_opdep(Teqi, rhoi, ueqi) - use io, only:warning + use io, only:fatal real, intent(out) :: ueqi real, intent(in) :: Teqi,rhoi @@ -221,9 +221,9 @@ subroutine getintenerg_opdep(Teqi, rhoi, ueqi) real rhoi_ if (rhoi > OPTABLE(nx,1,1) .or. rhoi < OPTABLE(1,1,1)) then - call warning('getintenerg_opdep','rhoi out of range',var='rhoi',val=rhoi) + call fatal('getintenerg_opdep','rhoi out of range',var='rhoi',val=rhoi) elseif (Teqi > OPTABLE(1,ny,2) .or. Teqi < OPTABLE(1,1,2)) then - call warning('getintenerg_opdep','Ti out of range',var='Ti',val=Teqi) + call fatal('getintenerg_opdep','Ti out of range',var='Ti',val=Teqi) endif From 0ffc64611dcce48e0cced9076a450ecf7521dce0 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 1 Jul 2024 15:35:29 +0200 Subject: [PATCH 668/814] (ptmass) fix a doubled contribution of the vdep force correction... --- src/main/ptmass.F90 | 17 ++++++++++------- src/main/substepping.F90 | 8 ++++---- 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 65dab95a1..6b58bb700 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -658,25 +658,28 @@ subroutine ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyz real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: fxyz_ptmass(4,nptmass) integer, intent(in) :: iexternalforce - real :: fxi,fyi,fzi,fextv(3) + real :: fxi,fyi,fzi,vxhalfi,vyhalfi,vzhalfi,fextv(3) integer :: i !$omp parallel do schedule(static) default(none) & !$omp shared(vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dkdt,nptmass,iexternalforce) & - !$omp private(fxi,fyi,fzi,fextv) & + !$omp private(vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi,fextv) & !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then + vxhalfi = vxyz_ptmass(1,i) + vyhalfi = vxyz_ptmass(2,i) + vzhalfi = vxyz_ptmass(3,i) fxi = fxyz_ptmass(1,i) fyi = fxyz_ptmass(2,i) fzi = fxyz_ptmass(3,i) call update_vdependent_extforce(iexternalforce,& - vxyz_ptmass(1,i),vxyz_ptmass(2,i),vxyz_ptmass(3,i), & - fxi,fyi,fzi,fextv,dkdt,xyzmh_ptmass(1,i),xyzmh_ptmass(2,i), & + vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi,fextv,dkdt, & + xyzmh_ptmass(1,i),xyzmh_ptmass(2,i), & xyzmh_ptmass(3,i)) - fxyz_ptmass(1,i) = fxi + fextv(1) - fxyz_ptmass(2,i) = fyi + fextv(2) - fxyz_ptmass(3,i) = fzi + fextv(3) + fxyz_ptmass(1,i) = fxi + fxyz_ptmass(2,i) = fyi + fxyz_ptmass(3,i) = fzi endif enddo !$omp end parallel do diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 5a7d90734..4d5434c38 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -917,10 +917,10 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) @@ -928,10 +928,10 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass endif endif else From bb8d32b32828017f37d45676bb411c4d6cd793f7 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 1 Jul 2024 16:44:56 +0200 Subject: [PATCH 669/814] (substep) match sizes of array to avoid corruption during copy... --- src/main/substepping.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 4d5434c38..d00f9624a 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -919,8 +919,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass + fxyz_ptmass_sinksink(1:4,1:nptmass)=fxyz_ptmass + dsdt_ptmass_sinksink(1:3,1:nptmass)=dsdt_ptmass else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) @@ -930,8 +930,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass + fxyz_ptmass_sinksink(1:4,1:nptmass)=fxyz_ptmass + dsdt_ptmass_sinksink(1:3,1:nptmass)=dsdt_ptmass endif endif else From 74709ba671ea7be6d4adf939c2ab0540dd430d14 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 1 Jul 2024 16:56:34 +0200 Subject: [PATCH 670/814] minor compilation fix --- src/main/evolve.F90 | 1 - src/setup/setup_cluster.f90 | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 5a900ee9d..8ca0c2623 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -141,7 +141,6 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) logical :: should_conserve_energy,should_conserve_momentum,should_conserve_angmom logical :: should_conserve_dustmass logical :: use_global_dt - logical :: star_formed integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold character(len=120) :: dumpfile_orig integer :: dummy diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index f1707e1e9..cd166a1a5 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -56,7 +56,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use timestep, only:dtmax,tmax use centreofmass, only:reset_centreofmass use ptmass, only:h_acc,r_crit,rho_crit_cgs,icreate_sinks,tmax_acc,h_soft_sinkgas, & - r_merge_uncond,use_regnbody,f_crit_override + r_merge_uncond,use_regnbody,f_crit_override,tseeds use datafiles, only:find_phantom_datafile use eos, only:ieos,gmw use kernel, only:hfact_default From 71e4c9831aefa0ad038980154b2389909a97f47f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 2 Jul 2024 10:50:17 +0200 Subject: [PATCH 671/814] (ptmass) change state of the null pointer before seed creation --- src/main/evolve.F90 | 2 +- src/main/ptmass.F90 | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 8ca0c2623..6a67f1b54 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -307,7 +307,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! creation of new stars from sinks (cores) ! if(ipart_createstars /= 0) then - call ptmass_create_stars(nptmass,ipart_createseeds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink, & + call ptmass_create_stars(nptmass,ipart_createstars,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink, & linklist_ptmass,time) ! Need to recompute the force when sink or stars are created if (use_regnbody) then diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 2cb6007df..e3151c824 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -822,7 +822,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & if(ipart_createstars == 0) ipart_createstars = i cycle endif - if (tbirthi + tseeds < time .and. linklist_ptmass(i) /= -1) then + if (tbirthi + tseeds < time .and. linklist_ptmass(i) == 0) then if(ipart_createstars == 0) ipart_createseeds = i endif endif @@ -1585,7 +1585,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote nptmass = new_nptmass ! link the new sink to nothing (waiting for age > tseeds) if (icreate_sinks == 2) then - linklist_ptmass(nptmass) = -1 + linklist_ptmass(nptmass) = 0 endif ! ! open new file to track new sink particle details & and update all sink-tracking files; @@ -1640,7 +1640,7 @@ subroutine ptmass_create_seeds(nptmass,itest,xyzmh_ptmass,linklist_ptmass,time) nptmass = n else write(iprint,"(a,i3,a,i3)") ' Star formation prescription : creation of :', 1, ' seeds in sink n° :', itest - linklist_ptmass(itest) = -2 !! special null pointer to differentiate mono seed to gas clump + linklist_ptmass(itest) = -1 !! null pointer to differentiate mono seed to gas clump endif ipart_createseeds = 0 ! reset pointer to zero From 7da8bbebf8c82a25f23cb7d549c6e6617e127b0e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 2 Jul 2024 14:25:22 +0200 Subject: [PATCH 672/814] (ptmass) debug new create stars implementation --- src/main/evolve.F90 | 31 ++++++++++++++----------------- src/main/ptmass.F90 | 28 ++++++++++++++-------------- 2 files changed, 28 insertions(+), 31 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 6a67f1b54..3b05c8d90 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -286,14 +286,6 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! 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) - - if(isdead_or_accreted(xyzh(4,ipart_rhomax))) then - if (use_regnbody) then - call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& - fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,group_info=group_info) - endif - endif endif if (icreate_sinks == 2) then @@ -309,17 +301,22 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if(ipart_createstars /= 0) then call ptmass_create_stars(nptmass,ipart_createstars,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink, & linklist_ptmass,time) - ! Need to recompute the force when sink or stars are created - if (use_regnbody) then - call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& - fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,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) - endif endif endif + + ! Need to recompute the force when sink or stars are created + if (isdead_or_accreted(xyzh(4,ipart_rhomax)) .or. (ipart_createseeds /= 0) .or. (ipart_createstars /= 0)) then + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& + fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,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) + endif + ipart_createseeds = 0 ! reset pointer to zero + ipart_createstars = 0 ! reset pointer to zero + endif ! ! Strang splitting: implicit update for half step ! diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e3151c824..e50473fdd 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -606,14 +606,14 @@ subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,group_info,n_ingro integer, optional, intent(in) :: n_ingroup integer, optional, intent(in) :: group_info(:,:) integer :: i,k,istart_ptmass - logical :: woutsub + logical :: wsub if (present(n_ingroup)) then istart_ptmass = n_ingroup + 1 - woutsub = .true. + wsub = .true. else istart_ptmass = 1 - woutsub = .false. + wsub = .false. endif !$omp parallel do schedule(static) default(none) & @@ -621,7 +621,7 @@ subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,group_info,n_ingro !$omp shared(n_ingroup,group_info,woutsub,istart_ptmass) & !$omp private(i,k) do k=istart_ptmass,nptmass - if (woutsub) then + if (wsub) then i = group_info(igarg,k) else i = k @@ -816,16 +816,19 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & mpt = xyzmh_ptmass(4,i) tbirthi = xyzmh_ptmass(itbirth,i) if (mpt < 0.) cycle + !$omp single if(icreate_sinks==2) then if (hacc < h_acc ) cycle if (tbirthi + tmax_acc < time) then if(ipart_createstars == 0) ipart_createstars = i cycle endif - if (tbirthi + tseeds < time .and. linklist_ptmass(i) == 0) then - if(ipart_createstars == 0) ipart_createseeds = i + if ((tbirthi + tseeds < time) .and. (linklist_ptmass(i) == 0) .and. & + (ipart_createseeds == 0)) then + ipart_createseeds = i endif endif + !$omp end single dx = xi - xyzmh_ptmass(1,i) dy = yi - xyzmh_ptmass(2,i) dz = zi - xyzmh_ptmass(3,i) @@ -1629,22 +1632,21 @@ subroutine ptmass_create_seeds(nptmass,itest,xyzmh_ptmass,linklist_ptmass,time) if(nseed > 0) then n = nptmass linklist_ptmass(itest) = n + 1 !! link the core to the seeds - do j=1,nseed-1 + do j=1,nseed n = n + 1 - xyzmh_ptmass(4,n) = -1. + xyzmh_ptmass(:,n) = 0. + xyzmh_ptmass(4,n) = -1. xyzmh_ptmass(ihacc,n) = -1. - linklist_ptmass(n) = n + 1 !! link this new seed to the next one + linklist_ptmass(n) = n + 1 !! link this new seed to the next one enddo linklist_ptmass(n) = -1 !! null pointer to end the link list - write(iprint,"(a,i3,a,i3)") ' Star formation prescription : creation of :', nseed, ' seeds in sink n° :', itest + write(iprint,"(a,i3,a,i3)") ' Star formation prescription : creation of :', nseed+1, ' seeds in sink n° :', itest nptmass = n else write(iprint,"(a,i3,a,i3)") ' Star formation prescription : creation of :', 1, ' seeds in sink n° :', itest linklist_ptmass(itest) = -1 !! null pointer to differentiate mono seed to gas clump endif - ipart_createseeds = 0 ! reset pointer to zero - end subroutine ptmass_create_seeds subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time) @@ -1743,8 +1745,6 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas enddo deallocate(masses) - ipart_createstars = 0 ! reset pointer to zero - end subroutine ptmass_create_stars From 201f30937052a189c7ee2536422e8253acc55820 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 2 Jul 2024 14:43:59 +0200 Subject: [PATCH 673/814] (ptmass) linor compilation errors fix --- src/main/ptmass.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e50473fdd..71245670a 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -618,7 +618,7 @@ subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,group_info,n_ingro !$omp parallel do schedule(static) default(none) & !$omp shared(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) & - !$omp shared(n_ingroup,group_info,woutsub,istart_ptmass) & + !$omp shared(n_ingroup,group_info,wsub,istart_ptmass) & !$omp private(i,k) do k=istart_ptmass,nptmass if (wsub) then @@ -816,19 +816,21 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & mpt = xyzmh_ptmass(4,i) tbirthi = xyzmh_ptmass(itbirth,i) if (mpt < 0.) cycle - !$omp single if(icreate_sinks==2) then if (hacc < h_acc ) cycle if (tbirthi + tmax_acc < time) then + !$omp single if(ipart_createstars == 0) ipart_createstars = i + !$omp end single cycle endif if ((tbirthi + tseeds < time) .and. (linklist_ptmass(i) == 0) .and. & (ipart_createseeds == 0)) then + !$omp single ipart_createseeds = i + !$omp end single endif endif - !$omp end single dx = xi - xyzmh_ptmass(1,i) dy = yi - xyzmh_ptmass(2,i) dz = zi - xyzmh_ptmass(3,i) From f809858e12407e2aec87afaa3a0b1d27dfd2c34b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 2 Jul 2024 15:56:11 +0200 Subject: [PATCH 674/814] (HIIRegion) fix wrong conditions that skipped the neighboour search --- src/main/H2regions.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 834a02cc4..f1aeeee96 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -212,16 +212,16 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) zi = xyzmh_ptmass(3,i) stromi = xyzmh_ptmass(irstrom,i) if(stromi >= 0. ) then - hcheck = 1.4*stromi + hcheck = 1.4*stromi + 0.01*Rmax else hcheck = Rmax endif - do while(nneigh < 0 .and. hcheck/=Rmax) - hcheck = hcheck + 0.01*Rmax ! additive term to allow unresolved case to open - if (hcheck > Rmax) hcheck = Rmax + do while(hcheck <= Rmax) call getneigh_pos((/xi,yi,zi/),0.,hcheck,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) call set_r2func_origin(xi,yi,zi) call Knnfunc(nneigh,r2func_origin,xyzh,listneigh) + if (nneigh > 0) exit + hcheck = hcheck + 0.01*Rmax ! additive term to allow unresolved case to open enddo do k=1,nneigh j = listneigh(k) From deb6e5fdc769e2fbc0ac6966eb4abf48fe76b47d Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 2 Jul 2024 15:58:37 +0200 Subject: [PATCH 675/814] (test_ptmass) update HII and star creation tests --- src/tests/test_ptmass.f90 | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index a3c822d77..d11f2bb8f 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -776,7 +776,8 @@ subroutine test_createsink(ntests,npass) dptmass,fxyz_ptmass_sinksink,linklist_ptmass use ptmass, only:ptmass_accrete,update_ptmass,icreate_sinks,& ptmass_create,finish_ptmass,ipart_rhomax,h_acc,rho_crit,rho_crit_cgs, & - ptmass_create_stars,tmax_acc + ptmass_create_stars,tmax_acc,tseeds,ipart_createseeds,ipart_createstars,& + ptmass_create_seeds use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceloc_mpi,reduceall_mpi use spherical, only:set_sphere @@ -786,7 +787,6 @@ subroutine test_createsink(ntests,npass) integer :: id_rhomax,ipart_rhomax_global real :: psep,totmass,r2min,r2,t,coremass,starsmass real :: etotin,angmomin,totmomin,rhomax,rhomax_test - logical :: formed procedure(rho_func), pointer :: density_func density_func => gaussianr @@ -842,6 +842,9 @@ subroutine test_createsink(ntests,npass) icreate_sinks = 2 linklist_ptmass = -1 tmax_acc = 0. + tseeds = 0. + ipart_createseeds = 1 + ipart_createstars = 1 else icreate_sinks = 1 endif @@ -907,11 +910,16 @@ subroutine test_createsink(ntests,npass) if (itest==3) then coremass = 0. starsmass = 0. + xyzmh_ptmass(4,1) = xyzmh_ptmass(4,1)*6e33 coremass = xyzmh_ptmass(4,1) - call ptmass_create_stars(nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,0.,formed) + call ptmass_create_seeds(nptmass,ipart_createseeds,xyzmh_ptmass,linklist_ptmass,0.) + call ptmass_create_stars(nptmass,ipart_createstars,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & + fxyz_ptmass_sinksink,linklist_ptmass,0.) do i=1,nptmass starsmass = starsmass + xyzmh_ptmass(4,i) enddo + xyzmh_ptmass(4,1) = coremass/6e33 + xyzmh_ptmass(4,:) = 0. endif ! ! check that creation succeeded @@ -1143,7 +1151,7 @@ subroutine test_merger(ntests,npass) end subroutine test_merger subroutine test_HIIregion(ntests,npass) - use dim, only:maxp,maxphase + use dim, only:maxp,maxphase,maxvxyzu use io, only:id,master,iverbose,iprint use eos_HIIR, only:polykion,init_eos_HIIR use eos, only:gmw,ieos,polyk,gamma @@ -1166,7 +1174,7 @@ subroutine test_HIIregion(ntests,npass) real :: totmass,psep real :: Rstrom,ci,k,rho0 real :: totvol,nx,rmin,rmax,temp - if (id==master) write(*,"(/,a)") '--> testing HII region expansion around massive stars...' + if (id==master) write(iprint,"(/,a)") '--> testing HII region expansion around massive stars...' call set_units(dist=pc,mass=solarm,G=1.d0) call init_eos_HIIR() @@ -1182,7 +1190,7 @@ subroutine test_HIIregion(ntests,npass) h_acc = 0.002 - xyzmh_ptmass(4,1) = -1 + xyzmh_ptmass(4,1) = -1. xyzmh_ptmass(irateion,1) = (10.**49.)*utime ! rate_ion [s^-1] nptmass = 1 nHIIsources = 1 @@ -1233,12 +1241,17 @@ subroutine test_HIIregion(ntests,npass) rho0 = totmass/totvol Rstrom = ((3*xyzmh_ptmass(irateion,1)*mH**2)/(4*pi*ar*rho0**2))**(1./3.) + xyzmh_ptmass(irstrom,1) = -1. ci = sqrt(polykion) k = 0.005 polyk = (kboltz*temp)/(gmw*mass_proton_cgs)*((unit_velocity)**2) vxyzu(:,:) = 0. fxyzu(:,:) = 0. + if (maxvxyzu >= 4) then + vxyzu(4,:) = polyk + ieos = 22 + endif call get_derivs_global() From 816d574008eab0af290f9f90d0f6d2a5515174cb Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 2 Jul 2024 16:02:17 +0200 Subject: [PATCH 676/814] (ptmass) fix wrong omp flag --- src/main/ptmass.F90 | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 71245670a..6d8c0d40e 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -819,16 +819,16 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & if(icreate_sinks==2) then if (hacc < h_acc ) cycle if (tbirthi + tmax_acc < time) then - !$omp single + !$omp master if(ipart_createstars == 0) ipart_createstars = i - !$omp end single + !$omp end master cycle endif if ((tbirthi + tseeds < time) .and. (linklist_ptmass(i) == 0) .and. & (ipart_createseeds == 0)) then - !$omp single + !$omp master ipart_createseeds = i - !$omp end single + !$omp end master endif endif dx = xi - xyzmh_ptmass(1,i) @@ -1642,10 +1642,12 @@ subroutine ptmass_create_seeds(nptmass,itest,xyzmh_ptmass,linklist_ptmass,time) linklist_ptmass(n) = n + 1 !! link this new seed to the next one enddo linklist_ptmass(n) = -1 !! null pointer to end the link list - write(iprint,"(a,i3,a,i3)") ' Star formation prescription : creation of :', nseed+1, ' seeds in sink n° :', itest + write(iprint,"(a,i3,a,i3,a,es18.10)") ' Star formation prescription : creation of :',& + nseed+1, ' seeds in sink n° :', itest, " t= ",time nptmass = n else - write(iprint,"(a,i3,a,i3)") ' Star formation prescription : creation of :', 1, ' seeds in sink n° :', itest + write(iprint,"(a,i3,a,i3,a,es18.10)") ' Star formation prescription : creation of :',& + 1, ' seeds in sink n° :', itest, " t= ",time linklist_ptmass(itest) = -1 !! null pointer to differentiate mono seed to gas clump endif From ee6ee66bf3a143a8bd1be76b6ea8116ae56f9885 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 2 Jul 2024 16:44:59 +0200 Subject: [PATCH 677/814] (setup_cluster) update setup to use the new eos 22 --- src/main/readwrite_infile.F90 | 3 ++- src/setup/setup_cluster.f90 | 24 +++++++++++++++++++++--- 2 files changed, 23 insertions(+), 4 deletions(-) diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index b1e879a87..62d9d018d 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -216,7 +216,8 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) ! thermodynamics ! call write_options_eos(iwritein) - if (maxvxyzu >= 4 .and. (ieos==2 .or. ieos==5 .or. ieos==10 .or. ieos==15 .or. ieos==12 .or. ieos==16 .or. ieos==17) ) then + if (maxvxyzu >= 4 .and. (ieos==2 .or. ieos==5 .or. ieos==10 .or. ieos==15 .or. & + ieos==12 .or. ieos==16 .or. ieos==17 .or. ieos==22) ) then call write_inopt(ipdv_heating,'ipdv_heating','heating from PdV work (0=off, 1=on)',iwritein) call write_inopt(ishock_heating,'ishock_heating','shock heating (0=off, 1=on)',iwritein) if (mhd) then diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index cd166a1a5..e1dcda441 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -64,6 +64,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use HIIRegion, only:iH2R use subgroup, only:r_neigh use utils_shuffleparticles, only:shuffleparticles + use cooling, only:Tfloor integer, intent(in) :: id integer, intent(out) :: npart integer, intent(out) :: npartoftype(:) @@ -107,6 +108,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ieos_in = 8 ! Barotropic equation of state mass_fac = 1.0 ! mass code unit: mass_fac * solarm dist_fac = 0.1 ! distance code unit: dist_fac * pc + if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state case(2) ! Young Massive Cluster (S. Jaffa, University of Hertfordshire) default_cluster = "Young Massive Cluster" @@ -115,17 +117,25 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ieos_in = 1 ! Isothermal equation of state mass_fac = 1.0d5 ! mass code unit: mass_fac * solarm dist_fac = 1.0 ! distance code unit: dist_fac * pc + if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state + case(3) ! Young Massive Cluster (Yann Bernard, IPAG) default_cluster = "Embedded cluster" Rcloud_pc = 10.0 ! Input radius [pc] Mcloud_msun = 1.0d4 ! Input mass [Msun] - ieos_in = 21 ! Isothermal equation of state + ieos_in = 21 ! Isothermal equation of state + HII mass_fac = 1.0d4 ! mass code unit: mass_fac * solarm dist_fac = 1.0 ! distance code unit: dist_fac * pc iH2R = 1 ! switch HII regions Rsink_au = 4000. ! Sink radius [au] mu = 2.35 ! mean molecular weight + if (maxvxyzu >= 4) then + ieos_in = 22 ! Adiabatic equation of state + HII + gamma = 5./3. + Tfloor = 6. + endif + case default ! from Bate, Bonnell & Bromm (2003) @@ -135,10 +145,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ieos_in = 8 ! Barotropic equation of state mass_fac = 1.0 ! mass code unit: mass_fac * solarm dist_fac = 0.1 ! distance code unit: dist_fac * pc + if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state end select - if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state !--Read values from .setup if (setexists) then @@ -158,7 +168,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_units(dist=dist_fac*pc,mass=mass_fac*solarm,G=1.) !--Define remaining variables using the inputs - polyk = kboltz*Temperature/(mu*mass_proton_cgs)*(utime/udist)**2 + polyk = gamma*kboltz*Temperature/(mu*mass_proton_cgs)*(utime/udist)**2 rmax = Rcloud_pc*(pc/udist) r2 = rmax*rmax totmass = Mcloud_msun*(solarm/umass) @@ -196,6 +206,14 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call normalise_vfield(npart,vxyzu,ierr,ke=epotgrav) if (ierr /= 0) call fatal('setup','error normalising velocity field') + if (maxvxyzu >= 4) then + if (gamma > 1.) then + vxyzu(4,:) = polyk/(gamma*(gamma-1.)) + else + vxyzu(4,:) = 1.5*polyk + endif + endif + !--Setting the centre of mass of the cloud to be zero call reset_centreofmass(npart,xyzh,vxyzu) From b1b4ae0656a5fe80216875be2dcb40c3bc165436 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 2 Jul 2024 17:09:52 +0200 Subject: [PATCH 678/814] (checksetups) add conditions for HIIRegion --- src/main/checksetup.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 9cc02878e..fe55d6628 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -1055,8 +1055,8 @@ subroutine check_HIIRegion(nerror) use eos, only:ieos use dim, only:gr,mpi integer, intent(inout) :: nerror - if(iH2R > 0 .and. ieos/=21) then - print "(/,a,/)", "Error: If HII activated, eos == 21 is mandatory..." + if(iH2R > 0 .and. (ieos/=21 .or. ieos==22)) then + print "(/,a,/)", "Error: If HII activated, eos == 21 or 22 is mandatory..." nerror = nerror + 1 endif if(iH2R > 0 .and. gr) then From be9e8bd0b6a32c91e152ed5ed7ba422341fd0550 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Jul 2024 10:04:01 +0200 Subject: [PATCH 679/814] (HIIRegion) add internal energy to ionised particle if adiab --- src/main/H2regions.f90 | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index f1aeeee96..62c242c17 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -16,7 +16,7 @@ module HIIRegion ! reference : Fujii et al. 2021 SIRIUS Project Paper III ! ! - + use dim, only:maxvxyzu implicit none public :: update_ionrates,update_ionrate, HII_feedback,initialize_H2R,read_options_H2R,write_options_H2R @@ -38,10 +38,10 @@ module HIIRegion real, parameter :: sigd_cgs = 1.d-21 real :: sigd real :: hv_on_c - real :: T_ion - real :: u_to_t + real :: Tion real :: Rst_max real :: Minmass + real :: uIon private @@ -57,21 +57,25 @@ subroutine initialize_H2R use part, only:isionised use units, only:udist,umass,utime use physcon, only:mass_proton_cgs,kboltz,pc,eV,solarm - use eos , only:gmw + use eos , only:gmw,gamma isionised(:)=.false. !calculate the useful constant in code units mH = gmw*mass_proton_cgs - u_to_t = (3./2)*(kboltz/mH)*(utime/udist)**2 mH = mH/umass - T_ion = 1.d4 + Tion = 1.d4 ar = ar_cgs*(utime/udist**3) sigd = sigd_cgs*udist**2 hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) Rst_max = sqrt(((Rmax*pc)/udist)**2) Minmass = (Mmin*solarm)/umass + if (gamma>1.) then + uIon = kboltz*Tion/(mH*(gamma-1.))*(utime/udist)**2 + else + uIon = 1.5*(kboltz*Tion/(mH)*(utime/udist)**2) + endif if (id == master .and. iverbose > 1) then - write(iprint,"(/a,es18.10,es18.10/)") "feedback constants mH, u_to_t : ", mH, u_to_t + write(iprint,"(/a,es18.10/)") "feedback constants mH : ", mH write(iprint,"(/a,es18.10,es18.10/)") "Max strögrem radius (code/pc) : ", Rst_max, Rmax write(iprint,"(/a,es18.10,es18.10/)") "Min feedback mass (code/Msun) : ", Minmass, Mmin endif @@ -232,6 +236,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) if (.not.(isionised(j))) then Ndot = Ndot - DNdot isionised(j)=.true. + if (maxvxyzu >= 4) vxyzu(4,j) = uIon endif else if (k > 1) then From 9e1b5b0cfdeb87b80d74d86cd8da9ac5e39337e1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Jul 2024 10:04:38 +0200 Subject: [PATCH 680/814] (ptmass) set linklist pointer to -2 if a gas clump is killed --- src/main/ptmass.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 6d8c0d40e..7e0f338b6 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1856,7 +1856,11 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklis if (icreate_sinks == 2) then ! Connect linked list of the merged sink to the survivor call ptmass_endsize_lklist(k,l,n,linklist_ptmass) - if(.not.(linklist_ptmass(l)/=-1 .and. n == 1)) linklist_ptmass(l) = j + if(linklist_ptmass(l)/=0)then + linklist_ptmass(l) = j + else + linklist_ptmass(j) = -2 ! special null pointer for dead gas clump + endif endif ! print success write(iprint,"(/,1x,3a,I8,a,I8,a,F10.4)") 'merge_sinks: ',typ,' merged sinks ',k,' & ',j,' at time = ',time From 9936e33568d41b9e6cb42775f45bfc9c2b27319e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Jul 2024 10:41:25 +0200 Subject: [PATCH 681/814] wrong condition again... --- src/main/checksetup.f90 | 2 +- src/main/readwrite_infile.F90 | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index fe55d6628..170729626 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -1055,7 +1055,7 @@ subroutine check_HIIRegion(nerror) use eos, only:ieos use dim, only:gr,mpi integer, intent(inout) :: nerror - if(iH2R > 0 .and. (ieos/=21 .or. ieos==22)) then + if(iH2R > 0 .and. ieos/=21 .and. ieos/=22) then print "(/,a,/)", "Error: If HII activated, eos == 21 or 22 is mandatory..." nerror = nerror + 1 endif diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 62d9d018d..8353a31fd 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -692,7 +692,8 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (beta > 4.) call warn(label,'very high beta viscosity set') #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)) & + ieos /=11 .and. ieos /=12 .and. ieos /= 15 .and. ieos /= 16 .and. ieos /= 17 .and. & + ieos /= 20 .and. ieos/=22)) & 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 42c27132e587d9c34e8f1b82bc7cdd23ba8f899b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Jul 2024 11:01:37 +0200 Subject: [PATCH 682/814] (read_infile) update condition on cooling requierment --- 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 8353a31fd..2817e7bd7 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -700,7 +700,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (shearparam < 0.) call fatal(label,'stupid value for shear parameter (< 0)') if (irealvisc==2 .and. shearparam > 1) call error(label,'alpha > 1 for shakura-sunyaev viscosity') if (iverbose > 99 .or. iverbose < -9) call fatal(label,'invalid verboseness setting (two digits only)') - if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos == 17)) & + if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos == 17 .or. ieos==22)) & call fatal(label,'cooling requires adiabatic eos (ieos=2)') if (icooling > 0 .and. (ipdv_heating <= 0 .or. ishock_heating <= 0)) & call fatal(label,'cooling requires shock and work contributions') From 8477dac2212d553fe27177683f755fbdbf3e5ff3 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Jul 2024 12:41:13 +0200 Subject: [PATCH 683/814] (cons2prim) add isionised in the case of adiab eos --- src/main/cons2prim.f90 | 2 +- src/main/evolve.F90 | 3 ++- src/main/step_leapfrog.F90 | 1 - 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 3c05a5213..a8bb68ffc 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -274,7 +274,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& uui = vxyzu(4,i) if (uui < 0.) call warning('cons2prim','Internal energy < 0',i,'u',uui) 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) + gamma_local=gammai,mu_local=mui,Xlocal=X_i,Zlocal=Z_i,isionised=isionised(i)) else !isothermal call equationofstate(ieos,p_on_rhogas,spsound,rhogas,xi,yi,zi,temperaturei,mu_local=mui, & diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 3b05c8d90..192021e71 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -305,7 +305,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) endif ! Need to recompute the force when sink or stars are created - if (isdead_or_accreted(xyzh(4,ipart_rhomax)) .or. (ipart_createseeds /= 0) .or. (ipart_createstars /= 0)) then + if (ipart_rhomax /= 0 .or. ipart_createseeds /= 0 .or. ipart_createstars /= 0) then if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& @@ -316,6 +316,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) endif ipart_createseeds = 0 ! reset pointer to zero ipart_createstars = 0 ! reset pointer to zero + dummy = 0 endif ! ! Strang splitting: implicit update for half step diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 14f8baa04..f8dca1e91 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -124,7 +124,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use porosity, only:get_filfac use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative - use eos, only:equationofstate use substepping, only:substep,substep_gr, & substep_sph_gr,substep_sph From 35021daf07716dff745b1630d5cff62fbf5e9cc9 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Jul 2024 15:38:03 +0200 Subject: [PATCH 684/814] (HIIRegion) fix stupid dividing by zero mistake --- src/main/H2regions.f90 | 15 ++++++++------- src/main/checksetup.f90 | 4 ++-- src/main/eos_HIIR.f90 | 9 ++++----- src/main/evolve.F90 | 6 ++++-- src/main/part.F90 | 1 + 5 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 62c242c17..c97f48179 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -16,7 +16,6 @@ module HIIRegion ! reference : Fujii et al. 2021 SIRIUS Project Paper III ! ! - use dim, only:maxvxyzu implicit none public :: update_ionrates,update_ionrate, HII_feedback,initialize_H2R,read_options_H2R,write_options_H2R @@ -61,8 +60,7 @@ subroutine initialize_H2R isionised(:)=.false. !calculate the useful constant in code units mH = gmw*mass_proton_cgs - mH = mH/umass - Tion = 1.d4 + Tion = 1.e4 ar = ar_cgs*(utime/udist**3) sigd = sigd_cgs*udist**2 hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) @@ -71,13 +69,15 @@ subroutine initialize_H2R if (gamma>1.) then uIon = kboltz*Tion/(mH*(gamma-1.))*(utime/udist)**2 else - uIon = 1.5*(kboltz*Tion/(mH)*(utime/udist)**2) + uIon = 1.5*(kboltz*Tion/(mH))*(utime/udist)**2 endif + mH = mH/umass + if (id == master .and. iverbose > 1) then - write(iprint,"(/a,es18.10/)") "feedback constants mH : ", mH - write(iprint,"(/a,es18.10,es18.10/)") "Max strögrem radius (code/pc) : ", Rst_max, Rmax - write(iprint,"(/a,es18.10,es18.10/)") "Min feedback mass (code/Msun) : ", Minmass, Mmin + write(iprint,"(a,es18.10,es18.10)") " feedback constants mH,uIon : ", mH,uIon + write(iprint,"(a,es18.10,es18.10)") " Max strögrem radius (code/pc) : ", Rst_max, Rmax + write(iprint,"(a,es18.10,es18.10)") " Min feedback mass (code/Msun) : ", Minmass, Mmin endif return end subroutine initialize_H2R @@ -178,6 +178,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) use sortutils, only:Knnfunc,set_r2func_origin,r2func_origin use physcon, only:pc,pi use timing, only:get_timings,increment_timer,itimer_HII + use dim, only:maxvxyzu integer, intent(in) :: nptmass,npart real, intent(in) :: xyzh(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyzu(:,:) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 170729626..5a815ad6c 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -105,7 +105,7 @@ subroutine check_setup(nerror,nwarn,restart) nerror = nerror + 1 endif else - if (polyk < tiny(0.) .and. ieos /= 2 .and. ieos /= 5 .and. ieos /= 17) then + if (polyk < tiny(0.) .and. ieos /= 2 .and. ieos /= 5 .and. ieos /= 17 .and. ieos/= 22) then print*,'WARNING! polyk = ',polyk,' in setup, speed of sound will be zero in equation of state' nwarn = nwarn + 1 endif @@ -239,7 +239,7 @@ subroutine check_setup(nerror,nwarn,restart) nerror = nerror + 1 endif else - if (abs(gamma-1.) > tiny(gamma) .and. (ieos /= 2 .and. ieos /= 5 .and. ieos /=9 .and. ieos /= 17)) then + if (abs(gamma-1.) > tiny(gamma) .and. (ieos /= 2 .and. ieos /= 5 .and. ieos /=9 .and. ieos /= 17 .and. ieos /=22)) then print*,'*** ERROR: using isothermal EOS, but gamma = ',gamma gamma = 1. print*,'*** Resetting gamma to 1, gamma = ',gamma diff --git a/src/main/eos_HIIR.f90 b/src/main/eos_HIIR.f90 index 1f836ed44..6735f28a1 100644 --- a/src/main/eos_HIIR.f90 +++ b/src/main/eos_HIIR.f90 @@ -84,11 +84,10 @@ end subroutine get_eos_HIIR_iso !----------------------------------------------------------------------- subroutine get_eos_HIIR_adiab(polyk,temperature_coef,mui,tempi,ponrhoi,rhoi,eni,gammai,spsoundi,isionisedi) use io, only:fatal - real, intent(in) :: polyk,temperature_coef,rhoi,gammai - real, intent(out) :: ponrhoi,spsoundi,mui,tempi - real, intent(in), optional :: eni - - logical, intent(in) :: isionisedi + real, intent(in) :: polyk,temperature_coef,rhoi,gammai + real, intent(out) :: ponrhoi,spsoundi,mui,tempi + logical, intent(in) :: isionisedi + real, intent(in), optional :: eni if (gammai < tiny(gammai)) call fatal('eos','gamma not set for adiabatic eos',var='gamma',val=gammai) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 192021e71..75880ff1c 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -143,7 +143,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) logical :: use_global_dt integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold character(len=120) :: dumpfile_orig - integer :: dummy + integer :: dummy,istepHII dummy = 0 @@ -327,7 +327,9 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (iH2R > 0 .and. id==master) then #ifdef IND_TIMESTEPS - if(mod(istepfrac,2**(nbinmax-3))==0 .or. istepfrac==1) then + istepHII = 2**nbinmax/8 + if (istepHII==0) istepHII = 1 + if(mod(istepfrac,istepHII)==0 .or. istepfrac==1) then call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) endif #else diff --git a/src/main/part.F90 b/src/main/part.F90 index 9f14cb966..9da9debbe 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -610,6 +610,7 @@ subroutine init_part npartoftype(:) = 0 npartoftypetot(:) = 0 massoftype(:) = 0. + isionised(:) = .false. !--initialise point mass arrays to zero xyzmh_ptmass = 0. vxyz_ptmass = 0. From 7c579385fe1700a43ccb465f690ffa2a10931e85 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Jul 2024 15:46:03 +0200 Subject: [PATCH 685/814] (setup_cluster) change initial temp and add icooling --- src/setup/setup_cluster.f90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index e1dcda441..79d592f36 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -64,7 +64,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use HIIRegion, only:iH2R use subgroup, only:r_neigh use utils_shuffleparticles, only:shuffleparticles - use cooling, only:Tfloor + use cooling, only:Tfloor,icooling integer, intent(in) :: id integer, intent(out) :: npart integer, intent(out) :: npartoftype(:) @@ -134,6 +134,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ieos_in = 22 ! Adiabatic equation of state + HII gamma = 5./3. Tfloor = 6. + icooling = 6 + Temperature = 40. endif From ef3fea69656080c2c3409e73b16b173bd794e16a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 4 Jul 2024 10:44:06 +0200 Subject: [PATCH 686/814] (ptmass) wrong index in merge ptmass --- src/main/ptmass.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 7e0f338b6..046e94475 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1856,7 +1856,7 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklis if (icreate_sinks == 2) then ! Connect linked list of the merged sink to the survivor call ptmass_endsize_lklist(k,l,n,linklist_ptmass) - if(linklist_ptmass(l)/=0)then + if(linklist_ptmass(j)/=0)then linklist_ptmass(l) = j else linklist_ptmass(j) = -2 ! special null pointer for dead gas clump From e49b89d6af1a8dd1cd185e1df630471a3718d2a7 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 4 Jul 2024 16:46:41 +0200 Subject: [PATCH 687/814] (setup_cluster) module import mistake --- src/setup/setup_cluster.f90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 79d592f36..1ff9c99da 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -64,7 +64,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use HIIRegion, only:iH2R use subgroup, only:r_neigh use utils_shuffleparticles, only:shuffleparticles - use cooling, only:Tfloor,icooling + use cooling, only:Tfloor + use options, only:icooling + integer, intent(in) :: id integer, intent(out) :: npart integer, intent(out) :: npartoftype(:) From de8790d837356362e13d310e2c441ec015a842ba Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 5 Jul 2024 10:52:37 +0200 Subject: [PATCH 688/814] (HIIR) force HII feedback after star creation --- src/main/evolve.F90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 75880ff1c..64f377bc8 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -304,6 +304,18 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) endif endif + if (iH2R > 0 .and. id==master) then +#ifdef IND_TIMESTEPS + istepHII = 2**nbinmax/8 + if (istepHII==0) istepHII = 1 + if(mod(istepfrac,istepHII)==0 .or. istepfrac==1 .or. ipart_createstars /= 0) then + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) + endif +#else + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) +#endif + endif + ! Need to recompute the force when sink or stars are created if (ipart_rhomax /= 0 .or. ipart_createseeds /= 0 .or. ipart_createstars /= 0) then if (use_regnbody) then @@ -325,18 +337,6 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) endif - if (iH2R > 0 .and. id==master) then -#ifdef IND_TIMESTEPS - istepHII = 2**nbinmax/8 - if (istepHII==0) istepHII = 1 - if(mod(istepfrac,istepHII)==0 .or. istepfrac==1) then - call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) - endif -#else - call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) -#endif - endif - nsteps = nsteps + 1 ! !--evolve data for one timestep From 2df218246fac214ef16fca53b0a832d862601b62 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Jul 2024 09:49:28 +0200 Subject: [PATCH 689/814] (substep) forgot one argument in the last force in leapfrog mode --- src/main/evolve.F90 | 5 ++--- src/main/substepping.F90 | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 64f377bc8..7ae1ff33f 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -305,15 +305,14 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) endif if (iH2R > 0 .and. id==master) then + istepHII = 1 #ifdef IND_TIMESTEPS istepHII = 2**nbinmax/8 if (istepHII==0) istepHII = 1 +#endif if(mod(istepfrac,istepHII)==0 .or. istepfrac==1 .or. ipart_createstars /= 0) then call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) endif -#else - call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) -#endif endif ! Need to recompute the force when sink or stars are created diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 348d86e06..c86c1febf 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -498,7 +498,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & 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) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,isionised=isionised) endif if (use_fourthorder) then !! FSI 4th order scheme From 11ca2bdf58495a91492bfa28af39e5c298470b80 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 8 Jul 2024 09:43:18 +0100 Subject: [PATCH 690/814] Adds dradcool/dU_hydro check to icooling=9 --- src/main/cooling_radapprox.f90 | 44 ++++++++++++++++++---------------- src/main/step_leapfrog.F90 | 17 ++++++------- 2 files changed, 33 insertions(+), 28 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index 4b14a0641..fea45fdfd 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -21,6 +21,7 @@ module cooling_radapprox implicit none real :: Lstar = 0d0 ! in units of L_sun + real,parameter :: dtcool_crit = 0.001 ! critical dt_rad/dt_hydro for not applying cooling 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 @@ -77,15 +78,10 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot real :: cs2,Om2,Hmod2 real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi - integer :: i,ratefile - character(len=20) :: filename + integer :: i,ratefile,n_uevo ! write (temp,'(E5.2)') dt - write (filename, 11) dt -11 format("coolrate_", E7.2,".dat") - ratefile = 34 - open(unit=ratefile,file=filename,status="replace",form="formatted") !$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) & @@ -94,7 +90,7 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) !$omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot) & !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb) overpart: do i=1,npart -! if (.not. iactive(iphase(i)) ) cycle + if (.not. iactive(iphase(i)) ) cycle if (isdead_or_accreted(xyzh(4,i)) ) cycle poti = Gpot_cool(i) du_FLDi = duFLD(i) @@ -114,12 +110,6 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) presi = kb_on_mh*rhoi*unit_density*Ti/gmwi ! cgs presi = presi/unit_pressure !code units - 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) ! Stamatellos+ 2007 method @@ -163,6 +153,15 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) opac_store(i) = opaci dudti_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/opaci/unit_ergg*utime! code units + ! If radiative cooling is negligible compared to hydrodynamical heating + ! don't use this method to update energy, just use hydro du/dt (don't zero + ! fxyzu(4,i) ). + if (abs(dudti_rad/dudt_sph(i)) < dtcool_crit) then +! print *, "not cooling/heating for r=",sqrt(ri2),".", dudti_rad,& +! dudt_sph(i) + cycle + endif + if (doFLD) then Teqi = (du_FLDi + dudt_sph(i)) *opaci*unit_ergg/utime ! physical units du_tot = dudt_sph(i) + dudti_rad + du_FLDi @@ -209,7 +208,7 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) else energ(i) = ui*exp(-dt/tthermi) + ueqi*(1.d0-exp(-dt/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 @@ -221,14 +220,19 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) stop endif - if (abs(dudt_sph(i)) >1.) then - !$omp critical - write (ratefile,'(I6,1X,E15.4)') i, (ui - energ(i))/dt - !$omp end critical - endif + ! zero fxyzu(4,i) because we already updated the energy + dudt_sph(i) = 0d0 enddo overpart !$omp end parallel do - close(ratefile) + + n_uevo = 0 + !$omp parallel do default(none) & + !$omp shared(dudt_sph,npart) private(i) reduction(+:n_uevo) + do i=1, npart + if (dudt_sph(i) /= 0d0) n_uevo = n_uevo + 1 + enddo + !$omp end parallel do + print *, "energy not evolved with cooling for", n_uevo, "particles" ! print *, "min/max dudt_sph():", minval(dudt_sph), maxval(dudt_sph) end subroutine radcool_update_energ diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 56ec50dc3..a1dd9939b 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -200,7 +200,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif !Alison - if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L202", fxyzu(4,i) + !if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L202", fxyzu(4,i) !--floor the thermal energy if requested and required if (ufloor > 0. .and. icooling /= 9) then @@ -323,7 +323,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vpred(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif !Alison - if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L324", fxyzu(4,i) + !if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L324", fxyzu(4,i) !--floor the thermal energy if requested and required if (ufloor > 0. .and. icooling /= 9) then @@ -393,7 +393,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) dustpred,ddustevol,filfacpred,dustfrac,eos_vars,timei,dtsph,dtnew,& ppred,dens,metrics) - if (do_radiation .and. implicit_radiation .or. icooling == 9) then + if (do_radiation .and. implicit_radiation) then! .or. icooling == 9) then rad = radpred vxyzu(4,1:npart) = vpred(4,1:npart) endif @@ -484,7 +484,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) endif !Alison - if (icooling==9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L488", fxyzu(4,i) + ! if (icooling==9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L488", fxyzu(4,i) if (use_dustgrowth .and. itype==idust) dustprop(:,i) = dustprop(:,i) + dti*ddustprop(:,i) if (itype==igas) then @@ -508,7 +508,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif !Alison - if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L509", fxyzu(4,i) +! if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L509", fxyzu(4,i) !--floor the thermal energy if requested and required if (ufloor > 0. .and. icooling /= 9) then @@ -567,7 +567,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vzi = vxyzu(3,i) + hdtsph*fxyzu(3,i) if (maxvxyzu >= 4) eni = vxyzu(4,i) + hdtsph*fxyzu(4,i) !Alison - if (icooling==9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L568", fxyzu(4,i) + ! if (icooling==9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L568", fxyzu(4,i) erri = (vxi - vpred(1,i))**2 + (vyi - vpred(2,i))**2 + (vzi - vpred(3,i))**2 errmax = max(errmax,erri) @@ -660,8 +660,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) endif - !Alison - if (icooling ==9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L662", fxyzu(4,i) if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) - hdtsph*ddustprop(:,i) if (itype==igas) then if (mhd) Bevol(:,i) = Bevol(:,i) - hdtsph*dBevol(:,i) @@ -693,6 +691,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) rad = radpred vxyzu(4,1:npart) = vpred(4,1:npart) endif + if (icooling == 9) then + vxyzu(4,1:npart) = vpred(4,1:npart) + endif endif enddo iterations From 7ae4d40adf3b0ee15475bcb318db5331a0630297 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 8 Jul 2024 09:54:47 +0100 Subject: [PATCH 691/814] Merging upstream changes --- AUTHORS | 4 ++-- build/MakeKrome | 4 ++++ build/Makefile_defaults_ifx | 17 +++++++++++++++++ src/main/extern_spiral.f90 | 14 +++++++------- 4 files changed, 30 insertions(+), 9 deletions(-) create mode 100644 build/Makefile_defaults_ifx diff --git a/AUTHORS b/AUTHORS index f236e7dc4..9f44811cf 100644 --- a/AUTHORS +++ b/AUTHORS @@ -18,18 +18,18 @@ Arnaud Vericel Mark Hutchison Mats Esseldeurs Rebecca Nealon +Yrisch Elisabeth Borchert Ward Homan Christophe Pinte -Yrisch Terrence Tricco Stephane Michoulier Simone Ceppi Spencer Magnall Enrico Ragusa Caitlyn Hardiman -Sergei Biriukov Cristiano Longarini +Sergei Biriukov Giovanni Dipierro Roberto Iaconi Hauke Worpel diff --git a/build/MakeKrome b/build/MakeKrome index 0171e2408..7de5d0c75 100644 --- a/build/MakeKrome +++ b/build/MakeKrome @@ -6,9 +6,13 @@ KROME_BUILD_DIR = ${KROMEPATH}/build KFLAGS=$(filter-out -std=f2008, $(FFLAGS)) ifeq ($(SYSTEM), ifort) KFLAGS += -O3 -ipo -ip -unroll -xHost -g -fp-model precise +else +ifeq ($(SYSTEM), ifx) + KFLAGS += -O3 -ipo -ip -unroll -xHost -g -fp-model precise else KFLAGS += -ffree-line-length-none -w -fallow-argument-mismatch endif +endif FFLAGS+= -I$(KROME_BUILD_DIR) PASSED=0 diff --git a/build/Makefile_defaults_ifx b/build/Makefile_defaults_ifx new file mode 100644 index 000000000..1e00e3918 --- /dev/null +++ b/build/Makefile_defaults_ifx @@ -0,0 +1,17 @@ +# default settings for ifx compiler +# override these in the Makefile +FC= ifx +#FFLAGS= -O3 -inline-factor=500 -shared-intel -warn uninitialized -warn unused -warn truncated_source -no-wrap-margin +FFLAGS= -O3 -shared-intel -warn uninitialized -warn unused -warn truncated_source -no-wrap-margin +DBLFLAG= -r8 +DEBUGFLAG= -check all -WB -traceback -g -debug all # -fpe0 -fp-stack-check -debug all -noarg_temp_created +#DEBUGFLAG= -g -traceback -check all -check bounds -check uninit -ftrapuv -debug all -warn all,nodec,interfaces,nousage -fpe0 -fp-stack-check -WB -no-diag-error-limit -no-wrap-margin -O0 -noarg_temp_created +ENDIANFLAGBIG= -convert big_endian +ENDIANFLAGLITTLE= -convert little_endian +# or use setenv F_UFMTENDIAN=big:45 at runtime (e.g. for unit 45 only) +CC = icc +CCFLAGS = -O3 +LIBCXX = -cxxlib +KNOWN_SYSTEM=yes + +OMPFLAGS= -qopenmp diff --git a/src/main/extern_spiral.f90 b/src/main/extern_spiral.f90 index ddeb68966..f27a06d9f 100644 --- a/src/main/extern_spiral.f90 +++ b/src/main/extern_spiral.f90 @@ -377,20 +377,20 @@ subroutine initialise_spiral(ierr) spiralsum(jj)=0.0d0 !-Loop over spheroids do j=1,Nt - Rspheroids(jj,j) = Ri+(DBLE(j)-1.d0)*d_0 + Rspheroids(jj,j) = Ri+(dble(j)-1.d0)*d_0 shapefn(jj,j) = (cotalpha/Nshape) * & - log(1.d0+(Rspheroids(jj,j)/Rsarms)**Nshape) + jj*2.0d0*pi/DBLE(NNi) + log(1.d0+(Rspheroids(jj,j)/Rsarms)**Nshape) + jj*2.0d0*pi/dble(NNi) !print*,jj,j,Rspheroids(jj,j),shapefn(jj,j) select case(iarms) case(2,4) !--For a linear density drop off from galactic centre: den0(jj,j) = (Rf-Rspheroids(jj,j))*3.d0*Mspiral & - / (DBLE(NNi)*pi*a_0*a_0*c_0) + / (dble(NNi)*pi*a_0*a_0*c_0) spiralsum(jj) = spiralsum(jj) + (Rf-Rspheroids(jj,j)) case(3) !--For a log density drop off from galactic centre: den0(jj,j) = exp((Ri-Rspheroids(jj,j))/Rl)*3.d0*Mspiral & - / (DBLE(NNi)*pi*a_0*a_0*c_0) + / (dble(NNi)*pi*a_0*a_0*c_0) spiralsum(jj) = spiralsum(jj) + exp((Ri-Rspheroids(jj,j))/Rl) end select enddo @@ -420,9 +420,9 @@ subroutine initialise_spiral(ierr) case(1) potfilename = 'pot3D.bin' if (id==master) print*,'Reading in potential from an external file (BINARY): ',potfilename - open (unit =1, file = TRIM(potfilename), status='old', form='UNFORMATTED', access='SEQUENTIAL', iostat=ios) + open(unit=1,file=trim(potfilename),status='old',form='UNFORMATTED',access='SEQUENTIAL',iostat=ios) if (ios /= 0 .and. id==master) then - print*, 'Error opening file:', TRIM(potfilename) + print*, 'Error opening file:', trim(potfilename) endif !Read in the grid lengths if they exist in the header. read(1) potlenz,potlenx,potleny @@ -1281,7 +1281,7 @@ subroutine Wang_bar(ri,phii,thetai,pot) allocate(PlmA(l+1)) call legendre_associated(l,m,cos(thetai),PlmA) Plm=PlmA(l+1) - thisphi = Anlm(i) * (s**REAL(l))/((1.+s)**(2.*REAL(l)+1.)) * Gnl * Plm * cos(REAL(m)*(phii)) + thisphi = Anlm(i) * (s**real(l))/((1.+s)**(2.*real(l)+1.)) * Gnl * Plm * cos(real(m)*(phii)) AlmnSum = AlmnSum + thisphi deallocate(GnlA,PlmA) From 32de3d177341ba43c97b978b9a183426d1638252 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 8 Jul 2024 10:02:37 +0100 Subject: [PATCH 692/814] Adds upstream changes --- src/main/extern_binary.f90 | 8 ++ src/main/extern_densprofile.f90 | 6 +- src/utils/moddump_radiotde.f90 | 156 +++++++++++++++++++++++++++----- src/utils/phantomanalysis.f90 | 7 +- 4 files changed, 148 insertions(+), 29 deletions(-) diff --git a/src/main/extern_binary.f90 b/src/main/extern_binary.f90 index d22725666..1602453fc 100644 --- a/src/main/extern_binary.f90 +++ b/src/main/extern_binary.f90 @@ -19,6 +19,7 @@ module extern_binary ! - accradius2 : *accretion radius of secondary (if iexternalforce=binary)* ! - eps_soft1 : *Plummer softening of primary* ! - eps_soft2 : *Plummer softening of secondary* +! - mass1 : *m1 of central binary system (if iexternalforce=binary)* ! - mass2 : *m2 of central binary system (if iexternalforce=binary)* ! - ramp : *ramp up mass of secondary over first 5 orbits?* ! @@ -234,6 +235,7 @@ subroutine write_options_externbinary(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit + call write_inopt(mass1,'mass1','m1 of central binary system (if iexternalforce=binary)',iunit) call write_inopt(mass2,'mass2','m2 of central binary system (if iexternalforce=binary)',iunit) call write_inopt(accradius1,'accradius1','accretion radius of primary',iunit) call write_inopt(accradius2,'accradius2','accretion radius of secondary (if iexternalforce=binary)',iunit) @@ -259,6 +261,12 @@ subroutine read_options_externbinary(name,valstring,imatch,igotall,ierr) imatch = .true. igotall = .false. select case(trim(name)) + case('mass1') + read(valstring,*,iostat=ierr) mass1 + ngot = ngot + 1 + if (mass1 < 0.) then + call fatal(where,'invalid setting for m1 (<0)') + endif case('mass2') read(valstring,*,iostat=ierr) mass2 ngot = ngot + 1 diff --git a/src/main/extern_densprofile.f90 b/src/main/extern_densprofile.f90 index 407e50fae..d8fc59c21 100644 --- a/src/main/extern_densprofile.f90 +++ b/src/main/extern_densprofile.f90 @@ -137,13 +137,13 @@ subroutine read_rhotab(filename, rsize, rtab, rhotab, nread, polyk, gamma, rhoc, endif ! First line: # K gamma rhoc - read(iunit, *, iostat=ierr) hash,polyk, 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) - read(iunit,*, iostat=ierr) hash,nread + read(iunit,*,iostat=ierr) hash,nread if (ierr /= 0) then call error('extern_densityprofile','Error reading second line of header from '//trim(filename)) return @@ -155,7 +155,7 @@ subroutine read_rhotab(filename, rsize, rtab, rhotab, nread, polyk, gamma, rhoc, endif ! Loop over 'n' lines: r and density separated by space do i = 1,nread - read(iunit,*, iostat=ierr) rtab(i), rhotab(i) + read(iunit,*,iostat=ierr) rtab(i), rhotab(i) if (ierr /= 0) then call error('extern_densityprofile','Error reading data from '//trim(filename)) return diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index ab4ab6bfe..28af40a44 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -14,7 +14,9 @@ module moddump ! ! :Runtime parameters: ! - ieos : *equation of state used* -! - ignore_radius : *tde particle inside this radius will be ignored* +! - ignore_radius : *ignore tde particle inside this radius (-ve = ignore all for injection)* +! - m_target : *target mass in circumnuclear gas cloud (in Msun) (-ve = ignore and use rho0)* +! - m_threshold : *threshold in solving rho0 for m_target (in Msun)* ! - mu : *mean molecular density of the cloud* ! - nbreak : *number of broken power laws* ! - nprof : *number of data points in the cloud profile* @@ -23,7 +25,7 @@ module moddump ! - rad_min : *inner radius of the circumnuclear gas cloud* ! - remove_overlap : *remove outflow particles overlap with circum particles* ! - rhof_n_1 : *power law index of the section* -! - rhof_rho0 : *density at rad_min (in g/cm^3)* +! - rhof_rho0 : *density at rad_min (in g/cm^3) (-ve = ignore and calc for m_target)* ! - temperature : *temperature of the gas cloud (-ve = read from file)* ! - use_func : *if use broken power law for density profile* ! @@ -32,7 +34,7 @@ module moddump ! implicit none public :: modify_dump - private :: rho,rho_tab,get_temp_r,uerg,calc_rhobreak,write_setupfile,read_setupfile + private :: rho,rho_tab,get_temp_r,uerg,calc_rhobreak,calc_rho0,write_setupfile,read_setupfile private integer :: ieos_in,nprof,nbreak,nbreak_old @@ -42,7 +44,7 @@ module moddump real, allocatable :: rhof_n(:),rhof_rbreak(:),rhof_rhobreak(:) real, allocatable :: rhof_n_in(:),rhof_rbreak_in(:) real, allocatable :: rad_prof(:),dens_prof(:) - real :: rhof_rho0 + real :: rhof_rho0,m_target,m_threshold logical :: use_func,use_func_old,remove_overlap contains @@ -53,9 +55,11 @@ module moddump ! !---------------------------------------------------------------- subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) - use physcon, only:solarm,years,mass_proton_cgs + use physcon, only:solarm,years,mass_proton_cgs,kb_on_mh,kboltz,radconst use setup_params, only:npart_total - use part, only:igas,set_particle_type,delete_particles_inside_radius,delete_particles_outside_sphere + use part, only:igas,set_particle_type,pxyzu,delete_particles_inside_radius, & + delete_particles_outside_sphere,kill_particle,shuffle_part, & + eos_vars,itemp,igamma,igasP use io, only:fatal,master,id use units, only:umass,udist,utime,set_units,unit_density use timestep, only:dtmax,tmax @@ -71,7 +75,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) real, intent(inout) :: massoftype(:) integer :: i,ierr,iunit=12,iprof integer :: np_sphere,npart_old - real :: totmass,delta,r + real :: totmass,delta,r,rhofr,presi character(len=120) :: fileset,fileprefix='radio' logical :: read_temp,setexists real, allocatable :: masstab(:),temp_prof(:) @@ -88,7 +92,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) !--Set default values temperature = 10. ! Temperature in Kelvin - mu = 2. ! mean molecular weight + mu = 1. ! mean molecular weight ieos_in = 2 ignore_radius = 1.e14 ! in cm use_func = .true. @@ -103,6 +107,9 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) allocate(rhof_n(nbreak),rhof_rbreak(nbreak)) rhof_n = -1.7 rhof_rbreak = rad_min + m_target = dot_product(npartoftype,massoftype)*umass/solarm + m_threshold = 1.e-3 + !--Profile default setups read_temp = .false. profile_filename = default_name @@ -138,7 +145,6 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) allocate(rhof_n(nbreak),rhof_rbreak(nbreak),rhof_rhobreak(nbreak)) rhof_n(:) = rhof_n_in(1:nbreak) rhof_rbreak(:) = rhof_rbreak_in(1:nbreak) - call calc_rhobreak() else if (temperature <= 0) read_temp = .true. rhof => rho_tab @@ -166,6 +172,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) endif ieos = ieos_in gmw = mu + write(*,'(a,1x,i2)') ' Using eos =', ieos !--Everything to code unit ignore_radius = ignore_radius/udist @@ -174,6 +181,8 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) rad_max = rad_max/udist rhof_rbreak = rhof_rbreak/udist rhof_rhobreak = rhof_rhobreak/unit_density + m_target = m_target*solarm/umass + m_threshold = m_threshold*solarm/umass else rad_prof = rad_prof/udist dens_prof = dens_prof/unit_density @@ -181,14 +190,34 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) rad_max = rad_prof(nprof) endif + !--Calc rho0 and rhobreak + if (use_func) then + if (rhof_rho0 < 0.) then + call calc_rho0(rhof) + elseif (m_target < 0.) then + call calc_rhobreak() + else + call fatal('moddump','Must give rho0 or m_target') + endif + endif + !--remove unwanted particles - npart_old = npart - call delete_particles_inside_radius((/0.,0.,0./),ignore_radius,npart,npartoftype) - write(*,'(I10,1X,A23,1X,E8.2,1X,A14)') npart_old - npart, 'particles inside radius', ignore_radius*udist, 'cm are deleted' - npart_old = npart - if (remove_overlap) then - call delete_particles_outside_sphere((/0.,0.,0./),rad_min,npart) - write(*,'(I10,1X,A24,1X,E8.2,1X,A14)') npart_old - npart, 'particles outside radius', rad_min*udist, 'cm are deleted' + if (ignore_radius > 0) then + npart_old = npart + call delete_particles_inside_radius((/0.,0.,0./),ignore_radius,npart,npartoftype) + write(*,'(I10,1X,A23,1X,E8.2,1X,A14)') npart_old - npart, 'particles inside radius', ignore_radius*udist, 'cm are deleted' + npart_old = npart + if (remove_overlap) then + call delete_particles_outside_sphere((/0.,0.,0./),rad_min,npart) + write(*,'(I10,1X,A24,1X,E8.2,1X,A14)') npart_old - npart, 'particles outside radius', rad_min*udist, 'cm are deleted' + npart_old = npart + endif + else + write(*,'(a)') ' Ignore all TDE particles' + do i = 1,npart + call kill_particle(i,npartoftype) + enddo + call shuffle_part(npart) npart_old = npart endif @@ -204,14 +233,21 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) !--Set particle properties do i = npart_old+1,npart call set_particle_type(i,igas) - r = dot_product(xyzh(1:3,i),xyzh(1:3,i)) + r = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) + rhofr = rhof(r) if (read_temp) temperature = get_temp_r(r,rad_prof,temp_prof) - vxyzu(4,i) = uerg(rhof(r),temperature) + vxyzu(4,i) = uerg(rhofr,temperature,ieos) vxyzu(1:3,i) = 0. ! stationary for now + pxyzu(4,i) = entropy(rhofr,temperature,ieos) + pxyzu(1:3,i) = 0. + eos_vars(itemp,i) = temperature + presi = pressure(rhofr,temperature,ieos) + eos_vars(igamma,i) = 1. + presi/(rhofr*vxyzu(4,i)) enddo + if (ieos == 12) write(*,'(a,1x,f10.4)') ' Mean gamma =', sum(eos_vars(igamma,npart_old+1:npart))/(npart - npart_old) !--Set timesteps - tmax = 10.*years/utime + tmax = 3.*years/utime dtmax = tmax/1000. end subroutine modify_dump @@ -282,19 +318,60 @@ real function get_temp_r(r,rad_prof,temp_prof) end function get_temp_r -real function uerg(rho,T) +real function uerg(rho,T,ieos) use physcon, only:kb_on_mh,radconst use units, only:unit_density,unit_ergg real, intent(in) :: rho,T + integer, intent(in) :: ieos real :: ucgs_gas,ucgs_rad,rhocgs rhocgs = rho*unit_density ucgs_gas = 1.5*kb_on_mh*T/mu - ucgs_rad = 0. !radconst*T**4/rhocgs + if (ieos == 12) then + ucgs_rad = radconst*T**4/rhocgs + else + ucgs_rad = 0. !radconst*T**4/rhocgs + endif uerg = (ucgs_gas+ucgs_rad)/unit_ergg end function uerg +real function entropy(rho,T,ieos) + use physcon, only:kb_on_mh,radconst,kboltz + use units, only:unit_density,unit_ergg + real, intent(in) :: rho,T + integer, intent(in) :: ieos + real :: ent_gas,ent_rad,rhocgs + + rhocgs = rho*unit_density + ent_gas = kb_on_mh/mu*log(T**1.5/rhocgs) + if (ieos == 12) then + ent_rad = 4.*radconst*T**3/(3.*rhocgs) + else + ent_rad = 0. + endif + entropy = (ent_gas+ent_rad)/kboltz/ unit_ergg + +end function entropy + +real function pressure(rho,T,ieos) + use physcon, only:kb_on_mh,radconst + use units, only:unit_density,unit_pressure + real, intent(in) :: rho,T + integer, intent(in) :: ieos + real :: p_gas,p_rad,rhocgs + + rhocgs = rho*unit_density + p_gas = rhocgs*kb_on_mh*T/mu + if (ieos == 12) then + p_rad = radconst*T**4/3. + else + p_rad = 0. + endif + pressure = (p_gas+p_rad)/ unit_pressure + +end function pressure + subroutine calc_rhobreak() integer :: i @@ -307,6 +384,33 @@ subroutine calc_rhobreak() end subroutine calc_rhobreak +subroutine calc_rho0(rhof) + use units, only:unit_density + use stretchmap, only:get_mass_r + procedure(rho), pointer, intent(in) :: rhof + real :: rho0_min,rho0_max,totmass + integer :: iter + + rho0_min = 0. + rho0_max = 1. + totmass = -1. + iter = 0 + + do while (abs(totmass - m_target) > m_threshold) + rhof_rho0 = 0.5*(rho0_min + rho0_max) + call calc_rhobreak() + totmass = get_mass_r(rhof,rad_max,rad_min) + if (totmass > m_target) then + rho0_max = rhof_rho0 + else + rho0_min = rhof_rho0 + endif + iter = iter + 1 + enddo + write(*,'(a11,1x,es10.2,1x,a12,1x,i3,1x,a10)') ' Get rho0 =', rhof_rho0*unit_density, 'g/cm^-3 with', iter, 'iterations' + +end subroutine + !---------------------------------------------------------------- !+ ! write parameters to setup file @@ -324,14 +428,16 @@ subroutine write_setupfile(filename) write(iunit,"(a)") '# input file for setting up a circumnuclear gas cloud' write(iunit,"(/,a)") '# geometry' - call write_inopt(ignore_radius,'ignore_radius','tde particle inside this radius will be ignored',iunit) + call write_inopt(ignore_radius,'ignore_radius','ignore tde particle inside this radius (-ve = ignore all for injection)',iunit) call write_inopt(remove_overlap,'remove_overlap','remove outflow particles overlap with circum particles',iunit) call write_inopt(use_func,'use_func','if use broken power law for density profile',iunit) if (use_func) then call write_inopt(rad_min,'rad_min','inner radius of the circumnuclear gas cloud',iunit) call write_inopt(rad_max,'rad_max','outer radius of the circumnuclear gas cloud',iunit) write(iunit,"(/,a)") '# density broken power law' - call write_inopt(rhof_rho0,'rhof_rho0','density at rad_min (in g/cm^3)',iunit) + call write_inopt(rhof_rho0,'rhof_rho0','density at rad_min (in g/cm^3) (-ve = ignore and calc for m_target)',iunit) + call write_inopt(m_target,'m_target','target mass in circumnuclear gas cloud (in Msun) (-ve = ignore and use rho0)',iunit) + call write_inopt(m_threshold,'m_threshold','threshold in solving rho0 for m_target (in Msun)',iunit) call write_inopt(nbreak,'nbreak','number of broken power laws',iunit) write(iunit,"(/,a)") '# section 1 (from rad_min)' call write_inopt(rhof_n(1),'rhof_n_1','power law index of the section',iunit) @@ -386,7 +492,9 @@ subroutine read_setupfile(filename,ierr) if (use_func) then call read_inopt(rad_min,'rad_min',db,min=ignore_radius,err=ierr) call read_inopt(rad_max,'rad_max',db,min=rad_min,err=ierr) - call read_inopt(rhof_rho0,'rhof_rho0',db,min=0.,err=ierr) + call read_inopt(rhof_rho0,'rhof_rho0',db,err=ierr) + call read_inopt(m_target,'m_target',db,err=ierr) + call read_inopt(m_threshold,'m_threshold',db,err=ierr) call read_inopt(nbreak,'nbreak',db,min=1,err=ierr) allocate(rhof_rbreak_in(in_num),rhof_n_in(in_num)) call read_inopt(rhof_n_in(1),'rhof_n_1',db,err=ierr) diff --git a/src/utils/phantomanalysis.f90 b/src/utils/phantomanalysis.f90 index a0b88c2d2..94ccc3695 100644 --- a/src/utils/phantomanalysis.f90 +++ b/src/utils/phantomanalysis.f90 @@ -14,8 +14,8 @@ program phantomanalysis ! ! :Usage: phantomanalysis dumpfile(s) ! -! :Dependencies: analysis, dim, eos, fileutils, infile_utils, io, kernel, -! part, readwrite_dumps +! :Dependencies: analysis, dim, eos, externalforces, fileutils, +! infile_utils, io, kernel, part, readwrite_dumps ! use dim, only:tagline,do_nucleation,inucleation use part, only:xyzh,hfact,massoftype,vxyzu,npart !,npartoftype @@ -26,6 +26,7 @@ program phantomanalysis use analysis, only:do_analysis,analysistype use eos, only:ieos use kernel, only:hfact_default + use externalforces, only:mass1,accradius1 implicit none integer :: nargs,iloc,ierr,iarg,i,idust_opacity real :: time @@ -76,6 +77,8 @@ program phantomanalysis do_nucleation = .true. inucleation = 1 endif + call read_inopt(mass1,'mass1',db,ierr) + call read_inopt(accradius1,'accradius1',db,ierr) call close_db(db) close(ianalysis) endif From cc61452d00a529f3c9f840bbeab7278f3952c22f Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 8 Jul 2024 10:10:04 +0100 Subject: [PATCH 693/814] Adds upstream changes --- build/Makefile_systems | 5 + src/main/eos_mesa_microphysics.f90 | 8 +- src/main/extern_gr.f90 | 2 +- src/main/externalforces_gr.f90 | 6 +- src/utils/analysis_tdeoutflow.f90 | 290 +++++++++++++++++++++++++++ src/utils/analysis_velocityshear.f90 | 16 +- src/utils/analysis_write_kdtree.F90 | 12 +- 7 files changed, 317 insertions(+), 22 deletions(-) create mode 100644 src/utils/analysis_tdeoutflow.f90 diff --git a/build/Makefile_systems b/build/Makefile_systems index d38bd096e..4a3c950f3 100644 --- a/build/Makefile_systems +++ b/build/Makefile_systems @@ -179,6 +179,11 @@ ifeq ($(SYSTEM), ifort) include Makefile_defaults_ifort endif +ifeq ($(SYSTEM), ifx) +# default settings for the new Intel Fortran Compiler + include Makefile_defaults_ifx +endif + ifeq ($(SYSTEM), ifortmac) # default settings for the Intel Fortran Compiler on Mac OS include Makefile_defaults_ifort diff --git a/src/main/eos_mesa_microphysics.f90 b/src/main/eos_mesa_microphysics.f90 index aa9268c13..903fef912 100644 --- a/src/main/eos_mesa_microphysics.f90 +++ b/src/main/eos_mesa_microphysics.f90 @@ -69,7 +69,7 @@ subroutine get_opacity_constants_mesa opacs_file = find_phantom_datafile(filename,'eos/mesa') ! Read the constants from the header of the opacity file - open(newunit=fnum, file=trim(opacs_file), status='old', action='read', form='unformatted') + open(newunit=fnum,file=trim(opacs_file),status='old',action='read',form='unformatted') read(fnum) mesa_opacs_nz,mesa_opacs_nx,mesa_opacs_nr,mesa_opacs_nt close(fnum) @@ -102,7 +102,7 @@ subroutine read_opacity_mesa(x,z) filename = trim(mesa_opacs_dir)//'opacs'//trim(mesa_opacs_suffix)//'.bindata' ! filename = trim(mesa_opacs_dir)//'/'//'opacs'//trim(mesa_opacs_suffix)//'.bindata' opacs_file = find_phantom_datafile(filename,'eos/mesa') - open(unit=fnum, file=trim(opacs_file), status='old', action='read', form='unformatted') + open(unit=fnum,file=trim(opacs_file),status='old',action='read',form='unformatted') read(fnum) mesa_opacs_nz,mesa_opacs_nx,mesa_opacs_nr,mesa_opacs_nt ! Read in the size of the table and the data @@ -308,7 +308,7 @@ subroutine get_eos_constants_mesa(ierr) filename = find_phantom_datafile(filename,'eos/mesa') ! Read constants from the header of first EoS tables - open(unit=fnum, file=trim(filename), status='old', action='read', form='unformatted',iostat=ierr) + open(unit=fnum,file=trim(filename),status='old',action='read',form='unformatted',iostat=ierr) if (ierr /= 0) return read(fnum) mesa_eos_ne, mesa_eos_nv, mesa_eos_nvar2 close(fnum) @@ -364,7 +364,7 @@ subroutine read_eos_mesa(x,z,ierr) ! Read in the size of the tables and the data ! i and j hold the Z and X values respectively ! k, l and m hold the values of V, Eint and the data respectively - open(unit=fnum, file=trim(filename), status='old', action='read', form='unformatted') + open(unit=fnum,file=trim(filename),status='old',action='read',form='unformatted') read(fnum) mesa_eos_ne, mesa_eos_nv, mesa_eos_nvar2 read(fnum)(mesa_eos_logVs(k),k=1,mesa_eos_nv) read(fnum)(mesa_eos_logEs(l),l=1,mesa_eos_ne) diff --git a/src/main/extern_gr.f90 b/src/main/extern_gr.f90 index 3d3aacdb2..7043299e2 100644 --- a/src/main/extern_gr.f90 +++ b/src/main/extern_gr.f90 @@ -13,7 +13,7 @@ module extern_gr ! Liptai & Price (2019), MNRAS 485, 819 ! Magnall, Price, Lasky & Macpherson (2023), Phys. Rev D. 108, 103534 ! -! :Owner: Spencer Magnall +! :Owner: David Liptai ! ! :Runtime parameters: None ! diff --git a/src/main/externalforces_gr.f90 b/src/main/externalforces_gr.f90 index 562660310..4219f96ae 100644 --- a/src/main/externalforces_gr.f90 +++ b/src/main/externalforces_gr.f90 @@ -27,7 +27,7 @@ module externalforces public :: accrete_particles,was_accreted public :: write_options_externalforces,read_options_externalforces public :: initialise_externalforces,is_velocity_dependent - public :: update_vdependent_extforce_leapfrog + public :: update_vdependent_extforce public :: update_externalforce public :: write_headeropts_extern,read_headeropts_extern @@ -124,7 +124,7 @@ end subroutine externalforce_vdependent ! necessary for using v-dependent forces in leapfrog !+ !----------------------------------------------------------------------- -subroutine update_vdependent_extforce_leapfrog(iexternalforce, & +subroutine update_vdependent_extforce(iexternalforce, & vhalfx,vhalfy,vhalfz,fxi,fyi,fzi,fexti,dt,xi,yi,zi,densi,ui) integer, intent(in) :: iexternalforce real, intent(in) :: dt,xi,yi,zi @@ -136,7 +136,7 @@ subroutine update_vdependent_extforce_leapfrog(iexternalforce, & ! ! This doesn't doesn't actually get used in gr... ! -end subroutine update_vdependent_extforce_leapfrog +end subroutine update_vdependent_extforce !----------------------------------------------------------------------- !+ diff --git a/src/utils/analysis_tdeoutflow.f90 b/src/utils/analysis_tdeoutflow.f90 new file mode 100644 index 000000000..3012ee514 --- /dev/null +++ b/src/utils/analysis_tdeoutflow.f90 @@ -0,0 +1,290 @@ +!--------------------------------------------------------------------------! +! 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 analysis +! +! Computes the outflow profile in a TDE simulation +! +! :References: None +! +! :Owner: Fitz) Hu +! +! :Runtime parameters: +! - phi_max : *max phi (in deg) (-ve = ignore)* +! - phi_min : *min phi (in deg) (-ve = ignore)* +! - r_in : *radius to count outflow (in cm)* +! - theta_max : *max theta (in deg) (-ve = ignore)* +! - theta_min : *min theta (in deg) (-ve = ignore)* +! +! :Dependencies: infile_utils, io, part, physcon, readwrite_dumps, units +! + implicit none + character(len=10), parameter, public :: analysistype = 'tdeoutflow' + public :: do_analysis + + private + + character(len=7) :: ana + real, dimension(:), allocatable :: rad_all,vr_all,v_all + real, dimension(:), allocatable :: theta,plot_theta,phi,vr,vtheta,vphi + logical, dimension(:), allocatable :: cap + real :: m_accum, m_cap + real :: vr_accum_mean, vr_accum_max, vr_cap_mean, vr_cap_max + real :: r_accum_maxv, r_cap_maxv + real :: v_accum_mean, v_cap_mean + real :: e_accum, e_cap + integer :: n_accum, n_cap + real :: shock_v, rad_min, rad_max, shock_e, shock_m!, shock_rho + real :: shock_v_tde, rad_min_tde, rad_max_tde, shock_e_tde, shock_m_tde!, shock_rho + real :: shock_v_cnm, rad_min_cnm, rad_max_cnm, shock_e_cnm, shock_m_cnm!, shock_rho + + !---- These can be changed in the params file + real :: rad_cap = 1.e16 ! radius where the outflow in captured (in cm) + real :: drad_cap = 4.7267e14 ! thickness of the shell to capture outflow (in cm) + real :: v_min = 0. + real :: v_max = 1. + real :: theta_min = -180. + real :: theta_max = 180. + real :: phi_min = -90. + real :: phi_max = 90. + + !--- shock detection global var + integer :: npart_cnm = -1, npart_tde, npart_tde_reserve=-1 + real, allocatable :: ent_bg(:) + logical, allocatable :: counted(:),accreted(:) + real :: told,r_in=1.e14 + logical :: first = .true. + +contains + +subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) + use readwrite_dumps, only: opened_full_dump + use units, only: udist,utime,unit_energ,umass!,unit_density + use physcon, only: solarm,days,c + use part, only: pxyzu + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: numfile,npart,iunit + real, intent(in) :: xyzh(:,:),vxyzu(:,:) + real, intent(in) :: pmass,time + character(len=120) :: output + character(len=30) :: filename,outfile + integer :: i,ierr,npart_new,npart_tde_old + logical :: iexist + real :: toMsun,todays,dt + real :: mout,vrout,vout,macc + + toMsun = umass/solarm + todays = utime/days + + if (.not.opened_full_dump) then + write(*,'("SKIPPING FILE -- (Not a full dump)")') + return + endif + +! Print the analysis being done + write(*,'(" Performing analysis type ",A)') analysistype + write(*,'(" Input file name is ",A)') dumpfile + + ! Read black hole mass from params file + filename = 'analysis_'//trim(analysistype)//'.params' + inquire(file=filename,exist=iexist) + if (iexist) call read_tdeparams(filename,ierr) + if (.not.iexist.or.ierr/=0) then + call write_tdeparams(filename) + print*,' Edit '//trim(filename)//' and rerun phantomanalysis' + stop + endif + + ! input to code unit + r_in = r_in / udist + + ! allocate memory + if (allocated(rad_all)) deallocate(rad_all(npart),vr_all(npart),v_all(npart)) + allocate(rad_all(npart),vr_all(npart),v_all(npart)) + call to_rad(npart,xyzh,vxyzu,rad_all,vr_all,v_all) + + write(*,'(a)') ' Analysing the outflow ...' + + print*, 'Counting outflow from', r_in + + if (first) then + allocate(counted(npart),accreted(npart)) + counted = .false. + accreted = .false. + mout = 0. + vrout = 0. + vout = 0. + macc = 0. + dt = 1. + else + call outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all,mout,vrout,vout,macc) + dt = time - told + endif + told = time + + outfile='outflow' + inquire(file=outfile,exist=iexist) + if (iexist .and. .not. first) then + open(iunit,file=outfile,status='old',access='append') + elseif (iexist) then + open(iunit,file=outfile,status='replace') + else + open(iunit,file=outfile,status='new') + endif + + if (first) then + write(iunit,"('#',5(1x,'[',i2.2,1x,a11,']',2x))") & + 1,'time [s]', & + 2,'mout [g/s]', & + 3,'vrout [cm/s]', & + 4,'vout [cm/s]', & + 5,'macc [g/s]' + endif + + write(iunit,'(5(es18.10,1X))') & + time*utime, & + mout/dt*umass/utime, & + vrout, & + vout, & + macc/dt*umass/utime + close(iunit) + first = .false. + +end subroutine do_analysis + +subroutine to_rad(npart,xyzh,vxyzu,rad,vr,v) + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:),vxyzu(:,:) + real, intent(out) :: rad(:),vr(:),v(:) + integer :: i + real :: xyz(1:3),vxyz(1:3) + + do i = 1,npart + xyz = xyzh(1:3,i) + vxyz = vxyzu(1:3,i) + rad(i) = sqrt(dot_product(xyz,xyz)) + vr(i) = dot_product(xyz,vxyz)/rad(i) + v(i) = sqrt(dot_product(vxyz,vxyz)) + enddo + +end subroutine to_rad +!-------------------------------------------------------------------------------------------------------------------- +! +!-- Actual subroutine where the analysis is done! +! +!-------------------------------------------------------------------------------------------------------------------- +subroutine outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all,mout,vrout,vout,macc) + use io, only: fatal + use part, only:isdead_or_accreted + integer, intent(in) :: npart + real, intent(in) :: pmass,xyzh(:,:),vxyzu(:,:),rad_all(:),vr_all(:),v_all(:) + real, intent(out) :: mout,vrout,vout,macc + integer :: i,nout,nacc + real :: ri,vi,x,y,z + real :: thetai,phii,vri + real :: vrsum,vsum + + nout = 0 + nacc = 0 + vrsum = 0. + vsum = 0. + + do i = 1,npart + ri = rad_all(i) + vi = v_all(i) + vri = vr_all(i) + if (isdead_or_accreted(xyzh(4,i))) then + nacc = nacc + 1 + accreted(i) = .true. + elseif (ri > r_in) then + if (.not. counted(i)) then + if (theta_min < -180. .or. theta_min > 180.) theta_min = -180. + if (theta_max < theta_min .or. theta_max > 180.) theta_max = 180. + if (phi_min < -90. .or. phi_min > 90.) phi_min = -90. + if (phi_max < phi_min .or. phi_max > 90.) phi_max = 90. + + x = xyzh(1,i) + y = xyzh(2,i) + z = xyzh(3,i) + thetai = atan2d(y,x) + phii = atan2d(z,sqrt(x**2+y**2)) + + if ((thetai >= theta_min .and. thetai <= theta_max) .and. (phii >= phi_min .and. phii <= phi_max)) then + nout = nout + 1 + vrsum = vrsum + vri + vsum = vsum + vi + endif + counted(i) = .true. + endif + else + counted(i) = .false. + endif + enddo + mout = nout * pmass + vrout = vrsum / nout + vout = vsum / nout + macc = nacc * pmass + +end subroutine outflow_analysis + +!---------------------------------------------------------------- +!+ +! Read/write tde information from/to params file +!+ +!---------------------------------------------------------------- +subroutine write_tdeparams(filename) + use infile_utils, only:write_inopt + character(len=*), intent(in) :: filename + integer, parameter :: iunit = 20 + + print "(a)",' writing analysis options file '//trim(filename) + open(unit=iunit,file=filename,status='replace',form='formatted') + write(iunit,"(a,/)") '# options when performing TDE outflow analysis' + + call write_inopt(r_in,'r_in','radius to count outflow (in cm)',iunit) + + call write_inopt(theta_min,'theta_min','min theta (in deg) (-ve = ignore)',iunit) + call write_inopt(theta_max,'theta_max','max theta (in deg) (-ve = ignore)',iunit) + + call write_inopt(phi_min,'phi_min','min phi (in deg) (-ve = ignore)',iunit) + call write_inopt(phi_max,'phi_max','max phi (in deg) (-ve = ignore)',iunit) + + close(iunit) + +end subroutine write_tdeparams + +subroutine read_tdeparams(filename,ierr) + use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db + use io, only:error + character(len=*), intent(in) :: filename + integer, intent(out) :: ierr + integer, parameter :: iunit = 21 + integer :: nerr + type(inopts), allocatable :: db(:) + + print "(a)",' reading analysis options from '//trim(filename) + nerr = 0 + ierr = 0 + call open_db_from_file(db,filename,iunit,ierr) + + call read_inopt(r_in,'r_in',db,min=0.,errcount=nerr) + + call read_inopt(theta_min,'theta_min',db,max=360.,errcount=nerr) + call read_inopt(theta_max,'theta_max',db,max=360.,errcount=nerr) + + call read_inopt(phi_min,'phi_min',db,max=180.,errcount=nerr) + call read_inopt(phi_max,'phi_max',db,max=180.,errcount=nerr) + + call close_db(db) + if (nerr > 0) then + print "(1x,i2,a)",nerr,' error(s) during read of params file: re-writing...' + ierr = nerr + endif + +end subroutine read_tdeparams + +end module analysis + diff --git a/src/utils/analysis_velocityshear.f90 b/src/utils/analysis_velocityshear.f90 index 16637d2d6..da5209758 100644 --- a/src/utils/analysis_velocityshear.f90 +++ b/src/utils/analysis_velocityshear.f90 @@ -70,11 +70,11 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! Check if a neighbour file is present - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh.eqv..true.) then - print*, 'Neighbour file ', TRIM(neighbourfile), ' found' + print*, 'Neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart) else @@ -158,8 +158,8 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) write(fmtstring, "('(I',I1,')')") ndigits write(numstring, fmtstring) num - valuefile = 'eig0'//TRIM(numstring) - vectorfile = 'evc0'//TRIM(numstring) + valuefile = 'eig0'//trim(numstring) + vectorfile = 'evc0'//trim(numstring) call write_eigenfiles(valuefile,vectorfile, iwrite) @@ -516,8 +516,8 @@ subroutine write_eigenfiles(valuefile,vectorfile, ngas) ! Write eigenvalues to file - print*, 'Writing eigenvalues to file ', TRIM(valuefile) - open(27,file=TRIM(valuefile), status='unknown',form='unformatted') + print*, 'Writing eigenvalues to file ', trim(valuefile) + open(27,file=trim(valuefile),status='unknown',form='unformatted') write(27) ngas write(27) (eigenpart(i),i=1,ngas) write(27) (xbin(i), i=1,ngas) @@ -529,8 +529,8 @@ subroutine write_eigenfiles(valuefile,vectorfile, ngas) close(27) ! Now write the eigenvectors to file - print*, 'Writing eigenvectors to file ', TRIM(vectorfile) - open(27,file=TRIM(vectorfile),status='unknown', form='unformatted') + print*, 'Writing eigenvectors to file ', trim(vectorfile) + open(27,file=trim(vectorfile),status='unknown',form='unformatted') write(27) ngas write(27) (eigenpart(i),i=1,ngas) write(27) (eigenvectors(1,1:3,i),i=1,ngas) diff --git a/src/utils/analysis_write_kdtree.F90 b/src/utils/analysis_write_kdtree.F90 index a185c915d..f27f4d623 100644 --- a/src/utils/analysis_write_kdtree.F90 +++ b/src/utils/analysis_write_kdtree.F90 @@ -78,8 +78,8 @@ subroutine write_kdtree_file(dumpfile) character(100) :: treefile integer :: icell - treefile = 'kdtree_'//TRIM(dumpfile) - print'(a,a)', 'Writing kdtree to binary file ', TRIM(treefile) + treefile = 'kdtree_'//trim(dumpfile) + print'(a,a)', 'Writing kdtree to binary file ', trim(treefile) ! Write tag indicating if this is from a run with or without gravity #ifdef GRAVITY @@ -90,7 +90,7 @@ subroutine write_kdtree_file(dumpfile) print '(a,a,I7)', 'This file does not contains masses: ', filetag, ncells #endif - open(10,file=treefile, form='unformatted') + open(10,file=treefile,form='unformatted') ! Write header data write(10) filetag, ncells @@ -131,10 +131,10 @@ subroutine read_kdtree_file(dumpfile) character(7) :: filetag character(100) :: treefile - treefile = 'kdtree_'//TRIM(dumpfile) - print'(a,a)', 'Reading kdtree from binary file ', TRIM(treefile) + treefile = 'kdtree_'//trim(dumpfile) + print'(a,a)', 'Reading kdtree from binary file ', trim(treefile) - open(10,file=treefile, form='unformatted') + open(10,file=treefile,form='unformatted') ! Read header read(10) filetag, ncells From 6913b19b5c37833351ac24b0460e1ac1c0e1da93 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 8 Jul 2024 10:15:09 +0100 Subject: [PATCH 694/814] Adds upstream changes --- src/main/forcing.F90 | 4 +- src/main/initial.F90 | 23 +- src/main/inject_BHL.f90 | 7 +- .../analysis_collidingcloudhistograms.f90 | 12 +- src/utils/analysis_dustywind.f90 | 348 ++++++++++++++++ src/utils/analysis_energies.f90 | 63 +++ src/utils/analysis_polytropes.f90 | 6 +- src/utils/analysis_prdrag.f90 | 6 +- src/utils/analysis_radiotde.f90 | 379 +++++++++++++----- 9 files changed, 734 insertions(+), 114 deletions(-) create mode 100644 src/utils/analysis_dustywind.f90 create mode 100644 src/utils/analysis_energies.f90 diff --git a/src/main/forcing.F90 b/src/main/forcing.F90 index 878e88f86..a0db37a7a 100644 --- a/src/main/forcing.F90 +++ b/src/main/forcing.F90 @@ -1076,8 +1076,8 @@ subroutine read_stirring_data_from_file(infile, time, timeinfile) my_file = find_phantom_datafile(infile,'forcing') - open (unit=42, file=my_file, iostat=ierr, status='old', action='read', & - access='sequential', form='unformatted') + open(unit=42,file=my_file,iostat=ierr,status='old',action='read', & + access='sequential',form='unformatted') ! header contains number of times and number of modes, end time, autocorrelation time, ... if (ierr==0) then if (Debug) write (*,'(A)') 'reading header...' diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 314b72644..4c9a97aa2 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -22,7 +22,7 @@ module initial ! krome_interface, linklist, metric_tools, mf_write, mpibalance, ! mpidomain, mpimemory, mpitree, mpiutils, nicil, nicil_sup, omputils, ! options, part, partinject, porosity, ptmass, radiation_utils, -! readwrite_dumps, readwrite_infile, timestep, timestep_ind, +! readwrite_dumps, readwrite_infile, subgroup, timestep, timestep_ind, ! timestep_sts, timing, tmunu2grid, units, writeheader ! @@ -127,10 +127,11 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,Bevol,dBevol,tau, tau_lucy, & npartoftype,maxtypes,ndusttypes,alphaind,ntot,ndim,update_npartoftypetot,& maxphase,iphase,isetphase,iamtype,igas,idust,imu,igamma,massoftype, & - nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& + 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, & - Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx + Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx, & + n_group,n_ingroup,n_sing,nmatrix,group_info use part, only:pxyzu,dens,metrics,rad,radprop,drad,ithick use densityforce, only:densityiterate use linklist, only:set_linklist @@ -150,7 +151,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use nicil_sup, only:use_consistent_gmw use ptmass, only:init_ptmass,get_accel_sink_gas,get_accel_sink_sink, & h_acc,r_crit,r_crit2,rho_crit,rho_crit_cgs,icreate_sinks, & - r_merge_uncond,r_merge_cond,r_merge_uncond2,r_merge_cond2,r_merge2 + r_merge_uncond,r_merge_cond,r_merge_uncond2,r_merge_cond2,r_merge2, & + use_regnbody use timestep, only:time,dt,dtextforce,C_force,dtmax,dtmax_user,idtmax_n use timing, only:get_timings use timestep_ind, only:ibinnow,maxbins,init_ibin,istepfrac @@ -210,6 +212,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use fileutils, only:make_tags_unique use damping, only:idamp + use subgroup, only:group_identify character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile logical, intent(in), optional :: noread @@ -495,10 +498,15 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass - ! compute initial sink-sink forces and get timestep - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& + iexternalforce,time,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) + else + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& iexternalforce,time,merge_ij,merge_n,dsdt_ptmass) + endif dtsinksink = C_force*dtsinksink if (id==master) write(iprint,*) 'dt(sink-sink) = ',dtsinksink dtextforce = min(dtextforce,dtsinksink) @@ -538,6 +546,9 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) if (r_merge_uncond < 2.0*h_acc) then write(iprint,*) ' WARNING! Sink creation is on, but but merging is off! Suggest setting r_merge_uncond >= 2.0*h_acc' endif + dsdt_ptmass = 0. ! could introduce NaN in ptmass spins if not initialised (no get_accel done before creating sink) + fxyz_ptmass = 0. + fxyz_ptmass_sinksink = 0. endif if (abs(time) <= tiny(0.)) then !initialize nucleation array at the start of the run only diff --git a/src/main/inject_BHL.f90 b/src/main/inject_BHL.f90 index 860dcf058..a23162cc0 100644 --- a/src/main/inject_BHL.f90 +++ b/src/main/inject_BHL.f90 @@ -30,7 +30,7 @@ module inject character(len=*), parameter, public :: inject_type = 'BHL' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par ! !--runtime settings for this module ! @@ -261,6 +261,11 @@ subroutine inject_or_update_particles(ifirst, n, position, velocity, h, u, bound end subroutine inject_or_update_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file diff --git a/src/utils/analysis_collidingcloudhistograms.f90 b/src/utils/analysis_collidingcloudhistograms.f90 index c17daaddb..11345d4ce 100644 --- a/src/utils/analysis_collidingcloudhistograms.f90 +++ b/src/utils/analysis_collidingcloudhistograms.f90 @@ -63,8 +63,8 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! ! Initialise values & Open file ! - fileoutSV = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_SinkVel.dat' - fileoutSA = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_SinkAverages.dat' + fileoutSV = trim(dumpfile(1:index(dumpfile,'_')-1))//'_SinkVel.dat' + fileoutSA = trim(dumpfile(1:index(dumpfile,'_')-1))//'_SinkAverages.dat' inquire(file=fileoutSV,exist=iexist) if ( .not.iexist .or. firstcall ) then firstcall = .false. @@ -117,7 +117,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) 7,'vy', & 8,'vz' do k = 1,nres - write(fileoutSH,'(2a,I3.3,a)') trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_SinkHisto',nbins(k),'.dat' + write(fileoutSH,'(2a,I3.3,a)') trim(dumpfile(1:index(dumpfile,'_')-1)),'_SinkHisto',nbins(k),'.dat' open(iunit+(2*k+1),file=fileoutSH,status='replace') write(iunit+(2*k+1),"('#',10(1x,'[',i2.2,1x,a11,']',2x))") & 1,'idump', & @@ -130,7 +130,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) 8,'N velx', & 9,'N vely', & 10,'N velz' - write(fileoutGH,'(2a,I3.3,a)') trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_GasHisto',nbins(k),'.dat' + write(fileoutGH,'(2a,I3.3,a)') trim(dumpfile(1:index(dumpfile,'_')-1)),'_GasHisto',nbins(k),'.dat' open(iunit+(2*k+2),file=fileoutGH,status='replace') write(iunit+(2*k+2),"('#',10(1x,'[',i2.2,1x,a11,']',2x))") & 1,'idump', & @@ -162,8 +162,8 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) open(iunit ,file=fileoutSV,position='append') open(iunit+20,file=fileoutSA,position='append') do k = 1,nres - write(fileoutSH,'(2a,I3.3,a)') trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_SinkHisto',nbins(k),'.dat' - write(fileoutGH,'(2a,I3.3,a)') trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_GasHisto',nbins(k),'.dat' + write(fileoutSH,'(2a,I3.3,a)') trim(dumpfile(1:index(dumpfile,'_')-1)),'_SinkHisto',nbins(k),'.dat' + write(fileoutGH,'(2a,I3.3,a)') trim(dumpfile(1:index(dumpfile,'_')-1)),'_GasHisto',nbins(k),'.dat' open(iunit+(2*k+1),file=fileoutSH,position='append') open(iunit+(2*k+2),file=fileoutGH,position='append') enddo diff --git a/src/utils/analysis_dustywind.f90 b/src/utils/analysis_dustywind.f90 new file mode 100644 index 000000000..74f071edb --- /dev/null +++ b/src/utils/analysis_dustywind.f90 @@ -0,0 +1,348 @@ +!--------------------------------------------------------------------------! +! 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 analysis +! +! Analysis routine for dusty wind testing +! +! :References: None +! +! :Owner: Lionel Siess +! +! :Runtime parameters: None +! +! :Dependencies: dim, dust_formation, kernel, part, units +! + + implicit none + character(len=20), parameter, public :: analysistype = 'dustywind' + + public :: do_analysis + + private + integer, parameter :: N = 1024 !32 + real, parameter :: theta = 0., phi = 0. + real, parameter :: u(3) = (/ sin(theta)*cos(phi), sin(theta)*sin(phi), cos(theta) /) + +contains + +subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) + + use part, only: nptmass,xyzmh_ptmass,vxyz_ptmass,iLum,iTeff,iReff + use part, only: dust_temp,isdead_or_accreted,nucleation + use dust_formation, only: set_abundances + + !general variables + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: num,npart,iunit + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real, intent(in) :: particlemass,time + + real :: L_star,T_star,R_star,xa,ya,za + integer :: j + + call set_abundances + !property of the sink particle + j = 1 + T_star = xyzmh_ptmass(iTeff,j) + L_star = xyzmh_ptmass(iLum,j) + R_star = xyzmh_ptmass(iReff,j) !sqrt(L_star/(4.*pi*steboltz*utime**3/umass*R_star**4)) + xa = xyzmh_ptmass(1,j) + ya = xyzmh_ptmass(2,j) + za = xyzmh_ptmass(3,j) + call get_Teq_from_Lucy(npart,xyzh,xa,ya,za,R_star,T_star,dust_temp) + + +end subroutine do_analysis + +!------------------------------------------------------------------------------- +!+ +! Calculates the radiative equilibrium temperature using the Lucy approximation +! Performs ray-tracing along 1 direction (could be generalized to include other directions) +!+ +!------------------------------------------------------------------------------- +subroutine get_Teq_from_Lucy(npart,xyzh,xa,ya,za,R_star,T_star,dust_temp) + use part, only:isdead_or_accreted,nucleation,idK3 + use dim, only:do_nucleation + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:),xa,ya,za,R_star,T_star + real, intent(out) :: dust_temp(:) + real :: r(3),r0(3),d,dmin,dmax,d2_axis,OR(N),Teq(N),K3(N),rho_over_r2(2*N+1),rho(N) + integer :: i,idx_axis(npart),naxis + + !.. find particles that lie within 2 smoothing lengths of the ray axis + r0(1:3) = (/xa, ya, za/) + dmin = 1.d99 + dmax = 0 + naxis = 0 +!$omp parallel do default(none) & +!$omp shared(npart,xyzh,r0,naxis,idx_axis) & +!$omp private(i,r,d,d2_axis) & +!$omp reduction(min:dmin) & +!$omp reduction(max:dmax) + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + r = xyzh(1:3,i)-r0 + !d = r(1)**2+r(2)**2+r(3)**2 + d = dot_product(r,r) + dmin = min(d,dmin) + dmax = max(d,dmax) + !distance to the axis + !d2_axis = sq_distance_to_z(r) + d2_axis = sq_distance_to_line(r,u) + if (d2_axis < 4.*xyzh(4,i)*xyzh(4,i)) then + !$omp critical (crit_naxis_add) + naxis = naxis+1 + idx_axis(naxis) = i + !$omp end critical (crit_naxis_add) + endif + endif + enddo +!$omp end parallel do + dmin = sqrt(dmin) + dmax = sqrt(dmax) + + + if (do_nucleation) then + call density_along_line(npart, xyzh, r0, naxis, idx_axis, -dmax, dmax, R_star, N, rho, & + rho_over_r2, dust_temp, Teq, nucleation(idK3,:), K3) + call calculate_Teq(N, dmax, R_star, T_star, rho, rho_over_r2, OR, Teq, K3) + else + call density_along_line(npart, xyzh, r0, naxis, idx_axis, -dmax, dmax, R_star, N, rho, & + rho_over_r2, dust_temp, Teq) + call calculate_Teq(N, dmax, R_star, T_star, rho, rho_over_r2, OR, Teq) + endif + call interpolate_on_particles(npart, N, dmax, r0, Teq, dust_temp, xyzh) + +end subroutine get_Teq_from_Lucy + +!-------------------------------------------------------------------------- +!+ +! Calculates the radiative equilibrium temperature along the ray direction +!+ +!-------------------------------------------------------------------------- +subroutine calculate_Teq(N, dmax, R_star, T_star, rho, rho_over_r2, OR, Teq, K3) + use dust_formation, only : calc_kappa_dust,calc_kappa_bowen,idust_opacity + integer, intent(in) :: N + real, intent(in) :: dmax, R_star, T_star, rho(N), rho_over_r2(2*N+1) + real, optional, intent(in) :: K3(N) + real, intent(out) :: Teq(N) + + real :: OR(N),tau_prime(N),vTeq(N),kappa(N),dTeq,pTeq(N) + real :: dr, fact, rho_on_r2(N) + real, parameter :: tol = 1.d-2, kap_gas = 2.d-4 + integer :: i,istart,iter + + + tau_prime = 0. + iter = 0 + vTeq = 0. + dTeq = 1. + dr = dmax/N + forall(i=1:N) OR(i) = i*dr + OR(N) = dmax + fact = dr/2. * R_star**2 + do i = 1,N + if (OR(i) > R_star) exit + enddo + istart = i-1 + if (istart > 0) Teq(1:istart) = T_star + Teq(istart+1:N) = T_star*(0.5*(1.-sqrt(1.-(R_star/OR(istart+1:N))**2))) + vTeq = Teq + pTeq= Teq + rho_on_r2 = 0. + kappa = 0. + + do while (dTeq > tol .and. iter < 20) + if (iter == 0) dTeq = 0. + iter = iter+1 + do i=N-1,istart+1,-1 + if (idust_opacity == 2) then + if (rho(i) > 0.) then + kappa(i) = calc_kappa_dust(K3(i),Teq(i),rho(i)) + else + kappa(i) = 0.d0 + endif + elseif (idust_opacity == 1) then + kappa(i) = calc_kappa_bowen(Teq(i)) + endif + rho_on_r2(i) = rho_over_r2(N-i)+rho_over_r2(N-i+1)+rho_over_r2(N+i+1)+rho_over_r2(N+i+2) + !if (iter >= 1) print *,'teq loop',i,K3(i),Teq(i),kappa(i),rho_on_r2(i) + tau_prime(i) = tau_prime(i+1) + fact*(kappa(i)+kap_gas) *rho_on_r2(i) + + Teq(i) = T_star*(0.5*(1.-sqrt(1.-(R_star/OR(i))**2)) + 0.75*tau_prime(i))**(1./4.) + dTeq = max(dTeq,abs(1.-Teq(i)/(1.d-5+vTeq(i)))) + vTeq(i) = Teq(i) + enddo + print *,iter,dTeq + enddo + print *,iter + open(unit=220,file='Teq.dat') + write(220,*) '# ng z vTeq Teq tau kappa rho_on_r2' + do i = 1,N + write(220,*) i,OR(i),pTeq(i),Teq(i),tau_prime(i),kappa(i),rho_on_r2(i) + enddo + close(220) + +end subroutine calculate_Teq + +!----------------------------------------------------------------------- +!+ +! compute the mean properties along the ray +!+ +!----------------------------------------------------------------------- +subroutine density_along_line(npart, xyzh, r0, npart_axis, idx_axis, rmin, rmax, r_star, N, & + rho_cgs, rho_over_r2, T, Teq, K3, K3i) + use kernel, only:cnormk,wkern + use part, only:massoftype,igas,rhoh + use units, only:unit_density + integer, intent(in) :: npart,N + real, intent(in) :: xyzh(:,:), T(:), r0(3) + real, optional, intent(in) :: K3(:) + integer, intent(in) :: npart_axis, idx_axis(npart) + real, intent(in) :: rmin, rmax, R_star + real, intent(out) :: rho_over_r2(2*N+1), Teq(N), rho_cgs(N) + real, optional, intent(out) :: K3i(N) + real :: rhoi(2*N+1), OR(2*N+1), Ti(2*N+1), Ki(2*N+1), xnorm(2*N+1) + real :: OH, d2_axis, HR, q2, q, fact0, fact, h, h2, part_mass + real :: delta_r, rmin_o, rmin_p, rmax_p, dr, r(3), xfact, rhoinv + integer :: i, np, j, j_min, j_max, Nr + +! Discretization of the line of sight in N segments + Nr = 2*N+1 + dr = (rmax-rmin)/(Nr-1) + rmin_o = rmin - dr + do i=1,Nr + OR(i) = dr*i+rmin_o + print *,i,OR(i),R_star + enddo + print *,'*******',rmax,rmin,r_star + + open(unit=220,file='allpart.dat') + write(220,*) '# ng x y z rho T K' + do i = 1, npart + write (220,*) np,xyzh(1:3,i)-r0(3),rhoh(xyzh(4,i),part_mass),T(i),K3(i) + enddo + close(220) + rhoi(:) = 0. + Teq(:) = 0. + K3i(:) = 0. + Ki(:) = 0. + Ti(:) = 0. + xnorm(:) = 0. + part_mass = massoftype(igas) + fact0 = part_mass*cnormk + open(unit=221,file='part_axis.dat') + write(221,*) '# ng x y z rho T K' + do i = 1, npart_axis + np = idx_axis(i) + r = xyzh(1:3,np)-r0(3) + !distance to z-axis + !OH = r(3) + !d2_axis = sq_distance_to_z(r) + OH = dot_product(r,u) + d2_axis = sq_distance_to_line(r,u) + h = xyzh(4,np) + h2 = h*h + delta_r = sqrt(4.*h2 - d2_axis) + ! rmin_p and rmax_p are the positions on the line of the two intersections between the line and the interaction sphere + rmin_p = OH-delta_r + rmax_p = OH+delta_r + j_min = ceiling((rmin_p-rmin_o)/dr) + j_max = floor((rmax_p-rmin_o)/dr) + j_min = max(1, j_min) + j_max = min(Nr, j_max) + ! Adds the contribution of particle np to density at all the discretized locations in the interaction sphere + fact = fact0/h**3 + rhoinv = 1./rhoh(h,part_mass) + write (221,*) np,r,rhoh(h,part_mass),T(np),K3(np) + do j=j_min, j_max + HR = OR(j) - OH + q2 = (d2_axis+HR**2)/h2 + q = sqrt(q2) + xfact = fact*wkern(q2,q) + rhoi(j) = rhoi(j) + xfact + xnorm(j) = xnorm(j)+xfact*rhoinv + Ti(j) = Ti(j) + xfact*rhoinv*T(np) + if (present(K3)) Ki(j) = Ki(j) + xfact*rhoinv*K3(np) + !print *,j,Ti(j),T(np),part_mass/(rhoh(h,part_mass)*h**3)!rhoh(h,part_mass),part_mass,q,fact,wkern(q2,q) + enddo + enddo + close (221) +! rho_over_r2 = 0 inside the star so that we do not divide by zero! + open(unit=222,file='ray.dat') + write(222,*) '# ng z rho T K xnorm rho_over_r2' + do j=1,Nr + if (xnorm(j) > 0.) then + Ti(j) = Ti(j)/xnorm(j) + if (present(K3)) Ki(j) = Ki(j) /xnorm(j) + endif + if (abs(OR(j)) < r_star) then + rho_over_r2(j) = 0. + else + rho_over_r2(j) = rhoi(j)/OR(j)**2 + endif + print *,j,rho_over_r2(j) + write (222,*) j,OR(j),rhoi(j),Ti(j),Ki(j),xnorm(j),rho_over_r2(j) + enddo + close(222) + do j=1,N + rho_cgs(N+1-j) = (rhoi(j)+rhoi(2*N-j+2))*unit_density/2. + Teq(N+1-j) = (Ti(j)+Ti(2*N-j+2))/2. + if (present(K3)) K3i(N+1-j) = (Ki(j)+Ki(2*N-j+2))/2. +! print *,'k3i',j,k3i(j) + enddo + +end subroutine density_along_line + +!----------------------------------------------------------------------- +!+ +! Interpolates a quantity computed on the discretized line of sight for all SPH particles +! (spherical symmetry assumed) +!+ +!----------------------------------------------------------------------- +subroutine interpolate_on_particles(npart, N, dmax, r0, Teq, dust_temp, xyzh) + use part, only:isdead_or_accreted + integer, intent(in) :: npart, N + real, intent(in) :: dmax, r0(3), Teq(N), xyzh(:,:) + real, intent(out) :: dust_temp(:) + + real :: r(3), d, dr, d2 + integer :: i, j + + dr = dmax / N + !should start at nwall + do i=1,npart + if (.not.isdead_or_accreted(xyzh(4,i))) then + r = xyzh(1:3,i) - r0 + d2 = dot_product(r,r) + d = sqrt(d2) + j = min(int(d/dr),N-1) + dust_temp(i) = (d-dr*j)*(Teq(j+1)-Teq(j))/dr + Teq(j) + endif + enddo + open(unit=220,file='all_final.dat') + write(220,*) '# ng x y z T' + do i = 1, npart + write (220,*) i,xyzh(1:3,i)-r0(3),dust_temp(i) + enddo + close(220) +end subroutine interpolate_on_particles + +real function sq_distance_to_z(r) + real, intent(in) :: r(3) + sq_distance_to_z = r(1)*r(1)+r(2)*r(2) +end function sq_distance_to_z + +real function sq_distance_to_line(r,u) + real, intent(in) :: r(3),u(3) + real :: p,d(3) + p = dot_product(r,u) + d = r-p*u + sq_distance_to_line = dot_product(d,d) +end function sq_distance_to_line + +end module analysis diff --git a/src/utils/analysis_energies.f90 b/src/utils/analysis_energies.f90 new file mode 100644 index 000000000..4d4288b74 --- /dev/null +++ b/src/utils/analysis_energies.f90 @@ -0,0 +1,63 @@ +!--------------------------------------------------------------------------! +! 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 analysis +! +! Analysis routine computing the energy accounting for accreted +! particles +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: energies, evwrite, metric_tools, options, part +! + implicit none + character(len=20), parameter, public :: analysistype = 'energies' + public :: do_analysis + + logical, private :: first = .true. + private + +contains + +subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) + use energies, only:compute_energies,track_mass,ekin,emag,etherm,epot,etot,& + eacc,etotall,totmom,angtot,angall + use metric_tools, only:init_metric + use part, only:metrics,metricderivs,gr + use evwrite, only:init_evfile + use options, only:iexternalforce + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: num,npart,iunit + real, intent(in) :: xyzh(:,:),vxyzu(:,:) + real, intent(in) :: particlemass,time + + if (gr) then + call init_metric(npart,xyzh,metrics,metricderivs) + iexternalforce = 1 + endif + if (first) then + call init_evfile(1,'crap.ev',open_file=.false.) + endif + track_mass = .true. + call compute_energies(time) + + if (first) then + open(unit=1,file='energies.ev',status='new',action='write') + write(1,"(a)") '# time,ekin,etherm,emag,epot,etot,eacc,etot+eacc,totmom,angtot,etotall,angall' + first = .false. + endif + write(1,*) time,ekin,etherm,emag,epot,etot,eacc,etot+eacc,totmom,angtot,etotall,angall + + print*,' TOTAL ENERGY IS: ',etot + print*,' TOTAL ENERGY INCLUDING ACCRETION: ',etotall + +end subroutine do_analysis + +end module analysis diff --git a/src/utils/analysis_polytropes.f90 b/src/utils/analysis_polytropes.f90 index bd0c57df8..c112085a3 100644 --- a/src/utils/analysis_polytropes.f90 +++ b/src/utils/analysis_polytropes.f90 @@ -61,7 +61,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) character(len=200) :: fileout ! !--from .setup, determine if binary or not - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'.setup' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'.setup' inquire(file=fileout,exist=iexist) if ( iexist ) then write(*,'(2a)') "reading setup file: ",trim(fileout) @@ -78,7 +78,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) if ( binary ) then ! !--Open file (appendif exists) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_centres.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_centres.dat' inquire(file=fileout,exist=iexist) if ( .not.iexist .or. firstcall ) then open(iunit,file=fileout,status='replace') @@ -252,7 +252,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! !--print period tracking to file (overwriting anything in existance) if ( binary ) then - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_period.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_period.dat' fileout=trim(fileout) open(iunit,file=fileout) write(iunit,"('#',4(1x,'[',i2.2,1x,a11,']',2x))") & diff --git a/src/utils/analysis_prdrag.f90 b/src/utils/analysis_prdrag.f90 index 14160df8a..8372c5c23 100644 --- a/src/utils/analysis_prdrag.f90 +++ b/src/utils/analysis_prdrag.f90 @@ -48,7 +48,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) real :: r1, r2 print*,' Hello Hauke, time in file = ',time - open( unit=106, file='radial.out', status='replace', iostat=ierr) + open( unit=106,file='radial.out',status='replace', iostat=ierr) if ( ierr /= 0 ) stop 'error opening radial.out' call make_beta_grids( xyzh, particlemass, npart ) @@ -67,7 +67,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) enddo close( 106 ) - open( unit=106, file='radialinterp.out', status='replace', iostat=ierr) + open( unit=106,file='radialinterp.out',status='replace', iostat=ierr) if ( ierr /= 0 ) stop 'error opening radialinterp.out' write(106,*), "#r_rad rbin theta thetabin r_cyl z rho tau beta" @@ -93,7 +93,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) close(106) - open( unit=106, file='applied.out', status='replace', iostat=ierr) + open( unit=106,file='applied.out',status='replace', iostat=ierr) if ( ierr /= 0 ) stop 'error opening applied.out' write(106,*), "#x y z r_cyl beta r_bin th_bin" diff --git a/src/utils/analysis_radiotde.f90 b/src/utils/analysis_radiotde.f90 index bef969001..918e8473b 100644 --- a/src/utils/analysis_radiotde.f90 +++ b/src/utils/analysis_radiotde.f90 @@ -14,6 +14,7 @@ module analysis ! ! :Runtime parameters: ! - drad_cap : *capture thickness (in cm) (-ve for all particles at outer radius)* +! - npart_tde : *npart in tde sims (-ve=10*npart of cnm)* ! - phi_max : *max phi (in deg)* ! - phi_min : *min phi (in deg)* ! - rad_cap : *capture inner radius (in cm)* @@ -22,7 +23,7 @@ module analysis ! - v_max : *max velocity (in c)* ! - v_min : *min velocity (in c)* ! -! :Dependencies: infile_utils, io, physcon, readwrite_dumps, units +! :Dependencies: infile_utils, io, part, physcon, readwrite_dumps, units ! implicit none character(len=8), parameter, public :: analysistype = 'radiotde' @@ -30,8 +31,19 @@ module analysis private + character(len=7) :: ana + real, dimension(:), allocatable :: rad_all,vr_all,v_all real, dimension(:), allocatable :: theta,plot_theta,phi,vr,vtheta,vphi logical, dimension(:), allocatable :: cap + real :: m_accum, m_cap + real :: vr_accum_mean, vr_accum_max, vr_cap_mean, vr_cap_max + real :: r_accum_maxv, r_cap_maxv + real :: v_accum_mean, v_cap_mean + real :: e_accum, e_cap + integer :: n_accum, n_cap + real :: shock_v, rad_min, rad_max, shock_e, shock_m!, shock_rho + real :: shock_v_tde, rad_min_tde, rad_max_tde, shock_e_tde, shock_m_tde!, shock_rho + real :: shock_v_cnm, rad_min_cnm, rad_max_cnm, shock_e_cnm, shock_m_cnm!, shock_rho !---- These can be changed in the params file real :: rad_cap = 1.e16 ! radius where the outflow in captured (in cm) @@ -42,22 +54,25 @@ module analysis real :: theta_max = 180. real :: phi_min = -90. real :: phi_max = 90. - real :: m_accum, m_cap, vr_accum_mean, vr_cap_mean, v_accum_mean, v_cap_mean, e_accum, e_cap - integer :: n_accum, n_cap + + !--- shock detection global var + integer :: npart_cnm = -1, npart_tde, npart_tde_reserve=-1 + real, allocatable :: ent_bg(:) contains subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) use readwrite_dumps, only: opened_full_dump - use units, only: utime,udist,unit_energ,umass + use units, only: utime,udist,unit_energ,umass!,unit_density use physcon, only: solarm,days + use part, only: pxyzu character(len=*), intent(in) :: dumpfile integer, intent(in) :: numfile,npart,iunit real, intent(in) :: xyzh(:,:),vxyzu(:,:) real, intent(in) :: pmass,time character(len=120) :: output character(len=30) :: filename - integer :: i,ierr + integer :: i,ierr,npart_new,npart_tde_old logical :: iexist real :: toMsun,todays @@ -67,6 +82,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) n_cap = 0 e_accum = 0. e_cap = 0. + ana = 'shock' toMsun = umass/solarm todays = utime/days @@ -77,11 +93,8 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) endif ! Print the analysis being done - write(*,'("Performing analysis type ",A)') analysistype - write(*,'("Input file name is ",A)') dumpfile - - write(output,"(a8,i5.5)") 'outflow_',numfile - write(*,'("Output file name is ",A)') output + write(*,'(" Performing analysis type ",A)') analysistype + write(*,'(" Input file name is ",A)') dumpfile ! Read black hole mass from params file filename = 'analysis_'//trim(analysistype)//'.params' @@ -93,81 +106,157 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) stop endif - rad_cap = rad_cap/udist - if (drad_cap < 0.) then - drad_cap = huge(0.) - else - drad_cap = drad_cap/udist + ! read background entropy + if (npart_cnm < 0) then + if (npart_tde_reserve < 0) npart_tde_reserve = 10*npart + allocate(ent_bg(npart_tde_reserve+npart)) ! save more memory for later injection + npart_cnm = npart + call record_background(pxyzu(4,:),0,npart,ent_bg) + write(*,'(I9,1x,a16)') npart_cnm, 'particles in CNM' endif - print*, 'Capture particles from', rad_cap, 'to', rad_cap+drad_cap - - allocate(theta(npart),plot_theta(npart),phi(npart),vr(npart),vtheta(npart),vphi(npart),cap(npart)) - cap = .false. - - call tde_analysis(npart,pmass,xyzh,vxyzu) - - if (n_cap > 0) then - open(iunit,file=output) - write(iunit,'("# ",es20.12," # TIME")') time - write(iunit,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & - 1,'theta', & - 2,'thetap', & - 3,'phi', & - 4,'vr', & - 5,'vtheta', & - 6,'vphi' - - do i = 1,npart - if (cap(i)) then - write(iunit,'(6(es18.10,1X))') & - theta(i), & - plot_theta(i), & - phi(i), & - vr(i), & - vtheta(i), & - vphi(i) - endif - enddo +! not meaningful and will not do anything if cut-and-put + npart_tde_old = npart_tde + npart_tde = npart - npart_cnm + npart_new = npart_tde - npart_tde_old + if (npart_new > 0) call record_background(pxyzu(4,:),npart_tde_old+npart_cnm,npart_new,ent_bg) + + ! allocate memory + allocate(rad_all(npart),vr_all(npart),v_all(npart)) + call to_rad(npart,xyzh,vxyzu,rad_all,vr_all,v_all) + + select case (trim(ana)) + case ('outflow') + write(*,'(a)') ' Analysing the outflow ...' + write(output,"(a8,i5.5)") 'outflow_',numfile + write(*,'(" Output file name is ",A)') output + + rad_cap = rad_cap/udist + if (drad_cap < 0.) then + drad_cap = huge(0.) + else + drad_cap = drad_cap/udist + endif + print*, 'Capture particles from', rad_cap, 'to', rad_cap+drad_cap + + allocate(theta(npart),plot_theta(npart),phi(npart),vr(npart),vtheta(npart), & + vphi(npart),cap(npart)) + cap = .false. + + call outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all) + + if (n_cap > 0) then + open(iunit,file=output) + write(iunit,'("# ",es20.12," # TIME")') time + write(iunit,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & + 1,'theta', & + 2,'thetap', & + 3,'phi', & + 4,'vr', & + 5,'vtheta', & + 6,'vphi' + + do i = 1,npart + if (cap(i)) then + write(iunit,'(6(es18.10,1X))') & + theta(i), & + plot_theta(i), & + phi(i), & + vr(i), & + vtheta(i), & + vphi(i) + endif + enddo + close(iunit) + endif + + deallocate(theta,plot_theta,phi,vr,vtheta,vphi,cap,rad_all,vr_all,v_all) + + inquire(file='outflows',exist=iexist) + if (iexist) then + open(iunit,file='outflows',status='old',position='append') + else + open(iunit,file='outflows',status='new') + write(iunit,'(14(A,1X))') '#', 'time', 'm_cap[msun]', 'm_accum[msun]', 'vr_accum_mean[c]', 'vr_accum_max[c]', & + 'r_accum_maxv[cm]', 'vr_cap_mean[c]', 'vr_cap_max[c]', 'r_cap_maxv[cm]', & + 'v_accum_mean[c]', 'v_cap_mean[c]', 'e_accum[erg]', 'e_cap[erg]' + endif + write(iunit,'(13(es18.10,1x))') & + time*todays, & + m_cap*toMsun, & + m_accum*toMsun, & + vr_accum_mean, & + vr_accum_max, & + r_accum_maxv*udist, & + vr_cap_mean, & + vr_cap_max, & + r_cap_maxv*udist, & + v_accum_mean, & + v_cap_mean, & + e_accum*unit_energ, & + e_cap*unit_energ close(iunit) - endif - deallocate(theta,plot_theta,phi,vr,vtheta,vphi,cap) + write(*,'(I8,1X,A2,1X,I8,1X,A34)') n_cap, 'of', npart, 'particles are in the capture shell' + write(*,'(I8,1X,A2,1X,I8,1X,A40)') n_accum, 'of', npart, 'particles are outside the capture radius' - inquire(file='outflows',exist=iexist) - if (iexist) then - open(iunit,file='outflows',status='old',position='append') - else - open(iunit,file='outflows',status='new') - write(iunit,'(9(A15,1X))') '# time', 'm_cap[msun]', 'm_accum[msun]', 'vr_accum_mean[c]', 'vr_cap_mean[c]', & - 'v_accum_mean[c]', 'v_cap_mean[c]', 'e_accum[erg]', 'e_cap[erg]' - endif - write(iunit,'(9(es18.10,1x))') & - time*todays, & - m_cap*toMsun, & - m_accum*toMsun, & - vr_accum_mean, & - vr_cap_mean, & - v_accum_mean, & - v_cap_mean, & - e_accum*unit_energ, & - e_cap*unit_energ - close(iunit) + case ('shock') + write(*,'(a)') ' Analysing the shock ...' - write(*,'(I8,1X,A2,1X,I8,1X,A34)') n_cap, 'of', npart, 'particles are in the capture shell' - write(*,'(I8,1X,A2,1X,I8,1X,A40)') n_accum, 'of', npart, 'particles are outside the capture radius' + call shock_analysis(npart,pmass,rad_all,vr_all,pxyzu(4,:)) + + deallocate(rad_all,vr_all,v_all) + + inquire(file='shock',exist=iexist) + if (iexist) then + open(iunit,file='shock',status='old',position='append') + else + open(iunit,file='shock',status='new') + write(iunit,'(17(A,1x))') '#', 'time', 'rad_min[cm]', 'rad_max[cm]', 'velocity[c]', 'mass[Msun]', 'energy[erg]', & !'density[g/cm-3]' + 'rad_min_tde[cm]', 'rad_max_tde[cm]', 'vel_tde[c]', 'mass_tde[Msun]', 'ene_tde[erg]', & + 'rad_min_cnm[cm]', 'rad_max_cnm[cm]', 'vel_cnm[c]', 'mass_cnm[Msun]', 'ene_cnm[erg]' + endif + if (rad_max > 0.) then + write(iunit,'(16(es18.10,1x))') & + time*todays, & + rad_min*udist, rad_max*udist, shock_v, shock_m*umass/solarm, shock_e*unit_energ, & + rad_min_tde*udist, rad_max_tde*udist, shock_v_tde, shock_m_tde*umass/solarm, shock_e_tde*unit_energ, & + rad_min_cnm*udist, rad_max_cnm*udist, shock_v_cnm, shock_m_cnm*umass/solarm, shock_e_cnm*unit_energ !shock_rho*unit_density + endif + close(iunit) + + case default + write(*,'(a)') " Unknown analysis type. Do 'outflow' or 'shock'" + stop + end select end subroutine do_analysis +subroutine to_rad(npart,xyzh,vxyzu,rad,vr,v) + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:),vxyzu(:,:) + real, intent(out) :: rad(:),vr(:),v(:) + integer :: i + real :: xyz(1:3),vxyz(1:3) + + do i = 1,npart + xyz = xyzh(1:3,i) + vxyz = vxyzu(1:3,i) + rad(i) = sqrt(dot_product(xyz,xyz)) + vr(i) = dot_product(xyz,vxyz)/rad(i) + v(i) = sqrt(dot_product(vxyz,vxyz)) + enddo + +end subroutine to_rad !-------------------------------------------------------------------------------------------------------------------- ! !-- Actual subroutine where the analysis is done! ! !-------------------------------------------------------------------------------------------------------------------- -subroutine tde_analysis(npart,pmass,xyzh,vxyzu) +subroutine outflow_analysis(npart,pmass,xyzh,vxyzu,rad_all,vr_all,v_all) integer, intent(in) :: npart - real, intent(in) :: pmass,xyzh(:,:),vxyzu(:,:) + real, intent(in) :: pmass,xyzh(:,:),vxyzu(:,:),rad_all(:),vr_all(:),v_all(:) integer :: i - real :: r,v,x,y,z,xyz(1:3),vx,vy,vz,vxyz(1:3) + real :: r,v,x,y,z,vx,vy,vz real :: thetai,phii,vri real :: vr_accum_add,vr_cap_add,v_accum_add,v_cap_add @@ -175,25 +264,29 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) vr_cap_add = 0. v_accum_add = 0. v_cap_add = 0. + vr_accum_max = 0. + vr_cap_max = 0. do i = 1,npart x = xyzh(1,i) y = xyzh(2,i) z = xyzh(3,i) - xyz = (/x,y,z/) vx = vxyzu(1,i) vy = vxyzu(2,i) vz = vxyzu(3,i) - vxyz = (/vx,vy,vz/) - r = sqrt(dot_product(xyz,xyz)) - v = sqrt(dot_product(vxyz,vxyz)) + r = rad_all(i) + v = v_all(i) if (r > rad_cap) then m_accum = m_accum + pmass n_accum = n_accum + 1 e_accum = e_accum + 0.5*pmass*v**2 - vri = dot_product(vxyz,xyz)/r + vri = vr_all(i) vr_accum_add = vr_accum_add + vri v_accum_add = v_accum_add + v + if (vri > vr_accum_max) then + vr_accum_max = vri + r_accum_maxv = r + endif if (r-rad_cap < drad_cap .and. (v >= v_min .and. v <= v_max)) then thetai = atan2d(y,x) phii = atan2d(z,sqrt(x**2+y**2)) @@ -210,6 +303,10 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) e_cap = e_cap + 0.5*pmass*v**2 vr_cap_add = vr_cap_add + vri v_cap_add = v_cap_add + v + if (vri > vr_cap_max) then + vr_cap_max = vri + r_cap_maxv = r + endif endif endif endif @@ -219,7 +316,88 @@ subroutine tde_analysis(npart,pmass,xyzh,vxyzu) vr_cap_mean = vr_cap_add/n_cap v_cap_mean = v_cap_add/n_cap -end subroutine tde_analysis +end subroutine outflow_analysis + +subroutine record_background(ent,npart_old,npart_new,ent_bg) + real, intent(in) :: ent(:) + integer, intent(in) :: npart_old,npart_new + real, intent(inout) :: ent_bg(:) + integer, parameter :: iunit=235 + integer :: i + + print*, 'Record background entropy of ', npart_new, ' particles' + + do i=1,npart_new + ent_bg(npart_old+i) = ent(npart_old+i)*1.1 ! give some range for self evolution + !(is there a reasonable choice instead of arbitrary?) + enddo + +end subroutine record_background + +subroutine shock_analysis(npart,pmass,rad_all,vr_all,ent) + use units, only: udist + use physcon, only: au,pi + integer, intent(in) :: npart + real, intent(in) :: pmass,rad_all(:),vr_all(:),ent(:) + integer :: i,n,n_cnm,n_tde + real :: ri,half_m,ei,vi + ! + !------Determine the shock + ! + n = 0 + n_cnm = 0. + n_tde = 0. + shock_e = 0. + shock_e_cnm = 0. + shock_e_tde = 0. + shock_v = 0. ! take max vel + shock_v_cnm = 0. + shock_v_tde = 0. + rad_max = 0. + rad_max_cnm = 0. + rad_max_tde = 0. + rad_min = huge(0.) + rad_min_cnm = huge(0.) + rad_min_tde = huge(0.) + half_m = pmass*0.5 + + do i = 1,npart + if (ent(i) > ent_bg(i)) then + ri = rad_all(i) + vi = vr_all(i) + ei = half_m*vi**2 + n = n + 1 + if (vi > shock_v) shock_v = vi + if (ri < rad_min) rad_min = ri + if (ri > rad_max) rad_max = ri + shock_e = shock_e + ei + + if (i > npart_cnm) then + ! tde outflow + n_tde = n_tde + 1 + if (vi > shock_v_tde) shock_v_tde = vi + if (ri < rad_min_tde) rad_min_tde = ri + if (ri > rad_max_tde) rad_max_tde = ri + shock_e_tde = shock_e_tde + ei + else + ! cnm + n_cnm = n_cnm + 1 + if (vi > shock_v_cnm) shock_v_cnm = vi + if (ri < rad_min_cnm) rad_min_cnm = ri + if (ri > rad_max_cnm) rad_max_cnm = ri + shock_e_cnm = shock_e_cnm + ei + endif + endif + enddo + + write(*,'(a14,1x,es8.1,1x,a5,1x,es8.1,1x,a2)') ' Shock is from', rad_min*udist/au, 'au to', rad_max*udist/au, 'au' + + shock_m = shock_e*2./shock_v**2 !pmass*n + shock_m_cnm = shock_e_cnm*2./shock_v_cnm**2 !pmass*n_cnm + shock_m_tde = shock_e_tde*2./shock_v_tde**2 !pmass*n_tde + !shock_rho = shock_m*4./3.*pi*(rad_max**3-rad_min**3) + +end subroutine shock_analysis !---------------------------------------------------------------- !+ @@ -234,18 +412,25 @@ subroutine write_tdeparams(filename) print "(a)",' writing analysis options file '//trim(filename) open(unit=iunit,file=filename,status='replace',form='formatted') write(iunit,"(a,/)") '# options when performing radio TDE analysis' + call write_inopt(ana,'analysis',"analysis type: 'outflow' or 'shock'",iunit) - call write_inopt(rad_cap,'rad_cap','capture inner radius (in cm)',iunit) - call write_inopt(drad_cap,'drad_cap','capture thickness (in cm) (-ve for all particles at outer radius)',iunit) + select case (trim(ana)) + case ('outflow') + call write_inopt(rad_cap,'rad_cap','capture inner radius (in cm)',iunit) + call write_inopt(drad_cap,'drad_cap','capture thickness (in cm) (-ve for all particles at outer radius)',iunit) - call write_inopt(v_min,'v_min','min velocity (in c)',iunit) - call write_inopt(v_max,'v_max','max velocity (in c)',iunit) + call write_inopt(v_min,'v_min','min velocity (in c)',iunit) + call write_inopt(v_max,'v_max','max velocity (in c)',iunit) - call write_inopt(theta_min,'theta_min','min theta (in deg)',iunit) - call write_inopt(theta_max,'theta_max','max theta (in deg)',iunit) + call write_inopt(theta_min,'theta_min','min theta (in deg)',iunit) + call write_inopt(theta_max,'theta_max','max theta (in deg)',iunit) - call write_inopt(phi_min,'phi_min','min phi (in deg)',iunit) - call write_inopt(phi_max,'phi_max','max phi (in deg)',iunit) + call write_inopt(phi_min,'phi_min','min phi (in deg)',iunit) + call write_inopt(phi_max,'phi_max','max phi (in deg)',iunit) + case ('shock') + call write_inopt(npart_tde_reserve,'npart_tde','npart in tde sims (-ve=10*npart of cnm)',iunit) + case default + end select close(iunit) @@ -260,22 +445,30 @@ subroutine read_tdeparams(filename,ierr) integer :: nerr type(inopts), allocatable :: db(:) - print "(a)",'reading analysis options from '//trim(filename) + print "(a)",' reading analysis options from '//trim(filename) nerr = 0 ierr = 0 call open_db_from_file(db,filename,iunit,ierr) - call read_inopt(rad_cap,'rad_cap',db,min=0.,errcount=nerr) - call read_inopt(drad_cap,'drad_cap',db,errcount=nerr) + call read_inopt(ana,'analysis',db,errcount=nerr) + + select case (trim(ana)) + case ('outflow') + call read_inopt(rad_cap,'rad_cap',db,min=0.,errcount=nerr) + call read_inopt(drad_cap,'drad_cap',db,errcount=nerr) - call read_inopt(v_min,'v_min',db,min=0.,max=1.,errcount=nerr) - call read_inopt(v_max,'v_max',db,min=0.,max=1.,errcount=nerr) + call read_inopt(v_min,'v_min',db,min=0.,max=1.,errcount=nerr) + call read_inopt(v_max,'v_max',db,min=0.,max=1.,errcount=nerr) - call read_inopt(theta_min,'theta_min',db,min=-180.,max=180.,errcount=nerr) - call read_inopt(theta_max,'theta_max',db,min=-180.,max=180.,errcount=nerr) + call read_inopt(theta_min,'theta_min',db,min=-180.,max=180.,errcount=nerr) + call read_inopt(theta_max,'theta_max',db,min=-180.,max=180.,errcount=nerr) - call read_inopt(phi_min,'phi_min',db,min=-90.,max=90.,errcount=nerr) - call read_inopt(phi_max,'phi_max',db,min=-90.,max=90.,errcount=nerr) + call read_inopt(phi_min,'phi_min',db,min=-90.,max=90.,errcount=nerr) + call read_inopt(phi_max,'phi_max',db,min=-90.,max=90.,errcount=nerr) + case ('shock') + call read_inopt(npart_tde_reserve,'npart_tde',db,errcount=nerr) + case default + end select call close_db(db) if (nerr > 0) then From 9de0709d36bf41547bac589a1eda1a4e2790a515 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Jul 2024 13:47:19 +0200 Subject: [PATCH 695/814] (ptmass) COM correction after creating a star --- src/main/ptmass.F90 | 35 ++++++++++++++++++++++++++++------- 1 file changed, 28 insertions(+), 7 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 046e94475..3b757f902 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1670,7 +1670,7 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas real :: xi(3),vi(3) integer :: k,n,l real :: mi,hacci,minmass,mcutoff - real :: a(8),velk,rk,xk(3),vk(3),rvir + real :: a(8),velk,rk,xk(3),vk(3),xcom(3),vcom(3),rvir write(iprint,"(a,es18.10)") "ptmass_create_stars : new stars formed at : ",time @@ -1731,15 +1731,15 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas xyzmh_ptmass(ihacc,k) = hacci*1.e-3 xyzmh_ptmass(ihsoft,k) = h_soft_sinkgas xyzmh_ptmass(4,k) = masses(n) - xyzmh_ptmass(3,k) = xi(3) + xk(3) - xyzmh_ptmass(2,k) = xi(2) + xk(2) - xyzmh_ptmass(1,k) = xi(1) + xk(1) + xyzmh_ptmass(3,k) = xk(3) + xyzmh_ptmass(2,k) = xk(2) + xyzmh_ptmass(1,k) = xk(1) xyzmh_ptmass(ispinx,k) = 0. ! xyzmh_ptmass(ispiny,k) = 0. ! -- No spin for the instant xyzmh_ptmass(ispinz,k) = 0. ! - vxyz_ptmass(1,k) = vi(1) + vk(1) - vxyz_ptmass(2,k) = vi(2) + vk(2) - vxyz_ptmass(3,k) = vi(3) + vk(3) + vxyz_ptmass(1,k) = vk(1) + vxyz_ptmass(2,k) = vk(2) + vxyz_ptmass(3,k) = vk(3) fxyz_ptmass(1:4,k) = 0. fxyz_ptmass_sinksink(1:4,k) = 0. if (iH2R > 0) call update_ionrate(k,xyzmh_ptmass,h_acc) @@ -1747,6 +1747,27 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas k = linklist_ptmass(k) ! acces to the next point mass in the linked list n = n - 1 enddo + k = itest + do while(k>0) + xcom(1) = xyzmh_ptmass(4,k)*xyzmh_ptmass(1,k) + xcom(2) = xyzmh_ptmass(4,k)*xyzmh_ptmass(2,k) + xcom(3) = xyzmh_ptmass(4,k)*xyzmh_ptmass(3,k) + vcom(1) = xyzmh_ptmass(4,k)*vxyz_ptmass(1,k) + vcom(2) = xyzmh_ptmass(4,k)*vxyz_ptmass(2,k) + vcom(3) = xyzmh_ptmass(4,k)*vxyz_ptmass(3,k) + k = linklist_ptmass(k) ! acces to the next point mass in the linked list + enddo + + k = itest + do while(k>0) + xyzmh_ptmass(1,k) = xyzmh_ptmass(1,k) - xcom(1) + xi(1) + xyzmh_ptmass(2,k) = xyzmh_ptmass(2,k) - xcom(2) + xi(2) + xyzmh_ptmass(3,k) = xyzmh_ptmass(3,k) - xcom(3) + xi(3) + vxyz_ptmass(1,k) = vxyz_ptmass(1,k) - vcom(1) + vi(1) + vxyz_ptmass(2,k) = vxyz_ptmass(2,k) - vcom(2) + vi(2) + vxyz_ptmass(3,k) = vxyz_ptmass(3,k) - vcom(3) + vi(3) + k = linklist_ptmass(k) ! acces to the next point mass in the linked list + enddo deallocate(masses) From 236548f6239f5f9cd8e155a77e88c615bc26958e Mon Sep 17 00:00:00 2001 From: Madeline Nicole Overton Date: Tue, 9 Jul 2024 11:34:27 -0700 Subject: [PATCH 696/814] add inject_randomwind.f90 name change asteroidwind --- src/main/inject_randomwind.f90 | 222 +++++++++++++++++++++++++++++++++ 1 file changed, 222 insertions(+) create mode 100644 src/main/inject_randomwind.f90 diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 new file mode 100644 index 000000000..8bf8e9355 --- /dev/null +++ b/src/main/inject_randomwind.f90 @@ -0,0 +1,222 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.bitbucket.io/ ! +!--------------------------------------------------------------------------! +module inject +! +! None +! +! :References: None +! +! :Owner: David Liptai +! +! :Runtime parameters: +! - mdot : *mass injection rate in grams/second* +! - mdot_type : *injection rate (0=const, 1=cos(t), 2=r^(-2))* +! - npartperorbit : *particle injection rate in particles/binary orbit* +! - vlag : *percentage lag in velocity of wind* +! +! :Dependencies: binaryutils, externalforces, infile_utils, io, options, +! part, partinject, physcon, random, units +! + use io, only:error + use physcon, only:pi + implicit none + character(len=*), parameter, public :: inject_type = 'randomwind' + real, public :: mdot = 5.e8 ! mass injection rate in grams/second + real,save :: dndt_scaling ! scaling to get ninject correct + + public :: init_inject,inject_particles,write_options_inject,read_options_inject + + private + + real :: npartperorbit = 1000. ! particle injection rate in particles per orbit + real :: vlag = 0.0 ! percentage lag in velocity of wind + integer :: mdot_type = 2 ! injection rate (0=const, 1=cos(t), 2=r^(-2)) + logical,save :: scaling_set ! has the scaling been set (initially false) + +contains +!----------------------------------------------------------------------- +!+ +! Initialize global variables or arrays needed for injection routine +!+ +!----------------------------------------------------------------------- +subroutine init_inject(ierr) + integer, intent(inout) :: ierr + + scaling_set = .false. + + ierr = 0 + +end subroutine init_inject + +!----------------------------------------------------------------------- +!+ +! Inject particles +!+ +!----------------------------------------------------------------------- +subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + npart,npartoftype,dtinject) + use io, only:fatal + use part, only:nptmass,massoftype,igas,hfact,ihsoft + use partinject, only:add_or_update_particle + use physcon, only:twopi,gg,kboltz,mass_proton_cgs + use random, only:get_random_pos_on_sphere + use units, only:umass, utime + use options, only:iexternalforce + use externalforces,only:mass1 + use binaryutils, only:get_orbit_bits + real, intent(in) :: time, dtlast + real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) + integer, intent(inout) :: npart + integer, intent(inout) :: npartoftype(:) + real, intent(out) :: dtinject + real, dimension(3) :: xyz,vxyz,r1,r2,v2,vhat,v1 + integer :: i,ipart,npinject,seed,pt + real :: dmdt,robject,h,u,speed,inject_this_step + real :: m1,m2,r + real :: dt + real, save :: have_injected,t_old + real, save :: semia + + if (nptmass < 2 .and. iexternalforce == 0) call fatal('inject_randomwind','not enough point masses for random wind injection') + if (nptmass > 2) call fatal('inject_randomwind','too many point masses for random wind injection') + + if (nptmass == 2) then + pt = 2 + r1 = xyzmh_ptmass(1:3,1) + m1 = xyzmh_ptmass(4,1) + v1 = vxyz_ptmass(1:3,1) + else + pt = 1 + r1 = 0. + m1 = mass1 + v1 = 0. + endif + + r2 = xyzmh_ptmass(1:3,pt) + robject = xyzmh_ptmass(ihsoft,pt) + m2 = xyzmh_ptmass(4,pt) + v2 = vxyz_ptmass(1:3,pt) + + speed = sqrt(dot_product(v2,v2)) + vhat = v2/speed + + r = sqrt(dot_product(r1-r2,r1-r2)) + +! +! Add any dependency on radius to mass injection rate (and convert to code units) +! + dmdt = mdot*mdot_func(r,semia)/(umass/utime) ! Use semi-major axis as r_ref + +!-- How many particles do we need to inject? +! (Seems to need at least eight gas particles to not crash) <-- This statement may or may not be true... +! + if (npartoftype(igas)<8) then + npinject = 8-npartoftype(igas) + else + ! Calculate how many extra particles from previous step to now + dt = time - t_old + inject_this_step = dt*mdot/massoftype(igas)/(umass/utime) + + npinject = max(0, int(0.5 + have_injected + inject_this_step - npartoftype(igas) )) + + ! Save for next step (faster than integrating the whole thing each time) + t_old = time + have_injected = have_injected + inject_this_step + endif + +!-- Randomly inject particles around the asteroids outer 'radius' +! + do i=1,npinject + xyz = r2 + robject*get_random_pos_on_sphere(seed) + vxyz = (1.-vlag/100)*speed*vhat + u = 0. ! setup is isothermal so utherm is not stored + h = hfact*(robject/2.) + ipart = npart + 1 + call add_or_update_particle(igas,xyz,vxyz,h,u,ipart,npart,npartoftype,xyzh,vxyzu) + enddo + + ! + !-- no constraint on timestep + ! + dtinject = huge(dtinject) + +end subroutine inject_particles + +!----------------------------------------------------------------------- +!+ +! Returns dndt(t) depending on which function is chosen +! Note that time in this function is strictly the fraction +! of the orbit, not absolute time +!+ +!----------------------------------------------------------------------- + +real function mdot_func(r,r_ref) + real, intent(in) :: r,r_ref + + select case (mdot_type) + case (2) + mdot_func = (r_ref/r)**2 + case default + mdot_func = 1.0 + end select + +end function mdot_func + +!----------------------------------------------------------------------- +!+ +! Writes input options to the input file. +!+ +!----------------------------------------------------------------------- +subroutine write_options_inject(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + call write_inopt(mdot ,'mdot' ,'mass injection rate in grams/second' ,iunit) + call write_inopt(npartperorbit,'npartperorbit','particle injection rate in particles/binary orbit',iunit) + call write_inopt(vlag ,'vlag' ,'percentage lag in velocity of wind' ,iunit) + call write_inopt(mdot_type ,'mdot_type' ,'injection rate (0=const, 1=cos(t), 2=r^(-2))' ,iunit) + +end subroutine write_options_inject + +!----------------------------------------------------------------------- +!+ +! Reads input options from the input file. +!+ +!----------------------------------------------------------------------- +subroutine read_options_inject(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_inject' + + imatch = .true. + select case(trim(name)) + case('mdot') + read(valstring,*,iostat=ierr) mdot + ngot = ngot + 1 + if (mdot < 0.) call fatal(label,'mdot < 0 in input options') + case('npartperorbit') + read(valstring,*,iostat=ierr) npartperorbit + ngot = ngot + 1 + if (npartperorbit < 0.) call fatal(label,'npartperorbit < 0 in input options') + case('vlag') + read(valstring,*,iostat=ierr) vlag + ngot = ngot + 1 + case('mdot_type') + read(valstring,*,iostat=ierr) mdot_type + ngot = ngot + 1 + case default + imatch = .false. + end select + + igotall = (ngot >= 1) + +end subroutine read_options_inject + +end module inject From 25f0c6043b631f00644e205dd2bd49f9f1749f0a Mon Sep 17 00:00:00 2001 From: Madeline Nicole Overton Date: Tue, 9 Jul 2024 12:00:04 -0700 Subject: [PATCH 697/814] remove *asteroidwind* from Makefile_setups --- build/Makefile_setups | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/build/Makefile_setups b/build/Makefile_setups index d5f34b9a5..5b875708a 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -74,10 +74,10 @@ ifeq ($(SETUP), wddisc) DUST=yes endif -ifeq ($(SETUP), asteroidwind) -# asteroid emitting a wind (Trevascus et al. 2021) +ifeq ($(SETUP), randomwind) +# object emitting a wind (Trevascus et al. 2021) SETUPFILE=setup_asteroidwind.f90 - SRCINJECT=utils_binary.f90 inject_asteroidwind.f90 + SRCINJECT=utils_binary.f90 inject_randomwind.f90 IND_TIMESTEPS=yes CONST_AV=yes ISOTHERMAL=yes From 32604f2bb93fe68730237aea8c6b6b64c17b6bd3 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Jul 2024 09:59:11 +0200 Subject: [PATCH 698/814] (ptmass) fix a bug that bricked the sim if cores are not enough massive --- src/main/random.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/random.f90 b/src/main/random.f90 index 32d1e7d53..566b4fc47 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -173,7 +173,7 @@ subroutine divide_unit_seg(lengths,mindist,nlengths,iseed) integer, intent(in) :: nlengths integer, intent(inout) :: iseed real, intent(inout) :: lengths(nlengths) - real, intent(in) :: mindist + real, intent(inout) :: mindist real, allocatable :: points(:) integer, allocatable :: idx(:) integer :: i,j @@ -186,6 +186,11 @@ subroutine divide_unit_seg(lengths,mindist,nlengths,iseed) points(1) = 0. tmp = 0. + if (mindist > 1./nlengths) then ! override the minimum distance if we are in a bricked situation... + mindist = (1./(nlengths+1)) ! we'll have stars less massive than 0.08 solarmasses but it will assure to never brick the sim... + endif + + do i=2,nlengths close = .true. do while (close) From 8bbb6a85eb607696414c4f20df07ebb27afc4b95 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Jul 2024 10:02:58 +0200 Subject: [PATCH 699/814] (ptmass) forgot to normalise the COM var --- src/main/ptmass.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 3b757f902..81c0f8d76 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1758,6 +1758,9 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas k = linklist_ptmass(k) ! acces to the next point mass in the linked list enddo + xcom = xcom/mi + vcom = vcom/mi + k = itest do while(k>0) xyzmh_ptmass(1,k) = xyzmh_ptmass(1,k) - xcom(1) + xi(1) From 03403c8b22f59958c1bb6c85ad92e9f7fdd27bd3 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 10 Jul 2024 17:23:25 +0100 Subject: [PATCH 700/814] Calling cooling_radapprox from evolve.f90 --- src/main/cooling_radapprox.f90 | 41 ++++++++++++++------------- src/main/deriv.F90 | 27 ++++-------------- src/main/evolve.F90 | 31 +++++++++++++++++++-- src/main/step_leapfrog.F90 | 51 +++++++++++++++++----------------- 4 files changed, 81 insertions(+), 69 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index fea45fdfd..774c237d7 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -62,7 +62,7 @@ end subroutine init_star ! ! Do cooling calculation ! -! update energy to return evolved energy array. +! update energy to return evolved energy array. Called from evolve.F90 subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) use io, only:warning use physcon, only:steboltz,pi,solarl,Rg,kb_on_mh,piontwo,rpiontwo @@ -90,8 +90,9 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) !$omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot) & !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb) overpart: do i=1,npart - if (.not. iactive(iphase(i)) ) cycle - if (isdead_or_accreted(xyzh(4,i)) ) cycle + if (.not. iactive(iphase(i)) .or. isdead_or_accreted(xyzh(4,i)) ) then + dudt_sph(i) = 0d0 + endif poti = Gpot_cool(i) du_FLDi = duFLD(i) ui = energ(i) @@ -154,11 +155,12 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) dudti_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/opaci/unit_ergg*utime! code units ! If radiative cooling is negligible compared to hydrodynamical heating - ! don't use this method to update energy, just use hydro du/dt (don't zero - ! fxyzu(4,i) ). + ! don't use this method to update energy, just use hydro du/dt if (abs(dudti_rad/dudt_sph(i)) < dtcool_crit) then ! print *, "not cooling/heating for r=",sqrt(ri2),".", dudti_rad,& -! dudt_sph(i) + ! dudt_sph(i) + energ(i) = ui + dudt_sph(i)*dt + dudt_sph(i) = 0d0 cycle endif @@ -179,11 +181,11 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) endif teqi_store(i) = Teqi -! if (Teqi > 1e6) 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 * dt=", dudt_sph(i)*dt -! endif + 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 * dt=", dudt_sph(i)*dt + endif call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) ueqi = ueqi/unit_ergg @@ -225,14 +227,15 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) enddo overpart !$omp end parallel do - n_uevo = 0 - !$omp parallel do default(none) & - !$omp shared(dudt_sph,npart) private(i) reduction(+:n_uevo) - do i=1, npart - if (dudt_sph(i) /= 0d0) n_uevo = n_uevo + 1 - enddo - !$omp end parallel do - print *, "energy not evolved with cooling for", n_uevo, "particles" + !n_uevo = 0 + !!$omp parallel do default(none) & + !!$omp shared(dudt_sph,npart) private(i) reduction(+:n_uevo) + !do i=1, npart + ! if (dudt_sph(i) /= 0d0) n_uevo = n_uevo + 1 + ! dudt_sph(i) = 0d0 + !enddo + !!$omp end parallel do +! print *, "energy not evolved with cooling for", n_uevo, "particles" ! print *, "min/max dudt_sph():", minval(dudt_sph), maxval(dudt_sph) end subroutine radcool_update_energ diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index 0294d04f8..4bbab4bdf 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -14,10 +14,10 @@ module deriv ! ! :Runtime parameters: None ! -! :Dependencies: cons2prim, densityforce, derivutils, dim, dust_formation, -! externalforces, forces, forcing, growth, io, linklist, metric_tools, -! options, part, porosity, ptmass, ptmass_radiation, radiation_implicit, -! timestep, timestep_ind, timing +! :Dependencies: cons2prim, densityforce, derivutils, dim, externalforces, +! forces, forcing, growth, io, linklist, metric_tools, options, part, +! porosity, ptmass, ptmass_radiation, radiation_implicit, timestep, +! timestep_ind, timing ! implicit none @@ -61,9 +61,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& use cons2prim, only:cons2primall,cons2prim_everything use metric_tools, only:init_metric use radiation_implicit, only:do_radiation_implicit,ierr_failed_to_converge - use options, only:implicit_radiation,implicit_radiation_store_drad,use_porosity,icooling - use cooling_radapprox, only:radcool_update_energ - use cooling, only:Tfloor + use options, only:implicit_radiation,implicit_radiation_store_drad,use_porosity integer, intent(in) :: icall integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -182,11 +180,6 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& if (use_porosity) call get_probastick(npart,xyzh,ddustprop(1,:),dustprop,dustgasprop,filfac) endif -! -! update energy if using radiative cooling approx (icooling=9) -! - if (icooling == 9 .and. dt > 0.0 .and. icall==1) call radcool_update_energ(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) - ! ! compute dust temperature ! @@ -202,16 +195,6 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& enddo !$omp end parallel do endif - -! Set dudt to zero because we evolved energy already for icooling=9 - if (icooling == 9 .and. icall==1) then - !$omp parallel do shared(fxyzu,npart) private(i) - do i=1,npart - fxyzu(4,i) = 0. - enddo - !$omp end parallel do - endif - ! ! set new timestep from Courant/forces condition ! diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 92c22f776..a823bd1bc 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -77,10 +77,12 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) use partinject, only:update_injected_particles #endif use dim, only:do_radiation - use options, only:exchange_radiation_energy,implicit_radiation + use options, only:exchange_radiation_energy,implicit_radiation,icooling use part, only:rad,radprop use radiation_utils, only:update_radenergy use timestep, only:dtrad + use cooling, only:Tfloor + use cooling_radapprox,only:radcool_update_energ #ifdef LIVE_ANALYSIS use analysis, only:do_analysis use part, only:igas @@ -89,7 +91,8 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) #endif 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, & + iphase,iactive use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & set_integration_precision @@ -137,7 +140,9 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) logical :: use_global_dt integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold character(len=120) :: dumpfile_orig - + integer :: imax + real :: umax + tprint = 0. nsteps = 0 nsteplast = 0 @@ -284,6 +289,20 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (do_radiation .and. exchange_radiation_energy .and. .not.implicit_radiation) then call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) endif + + if (icooling == 9) then + write (*,*) "Before step", maxval(vxyzu(4,:)),minval(vxyzu(4,:)) + umax = 0d0 + do i=1, npart + if (vxyzu(4,i) > umax) then + umax = vxyzu(4,i) + imax = i + endif + enddo + print *, "max i=", imax, iactive(iphase(i)), fxyzu(4,i) + call radcool_update_energ(dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) + write (*,*) " ",maxval(vxyzu(4,:)),minval(vxyzu(4,:)), fxyzu(4,i) + endif nsteps = nsteps + 1 ! !--evolve data for one timestep @@ -302,6 +321,12 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) endif +! if (icooling == 9) then + ! write (*,*) "after step",maxval(vxyzu(4,:)),minval(vxyzu(4,:)) +! call radcool_update_energ(0.5*dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) + ! write (*,*) " ",maxval(vxyzu(4,:)),minval(vxyzu(4,:)) + ! endif + dtlast = dt !--timings for step call diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index a1dd9939b..a5eccbc54 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -127,7 +127,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use eos, only:equationofstate use substepping, only:substep,substep_gr, & substep_sph_gr,substep_sph - + integer, intent(inout) :: npart integer, intent(in) :: nactive real, intent(in) :: t,dtsph @@ -172,7 +172,7 @@ 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) & !$omp shared(mprev,filfacprev,filfac,use_porosity) & !$omp shared(ibin,ibin_old,twas,timei) & !$omp firstprivate(itype) & @@ -199,11 +199,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif - !Alison - !if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L202", fxyzu(4,i) !--floor the thermal energy if requested and required - if (ufloor > 0. .and. icooling /= 9) then + if (ufloor > 0.) then if (vxyzu(4,i) < ufloor) then vxyzu(4,i) = ufloor nvfloorp = nvfloorp + 1 @@ -233,7 +231,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif - +! print *, "line 234", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) !---------------------------------------------------------------------- ! substepping with external and sink particle forces, using dtextforce @@ -251,7 +249,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) 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,& + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& dptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info, & nmatrix,n_group,n_ingroup,n_sing) else @@ -275,7 +273,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) & !$omp shared(twas,timei) & !$omp shared(rad,drad,radpred)& !$omp private(hi,rhoi,tdecay1,source,ddenom,hdti) & @@ -326,7 +324,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L324", fxyzu(4,i) !--floor the thermal energy if requested and required - if (ufloor > 0. .and. icooling /= 9) then + if (ufloor > 0.) then if (vpred(4,i) < ufloor) then vpred(4,i) = ufloor nvfloorps = nvfloorps + 1 @@ -387,13 +385,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (npart > 0) then if (gr) vpred = vxyzu ! Need primitive utherm as a guess in cons2prim 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) - if (do_radiation .and. implicit_radiation) then! .or. icooling == 9) then + if (do_radiation .and. implicit_radiation) then rad = radpred vxyzu(4,1:npart) = vpred(4,1:npart) endif @@ -407,6 +404,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call fatal('step','step too small: bin would exceed maximum') endif endif +! print *, "line 407", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) ! ! if using super-timestepping, determine what dt will be used on the next loop ! @@ -422,6 +420,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! any extra iterations, but to be reversible for velocity-dependent ! forces we must iterate until velocities agree. !------------------------------------------------------------------------- + +! print *, "line 423", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) its = 0 converged = .false. errmaxmean = 0.0 @@ -483,9 +483,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) endif - !Alison - ! if (icooling==9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L488", fxyzu(4,i) - + if (use_dustgrowth .and. itype==idust) dustprop(:,i) = dustprop(:,i) + dti*ddustprop(:,i) if (itype==igas) then if (mhd) Bevol(:,i) = Bevol(:,i) + dti*dBevol(:,i) @@ -507,11 +505,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif - !Alison -! if (fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L509", fxyzu(4,i) - + !--floor the thermal energy if requested and required - if (ufloor > 0. .and. icooling /= 9) then + if (ufloor > 0.) then if (vxyzu(4,i) < ufloor) then vxyzu(4,i) = ufloor nvfloorc = nvfloorc + 1 @@ -566,8 +562,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) 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) - !Alison - ! if (icooling==9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L568", fxyzu(4,i) erri = (vxi - vpred(1,i))**2 + (vyi - vpred(2,i))**2 + (vzi - vpred(3,i))**2 errmax = max(errmax,erri) @@ -579,7 +573,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(2,i) = vyi vxyzu(3,i) = vzi !--this is the energy equation if non-isothermal - if (maxvxyzu >= 4 .and. icooling /= 9) vxyzu(4,i) = eni + if (maxvxyzu >= 4) vxyzu(4,i) = eni endif if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) + hdtsph*ddustprop(:,i) @@ -619,8 +613,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp shared(store_itype,vxyzu,fxyzu,vpred,iphase) & !$omp shared(Bevol,dBevol,Bpred,pxyzu,ppred) & !$omp shared(dustprop,ddustprop,dustproppred,use_dustfrac,dustevol,dustpred,ddustevol) & -!$omp shared(filfac,filfacpred,use_porosity,icooling) & -!$omp shared(rad,drad,radpred) & +!$omp shared(filfac,filfacpred,use_porosity) & +!$omp shared(rad,drad,radpred,icooling) & !$omp firstprivate(itype) & !$omp schedule(static) until_converged: do i=1,npart @@ -628,11 +622,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (iamboundary(itype)) cycle until_converged if (ind_timesteps) then + if (icooling == 9) vxyzu(4,i) = vpred(4,i) !keep original value of u if (iactive(iphase(i))) then - if (gr) then ppred(:,i) = pxyzu(:,i) else +! if (icooling == 9) vxyzu(4,i) = vpred(4,i) !keep original value of u vpred(:,i) = vxyzu(:,i) endif if (use_dustgrowth) dustproppred(:,i) = dustprop(:,i) @@ -683,6 +678,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! get new force using updated velocity: no need to recalculate density etc. ! if (gr) vpred = vxyzu ! Need primitive utherm as a guess in cons2prim +! print *, "before 2nd derivs", maxval(vpred(4,:)), minval(vpred(4,:)),maxval(fxyzu(4,:)) 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) @@ -692,11 +688,16 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(4,1:npart) = vpred(4,1:npart) endif if (icooling == 9) then +! print *, "after 2nd derivs:vpred", maxval(vpred(4,:)), minval(vpred(4,:)) vxyzu(4,1:npart) = vpred(4,1:npart) endif endif + if (icooling == 9) then +! print *, "end of iteration", maxval(vpred(4,:)), minval(vpred(4,:)) + vxyzu(4,1:npart) = vpred(4,1:npart) + endif enddo iterations - + print *, "line 695", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) ! MPI reduce summary variables nwake = int(reduceall_mpi('+', nwake)) nvfloorp = int(reduceall_mpi('+', nvfloorp)) From 0e0cc6d9ed4e4c24965874fae4371883d12dd222 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 11 Jul 2024 11:16:39 +0200 Subject: [PATCH 701/814] (ptmass) fix accretion with ind_timestep.. --- src/main/evolve.F90 | 4 ++-- src/main/random.f90 | 24 +++++++++++++----------- src/main/substepping.F90 | 5 ++++- 3 files changed, 19 insertions(+), 14 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 7ae1ff33f..7b5be2313 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -325,8 +325,8 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) 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) endif - ipart_createseeds = 0 ! reset pointer to zero - ipart_createstars = 0 ! reset pointer to zero + if (ipart_createseeds /= 0) ipart_createseeds = 0 ! reset pointer to zero + if (ipart_createstars /= 0) ipart_createstars = 0 ! reset pointer to zero dummy = 0 endif ! diff --git a/src/main/random.f90 b/src/main/random.f90 index 566b4fc47..63cd5e976 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -176,18 +176,20 @@ subroutine divide_unit_seg(lengths,mindist,nlengths,iseed) real, intent(inout) :: mindist real, allocatable :: points(:) integer, allocatable :: idx(:) - integer :: i,j + integer :: i,j,np logical :: close real :: tmp,dist - allocate(points(nlengths+1)) - allocate(idx(nlengths+1)) - points(nlengths+1) = 1. - points(1) = 0. - tmp = 0. + np = nlengths+1 - if (mindist > 1./nlengths) then ! override the minimum distance if we are in a bricked situation... - mindist = (1./(nlengths+1)) ! we'll have stars less massive than 0.08 solarmasses but it will assure to never brick the sim... + allocate(points(np)) + allocate(idx(np)) + points(np) = 1. + points(1) = 0. + tmp = 0. + + if (mindist >= 0.1) then ! override the minimum distance if we are in a bricked situation... + mindist = 0.01 ! we'll have stars less massive than 0.08 solarmasses but it will assure to never brick the sim... endif @@ -199,15 +201,15 @@ subroutine divide_unit_seg(lengths,mindist,nlengths,iseed) do j=2,i-1 dist = min(abs(points(j)-tmp),dist) enddo - dist = min(abs(points(nlengths+1)-tmp),dist) + dist = min(abs(points(np)-tmp),dist) close = dist Date: Thu, 11 Jul 2024 16:24:42 +0100 Subject: [PATCH 702/814] radapprox bugfix and upstream updates --- docs/images/vscode-findent.png | Bin 43037 -> 0 bytes src/main/cooling_radapprox.f90 | 1 + src/main/force.F90 | 3 +- src/main/inject_asteroidwind.f90 | 7 ++++- src/main/inject_bondi.f90 | 7 ++++- src/main/inject_firehose.f90 | 6 +++- src/main/inject_galcen_winds.f90 | 7 ++++- src/main/inject_keplerian.f90 | 30 ++++++++++---------- src/main/inject_keplerianshear.f90 | 7 ++++- src/main/inject_rochelobe.f90 | 6 +++- src/main/inject_sne.f90 | 7 ++++- src/main/inject_steadydisc.f90 | 7 ++++- src/main/inject_unifwind.f90 | 7 ++++- src/main/inject_wind.f90 | 43 +++++++++++++++++++++++------ src/main/inject_windtunnel.f90 | 6 +++- 15 files changed, 110 insertions(+), 34 deletions(-) delete mode 100644 docs/images/vscode-findent.png diff --git a/docs/images/vscode-findent.png b/docs/images/vscode-findent.png deleted file mode 100644 index a26de6b40d39e56731c69058271a95d5407e3e3a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 43037 zcmb5Vb9^4#`Ue^(jcuEaZ8UCd+qP|^N#itZ!^XCqG`4LuYH+7#pYz*2``r7-P2YSn zeP`CJHA~MI&qON7Ng%-D!h(Q+AV^7yDS?1Mh=72AqQZay-?(8O_(p8s!QDF&=ujjnuW}Vl5BK?=Y`T6tBmNnwI~6OCAN@J#hcYDG~?A$~{tyh8p} z?j~GHF2{(?bA*aED3pl+gfG1}u@FqCLFDw-#*P*>oKG{jB7zE?BrCd#O1*1~#0S-| zY;3G3nJ=aaXPXf!Ajk!pDd`QB^{4$+^4=A9mI}B00y~9=ex6EJx8|dN!@j?aS(wc} zJet@rn3O@EiG1Sgnv^~+y}6>3#UebM=ZtTzNgzFwS6H)>S`YjUS4a1CJ5C-6YZmFP z`RI;Gb%9wLu^`-}#lFK6{1QJg(CVt9)s5o3MHHL2>3NW|Paoi@!MGJV9f) z$1;B$nnX1Z8GU)g0d;C+<5lY5gnQ&NzYiPrP8)a!n`_twCPED6lkko!01+&Z5k&JD zLo+$FDm6-7I;13so(HYj)`v&Cuf95eWo3B>5VkYT%pc~vuo$3IZYgxhCh{v&$w=_TU?0A~vIV?nf-vjCT?9AZL~IKr zf&numhV2XP4}gP^Tt}_K-wpanOoSd}Yk)-!p7I3>A0oV4aSBW>sCJXI3AUx1!GY*D znB)>aCdl0YKZqD#Ebvl(z;+%vH3q6M3pLg<42DR*0*(sg zoUot>)tA~S({Io%a0o(VQ`U!QF+syswB_KLUCxG3VP}i3)6=1V(WCg{l<{zd@+LN(X5L(+Z`0DOHU9#-T!W3{^_> z6YM8S><8r^E_Lk71OyRr;?6%tr>v*6r%Vrn56x~pZxL=mywG1TM7u4F>6z`YIVcg6 zqcr1&2R|8DF%L3hF*P!Yrnzg-r-rfjw-|s|UoEno(w<_T>e-+*5Ud0f^u=vCa3N$- zOn_sB?QGUKJT~z+i8iq|>8&E4gXe@S^sel@T)p!^@dNLG(2p04z33P0k4O6iGXTLU zf*mNKAw^AkN>ztai53R4BW9XU^CKAhgDhDkRVpf8Bvu4cguNtr66kPBT>v?G1zAc` zT*CWAC`qDWS`#>y=q$<9#Kt6~gq30UVS8%ysCWIDNkYTz&Q<=q|Gn!TVmQt3jbn-RNf|8AcAy`d}SGx7%FE$BtL}x_*iGA)^XRm`c z^#!GSwSzLOZ=59?N^gb23zsvJ3yYOM@~;%oDlGGwg`AuB1;*hr80%E(SL>U!Ahjgw z&nO>Xg(!#bZ}JgwEPtK#PUM>^8UpUTshbx7y;@d6cR#Y74q6P(0NBpjK=#1JN7;`?A34(N(%>^oGiyFN%i_rrr74cJjisimX0EXfX0VRU zjNfOtYj!Vy|7Ee|OS1XrH7GAc5PK-{H4z11;c4>^m0OkONdQ4gTiPl1LCDB^e zTFq))%gdJCSg+i+R$)ea?&ClOFzetM7yBVe5Ps zS{Gksoy~A>kZ+3OE8_bOnkKzd@vPa)*0A>QHnlfb_P%aoovH8N4{dY_&UJSCvvtuJ zs0w)#Q!;TmcpDIDhmV^sR7(Ww1gSx1BT+(2Kz)W3M68BM45=FrKY$+JV15(+=J<`e zjsiZUy4Nj)AD$CIAM^DF>@?^Sat|&?Z1KacxQn_*VQ?XaSuZuYq0kulzAM6HhCL8x^UsB*{C;Y_KYmLbw)q- z`ZJ|%@n?h=LHBc#OI7$SLSgB%^$8luLsMN{hoitb1RuA~>*X7n>HiGrX{4=%_ zm9ki}juTtRT*Wpis8QOGYeGzW)GY%oQ!FoLdZ&>JMzfyTIwZatJ%a$B)+#ny6Lz32(pJb{k9PHxBR zXM_g4D9*Mu?AB@qc`AF|^-WID4YpmnU771&9L@Hn&zLV2mn)Uyh?(~`uUcJnO-dHp z8cGkIaPFfi7pEO`FLp-OBlDG{2l>7$RV!jEcJ}wnepMRHTwgsL2A>JWd5?JE+&b3k zO&0c02a`tD`qpaJUW!PHD!gOvY*ucXWfk1YR=>8Dh_o6x_y1~dYj6M6cF(SMtb(cL z_oVmml3f~5x^Ip2C)Zm{aId1wz+{I`kF;lbCP z1033#x)>6B*xJ}R^LX%+{_6@J;Q05~jHJZ>y2QnrpH$8C5pC|uW@LyGG{9Pq86F1YJb^dYckD|Yy zfk)oS5~$AbcP9!k^D+LVJI#>qLe4&sDoYE*W zBO^0CooYLQPQ5aV+nHkfGW)aF&*O#WTH~v2wQDb2HjC*7TW_D;bSFG3+x{rmP&h1< z^o=$+PtD~{LC`}D_IilU$4>vZCDA{+B@hDIIak0}NmR_=rBtAB_Vs&YxRP60l6aoI$*vN>8uj%0U7!?oi z>ecgRKaM^}Q3gT;Xu7FS4eweu}^SGm<~t-|{udmPLe6>O@+e^1)5qR7V+ZDtr0{rDXZhwD$=bNCG z79LPgMl41>hx>Da5)s2qaac_H@`8fkprPU1P7rd~7TQX)(Ny1C3w2{-G>e9X@4*8x zjw8u~Cc8sFns}TFM{CXXdczQcvf0bJulKCQHq0h-{9c|^75Q|t@6UKMxSh@Bv<2MH zW1>f4=ALtNmA_7OwzRa!=L&QmwV-1M}YBhJ^nyz_ky@3+_X2TPqM3_7(o z?MA%>(r=f`^>he$9CowchEwQ1vzU!VY*G5qsy%BfE7yw0YE@NR9Q-_4V4BJ*GL3xs zYV|9DN&)M7ak28=2UCo601&R{%)78}tMG_I_k|5Nqc>~^QR?2o9o9{I_BwjsY4 zsI6%7dK)XNFnk}Y`Emvp^$IPh#Ndm?*B5VcPTW5ij%Bn^&=2g@u+N{>tBurPd}9bs zbXr_AWoxx+&GzanYx@Xzc-#UK*{#(C1vkvbwa{sdNUkYxh?ACT_R^S*&w-YR$Ku9i zO&5&{#m3-;3x#tg6&Dxpji?3$Zu~%Ta&#j^%yu}MhP0rH;k`d!BOoNan-om3Uu#L^ z_eLZl${k55GrCQuioa^G%~XJeRvAfUz%xXrRcZ42nc?WEpN;I^?6_kUi#v}@rKP2n zz(1v{S~ia?r(7Hp9{A|ARBP^kL%G;TPGlq;PslG;{PiFii!ld|Q-1@?dZ9AJ*2rkO zP|BIUGGUv$hvX$II9NX(k5k&O^Yt}~T0)CkL{#+G{YAQ(*Qj3-$h(C9eEMXFnQ?-_ z!jUel=SDCKe6&~GgoTCI*K?E@_`Pn0Z6F*m;18L}=tRRN1&3t<5x3Gg?e(xl>bj_P zny9zAl~9$0hp@$Lm^wbyfr<|#P+WGpU*v>-s6L*n$a_yLh)>{cu*Z)J+^XsuQ9CMB zRG+J8VF%B5-BzoKEXYL+2LIRRrYh4>N~r;%b(gbcQEhF!b`eLK`CHXTc$}c%;17s} zpQej$Q)8l{l8S9;)_BdH>Mdswr&UBn(K0Ug$MF;*fBg92&rfH}T#vr6@OLo_xEf4HrjY(i$R?l1?Qe=?Pq#-K-xQVmwwW*-7AkEWFl`O}xm7~5 zN!Zv~{T?nsd7S$qgki?(ZI+5{{Z^kCvlgKVZmS)HCHFe-s3JW;d=yVH3eSIP*fppfB zP1F{MR*}%CkC_cZ+C##&Fil(5l&~$WjK2HNGalNrVR4&oUFRU7T z%K2i$Z?C`J20*08DL$=M8`I4<8eq4WjY~Hp*@5;d<3CX7EgN!kX`pNc-u8S`KbOUW zK>qYi{d>o4pqDUZ&RPV@dnRP>bS_7mg-QYv-o%j7qZxA$c*g)%!tJM@Wn0bn;dOV z=0A>S)c4`D?&`O=IPQq|BV#tiPr|`dRBwPJ0rS*qx^M|-w!w~&cFjI|d+ddR3;c%` zmm^F}%>AQBbg7cnf!LGf#tSb0*QCS4H1+R#hJ&m+{RD;=?6(jtW$KLm4WQfa4K9Z= zRQ(?=zt0cgb34JH-4QE-m~V-2p0Yp}=ywu&-xCH7D0qz`dl*sXp$>$?9c1%+up8nS(>zELUJ{7m`ZOh2LQl+etc=K2~7Uo3sNyF%hLI zlnT@C9rz4bk*p_0&j1!SE)++fY>{*d$plKBaE;B`V<+v$Jc z)J=61NreG}(zHV~D1Q!)k43LiE7bB?T!<@ihBXL&-%=~Lq3wsmNE$!`0!vJ%i*61k zw}Tt?^1qPBZU*PBUv-<1dxj1H@QG+*Tcg$tQb1n`r;sPH)_9P^r%74HGfTd6Wc3$d=N zV<|1Oj*!j!5|UkW1B^vckOmVt4F#>lTOwm_UxZ-zw{McRXR=9x2!G>4;=o*aVqu)* zPn8B-c=*q6u9Q+Vq>m7gkkSpS3e!y2GJ->4UfpI>r76ac%~q7omvt5lk`+1XvIlVGnB%*JtNzw65o zMkjNE%6lp;F0RS3-(+$Fa4rl8 z5s`yLaBN~=07AlS(4|n$BwVa<^7e9{LX+G8a~cwAc&0>6i_h=Xrc}?&{9~xQ(#yyc z&SvXffpm%$O#%@xhNvH7@Hj2cS3hWorr7EG(Q;kN{>>gb-vNwgV^_HF%ua~GfRSqz zoI`oN!*}CH!Pjau@Fb0spqD|Vy>+HgS^Ap6o|N8jc|vX{TwZzVIiH;Y*Ifg;Jp$f4 z;EA9))+y0(alr~CQKA7<-(WQ-ULv_YOsD?dP@nxlNH~T1O8sg(HEk@60Rok=zwA#G zCYS+YIu=j)d@#${U@c=oFxuu>Tdgm$n&XO7wNGf5_A=M(%zH&kSgjc}9cI7i^()h* z16{@A?qosP0`LU68R^v&AK`ZeLofa%ZbrqkLNUd)>~uGcE4RtyEnlHQn*! zG*048vpsd(*-y9g)v!iSBi42RD@3+RN*{Ep488q{fC^ba*~!QXR4S9^itNEWmJr?i zdexQ%VZhyd1~}Y3;;lr2U=z{WmX%&9m2V+fN2-+czm*rdmje(HAa-GItIe!Ae2V4C z-P=Sc2TP6ilVj=1NqQLke{PdXi6Ex3v^^%O{)`Ue^0(bNHAQFD;cdrs$Y^|odF;XXfOx}A0VK*@x{`suAy=F0ZjV- zJ(=A`$4@w(KFU99+=gMo?PUae=MxN~7xJ{AUqnwIWf(g?SEj!08+^c7x@r370#l(7 z!bvXW(!}|@?%xQpE1s$=d&G~=xZ%%P3mhkuLZIs4%>Zku3qijV z(d+&^o9_*J$%9$)WZsQJCUw9hNBujP()>v08wWO@huF_!_Bed*-Sdv;JsJPi+0|ya ztE4_)EBIP2mrD8vsR6kCLny!uty%%H>yaLott)f-gZ%OKbZK&W8rWLa0>OV3ju9Ce zOzODbn`)@Ux+54Vx@PnItfDkLo_$ASQRaML7Z~^*5q~khhTCbkORr0+#AKcC9*AXj zOEt_i6SpM)s4g7>^%L_H(-hLjjJm~Yrryqt@Z(sifm@|grJTcJD)J-0pD7!@KO7zhfQ-BbLPRBzp>Ur8 zp7}c-?h28qR_b7oGVndG0hs!|4p*by8m3K^cDvVj=Ub(T{f0R0hu}W~761-5-H8(x zQQrXWiid4Nr&Rdu@LRpBZW|rAB5tCKYj&2Pf1YX?pIW6(hM<3UwJ{Yb5#xNwaP&R3h;0o(>4#pjDoUZ6puiLrPK6X~on zdfNMAE!&~o01}P35n?2{Mnk{lCK5pD9v-d=BGS8NdU|Sr)6(}g+Px3f+j$e;_CHqD-eA+u z4_1Opo-bDaygfo=Dpe`b$`k1asuGeWdE6aFv$vPWE|sXaV$TuuZ?H%dIn(L%t9RTf zM%Dsq`E^UfK}`)4W`(ls$$xTWP*Vg3*_U^jlw^&v9Sqi zAQWh0bUI&ag)8uIEMqm7>*>NYA$=RqOaOE!Sl%mEH)Avf|6LyennroJYqn-_aj{g@+F%6p{oMBr zNiLsS8;8r2!$a(`pFAE4)$M6q#d6u9bMzTq=z2DlsvEuOa#*=i(;QrY`2EVC-M!o;9I|S;e!^1<-@K;9KFY;hu zU^X_VK0ZE|l&P;T;k#q$z1?~3O7`+Oe1^8VaEzAS_za?=#*XYXrtTN(^Z6f6P{?#R zY_-Cb)>?kjDty^ot}ojj>9F~cpVD|gQ&n{-92~Zj!U8b*z97t^;^eeGKk%Q&bAz!u zZ61{}pU)SgD$FM<6PP2$G_+EMHirfeoY`n1F{WexvE(GsBy|S*@*jZ>-oS9INCu0T zM9jXA*5CXf4^Wl}1y*s=6%`eo_s0SPWwuK%b?S!B`r$65Q%c1?_-ZuR0NYMwev-#% z6zO)GVQ-7gk`r-~a)S-`E-_cF&tnp=yIuEh#$daAYS@c@W@OKdh1IWTlCP*aliM0d zFkM*2WO8>93(Lp1TK!JAOszt@v7x`lkN))?ENsZiR`0J&&c<|hYrT{C@$Hc-vA-e7 zZ)kAYimbrO!t#{UVXzbv7boZ7;Lw%=PjHNmgTrjUZlm)-4AQ>(bbU?ONv^H@8}iJ+ zmqZm&QZ23J+jhqbPc00Kpv0P{y!@RfOYz>FpK{k&4>ec zQNF}T5i)xHNr8Vi-U;jzbLTTk75JaP3^*Pp15f~;-Yw;S-{@fvg4)>ck<8$qs(6xw z5G%=j7(!;77ly;$2t{)+fCBbL<|cFaLuIa?Lu{a-C5(-eBhdyacN12BE8ff;6LgIA z-uHKDY1p2Kw*TlV!OVY4+rTK))LPSEz2o=3tF5bxitupX?CL0VU}k3@&Ag|ZOZ=o1 z`A}!S@neWu-sSeqb@WF8bZ<`&Dh;V_seY&8%|1h`t8;>r#Xr_`;Rmn`V1EbLTZPp^ zp5g55YzCWUwecXPBRe2yPcfC|2yzb&4w?g^4UGkx`GgLjrYb2UeE5eM;713R0q7j* z0=`LBxx~f^OJ9UVr3QeVX=JUgu5KVU)51Fkxw*bd3jg2 zM>{milznv7yKBg9lR3V0s-;2Vq9P*dk?Nnx`{REm{`v(23wA3%T3$;nAmp&ZFiBINfHwdnf_e~+O_@j2z_BCtN;R#+ud|Vvj`@9dYX{Pt5O1CDOnH7?1QWzhB*ib z_{@a-j3SlwL;e;Y>UJ)XES$uq#&pyV;Bx4L2(XQgJ32u@U_gI08TK{+9+9Y#RR2uM zk8g^smx&wK_8rYV_KSwjH(=@I^HM4MKI{O5>^04>)c@MST>PR2Cy@dreTg(tJbJOY6 z?G`^oX$WBpwMY1T3dMcgzLCb>K0P>~i{Z2vaoQiF=_Ef52ncwGHUPs*N(vSh7#KK< zHul<6&J=?c+WXs0K)KMgz}68NG6f8oken~|Q=HALZ171<1xQ2!fHtY=N29w$z~iDs zntVHs0b=zd-;_(#`IXILV`&TherDLRF7(3{&_gf`B=Ue`w~6=b`SAu_y;2J~Sp?8| zo+G6O2jhQiLxa&ANMPG8*VQ+=YqWcXTFB5ml4+S_|GkkCQ(Yq91UG9iXfL}R&tfE| zV$kswCL!ZtUx_kA5TwIl(uc^z6A99*jZH5uYB-H1?$jb)U3jm;PI*Nk}a``O2*?T zPhop(cK)iYBR>tdKVcg|lbsZ#Bu&{)==FEJ6B>c>5gia>UG4BKP^;icqYX>BQo@Un zGl)}*#;j;-&kYL=MZ#sn?}oJq0G6d%`NRF?)&u~+DuJE&?vz_Z1pNwG*5&aacLd-( zD@~3SDXLO!@@6;tu7hy|iL}pzJAkB_Ha6eZ46xJBfRGo*&Os$lTU&0FuPb^lV#&9oBf93@g5u+u{%cK0RkGD zYYUH6#WgjPrTbp=tFU(~D^_)uV23_G$3(VHTjP zMMU1?eoSLJJ73dAw!hv595CmD_aVy?2=CSi&S(4kF*xJ0S(#E${OO4V#SK3@u!VQx ziglf@x8KZt9H0OwZ5c$KaIm;;>zxp^5Ih=9I09Zo=TbWBn)IiKlkI-E2jkl-&+}~- zr^jn{0GbX^`aQJyzu8^yUcLN63X4?&6#BthWo2b|C#Mp%3d&;iZT;ZhaHNSWZb*Sx zJWkP3K!Pn-?8P0O-W^t}$S`<|U#dO8danc6F5tIWSz!X+`?luh7n@Ui0G~Mw4hu5_ zBAKdv2>0JBAwdi*S3Q7yvmy;I%#(}@5OYC$iMPVI;Njsv5-WxwI1>u`)fAhFV|_;H zIRmKN;x$}w+VPyV5d>M3kfqH=M>Bw|fL?KOIlbEKZr5#fi}32hv6CKdg8v}8!B?fX zH<7K~&|qsmo)O*-0kFxt-C?p%BBA+mir^}M$;hQO=%A1jUpAV`@L^)Mq;?=K`|`Rd z_fq{@xL8bxtFV!^4=N=5A)@Fwo7X)!00J6fkI4X7+T4BQNe|hCc@58xaNEKjUIN{p zp_v@J5QbxL>VcREhfW=F19TPh9IO|}oRNDI5Wn|^62YZZk|?4D@M+a6?>4)A$1v(@ zXcZgJJDv8iRRJ@QNYpt3$FswPs=YU#!RF?2yPwtO;LF#~kRLzOse``6$HeqO3Hvkj2xsD}T(*LA{_J-DC`wwWP*4vjKcLApIr_eo zTOg|BsVG9&@%@dWi2ET>V+QIhXLMAKcW!zHic4mNPUfTZ4IK?UW^2vWV?yfc>v!?! zygizL=masURRvdjiGBb8gsosrYHU_R5L&B*g&67GVa0;5(P+3<`wha<^dU!Af>>d4 zzvV#~DJO-Du3&M%&NmE+4Wxk>&f$+5f7cgS#D2ECv?+1eXfJxjTQ?LEyeeTSzWO=; z=&%zz(#V6>4qGPd@|Kxc+-d4dha~2E9h2$8BbYWxUY8w15+cNiei9>aaJ=p<8#A*w zR#I#ra{$hi%RtB;ew73YnIF(0wC+yd^wH{lnt9#yzv;Hx0TwrjK+uV868s+I3ZywhzFu#%k<~09(!$4NK4+}NQXm7-|*=et5 z4u`dPbM$RX6upB3hLM;sH1ab*p~2A5l6@ki`F)=t?5+zVBd^O0R4)*(h(7h4ZD!Ip zKnS5iH_Qa63Af3Rr%XJ|3GE75&X%e|3Zs%=nMV+#*3ESIN+6qkiZWo0`Iw2`YK>0) zB@GT2|GCB69s2nZ5SgKHi)~lbhE`kenN&VzRl_M314_VD`k_#XlIf*!-}9q0U~{as zdD0D$FFGVs)z`CiyM8RXUC@H>}^ zP6LZ7uCg>fs3Yp7B#=^Uval%K)9J3kkeQrh;V-7;zMj5E{XP z$_TLPfnbst)I+0+Q*Fs8M=YQ>^18+a0|!s&%aS^JKF{t^i(UZ-%Ye0lCKaY7{i#3l zSe)nO{-6qS*vE;(YXwsB4MIjg1SY0&A{hE!IB+K^0`grR^?ZeJdw7UJV~mdHHFk6j zOza3}5(t zv>ua3w@1nR{JE8YapcGDi03V1K-GSE>0WD2x6LO#=jXWPBTY`zS!fa-9&X5jT^uNEGh1?FFEaH>xP~xjn_e_jupKd}Q=9BSm;2UT+w;aBsPOCoXT^%8I+)bYXfMeO;6lYBES-OK$|uec0KgO#0wPT?sX(& zLTSX~D#3Z5WWUkU_z%X}R!PLU0JINn-cjl?ZKVOo9-#k`=!D7)MA7gv zjmqGk45OdFi=)Fu8w&VFeJqsh`Ha4e*7&YD!WNvIlaWy#z*P$;i`8)Oo~Rj^iYzvS z5lo2NHr{vmd@hHDDRcTtnt$Y(T)qHgxg*!mt3)_slYEVdqqfES9?|dgyM8ALCV?Sy zq{oRxR*;bm!AxpZ8y*q1!vl*p?92dR9_moqe8pLf`DB=;Rem0$`3KW{NuByP zLBmRwc*1O6SF6ucvi*hb8ta(2$iBU7WpA9RTW<|bEv_fxpF~{1WY&M6mCP1@#A70Z z>w&u15G&@R2?@!_$fxy;zHaSxDhF&#Lrzu*c|c~}O1hk#8HJrA&t0WBSvgoP%mTP- zxo#`0l*{DoEPh~yfNx8`?u-A7WYlZKQ&CM%0?WZfcBByO9emde3a?v)3?OuOhe3NB zy1AVxiqR}pXj4(+$fAb~b+4o%k9FHw>VGSi{Yc}QAoU-XA9yPV@;&eQc_8IhF6cg2 z2@G3rr=DcG(j`(QxC$if;flwgxvjFY^7cB}!&ixp^@u>O?Za$AOG+qp5IZXjn$(jR zO}b?LqWAdpwAIZ%0$^j?tSvW~j&f*(u{nG(;=$zb@11QG8!6QrNv1;T5mpE*{hX8% zd=Q-tqH+QXim%k6glhd#O%UYMpk0Go^heGGxkvyDB??!Y7?@xt$oe6RK^O8N=ntmU zU-H>JTl?cDf~`b0@qa6Be)hi=l=~aQi)kXzQveY&X=raB9eG}DH}8rYOcOD!Gyg~I z5%MAjL>0nZo{K+ST_B^74fOq${7ig&_MZfkIPg{yXbHc7>-rz917wUsOQ1%}r>p9l zzX8^7ABONF4_kv0SZUUw$C${*Xbl21xk1nh+!Wuj_@tjuHaQV9!0z zS3^BoiS(kr78k2kXd$#=+3yZ@8yXtYe4~Z@08GF{25q+??6%Kjko}q=e?R!|7*1S) zCh5jzHk6P!#q>KTW~Ct|TXz(gT7aVf2=n|E!3J;tP^hM115G510XX6S2!H@>iRR^V z-1fNIrnoGIOFaEi;GRM|cU5x-Kp#MJKktt|0P-LS3Cn;iA*Etj%@Bng0bf4T5r`{V zc+~?Q*H>4E!zVzvmKj9_2tJTgayOMHXFBp}W_H%&?e(`q^IfMoOKqqo_aDzL7$J0> z&pa?NfQx$!Oy;C}v+khgoq<@9xY$@-AhibIWjy8+@E<>pOC=YRp}iuL04}|oyMC4P z!5xrq!e+b7LUJ&c&T2lEhQj!&U1PF!ccy(jTcX|J6AI+bOk}V#(9+iUzmZ(KS^h(F zE0hNtjvfG<0ra#SK2K5uz&V5u#9Aa05CdpDMkyIFvBAZv;JeWSCdJd0^O|3$!m|Df(l7M%(B|uC;^dF~jGZP|- z$~cGrMkE$+tBe}3V}SGnD{Je|^qREpcB14Y91egj!91}|tx=Vb!0hJ-%N)G(mm$y- zvA{h6DFBNQ42}>>cxGjga0d8ti*iCH*UvIAY!*`*+PulLE*2I;fZbKNJIQ%D2c*a< z%$IAnx?g}{yxj066l?dn`M*3N^vNUnuM6O4;jkCS+hmbtPM}>7XOC$;-k4&+7RD4w zrCdXDTy$3Ol*&CTHrQ%CtzvxtG@NGF;Gf%^(Nhz7JJQ{a0*4MH^^_gYG%BainvV15 zLJ#^qnP|>ZW0=ZTp0?QHrfRj{EU#2adbSot<9((#Yjavr^`x{(UVTa#$=L9|J|0?< zxR!axPuz_3A5~KlHgI|h8bABsXCbzMe$$XPLwL45 zso}VVW~t=;B=8u$_9r9D*xH*afK@bD{8*l-%zmal%a!_KJUF3{Bo)w(rnp7 zAlHH={NLLKDpdj>4jLXFfYQ$?KW4;YZ`HV+NrxEO*sg53caLXsen~%B_-?q4RX7B! zeC>LxVD%Ar+*w{e9Z&JVLxr{pXgmtJ5Qv1UfbyP%&Xz$H z9~mdNkB%-|C^=vLq+Y4BTxFa)i7S+g_H%XK-E9dO+)!~oy^Ie( z`qwr*d)8vmrO{E|CHtkyKD5O@AS0v4NvY}D(tSDox(L6P-6);nVypavDSSN#?Veyo zMeKI}$-jd&H49x`alS$7=$hi%%F@!x{P~TpwDi-c{mka~Rqon0zZ<{OU)5NzfR|{J zu{CQkan0&lhEAi;qA#{Ph$ACs2w|V5j8skRS`QCnL`)iDB`QL;-WHpnCGScmUrFB& zN0+~?NRT-d={@w-_6bn&_MaLk1J` zEGN@Y3=vl!Kk3E_l?G?+9sTElD#tMmuj54XFIA3l_n_m1bGM22Wgn~=VH)XMv}(oK zHCwK(_q3zZ1d;w7)g^&F)db#37y>F<_4TDu7)X{)=yUl_CV^hLS+xp9=d;*Y& z3)+3DU~&Kw|M2)|I-K;OX$#-|ONf!3SKGw)wD}-BPAY?Tl$0spRf%*oHk!XaLl()f z`9Xte;IP}RiUA4P$H!LR_1Z<+_U6h!Vy>$>*VbAaE6QJC-@QXb@;5g#3tP8atRg^+ z#bxi-=?18})9w(n=d}lb-}sEE4P!#|IuUVM2j2aJ$J_tJX)mz5d4f(z7&cCLcfQ8Z zxq*P!V2Bh6*kLN=4@hn=;-PYK1H()KMGn(0n)%lUaClt6o#9f z%`q7=!po%3^g1i~mY@Wbgv)0e$r(B4mgTXoWmpw~}q+Qa1PQK#mJCZJ6bJb zcf%X}?NTnh{ShNYVoo!?$4)QrlMX>KI7;E{&iz=%+LJD?DOxHXr)AbN?(g{UmcG zpX*vA^3c`fa?@XK`c+JI+s0Hi-~TNS3hD{QX?tErSNF2r)m=X>vgsjndT#C=j7Ma} z*~NN0xWCvmav~I6U-gc!)WYGbYwZc0AN`@RK8|@gNX<#38kMrR%VddrMY&hHouG&2 zz_f=)JZ>BrhSqy^xpp5C`@5r?WzTiHScRCe8V*=RWc6ZqL`MY{4 zo_4Ash5!_h-5p3u^fp*uZAr^*U_!Q3IsuGupM+D_#3&$+d}#o*5oRUy$3;k;*RzB}*a_Q;vXtq#q5MpH}6FfDp1;1XY8 zmD^bS44CPgD`1+@%vWbCjq?@SkC$7)9lp>;h8S+u!Ce8B*h~fy$umq3KlZnTf(?vOZ`^{(Yo&Cjkt zQBFIZaH8hC^AN%P(a3rO>H4krySF;JRGFDr8ucUKxCP2ogFrHi5mfQwIg*t*ux#ea zw1L+V2>g{7$)~!AdEFL3c<5Dvd(aU;hXmhL8fs_*t6A?z98x9 zN{C(q830Hkh^;VYBcE^-X|}+(0vVxfe!LH%Ffjxq^_4nHxWMCW7M468K1~SwE3%=p z70#^~iFod^v~n24cfOvu>{ePpZgtFQUj5TO(Q4zx7f^67Dc#t}$JueqGToi&IawY2ljCUaD^yGII zlL1Fnx9Y$Bx^8^GiH1_d_X`CVN|_Wu(MnYYhI~t@47Lq6ONC`+(P#Tty$Ti<7U779 z9_6B8w{(j6l2e{9kUA3J z7Ec}$L_i`OsexM|7?SptI7o@=B9vK(kMk+qlKW2(gkMCx^C&Z0oG-Hi z{kVNtH&>HDGQ0fXDdDRhmVdh9o@kL5e$y}?E2B!6OZ1Zr4bF*_6k`mOPaTne2zzll zaSB|k^8l*2Y>9)m-lO*e*FuRB_ROUi|KCEu7inS&7N~lmd_Fk?PmuS9d|#K9+PI}0 z!$_kV=~?|*0s#|aiww74+joC5*Vru8A4r;8M8QjcNL*aI63p}=lNk^+a*lLhBlwfAz)8S+eH%q@;X?}WaH?55za+9HZ+B>4y@)1 z^yiac1FxnCDOmJHbQ`U_g8^@Amh>3G6N!WA=?Vac3c}v&74W>~0uy7ZqRKgL@R-c; z9OXq)g_4(_q_QZJO?NuHtFuhLOy=Iz42AVy_-2TJ0}fr}mPjV}JG*%)EuzlD)033w z3PK8XXpLOEgu}B&A+KjJo~YgJBg$oURaLo))D>$R*FdauH_^o2XhP7+@mv{FUWDIv z(k*((3Xq4TU|1kNE`-XPCm|t`%j2q~gKAEV`OE~oE)(Z`AeYO1Ge^;!X#!-ay;CKz zG)lV9^%r<^iZ8ShxJ_wn`#Lk*yu>7w==X`z!hkIGHY0Mc9yY6W<#iZq!>N!JjbS_F!5BouNaS#5iNBn_Qb7dQN zUktxUM`s|?OX1yZKvl{zM*6g-i-rZZiC()GjyWr<^RV!+Lg`0oqd0s%=3A^~rPWaE zLo)pc{}?Y6wqSI{Qstb!@>=N>bT9D#hqbqis&eh#cq!@bl#uT34ke`(L^?#IySoJm zX_4-bP!MTp1OZVI5NV|wl@iY6-Fv&^{6CxzXN-63ca1&Ru-1B>=f3B>=5_t5xIXymB&*0_W%O%hjg}QWVe4k`h;MQVtqVyADw|BF zAR5N6$HxULkKF5pbjLP)m284TeBqK}425ZAg?%}kgee3t{MwRA5l(V=G|pNO6X!?yT_SK;7ED}Cx5KAN{O+KzG3VRdVtweJbr>( zUB`=W??p>sO5z?zy9}P|ta$e69hj&1Xe}gX8aW#iGdp!-%D;lDB!Xv zIQ&4>*Ki?5%#3{9+$Jj;F)J&}k~N0U#dSmFq|w{LYK??UO->yG_{kqhihqxZcQnxB87;%As$7uv=5joX$5+VavWgLC!P$l<2HPT~&_ z>pO3;hu(xb8pjSaa^4oF)v+WPkjb}9)d$RS$r9cypzCtcTuS?Cra^EuoN-IGXV;Wy<+!-jeT?mBX?z271(qc`GRU-JbiQ@p=Pq{lgHaEjlJd=b;a@J zAj*ty>CtWs>6{PABU=M_i0`yIzPx%QQqS$Vku&!+>f%C;EN5YdBtOUgL_DL2h3Axe z5gA|Zi~li(d>~)>56hjr^bm6cm++&}h4+J}B8=q@V}D42^9k2>k1xi8W&-vi14R+B z-|;qsuR#BJpQKjQ3X-fx3#RHVI(AgZzrapsW|0vYX~F*JtTU0=(wCZ?35KbPfow59 zz~)m}XjzMW=~D&W`g!BCYqO3iJ&VatR*hb~Y4qM7K||vRWUev#Y063bnvx3pJ&Ss0 zSERf_bFlu7WuJPY9T94Cc!P*4a=`GCd=$a)>tDAj^scm^Pfj&N-RWF?1tG%32ncSz zZb`*|s#BrCM$s?R+1H2rejPtkPHHtQIYE+woE%}qV3kK+f1C+jSy2WWoA77&n2OCP z$PdrI%#fNdzHfMtPS7jAin&@f0 zFYUDIy`tV^tTBG{pZ}n+i8@iIBo@wD>vsEML?0_7u;E_tG8={5>mBx#H|bmtY$_S9 zvGSt4GtG) zN`*a*jq2t03Kiu0+ivjiVL6(8vfJ%Ee)%p;Jh`=D~H;cv`Nz;$B^%ue>4>9CkY)q~M=TzXi{W;x~y(z1klc#|+ z$S}Vw=sx{o3Z^B6#GZ^qHP~Iw)G98d4O^3S#ojI)ar+=RMfo2yRfTp=c#?BiS|#iW zdfp?nX3FJJ_&6#Mq!{5!i(Lgj^pK{FSu^L6&iQ%Z(QA`!x>(jbzxLhs(#1(`?+(2f z(6lv@^jWFJi(tQ zyhUV=l(GBTFfjU5%5zisiSSmf65{gvrxLlJ*f3r~!*6lrc@O?pm|g zI*fHy{;!clv*rOF@dpb)gd8+uYH9xzur|BnAvWKAgk}Ta@6Q}`J5bUd4V!p2YxckC+L$j#v*|-Mcs-X_a)liO9rI!IQE-js zU5(iBim3jQp=*AIEt>W*YIst}bu*^>AEE}F*n)Y&Q2I5Ww*~Dx*@78Mz;8_HI>Y=|_r2OVZ z)3NKLD{)qAFXoJ9kfx!p*qJB(Y(_hr$Vq0m{|)KsH|t%*w5Xh#<a!aWJne8_&H z8u;kfvS?&QX5RUA@?Gx@nF=xR6$tlmlENa#5cwpyXBqZvkT{VzU%!66XQKZmoQ2tU zFalhKeGdII#Sa7I@d)0rY>t;49?{9y4k4vAL^JPpv2MO_w0uvjQC42ACQJB+tk`+T zfbp^SO6pNzp#54TYy5b1u_K}Om5bZ?s{CjgW}nR7OQMdR$rEN~G3{V<#pBCNddqGi z(siIv1xZZKBOb7)?k{Qd1xUHdZ}s~L&8jQP=gstuNQGvaS==&cb*#wr{(_^IJ^?Zr|9BFy z`HyY3NDL{iujti{AD=zQkzI}rBxldfXQ~9z(`KA82r$?(Es$mImo`=D@y>qVPe+xV-@5t+mY*`8-^;FxG^-Y>l!pUvrR0UC0&=NL~Sr968k7l zv|eFHRAAqF-1N0a2>T8DUP2|y)Pr2T(_HUIrok42E$bm%h^_w8H5s?tDzcCp9!JZZ zJBNmm92_RQ_5?^J=bIOaU%Mv5sMeilW>#xam$r_W8tTDWajYez+I9US%Ph4zBZuKI zxtgQ+3)Y8axI*f!DH$sNb3)_ufKAxDj`uN&P6$Hd+csaJx?=S5u|BWcE(=|+pq&V~ zXvyF<7EefDDDz~=_t)3_RwRySUqwxQBF(UV(C%Mua`E$aG>H(h_-!mdvY6Cg8(wo~ z=a`0n7@K8J=sQ)c*H#P18W4^!n;_eQzBxoAu@bI{)dd7-Z#*cD*kpKo-|r)pG&xo+jBT_&CE^uL`gez3^TaD36-%roNylEk57iIV9S=7&lFR$DlKwsA8`@Nf!Uoev=m+f0} z!-IPesIqJorRKNUoe$h2ef?Ps{6_bNojFWey(6*hK%6VnuYAK9-0p6qUV8TUhs;I2QYB6a;U05)O@f?h^?$0#6f;8>keoID%t&9w9 zt0~fmvjFcvnijz_3_CY!I#lg!Z5QLe7eye?gg?LQ`2?2TLMwIo z`EY)f)e4<<1LQC!!GWC*8Yttuupn!HQU+Qsj$iC(#pwdYT^y$)|z)Glx2H>C-RIAsjjXL z*1?5^1(~wITWWt^fR032OzSv^>Nz5RMdxj><$K2oA$6q|R$*^!}sj%dsyeA{SRR z1eCSvZ4Qw$%rA{-F4{ zxVBcw(QGkDljT-XuKp+Au)9KVRBesze0q9XeW&4UbZJE5KdC=uKE!RQR10^`|J>fY z43*Fg)q1mr?u4x5;#7eu}-v+1d>p|K~O>2qMS)Lx?T`D;j#T`G* z9dY{d(t2oO`Rx-tW02xjLF=!oen7^mRi;LE3h4<*H2z%wI23eY%qA{=GMxEXx0Idu zQH}}euq@zNh@Ei6U6=FRohSrsviZ7kc+llXfOUh0w|%;|bSXGOTUTCQ{&mojnv}HB zygLi@)}|JoAuzJry1-EXrPEw8JA`3^BoV2oJ{z|*R<=h7Lk|L}2w3@*pe|^oa zNZESKrE(G!D9jp^D=RCfVC}rOVh&H{a57V6PR`XgFm;s8%*f1C_zX7MkJHUJ^W`Iw z@Ng_GlD*b+ejXpJe5g9U@X7!eDIV_j_Q75VU%<&-(L!NS%k-_m$NhlWfk>0%KsIPS zva+(u(FMJ*rZGgJVH6P|q057-u(#VXJ}oWnEG^$WjmPw%T2|JXhAM949~r#PT+Lwq zZ=*qdGOM_d5ZOQfbqZ!OgvpKl{KBh&tADe7g4=ol6?L0j^#5~rIAchS54;ZCR4{fkf#>Somle*|v zgrH)a?V;?x-T64g2Qs-UQ&=^BVtCiuL^TmZZjdC(EZv`X*#O2anxq)cbouppm`{C( zIJN{;?&$U8usWZ@=4{)AA~Jl9_>tx1VsXCTDL+&j(W3f0gJFPUWM?)Y?K)&5l-Ji? zRj_$?l{-*!WPSpS;-Eljh|aj#vjHvIdg#{DPS?A-!Xr1e4qNY)KeoKJWZ8Oa^)S@< zJ)*oGc0s}AqrGc7`z%zTWkb-cGZ---(6z;$`xT16zeyhY)d_HVn-jC?=zV}d2K7P~ zgajb)A^pl@JQro03h|7_V`sb8dk>S9!ox#IeF^+Y3R+rbzDu2_fAO^Nl^f&MChG(O z`4eJdNR9$S<6f_S{Pxz!bK@J`9coE$QD*Hp2%4(I1=o%8B+TU^*tE{0SwaS2GD{3x z`*_-i6bo7DJioTKBo@+bWMpJmSkfUI2vJ(be2K0ua`l_tD9Te=MeF|;ktY1I+1 z#(5)#zXbT$+pA|sVw{9IrMsR)kK6XJ{aAcBk8nExz zEn1H=erjqt3VK`6ROZkTspPr z^K7iFijp%8`bsn;phd`Iw5;_RX>uWY`xeV0ryI~1`0TGWcm6Q7z+}n6`ulBV<=sSj zWXYKW=gXfIC*)DT>Y1VojAVe0B!P+3Tbbb%Di*SaxxMxN5t z*&*%a0@*?#>W9&tG+q&r8yAU+956Bv5gDE92&(zRArqTA2ZH$xsj`{34x}@+Z=isR zt*hg^KAdrO>$%MqM1h=-o=hS?+M&#Vt)b70Y03u*1~8=1(-rCwZrtM?l3`u_EW>5_ z5<#@mkv&h3{xRHkbY>P7i(6Y7#D7*@u$n6m-n7o-x9&32^Y7WtC1SbxHn#&fE|p)t zkgaZPXy!hfjKaKgh3CP`7caWhWWIsG%4FE}*5TXn!96I(T)}r^wxof68P>#fvdvgs zO#m@_s?84#v(f(kb8z0kL>^5J|Tu%WN8BR{0gRC&j{tLPj_ z$&4fA;+gul!6^_WBt@OQTTNz{piRu}8?gzp#UJWC~FL4a#y#4?Y;q~q3EeY?w& z_y8Wc#VK3Wa=Y`w477(}{`NiEm0P9o2R#In37PgrKW-P%LB|uJ2iir^y=h!ekdRCm zh_q=g=}a9#wE2YxVlmXme2&>zw^}UbW?>3Vul3x1icmqJ8;lVaQKn51k&(Dm-xzN2hwqR2I7Co`j_L6mI+@y*l%x48(b3tmkE5M24Tw1n&{z5s9{)=AP`t_e zcJu65fJR~(cukW0`+jpya62HY=r-8l?1h7uhY>sHzh$LhNQ$CmiX*uW;z9eJ7q(xw zehG4N`h%2)9x3U2s5Q)>>w1$hMx0`P18!&os5u+U(}QJ!0?bYqkrDc{vW3aIYta|r zvWL*BqHF&nF3|)E0Ys`DRi60c<~vHM__sxQ?koc#quy($YpxX|Q}BLvO3m*4KkI}` zAD=K(?%iJ%9d*^zjEsypI5{~9a-B@%nY@LB()Kxg)>l`}vNG{mq9^HYg$=|dC)l~J zYLyNQL|+ymIxih3(_dYk4T+D>(U;16jE)Gw4o*AyL@oka6R53@zMz}23_=kp39v1% z4f0ckKX0WuO*#_hRF$Wlr?R_A$!r2z3eL`wsRK$_J#mtm$_lfyCe=otFU3S@s4=2{ zXmvA&a^$N401E$ur9AF17#ELlFy?br&maDzk|y(v`QKwir;lD_Bgm{Tp0b{5wiB}d zmBY@iVy@Na8r#r)oi^mE#J?Z5|G5c0FwTzonLT{!g#UAoncfV3AO3&GPQfDS)4KYf zCt`O9YP_@k8=bhntJ6PTFeU(eW8eGTlYjr^`Si>3>}x_W&A<9mL_+1O&?qnO6^Q(+ zf=uk>VUeXc7@|d#fD87||0PO-H*;`F$?5;~0b~_4HF*r5+K%P9xVyW<-DQ<}5|FKy z!a7x;R0$8?#>R%9uk^3Owf8&kMSlF(XUT^00d$z;MV4dx=@(0okb#vj$#p#OUEz(L zI}PjCuV06h7`<9r)$7+ar-y6jP!0;ZV{Nkk`)$jLXX%wZdu9S_J~-zlKfhd?nF{4jGTjx^K#c!%uj8bMZ}rxmrRv8(yq%JKwZErF+S_^b<3}c8;fXH+uR1zv04rf^ z{1ozqAms&z%en~*J3x>&iA}de#3?i>7nmQ2$R{ss-!+3<3y@Q>=T!!E+YpL*B3zyD z@>`YR^XBH808M%n|H~ch{LznLFS^_2D`wdjx74S>sg=je{-?{ur>M8H6G0XA3y}uI z;RC?}0K23D|7@t1C@!ust#qr?eM2OeE#AKS((&VLTgyTMX^Y3k$Cj6t29rh~Nxxo! zE<^|-P=k;>)iJPH8y@$MZh%%SVSq7A(|45G)xjE#-aga6#6uG4+d^HL z-N*H;EJ}PO){S*>v7mGL%3D5FcV7txori++CWSqmfSQ_`kZ`=-dV|lBS@u2<2C}6C zx`u`X@edUTlK!p?EQ|7jhIP%lLU z2nm#H7m}i2d`pHd#(E$)VG$h@lQ6QQBj|2mBvgm(eq`MIF1Wb3Z&Ep4rsxUjJph&} zzGHhkPxy26($0}5BD5okDnbt?Lg}-*;~M@)rV!XH*JbJCN4LE32tt)lo7kMKjN4LH3$1t>RX-3xu@2 z2IKS;6yLzs&FbYq6n=LD6BbR88l8 zm|%-QfU#-n|0gu=0DRTxPp~P7cT#$sY5UUydoYpZGR(VC8*R;zal$?_E5#BEfq6|0 zNf$ zs}Lowbp3jCd|ch03($(1y}UZFTNMy@$(7wueN#y&Jn_QnZAHQn9_i1an!x9IGlq_( zO?j=!xlRI<2M3wYmHx5ITwZ-Ue&(3A*JF@9NcHt?Mt@*-NJ~Q_WfMm?b^hKExmj0H6>vMj|Lz}LwjR#?sqS;*??pH9COYGf z^+EU0;Fo`>(Z4s)#70ncimF$7XaCL||4*{9%8Oe_|4YOB^S+^rzeHMC;>CUWt0(>Q zQ^3!9{eS=2W8@BGh^^q!h{q(fwRO{a`?WIt^XqWeloj|wbmWF0_+X+Q=4QGj>fm4> z%iz1&#J9YY2;9nV)mBy4pcP^h~!09c)v3!Me*nL4!ILi59@B@v26}U35!%ow=jrA(@){>cqS_7zJBO%z~dA#3y zZ?yH`n~+joBw{8lip<(afE7eUMX`L5>CG{GzW#7WHuiy;+~1%6=qUyxtL4~z4UPDB zg)G<<<2zpMh(9#&4O+eFk$6C_Y4SNhm1b}oN{hdw5dkpb)yUJWjwt;wR1JQcv-QtV z=|0QI$k-`Ah)Vl~BViBy(|FPSz(8q*C|vbwKQQsyKp=U4`ev@Q;s5x|67b*!yesel z|NIodh!{*>TJ(+s$(3dKas8S7R6RI2koUfQ6XviMswMvWA?#6`uM8;%28nDiWbCff zgV>W~N+~=%*u%I3S$#nB0vHwoA|@{eaBv4;6q;L7Vgv4=YYYse-0mAQQ+!5^o3zsY z&R)4_B0fwnbdwO$_Koh`SwK4iA27oYi~EKJrZU(mA4xegfTjEv0A2n^yLCn{bHI@_ zRcr3>X4>KNgo(yhWdQ`)Z~B^<&q{g`Z-0K-e_Q`-pvTKowAYwQc=(mAHWoyj0|VR3 z6mzg~aAM-({P((8dQ&S&;d7&%&nzDwJwDvqi;0z282x%2GYNH_7R+Xs)q7a-)hQVpenuVkgD698D1vS-G&{Xa4SuK6!`1n`_2ly30 z3|j`Y)N>mRV57bPuoFO>K#oE_J~BV*iLr#`bL;)R&iRW5FH$pY>mAzCBz$~ie5D?w zUPpD_36s=@x)!60*ocrC83TCY{zGeUg9Myl7sMqY*!Un31e=)X);7s7Fi@xBk@NQS z-viL2jI-HJwUG$m86dY0MyAdc>Cxf$JAc?^`a_v5+e4vvm{_Y12UkCJhN zJWYYdoyhVPUx+ma93oq%O458DZPP7Y=}q5xJ88dE-hLezc<%$nJqPI=T`MhfSZ8}a z0{!Fst@j6P-(qP@nRZd zV=5Z4eIo2|B2)~5ffrVT@!nGKYsjvJ)H$I%NpwHhlhvn`DG47 z^uR;fpMu#R__h}MnmcV;oLU3m0?`5GJ5fCdluup+`tI}S&LPCSS)ncb!7s2POc-V%*#wH{!^{>2L*F0Ss* z%YqwJ1f$Ok8xzOUfoJ3e#aj9DFnxI)@Qyi|w?Q)$hNL}si?NnD) z!HSRb)6&3z{M*+sG`t%e*KRy|jgQ~u^?jX0p<8klBfK9*oB$F^s04ws!(}OJoULT3 zjMU+^?3YzYGbAKg*g}Xqq=cW3uP<$?*6GU$uwm}{{!E*jJ4AC-4MDoH7l!f-Nm{Qm zGqaWcgPEfvt|1bQt(jT0FTNzIfaWO0SiEK~s^X0s?Ax+Uu3yD(+$d$yJj-Y0byh?! zct0jwhQEjzGz378-nU)e+G6&3nJ#C?D-rO%Sv{~_0tUnaPVSA#y6ox8;hu!)&KQoh z0J7r+rg$(tkX1F%sXEcDGR%E60ZSPc76uIE_zPP6;nf5kBFW!1#y|s#^g=u$*{~ds z@kyo1xG*=#Lpd! zeu5kR`t>(2c}_Qxb)D7il=i@75BL1t7Ej~sn;E>6r64qCiM?+zR}iVzqbzdW0{WUj*jv9V`JF` z66iweS%QvxizFFIme(-tg`eJH{qAKW(dzfJ5zau!tIY^faF^@8#%VW@NMMk@^Ytr+ z(!$bnj571*?rRJI0bzKwgn5|rFG6H6E51R~-teG>7(fU>O4rO8Fs6-I?oSr6)kebneeoTwFy(+3)t+oU)LD13Us}?{p4?v;B zE0`P~|2Fgr7%y5Fpa1jlU&1eeBYyL<(Si!EX&7V+~4=I z2>cO(31nvWSTxi(pK6xsd@L-I$Jm|kcFu+7T{B0xh#9#3>8|Z6Rld2|{KC7!>+#dm z_qipSgo?y5s$0S;O3a1b0@HPmPkQE z6Q(IjzsJ^$p>d@FSu;XU(dg9jW$|zv(b^3(dPMgzUe=>cLxjXwWHr+?o(pYbhspe# z_HnpQD!x>#h_>X*-9M2uEFj-wZ5{Fc^UDjMDG12-rEqP;QDbAem@X1ZKYhx9PI1|R zC1GqPLR!{UB&iv>{o0YUv&WZajm43!`=~dviAketDp|3vL|=_{8d~Z_Ph9Cz!kn@9bAGI6-7#8Olvr>imHC(CXW$Dd$_>*|vv$ zmCCzx)M6QD4s-1kHp)whWXfy|gluaG$2!bJhHCR&5px7e6CD?Hw?Fk6>>{9{BO&db zQJDws7AnVB)Qz$)0s?rj#g z78d9#=;-Ld_hbj@!gSH12)90aMaRS#H>&p%UtmdO%e6GYd=77b>nNSKEl14l>RqDP zAI>yZ&K2G&Y&1kf@rf0XWS(hqY11w&x&P+opz1Mkg}#eJ-2PYhl`(+>sy<%N2=pua;K*XpBUP{MP3?Snrq;)|t6o30vkCo6#H9N~sKsF^?qOGo&O|q_ z0-S?l>S23S?A7>rT6MXi{>oUqQxa36I;T1AGiB?{BT5uF1R%0pAWilVIPvRxJe-!w zF@4AIFx8lMU#F4qG*Et9?h86WEHz)}iUlGs|6lWj;kWhRJ!4Lb76%pr$P zpcmO-1(Uko67$$nc}doZMCpL#0eVp%faQe?iR}(6qk61==+4R>O1~i9cv^Hes+KKt zA(574ri3{$p-^Ton@3lO~nINZf?>I|9Rdi2ul~< zC?B$PCK^ifi1c;wa$5r7ug^;gMD`%>000q;yxqZK!w}fOq7*m3rm3iZLhD2HN~} z9HOtuGZ_Q`d;3Ne&5e|-rj#FSHFB=lCAZS|IT#o$j&?&59oBC5q6?H`l&3V~ax^kg z3|ZYLFm~3=~^S+b;TW&(ct>M}jrlo`~P`wIz3U8v8Hi{HOEA9zb_q(@C-A{+Cz zo*+LeVD?sx395h#2{&aKvw#3rxnC@X_LG#t$%7R2@`G{=lo(*nQ*R{Ia%DW$6`MgS z-yF;Tm2WjqwYR$(QBC<{b1K9ssmwH=q+Grlda`S@cBGZTMXGdnYJZ?s9x(kn7~;8S z7C9#5ugUA%YZ5|E?SgLKZ9{*s0;@t#Vp2?wSt);+>E`vz)fqsKOVlNz95ov-O!g232@G=+AY z`!ou30MJxMtWC}~qnK=@vL+a2hlWdi3;I#;qFmlSi}llu9#L3GMs#`T3^hGS8Q8J+ zeh@ZtbQTb=q85ibqbwwU3$Z)mUf_bDudO#Gk4A57DrCS=%8|EF?h%{JOmzflYE$1N zKU6%p?PE8|`u2Bg?kXNKn#3m-Fud78m#EJlDfv7R!IQf0+lX^(w0M35WITV4%7{F# zjoG}V4_Ita)|hc9_@V@CyvO&Fzc>>89>Gk-!)(H{<=WgcnH0XcM;hne!p!syKg~2@fY|o^^E>ahP{{C zB>i8F;pMRIExP|Z!l1WVc_e@JJpU6{K(er6f-y%`(O~oMPxZ%(c0~C1P6(MA|CBZU z|NVI>4~N4w0fe1VTue+=Rn@bV+zv2wFmUeqws%E5q@{0BIK77&GsG_bu{_fr7=^unZtvmaETZUZ3VY&(y z_kkpXRzI?8R!g(_&AYSj-eI8n`uYwIUV}p@{LjyJk^^jr2KTQ$kFeGJ&p-&OsZ>7x z%*_wwkD;XTRQ%H`50)NI250#z=WUKlj&1y0TC4soci2-r#)IYv1T(n|h(@ zAt@IcpNFZj$Cb?A*E7)p!~afS-Ucv3#t5P7T#F*0p`pRw?U`sSb03_Ukv{`Blu9N$ z5tOe33DMD=FR;HG85*7*Rl&?`ZaC8oCStuP8xvRNCqh7Uyv42t67(H|nPlsBCZuI*R9UTEDveMyb({CF4OT9 zi1@Vynol*-mJ_JOaM|xv*g-3@y-ic3%lvzxsZR`^&f}+{xs(R3y}%}V3I$ccAbhTJ zd-5S0)im{|Bx~#I_LH?r8Riz#b(TiO47{r!D{0wzZjXST)&eQR?$K-Zl2R=4m2~mb zXJ;dTQX{#4qu&*@ghbJR6KGeY=*j>kuT^ER*Bx~sq}j!Z|F+tojyNq^(CC#bO|}5! zgLkH$d&N^W>@V|$524?Hvs@g%G{;Ei2^;JW5F?h!xfD_f!JK_8L_L+H&uKOsn|ks_ z5v1tN9CO&c15e-L$>eG;1eHWH#B1VW`q|I(Si|W%xi8e6%&e>!9v!9&jt*Lu-81H` zsZO10X~Of2;L_sdWZ+&m_W$Xb`ar+2d+qVcf{f#lafS29^%v^z-#zfo z{7;Wwoi5rvt?12~;4uEsM;(-!+!oTly_>`RRn?Gw<)s>;5w3|sflYCN)aTpZ&-Ol) z&3bG-T*kt9nAyJUZa))c5y53&J#4Pk(}xsF5%Vekoy%T~vT{^r<}vi^aQ(Ty`WJ`C z$Hyln)#>>_;uMQGF(DM~uT4TWjR>mCvE=gmCW@!F_Xkbd{p;?Hj(`iM!v5-`M}Rhm z`$P&tA4%ivTe|BXViOWhw_dsdq9)NkJd#aEaeLCm?ZM{yG&;s6cd(|nF^m!+K=BjY zV!eHR3;R6&|85tuPd_#RD%C7aBKj(r{*R?b8=wG-jHNp{f z@;$WgN z{h z4BVPWc)>CSK$JZ?eo7(~JsNvcxZAfW`ml;`A7SKukmSsd_wg;~^eQTY9+gv{?|jvN z@sizax+;)Om#DjA=ZX>8z~@&Uy>3BLkx1q1_7Y`A)wk*2^`C9u<~Evax2>ppDmeM^ z^~nA(Z9)}hmhdy9@e7~Th{{pU;kf-QN_m2{b=!+Twmfr(s9703qlT@~sik%z2b`@O zN{f}}8{@RMb5v<2>#aqWHNZy(MCFJb^6T&os)H)liDfM1waq#6z{PYoz|GaQ-FxpR z8s61;VKCpr@nNd`hU1{u>^h;C+}&fkbV#vlUc}3za9({oPw0qKp`^tzU46So4rIfV z!#(BupRl&A$x%>H0Lw?BX_Yc<+;*~bp-_II{<};nW6ZnNXSU6nc2vp9Y(4#1qEp26 zr{j9p-A$^&F zvk>XE*|x_P%;PT|e{F5vy*hdWhCRe2Bx1gYD8p=Unp3G&pRNYFpyL@x-8Ffnyc-Um zwxc{YmNy>dnO9X~DaiEn_j~Tls#V-DZh!WSTdyD3#`uA^8tmdP9Ya{U!2D7_(jwJu zGkpHdlFD(_2t@)8L!+RFquYiDo_zW+JuUt<tm8f?ZCw9A9}$3tsc(C zsl8#E#GnNK1Y4`|-F3NKj(4)dS8YatlkN9Q+3L|Q{a%C}upvgjZ=@?pUk^dJ z8IIKW;1eRp`_|SH1`8Y{0F#|U{_eqSt4FRhGBQ%m{Edp0_3HHQd(=7nFW#Mo_e5+2 zDFmu#OB!rUSIeGt>WB8SC)X*O3FSU&95-Vc+>8dE$M zQ@Z4UfKOjKg76rCX833o;7Z*Xn+xwaL`9GKX;&^eh!>%krz7#$o$Op~e_`2wp4;C3 z`c10Z?hG89VyIg(+!S=N4d&^0+knsA+}e8S@Hs9|byFfi?R}{qdjp5~u;%YpLjxU3 zUJ7DiVPO~wV&>=rhv{Q)F?T`Nttx};kbn|yIqBE>&5b4~zbLlH4=`HeFDdf(!*6d(h4-jm$51go8VhI7$RPoC_gRS64ny zPcLdW>$v2Ah*#o%1&g%H^8O6n@Bw}W8b#R3)NXgSs0)fr8DcmZZiAHuCi+$K{E9T4ZZn0G11%{;~DhV>6@m!1-u?O_X_0*|g2~$_QyMFN;-)3><&r zw!iGM49{%<*bI`c?aTJVl8j7DxXZd|-my!0eDaJ|$nNgi_@e^CXlndm_HIkR=x)HD zu#fW!356Mg9?ori@?aqGyde4z1BaHDHcA`I9Wv2=V15O0lQ;Mt96M{g>v>h0Gq*-f z;qe=J+E{(_F_}S{sFbLv+B?gX$maJWFf$lBH}~JBtNN8lq$k}l|M<+#v|65k(aiFG z5*mh!cg=oSq@1`gH@%aIk96o1L*dte=-5ZPQxyK1yR-;uYl#RV5)yuER9JYt?P|Nj z(Qg*6ci+Bpe}LRyUZ(pc>VmlY>Hst|!TtsYqQdBG+65>kfvM+ISK`L{SXmu$mN}X! zDNk-mipa4Y<$~J)H;msp+ipVL3RzN7NKyTwRhKRn z_)6+L{I&*95t%7sizTJ{f#r|#9?Pmd=pt}!TxpTr2EmpfA#=2}&F(t8*RPY0Uh{hj>WPc$V}lgpEQ+@V@uF=cEGW;2KW)7T08}!He1S_-I2#% zQ`k&)(F(ZsNX945o7&~;s=C@Rn$H5@gag7KyL^jJ*v7|PcSq@P z$nd4}5f!DSX{f0cDJfAg(B=KP-iZv#G6K33JPDb?4l@L!sAP+gI2(DIDfUIW0s;@A zs(7fYSRO*yTDYi3nPpYQ4^A`2{dXME`bBWG0{Bq4zEgYG{fc~3pLMT2kcunrH73S~ zomDOTn4zGd@9ell*M7YSpZOW#Zyw{W_(pnUalLZvgI@}x+Qj*%4jiB2F6J;zswZ8w zp`#j;ve66+%X+u6F>$VuL`BL`o>1g=36YVJJ$BWX2y;r&yUS<(fFs>%_sPeao!IbI zwj2};s$x$PEdJl#&AdmK{du{rM5=Wp9&HgnZKkwzG({cwDvvW_(75&nvu*|3OLT7v*pI96F9q+fXYtDXf{U+8nIP(gHVgd7jzqV(=h>BGW~Ma$)w22ZOvg6qG`s z%)Rcv_mMW}3^xkF?`%N+z1XmpB&aSy(oznfYiLqM`{>x$~!7rFP`)9%uGHIhA48?c)p6S>w6CA5U1kn`OqR z*aFcNt+N~H?RWk@&%^d6UEx&Rw+4S4HObjq44q=T zxkj|Ann$J&_II_`|}31&|+1y*n=_z5|#_gIju0;$F&n)oIVP9v}2X`xTHatI6K z-mXj1%hIT*J1QRMug>}4o8Q8$c{SlHt3g3LSzL5oo~U~l$V2#5=n+fvS`60i4Bi-5 z-k+pUeqeUuVsh2Vfpw0uhtp$wCSWi*)gUi|M07E!bw+tXx$curQAjlsA>ks-?;Fg! zCql1OPgI|hr!l{IpZvKN0fCZRMNv-Ae3KBj>X%~$BfQ=0ZG31O@WKKu?(1}Mh64^FY@0{$}ggq1swcEZD8UX=;ZhpM`0nvI-n*9e6J3mwc>+MCnu+;YV_u-rTOMLqXyjw zbx}gX`T0)c3EJg;qWVQ4(z04HOcZNesjg#~UF%&sKU8lu7wr@Cxei<~nr!L^(+7>K zTN6>*P=0+UA~>f1N|5&RQ**u`1I6{MGR<4jZxJ>zpG1ZCv2N*=)aQkS#rHF1$d%#0~jtycLX6F9SOCW>7-=Ej%{Ml!3)Mv03u4 zfGbGIrgz)VK9NaR+^)zj{ioV%c!^HNGXGXv!D{I`iDT*YTl)mzX&l`-CWsQ_{BIoj zr8-VHKo4Xc*MWEok$?X1|9&1^iAnSS_4HF;f}*2lSUn&A{YEckExJn`|Ns2;habK_ z*UUxqrZCmg($djcl({$q!#|NZ5Xl`fIoE)0p(DpqS}!cz2#%#)e$iH+Ur?!ge>d{? zzl;mni(STQ z36k^5=3PYo5(BjTDv-9Q1HM1vH$=6A~-{UpNq}~M}~pbo;?e?BRd?Cdwa{r#5t9quuIrJ#Q&L5^IJ?5wdXB0m+&A&YQv zO@Uqxqc9&xR=t~r*FfiGZ;)~+U`abtD+Muy)39Ff)-f2#u{KT#;+c&teh<0+GNra> zL!E;xGYrObu!Zw~?n_}KqLuQ^n9_OiF97)EU5SI??;Fz*N%Ai4-!~b!{Bc66Quz1{ z_g}6F8vW;F(Sf%pFRH7n-42f24kmH1v0V>##XNuaXK)f-wi+Er8=qJ@lHbk$%qzms z%ZwLu!}>a(1v((vJaRbrbhYq7%FY9kl_T8OANQ&3~`A419AhY{#ceQf)~c^$G=#_3OvA^uIl!v}<7F5m?v|Pc_?1`THAp<$(2P z#&@OTyy^7Sz`8i&OI8lusg#^YX%R_j5q0}YsmGphGUBZ?!zY76qXVca7oQkaUXhRf zb0Kjhy8IpPFFO_tzPmT5k|tK-e$uJ19=`XpcUpZ&yrv#+<@p0kxqp6P*~+pSJqc;I zKyrY&bZBU3ax&q?@yZU&VQi&a8y*CR*cnCUvWK?ZEj@L51U*2TT(tKv#=*>7HQRuhR;Mp-xJd9&>Bx|2(W7U}s>UHihLJ)kE{m_PI|O!qVH{fXS-ksbotU+Wu`!{)zkgr= z)_MZ4>oiN5b~tqGSZVMQS4c<*C_UI7FH$~0LhW1JuAD}?VKO!t z%u_H@e?7%AuJFxY%fgmd1FAZ$#c-QCFS7-8O%~VjWW}&4uII*A=A=Ar^#i9z4fcuk zzuUXx_|Rk#c^IgUNbNAmQyqOA_d3d;4Nz@P>B}G;Q4XL1=TQh9RFsoDcd>E9R!SrWv@Dp(UTW8df4hjP*79 z4vi6`E)oS9Y`N}R%q4k(&?jjpp*T9*IEKo|bH}O6cu!_Tp~BSqNB!*(rbXwZFrBek zJ9+X+sr1FmttTT+{(F6Q7EZ;^3>l2F_XQzLH^Af?eq;m>p>)s(C|xk^Z%eVaw`6Ox z=NrLnAPH+-9T{aHLqii$Uj8ywJb{UcNk{yht?l#|fPO_p{QAT(5RH4}0Q;r4Z^Kts z#EgyO0S~RdGV&DqvBMaH_hLQR+qN%H$Q<*WmS{%ZeC3TtAtf&`9pc?m_It_9GR2nM z80jXt)Y2cXVfrfFVsU&$DECgw5`xa4(~~7GIZWF?YoIO!W4+&GGIy8sF{zmWewW0( zF33W&x7ScrRYjpts;Xr`vBUQRZUV)?w)Sf8;2<3mW*F-Vr;-|TY|c{AsTtT{xH=|# zgUeVu(5R!J7-?*-&H=8~5W=nKL8vLvn@jR`ax%l({({UGSS3l@t9L9J`zoF<^985NTT?%(!xk@uKPOdE?ctbS^!=J@pqrDfnsd1{Z}t1o)3#d` zr?nsLC|VnI+y4ltwg{z`Liw&>S^)IXmNUS^yz@cf;>}25tqm(%+p-9q4*2-iwl z)jb(`s^7yPBjOe$+Lb`lbHwg>QCxNPaSq@f2Ce-lN&MhZ2nbV^Kjmg|_Hmm~U)aa` zjJ+8-d0*=MQ!N@x(IB!dHT_KIqbHO8T9ltvdK+%RDaW`BBN1e;_>E;5D(~tsgvWj# z!+?B;xAmQ&0eeLzsu>@2jr_%`UFA(XeL~`>=XsOBUs*~PB!X|!Db+Imr92kyfQ8Ke zEj%@;x7ew9gPn~}Eh$|hSwOG>EW3k3KGcD2B<+paA@)lTES?chco2BdTQJH!N!dG& z*S!g(HnloNU36DdlZfoX-FCbM71*S#tgyH%<%ET{MTfg#cWd@)Bb}DNBb6aVaZW~SL#vQ!}D?rwTdID}t zR{V=#s0_VAD%Pz`6V&5nWo38eY}NGjTT`AUdpL}1XzqD^=vczIZ?RHSz3vy1+V$Y2 zOE*pun%rDJQhCRBLTAo@46W#3dI~3a-Dg#k{qur)Lhg?$#!S(u*7j=$8^a-jNX~@a zTl~W*nI>HmJ6p)`90StC5&!P>n~*UIY^GRl8Q+anQ&UMP<9QQzVihmf%i>ZB zg7WyKn0IfKVNO8t<>V$9FkMNRUv}`A!glnHl@I zyk34UgJ`T%ks04-7c0>tEA|$(_&#srJwMUSTxgb#dK-szoHXvRSoY4+9jZW`wbEMU zN!bLdcy)CEgguuM&~=XbM-jh|rvH7Wxv;HiXT8~Okh&RMtXp9hBcQgHiW!p$3XlKN z-6IbX$gxa=ik%scq85U4+Zr`+!suO}bdDOL#EY^#z@mc$CtC|1zs-<%ewfP6Zt{2w zA;64FD6g%y^4^5XqvqY0mWv9gL~~!; zSY2DQvdX+RGk_imf};Tx9T4jr1iO#`r7;zu@vi>rZ8!7UYu^Y@PX81N%kg&4YA{T7 z8>`{(35S9N7gD&|rtqX`qiTQ=)=~eSK&4wZ<5!M9r?+gjGcyUvjLsrAA&(Jj7jj?1 zlp_mAj`k+&Vknf}Wn9z7zQ-3!Hb(oMDs1e+AE)x!Kv2loTMF0+mj@w|G?*)IC4GK8HPJ zFl0oNA+}jdcw2qC%tHd#BhI<3KS%ORP5n`xlEP-3ZHPa37kMBW_jxxzDL&#(@P&$=gwgThCw;zu$H0CuZI~?vTO7j3V zI~WyTm*&WT9!`)j8)zA{RnoJDK#&w8?8zSki)KH6ZAmHB$~ZmH4x*zq`;ypvnj8{3 zzcpZ(=z|KdB=Bcv;;giW)V{T4&*M^ya3iuTgRRpbkqE}WlZ%rY!1@VWnGFUuKk=3S zvCB|JuLpM@@Z#m=1<5B2i3@P@D0vYJC?&Zkf9=cX;O34BO+Nq3Iw6Yno6Z7>(B6(G z5X^fs-FGzDaNvcX=4fx{?<+PV9+^i=;^Ps1PaJ=_+M1Km?uS<>LBOtusQ@U&pG*2Gb=-Acbcb_mx znr_<~Gq75sqA)a7gxsS% zz_Css7QR-?Mf0xzqD-{Ja_Wd?8jFYgUJHm~u`6$+$;$!>7$l_Hl~jO;U0kfgEIs+Y z?p|)@a@3^4)iQokfw3TE7Y1U#Bl?Rq5giLGO;Tp{ti>Ee+k*7kF&C%la?5T5&r zJmj62rP6!gxfee_M17NAU+!>O95jm6l(KrCr9e|krgX2fhlJIKValCaIDF5=5TyjV4a&0PoIdKeXpu(YOoF;-*a6VDl`+#%KZ`}a?TN>|S^%3BV> zfPKAp($bbY)6|2gSaJ{rhpt*pEBJwlFB=yZluO;{D%D_SZmA@4)<+w~vmw#}v@u|t zm@lakivQx~o?*tMt@3H;pvkAWPt;Ddi>$Pus%VU)b5Gy+-`4EEt(XzCV#GBC2Zy7o zx4X;vt!Q1l-@PNH$HWBxysKp9J4<5b-Ght1AAv{Mge%D^D74K}JNe6&Twc5F(+*xe zY&Hc)6%TW=GsFw3r!tT3ed>byTmk`nQ~CEb!_Fv8yuW1i%19wz+f{wH0i^JQ1FOco zsoe%G^X`C$>K`zw+KENANA5krDA^VH+wD(hOuyp*huDV9AbocISM4R+AnbImbHlFN z5fly&<2$Nf=F#jz$ij1s0E2xpid@-k=<9pr-s%92yu12~k5LkrEPT$j z3oJ@Y>#qxrtFNyI;lb*swCLN#;7dLUy3gcf)1o4AP+tKlR|OJFvC=j#YJD7sfzEfh zuf2V0aT3kMef@}#vueO}Ar6;F_yO?>_6;m~@~#E diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index 774c237d7..d154b90b0 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -92,6 +92,7 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) overpart: do i=1,npart if (.not. iactive(iphase(i)) .or. isdead_or_accreted(xyzh(4,i)) ) then dudt_sph(i) = 0d0 + cycle endif poti = Gpot_cool(i) du_FLDi = duFLD(i) diff --git a/src/main/force.F90 b/src/main/force.F90 index 491b961a8..82a63baf4 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -2827,7 +2827,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv fsum(ifxi) = fsum(ifxi) + fxi fsum(ifyi) = fsum(ifyi) + fyi fsum(ifzi) = fsum(ifzi) + fzi - if ((icooling==9) .and. iamgasi) Gpot_cool(i) = Gpot_cool(i) + poti ! add contribution from distant nodes + if ((icooling==9) .and. iamgasi) Gpot_cool(i) = Gpot_cool(i) + poti ! add contribution from distant nodes if (gr .and. ien_type == ien_etotal) then fsum(idudtdissi) = fsum(idudtdissi) + vxi*fxi + vyi*fyi + vzi*fzi endif @@ -3065,6 +3065,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv ! cooling timestep dt < fac*u/(du/dt) if (maxvxyzu >= 4 .and. .not. gr) then ! not with gr which uses entropy if (eni + dtc*fxyzu(4,i) < epsilon(0.) .and. eni > epsilon(0.)) dtcool = C_cool*abs(eni/fxyzu(4,i)) + if (dtcool < epsilon(0.) .or. isnan(dtcool)) print *, "dtcool=zero or NaN in force.F90", dtcool endif ! s entropy timestep to avoid too large s entropy leads to infinite temperature diff --git a/src/main/inject_asteroidwind.f90 b/src/main/inject_asteroidwind.f90 index 0df65a857..37072a760 100644 --- a/src/main/inject_asteroidwind.f90 +++ b/src/main/inject_asteroidwind.f90 @@ -29,7 +29,7 @@ module inject real, public :: mdot = 5.e8 ! mass injection rate in grams/second public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par private @@ -149,6 +149,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Returns dndt(t) depending on which function is chosen diff --git a/src/main/inject_bondi.f90 b/src/main/inject_bondi.f90 index 8eb40aec7..9af9af121 100644 --- a/src/main/inject_bondi.f90 +++ b/src/main/inject_bondi.f90 @@ -31,7 +31,8 @@ module inject inject_particles, & write_options_inject, & read_options_inject, & - set_default_options_inject + set_default_options_inject, & + update_injected_par !-- Runtime variables read from input file real, public :: rin = 18.1 @@ -216,6 +217,10 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_firehose.f90 b/src/main/inject_firehose.f90 index 92bf578c0..7db1c2759 100644 --- a/src/main/inject_firehose.f90 +++ b/src/main/inject_firehose.f90 @@ -26,7 +26,7 @@ module inject character(len=*), parameter, public :: inject_type = 'firehose' public :: inject_particles, write_options_inject, read_options_inject - public :: init_inject, set_default_options_inject + public :: init_inject, set_default_options_inject, update_injected_par real, private :: Mdot = 0. real, private :: Mdotcode = 0. @@ -210,6 +210,10 @@ end function Mdotfunc end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_galcen_winds.f90 b/src/main/inject_galcen_winds.f90 index 231367852..5422ba9ff 100644 --- a/src/main/inject_galcen_winds.f90 +++ b/src/main/inject_galcen_winds.f90 @@ -26,7 +26,7 @@ module inject character(len=*), parameter, public :: inject_type = 'galcen_winds' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par real :: outer_boundary = 20. character(len=120) :: datafile = 'winddata.txt' @@ -223,6 +223,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file. diff --git a/src/main/inject_keplerian.f90 b/src/main/inject_keplerian.f90 index 7ade9b7b0..7e4f8e221 100644 --- a/src/main/inject_keplerian.f90 +++ b/src/main/inject_keplerian.f90 @@ -8,16 +8,18 @@ module inject ! ! Injection of material at keplerian speed in an accretion disc ! -! :References: +! :References: ! -! :Owner: Daniel Price +! :Owner: Cristiano Longarini ! ! :Runtime parameters: -! - datafile : *name of data file for wind injection* -! - outer_boundary : *kill gas particles outside this radius* +! - HonR_inj : *aspect ratio to give temperature at rinj* +! - follow_sink : *injection radius is relative to sink particle 1* +! - mdot : *mass injection rate [msun/yr]* +! - rinj : *injection radius* ! -! :Dependencies: dim, eos, infile_utils, io, part, partinject, physcon, -! random, units +! :Dependencies: eos, externalforces, infile_utils, io, options, part, +! partinject, physcon, random, units ! implicit none character(len=*), parameter, public :: inject_type = 'keplerian' @@ -114,7 +116,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& r2min = huge(r2min) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then - r2 = (xyzh(1,i)-x0(1))**2 + (xyzh(2,i)-x0(2))**2 + r2 = (xyzh(1,i)-x0(1))**2 + (xyzh(2,i)-x0(2))**2 dr2 = abs(r2 - rinj*rinj) if (dr2 < r2min) then hguess = xyzh(4,i) @@ -174,8 +176,8 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& vphi = vkep*(1. - (zi/rinj)**2)**(-0.75) ! see Martire et al. (2024) - xyzi = (/rinj*cosphi,rinj*sinphi,zi/) - vxyz = (/-vphi*sinphi, vphi*cosphi, 0./) + xyzi = (/rinj*cosphi,rinj*sinphi,zi/) + vxyz = (/-vphi*sinphi, vphi*cosphi, 0./) u = 1.5*cs**2 @@ -214,11 +216,11 @@ subroutine write_options_inject(iunit) call write_inopt(mdot,'mdot','mass injection rate [msun/yr]',iunit) call write_inopt(rinj,'rinj','injection radius',iunit) if (maxvxyzu >= 4) then - call write_inopt(HonR_inj,'HonR_inj','aspect ratio to give temperature at rinj',iunit) -endif -if (nptmass >= 1) then - call write_inopt(follow_sink,'follow_sink','injection radius is relative to sink particle 1',iunit) -endif + call write_inopt(HonR_inj,'HonR_inj','aspect ratio to give temperature at rinj',iunit) + endif + if (nptmass >= 1) then + call write_inopt(follow_sink,'follow_sink','injection radius is relative to sink particle 1',iunit) + endif end subroutine write_options_inject diff --git a/src/main/inject_keplerianshear.f90 b/src/main/inject_keplerianshear.f90 index ac93e0858..cea2359ae 100644 --- a/src/main/inject_keplerianshear.f90 +++ b/src/main/inject_keplerianshear.f90 @@ -50,7 +50,7 @@ module inject character(len=*), parameter, public :: inject_type = 'keplerianshear' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par public :: set_injection_parameters type injectparams @@ -186,6 +186,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file diff --git a/src/main/inject_rochelobe.f90 b/src/main/inject_rochelobe.f90 index ffe84d4dd..054a264b1 100644 --- a/src/main/inject_rochelobe.f90 +++ b/src/main/inject_rochelobe.f90 @@ -25,7 +25,7 @@ module inject character(len=*), parameter, public :: inject_type = 'rochelobe' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par real, private :: Mdot = 1.0e-9 real, private :: Mdotcode = 0. @@ -278,6 +278,10 @@ subroutine phi_derivs(phinns,phizzs,xyzL1,xx1,xx2,theta_s,m1,m2,mu,r12,Porb) end subroutine phi_derivs +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_sne.f90 b/src/main/inject_sne.f90 index 24d3bc2ab..2152ef1eb 100644 --- a/src/main/inject_sne.f90 +++ b/src/main/inject_sne.f90 @@ -20,7 +20,7 @@ module inject character(len=*), parameter, public :: inject_type = 'supernovae' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par integer, parameter :: maxsn = 30 real, parameter :: xyz_sn(3,maxsn) = & @@ -135,6 +135,11 @@ subroutine inject_particles(time,dtlast_u,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file diff --git a/src/main/inject_steadydisc.f90 b/src/main/inject_steadydisc.f90 index c8ec71e01..eb6d6c128 100644 --- a/src/main/inject_steadydisc.f90 +++ b/src/main/inject_steadydisc.f90 @@ -26,7 +26,7 @@ module inject character(len=*), parameter, public :: inject_type = 'steadydisc' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par real, private :: R_ref,sig_ref real, private :: p_index,q_index,HoverR,M_star @@ -203,6 +203,11 @@ subroutine inject_particles_in_annulus(r1,r2,ninject,injected,list) end subroutine inject_particles_in_annulus +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file diff --git a/src/main/inject_unifwind.f90 b/src/main/inject_unifwind.f90 index d1a456ff6..d2205b97b 100644 --- a/src/main/inject_unifwind.f90 +++ b/src/main/inject_unifwind.f90 @@ -23,7 +23,7 @@ module inject character(len=*), parameter, public :: inject_type = 'unifwind' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,update_injected_par real, public :: wind_density = 7.2d-16 real, public :: wind_velocity = 29. @@ -125,6 +125,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Writes input options to the input file diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index cca46c932..43de42245 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.f90 @@ -34,7 +34,7 @@ module inject character(len=*), parameter, public :: inject_type = 'wind' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - wind_injection_radius,set_default_options_inject + wind_injection_radius,set_default_options_inject,update_injected_par private ! !--runtime settings for this module @@ -78,7 +78,7 @@ subroutine init_inject(ierr) use options, only:icooling,ieos use io, only:fatal,iverbose use setbinary, only:get_eccentricity_vector - use timestep, only:tmax,dtmax + use timestep, only:tmax use wind_equations, only:init_wind_equations use wind, only:setup_wind,save_windprofile use physcon, only:mass_proton_cgs, kboltz, Rg, days, km, au, years, solarm, pi, Gg @@ -88,12 +88,11 @@ subroutine init_inject(ierr) use part, only:xyzmh_ptmass,vxyz_ptmass,massoftype,igas,iboundary,imloss,ilum,iTeff,iReff,nptmass use injectutils, only:get_sphere_resolution,get_parts_per_sphere,get_neighb_distance use cooling_molecular, only:do_molecular_cooling,fit_rho_power,fit_rho_inner,fit_vel,r_compOrb - use ptmass_radiation, only:alpha_rad integer, intent(out) :: ierr - integer :: ires_min,nzones_per_sonic_point,new_nfill + integer :: nzones_per_sonic_point,new_nfill real :: mV_on_MdotR,initial_wind_velocity_cgs,dist_to_sonic_point,semimajoraxis_cgs - real :: dr,dp,mass_of_particles1,tcross,tend,vesc,rsonic,tsonic,initial_Rinject,tboundary + real :: dr,dp,mass_of_particles1,tcross,tend,rsonic,tsonic,initial_Rinject,tboundary real :: separation_cgs,wind_mass_rate_cgs,wind_velocity_cgs,ecc(3),eccentricity,Tstar if (icooling > 0) nwrite = nwrite+1 @@ -232,6 +231,7 @@ subroutine init_inject(ierr) time_between_spheres = mass_of_spheres / wind_mass_rate massoftype(iboundary) = mass_of_particles if (time_between_spheres > tmax) then + call logging(initial_wind_velocity_cgs,rsonic,Tsonic,Tboundary) print *,'time_between_spheres = ',time_between_spheres,' < tmax = ',tmax call fatal(label,'no shell ejection : tmax < time_between_spheres') endif @@ -268,8 +268,29 @@ subroutine init_inject(ierr) print*,'got dr/dp = ',dr/dp,' compared to desired dr on dp = ',wind_shell_spacing endif + xyzmh_ptmass(imloss,wind_emitting_sink) = wind_mass_rate !logging + call logging(initial_wind_velocity_cgs,rsonic,Tsonic,Tboundary) + +end subroutine init_inject + + +!----------------------------------------------------------------------- + +subroutine logging(initial_wind_velocity_cgs,rsonic,Tsonic,Tboundary) + +!----------------------------------------------------------------------- + + use physcon, only:pi,gg + use units, only:utime,udist + use timestep, only:dtmax + use ptmass_radiation, only:alpha_rad + + real, intent(in) :: initial_wind_velocity_cgs,rsonic,Tsonic,Tboundary + integer :: ires_min + real :: vesc + vesc = sqrt(2.*Gg*Mstar_cgs*(1.-alpha_rad)/Rstar_cgs) print*,'mass_of_particles = ',mass_of_particles print*,'particles per sphere = ',particles_per_sphere @@ -309,9 +330,8 @@ subroutine init_inject(ierr) if (iwind_resolution < ires_min) print *,'WARNING! resolution too low to pass sonic point : iwind_resolution < ',ires_min endif - xyzmh_ptmass(imloss,wind_emitting_sink) = wind_mass_rate +end subroutine logging -end subroutine init_inject !----------------------------------------------------------------------- !+ @@ -482,6 +502,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Oscillating inner boundary @@ -635,15 +660,15 @@ subroutine set_default_options_inject(flag) wind_mass_rate_Msun_yr = 8.2d-8 wind_injection_radius_au = 0. else - !trans-sonic wind if (icase == 1) then + !trans-sonic wind sonic_type = 1 wind_velocity_km_s = 0. wind_mass_rate_Msun_yr = 1.d-5 wind_injection_radius_au = 2. wind_temperature = 50000. - !super sonic-wind else + !super sonic-wind sonic_type = 0 wind_velocity_km_s = 20. wind_mass_rate_Msun_yr = 1.d-5 diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 7ef2cdc25..79ee0aac0 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -32,7 +32,7 @@ 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,update_injected_par ! !--runtime settings for this module ! @@ -255,6 +255,10 @@ subroutine inject_or_update_particles(ifirst, n, position, velocity, h, u, bound end subroutine inject_or_update_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine !----------------------------------------------------------------------- !+ From 0f573c64af2a143f61d0bb1261a02718ac8199a3 Mon Sep 17 00:00:00 2001 From: rebeccagmartin <74937128+rebeccagmartin@users.noreply.github.com> Date: Thu, 11 Jul 2024 14:25:05 -0230 Subject: [PATCH 703/814] added sink surface force from Ayliffe & Bate (2010) --- src/main/ptmass.F90 | 30 +++++++++++++++---- src/tests/test_ptmass.f90 | 61 ++++++++++++++++++++++++++++++++++++++- src/tests/testsuite.F90 | 2 +- 3 files changed, 86 insertions(+), 7 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 6b58bb700..e75d1c29d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -59,6 +59,7 @@ module ptmass ! settings affecting routines in module (read from/written to input file) integer, public :: icreate_sinks = 0 + integer, public :: isink_potential = 0 real, public :: rho_crit_cgs = 1.e-10 real, public :: r_crit = 5.e-3 real, public :: h_acc = 1.e-3 @@ -69,7 +70,6 @@ module ptmass real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius real, public :: f_crit_override = 0.0 ! 1000. - logical, public :: use_regnbody = .false. ! subsystems switch logical, public :: use_fourthorder = .true. integer, public :: n_force_order = 3 @@ -160,7 +160,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, 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 + real :: fxj,fyj,fzj,dsx,dsy,dsz,fac,r integer :: j logical :: tofrom,extrap ! @@ -241,14 +241,30 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, ! acceleration of gas due to point mass particle f1 = pmassj*dr3 + + ! acceleration of sink from gas + if (tofrom) f2 = pmassi*dr3 + + ! modified potential + select case (isink_potential) + case(1) + ! Ayliffe & Bate (2010) equation 2 (prevent accretion on to sink) + Rsink = xyzmh_ptmass(iReff,j) + r=1./ddr + if (Rsink > 0. .and. r < 2*Rsink) then + fac = (1. - (2. - r/Rsink)**4) + f1 = f1*fac + f2 = f2*fac + phi = phi - pmassj*(r**3/3.-4.*r**2*Rsink+24.*r*Rsink**2 & + -16.*Rsink**4/r-32.*Rsink**3*log(r))/Rsink**4 + endif + end select + ftmpxi = ftmpxi - dx*f1 ftmpyi = ftmpyi - dy*f1 ftmpzi = ftmpzi - dz*f1 phi = phi - pmassj*ddr ! potential (GM/r) - ! acceleration of sink from gas - if (tofrom) f2 = pmassi*dr3 - ! additional accelerations due to oblateness if (abs(J2) > 0.) then shat = unitvec(xyzmh_ptmass(ispinx:ispinz,j)) @@ -1934,6 +1950,7 @@ subroutine write_options_ptmass(iunit) integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling sink particles' + call write_inopt(isink_potential,'isink_potential','sink potential(0=1/r,1=surf)',iunit) if (gravity) then call write_inopt(icreate_sinks,'icreate_sinks','allow automatic sink particle creation',iunit) if (icreate_sinks > 0) then @@ -1980,6 +1997,9 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) icreate_sinks ngot = ngot + 1 if (icreate_sinks < 0) call fatal(label,'sink creation option out of range') + case('isink_potential') + read(valstring,*,iostat=ierr) isink_potential + ngot = ngot + 1 case('rho_crit_cgs') read(valstring,*,iostat=ierr) rho_crit_cgs if (rho_crit_cgs < 0.) call fatal(label,'rho_crit < 0') diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 966a77727..969132c99 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -40,7 +40,7 @@ subroutine test_ptmass(ntests,npass,string) integer, intent(inout) :: ntests,npass integer :: itmp,ierr,itest,istart logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening - logical :: do_test_chinese_coin,do_test_merger + logical :: do_test_chinese_coin,do_test_merger,do_test_potential logical :: testall if (id==master) write(*,"(/,a,/)") '--> TESTING PTMASS MODULE' @@ -50,6 +50,7 @@ subroutine test_ptmass(ntests,npass,string) do_test_createsink = .false. do_test_softening = .false. do_test_merger = .false. + do_test_potential = .false. do_test_chinese_coin = .false. testall = .false. istart = 1 @@ -64,6 +65,8 @@ subroutine test_ptmass(ntests,npass,string) do_test_softening = .true. case('ptmassmerger') do_test_merger = .true. + case('ptmasspotential') + do_test_potential = .true. case('ptmasschinchen','ptmasscoin','chinchen','coin','chinesecoin') do_test_chinese_coin = .true. case('ptmassfsi','fsi') @@ -111,6 +114,10 @@ subroutine test_ptmass(ntests,npass,string) if (do_test_merger .or. testall) call test_merger(ntests,npass) enddo ! + ! Test of sink particle potentials + ! + if (do_test_potential .or. testall) call test_sink_potential(ntests,npass) + ! ! Tests of accrete_particle routine ! if (do_test_accretion .or. testall) then @@ -1111,6 +1118,58 @@ subroutine test_merger(ntests,npass) end subroutine test_merger +!----------------------------------------------------------------------- +!+ +! Test sink particle surface force, simply that the acceleration +! is the gradient of the potential +!+ +!----------------------------------------------------------------------- +subroutine test_sink_potential(ntests,npass) + use io, only:id,master + use testutils, only:checkval,update_test_scores + use ptmass, only:get_accel_sink_gas,isink_potential + use part, only:npart,npartoftype,nptmass,xyzmh_ptmass,ihacc,iReff + use units, only:set_units + integer, intent(inout) :: ntests,npass + integer :: nfailed(1) + real :: phi1,phi,eps,x0(3) + real :: dphidx,hi,xi,yi,zi,dumxi,dumyi,dumzi,fxi,fyi,fzi,rp + + if (id==master) write(*,"(/,a)") '--> testing sink particle surface force' + nptmass = 1 + npart = 0 + npartoftype = 0 + hi = 0. + x0 = [100.,100.,100.] + rp = 2. + isink_potential = 1 + ! place a single point mass at a random location + xyzmh_ptmass(1:3,1) = x0 + xyzmh_ptmass(4,1) = 3.14159 + xyzmh_ptmass(ihacc,1) = 0. + xyzmh_ptmass(iReff,1) = rp ! surface radius = 2 + + call set_units(mass=1.d0,dist=1.d0,G=1.d0) + + ! evaluate sink-gas acceleration at some position + xi = x0(1) + 1.00001*rp + yi = x0(2) + 1.*rp + zi = x0(3) + 1.*rp + call get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi) + ! evaluate sink-gas acceleration at some position + epsilon + eps = 1.e-6 + call get_accel_sink_gas(nptmass,xi+eps,yi,zi,hi,xyzmh_ptmass,dumxi,dumyi,dumzi,phi1) + ! get the derivative of phi and check it equals the acceleration + dphidx = -(phi1 - phi)/eps + + call checkval(dphidx,fxi,3.3e-8,nfailed(1),'dphi/dx = acceleration') + call update_test_scores(ntests,nfailed(1:1),npass) + + ! reset options + isink_potential = 0 + +end subroutine test_sink_potential + !----------------------------------------------------------------------- !+ ! Helper function used in sink particle creation test diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index a5c129f0d..daa5e8f4f 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -447,7 +447,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) "|_| /_/ \_\____/____/ " write(*,"(a)") 'TEST SUITE PASSED' - call system("say OK") + call system("say fantastic!") else write(*,"(5(a,/))") & " _____ _ ___ _ ", & From 70025fad989dcf4244b552ec2ab057a4e6486366 Mon Sep 17 00:00:00 2001 From: Madeline Overton Date: Thu, 11 Jul 2024 10:12:41 -0700 Subject: [PATCH 704/814] fixed name change inject_asteroidwind to inject_randomwind and added setup randomwind --- build/Makefile_setups | 16 ++- src/main/inject_asteroidwind.f90 | 235 ------------------------------- src/main/inject_randomwind.f90 | 84 ++++++----- 3 files changed, 62 insertions(+), 273 deletions(-) delete mode 100644 src/main/inject_asteroidwind.f90 diff --git a/build/Makefile_setups b/build/Makefile_setups index 5b875708a..e236c8b44 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -74,8 +74,8 @@ ifeq ($(SETUP), wddisc) DUST=yes endif -ifeq ($(SETUP), randomwind) -# object emitting a wind (Trevascus et al. 2021) +ifeq ($(SETUP), asteroidwind) +# asteroid emitting a wind (Trevascus et al. 2021) SETUPFILE=setup_asteroidwind.f90 SRCINJECT=utils_binary.f90 inject_randomwind.f90 IND_TIMESTEPS=yes @@ -165,6 +165,18 @@ ifeq ($(SETUP), disc) IND_TIMESTEPS=yes endif +ifeq ($(SETUP), randomwind) +# one component of binary emitting a wind + DISC_VISCOSITY=yes + SETUPFILE=setup_disc.f90 + ANALYSIS= analysis_disc.f90 + SRCINJECT=utils_binary.f90 inject_randomwind.f90 + IND_TIMESTEPS=yes + CONST_AV=yes + ISOTHERMAL=yes + KNOWN_SETUP=yes +endif + ifeq ($(SETUP), grtde) # tidal disruption event in general relativity SETUPFILE= setup_grtde.f90 diff --git a/src/main/inject_asteroidwind.f90 b/src/main/inject_asteroidwind.f90 deleted file mode 100644 index 37072a760..000000000 --- a/src/main/inject_asteroidwind.f90 +++ /dev/null @@ -1,235 +0,0 @@ -!--------------------------------------------------------------------------! -! 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 inject -! -! Injection module for wind from an orbiting asteroid, as used -! in Trevascus et al. (2021) -! -! :References: -! Trevascus et al. (2021), MNRAS 505, L21-L25 -! -! :Owner: David Liptai -! -! :Runtime parameters: -! - mdot : *mass injection rate in grams/second* -! - mdot_type : *injection rate (0=const, 1=cos(t), 2=r^(-2))* -! - vlag : *percentage lag in velocity of wind* -! -! :Dependencies: binaryutils, externalforces, infile_utils, io, options, -! part, partinject, physcon, random, units -! - use io, only:error - use physcon, only:pi - implicit none - character(len=*), parameter, public :: inject_type = 'asteroidwind' - real, public :: mdot = 5.e8 ! mass injection rate in grams/second - - public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject,update_injected_par - - private - - real :: npartperorbit = 1000. ! particle injection rate in particles per orbit - real :: vlag = 0.0 ! percentage lag in velocity of wind - integer :: mdot_type = 2 ! injection rate (0=const, 1=cos(t), 2=r^(-2)) - -contains -!----------------------------------------------------------------------- -!+ -! Initialize global variables or arrays needed for injection routine -!+ -!----------------------------------------------------------------------- -subroutine init_inject(ierr) - integer, intent(inout) :: ierr - - ierr = 0 - -end subroutine init_inject - -!----------------------------------------------------------------------- -!+ -! Inject particles -!+ -!----------------------------------------------------------------------- -subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npart_old,npartoftype,dtinject) - use io, only:fatal - use part, only:nptmass,massoftype,igas,hfact,ihsoft - use partinject, only:add_or_update_particle - use physcon, only:twopi,gg,kboltz,mass_proton_cgs - use random, only:get_random_pos_on_sphere - use units, only:umass, utime - use options, only:iexternalforce - use externalforces,only:mass1 - use binaryutils, only:get_orbit_bits - real, intent(in) :: time, dtlast - real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart, npart_old - integer, intent(inout) :: npartoftype(:) - real, intent(out) :: dtinject - real, dimension(3) :: xyz,vxyz,r1,r2,v2,vhat,v1 - integer :: i,ipart,npinject,seed,pt - real :: dmdt,rasteroid,h,u,speed,inject_this_step - real :: m1,m2,r - real :: dt - real, save :: have_injected,t_old - real, save :: semia - - if (nptmass < 2 .and. iexternalforce == 0) & - call fatal('inject_asteroidwind','not enough point masses for asteroid wind injection') - if (nptmass > 2) & - call fatal('inject_asteroidwind','too many point masses for asteroid wind injection') - - if (nptmass == 2) then - pt = 2 - r1 = xyzmh_ptmass(1:3,1) - m1 = xyzmh_ptmass(4,1) - v1 = vxyz_ptmass(1:3,1) - else - pt = 1 - r1 = 0. - m1 = mass1 - v1 = 0. - endif - - r2 = xyzmh_ptmass(1:3,pt) - rasteroid = xyzmh_ptmass(ihsoft,pt) - m2 = xyzmh_ptmass(4,pt) - v2 = vxyz_ptmass(1:3,pt) - - speed = sqrt(dot_product(v2,v2)) - vhat = v2/speed - - r = sqrt(dot_product(r1-r2,r1-r2)) - - ! - ! Add any dependency on radius to mass injection rate (and convert to code units) - ! - dmdt = mdot*mdot_func(r,semia)/(umass/utime) ! Use semi-major axis as r_ref - - ! - !-- How many particles do we need to inject? - ! (Seems to need at least eight gas particles to not crash) <-- This statement may or may not be true... - ! - if (npartoftype(igas) < 8) then - npinject = 8-npartoftype(igas) - else - ! Calculate how many extra particles from previous step to now - dt = time - t_old - inject_this_step = dt*mdot/massoftype(igas)/(umass/utime) - - npinject = max(0, int(0.5 + have_injected + inject_this_step - npartoftype(igas) )) - - ! Save for next step (faster than integrating the whole thing each time) - t_old = time - have_injected = have_injected + inject_this_step - endif - - ! - !-- Randomly inject particles around the asteroids outer 'radius'. - ! Only inject them on the side that is facing the central sink - ! - do i=1,npinject - xyz = r2 + rasteroid*get_random_pos_on_sphere(seed) - vxyz = (1.-vlag/100)*speed*vhat - u = 0. ! setup is isothermal so utherm is not stored - h = hfact*(rasteroid/2.) - ipart = npart + 1 - call add_or_update_particle(igas,xyz,vxyz,h,u,ipart,npart,npartoftype,xyzh,vxyzu) - enddo - - ! - !-- no constraint on timestep - ! - dtinject = huge(dtinject) - -end subroutine inject_particles - -subroutine update_injected_par - ! -- placeholder function - ! -- does not do anything and will never be used -end subroutine - -!----------------------------------------------------------------------- -!+ -! Returns dndt(t) depending on which function is chosen -! Note that time in this function is strictly the fraction -! of the orbit, not absolute time -!+ -!----------------------------------------------------------------------- -real function mdot_func(r,r_ref) - real, intent(in) :: r,r_ref - - select case (mdot_type) - case (2) - mdot_func = (r_ref/r)**2 - case default - mdot_func = 1.0 - end select - -end function mdot_func - -!----------------------------------------------------------------------- -!+ -! Writes input options to the input file. -!+ -!----------------------------------------------------------------------- -subroutine write_options_inject(iunit) - use infile_utils, only:write_inopt - integer, intent(in) :: iunit - - call write_inopt(mdot,'mdot','mass injection rate in grams/second',iunit) - call write_inopt(npartperorbit,'npartperorbit',& - 'particle injection rate in particles/binary orbit',iunit) - call write_inopt(vlag,'vlag','percentage lag in velocity of wind',iunit) - call write_inopt(mdot_type,'mdot_type','injection rate (0=const, 1=cos(t), 2=r^(-2))',iunit) - -end subroutine write_options_inject - -!----------------------------------------------------------------------- -!+ -! Reads input options from the input file. -!+ -!----------------------------------------------------------------------- -subroutine read_options_inject(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_inject' - - imatch = .true. - select case(trim(name)) - case('mdot') - read(valstring,*,iostat=ierr) mdot - ngot = ngot + 1 - if (mdot < 0.) call fatal(label,'mdot < 0 in input options') - case('npartperorbit') - read(valstring,*,iostat=ierr) npartperorbit - ngot = ngot + 1 - if (npartperorbit < 0.) call fatal(label,'npartperorbit < 0 in input options') - case('vlag') - read(valstring,*,iostat=ierr) vlag - ngot = ngot + 1 - case('mdot_type') - read(valstring,*,iostat=ierr) mdot_type - ngot = ngot + 1 - case default - imatch = .false. - end select - - igotall = (ngot >= 1) - -end subroutine read_options_inject - -subroutine set_default_options_inject(flag) - integer, optional, intent(in) :: flag - -end subroutine set_default_options_inject - -end module inject diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index 8bf8e9355..fc91f058b 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -1,22 +1,23 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2022 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2024 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! -! http://phantomsph.bitbucket.io/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module inject ! -! None +! Injection module for wind from an orbiting body, as used +! in Trevascus et al. (2021) ! -! :References: None +! :References: +! Trevascus et al. (2021), MNRAS 505, L21-L25 ! ! :Owner: David Liptai ! ! :Runtime parameters: -! - mdot : *mass injection rate in grams/second* -! - mdot_type : *injection rate (0=const, 1=cos(t), 2=r^(-2))* -! - npartperorbit : *particle injection rate in particles/binary orbit* -! - vlag : *percentage lag in velocity of wind* +! - mdot : *mass injection rate in grams/second* +! - mdot_type : *injection rate (0=const, 1=cos(t), 2=r^(-2))* +! - vlag : *percentage lag in velocity of wind* ! ! :Dependencies: binaryutils, externalforces, infile_utils, io, options, ! part, partinject, physcon, random, units @@ -25,17 +26,16 @@ module inject use physcon, only:pi implicit none character(len=*), parameter, public :: inject_type = 'randomwind' - real, public :: mdot = 5.e8 ! mass injection rate in grams/second - real,save :: dndt_scaling ! scaling to get ninject correct + real, public :: mdot = 5.e8 ! mass injection rate in grams/second - public :: init_inject,inject_particles,write_options_inject,read_options_inject + public :: init_inject,inject_particles,write_options_inject,read_options_inject,& + set_default_options_inject,update_injected_par private real :: npartperorbit = 1000. ! particle injection rate in particles per orbit real :: vlag = 0.0 ! percentage lag in velocity of wind integer :: mdot_type = 2 ! injection rate (0=const, 1=cos(t), 2=r^(-2)) - logical,save :: scaling_set ! has the scaling been set (initially false) contains !----------------------------------------------------------------------- @@ -46,8 +46,6 @@ module inject subroutine init_inject(ierr) integer, intent(inout) :: ierr - scaling_set = .false. - ierr = 0 end subroutine init_inject @@ -58,7 +56,7 @@ end subroutine init_inject !+ !----------------------------------------------------------------------- subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - npart,npartoftype,dtinject) + npart,npart_old,npartoftype,dtinject) use io, only:fatal use part, only:nptmass,massoftype,igas,hfact,ihsoft use partinject, only:add_or_update_particle @@ -70,19 +68,21 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& use binaryutils, only:get_orbit_bits real, intent(in) :: time, dtlast real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) - integer, intent(inout) :: npart + integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject real, dimension(3) :: xyz,vxyz,r1,r2,v2,vhat,v1 integer :: i,ipart,npinject,seed,pt - real :: dmdt,robject,h,u,speed,inject_this_step + real :: dmdt,rbody,h,u,speed,inject_this_step real :: m1,m2,r real :: dt real, save :: have_injected,t_old real, save :: semia - if (nptmass < 2 .and. iexternalforce == 0) call fatal('inject_randomwind','not enough point masses for random wind injection') - if (nptmass > 2) call fatal('inject_randomwind','too many point masses for random wind injection') + if (nptmass < 2 .and. iexternalforce == 0) & + call fatal('inject_randomwind','not enough point masses for random wind injection') + if (nptmass > 2) & + call fatal('inject_randomwind','too many point masses for random wind injection') if (nptmass == 2) then pt = 2 @@ -97,7 +97,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& endif r2 = xyzmh_ptmass(1:3,pt) - robject = xyzmh_ptmass(ihsoft,pt) + rbody = xyzmh_ptmass(ihsoft,pt) m2 = xyzmh_ptmass(4,pt) v2 = vxyz_ptmass(1:3,pt) @@ -106,15 +106,16 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& r = sqrt(dot_product(r1-r2,r1-r2)) -! -! Add any dependency on radius to mass injection rate (and convert to code units) -! + ! + ! Add any dependency on radius to mass injection rate (and convert to code units) + ! dmdt = mdot*mdot_func(r,semia)/(umass/utime) ! Use semi-major axis as r_ref -!-- How many particles do we need to inject? -! (Seems to need at least eight gas particles to not crash) <-- This statement may or may not be true... -! - if (npartoftype(igas)<8) then + ! + !-- How many particles do we need to inject? + ! (Seems to need at least eight gas particles to not crash) <-- This statement may or may not be true... + ! + if (npartoftype(igas) < 8) then npinject = 8-npartoftype(igas) else ! Calculate how many extra particles from previous step to now @@ -128,13 +129,14 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& have_injected = have_injected + inject_this_step endif -!-- Randomly inject particles around the asteroids outer 'radius' -! + ! + !-- Randomly inject particles around the body's outer 'radius'. + ! do i=1,npinject - xyz = r2 + robject*get_random_pos_on_sphere(seed) + xyz = r2 + rbody*get_random_pos_on_sphere(seed) vxyz = (1.-vlag/100)*speed*vhat u = 0. ! setup is isothermal so utherm is not stored - h = hfact*(robject/2.) + h = hfact*(rbody/2.) ipart = npart + 1 call add_or_update_particle(igas,xyz,vxyz,h,u,ipart,npart,npartoftype,xyzh,vxyzu) enddo @@ -146,6 +148,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& end subroutine inject_particles +subroutine update_injected_par + ! -- placeholder function + ! -- does not do anything and will never be used +end subroutine + !----------------------------------------------------------------------- !+ ! Returns dndt(t) depending on which function is chosen @@ -153,7 +160,6 @@ end subroutine inject_particles ! of the orbit, not absolute time !+ !----------------------------------------------------------------------- - real function mdot_func(r,r_ref) real, intent(in) :: r,r_ref @@ -175,10 +181,11 @@ subroutine write_options_inject(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit - call write_inopt(mdot ,'mdot' ,'mass injection rate in grams/second' ,iunit) - call write_inopt(npartperorbit,'npartperorbit','particle injection rate in particles/binary orbit',iunit) - call write_inopt(vlag ,'vlag' ,'percentage lag in velocity of wind' ,iunit) - call write_inopt(mdot_type ,'mdot_type' ,'injection rate (0=const, 1=cos(t), 2=r^(-2))' ,iunit) + call write_inopt(mdot,'mdot','mass injection rate in grams/second',iunit) + call write_inopt(npartperorbit,'npartperorbit',& + 'particle injection rate in particles/binary orbit',iunit) + call write_inopt(vlag,'vlag','percentage lag in velocity of wind',iunit) + call write_inopt(mdot_type,'mdot_type','injection rate (0=const, 1=cos(t), 2=r^(-2))',iunit) end subroutine write_options_inject @@ -219,4 +226,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) end subroutine read_options_inject +subroutine set_default_options_inject(flag) + integer, optional, intent(in) :: flag + +end subroutine set_default_options_inject + end module inject From a3a7a0a745716098a156b140db18425bd0d5c0dc Mon Sep 17 00:00:00 2001 From: Madeline Overton Date: Thu, 11 Jul 2024 10:15:52 -0700 Subject: [PATCH 705/814] fixed email --- .mailmap | 1 + 1 file changed, 1 insertion(+) diff --git a/.mailmap b/.mailmap index 8332207b8..c8f50cfe7 100644 --- a/.mailmap +++ b/.mailmap @@ -115,4 +115,5 @@ Amena Faruqi <42060670+amenafaruqi@users.noreply.gi Amena Faruqi Amena Faruqi Alison Young Alison Young Simone Ceppi Simone Ceppi +Madeline Overton Madeline Nicole Overton Nicolás Cuello Nicolas Cuello From 6d3a0cd47de832d11d1a445fcbb24eea40a0dc21 Mon Sep 17 00:00:00 2001 From: Ariel Chitan Date: Thu, 11 Jul 2024 14:22:45 -0400 Subject: [PATCH 706/814] Corrected dist_unit not found error for grdisc setup w/o GR. --- build/Makefile_setups | 2 +- src/setup/setup_grdisc.F90 | 6 ++---- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/build/Makefile_setups b/build/Makefile_setups index d5f34b9a5..94c9d7e0d 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -206,7 +206,7 @@ ifeq ($(SETUP), grdisc) # accretion disc around a Kerr black hole SETUPFILE= setup_grdisc.f90 ANALYSIS= analysis_disc.f90 - GR=yes + GR=no METRIC=kerr KNOWN_SETUP=yes MULTIRUNFILE= multirun.f90 diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index 6bd0d7953..ed22b212c 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -251,7 +251,6 @@ subroutine write_setupfile(filename) use infile_utils, only:write_inopt use setstar, only:write_options_stars use setorbit, only:write_options_orbit - use dim, only:gr use setunits, only:write_options_units character(len=*), intent(in) :: filename integer, parameter :: iunit = 20 @@ -259,7 +258,7 @@ subroutine write_setupfile(filename) print "(a)",' writing setup options file '//trim(filename) open(unit=iunit,file=filename,status='replace',form='formatted') - call write_options_units(iunit,gr) + call write_options_units(iunit,gr=.true.) write(iunit,"(/,a)") '# disc parameters' call write_inopt(mhole ,'mhole' ,'mass of black hole (solar mass)' , iunit) @@ -293,7 +292,6 @@ subroutine read_setupfile(filename,ierr) use setstar, only:read_options_stars use setorbit, only:read_options_orbit use eos, only:ieos,polyk - use dim, only:gr use setunits, only:read_options_and_set_units character(len=*), intent(in) :: filename integer, intent(out) :: ierr @@ -305,7 +303,7 @@ subroutine read_setupfile(filename,ierr) 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_and_set_units(db,nerr,gr=.true.) call read_inopt(mhole ,'mhole' ,db,min=0.,errcount=nerr) call read_inopt(mdisc ,'mdisc' ,db,min=0.,errcount=nerr) call read_inopt(r_in ,'r_in' ,db,min=0.,errcount=nerr) From 043922d998df9e0b374378829be61f986fa32022 Mon Sep 17 00:00:00 2001 From: Madeline Overton Date: Fri, 12 Jul 2024 05:07:19 -0700 Subject: [PATCH 707/814] fixed compile time choices for setup randomwind --- build/Makefile_setups | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/build/Makefile_setups b/build/Makefile_setups index e236c8b44..1eead4b84 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -171,10 +171,10 @@ ifeq ($(SETUP), randomwind) SETUPFILE=setup_disc.f90 ANALYSIS= analysis_disc.f90 SRCINJECT=utils_binary.f90 inject_randomwind.f90 - IND_TIMESTEPS=yes - CONST_AV=yes ISOTHERMAL=yes KNOWN_SETUP=yes + MULTIRUNFILE= multirun.f90 + IND_TIMESTEPS=yes endif ifeq ($(SETUP), grtde) From f7a98c17fe0924ba7c24d187675e237334ff2d89 Mon Sep 17 00:00:00 2001 From: DavidBamba Date: Fri, 12 Jul 2024 14:20:16 -0230 Subject: [PATCH 708/814] (gr) can use tabulated metric independently of einstein toolkit --- build/Makefile | 20 ++++- src/main/initial.F90 | 11 ++- src/main/metric_et.f90 | 83 +++++++++++------- src/main/metric_et_utils.f90 | 150 +++++++++++++++++++++++++++++++++ src/utils/einsteintk_utils.f90 | 36 ++------ src/utils/tabulate_metric.f90 | 67 +++++++++++++++ 6 files changed, 307 insertions(+), 60 deletions(-) create mode 100644 src/main/metric_et_utils.f90 create mode 100644 src/utils/tabulate_metric.f90 diff --git a/build/Makefile b/build/Makefile index a6a52c554..4a609420c 100644 --- a/build/Makefile +++ b/build/Makefile @@ -488,7 +488,7 @@ ifdef METRIC else SRCMETRIC= metric_minkowski.f90 endif -SRCGR=inverse4x4.f90 einsteintk_utils.f90 $(SRCMETRIC) metric_tools.f90 utils_gr.f90 interpolate3D.f90 tmunu2grid.f90 +SRCGR=inverse4x4.f90 metric_et_utils.f90 einsteintk_utils.f90 $(SRCMETRIC) metric_tools.f90 utils_gr.f90 interpolate3D.f90 tmunu2grid.f90 # # chemistry and cooling # @@ -1230,6 +1230,24 @@ combinedustdumps: checksys checkparams $(OBJCDD) cleancombinedustdumps: rm -f $(BINDIR)/combinedustdumps +#---------------------------------------------------- +# these are the sources for the tabulate_metric tility +.PHONY: tabulate_metric +SRCTAB= io.F90 utils_infiles.f90 metric_${METRIC}.f90 metric_et_utils.f90 tabulate_metric.f90 #metric_tools.F90 +OBJTAB1= $(SRCTAB:.F90=.o) +OBJTAB= $(OBJTAB1:.f90=.o) + +tabulate_metric: checksys $(OBJTAB) + @echo "" + @echo "tabulate_metric: Because grids are great" + @echo "" + $(FC) $(FFLAGS) -o $(BINDIR)/$@ $(OBJTAB) + +cleantabulatemetric: + rm -f $(BINDIR)/tabulate_metric + + + include Makefile_qscripts diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 4c9a97aa2..6f81d142f 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -41,7 +41,7 @@ module initial !+ !---------------------------------------------------------------- subroutine initialise() - use dim, only:mpi + use dim, only:mpi,gr use io, only:fatal,die,id,master,nprocs,ievfile #ifdef FINVSQRT use fastmath, only:testsqrt @@ -56,6 +56,8 @@ subroutine initialise() use cpuinfo, only:print_cpuinfo use checkoptions, only:check_compile_time_settings use readwrite_dumps, only:init_readwrite_dumps + use metric, only:metric_type + use metric_et_utils, only:read_tabulated_metric,gridinit integer :: ierr ! !--write 'PHANTOM' and code version @@ -99,6 +101,13 @@ subroutine initialise() !--initialise MPI domains ! call init_domains(nprocs) +! +!--initialise metric if tabulated +! + if (gr .and. metric_type=='et') then + call read_tabulated_metric('tabuled_metric.dat',ierr) + gridinit = .true. + endif call init_readwrite_dumps() diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index ce133ea83..97dceb66d 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -32,33 +32,37 @@ module metric !+ !---------------------------------------------------------------- pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) - use einsteintk_utils, only:gridinit + use metric_et_utils, only:gridinit real, intent(in) :: position(3) real, intent(out) :: gcov(0:3,0:3) real, intent(out), optional :: gcon(0:3,0:3) real, intent(out), optional :: sqrtg + integer :: ierr ! The subroutine that computes the metric tensor for a given position ! In this case it is interpolated from the global grid values ! Perform trilenar interpolation if ( .not. gridinit) then + ierr = 1 ! This is required for phantomsetup ! As no grid information has been passed to phantom from ET ! So interpolation cannot be performed - gcov = 0. - gcov(0,0) = -1. - gcov(1,1) = 1. - gcov(2,2) = 1. - gcov(3,3) = 1. - if (present(gcon)) then - gcon = 0. - gcon(0,0) = -1. - gcon(1,1) = 1. - gcon(2,2) = 1. - gcon(3,3) = 1. + if (ierr /= 0) then + gcov = 0. + gcov(0,0) = -1. + gcov(1,1) = 1. + gcov(2,2) = 1. + gcov(3,3) = 1. + if (present(gcon)) then + gcon = 0. + gcon(0,0) = -1. + gcon(1,1) = 1. + gcon(2,2) = 1. + gcon(3,3) = 1. + endif + if (present(sqrtg)) sqrtg = -1. endif - if (present(sqrtg)) sqrtg = -1. elseif (present(gcon) .and. present(sqrtg)) then call interpolate_metric(position,gcov,gcon,sqrtg) else @@ -95,17 +99,26 @@ pure subroutine get_metric_spherical(position,gcov,gcon,sqrtg) end subroutine get_metric_spherical + pure subroutine metric_cartesian_derivatives(position,dgcovdx, dgcovdy, dgcovdz) - use einsteintk_utils, only:gridinit - real, intent(in) :: position(3) - real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3), dgcovdz(0:3,0:3) - if (.not. gridinit) then - dgcovdx = 0. - dgcovdy = 0. - dgcovdz = 0. - else - call interpolate_metric_derivs(position,dgcovdx,dgcovdy,dgcovdz) - endif + use metric_et_utils, only:gridinit +! use grid, only:read_tabulated_metric + real, intent(in) :: position(3) + real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3), dgcovdz(0:3,0:3) + integer :: ierr + if (.not. gridinit) then + ierr = 1 + if (ierr /= 0) then + dgcovdx = 0. + dgcovdy = 0. + dgcovdz = 0. + else + ! gridinit = .true. + call interpolate_metric_derivs(position,dgcovdx,dgcovdy,dgcovdz) + endif + else + call interpolate_metric_derivs(position,dgcovdx,dgcovdy,dgcovdz) + endif end subroutine metric_cartesian_derivatives pure subroutine metric_spherical_derivatives(position,dgcovdr, dgcovdtheta, dgcovdphi) @@ -154,6 +167,7 @@ subroutine write_options_metric(iunit) integer, intent(in) :: iunit write(iunit,"(/,a)") '# There are no options relating to the '//trim(metric_type)//' metric' + !call write_inopt(metric_file,'metric_file','file from which to read tabulated metric (blank if used with einsteintk)',iunit) end subroutine write_options_metric @@ -166,9 +180,17 @@ subroutine read_options_metric(name,valstring,imatch,igotall,ierr) character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr - - ! imatch = .true. - ! igotall = .true. + integer, save :: ngot = 0 + + select case(trim(name)) + !case('metric_file') + ! read(valstring,*,iostat=ierr) metric_file + ! ngot = ngot + 1 + case default + imatch = .false. + end select + !igotall = (ngot >= 1) + igotall = .true. end subroutine read_options_metric @@ -181,8 +203,8 @@ end subroutine read_options_metric pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) ! linear and cubic interpolators should be moved to their own subroutine ! away from eos_shen - use eos_shen, only:linear_interpolator_one_d - use einsteintk_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid,gridorigin!,gridsize + use eos_shen, only:linear_interpolator_one_d + use metric_et_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid,gridorigin!,gridsize real, intent(in) :: position(3) real, intent(out) :: gcov(0:3,0:3) real, intent(out), optional :: gcon(0:3,0:3), sqrtg @@ -291,7 +313,7 @@ end subroutine interpolate_metric pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) use eos_shen, only:linear_interpolator_one_d - use einsteintk_utils, only:metricderivsgrid, dxgrid,gridorigin + use metric_et_utils, only:metricderivsgrid, dxgrid,gridorigin real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3),dgcovdz(0:3,0:3) real, intent(in) :: position(3) integer :: xlower,ylower,zlower!,xupper,yupper,zupper @@ -389,7 +411,7 @@ pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) end subroutine interpolate_metric_derivs pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) - use einsteintk_utils, only:gridorigin + use metric_et_utils, only:gridorigin real, intent(in) :: position(3) real, intent(in) :: dx(3) integer, intent(out) :: xlower,ylower,zlower @@ -414,3 +436,4 @@ end subroutine get_grid_neighbours end module metric + diff --git a/src/main/metric_et_utils.f90 b/src/main/metric_et_utils.f90 new file mode 100644 index 000000000..2a8a89493 --- /dev/null +++ b/src/main/metric_et_utils.f90 @@ -0,0 +1,150 @@ +module metric_et_utils + implicit none + + real, allocatable :: gcovgrid(:,:,:,:,:) + real, allocatable :: gcongrid(:,:,:,:,:) + real, allocatable :: sqrtggrid(:,:,:) + real, allocatable :: metricderivsgrid(:,:,:,:,:,:) + real :: dxgrid(3), gridorigin(3) + integer :: gridsize(3) + logical :: gridinit = .false. + + ! Declaration of grid limits and dimensions + integer, public :: nx,ny,nz + real, parameter :: xmin = -10.0, xmax = 10.0 + real, parameter :: ymin = -10.0, ymax = 10.0 + real, parameter :: zmin = -10.0, zmax = 10.0 + real, parameter :: mass = 1.0 ! Mass of the central object + + contains + + subroutine allocate_grid(nxin,nyin,nzin,dx,dy,dz,originx,originy,originz) + integer, intent(in) :: nxin,nyin,nzin + real, intent(in) :: dx,dy,dz,originx,originy,originz + + nx = nxin + ny = nyin + nz = nzin + gridsize(1) = nx + gridsize(2) = ny + gridsize(3) = nz + + dxgrid(1) = dx + dxgrid(2) = dy + dxgrid(3) = dz + + gridorigin(1) = originx + gridorigin(2) = originy + gridorigin(3) = originz + + allocate(gcovgrid(0:3,0:3,nx,ny,nz)) + allocate(gcongrid(0:3,0:3,nx,ny,nz)) + allocate(sqrtggrid(nx,ny,nz)) + + !metric derivs are stored in the form + ! mu comp, nu comp, deriv, gridx,gridy,gridz + ! Note that this is only the spatial derivs of + ! the metric and we will need an additional array + ! for time derivs + allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) + + end subroutine allocate_grid + + subroutine initialize_grid() + ! Local variable declarations + real :: dx, dy, dz, x0(3) + + nx = 100 + ny = 100 + nz = 100 + + ! Calculate the step size in each direction + dx = (xmax - xmin) / (nx - 1) + dy = (ymax - ymin) / (ny - 1) + dz = (zmax - zmin) / (nz - 1) + + x0 = [0.,0.,0.] + call allocate_grid(nx,ny,nz,dx,dy,dz,x0(1),x0(2),x0(3)) + + gridinit = .true. + + end subroutine initialize_grid + + subroutine print_metric_grid() + ! Subroutine for printing quantities of the ET grid + + print*, "Grid spacing (x,y,z) is : ", dxgrid + print*, "Grid origin (x,y,z) is: ", gridorigin + print*, "Covariant metric tensor of the grid is: ", gcovgrid(:,:,1,1,1) + + end subroutine print_metric_grid + + subroutine write_tabulated_metric(metric_file, ierr) + character(len=*), intent(in) :: metric_file + integer, intent(out) :: ierr + integer :: iunit + + ! Open the file for writing + open(newunit=iunit, file=metric_file, status='replace', form='unformatted',action='write', iostat=ierr) + if (ierr /= 0) then + ierr = 1 + return + endif + + ! Write the dimensions of the grid + write(iunit) gridsize + + ! Write the grid origin and spacing + write(iunit) gridorigin + write(iunit) dxgrid + + ! Write the metric values to the file + write(iunit) gcovgrid + write(iunit) gcongrid + write(iunit) sqrtggrid + write(iunit) metricderivsgrid + + ! Close the file + close(iunit) + ierr = 0 + end subroutine write_tabulated_metric + + subroutine read_tabulated_metric(metric_file, ierr) + character(len=*), intent(in) :: metric_file + integer, intent(out) :: ierr + integer :: iunit + + + ! Open the file for reading + open(newunit=iunit, file=metric_file, status='old', form='unformatted', action='read', iostat=ierr) + if (ierr /= 0) return + + ! Read the dimensions of the grid + read(iunit) gridsize + + ! Read the grid origin and spacing + read(iunit) gridorigin + read(iunit) dxgrid + + nx = gridsize(1) + ny = gridsize(2) + nz = gridsize(3) + + call allocate_grid(nx,ny,nz,& + dxgrid(1),dxgrid(2),dxgrid(3),& + gridorigin(1),gridorigin(2),gridorigin(3)) + + ! Read the metric values from the file + read(iunit) gcovgrid + read(iunit) gcongrid + read(iunit) sqrtggrid + read(iunit) metricderivsgrid + + gridinit = .true. + + ! Close the file + close(iunit) + ierr = 0 + end subroutine read_tabulated_metric + +end module metric_et_utils diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index 6ec6668ef..c3fe29ae7 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -16,22 +16,18 @@ module einsteintk_utils ! ! :Dependencies: part ! + use metric_et_utils, only:gridorigin,dxgrid,gridsize implicit none - real, allocatable :: gcovgrid(:,:,:,:,:) - real, allocatable :: gcongrid(:,:,:,:,:) - real, allocatable :: sqrtggrid(:,:,:) real, allocatable :: tmunugrid(:,:,:,:,:) real, allocatable :: rhostargrid(:,:,:) real, allocatable :: pxgrid(:,:,:,:) real, allocatable :: entropygrid(:,:,:) - real, allocatable :: metricderivsgrid(:,:,:,:,:,:) - real :: dxgrid(3), gridorigin(3), boundsize(3) - integer :: gridsize(3) - logical :: gridinit = .false. + real :: boundsize(3) logical :: exact_rendering character(len=128) :: logfilestor,evfilestor,dumpfilestor,infilestor contains subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) + use metric_et_utils, only:allocate_grid,gridsize,dxgrid,gridorigin integer, intent(in) :: nx,ny,nz real, intent(in) :: dx,dy,dz,originx,originy,originz @@ -47,40 +43,24 @@ subroutine init_etgrid(nx,ny,nz,dx,dy,dz,originx,originy,originz) gridorigin(2) = originy gridorigin(3) = originz - - allocate(gcovgrid(0:3,0:3,nx,ny,nz)) - allocate(gcongrid(0:3,0:3,nx,ny,nz)) - allocate(sqrtggrid(nx,ny,nz)) + call allocate_grid(nx,ny,nz,dx,dy,dz,originx,originy,originz) ! Will need to delete this at somepoint ! For now it is the simplest way allocate(tmunugrid(0:3,0:3,nx,ny,nz)) - allocate(pxgrid(3,nx,ny,nz)) - allocate(rhostargrid(nx,ny,nz)) - allocate(entropygrid(nx,ny,nz)) - ! metric derivs are stored in the form - ! mu comp, nu comp, deriv, gridx,gridy,gridz - ! Note that this is only the spatial derivs of - ! the metric and we will need an additional array - ! for time derivs - allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) - - gridinit = .true. !exact_rendering = exact end subroutine init_etgrid subroutine print_etgrid() - ! Subroutine for printing quantities of the ET grid - - print*, "Grid spacing (x,y,z) is : ", dxgrid - print*, "Grid origin (x,y,z) is: ", gridorigin - print*, "Covariant metric tensor of the grid is: ", gcovgrid(:,:,1,1,1) - + use metric_et_utils, only:print_metric_grid + + call print_metric_grid() + end subroutine print_etgrid subroutine get_particle_rhs(i,vx,vy,vz,fx,fy,fz,e_rhs) diff --git a/src/utils/tabulate_metric.f90 b/src/utils/tabulate_metric.f90 new file mode 100644 index 000000000..1e8232a6c --- /dev/null +++ b/src/utils/tabulate_metric.f90 @@ -0,0 +1,67 @@ +program tabulate_metric + use metric_et_utils + !use metric + + implicit none + + integer :: ierr + character(len=64) :: metric_file = 'tabuled_metric.dat' + + + ! Init grid and tabulated metric + call initialize_grid() + + ! Fill and interpolate metric in the grid + call fill_grid() + + ! Write Data in file + call write_tabulated_metric(metric_file, ierr) + + if (ierr /= 0) then + print *, 'Error writing metric data to file' + else + print *, 'Metric data successfully written to file' + endif + +contains + +subroutine fill_grid() + use metric + integer :: i, j, k + real :: dx, dy, dz + real :: position(3) + real :: gcov(0:3,0:3) + real :: gcon(0:3,0:3) + real :: sqrtg + real :: dgcovdx(0:3,0:3) + real :: dgcovdy(0:3,0:3) + real :: dgcovdz(0:3,0:3) + ! Triple loop to fill the grid + dx = (xmax - xmin) / (nx - 1) + dy = (ymax - ymin) / (ny - 1) + dz = (zmax - zmin) / (nz - 1) + + do i = 1, nx + do j = 1, ny + do k = 1, nz + ! Calculate the current position in the grid + position(1) = xmin + (i - 1) * dx + position(2) = ymin + (j - 1) * dy + position(3) = zmin + (k - 1) * dz + ! Store the calculated values in the grid arrays + call get_metric_cartesian(position,gcov,gcon,sqrtg) + !call get_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) + call metric_cartesian_derivatives(position,dgcovdx, dgcovdy, dgcovdz) + gcovgrid(:,:,i,j,k) = gcov + gcongrid(:,:,i,j,k) = gcon + sqrtggrid(i,j,k) = sqrtg + metricderivsgrid(:,:,1,i,j,k) = dgcovdx + metricderivsgrid(:,:,2,i,j,k) = dgcovdy + metricderivsgrid(:,:,3,i,j,k) = dgcovdz + end do + end do + end do +end subroutine fill_grid + +end program tabulate_metric + From 0ded9ac19f195379701a2e6575974dd72892cf05 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Sat, 13 Jul 2024 10:27:33 +1000 Subject: [PATCH 709/814] (ptmass) bug fix in sink potential test --- src/tests/test_ptmass.f90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 969132c99..c68a9adc1 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -1144,6 +1144,7 @@ subroutine test_sink_potential(ntests,npass) rp = 2. isink_potential = 1 ! place a single point mass at a random location + xyzmh_ptmass(:,:) = 0. xyzmh_ptmass(1:3,1) = x0 xyzmh_ptmass(4,1) = 3.14159 xyzmh_ptmass(ihacc,1) = 0. @@ -1155,9 +1156,11 @@ subroutine test_sink_potential(ntests,npass) xi = x0(1) + 1.00001*rp yi = x0(2) + 1.*rp zi = x0(3) + 1.*rp + fxi = 0.; fyi = 0.; fzi = 0.; phi = 0. call get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi) ! evaluate sink-gas acceleration at some position + epsilon eps = 1.e-6 + dumxi = 0.; dumyi = 0.; dumzi = 0.; phi1 = 0. call get_accel_sink_gas(nptmass,xi+eps,yi,zi,hi,xyzmh_ptmass,dumxi,dumyi,dumzi,phi1) ! get the derivative of phi and check it equals the acceleration dphidx = -(phi1 - phi)/eps From 18619707bd40bb8353cedb973b63b5ca83efc00a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 22 Jul 2024 15:08:22 +0200 Subject: [PATCH 710/814] (HIIRegion) add a fixed parameter to control the update rate of the HII region feedback --- src/main/H2regions.f90 | 3 ++- src/main/evolve.F90 | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index c97f48179..5c7e10163 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -20,6 +20,7 @@ module HIIRegion public :: update_ionrates,update_ionrate, HII_feedback,initialize_H2R,read_options_H2R,write_options_H2R + integer, parameter, public :: HIIuprate = 8 ! update rate when IND_TIMESTEPS=yes integer, public :: iH2R = 0 real , public :: Rmax = 15 ! Maximum HII region radius (pc) to avoid artificial expansion... real , public :: Mmin = 8 ! Minimum mass (Msun) to produce HII region @@ -224,7 +225,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) do while(hcheck <= Rmax) call getneigh_pos((/xi,yi,zi/),0.,hcheck,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) call set_r2func_origin(xi,yi,zi) - call Knnfunc(nneigh,r2func_origin,xyzh,listneigh) + call Knnfunc(nneigh,r2func_origin,xyzh,listneigh) !! Here still serial version of the quicksort. Parallel version in prep.. if (nneigh > 0) exit hcheck = hcheck + 0.01*Rmax ! additive term to allow unresolved case to open enddo diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 7b5be2313..2a8379a7b 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -99,7 +99,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries - use HIIRegion, only:HII_feedback,iH2R + use HIIRegion, only:HII_feedback,iH2R,HIIuprate use subgroup, only:group_identify use substepping, only:get_force #ifdef MFLOW @@ -307,10 +307,10 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (iH2R > 0 .and. id==master) then istepHII = 1 #ifdef IND_TIMESTEPS - istepHII = 2**nbinmax/8 + istepHII = 2**nbinmax/HIIuprate if (istepHII==0) istepHII = 1 #endif - if(mod(istepfrac,istepHII)==0 .or. istepfrac==1 .or. ipart_createstars /= 0) then + if(mod(istepfrac,istepHII)==0 .or. istepfrac==1 .or. (icreate_sinks == 2 .and. ipart_createstars /= 0)) then call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) endif endif From a46f6aa340630f6a206f926e7dc1761ed6faf09d Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 22 Jul 2024 17:31:47 +0200 Subject: [PATCH 711/814] [header-bot] updated file headers --- src/main/porosity.f90 | 8 ++++---- src/setup/set_orbit.f90 | 30 ++++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 4 deletions(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 7b5071b17..bdbf14f1c 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -15,7 +15,7 @@ module porosity ! Tatsuuma et Kataoka (2021), ApJ 913, 132 ! Michoulier & Gonzalez (2022), MNRAS 517, 3064 ! -! :Owner: Stephane Michoulier +! :Owner: Daniel Price ! ! :Runtime parameters: ! - gammaft : *Force to torque efficient of gas flow on dust* @@ -789,18 +789,18 @@ end function get_coeffrest real function compute_vstick(mass,size) real, intent(in) ::mass,size compute_vstick = 8.76*((surfenerg**5 * size**4)/(mass**3*youngmod**2))**(1./6.) -end function +end function compute_vstick !--velocity limit between elastic and inelastic bouncing regime real function compute_vyield(vstick) real, intent(in) ::vstick compute_vyield = 10.*vstick -end function +end function compute_vyield !--velocity limit between partial sticking + bouncing regime and full bouncing regime real function compute_vend(vstick) real, intent(in) ::vstick compute_vend = 24343220.*vstick -end function +end function compute_vend end module porosity diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index 23a25885d..816a8afec 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -44,6 +44,36 @@ module setorbit ! :Dependencies: infile_utils, physcon, setbinary, setflyby, units ! +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils, physcon, setbinary, setflyby, units +! + +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils, physcon, setbinary, setflyby, units +! + ! While Campbell elements can be used for unbound orbits, they require ! specifying the true anomaly at the start of the simulation. This is ! not always easy to determine, so the flyby option is provided as an From efd5bf2f3fe0d3a694836b82d514bfb634963642 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 22 Jul 2024 17:33:34 +0200 Subject: [PATCH 712/814] [tab-bot] tabs removed --- AUTHORS | 40 +++++++++++++++------------- src/main/H2regions.f90 | 30 ++++++++++++++------- src/main/checksetup.f90 | 12 ++++----- src/main/eos.f90 | 2 +- src/main/eos_HIIR.f90 | 26 +++++++++--------- src/main/evolve.F90 | 16 +++++------ src/main/initial.F90 | 2 +- src/main/inject_BHL.f90 | 2 +- src/main/inject_asteroidwind.f90 | 2 +- src/main/inject_bondi.f90 | 2 +- src/main/inject_firehose.f90 | 2 +- src/main/inject_galcen_winds.f90 | 2 +- src/main/inject_keplerian.f90 | 2 +- src/main/inject_keplerianshear.f90 | 2 +- src/main/inject_rochelobe.f90 | 2 +- src/main/inject_sim.f90 | 4 +-- src/main/inject_sne.f90 | 2 +- src/main/inject_steadydisc.f90 | 2 +- src/main/inject_unifwind.f90 | 2 +- src/main/inject_wind.f90 | 2 +- src/main/inject_windtunnel.f90 | 2 +- src/main/ptmass.F90 | 25 +++++++++-------- src/main/random.f90 | 2 +- src/main/readwrite_dumps_common.f90 | 4 +-- src/main/readwrite_dumps_fortran.f90 | 2 +- src/main/readwrite_infile.F90 | 10 +++---- src/main/step_leapfrog.F90 | 6 ++--- src/main/subgroup.f90 | 7 ++--- src/main/utils_sort.f90 | 6 ++--- src/setup/setup_cluster.f90 | 7 ++--- src/setup/setup_grdisc.F90 | 7 +++-- src/tests/test_ptmass.f90 | 10 +++---- src/utils/moddump_radiotde.f90 | 2 +- src/utils/struct_part.f90 | 8 +++--- 34 files changed, 135 insertions(+), 119 deletions(-) diff --git a/AUTHORS b/AUTHORS index 9f44811cf..649e5eb20 100644 --- a/AUTHORS +++ b/AUTHORS @@ -13,12 +13,12 @@ David Liptai Lionel Siess Fangyi (Fitz) Hu Daniel Mentiplay +Yrisch Megha Sharma Arnaud Vericel Mark Hutchison Mats Esseldeurs Rebecca Nealon -Yrisch Elisabeth Borchert Ward Homan Christophe Pinte @@ -26,48 +26,50 @@ Terrence Tricco Stephane Michoulier Simone Ceppi Spencer Magnall -Enrico Ragusa Caitlyn Hardiman +Enrico Ragusa Cristiano Longarini Sergei Biriukov Giovanni Dipierro Roberto Iaconi -Hauke Worpel Amena Faruqi +Hauke Worpel Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi -Thomas Reichardt Sahl Rowther Simon Glover +Thomas Reichardt Jean-François Gonzalez Christopher Russell -Phantom benchmark bot -Jolien Malfait -Alex Pettitt Alessia Franchini +Alex Pettitt +Jolien Malfait +Phantom benchmark bot Kieran Hirsh -Nicole Rodrigues Mike Lau -Nicolás Cuello -Farzana Meru +Nicole Rodrigues David Trevascus +Farzana Meru +Nicolás Cuello Chris Nixon Miguel Gonzalez-Bolivar -Maxime Lombart -Joe Fisher +Benoit Commercon Giulia Ballabio +Joe Fisher +Maxime Lombart +Orsola De Marco Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> -Benoit Commercon -Orsola De Marco -MICHOULIER Stephane -Stéven Toupin -Taj Jankovič +Ariel Chitan +Chunliang Mu Cox, Samuel -Jeremy Smallwood Hugh Griffiths -Chunliang Mu +Jeremy Smallwood Jorge Cuadra +MICHOULIER Stephane Steven Rieder +Stéven Toupin +Taj Jankovič +rebeccagmartin <74937128+rebeccagmartin@users.noreply.github.com> diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 5c7e10163..ac89e60e2 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -1,13 +1,23 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2021 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2024 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! -! http://phantomsph.bitbucket.io/ ! -! Module proposed By Yann BERNARD to implement stellar feedbacks in cluster! -! simulations ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! - module HIIRegion +! +! HIIRegion +! +! :References: None +! +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: dim, eos, infile_utils, io, linklist, part, physcon, +! sortutils, timing, units +! + ! ! ! contains routine for Stromgren radius calculation and Radiative pressure velocity kick @@ -108,7 +118,7 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) do i=1,nptmass mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) - if(mi > Minmass .and. hi < h_acc)then + if (mi > Minmass .and. hi < h_acc) then logmi = log10(mi*(umass/solarm)) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases @@ -143,7 +153,7 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) real :: logmi,log_Q,mi,hi,Q mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) - if(mi > Minmass .and. hi < h_acc)then + if (mi > Minmass .and. hi < h_acc) then logmi = log10(mi*(umass/solarm)) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases @@ -217,7 +227,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) stromi = xyzmh_ptmass(irstrom,i) - if(stromi >= 0. ) then + if (stromi >= 0. ) then hcheck = 1.4*stromi + 0.01*Rmax else hcheck = Rmax @@ -258,7 +268,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) ! !-- Momentum feedback ! - if(momflag .and. npartin > 3) then + if (momflag .and. npartin > 3) then j = listneigh(1) r_in = sqrt((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) mHII = ((4.*pi*(r**3-r_in**3)*rhoh(xyzh(4,j),pmass))/3) @@ -300,7 +310,7 @@ subroutine write_options_H2R(iunit) use physcon, only:solarm integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling HII region expansion feedback' - if(iH2R>0) then + if (iH2R>0) then call write_inopt(iH2R, 'iH2R', "enable the HII region expansion feedback in star forming reigon", iunit) call write_inopt(Mmin, 'Mmin', "Minimum star mass to trigger HII region (MSun)", iunit) call write_inopt(Rmax, 'Rmax', "Maximum radius for HII region (pc)", iunit) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 5a815ad6c..61827b35b 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -14,9 +14,9 @@ module checksetup ! ! :Runtime parameters: None ! -! :Dependencies: boundary, boundary_dyn, centreofmass, dim, dust, eos, -! externalforces, io, metric_tools, nicil, options, part, physcon, -! ptmass, ptmass_radiation, sortutils, timestep, units, utils_gr +! :Dependencies: HIIRegion, boundary, boundary_dyn, centreofmass, dim, +! dust, eos, externalforces, io, metric_tools, nicil, options, part, +! physcon, ptmass, ptmass_radiation, sortutils, timestep, units, utils_gr ! implicit none public :: check_setup @@ -1055,15 +1055,15 @@ subroutine check_HIIRegion(nerror) use eos, only:ieos use dim, only:gr,mpi integer, intent(inout) :: nerror - if(iH2R > 0 .and. ieos/=21 .and. ieos/=22) then + if (iH2R > 0 .and. ieos/=21 .and. ieos/=22) then print "(/,a,/)", "Error: If HII activated, eos == 21 or 22 is mandatory..." nerror = nerror + 1 endif - if(iH2R > 0 .and. gr) then + if (iH2R > 0 .and. gr) then print "(/,a,/)", "Error: Gr is not compatible with HII Region" nerror = nerror + 1 endif - if(iH2R > 0 .and. mpi) then + if (iH2R > 0 .and. mpi) then print "(/,a,/)", "Error: MPI is not compatible with HII Region" nerror = nerror + 1 endif diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 6d3094f1b..10528d8ca 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -41,7 +41,7 @@ module eos ! - metallicity : *metallicity* ! - mu : *mean molecular weight* ! -! :Dependencies: dim, dump_utils, eos_barotropic, eos_gasradrec, +! :Dependencies: dim, dump_utils, eos_HIIR, eos_barotropic, eos_gasradrec, ! eos_helmholtz, eos_idealplusrad, eos_mesa, eos_piecewise, eos_shen, ! eos_stratified, infile_utils, io, mesa_microphysics, part, physcon, ! units diff --git a/src/main/eos_HIIR.f90 b/src/main/eos_HIIR.f90 index 6735f28a1..315d97734 100644 --- a/src/main/eos_HIIR.f90 +++ b/src/main/eos_HIIR.f90 @@ -5,17 +5,17 @@ ! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module eos_HIIR - ! - ! Implements Two temperature eos for HII region expansion - ! - ! :References: None - ! - ! :Owner: Yann Bernard - ! - ! :Runtime parameters: None - ! - ! :Dependencies: None - ! +! +! eos_HIIR +! +! :References: None +! +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: io, physcon, units +! implicit none public :: get_eos_HIIR_iso,get_eos_HIIR_adiab,init_eos_HIIR @@ -63,7 +63,7 @@ subroutine get_eos_HIIR_iso(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,is ! ! where :math:`c_s^2 \equiv K` is a constant stored in the dump file header ! - if(isionisedi) then + if (isionisedi) then ponrhoi = polykion spsoundi = sqrt(ponrhoi) tempi = Tion @@ -93,7 +93,7 @@ subroutine get_eos_HIIR_adiab(polyk,temperature_coef,mui,tempi,ponrhoi,rhoi,eni, if (gammai < tiny(gammai)) call fatal('eos','gamma not set for adiabatic eos',var='gamma',val=gammai) - if(isionisedi) then + if (isionisedi) then ponrhoi = polykion spsoundi = sqrt(ponrhoi) tempi = Tion diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 2a8379a7b..20cede37b 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -16,12 +16,12 @@ module evolve ! ! :Runtime parameters: None ! -! :Dependencies: analysis, 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, readwrite_infile, -! step_lf_global, supertimestep, timestep, timestep_ind, timestep_sts, -! timing +! :Dependencies: HIIRegion, analysis, 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, +! readwrite_infile, step_lf_global, subgroup, substepping, supertimestep, +! timestep, timestep_ind, timestep_sts, timing ! implicit none public :: evol @@ -298,7 +298,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! ! creation of new stars from sinks (cores) ! - if(ipart_createstars /= 0) then + if (ipart_createstars /= 0) then call ptmass_create_stars(nptmass,ipart_createstars,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink, & linklist_ptmass,time) endif @@ -310,7 +310,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) istepHII = 2**nbinmax/HIIuprate if (istepHII==0) istepHII = 1 #endif - if(mod(istepfrac,istepHII)==0 .or. istepfrac==1 .or. (icreate_sinks == 2 .and. ipart_createstars /= 0)) then + if (mod(istepfrac,istepHII)==0 .or. istepfrac==1 .or. (icreate_sinks == 2 .and. ipart_createstars /= 0)) then call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) endif endif diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 79d8379d6..7b8f26032 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -14,7 +14,7 @@ module initial ! ! :Runtime parameters: None ! -! :Dependencies: analysis, boundary, boundary_dyn, centreofmass, +! :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, diff --git a/src/main/inject_BHL.f90 b/src/main/inject_BHL.f90 index a23162cc0..ae41283de 100644 --- a/src/main/inject_BHL.f90 +++ b/src/main/inject_BHL.f90 @@ -264,7 +264,7 @@ end subroutine inject_or_update_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_asteroidwind.f90 b/src/main/inject_asteroidwind.f90 index 37072a760..5e61737fe 100644 --- a/src/main/inject_asteroidwind.f90 +++ b/src/main/inject_asteroidwind.f90 @@ -152,7 +152,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_bondi.f90 b/src/main/inject_bondi.f90 index 9af9af121..1c2fc22bc 100644 --- a/src/main/inject_bondi.f90 +++ b/src/main/inject_bondi.f90 @@ -220,7 +220,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_firehose.f90 b/src/main/inject_firehose.f90 index 7db1c2759..cf1e5bfb0 100644 --- a/src/main/inject_firehose.f90 +++ b/src/main/inject_firehose.f90 @@ -213,7 +213,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_galcen_winds.f90 b/src/main/inject_galcen_winds.f90 index 5422ba9ff..d52baaf8a 100644 --- a/src/main/inject_galcen_winds.f90 +++ b/src/main/inject_galcen_winds.f90 @@ -226,7 +226,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_keplerian.f90 b/src/main/inject_keplerian.f90 index 7e4f8e221..45376c6ba 100644 --- a/src/main/inject_keplerian.f90 +++ b/src/main/inject_keplerian.f90 @@ -201,7 +201,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_keplerianshear.f90 b/src/main/inject_keplerianshear.f90 index cea2359ae..773fc7d72 100644 --- a/src/main/inject_keplerianshear.f90 +++ b/src/main/inject_keplerianshear.f90 @@ -189,7 +189,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_rochelobe.f90 b/src/main/inject_rochelobe.f90 index 054a264b1..96cd13aca 100644 --- a/src/main/inject_rochelobe.f90 +++ b/src/main/inject_rochelobe.f90 @@ -281,7 +281,7 @@ end subroutine phi_derivs subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index a305b8dc8..127d1805d 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -276,7 +276,7 @@ subroutine read_injected_par() injected = .false. endif -end subroutine +end subroutine read_injected_par subroutine update_injected_par() use io, only:error @@ -298,7 +298,7 @@ subroutine update_injected_par() enddo close(iunit) endif -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_sne.f90 b/src/main/inject_sne.f90 index 2152ef1eb..867ad2b88 100644 --- a/src/main/inject_sne.f90 +++ b/src/main/inject_sne.f90 @@ -138,7 +138,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_steadydisc.f90 b/src/main/inject_steadydisc.f90 index eb6d6c128..d7071af77 100644 --- a/src/main/inject_steadydisc.f90 +++ b/src/main/inject_steadydisc.f90 @@ -206,7 +206,7 @@ end subroutine inject_particles_in_annulus subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_unifwind.f90 b/src/main/inject_unifwind.f90 index d2205b97b..80f203a63 100644 --- a/src/main/inject_unifwind.f90 +++ b/src/main/inject_unifwind.f90 @@ -128,7 +128,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index 43de42245..ed7597fcf 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.f90 @@ -505,7 +505,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 79ee0aac0..62cdf2f33 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -258,7 +258,7 @@ end subroutine inject_or_update_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index b571cffdc..e4dd1b468 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -28,15 +28,18 @@ module ptmass ! - h_soft_sinkgas : *softening length for new sink particles* ! - h_soft_sinksink : *softening length between sink particles* ! - icreate_sinks : *allow automatic sink particle creation* +! - isink_potential : *sink potential(0=1/r,1=surf)* ! - r_crit : *critical radius for point mass creation (no new sinks < r_crit from existing sink)* ! - r_merge_cond : *sinks will merge if bound within this radius* ! - r_merge_uncond : *sinks will unconditionally merge within this separation* +! - r_neigh : *searching radius to detect subgroups* ! - rho_crit_cgs : *density above which sink particles are created (g/cm^3)* +! - use_regnbody : *allow subgroup integration method* ! -! :Dependencies: boundary, dim, eos, eos_barotropic, eos_piecewise, -! extern_geopot, externalforces, fastmath, infile_utils, io, io_summary, -! kdtree, kernel, linklist, mpidomain, mpiutils, options, part, -! ptmass_heating, units, vectorutils +! :Dependencies: HIIRegion, boundary, dim, eos, eos_barotropic, +! eos_piecewise, extern_geopot, externalforces, fastmath, infile_utils, +! io, io_summary, kdtree, kernel, linklist, mpidomain, mpiutils, options, +! part, physcon, ptmass_heating, random, subgroup, units, vectorutils ! use part, only:nsinkproperties,gravity,is_accretable,& ihsoft,ihacc,ispinx,ispiny,ispinz,imacc,iJ2,iReff @@ -675,7 +678,7 @@ subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_pt vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dkdt*fxyz_ptmass(1,i) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dkdt*fxyz_ptmass(2,i) vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dkdt*fxyz_ptmass(3,i) - if(xyzmh_ptmass(iJ2,i) > 0.) then + if (xyzmh_ptmass(iJ2,i) > 0.) then xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) @@ -835,11 +838,11 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & mpt = xyzmh_ptmass(4,i) tbirthi = xyzmh_ptmass(itbirth,i) if (mpt < 0.) cycle - if(icreate_sinks==2) then + if (icreate_sinks==2) then if (hacc < h_acc ) cycle if (tbirthi + tmax_acc < time) then !$omp master - if(ipart_createstars == 0) ipart_createstars = i + if (ipart_createstars == 0) ipart_createstars = i !$omp end master cycle endif @@ -1650,7 +1653,7 @@ subroutine ptmass_create_seeds(nptmass,itest,xyzmh_ptmass,linklist_ptmass,time) !-- Draw the number of star seeds in the core ! nseed = floor(4*ran2(iseed_sf)) - if(nseed > 0) then + if (nseed > 0) then n = nptmass linklist_ptmass(itest) = n + 1 !! link the core to the seeds do j=1,nseed @@ -1709,7 +1712,7 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas minmass = 0.08/(mi*(umass/solarm)) call divide_unit_seg(masses,minmass,n,iseed_sf) masses = masses*mi - if(iverbose > 1) write(iprint,*) "Mass sharing : ", masses*umass/solarm + if (iverbose > 1) write(iprint,*) "Mass sharing : ", masses*umass/solarm k=itest @@ -1899,7 +1902,7 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklis if (icreate_sinks == 2) then ! Connect linked list of the merged sink to the survivor call ptmass_endsize_lklist(k,l,n,linklist_ptmass) - if(linklist_ptmass(j)/=0)then + if (linklist_ptmass(j)/=0) then linklist_ptmass(l) = j else linklist_ptmass(j) = -2 ! special null pointer for dead gas clump @@ -2218,7 +2221,7 @@ subroutine write_options_ptmass(iunit) call write_inopt(f_acc,'f_acc','particles < f_acc*h_acc accreted without checks',iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) - if(use_regnbody) then + if (use_regnbody) then call write_inopt(use_regnbody, 'use_regnbody', 'allow subgroup integration method', iunit) call write_inopt(r_neigh, 'r_neigh', 'searching radius to detect subgroups', iunit) endif diff --git a/src/main/random.f90 b/src/main/random.f90 index 63cd5e976..b5fc3bd88 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -15,7 +15,7 @@ module random ! ! :Runtime parameters: None ! -! :Dependencies: None +! :Dependencies: sortutils ! implicit none public :: ran2,get_random,rayleigh_deviate diff --git a/src/main/readwrite_dumps_common.f90 b/src/main/readwrite_dumps_common.f90 index b9d8990ac..c6993d678 100644 --- a/src/main/readwrite_dumps_common.f90 +++ b/src/main/readwrite_dumps_common.f90 @@ -16,7 +16,7 @@ module readwrite_dumps_common ! ! :Dependencies: boundary, boundary_dyn, checkconserved, dim, dump_utils, ! dust, dust_formation, eos, externalforces, fileutils, gitinfo, io, -! options, part, setup_params, sphNGutils, timestep, units +! options, part, ptmass, setup_params, sphNGutils, timestep, units ! use dump_utils, only:lenid implicit none @@ -768,7 +768,7 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert if (.not.all(got_sink_vels(1:3))) then if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING! sink particle velocities not found' endif - if( icreate_sinks > 1 .and. .not.got_sink_llist) then + if ( icreate_sinks > 1 .and. .not.got_sink_llist) then if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING! sink particle link list not found' endif if (id==master .and. i1==1) then diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 56c7bf61e..ad656dd50 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -19,7 +19,7 @@ module readwrite_dumps_fortran ! :Runtime parameters: None ! ! :Dependencies: boundary_dyn, dim, dump_utils, eos, io, memory, -! metric_tools, mpiutils, options, part, readwrite_dumps_common, +! metric_tools, mpiutils, options, part, ptmass, readwrite_dumps_common, ! sphNGutils, timestep ! use dump_utils, only:lenid,ndatatypes,i_int,i_int1,i_int2,i_int4,i_int8,& diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 2817e7bd7..450b42f88 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -65,11 +65,11 @@ module readwrite_infile ! - use_mcfost : *use the mcfost library* ! - xtol : *tolerance on xyz iterations* ! -! :Dependencies: 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, radiation_utils, -! timestep, viscosity +! :Dependencies: HIIRegion, 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, +! radiation_utils, timestep, viscosity ! use timestep, only:dtmax_dratio,dtmax_max,dtmax_min use options, only:nfulldump,nmaxdumps,twallmax,iexternalforce,tolh, & diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index f8dca1e91..a017c9dea 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -23,9 +23,9 @@ module step_lf_global ! :Runtime parameters: None ! ! :Dependencies: boundary_dyn, cons2prim, cons2primsolver, cooling, -! damping, deriv, dim, eos, extern_gr, growth, io, io_summary, -! metric_tools, mpiutils, options, part, porosity, substepping, timestep, -! timestep_ind, timestep_sts, timing +! damping, deriv, dim, extern_gr, growth, io, io_summary, metric_tools, +! mpiutils, options, part, porosity, substepping, timestep, timestep_ind, +! timestep_sts, timing ! use dim, only:maxp,maxvxyzu,do_radiation,ind_timesteps use part, only:vpred,Bpred,dustpred,ppred diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index b46786532..1e6e52e28 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -15,7 +15,8 @@ module subgroup ! ! :Runtime parameters: None ! -! :Dependencies: io, mpiutils, part, utils_kepler, utils_subgroup +! :Dependencies: io, mpiutils, part, physcon, timing, units, utils_kepler, +! utils_subgroup ! use utils_subgroup implicit none @@ -74,7 +75,7 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm call get_timings(t1,tcpu1) - if(large_search) then + if (large_search) then call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) else call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) @@ -195,7 +196,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) vxi = vxyz_ptmass(1,i) vyi = vxyz_ptmass(2,i) vzi = vxyz_ptmass(3,i) - if(mi < 0 ) cycle + if (mi < 0 ) cycle do j=1,nptmass if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index d20d793b2..2d15666d7 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -14,7 +14,7 @@ module sortutils ! ! :Runtime parameters: None ! -! :Dependencies: None +! :Dependencies: omp_lib ! implicit none public :: indexx,indexxfunc,Knnfunc,parqsort,find_rank,r2func,r2func_origin,set_r2func_origin @@ -515,7 +515,7 @@ subroutine parqsort(n, arr,func, indx) do while (func(arr(indx(j))) > a) j = j - 1 enddo - if(j>i) then + if (j>i) then itemp = indx(i) indx(i) = indx(j) indx(j) = itemp @@ -582,7 +582,7 @@ subroutine parqsort(n, arr,func, indx) do while (func(arr(indx(j))) > a) j = j - 1 enddo - if(j>i) then + if (j>i) then itemp = indx(i) indx(i) = indx(j) indx(j) = itemp diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 1ff9c99da..8e10a2937 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -23,9 +23,10 @@ module setup ! - mu : *mean molecular mass* ! - n_particles : *number of particles in sphere* ! -! :Dependencies: centreofmass, datafiles, dim, eos, infile_utils, io, -! kernel, mpidomain, part, physcon, prompting, ptmass, setup_params, -! setvfield, spherical, timestep, units, velfield +! :Dependencies: HIIRegion, centreofmass, cooling, datafiles, dim, eos, +! infile_utils, io, kernel, mpidomain, options, part, physcon, prompting, +! ptmass, setup_params, setvfield, spherical, subgroup, timestep, units, +! utils_shuffleparticles, velfield ! use dim, only: maxvxyzu,mhd implicit none diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index ed22b212c..2ae3e5427 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -29,10 +29,9 @@ module setup ! - spin : *spin parameter of black hole |a|<1* ! - theta : *inclination of disc (degrees)* ! -! :Dependencies: dim, eos, extern_lensethirring, externalforces, -! infile_utils, io, kernel, metric, mpidomain, options, part, physcon, -! prompting, setdisc, setorbit, setstar, setunits, setup_params, -! timestep, units +! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, +! io, kernel, metric, mpidomain, options, part, physcon, prompting, +! setdisc, setorbit, setstar, setunits, setup_params, timestep, units ! use options, only:alpha use setstar, only:star_t diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 2d5810fa9..fbc61fffe 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -14,11 +14,11 @@ module testptmass ! ! :Runtime parameters: None ! -! :Dependencies: boundary, checksetup, deriv, dim, energies, eos, -! 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, 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 ! use testutils, only:checkval,update_test_scores implicit none diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 28af40a44..e984c3792 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -409,7 +409,7 @@ subroutine calc_rho0(rhof) enddo write(*,'(a11,1x,es10.2,1x,a12,1x,i3,1x,a10)') ' Get rho0 =', rhof_rho0*unit_density, 'g/cm^-3 with', iter, 'iterations' -end subroutine +end subroutine calc_rho0 !---------------------------------------------------------------- !+ diff --git a/src/utils/struct_part.f90 b/src/utils/struct_part.f90 index 781a3c2fd..99640148d 100644 --- a/src/utils/struct_part.f90 +++ b/src/utils/struct_part.f90 @@ -149,10 +149,10 @@ subroutine get_structure_fn(sf,nbins,norder,distmin,distmax,xbins,ncount,npart,x !$omp reduction(+:sf) do ipt=1,npts !$ if (.false.) then - if (mod(ipt,100)==0) then - call cpu_time(tcpu2) - print*,' ipt = ',ipt,tcpu2-tcpu1 - endif + if (mod(ipt,100)==0) then + call cpu_time(tcpu2) + print*,' ipt = ',ipt,tcpu2-tcpu1 + endif !$ endif i = list(ipt) xpt(1) = xyz(1,i) From d0b44c2e045308d35e10f04b34d4a4917406299a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 22 Jul 2024 17:34:25 +0200 Subject: [PATCH 713/814] [header-bot] updated file headers --- src/main/porosity.f90 | 2 +- src/setup/set_orbit.f90 | 15 +++++++++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index bdbf14f1c..a70b3801c 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -15,7 +15,7 @@ module porosity ! Tatsuuma et Kataoka (2021), ApJ 913, 132 ! Michoulier & Gonzalez (2022), MNRAS 517, 3064 ! -! :Owner: Daniel Price +! :Owner: Stephane Michoulier ! ! :Runtime parameters: ! - gammaft : *Force to torque efficient of gas flow on dust* diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index 816a8afec..8a1308afd 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -74,6 +74,21 @@ module setorbit ! :Dependencies: infile_utils, physcon, setbinary, setflyby, units ! +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils, physcon, setbinary, setflyby, units +! + ! While Campbell elements can be used for unbound orbits, they require ! specifying the true anomaly at the start of the simulation. This is ! not always easy to determine, so the flyby option is provided as an From 95a29e272ddbd39f01000e8ffbfd8c4826d30bd9 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 22 Jul 2024 23:26:25 +0200 Subject: [PATCH 714/814] (substepping) correct wrong previous merge --- src/main/substepping.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 19cdd352c..504e7b9d3 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -940,8 +940,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif - fxyz_ptmass_sinksink(:,1:nptmass+1) = fxyz_ptmass (:,1:nptmass+1) - dsdt_ptmass_sinksink(:,1:nptmass+1) = dsdt_ptmass (:,1:nptmass+1) + 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) @@ -951,13 +951,13 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif - fxyz_ptmass_sinksink(:,1:nptmass+1) = fxyz_ptmass (:,1:nptmass+1) - dsdt_ptmass_sinksink(:,1:nptmass+1) = dsdt_ptmass (:,1:nptmass+1) + fxyz_ptmass_sinksink(:,1:nptmass) = fxyz_ptmass (:,1:nptmass) + dsdt_ptmass_sinksink(:,1:nptmass) = dsdt_ptmass (:,1:nptmass) endif endif else - fxyz_ptmass(4,1:nptmass) = 0. - dsdt_ptmass(3,1:nptmass) = 0. + fxyz_ptmass(:,1:nptmass) = 0. + dsdt_ptmass(:,1:nptmass) = 0. endif call bcast_mpi(epot_sinksink) call bcast_mpi(dtf) From 74182970240dc7976b8de0f26a0427860db41b32 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 23 Jul 2024 09:56:24 +0200 Subject: [PATCH 715/814] (sortutils) condition on omp lib import --- src/main/utils_sort.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index 2d15666d7..88d7d1686 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -462,7 +462,7 @@ end subroutine Knnfunc !+ !---------------------------------------------------------------- subroutine parqsort(n, arr,func, indx) - use omp_lib,only:omp_get_num_threads +!$ use omp_lib,only:omp_get_num_threads implicit none integer, parameter :: m=8, nstack=500 integer, intent(in) :: n From 7a217881e7b519ac3bffa74788e00b157e63c134 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 23 Jul 2024 14:01:38 +0200 Subject: [PATCH 716/814] (Makefile) update dependencies for random module --- build/Makefile | 4 ++-- src/main/utils_sort.f90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/build/Makefile b/build/Makefile index c07eed6a1..bafa65db1 100644 --- a/build/Makefile +++ b/build/Makefile @@ -629,7 +629,7 @@ OBJDUMP= $(OBJDUMP1:.F90=.o) # must NOT contain .F90 files or pre-processing options # LIBSETUP=$(BINDIR)/libphantomsetup.a -SRCLIBSETUP=physcon.f90 geometry.f90 random.f90 utils_tables.f90 utils_vectors.f90 stretchmap.f90 \ +SRCLIBSETUP=physcon.f90 geometry.f90 utils_sort.f90 random.f90 utils_tables.f90 utils_vectors.f90 stretchmap.f90 \ utils_binary.f90 set_binary.f90 set_flyby.f90 \ set_hierarchical_utils.f90 \ set_unifdis.f90 set_sphere.f90 set_shock.f90 \ @@ -867,7 +867,7 @@ pyanalysis: libphantom.so # .PHONY: phantom2struct phantom2struct: - ${MAKE} phantomanalysis ANALYSIS="utils_timing.f90 io_structurefn.f90 random.f90 struct_part.f90 analysis_structurefn.f90"\ + ${MAKE} phantomanalysis ANALYSIS="utils_timing.f90 io_structurefn.f90 utils_sort.f90 random.f90 struct_part.f90 analysis_structurefn.f90"\ ANALYSISBIN=$@ ANALYSISONLY=yes cleanphantom2struct: diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index 88d7d1686..dba9c1ecf 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -14,7 +14,7 @@ module sortutils ! ! :Runtime parameters: None ! -! :Dependencies: omp_lib +! :Dependencies: None ! implicit none public :: indexx,indexxfunc,Knnfunc,parqsort,find_rank,r2func,r2func_origin,set_r2func_origin From a6499e0af1f9ac4f94e96e01405bd692f710e2a8 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 23 Jul 2024 14:35:15 +0100 Subject: [PATCH 717/814] Edits for radapprox cooling --- src/main/cooling_radapprox.f90 | 60 ++++++++++++++++++++-------------- src/main/evolve.F90 | 26 ++++++++++----- src/main/step_leapfrog.F90 | 24 ++++++++------ 3 files changed, 67 insertions(+), 43 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index d154b90b0..64742de0d 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -21,7 +21,7 @@ module cooling_radapprox implicit none real :: Lstar = 0d0 ! in units of L_sun - real,parameter :: dtcool_crit = 0.001 ! critical dt_rad/dt_hydro for not applying cooling + real,parameter :: dtcool_crit = 0.0001 ! critical dt_rad/dt_hydro for not applying cooling 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 @@ -63,37 +63,47 @@ end subroutine init_star ! Do cooling calculation ! ! update energy to return evolved energy array. Called from evolve.F90 -subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) +subroutine radcool_update_energ(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 + use part, only:iphase,maxphase,maxp,iamtype,ibin + use timestep_ind, only:get_dt integer,intent(in) :: npart - real,intent(in) :: xyzh(:,:),dt,Tfloor + real,intent(in) :: xyzh(:,:),dtsph,Tfloor real,intent(inout) :: energ(:),dudt_sph(:) - real :: ui,rhoi,coldensi,kappaBari,kappaParti,ri2 + real :: ui,rhoi,coldensi,kappaBari,kappaParti,ri2,dti real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot real :: cs2,Om2,Hmod2 real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi integer :: i,ratefile,n_uevo ! write (temp,'(E5.2)') dt - + 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,dt,dudt_sph,utime,udist,umass,unit_ergg,gradP_cool,Lstar) & + !$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) + !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb,dti) & + !$omp shared(maxp,maxphase,ibin) reduction(+:n_uevo) + overpart: do i=1,npart - if (.not. iactive(iphase(i)) .or. isdead_or_accreted(xyzh(4,i)) ) then - dudt_sph(i) = 0d0 - cycle + if (maxphase==maxp) then + if (iamtype(iphase(i)) /= igas) cycle + if (isdead_or_accreted(xyzh(4,i))) cycle + if (.not. iactive(iphase(i)) ) then +! dudt_sph(i) = 0d0 + 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) @@ -104,6 +114,8 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) 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 @@ -157,13 +169,13 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) ! 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/dudt_sph(i)) < dtcool_crit) then -! print *, "not cooling/heating for r=",sqrt(ri2),".", dudti_rad,& - ! dudt_sph(i) - energ(i) = ui + dudt_sph(i)*dt - dudt_sph(i) = 0d0 - cycle - endif +! if (abs(dudti_rad/dudt_sph(i)) < dtcool_crit) then + ! print *, "not cooling/heating for r=",sqrt(ri2),".", dudti_rad,& + ! dudt_sph(i) + ! energ(i) = ui + dudt_sph(i)*dti + ! dudt_sph(i) = 0d0 + ! cycle + !endif if (doFLD) then Teqi = (du_FLDi + dudt_sph(i)) *opaci*unit_ergg/utime ! physical units @@ -185,7 +197,7 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) 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 * dt=", dudt_sph(i)*dt + "dudt_sph * dti=", dudt_sph(i)*dti endif call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) @@ -206,10 +218,10 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) ! evolve energy if (tthermi == 0d0) then energ(i) = ui ! condition if denominator above is zero - elseif ( (dt/tthermi) < TINY(ui) ) then + elseif ( (dti/tthermi) < TINY(ui) ) then energ(i) = ui else - energ(i) = ui*exp(-dt/tthermi) + ueqi*(1.d0-exp(-dt/tthermi)) !code units + 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 @@ -217,7 +229,7 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) 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=",dt,"tthermi=", tthermi,"umini=", umini + 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 @@ -228,7 +240,6 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) enddo overpart !$omp end parallel do - !n_uevo = 0 !!$omp parallel do default(none) & !!$omp shared(dudt_sph,npart) private(i) reduction(+:n_uevo) !do i=1, npart @@ -237,7 +248,8 @@ subroutine radcool_update_energ(dt,npart,xyzh,energ,dudt_sph,Tfloor) !enddo !!$omp end parallel do ! print *, "energy not evolved with cooling for", n_uevo, "particles" -! print *, "min/max dudt_sph():", minval(dudt_sph), maxval(dudt_sph) +! print *, "min/max dudt_sph():", minval(dudt_sph), maxval(dudt_sph) + print *, "radcool min/max u():", minval(energ), maxval(energ) end subroutine radcool_update_energ diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index a823bd1bc..3385e8fff 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -291,17 +291,20 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) endif if (icooling == 9) then - write (*,*) "Before step", maxval(vxyzu(4,:)),minval(vxyzu(4,:)) umax = 0d0 + imax = 0. do i=1, npart if (vxyzu(4,i) > umax) then umax = vxyzu(4,i) imax = i endif enddo - print *, "max i=", imax, iactive(iphase(i)), fxyzu(4,i) - call radcool_update_energ(dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) - write (*,*) " ",maxval(vxyzu(4,:)),minval(vxyzu(4,:)), fxyzu(4,i) + print *, "max i=", imax, vxyzu(4,imax),iactive(iphase(imax)), fxyzu(4,imax) + print *, "minmax fxyzu(4,:)=", minval(fxyzu(4,1:npart)),maxval(fxyzu(4,1:npart)) + call radcool_update_energ(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) + ! write (*,*) " ",maxval(vxyzu(4,:)),minval(vxyzu(4,:)), fxyzu(4,i) + write (*,*) "Before step", maxval(vxyzu(4,:)),minval(vxyzu(4,:)) + write (*,*) "fxyzu(4:)=", maxval(fxyzu(4,1:npart)),minval(fxyzu(4,1:npart)) endif nsteps = nsteps + 1 ! @@ -321,11 +324,16 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) endif -! if (icooling == 9) then - ! write (*,*) "after step",maxval(vxyzu(4,:)),minval(vxyzu(4,:)) -! call radcool_update_energ(0.5*dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) - ! write (*,*) " ",maxval(vxyzu(4,:)),minval(vxyzu(4,:)) - ! endif + if (icooling == 9) then + imax = 0 + write (*,*) "after step",maxval(vxyzu(4,1:npart)),minval(vxyzu(4,1:npart)) + do i=1,npart + if (abs(fxyzu(4,i)) > epsilon(fxyzu(4,i))) imax = imax + 1 + end do + print *, "n dudt > 0 =", imax + ! call radcool_update_energ(0.5*dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) + ! write (*,*) " ",maxval(vxyzu(4,:)),minval(vxyzu(4,:)) + endif dtlast = dt diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index a5eccbc54..2838c5a68 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -167,12 +167,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) store_itype = (maxphase==maxp .and. ntypes > 1) ialphaloc = 2 nvfloorp = 0 - + print *, "L197 predictor, maxmin abs fxyzu=", maxval(abs(fxyzu(4,1:npart))),minval(abs(fxyzu(4,1:npart))) !$omp parallel do default(none) & !$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) & + !$omp shared(dustprop,ddustprop,dustproppred,ufloor,icooling) & !$omp shared(mprev,filfacprev,filfac,use_porosity) & !$omp shared(ibin,ibin_old,twas,timei) & !$omp firstprivate(itype) & @@ -231,7 +231,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif -! print *, "line 234", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) + !Alison icooling, vpred is right value here for u, but shouldn't be ...? + print *, "line 234", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)),"nactive =", nactive !---------------------------------------------------------------------- ! substepping with external and sink particle forces, using dtextforce @@ -273,7 +274,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) & +!$omp shared(eos_vars,ufloor,icooling) & !$omp shared(twas,timei) & !$omp shared(rad,drad,radpred)& !$omp private(hi,rhoi,tdecay1,source,ddenom,hdti) & @@ -321,7 +322,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vpred(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif !Alison - !if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L324", fxyzu(4,i) + if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L324", fxyzu(4,i) !--floor the thermal energy if requested and required if (ufloor > 0.) then @@ -394,6 +395,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) rad = radpred vxyzu(4,1:npart) = vpred(4,1:npart) endif + if (icooling == 0) vxyzu(4,1:npart) = vpred(4,1:npart) if (gr) vxyzu = vpred ! May need primitive variables elsewhere? if (dt_too_small) then @@ -404,7 +406,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call fatal('step','step too small: bin would exceed maximum') endif endif -! print *, "line 407", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) + print *, "line 407", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)), "nactive=", nactive ! ! if using super-timestepping, determine what dt will be used on the next loop ! @@ -421,7 +423,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! forces we must iterate until velocities agree. !------------------------------------------------------------------------- -! print *, "line 423", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) + print *, "line 423", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) its = 0 converged = .false. errmaxmean = 0.0 @@ -688,16 +690,18 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(4,1:npart) = vpred(4,1:npart) endif if (icooling == 9) then -! print *, "after 2nd derivs:vpred", maxval(vpred(4,:)), minval(vpred(4,:)) + print *, "after 2nd derivs:vpred", maxval(vpred(4,:)), minval(vpred(4,:)) vxyzu(4,1:npart) = vpred(4,1:npart) endif endif if (icooling == 9) then -! print *, "end of iteration", maxval(vpred(4,:)), minval(vpred(4,:)) + ! print *, "end of iteration", maxval(vpred(4,:)), minval(vpred(4,:)) + print *, "end of iteration, dudt", maxval(fxyzu(4,1:npart)), minval(fxyzu(4,1:npart)) + print *, "End of iteration, nactive=", nactive vxyzu(4,1:npart) = vpred(4,1:npart) endif enddo iterations - print *, "line 695", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) +! print *, "line 695", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) ! MPI reduce summary variables nwake = int(reduceall_mpi('+', nwake)) nvfloorp = int(reduceall_mpi('+', nvfloorp)) From 10cf964b11ef162fd9c4026486ca3bd71703d2fc Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Jul 2024 11:58:47 +0200 Subject: [PATCH 718/814] (subgroup) add binary identification method and prepare the slow down method --- src/main/part.F90 | 3 +- src/main/ptmass.F90 | 10 ++- src/main/subgroup.f90 | 158 ++++++++++++++++++++++++++++++++++++++---- 3 files changed, 153 insertions(+), 18 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index 9da9debbe..b5fa1fae5 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -303,6 +303,7 @@ module part integer, parameter :: igarg = 1 ! idx of the particle member of a group integer, parameter :: igcum = 2 ! cumulative sum of the indices to find the starting and ending point of a group integer, parameter :: igid = 3 ! id of the group, correspond to the root of the group in the dfs/union find construction + integer, parameter :: icomp = 4 ! id of the binary companion if it exists, otherwise equal to the id ! needed for group identification and sorting integer :: n_group = 0 integer :: n_ingroup = 0 @@ -504,7 +505,7 @@ subroutine allocate_part call allocate_array('abundance', abundance, nabundances, maxp_h2) endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) - call allocate_array('group_info', group_info, 3, maxptmass) + call allocate_array('group_info', group_info, 4, maxptmass) call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) call allocate_array("gtgrad", gtgrad, 3, maxptmass) call allocate_array('isionised', isionised, maxp) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e4dd1b468..b9a363ef6 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -333,7 +333,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec - use part, only:igarg,igid,ihacc + use part, only:igarg,igid,icomp,ihacc integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(out) :: fxyz_ptmass(4,nptmass) @@ -404,8 +404,9 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp reduction(+:phitot,merge_n) do k=1,nptmass if (subsys) then - i = group_info(igarg,k) - gidi = group_info(igid,k) + 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 + compi = group_info(icomp,k) ! id of the companion if it exists else i = k endif @@ -531,6 +532,9 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin endif endif endif + if (compi /= i) then + pert_out = pert_out + f1 + endif enddo phitot = phitot + 0.5*pmassi*phii ! total potential (G M_1 M_2/r) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 1e6e52e28..1e94242b9 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -32,6 +32,12 @@ module subgroup real, parameter :: C_bin = 0.02 real, public :: r_neigh = 0.001 ! default value assume udist = 1 pc real :: r_search + + ! + !-- parameter for Slow Down method + ! + real, parameter :: kref = 1e-6 + private contains !----------------------------------------------- @@ -82,6 +88,8 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm endif call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + if (n_group > 0) call find_binaries(xyzmh_ptmass,group_info,n_group) + call get_timings(t2,tcpu2) call increment_timer(itimer_sg_id,t2-t1,tcpu2-tcpu1) @@ -96,9 +104,76 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm end subroutine group_identify +subroutine find_binaries(xyzmh_ptmass,group_info,n_group) + use part, only : igarg,igcum,icomp + real, intent(in) :: xyzmh_ptmass(:,:) + integer, intent(inout) :: group_info(:,:) + integer, intent(in) :: n_group + integer, allocatable :: r2min_id(:) + integer :: i,j,k,l,np,ns,start_id,end_id,gsize + + + do i=1,n_group + start_id = group_info(igcum,i) + 1 + end_id = group_info(igcum,i+1) + gsize = (end_id - start_id) + 1 + if (gsize > 2) then + allocate(r2min_id(gsize)) + call compute_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) + do j=start_id,end_id + np = (j-start_id) + 1 + k = group_info(igarg,j) + ns = r2min_id(np) + if (r2min_id(ns) == np) then ! We found a binary into a subgroup : tag as binary component and compute parameters + l = group_info(igarg,ns+start_id) ! to find orbital params we need the relative seperation... (r2min) + group_info(icomp,k) = l + group_info(icomp,l) = k + else ! No matches... Only a single + group_info(icomp,k) = k + endif + enddo + else + k = group_info(igarg,start_id) + l = group_info(igarg,end_id) + group_info(icomp,l) = k + group_info(icomp,k) = l + endif + enddo + +end subroutine find_binaries + +subroutine compute_r2min(xyzmh_ptmass,group_info,r2min_id,n_group) + use part, only : igarg,igcum + real, intent(in) :: xyzmh_ptmass(:,:) + integer, intent(in) :: group_info(:,:) + integer, intent(out) :: r2min_id(:) + integer, intent(in) :: n_group + integer :: i,j,k,l,n + real :: dr(3),r2min,r2 + do i=start_id,end_id + n = (i-start_id)+1 + j = group_info(igarg,i) + r2 = 0. + r2min = huge(r2) + do k=start_id,end_id + l = group_info(igarg,k) + if (j == l) cycle + dr(1) = xyzmh_ptmass(1,j) - xyzmh_ptmass(1,l) + dr(2) = xyzmh_ptmass(2,j) - xyzmh_ptmass(2,l) + dr(3) = xyzmh_ptmass(3,j) - xyzmh_ptmass(3,l) + r2 = dr(1)**2+dr(2)**2+dr(3)**2 + if (r2 < r2min) then + r2min = r2 + r2min_id(n) = (k-start_id)+1 + endif + enddo + enddo + +end subroutine compute_r2min + subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) - use part, only : igarg,igcum,igid + use part, only : igarg,igcum,igid,icomp integer, intent(in) :: nptmass integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) integer, intent(inout) :: group_info(3,nptmass) @@ -118,6 +193,7 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) n_ingroup = n_ingroup - 1 group_info(igarg,nptmass-n_sing) = i group_info(igid,nptmass-n_sing) = i + group_info(icomp,nptmass-n_sing) = i n_sing = n_sing + 1 endif endif @@ -571,7 +647,12 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t real, intent(inout) :: tcoord,W integer, intent(in) :: i,j integer :: k - real :: dtd,dtk,dvel1(3),dvel2(3),dw,om + real :: dtd,dtd_sd,dtk,dvel1(3),dvel2(3),dw,om + real :: vcom(3),mtot,m1,m2 + + m1 = xyzmh_ptmass(4,i) + m2 = xyzmh_ptmass(4,j) + mtot = m1+m2 do k = 1,ck_size dtd = ds*cks(k)/W @@ -579,12 +660,23 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t !if (i == 1) print*, fxyz_ptmass(1,i),i,j time_table(k) = tcoord - xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) - xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd*vxyz_ptmass(2,i) - xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd*vxyz_ptmass(3,i) - xyzmh_ptmass(1,j) = xyzmh_ptmass(1,j) + dtd*vxyz_ptmass(1,j) - xyzmh_ptmass(2,j) = xyzmh_ptmass(2,j) + dtd*vxyz_ptmass(2,j) - xyzmh_ptmass(3,j) = xyzmh_ptmass(3,j) + dtd*vxyz_ptmass(3,j) + if (kappa > 1.0) then + dtd_sd = dtd*kappa1 + vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,j))/mtot + 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 + else + dtd_sd = dtd + endif + + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd_sd*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd_sd*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd_sd*vxyz_ptmass(3,i) + xyzmh_ptmass(1,j) = xyzmh_ptmass(1,j) + dtd_sd*vxyz_ptmass(1,j) + xyzmh_ptmass(2,j) = xyzmh_ptmass(2,j) + dtd_sd*vxyz_ptmass(2,j) + xyzmh_ptmass(3,j) = xyzmh_ptmass(3,j) + dtd_sd*vxyz_ptmass(3,j) + + if(kappa > 1.0) call correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,i,j) call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) @@ -611,7 +703,7 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t gtgrad(2,j)*vxyz_ptmass(2,j)+& gtgrad(3,j)*vxyz_ptmass(3,j) - W = W + dw*dtk + W = W + dw*dtk*kappa1 vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dvel1(1) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dvel1(2) @@ -624,6 +716,35 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t end subroutine oneStep_bin +subroutine correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,dtd,i,j) + real, intent(inout) :: xyzmh_ptmass(:,:) + real, intent(in) :: vxyz_ptmass(:,:),vcom(3) + real, intent(in) :: kappa1,dtd + integer, intent(in) :: i,j + real :: vrel(3),kappa11 + + kappa11 = kappa1 - 1. + + vrel(1) = vxyz_ptmass(1,i) - vcom(1) + vrel(2) = vxyz_ptmass(2,i) - vcom(2) + vrel(3) = vxyz_ptmass(3,i) - vcom(3) + + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + vrel(1)*kappa11 + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + vrel(2)*kappa11 + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + vrel(3)*kappa11 + + vrel(1) = vxyz_ptmass(1,j) - vcom(1) + vrel(2) = vxyz_ptmass(2,j) - vcom(2) + vrel(3) = vxyz_ptmass(3,j) - vcom(3) + + xyzmh_ptmass(1,j) = xyzmh_ptmass(1,j) + vrel(1)*kappa11 + xyzmh_ptmass(2,j) = xyzmh_ptmass(2,j) + vrel(2)*kappa11 + xyzmh_ptmass(3,j) = xyzmh_ptmass(3,j) + vrel(3)*kappa11 + + + +end subroutine correct_com_drift + subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id,potonly,ds_init) use part, only: igarg @@ -708,10 +829,11 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id end subroutine get_force_TTL -subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j,potonly,ds_init) +subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,potonly,ds_init) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: i,j + real, intent(in) :: kappa1 real, intent(out) :: om logical, optional, intent(in) :: potonly real, optional, intent(out) :: ds_init @@ -726,10 +848,18 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j,potonly,ds_i r2 = dx**2+dy**2+dz**2 ddr = 1./sqrt(r2) ddr3 = ddr*ddr*ddr - gravfi = mj*ddr3 - gravfj = mi*ddr3 - gtki = mj*ddr - gtkj = mi*ddr + + if (kappa1<1.0) then + gravfi = kappa1*mj*ddr3 + gravfj = kappa1*mi*ddr3 + gtki = kappa1*mj*ddr + gtkj = kappa1*mi*ddr + else + gravfi = mj*ddr3 + gravfj = mi*ddr3 + gtki = mj*ddr + gtkj = mi*ddr + endif fxyz_ptmass(4,i) = -gtki From 6837d88b4300b47490d6be8806d82db49e39ba43 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Jul 2024 14:28:03 +0200 Subject: [PATCH 719/814] (subgroup) add a complementary array to store main orb parameters --- src/main/part.F90 | 24 ++++++++--- src/main/subgroup.f90 | 95 ++++++++++++++++++++++++++++++++++--------- 2 files changed, 94 insertions(+), 25 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index b5fa1fae5..33b212fd9 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -298,12 +298,22 @@ module part ! !-- Regularisation algorithm allocation ! - integer, allocatable :: group_info(:,:) - integer(kind=1), allocatable :: nmatrix(:,:) - integer, parameter :: igarg = 1 ! idx of the particle member of a group - integer, parameter :: igcum = 2 ! cumulative sum of the indices to find the starting and ending point of a group - integer, parameter :: igid = 3 ! id of the group, correspond to the root of the group in the dfs/union find construction - integer, parameter :: icomp = 4 ! id of the binary companion if it exists, otherwise equal to the id + integer(kind=1), allocatable :: nmatrix(:,:) ! adjacency matrix used to construct each groups + + integer, allocatable :: group_info(:,:) ! array storing group id/idx of each group comp/boundary idx/bin comp id + integer, parameter :: igarg = 1 ! idx of the particle member of a group + integer, parameter :: igcum = 2 ! cumulative sum of the indices to find the starting and ending point of a group + integer, parameter :: igid = 3 ! id of the group, correspond to the root of the group in the dfs/union find construction + integer, parameter :: icomp = 4 ! id of the binary companion if it exists, otherwise equal to the id + + real, allocatable :: bin_info(:,:) ! array storing important orbital parameters and quantities of each binary + integer, parameter :: isemi = 1 ! semi major axis + integer, parameter :: iecc = 2 ! eccentricity + integer, parameter :: iapo = 3 ! apocenter + integer, parameter :: ipert = 4 ! perturbation + integer, parameter :: ikap = 5 ! kappa slow down + + ! needed for group identification and sorting integer :: n_group = 0 integer :: n_ingroup = 0 @@ -506,6 +516,7 @@ subroutine allocate_part endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) call allocate_array('group_info', group_info, 4, maxptmass) + call allocate_array('bin_info', bin_info, 5, maxptmass) call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) call allocate_array("gtgrad", gtgrad, 3, maxptmass) call allocate_array('isionised', isionised, maxp) @@ -591,6 +602,7 @@ subroutine deallocate_part if (allocated(istsactive)) deallocate(istsactive) if (allocated(ibin_sts)) deallocate(ibin_sts) if (allocated(group_info)) deallocate(group_info) + if (allocated(bin_info)) deallocate(bin_info) if (allocated(nmatrix)) deallocate(nmatrix) if (allocated(gtgrad)) deallocate(gtgrad) if (allocated(isionised)) deallocate(isionised) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 1e94242b9..fd54aecbc 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -59,11 +59,12 @@ end subroutine init_subgroup ! Group identification routines ! !----------------------------------------------- -subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix,dtext) +subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass, & + group_info,bin_info,nmatrix,dtext) use io, only:id,master,iverbose,iprint use timing, only:get_timings,increment_timer,itimer_sg_id integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),bin_info(:,:) integer, intent(inout) :: group_info(3,nptmass) integer, intent(inout) :: n_group,n_ingroup,n_sing integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) @@ -88,7 +89,7 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm endif call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) - if (n_group > 0) call find_binaries(xyzmh_ptmass,group_info,n_group) + if (n_group > 0) call find_binaries(xyzmh_ptmass,group_info,bin_info,n_group) call get_timings(t2,tcpu2) call increment_timer(itimer_sg_id,t2-t1,tcpu2-tcpu1) @@ -104,13 +105,17 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm end subroutine group_identify -subroutine find_binaries(xyzmh_ptmass,group_info,n_group) - use part, only : igarg,igcum,icomp - real, intent(in) :: xyzmh_ptmass(:,:) - integer, intent(inout) :: group_info(:,:) +subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) + use part, only: igarg,igcum,icomp,isemi,iecc,iapo + + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(inout) :: group_info(:,:),bin_info(:,:) integer, intent(in) :: n_group integer, allocatable :: r2min_id(:) integer :: i,j,k,l,np,ns,start_id,end_id,gsize + real :: akl,ekl,apokl + ! need to be zeroed for safety reasons + bin_info(:,:) = 0. do i=1,n_group @@ -119,24 +124,49 @@ subroutine find_binaries(xyzmh_ptmass,group_info,n_group) gsize = (end_id - start_id) + 1 if (gsize > 2) then allocate(r2min_id(gsize)) + allocate(r2min(gsize)) call compute_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) do j=start_id,end_id np = (j-start_id) + 1 k = group_info(igarg,j) - ns = r2min_id(np) - if (r2min_id(ns) == np) then ! We found a binary into a subgroup : tag as binary component and compute parameters - l = group_info(igarg,ns+start_id) ! to find orbital params we need the relative seperation... (r2min) - group_info(icomp,k) = l - group_info(icomp,l) = k - else ! No matches... Only a single - group_info(icomp,k) = k + if (group_info(icomp,k) > 0) then + ns = r2min_id(np) + if (r2min_id(ns) == np) then ! We found a binary into a subgroup : tag as binary component and compute parameters + l = group_info(igarg,ns+start_id) + group_info(icomp,k) = l + group_info(icomp,l) = k + ! + !-- Compute and store main orbital parameters needed for SDAR method + ! + call compute_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,k,l) + bin_info(isemi,k) = akl + bin_info(isemi,l) = akl + bin_info(iecc,k) = ekl + bin_info(iecc,l) = ekl + bin_info(iapo,k) = apokl + bin_info(iapo,l) = apokl + else ! No matches... Only a single + group_info(icomp,k) = k + bin_info(:,k) = 0. + endif endif enddo + deallocate(r2min_id) else k = group_info(igarg,start_id) l = group_info(igarg,end_id) group_info(icomp,l) = k group_info(icomp,k) = l + ! + !-- Compute and store main orbital parameters needed for SDAR method + ! + call compute_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,k,l) + bin_info(isemi,k) = akl + bin_info(isemi,l) = akl + bin_info(iecc,k) = ekl + bin_info(iecc,l) = ekl + bin_info(iapo,k) = apokl + bin_info(iapo,l) = apokl endif enddo @@ -144,12 +174,12 @@ end subroutine find_binaries subroutine compute_r2min(xyzmh_ptmass,group_info,r2min_id,n_group) use part, only : igarg,igcum - real, intent(in) :: xyzmh_ptmass(:,:) + real , intent(in) :: xyzmh_ptmass(:,:) integer, intent(in) :: group_info(:,:) integer, intent(out) :: r2min_id(:) integer, intent(in) :: n_group integer :: i,j,k,l,n - real :: dr(3),r2min,r2 + real :: dr(3),r2,r2min do i=start_id,end_id n = (i-start_id)+1 j = group_info(igarg,i) @@ -163,7 +193,7 @@ subroutine compute_r2min(xyzmh_ptmass,group_info,r2min_id,n_group) dr(3) = xyzmh_ptmass(3,j) - xyzmh_ptmass(3,l) r2 = dr(1)**2+dr(2)**2+dr(3)**2 if (r2 < r2min) then - r2min = r2 + r2min = r2 r2min_id(n) = (k-start_id)+1 endif enddo @@ -171,6 +201,31 @@ subroutine compute_r2min(xyzmh_ptmass,group_info,r2min_id,n_group) end subroutine compute_r2min +subroutine compute_orbparams(xyzmh_ptmass,vxyz_ptmass,aij,eij,apoij,i,j) + use utils_kepler, only: extract_e,extract_a + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(out) :: aij,eij,apoij + integer, intent(in) :: i,j + real :: dv(3),dr(3),mu,r,v2 + + dv(1) = vxyz_ptmass(1,j)-vxyz_ptmass(1,i) + dv(2) = vxyz_ptmass(2,j)-vxyz_ptmass(2,i) + dv(3) = vxyz_ptmass(3,j)-vxyz_ptmass(3,i) + dr(1) = xyzmh_ptmass(1,j)-xyzmh_ptmass(1,i) + dr(2) = xyzmh_ptmass(2,j)-xyzmh_ptmass(2,i) + dr(3) = xyzmh_ptmass(3,j)-xyzmh_ptmass(3,i) + mu = xyzmh_ptmass(4,i) + xyzmh_ptmass(4,j) + r = sqrt(dr(1)**2+dr(2)**2+dr(3)**2) + v2 = dv(1)**2+dv(2)**2+dv(3)**2 + + call extract_a(r,mu,v2,aij) + + call extract_e(dr(1),dr(2),dr(3),dv(1),dv(2),dv(3),mu,r,eij) + + apoij = aij*(1+eij) + +end subroutine compute_orbparams + subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) use part, only : igarg,igcum,igid,icomp @@ -215,7 +270,8 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) ncg = 1 inode = iroot group_info(igarg,n_ingroup) = inode - group_info(igid,n_ingroup) = iroot + group_info(igid,n_ingroup) = iroot + group_info(icomp,n_ingroup) = -1 ! icomp to -1 -> need to be identified later stack_top = stack_top + 1 stack(stack_top) = inode visited(inode) = .true. @@ -231,6 +287,7 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) visited(j) = .true. group_info(igarg,n_ingroup) = j group_info(igid,n_ingroup) = iroot + group_info(icomp,n_ingroup) = -1 ! icomp to -1 -> need to be identified later endif enddo enddo @@ -660,7 +717,7 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t !if (i == 1) print*, fxyz_ptmass(1,i),i,j time_table(k) = tcoord - if (kappa > 1.0) then + if (kappa1 < 1.0) then dtd_sd = dtd*kappa1 vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,j))/mtot vcom(2) = (m1*vxyz_ptmass(2,i)+m2*vxyz_ptmass(2,j))/mtot From 939217dcda4f8935e7dca97c63e9e0927335e881 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Jul 2024 15:31:47 +0200 Subject: [PATCH 720/814] (subgroup) main part done for binary group --- src/main/part.F90 | 12 ++++---- src/main/subgroup.f90 | 71 +++++++++++++++++++++++++++++-------------- 2 files changed, 55 insertions(+), 28 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index 33b212fd9..02fdbf785 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -306,12 +306,12 @@ module part integer, parameter :: igid = 3 ! id of the group, correspond to the root of the group in the dfs/union find construction integer, parameter :: icomp = 4 ! id of the binary companion if it exists, otherwise equal to the id - real, allocatable :: bin_info(:,:) ! array storing important orbital parameters and quantities of each binary - integer, parameter :: isemi = 1 ! semi major axis - integer, parameter :: iecc = 2 ! eccentricity - integer, parameter :: iapo = 3 ! apocenter - integer, parameter :: ipert = 4 ! perturbation - integer, parameter :: ikap = 5 ! kappa slow down + real, allocatable :: bin_info(:,:) ! array storing important orbital parameters and quantities of each binary + integer, parameter :: isemi = 1 ! semi major axis + integer, parameter :: iecc = 2 ! eccentricity + integer, parameter :: iapo = 3 ! apocenter + integer, parameter :: ipert = 4 ! perturbation + integer, parameter :: ikap = 5 ! kappa slow down ! needed for group identification and sorting diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index fd54aecbc..13c1ec3be 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -125,7 +125,7 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) if (gsize > 2) then allocate(r2min_id(gsize)) allocate(r2min(gsize)) - call compute_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) + call get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) do j=start_id,end_id np = (j-start_id) + 1 k = group_info(igarg,j) @@ -138,7 +138,7 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) ! !-- Compute and store main orbital parameters needed for SDAR method ! - call compute_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,k,l) + call get_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,k,l) bin_info(isemi,k) = akl bin_info(isemi,l) = akl bin_info(iecc,k) = ekl @@ -160,7 +160,7 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) ! !-- Compute and store main orbital parameters needed for SDAR method ! - call compute_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,k,l) + call get_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,k,l) bin_info(isemi,k) = akl bin_info(isemi,l) = akl bin_info(iecc,k) = ekl @@ -172,7 +172,7 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) end subroutine find_binaries -subroutine compute_r2min(xyzmh_ptmass,group_info,r2min_id,n_group) +subroutine get_r2min(xyzmh_ptmass,group_info,r2min_id,n_group) use part, only : igarg,igcum real , intent(in) :: xyzmh_ptmass(:,:) integer, intent(in) :: group_info(:,:) @@ -199,9 +199,9 @@ subroutine compute_r2min(xyzmh_ptmass,group_info,r2min_id,n_group) enddo enddo -end subroutine compute_r2min +end subroutine get_r2min -subroutine compute_orbparams(xyzmh_ptmass,vxyz_ptmass,aij,eij,apoij,i,j) +subroutine get_orbparams(xyzmh_ptmass,vxyz_ptmass,aij,eij,apoij,i,j) use utils_kepler, only: extract_e,extract_a real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(out) :: aij,eij,apoij @@ -224,7 +224,7 @@ subroutine compute_orbparams(xyzmh_ptmass,vxyz_ptmass,aij,eij,apoij,i,j) apoij = aij*(1+eij) -end subroutine compute_orbparams +end subroutine get_orbparams subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) @@ -373,13 +373,15 @@ end subroutine matrix_construction ! !--------------------------------------------- -subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) +subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,bin_info & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) use part, only:igarg,igcum use io, only:id,master use mpiutils, only:bcast_mpi use timing, only:get_timings,increment_timer,itimer_sg_evol integer, intent(in) :: n_group,nptmass real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) + real, intent(inout) :: bin_info(:,:) integer, intent(in) :: group_info(:,:) real, intent(in) :: tnext,time integer :: i,start_id,end_id,gsize @@ -394,13 +396,14 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz if (id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& - !$omp shared(tnext,time,group_info,gtgrad,n_group)& + !$omp shared(tnext,time,group_info,bin_info,gtgrad,n_group)& !$omp private(i,start_id,end_id,gsize) do i=1,n_group start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) gsize = (end_id - start_id) + 1 - call integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) + call integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,& + bin_info,group_info,fxyz_ptmass,gtgrad) enddo !$omp end parallel do endif @@ -417,10 +420,11 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz end subroutine evolve_groups -subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) - use part, only: igarg +subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,& + bin_info,group_info,fxyz_ptmass,gtgrad) + use part, only: igarg,ikap real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & - fxyz_ptmass(:,:),gtgrad(:,:) + fxyz_ptmass(:,:),gtgrad(:,:),bin_info(:,:) integer, intent(in) :: group_info(:,:) integer, intent(in) :: start_id,end_id,gsize real, intent(in) :: tnext,time @@ -430,7 +434,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ integer :: switch integer :: step_count_int,step_count_tsyn,n_step_end real :: dt,ds_init,dt_end,step_modif,t_old,W_old - real :: W,tcoord + real :: W,tcoord,kappa1 logical :: t_end_flag,backup_flag,ismultiple integer :: i,prim,sec @@ -444,7 +448,12 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) - call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,W,prim,sec,ds_init=ds_init) + ! + !-- We need to compute the force a the beginning of the step ( and kappa if slow down) + ! + call get_kappa_bin(xyzmh_ptmass,bin_info,prim,sec) + kappa1 = 1./bin_info(ikap,prim) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,W,kappa1,prim,sec,ds_init=ds_init) endif @@ -478,7 +487,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) - call oneStep_bin(tcoord,W,ds(switch),xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,prim,sec) + call oneStep_bin(tcoord,W,ds(switch),kappa1,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,prim,sec) endif dt = tcoord - t_old @@ -698,9 +707,9 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,s end subroutine kick_TTL -subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,i,j) +subroutine oneStep_bin(tcoord,W,ds,kappa1,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,i,j) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:),time_table(:) - real, intent(in) :: ds + real, intent(in) :: ds,kappa1 real, intent(inout) :: tcoord,W integer, intent(in) :: i,j integer :: k @@ -714,7 +723,6 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t do k = 1,ck_size dtd = ds*cks(k)/W tcoord = tcoord + dtd - !if (i == 1) print*, fxyz_ptmass(1,i),i,j time_table(k) = tcoord if (kappa1 < 1.0) then @@ -733,9 +741,9 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t xyzmh_ptmass(2,j) = xyzmh_ptmass(2,j) + dtd_sd*vxyz_ptmass(2,j) xyzmh_ptmass(3,j) = xyzmh_ptmass(3,j) + dtd_sd*vxyz_ptmass(3,j) - if(kappa > 1.0) call correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,i,j) + if(kappa1 < 1.0) call correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,i,j) - call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j) dtk = ds*dks(k)/om @@ -955,6 +963,25 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,poton end subroutine get_force_TTL_bin +subroutine get_kappa_bin(xyzmh_ptmass,bin_info,i,j) + use part, only:ipert,iapo,ikap + real, intent(inout) :: bin_info(:,:) + real, intent(in) :: xyzmh_ptmass(:,:) + integer, intent(in) :: i,j + real :: kappa,m1,m2,pert,mu,rapo + + m1 = xyzmh_ptmass(4,i) + m2 = xyzmh_ptmass(4,j) + mu = (m1*m2)/(m1+m2) + pert = bin_info(ipert,i) + rapo = bin_info(iapo,i) + rapo3 = rapo*rapo*rapo + kappa = kref*mu*(rapo3*pert) + bin_info(ikap,i) = kappa + bin_info(ikap,j) = kappa + +end subroutine get_kappa_bin + subroutine get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) use part, only: igarg,igcum @@ -982,7 +1009,7 @@ subroutine get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epo else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) - call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phigroup,prim,sec,.true.) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phigroup,kappa1,prim,sec,.true.) endif phitot = phitot + phigroup enddo From 4faafcdeb9c304cb7a718020f2620d51f5c18d37 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Jul 2024 15:48:46 +0200 Subject: [PATCH 721/814] (ptmass) store perturbation on binary from environement --- src/main/ptmass.F90 | 17 +++++++++++------ src/main/subgroup.f90 | 2 +- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index b9a363ef6..f7bdc41d3 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -325,7 +325,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) + iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass,extrapfac,fsink_old,& + group_info,bin_info) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -333,7 +334,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec - use part, only:igarg,igid,icomp,ihacc + use part, only:igarg,igid,icomp,ihacc,ipert integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(out) :: fxyz_ptmass(4,nptmass) @@ -344,11 +345,12 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real, intent(out) :: dsdt_ptmass(3,nptmass) real, optional, intent(in) :: extrapfac real, optional, intent(in) :: fsink_old(4,nptmass) - integer, optional, intent(in) :: group_info(3,nptmass) + real, optional, intent(out) :: bin_info(5,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 - real :: fextx,fexty,fextz,phiext !,hsofti + real :: fextx,fexty,fextz,phiext,pert_out !,hsofti real :: fterm,pterm,potensoft0,dsx,dsy,dsz real :: J2i,rsinki,shati(3) real :: J2j,rsinkj,shatj(3) @@ -397,13 +399,14 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp private(gidi,gidj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & - !$omp private(fextx,fexty,fextz,phiext) & + !$omp private(fextx,fexty,fextz,phiext,pert_out) & !$omp private(q2i,qi,psoft,fsoft) & !$omp private(fterm,pterm,J2i,J2j,shati,shatj,rsinki,rsinkj) & !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) do k=1,nptmass if (subsys) 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 compi = group_info(icomp,k) ! id of the companion if it exists @@ -532,12 +535,14 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin endif endif endif - if (compi /= i) then + if (subsys .and. compi /= i) then 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 + ! !--apply external forces ! diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 13c1ec3be..e70ca5e2c 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -117,7 +117,7 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) ! need to be zeroed for safety reasons bin_info(:,:) = 0. - +! this loop could be parallelized... do i=1,n_group start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) From 97da71317cca60d5d42f581b62e66619098796d9 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Jul 2024 16:56:23 +0200 Subject: [PATCH 722/814] (readwritedump) restore previous makefile config and add a flag to store ll_ptmass --- build/Makefile | 7 ++++--- src/main/config.F90 | 2 ++ src/main/ptmass.F90 | 3 +++ src/main/readwrite_dumps_common.f90 | 5 ++--- src/main/readwrite_dumps_fortran.f90 | 11 +++++------ 5 files changed, 16 insertions(+), 12 deletions(-) diff --git a/build/Makefile b/build/Makefile index bafa65db1..5acba64f2 100644 --- a/build/Makefile +++ b/build/Makefile @@ -533,9 +533,10 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ mpi_memory.f90 mpi_derivs.F90 mpi_tree.F90 kdtree.F90 linklist_kdtree.F90 utils_healpix.f90 utils_raytracer.f90 \ partinject.F90 utils_inject.f90 dust_formation.f90 ptmass_radiation.f90 ptmass_heating.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ - ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ - ${SRCKROME} memory.f90 H2regions.f90 utils_subgroup.f90 utils_kepler.f90 subgroup.f90 ptmass.F90 \ - ${SRCREADWRITE_DUMPS} quitdump.f90\ + ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 \ + ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} ${SRCINJECT} \ + H2regions.f90 utils_subgroup.f90 utils_kepler.f90 subgroup.f90 \ + quitdump.f90 ptmass.F90\ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ mf_write.f90 evolve.F90 utils_orbits.f90 utils_linalg.f90 \ diff --git a/src/main/config.F90 b/src/main/config.F90 index ae125450d..97b13a132 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -44,6 +44,8 @@ module dim #endif integer, parameter :: nsinkproperties = 22 + logical :: store_ll_ptmass = .false. + ! storage of thermal energy or not #ifdef ISOTHERMAL integer, parameter :: maxvxyzu = 3 diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e4dd1b468..a5362c8a0 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -2236,6 +2236,7 @@ end subroutine write_options_ptmass subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) use io, only:warning,fatal use subgroup, only:r_neigh + use dim, only:store_ll_ptmass character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr @@ -2320,6 +2321,8 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) imatch = .false. end select + if (icreate_sinks ==2) store_ll_ptmass = .true. + !--make sure we have got all compulsory options (otherwise, rewrite input file) if (icreate_sinks > 0) then igotall = (ngot >= 8) diff --git a/src/main/readwrite_dumps_common.f90 b/src/main/readwrite_dumps_common.f90 index c6993d678..c3059a51f 100644 --- a/src/main/readwrite_dumps_common.f90 +++ b/src/main/readwrite_dumps_common.f90 @@ -571,7 +571,7 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert got_eosvars,got_nucleation,got_iorig,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 + do_radiation,store_dust_temperature,do_nucleation,use_krome,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,& @@ -580,7 +580,6 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert use options, only:alpha,use_dustfrac,use_var_comp use sphNGutils, only:itype_from_sphNG_iphase,isphNG_accreted use dust_formation, only:init_nucleation - use ptmass, only:icreate_sinks integer, intent(in) :: i1,i2,noffset,npartoftype(:),npartread,nptmass,nsinkproperties real, intent(in) :: massoftype(:),alphafile,tfile logical, intent(in) :: phantomdump,got_iphase,got_xyzh(:),got_vxyzu(:),got_alpha(:),got_dustprop(:) @@ -768,7 +767,7 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert if (.not.all(got_sink_vels(1:3))) then if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING! sink particle velocities not found' endif - if ( icreate_sinks > 1 .and. .not.got_sink_llist) then + if ( store_ll_ptmass .and. .not.got_sink_llist) then if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING! sink particle link list not found' endif if (id==master .and. i1==1) then diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index ad656dd50..40015c958 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -48,7 +48,8 @@ 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,& + 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 use part, only:xyzh,xyzh_label,vxyzu,vxyzu_label,Bevol,Bevol_label,Bxyz,Bxyz_label,npart,maxtypes, & @@ -70,7 +71,6 @@ 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 ptmass, only:icreate_sinks real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer, intent(in), optional :: iorder(:) @@ -306,7 +306,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ilen(2) = int(nptmass,kind=8) call write_array(2,xyzmh_ptmass,xyzmh_ptmass_label,nsinkproperties,nptmass,k,ipass,idump,nums,nerr) call write_array(2,vxyz_ptmass,vxyz_ptmass_label,3,nptmass,k,ipass,idump,nums,nerr) - if (icreate_sinks == 2) then + if (store_ll_ptmass) then call write_array(2,linklist_ptmass,"linklist_ptmass",nptmass,k,ipass,idump,nums,nerr) endif if (nerr > 0) call error('write_dump','error writing sink particle arrays') @@ -974,7 +974,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 + ind_timesteps,use_krome,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, & @@ -985,7 +985,6 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto ithick,ilambda,iorig,dt_in,krome_nmols,T_gas_cool use sphNGutils, only:mass_sphng,got_mass,set_gas_particle_mass use options, only:use_porosity - use ptmass, only:icreate_sinks integer, intent(in) :: i1,i2,noffset,narraylengths,nums(:,:),npartread,npartoftype(:),idisk1,iprint real, intent(in) :: massoftype(:) integer, intent(in) :: nptmass,nsinkproperties @@ -1122,7 +1121,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto case(2) call read_array(xyzmh_ptmass,xyzmh_ptmass_label,got_sink_data,ik,1,nptmass,0,idisk1,tag,match,ierr) call read_array(vxyz_ptmass, vxyz_ptmass_label, got_sink_vels,ik,1,nptmass,0,idisk1,tag,match,ierr) - if (icreate_sinks == 2) then + if (store_ll_ptmass) then call read_array(linklist_ptmass,'linklist_ptmass',got_sink_llist,ik,1,nptmass,0,idisk1,tag,match,ierr) endif end select From ec1a5848228b846fb4dff9abeaafd09088f445e4 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 24 Jul 2024 17:12:08 +0100 Subject: [PATCH 723/814] Fixes for cooling_radapprox --- src/main/cooling_radapprox.f90 | 214 ++++++++++++++++++++++++++++----- src/main/eos_stamatellos.f90 | 3 + src/main/evolve.F90 | 23 +--- src/main/step_leapfrog.F90 | 31 +++-- 4 files changed, 207 insertions(+), 64 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index 64742de0d..e73edcdf1 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -26,14 +26,14 @@ module cooling_radapprox 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 + public :: init_star,radcool_update_energ_loop contains subroutine init_star() use part, only:nptmass,xyzmh_ptmass use io, only:fatal - integer :: i,imin + integer :: i,imin=0 real :: rsink2,rsink2min rsink2min = 0d0 @@ -59,11 +59,168 @@ subroutine init_star() "at (xyz)",xyzmh_ptmass(1:3,isink_star)!"as illuminating star." end subroutine init_star + +! +! Do cooling calculation +! +! update energy to return evolved energy array. Called from step corrector +subroutine radcool_update_energ(i,dti,npart,xyzhi,ui,dudti_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 + use part, only:iphase,maxphase,maxp,iamtype,ibin + use timestep_ind, only:get_dt + integer,intent(in) :: i,npart + real,intent(in) :: xyzhi(:),dti,Tfloor,dudti_sph + real,intent(inout) :: ui + real :: rhoi,coldensi,kappaBari,kappaParti,ri2 + real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot + real :: cs2,Om2,Hmod2 + real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi + integer :: ratefile,n_uevo + +! write (temp,'(E5.2)') dt + coldensi = huge(coldensi) + poti = Gpot_cool(i) + du_FLDi = duFLD(i) + if (abs(ui) < epsilon(ui)) print *, "ui zero", i + rhoi = rhoh(xyzhi(4),massoftype(igas)) + + if (isink_star > 0) then + ri2 = (xyzhi(1)-xyzmh_ptmass(1,isink_star))**2d0 & + + (xyzhi(2)-xyzmh_ptmass(2,isink_star))**2d0 & + + (xyzhi(3)-xyzmh_ptmass(3,isink_star))**2d0 + else + ri2 = xyzhi(1)**2d0 + xyzhi(2)**2d0 + xyzhi(3)**2d0 + endif + + ! get opacities & Ti for ui + call getopac_opdep(ui*unit_ergg,rhoi*unit_density,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 + 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 = dudti_sph + du_FLDi + else + du_tot = dudti_sph + 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) + ui = ui + du_tot*dti + return + 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)=", dudti_sph, "duradi=", dudti_rad, "Ti=", Ti, & + "Tmini=", Tmini4**(1.0/4.0),du_tot,Hcomb, "r=",sqrt(ri2), "ui=", ui, & + "dudt_sph * dti=", dudti_sph*dti + endif + + 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 + 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 + ui = ui ! condition if denominator above is zero + elseif ( (dti/tthermi) < TINY(ui) ) then + ui = ui + else + ui = ui*exp(-dti/tthermi) + ueqi*(1.d0-exp(-dti/tthermi)) !code units + endif + + if (isnan(ui) .or. ui < 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",dudti_sph + 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 + +end subroutine radcool_update_energ + + ! ! Do cooling calculation ! ! update energy to return evolved energy array. Called from evolve.F90 -subroutine radcool_update_energ(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) +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 @@ -81,7 +238,10 @@ subroutine radcool_update_energ(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) 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) & @@ -97,7 +257,6 @@ subroutine radcool_update_energ(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) if (iamtype(iphase(i)) /= igas) cycle if (isdead_or_accreted(xyzh(4,i))) cycle if (.not. iactive(iphase(i)) ) then -! dudt_sph(i) = 0d0 n_uevo = n_uevo + 1 cycle endif @@ -153,6 +312,9 @@ subroutine radcool_update_energ(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) 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 @@ -166,25 +328,23 @@ subroutine radcool_update_energ(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) 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 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/dudt_sph(i)) < dtcool_crit) then - ! print *, "not cooling/heating for r=",sqrt(ri2),".", dudti_rad,& - ! dudt_sph(i) - ! energ(i) = ui + dudt_sph(i)*dti - ! dudt_sph(i) = 0d0 - ! cycle - !endif if (doFLD) then - Teqi = (du_FLDi + dudt_sph(i)) *opaci*unit_ergg/utime ! physical units - du_tot = dudt_sph(i) + dudti_rad + du_FLDi + du_tot = dudt_sph(i) + du_FLDi else - Teqi = dudt_sph(i)*opaci*unit_ergg/utime - du_tot = dudt_sph(i) + dudti_rad + 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 @@ -235,22 +395,12 @@ subroutine radcool_update_energ(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) stop endif - ! zero fxyzu(4,i) because we already updated the energy - dudt_sph(i) = 0d0 enddo overpart !$omp end parallel do - !!$omp parallel do default(none) & - !!$omp shared(dudt_sph,npart) private(i) reduction(+:n_uevo) - !do i=1, npart - ! if (dudt_sph(i) /= 0d0) n_uevo = n_uevo + 1 - ! dudt_sph(i) = 0d0 - !enddo - !!$omp end parallel do -! print *, "energy not evolved with cooling for", n_uevo, "particles" -! print *, "min/max dudt_sph():", minval(dudt_sph), maxval(dudt_sph) - print *, "radcool min/max u():", minval(energ), maxval(energ) -end subroutine radcool_update_energ + 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 subroutine write_options_cooling_radapprox(iunit) diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index 59c9449a9..5b784bb82 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -42,7 +42,10 @@ subroutine init_S07cool() allocate(ttherm_store(npart)) allocate(teqi_store(npart)) allocate(opac_store(npart)) + Gpot_cool(:) = 0d0 + gradP_cool(:) = 0d0 urad_FLD(:) = 0d0 + duFLD(:) = 0d0 open (unit=iunitst,file='EOSinfo.dat',status='replace') if (doFLD) then print *, "Using Forgan+ 2009 hybrid cooling method (FLD)" diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 3385e8fff..9c81bbf1d 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -82,7 +82,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) use radiation_utils, only:update_radenergy use timestep, only:dtrad use cooling, only:Tfloor - use cooling_radapprox,only:radcool_update_energ + use cooling_radapprox,only:radcool_update_energ_loop #ifdef LIVE_ANALYSIS use analysis, only:do_analysis use part, only:igas @@ -291,20 +291,10 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) endif if (icooling == 9) then - umax = 0d0 - imax = 0. - do i=1, npart - if (vxyzu(4,i) > umax) then - umax = vxyzu(4,i) - imax = i - endif - enddo - print *, "max i=", imax, vxyzu(4,imax),iactive(iphase(imax)), fxyzu(4,imax) - print *, "minmax fxyzu(4,:)=", minval(fxyzu(4,1:npart)),maxval(fxyzu(4,1:npart)) - call radcool_update_energ(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) + call radcool_update_energ_loop(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) ! write (*,*) " ",maxval(vxyzu(4,:)),minval(vxyzu(4,:)), fxyzu(4,i) write (*,*) "Before step", maxval(vxyzu(4,:)),minval(vxyzu(4,:)) - write (*,*) "fxyzu(4:)=", maxval(fxyzu(4,1:npart)),minval(fxyzu(4,1:npart)) + ! write (*,*) "fxyzu(4:)=", maxval(fxyzu(4,1:npart)),minval(fxyzu(4,1:npart)) endif nsteps = nsteps + 1 ! @@ -325,14 +315,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) endif if (icooling == 9) then - imax = 0 write (*,*) "after step",maxval(vxyzu(4,1:npart)),minval(vxyzu(4,1:npart)) - do i=1,npart - if (abs(fxyzu(4,i)) > epsilon(fxyzu(4,i))) imax = imax + 1 - end do - print *, "n dudt > 0 =", imax - ! call radcool_update_energ(0.5*dt,npart,xyzh,vxyzu(4,:),fxyzu(4,:),Tfloor) - ! write (*,*) " ",maxval(vxyzu(4,:)),minval(vxyzu(4,:)) endif dtlast = dt diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 2838c5a68..6820ba598 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -197,7 +197,11 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) else - vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) + if (icooling == 9) then + vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) + else + vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) + endif endif !--floor the thermal energy if requested and required @@ -321,9 +325,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else vpred(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif - !Alison - if (icooling == 9 .and. fxyzu(4,i) > epsilon(fxyzu(4,i))) print *, "!warning! step L324", fxyzu(4,i) - + !--floor the thermal energy if requested and required if (ufloor > 0.) then if (vpred(4,i) < ufloor) then @@ -385,6 +387,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 == 9) vpred(4,1:npart) = vxyzu(4,1:npart) dt_too_small = .false. call derivs(1,npart,nactive,xyzh,vpred,fxyzu,fext,divcurlv,& divcurlB,Bpred,dBevol,radpred,drad,radprop,dustproppred,ddustprop,& @@ -483,7 +486,11 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + dti*fxyzu(:,i) else - vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) + if (icooling == 9) then + vxyzu(1:3,i) = vxyzu(1:3,i) + dti*fxyzu(1:3,i) + else + vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) + endif endif if (use_dustgrowth .and. itype==idust) dustprop(:,i) = dustprop(:,i) + dti*ddustprop(:,i) @@ -505,7 +512,11 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) else - vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) + if (icooling == 9) then + vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) + else + vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) + endif endif !--floor the thermal energy if requested and required @@ -624,12 +635,10 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (iamboundary(itype)) cycle until_converged if (ind_timesteps) then - if (icooling == 9) vxyzu(4,i) = vpred(4,i) !keep original value of u if (iactive(iphase(i))) then if (gr) then ppred(:,i) = pxyzu(:,i) else -! if (icooling == 9) vxyzu(4,i) = vpred(4,i) !keep original value of u vpred(:,i) = vxyzu(:,i) endif if (use_dustgrowth) dustproppred(:,i) = dustprop(:,i) @@ -680,7 +689,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! get new force using updated velocity: no need to recalculate density etc. ! if (gr) vpred = vxyzu ! Need primitive utherm as a guess in cons2prim -! print *, "before 2nd derivs", maxval(vpred(4,:)), minval(vpred(4,:)),maxval(fxyzu(4,:)) 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) @@ -691,17 +699,16 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif if (icooling == 9) then print *, "after 2nd derivs:vpred", maxval(vpred(4,:)), minval(vpred(4,:)) - vxyzu(4,1:npart) = vpred(4,1:npart) endif endif if (icooling == 9) then - ! print *, "end of iteration", maxval(vpred(4,:)), minval(vpred(4,:)) + print *, "end of iteration", maxval(vpred(4,:)), minval(vpred(4,:)) print *, "end of iteration, dudt", maxval(fxyzu(4,1:npart)), minval(fxyzu(4,1:npart)) print *, "End of iteration, nactive=", nactive vxyzu(4,1:npart) = vpred(4,1:npart) endif enddo iterations -! print *, "line 695", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) + ! MPI reduce summary variables nwake = int(reduceall_mpi('+', nwake)) nvfloorp = int(reduceall_mpi('+', nvfloorp)) From 5714d7bc8d6179f04fd9cf84350644af4ad2eecd Mon Sep 17 00:00:00 2001 From: Shunquan Huang Date: Wed, 24 Jul 2024 17:26:51 -0700 Subject: [PATCH 724/814] an unpadte to randomwind --- build/Makefile_setups | 12 +++- ...asteroidwind.f90 => inject_randomwind.f90} | 55 +++++++++++++++---- src/main/random.f90 | 29 +++++++++- src/main/units.f90 | 36 +++++++++++- src/setup/setup_asteroidwind.f90 | 17 ++++-- 5 files changed, 129 insertions(+), 20 deletions(-) rename src/main/{inject_asteroidwind.f90 => inject_randomwind.f90} (76%) diff --git a/build/Makefile_setups b/build/Makefile_setups index 94c9d7e0d..f6dd95b81 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -77,7 +77,17 @@ endif ifeq ($(SETUP), asteroidwind) # asteroid emitting a wind (Trevascus et al. 2021) SETUPFILE=setup_asteroidwind.f90 - SRCINJECT=utils_binary.f90 inject_asteroidwind.f90 + SRCINJECT=utils_binary.f90 inject_randomwind.f90 + IND_TIMESTEPS=yes + CONST_AV=yes + ISOTHERMAL=yes + KNOWN_SETUP=yes +endif + +ifeq ($(SETUP), randomwind) +# asteroid emitting a wind (Trevascus et al. 2021) + SETUPFILE=setup_disc.f90 + SRCINJECT=utils_binary.f90 inject_randomwind.f90 IND_TIMESTEPS=yes CONST_AV=yes ISOTHERMAL=yes diff --git a/src/main/inject_asteroidwind.f90 b/src/main/inject_randomwind.f90 similarity index 76% rename from src/main/inject_asteroidwind.f90 rename to src/main/inject_randomwind.f90 index 37072a760..e0f78cf44 100644 --- a/src/main/inject_asteroidwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -15,9 +15,12 @@ module inject ! :Owner: David Liptai ! ! :Runtime parameters: +! - mdot_str : *mdot with unit* ! - mdot : *mass injection rate in grams/second* ! - mdot_type : *injection rate (0=const, 1=cos(t), 2=r^(-2))* ! - vlag : *percentage lag in velocity of wind* +! - random_type : random position on the surface, 0 for random, 1 for gaussian +! - delta_theta : standard deviation for the gaussion distribution (random_type=1) ! ! :Dependencies: binaryutils, externalforces, infile_utils, io, options, ! part, partinject, physcon, random, units @@ -26,7 +29,8 @@ module inject use physcon, only:pi implicit none character(len=*), parameter, public :: inject_type = 'asteroidwind' - real, public :: mdot = 5.e8 ! mass injection rate in grams/second + character(len=20), public :: mdot_str = "5.e8*g/s" + real, public :: mdot = 1.e8 ! mass injection rate in grams/second public :: init_inject,inject_particles,write_options_inject,read_options_inject,& set_default_options_inject,update_injected_par @@ -35,7 +39,9 @@ module inject real :: npartperorbit = 1000. ! particle injection rate in particles per orbit real :: vlag = 0.0 ! percentage lag in velocity of wind - integer :: mdot_type = 2 ! injection rate (0=const, 1=cos(t), 2=r^(-2)) + integer :: mdot_type = 0 ! injection rate (0=const, 1=cos(t), 2=r^(-2)) + integer :: random_type = 0 ! random position on the surface, 0 for random, 1 for gaussian + real :: delta_theta = 0.5 ! standard deviation for the gaussion distribution (random_type=1) contains !----------------------------------------------------------------------- @@ -61,8 +67,8 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& use part, only:nptmass,massoftype,igas,hfact,ihsoft use partinject, only:add_or_update_particle use physcon, only:twopi,gg,kboltz,mass_proton_cgs - use random, only:get_random_pos_on_sphere - use units, only:umass, utime + use random, only:get_random_pos_on_sphere, get_gaussian_pos_on_sphere + use units, only:umass, utime, in_code_units use options, only:iexternalforce use externalforces,only:mass1 use binaryutils, only:get_orbit_bits @@ -71,6 +77,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& integer, intent(inout) :: npart, npart_old integer, intent(inout) :: npartoftype(:) real, intent(out) :: dtinject + integer :: ierr real, dimension(3) :: xyz,vxyz,r1,r2,v2,vhat,v1 integer :: i,ipart,npinject,seed,pt real :: dmdt,rasteroid,h,u,speed,inject_this_step @@ -109,7 +116,8 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& ! ! Add any dependency on radius to mass injection rate (and convert to code units) ! - dmdt = mdot*mdot_func(r,semia)/(umass/utime) ! Use semi-major axis as r_ref + mdot = in_code_units(mdot_str,ierr) + dmdt = mdot*mdot_func(r,semia) ! Use semi-major axis as r_ref ! !-- How many particles do we need to inject? @@ -120,7 +128,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& else ! Calculate how many extra particles from previous step to now dt = time - t_old - inject_this_step = dt*mdot/massoftype(igas)/(umass/utime) + inject_this_step = dt*dmdt/massoftype(igas) npinject = max(0, int(0.5 + have_injected + inject_this_step - npartoftype(igas) )) @@ -134,7 +142,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& ! Only inject them on the side that is facing the central sink ! do i=1,npinject - xyz = r2 + rasteroid*get_random_pos_on_sphere(seed) + xyz = r2 + rasteroid*get_pos_on_sphere(seed, delta_theta) vxyz = (1.-vlag/100)*speed*vhat u = 0. ! setup is isothermal so utherm is not stored h = hfact*(rasteroid/2.) @@ -173,6 +181,25 @@ real function mdot_func(r,r_ref) end function mdot_func +!----------------------------------------------------------------------- +!+ +! Returns a random location on a sperical surface +!+ +!----------------------------------------------------------------------- +function get_pos_on_sphere(iseed, delta_theta) result(dx) + use random, only:get_random_pos_on_sphere, get_gaussian_pos_on_sphere + integer, intent(inout) :: iseed + real, intent(inout) :: delta_theta + real :: dx(3) + + select case (random_type) + case(1) + dx = get_gaussian_pos_on_sphere(iseed, delta_theta) + case(0) + dx = get_random_pos_on_sphere(iseed) + end select +end function get_pos_on_sphere + !----------------------------------------------------------------------- !+ ! Writes input options to the input file. @@ -182,11 +209,13 @@ subroutine write_options_inject(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit - call write_inopt(mdot,'mdot','mass injection rate in grams/second',iunit) + call write_inopt(mdot_str,'mdot','mass injection rate with unit, e.g. 1e8*g/s, 1e-7M_s/yr',iunit) call write_inopt(npartperorbit,'npartperorbit',& 'particle injection rate in particles/binary orbit',iunit) call write_inopt(vlag,'vlag','percentage lag in velocity of wind',iunit) call write_inopt(mdot_type,'mdot_type','injection rate (0=const, 1=cos(t), 2=r^(-2))',iunit) + call write_inopt(random_type, 'random_type', 'random position on the surface, 0 for random, 1 for gaussian', iunit) + call write_inopt(delta_theta, 'delta_theta', 'standard deviation for the gaussion distribution (random_type=1)', iunit) end subroutine write_options_inject @@ -206,9 +235,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) imatch = .true. select case(trim(name)) case('mdot') - read(valstring,*,iostat=ierr) mdot + read(valstring,'(A)',iostat=ierr) mdot_str ngot = ngot + 1 - if (mdot < 0.) call fatal(label,'mdot < 0 in input options') + ! if (mdot < 0.) call fatal(label,'mdot < 0 in input options') case('npartperorbit') read(valstring,*,iostat=ierr) npartperorbit ngot = ngot + 1 @@ -219,6 +248,12 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) case('mdot_type') read(valstring,*,iostat=ierr) mdot_type ngot = ngot + 1 + case('random_type') + read(valstring,*,iostat=ierr) random_type + ngot = ngot + 1 + case('delta_theta') + read(valstring,*,iostat=ierr) delta_theta + ngot = ngot + 1 case default imatch = .false. end select diff --git a/src/main/random.f90 b/src/main/random.f90 index e77444401..4984c9886 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -19,7 +19,7 @@ module random ! implicit none public :: ran2,get_random,rayleigh_deviate - public :: get_random_pos_on_sphere,gauss_random + public :: get_random_pos_on_sphere,gauss_random,get_gaussian_pos_on_sphere real, parameter :: pi = 4.*atan(1.) private @@ -167,4 +167,29 @@ real function gauss_random(iseed) end function gauss_random -end module random +!------------------------------------------------------------------------- +! +! get random position on sphere +! +!------------------------------------------------------------------------- +function get_gaussian_pos_on_sphere(iseed, deltheta) result(dx) + integer, intent(inout) :: iseed + real, intent(in) :: deltheta + real :: phi,theta,sintheta,costheta,sinphi,cosphi,gauss_theta + real :: dx(3) + + phi = 2.*pi*(ran2(iseed) - 0.5) + gauss_theta = gauss_random(iseed) * deltheta + do while (abs(gauss_theta) > 1.0) + gauss_theta = gauss_random(iseed) * deltheta + end do + theta = acos(gauss_theta) + sintheta = sin(theta) + costheta = cos(theta) + sinphi = sin(phi) + cosphi = cos(phi) + dx = (/sintheta*cosphi,sintheta*sinphi,costheta/) + +end function get_gaussian_pos_on_sphere + +end module random \ No newline at end of file diff --git a/src/main/units.f90 b/src/main/units.f90 index 62cae18aa..8af9b5dc9 100644 --- a/src/main/units.f90 +++ b/src/main/units.f90 @@ -34,7 +34,7 @@ module units public :: set_units, set_units_extra, print_units public :: get_G_code, get_c_code, get_radconst_code, get_kbmh_code public :: c_is_unity, G_is_unity, in_geometric_units - public :: is_time_unit, is_length_unit + public :: is_time_unit, is_length_unit, is_mdot_unit public :: in_solarr, in_solarm, in_solarl contains @@ -226,6 +226,12 @@ subroutine select_unit(string,unit,ierr) unit = minutes 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") + unit = solarm/years case default ierr = 1 unit = 1.d0 @@ -285,6 +291,32 @@ logical function is_length_unit(string) end function is_length_unit +!------------------------------------------------------------------------------------ +!+ +! check if string is a unit of mdot +!+ +!------------------------------------------------------------------------------------ +logical function is_mdot_unit(string) + character(len=*), intent(in) :: string + character(len=len(string)) :: unitstr + real(kind=8) :: fac + integer :: ierr + + ierr = 0 + call get_unit_multiplier(string,unitstr,fac,ierr) + + 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 + +end function is_mdot_unit + !------------------------------------------------------------------------------------ !+ ! parse a string like "10.*days" or "10*au" and return the value in code units @@ -301,6 +333,8 @@ real function in_code_units(string,ierr) result(rval) 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)) else rval = real(val) ! no unit conversion endif diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index 8ccc75fb8..0a2af47e0 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -22,7 +22,8 @@ module setup ! - ipot : *wd modelled by 0=sink or 1=externalforce* ! - m1 : *mass of white dwarf (solar mass)* ! - m2 : *mass of asteroid (ceres mass)* -! - mdot : *mass injection rate (g/s)* +! - mdot : *mass injection rate +! - mdot_str : *mdot with unit* ! - norbits : *number of orbits* ! - npart_at_end : *number of particles injected after norbits* ! - rasteroid : *radius of asteroid (km)* @@ -33,6 +34,7 @@ module setup ! timestep, units ! use inject, only:mdot + use inject, only:mdot_str implicit none public :: setpart @@ -47,7 +49,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,idust,set_particle_type,igas use setbinary, only:set_binary,get_a_from_period use spherical, only:set_sphere - use units, only:set_units,umass,udist,utime,unit_velocity + use units, only:set_units,umass,udist,utime,unit_velocity,in_code_units use physcon, only:solarm,au,pi,solarr,ceresm,km,kboltz,mass_proton_cgs use externalforces, only:iext_binary, iext_einsteinprec, update_externalforce, & mass1,accradius1 @@ -84,7 +86,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, rasteroid = 2338.3 ! (km) gastemp = 5000. ! (K) norbits = 1000. - mdot = 5.e8 ! Mass injection rate (g/s) + mdot = 5.e8 ! Mass injection rate (will change later by the mdot_str) + mdot_str = "5.e8*g/s" ! Mass injection rate with unit, e.g. 1e8*g/s, 1e-7M_s/yr npart_at_end = 1.0e6 ! Number of particles after norbits dumpsperorbit = 1 @@ -180,7 +183,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif ! we use the estimated injection rate and the final time to set the particle mass - massoftype(igas) = tmax*mdot/(umass/utime)/npart_at_end + mdot = in_code_units(mdot_str,ierr) + massoftype(igas) = tmax*mdot/npart_at_end hfact = hfact_default !npart_old = npart !call inject_particles(time,0.,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npart_old,npartoftype,dtinj) @@ -219,7 +223,7 @@ subroutine write_setupfile(filename) call write_inopt(norbits, 'norbits', 'number of orbits', iunit) call write_inopt(dumpsperorbit,'dumpsperorbit','number of dumps per orbit', iunit) call write_inopt(npart_at_end,'npart_at_end','number of particles injected after norbits',iunit) - call write_inopt(mdot,'mdot','mass injection rate (g/s)',iunit) + call write_inopt(mdot_str, 'mdot', 'mass injection rate with unit, e.g. 1e8*g/s, 1e-7M_s/yr (from setup)',iunit) close(iunit) end subroutine write_setupfile @@ -227,6 +231,7 @@ end subroutine write_setupfile subroutine read_setupfile(filename,ierr) use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db use io, only:error + use units, only:in_code_units character(len=*), intent(in) :: filename integer, intent(out) :: ierr integer, parameter :: iunit = 21 @@ -248,7 +253,7 @@ subroutine read_setupfile(filename,ierr) call read_inopt(norbits, 'norbits', db,min=0.,errcount=nerr) call read_inopt(dumpsperorbit,'dumpsperorbit',db,min=0 ,errcount=nerr) call read_inopt(npart_at_end, 'npart_at_end', db,min=0 ,errcount=nerr) - call read_inopt(mdot, 'mdot', db,min=0.,errcount=nerr) + call read_inopt(mdot_str, 'mdot', db,errcount=nerr) call close_db(db) if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' From 2dcebe5fbfff1837d01fadbd6320a36b2fa81542 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 25 Jul 2024 11:29:20 +0200 Subject: [PATCH 725/814] (HIIR) the iterative substraction is now in log space to avoid working with to big number --- src/main/H2regions.f90 | 42 +++++++++++++++++++-------------------- src/main/part.F90 | 2 +- src/tests/test_ptmass.f90 | 4 ++-- 3 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index ac89e60e2..6b8af754d 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -101,19 +101,19 @@ end subroutine initialize_H2R subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose - use units, only:utime,umass + use units, only:umass use part, only:irateion,ihacc,irstrom use physcon,only:solarm integer, intent(in) :: nptmass real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: h_acc - real :: logmi,log_Q,mi,hi,Q + real :: logmi,log_Q,mi,hi integer :: i nHIIsources = 0 !$omp parallel do default(none) & !$omp shared(xyzmh_ptmass,iprint,iverbose,umass)& - !$omp shared(utime,Minmass,h_acc,nptmass)& - !$omp private(logmi,log_Q,Q,mi,hi)& + !$omp shared(Minmass,h_acc,nptmass)& + !$omp private(logmi,log_Q,mi,hi)& !$omp reduction(+:nHIIsources) do i=1,nptmass mi = xyzmh_ptmass(4,i) @@ -123,8 +123,7 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) - Q = (10.**log_Q)*utime - xyzmh_ptmass(irateion,i) = Q + xyzmh_ptmass(irateion,i) = log_Q xyzmh_ptmass(irstrom,i) = -1. nHIIsources = nHIIsources + 1 if (iverbose >= 0) then @@ -144,13 +143,13 @@ end subroutine update_ionrates subroutine update_ionrate(i,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose - use units, only:utime,umass + use units, only:umass use part, only:irateion,ihacc,irstrom use physcon,only:solarm integer, intent(in) :: i real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: h_acc - real :: logmi,log_Q,mi,hi,Q + real :: logmi,log_Q,mi,hi mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) if (mi > Minmass .and. hi < h_acc) then @@ -158,8 +157,7 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) ! caluclation of the ionizing photon rate of each sources ! this calculation uses Fujii's formula derived from OSTAR2002 databases log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) - Q = (10.**log_Q)*utime - xyzmh_ptmass(irateion,i) = Q + xyzmh_ptmass(irateion,i) = log_Q xyzmh_ptmass(irstrom,i) = -1. nHIIsources = nHIIsources + 1 if (iverbose >= 0) then @@ -190,6 +188,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) use physcon, only:pc,pi use timing, only:get_timings,increment_timer,itimer_HII use dim, only:maxvxyzu + use units, only:utime integer, intent(in) :: nptmass,npart real, intent(in) :: xyzh(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyzu(:,:) @@ -199,8 +198,8 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) real, save :: xyzcache(maxcache,3) integer :: i,k,j,npartin,nneigh real(kind=4) :: t1,t2,tcpu1,tcpu2 - real :: pmass,Ndot,DNdot,taud,mHII,r,r_in,hcheck - real :: xi,yi,zi,Qi,stromi,xj,yj,zj,dx,dy,dz,vkx,vky,vkz + real :: pmass,Ndot,DNdot,logNdiff,taud,mHII,r,r_in,hcheck + real :: xi,yi,zi,log_Qi,stromi,xj,yj,zj,dx,dy,dz,vkx,vky,vkz logical :: momflag momflag = .false. @@ -220,9 +219,9 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) if (nHIIsources > 0) then do i=1,nptmass npartin=0 - Qi = xyzmh_ptmass(irateion,i) - if (Qi <=0.) cycle - Ndot = Qi + log_Qi = xyzmh_ptmass(irateion,i) + if (log_Qi <=0.) cycle + Ndot = log_Qi ! instead of working with very large number, we'll work in logspace now xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) @@ -243,10 +242,11 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) j = listneigh(k) if (.not. isdead_or_accreted(xyzh(4,j))) then ! ionising photons needed to fully ionise the current particle - DNdot = (pmass*ar*rhoh(xyzh(4,j),pmass))/(mH**2) + DNdot = log10((((pmass*ar*rhoh(xyzh(4,j),pmass))/(mH**2))/utime)) if (Ndot>DNdot) then if (.not.(isionised(j))) then - Ndot = Ndot - DNdot + logNdiff = DNdot -Ndot + Ndot = Ndot + log10(1-10**(logNdiff)) isionised(j)=.true. if (maxvxyzu >= 4) vxyzu(4,j) = uIon endif @@ -275,7 +275,7 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) if (mHII>3*pmass) then !$omp parallel do default(none) & !$omp shared(mHII,listneigh,xyzh,sigd,dt) & -!$omp shared(mH,vxyzu,Qi,hv_on_c,npartin,pmass,xi,yi,zi) & +!$omp shared(mH,vxyzu,log_Qi,hv_on_c,npartin,pmass,xi,yi,zi) & !$omp private(j,dx,dy,dz,vkx,vky,vkz,xj,yj,zj,r,taud) do k=1,npartin j = listneigh(1) @@ -288,9 +288,9 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) r = dx**2 + dy**2 + dz**2 taud = (rhoh(xyzh(4,j),pmass)/mH)*sigd*r if (taud > 1.97) taud=1.97 - vkx = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dx/r) - vky = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dy/r) - vkz = (1.+1.5*exp(-taud))*(QI/mHII)*hv_on_c*(dz/r) + vkz = (1.+1.5*exp(-taud))*((10**log_Qi)/mHII)*hv_on_c*(dz/r) + vkx = (1.+1.5*exp(-taud))*((10**log_Qi)/mHII)*hv_on_c*(dx/r) + vky = (1.+1.5*exp(-taud))*((10**log_Qi)/mHII)*hv_on_c*(dy/r) vxyzu(1,j) = vxyzu(1,j) + vkx*dt vxyzu(2,j) = vxyzu(2,j) + vky*dt vxyzu(3,j) = vxyzu(3,j) + vkz*dt diff --git a/src/main/part.F90 b/src/main/part.F90 index 9da9debbe..d54c878e5 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -205,7 +205,7 @@ module part integer, parameter :: imassenc = 18 ! mass enclosed in sink softening radius integer, parameter :: iJ2 = 19 ! 2nd gravity moment due to oblateness integer, parameter :: irstrom = 20 ! Stromgren radius of the stars (icreate_sinks == 2) - integer, parameter :: irateion = 21 ! overlapped energy between two HII regions (icreate_sinks == 2) + integer, parameter :: irateion = 21 ! Inoisation rate of the stars (log)(icreate_sinks == 2) integer, parameter :: itbirth = 22 ! birth time of the new sink integer, parameter :: ndptmass = 13 ! number of properties to conserve after a accretion phase or merge integer, allocatable :: linklist_ptmass(:) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index fbc61fffe..19de0ed9c 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -1198,7 +1198,7 @@ subroutine test_HIIregion(ntests,npass) h_acc = 0.002 xyzmh_ptmass(4,1) = -1. - xyzmh_ptmass(irateion,1) = (10.**49.)*utime ! rate_ion [s^-1] + xyzmh_ptmass(irateion,1) = 49. ! rate_ion [s^-1] nptmass = 1 nHIIsources = 1 @@ -1247,7 +1247,7 @@ subroutine test_HIIregion(ntests,npass) rho0 = totmass/totvol - Rstrom = ((3*xyzmh_ptmass(irateion,1)*mH**2)/(4*pi*ar*rho0**2))**(1./3.) + Rstrom = 10**((1./3)*(log10(((3*mH**2)/(4*pi*ar*rho0**2)))+xyzmh_ptmass(irateion,1)+log10(utime))) xyzmh_ptmass(irstrom,1) = -1. ci = sqrt(polykion) k = 0.005 From 0b3b23738e394af14c401bed58f764f05670f0ed Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 25 Jul 2024 12:38:02 +0200 Subject: [PATCH 726/814] (setup_cluster) add a relaxation option --- src/setup/setup_cluster.f90 | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index 8e10a2937..c1d1ae01a 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -37,6 +37,7 @@ module setup real :: Rsink_au,Rcloud_pc,Mcloud_msun,Temperature,mu real(kind=8) :: mass_fac,dist_fac character(len=32) :: default_cluster + logical :: relax contains @@ -102,6 +103,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, Temperature = 10.0 ! Temperature in Kelvin (required for polyK only) Rsink_au = 5. ! Sink radius [au] mu = 2.46 ! Mean molecular weight (required for polyK only) + relax = .false. + select case (icluster) case (1) ! from Bate, Bonnell & Bromm (2003) @@ -194,9 +197,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_particle_type(i,igas) enddo - call shuffleparticles(iprint,npart,xyzh,massoftype(1),rsphere=rmax,dsphere=rhozero,dmedium=0.,& - is_setup=.true.,prefix=trim(fileprefix)) - + if (relax) then + call shuffleparticles(iprint,npart,xyzh,massoftype(1),rsphere=rmax,dsphere=rhozero,dmedium=0.,& + is_setup=.true.,prefix=trim(fileprefix)) + endif !--Set velocities (from pre-made velocity cubes) write(*,"(1x,a)") 'Setting up velocity field on the particles...' vxyzu(:,:) = 0. @@ -277,6 +281,7 @@ subroutine get_input_from_prompts() call prompt('Enter the radius of the sink particles (in au)',Rsink_au) call prompt('Enter the Temperature of the cloud (used for initial sound speed)',Temperature) call prompt('Enter the mean molecular mass (used for initial sound speed)',mu) + call prompt('Do you want to relax your cloud',relax) if (maxvxyzu < 4) call prompt('Enter the EOS id (1: isothermal, 8: barotropic, 21: HII region expansion)',ieos_in) end subroutine get_input_from_prompts @@ -301,6 +306,7 @@ subroutine write_setupfile(filename) write(iunit,"(/,a)") '# options for sphere' call write_inopt(Mcloud_msun,'M_cloud','mass of cloud in solar masses',iunit) call write_inopt(Rcloud_pc,'R_cloud','radius of cloud in pc',iunit) + call write_inopt(relax, 'relax', 'relax the cloud ?', iunit) write(iunit,"(/,a)") '# options required for initial sound speed' call write_inopt(Temperature,'Temperature','Temperature',iunit) call write_inopt(mu,'mu','mean molecular mass',iunit) From 1ee547f635dbf716669dddeb127ba8ddc9256156 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 25 Jul 2024 12:07:35 +0100 Subject: [PATCH 727/814] minor changes to cooling_radapprox.f90 --- src/main/cooling_radapprox.f90 | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index e73edcdf1..b2a1e991f 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -175,7 +175,10 @@ subroutine radcool_update_energ(i,dti,npart,xyzhi,ui,dudti_sph,Tfloor) if (Teqi > 9e5) then print *,"i=",i, "dudt_sph(i)=", dudti_sph, "duradi=", dudti_rad, "Ti=", Ti, & "Tmini=", Tmini4**(1.0/4.0),du_tot,Hcomb, "r=",sqrt(ri2), "ui=", ui, & - "dudt_sph * dti=", dudti_sph*dti + "dudt_sph * dti=", dudti_sph*dti + elseif (Teqi < epsilon(Teqi)) then + print *, "Teqi=0.0", "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& + "Ti=", Ti, "poti=",poti, "rhoi=", rhoi endif call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) @@ -334,14 +337,14 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) else du_tot = dudt_sph(i) endif - ! If radiative cooling is negligible compared to hydrodynamical heating + !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 + 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 + energ(i) = ui + du_tot*dti + cycle + endif Teqi = du_tot * opaci*unit_ergg/utime ! physical units du_tot = du_tot + dudti_rad From 0f1469ef7ea899229f9269d24d1e4695e11d128b Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 26 Jul 2024 09:55:06 +0100 Subject: [PATCH 728/814] Edits to icooling = 9 --- src/main/cooling_radapprox.f90 | 60 ++++++++++++++++++++-------------- src/main/eos_stamatellos.f90 | 9 +++-- src/main/evolve.F90 | 5 --- src/main/step_leapfrog.F90 | 20 +++++++----- 4 files changed, 52 insertions(+), 42 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index b2a1e991f..dd62d3f50 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -26,7 +26,7 @@ module cooling_radapprox 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 :: init_star, radcool_update_energ_loop contains @@ -64,38 +64,39 @@ end subroutine init_star ! Do cooling calculation ! ! update energy to return evolved energy array. Called from step corrector -subroutine radcool_update_energ(i,dti,npart,xyzhi,ui,dudti_sph,Tfloor) +subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,dudti_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 - use part, only:iphase,maxphase,maxp,iamtype,ibin use timestep_ind, only:get_dt - integer,intent(in) :: i,npart - real,intent(in) :: xyzhi(:),dti,Tfloor,dudti_sph + integer,intent(in) :: i + integer(kind=1),intent(in) :: ibini + real,intent(in) :: xyzhi(:),dtsph,dudti_sph,Tfloor real,intent(inout) :: ui - real :: rhoi,coldensi,kappaBari,kappaParti,ri2 + real :: dti,rhoi,coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot real :: cs2,Om2,Hmod2 real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi - integer :: ratefile,n_uevo -! write (temp,'(E5.2)') dt - coldensi = huge(coldensi) - poti = Gpot_cool(i) - du_FLDi = duFLD(i) - if (abs(ui) < epsilon(ui)) print *, "ui zero", i - rhoi = rhoh(xyzhi(4),massoftype(igas)) - - if (isink_star > 0) then - ri2 = (xyzhi(1)-xyzmh_ptmass(1,isink_star))**2d0 & - + (xyzhi(2)-xyzmh_ptmass(2,isink_star))**2d0 & - + (xyzhi(3)-xyzmh_ptmass(3,isink_star))**2d0 - else - ri2 = xyzhi(1)**2d0 + xyzhi(2)**2d0 + xyzhi(3)**2d0 - endif + dti = get_dt(dtsph,ibini) + coldensi = huge(coldensi) + poti = Gpot_cool(i) + du_FLDi = duFLD(i) + kappaBari = 0d0 + kappaParti = 0d0 + if (abs(ui) < epsilon(ui)) print *, "ui zero", i + rhoi = rhoh(xyzhi(4),massoftype(igas)) + + if (isink_star > 0) then + ri2 = (xyzhi(1)-xyzmh_ptmass(1,isink_star))**2d0 & + + (xyzhi(2)-xyzmh_ptmass(2,isink_star))**2d0 & + + (xyzhi(3)-xyzmh_ptmass(3,isink_star))**2d0 + else + ri2 = xyzhi(1)**2d0 + xyzhi(2)**2d0 + xyzhi(3)**2d0 + endif ! get opacities & Ti for ui call getopac_opdep(ui*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,& @@ -132,6 +133,9 @@ subroutine radcool_update_energ(i,dti,npart,xyzhi,ui,dudti_sph,Tfloor) 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 + call warning("In radapprox cooling","cooling method not recognised",ival=od_method) + return end select ! Tfloor is from input parameters and is background heating @@ -151,8 +155,9 @@ subroutine radcool_update_energ(i,dti,npart,xyzhi,ui,dudti_sph,Tfloor) else du_tot = dudti_sph endif + ! If radiative cooling is negligible compared to hydrodynamical heating - ! don't use this method to update energy, just use hydro du/dt + ! don't use this method to update energy, just use hydro du/dt. Does it conserve u alright? if (abs(dudti_rad/du_tot) < dtcool_crit) then ! print *, "not cooling/heating for r=",sqrt(ri2),".", dudti_rad,& ! dudt_sph(i) @@ -161,10 +166,9 @@ subroutine radcool_update_energ(i,dti,npart,xyzhi,ui,dudti_sph,Tfloor) endif Teqi = du_tot * opaci*unit_ergg/utime ! physical units - du_tot = du_tot + dudti_rad - Teqi = Teqi/4.d0/steboltz Teqi = Teqi + Tmini4 + du_tot = du_tot + dudti_rad if (Teqi < Tmini4) then Teqi = Tmini4**(1.0/4.0) else @@ -179,6 +183,9 @@ subroutine radcool_update_energ(i,dti,npart,xyzhi,ui,dudti_sph,Tfloor) elseif (Teqi < epsilon(Teqi)) then print *, "Teqi=0.0", "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& "Ti=", Ti, "poti=",poti, "rhoi=", rhoi + elseif (Teqi < Tfloor) then + print *, "Teqi=",Teqi, "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& + "Ti=", Ti, "poti=",poti, "rhoi=", rhoi endif call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) @@ -360,7 +367,10 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) 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 + "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 call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index 5b784bb82..a6d485982 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -46,6 +46,9 @@ subroutine init_S07cool() gradP_cool(:) = 0d0 urad_FLD(:) = 0d0 duFLD(:) = 0d0 + teqi_store(:) = 0d0 + ttherm_store(:) = 0d0 + opac_store(:) = 0d0 open (unit=iunitst,file='EOSinfo.dat',status='replace') if (doFLD) then print *, "Using Forgan+ 2009 hybrid cooling method (FLD)" @@ -214,7 +217,7 @@ subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) end subroutine getopac_opdep subroutine getintenerg_opdep(Teqi, rhoi, ueqi) - use io, only:fatal + use io, only:warning real, intent(out) :: ueqi real, intent(in) :: Teqi,rhoi @@ -224,9 +227,9 @@ subroutine getintenerg_opdep(Teqi, rhoi, ueqi) real rhoi_ if (rhoi > OPTABLE(nx,1,1) .or. rhoi < OPTABLE(1,1,1)) then - call fatal('getintenerg_opdep','rhoi out of range',var='rhoi',val=rhoi) + call warning('getintenerg_opdep','rhoi out of range',var='rhoi',val=rhoi) elseif (Teqi > OPTABLE(1,ny,2) .or. Teqi < OPTABLE(1,1,2)) then - call fatal('getintenerg_opdep','Ti out of range',var='Ti',val=Teqi) + call warning('getintenerg_opdep','Ti out of range',var='Ti',val=Teqi) endif diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 9c81bbf1d..cd41228a4 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -81,8 +81,6 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) use part, only:rad,radprop use radiation_utils, only:update_radenergy use timestep, only:dtrad - use cooling, only:Tfloor - use cooling_radapprox,only:radcool_update_energ_loop #ifdef LIVE_ANALYSIS use analysis, only:do_analysis use part, only:igas @@ -291,10 +289,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) endif if (icooling == 9) then - call radcool_update_energ_loop(dt,npart,xyzh,vxyzu(4,1:npart),fxyzu(4,1:npart),Tfloor) - ! write (*,*) " ",maxval(vxyzu(4,:)),minval(vxyzu(4,:)), fxyzu(4,i) write (*,*) "Before step", maxval(vxyzu(4,:)),minval(vxyzu(4,:)) - ! write (*,*) "fxyzu(4:)=", maxval(fxyzu(4,1:npart)),minval(fxyzu(4,1:npart)) endif nsteps = nsteps + 1 ! diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 6820ba598..ae4ef96ff 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -117,7 +117,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use metric_tools, only:imet_minkowski,imetric use cons2prim, only:cons2primall use extern_gr, only:get_grforce_all - use cooling, only:ufloor,cooling_in_step + use cooling, only:ufloor,cooling_in_step,Tfloor use timing, only:increment_timer,get_timings,itimer_extf use growth, only:check_dustprop use options, only:use_porosity,icooling @@ -127,7 +127,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use eos, only:equationofstate use substepping, only:substep,substep_gr, & substep_sph_gr,substep_sph - + use cooling_radapprox, only:radcool_update_energ + integer, intent(inout) :: npart integer, intent(in) :: nactive real, intent(in) :: t,dtsph @@ -167,7 +168,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) store_itype = (maxphase==maxp .and. ntypes > 1) ialphaloc = 2 nvfloorp = 0 - print *, "L197 predictor, maxmin abs fxyzu=", maxval(abs(fxyzu(4,1:npart))),minval(abs(fxyzu(4,1:npart))) +! print *, "L197 predictor, maxmin abs fxyzu=", maxval(abs(fxyzu(4,1:npart))),minval(abs(fxyzu(4,1:npart))) !$omp parallel do default(none) & !$omp shared(npart,xyzh,vxyzu,fxyzu,iphase,hdtsph,store_itype) & !$omp shared(rad,drad,pxyzu) & @@ -236,7 +237,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif !Alison icooling, vpred is right value here for u, but shouldn't be ...? - print *, "line 234", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)),"nactive =", nactive +! print *, "line 234", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)),"nactive =", nactive !---------------------------------------------------------------------- ! substepping with external and sink particle forces, using dtextforce @@ -398,7 +399,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) rad = radpred vxyzu(4,1:npart) = vpred(4,1:npart) endif - if (icooling == 0) vxyzu(4,1:npart) = vpred(4,1:npart) + if (icooling == 9) vxyzu(4,1:npart) = vpred(4,1:npart) if (gr) vxyzu = vpred ! May need primitive variables elsewhere? if (dt_too_small) then @@ -409,7 +410,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call fatal('step','step too small: bin would exceed maximum') endif endif - print *, "line 407", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)), "nactive=", nactive +! print *, "line 407", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)), "nactive=", nactive ! ! if using super-timestepping, determine what dt will be used on the next loop ! @@ -426,7 +427,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! forces we must iterate until velocities agree. !------------------------------------------------------------------------- - print *, "line 423", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) +! print *, "line 423", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) its = 0 converged = .false. errmaxmean = 0.0 @@ -453,7 +454,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp shared(ibin,ibin_old,ibin_sts,twas,timei,use_sts,dtsph_next,ibin_wake,sts_it_n) & !$omp shared(ibin_dts,nbinmax) & !$omp private(dti,hdti) & -!$omp shared(rad,radpred,drad)& +!$omp shared(rad,radpred,drad,Tfloor)& !$omp private(i,vxi,vyi,vzi) & !$omp private(pxi,pyi,pzi,p2i) & !$omp private(erri,v2i,eni) & @@ -488,6 +489,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) + if (its == 1) call radcool_update_energ(i,ibin(i),dtsph,xyzh(:,i),vxyzu(4,i),fxyzu(4,i),Tfloor) else vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) endif @@ -703,9 +705,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif if (icooling == 9) then print *, "end of iteration", maxval(vpred(4,:)), minval(vpred(4,:)) + print *, "end of iteration", maxval(vxyzu(4,:)), minval(vxyzu(4,:)) print *, "end of iteration, dudt", maxval(fxyzu(4,1:npart)), minval(fxyzu(4,1:npart)) print *, "End of iteration, nactive=", nactive - vxyzu(4,1:npart) = vpred(4,1:npart) endif enddo iterations From 5edc12db13f6374ed87c32e2fc84833b6493c583 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 26 Jul 2024 16:47:35 +0200 Subject: [PATCH 729/814] (subgroups) first tests on binary subgroups with SD method --- build/Makefile | 4 +- src/main/energies.F90 | 4 +- src/main/evolve.F90 | 4 +- src/main/initial.F90 | 7 +- src/main/part.F90 | 5 +- src/main/ptmass.F90 | 17 +-- src/main/step_leapfrog.F90 | 4 +- src/main/subgroup.f90 | 197 ++++++++++++++++++-------------- src/main/substepping.F90 | 36 +++--- src/main/utils_kepler.f90 | 12 ++ src/setup/setup_starcluster.f90 | 8 +- 11 files changed, 175 insertions(+), 123 deletions(-) diff --git a/build/Makefile b/build/Makefile index bafa65db1..380c7dfb2 100644 --- a/build/Makefile +++ b/build/Makefile @@ -525,7 +525,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ utils_system.f90 utils_mathfunc.f90 part.F90 ${DOMAIN} boundary.f90 boundary_dynamic.f90 utils_timing.f90 mpi_balance.F90 \ setup_params.f90 timestep.f90 utils_dumpfiles.f90 utils_indtimesteps.F90 \ utils_sort.f90 utils_supertimestep.F90 utils_tables.f90 utils_gravwave.f90 \ - utils_sphNG.f90 utils_vectors.f90 utils_datafiles.f90 datafiles.f90 \ + utils_sphNG.f90 utils_vectors.f90 utils_subgroup.f90 utils_kepler.f90 utils_datafiles.f90 datafiles.f90 \ gitinfo.f90 ${SRCFASTMATH} random.f90 ${SRCEOS} cullendehnen.f90 ${SRCNIMHD} ${SRCGR} \ checkoptions.F90 viscosity.f90 damping.f90 options.f90 cons2primsolver.f90 radiation_utils.f90 cons2prim.f90 \ centreofmass.f90 ${SRCPOT} checkconserved.f90 \ @@ -534,7 +534,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ partinject.F90 utils_inject.f90 dust_formation.f90 ptmass_radiation.f90 ptmass_heating.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ - ${SRCKROME} memory.f90 H2regions.f90 utils_subgroup.f90 utils_kepler.f90 subgroup.f90 ptmass.F90 \ + ${SRCKROME} memory.f90 H2regions.f90 subgroup.f90 ptmass.F90 \ ${SRCREADWRITE_DUMPS} quitdump.f90\ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ diff --git a/src/main/energies.F90 b/src/main/energies.F90 index eec6576a3..8ab3c8a80 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -72,7 +72,7 @@ subroutine compute_energies(t) isdead_or_accreted,epot_sinksink,imacc,ispinx,ispiny,& ispinz,mhd,gravity,poten,dustfrac,eos_vars,itemp,igasP,ics,& nden_nimhd,eta_nimhd,iion,ndustsmall,graindens,grainsize,& - iamdust,ndusttypes,rad,iradxi,gtgrad,group_info,n_group + iamdust,ndusttypes,rad,iradxi,gtgrad,group_info,bin_info,n_group use part, only:pxyzu,fxyzu,fext use gravwaveutils, only:calculate_strain,calc_gravitwaves use centreofmass, only:get_centreofmass_accel @@ -644,7 +644,7 @@ subroutine compute_energies(t) erad = reduceall_mpi('+',erad) if (nptmass > 1) then if (use_regnbody) then - call get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + call get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) endif epot = epot + epot_sinksink endif diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 20cede37b..449161d23 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -91,7 +91,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,gravity,iboundary, & fxyz_ptmass_sinksink,ntot,poten,ndustsmall,accrete_particles_outside_sphere,& linklist_ptmass,isionised,dsdt_ptmass,isdead_or_accreted - use part, only:n_group,n_ingroup,n_sing,group_info,nmatrix + use part, only:n_group,n_ingroup,n_sing,group_info,bin_info,nmatrix use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & set_integration_precision,ptmass_create_stars,use_regnbody,ptmass_create_seeds,& @@ -318,7 +318,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! Need to recompute the force when sink or stars are created if (ipart_rhomax /= 0 .or. ipart_createseeds /= 0 .or. ipart_createstars /= 0) then if (use_regnbody) then - call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,nmatrix) 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,group_info=group_info) else diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 7b8f26032..b774c8f32 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -131,7 +131,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& nden_nimhd,dustevol,rhoh,gradh, & Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx, & - n_group,n_ingroup,n_sing,nmatrix,group_info,isionised + n_group,n_ingroup,n_sing,nmatrix,group_info,bin_info,isionised use part, only:pxyzu,dens,metrics,rad,radprop,drad,ithick use densityforce, only:densityiterate use linklist, only:set_linklist @@ -508,9 +508,10 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) ! compute initial sink-sink forces and get timestep if (use_regnbody) then call init_subgroup - call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + 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) + 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) diff --git a/src/main/part.F90 b/src/main/part.F90 index 02fdbf785..ad30404c9 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -310,8 +310,9 @@ module part integer, parameter :: isemi = 1 ! semi major axis integer, parameter :: iecc = 2 ! eccentricity integer, parameter :: iapo = 3 ! apocenter - integer, parameter :: ipert = 4 ! perturbation - integer, parameter :: ikap = 5 ! kappa slow down + integer, parameter :: iorb = 4 ! orbital period + integer, parameter :: ipert = 5 ! perturbation + integer, parameter :: ikap = 6 ! kappa slow down ! needed for group identification and sorting diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index f7bdc41d3..01d6c152a 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -111,7 +111,7 @@ module ptmass real, parameter :: dtfacphi2fsi = dtfacphifsi**2 real :: dtfacphi = dtfacphifsi - real :: dtfacphi2 = dtfacphifsi + real :: dtfacphi2 = dtfacphi2fsi ! parameters to control output regarding sink particles @@ -354,7 +354,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real :: fterm,pterm,potensoft0,dsx,dsy,dsz real :: J2i,rsinki,shati(3) real :: J2j,rsinkj,shatj(3) - integer :: k,l,i,j,gidi,gidj + integer :: k,l,i,j,gidi,gidj,compi logical :: extrap,subsys dtsinksink = huge(dtsinksink) @@ -392,14 +392,15 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !--compute N^2 forces on point mass particles due to each other ! !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info,subsys) & + !$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 private(i,j,xi,yi,zi,pmassi,pmassj,hacci,haccj) & - !$omp private(gidi,gidj) & + !$omp private(gidi,gidj,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,pert_out) & + !$omp private(fextx,fexty,fextz,phiext) & !$omp private(q2i,qi,psoft,fsoft) & !$omp private(fterm,pterm,J2i,J2j,shati,shatj,rsinki,rsinkj) & !$omp reduction(min:dtsinksink) & @@ -411,6 +412,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin gidi = group_info(igid,k) ! id of the group to identify which ptmasses are in the same group compi = group_info(icomp,k) ! id of the companion if it exists else + compi = 0 + pert_out = 0. i = k endif if (extrap) then @@ -535,8 +538,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin endif endif endif - if (subsys .and. compi /= i) then - pert_out = pert_out + f1 + if (subsys) 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) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index a017c9dea..04ddc2167 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -105,7 +105,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use mpiutils, only:reduceall_mpi use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & dsdt_ptmass,fsink_old,ibin_wake,dptmass,linklist_ptmass - use part, only:n_group,n_ingroup,n_sing,gtgrad,group_info,nmatrix + use part, only:n_group,n_ingroup,n_sing,gtgrad,group_info,bin_info,nmatrix use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax @@ -251,7 +251,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) 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, & - group_info,nmatrix,n_group,n_ingroup,n_sing,isionised) + group_info,bin_info,nmatrix,n_group,n_ingroup,n_sing,isionised) else call substep_sph(dtsph,npart,xyzh,vxyzu) endif diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index e70ca5e2c..7d46491d4 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -36,7 +36,7 @@ module subgroup ! !-- parameter for Slow Down method ! - real, parameter :: kref = 1e-6 + real, parameter :: kref = 1.e-6 private contains @@ -64,8 +64,9 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm use io, only:id,master,iverbose,iprint use timing, only:get_timings,increment_timer,itimer_sg_id integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),bin_info(:,:) - integer, intent(inout) :: group_info(3,nptmass) + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(inout) :: bin_info(:,:) + integer, intent(inout) :: group_info(4,nptmass) integer, intent(inout) :: n_group,n_ingroup,n_sing integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) real, optional, intent(in) :: dtext @@ -89,7 +90,7 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm endif call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) - if (n_group > 0) call find_binaries(xyzmh_ptmass,group_info,bin_info,n_group) + if (n_group > 0) call find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) call get_timings(t2,tcpu2) call increment_timer(itimer_sg_id,t2-t1,tcpu2-tcpu1) @@ -106,14 +107,15 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm end subroutine group_identify subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) - use part, only: igarg,igcum,icomp,isemi,iecc,iapo + use part, only: igarg,igcum,icomp,isemi,iecc,iapo,iorb real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, intent(inout) :: group_info(:,:),bin_info(:,:) + integer, intent(inout) :: group_info(:,:) + real, intent(inout) :: bin_info(:,:) integer, intent(in) :: n_group integer, allocatable :: r2min_id(:) integer :: i,j,k,l,np,ns,start_id,end_id,gsize - real :: akl,ekl,apokl + real :: akl,ekl,apokl,Tkl ! need to be zeroed for safety reasons bin_info(:,:) = 0. @@ -124,7 +126,6 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) gsize = (end_id - start_id) + 1 if (gsize > 2) then allocate(r2min_id(gsize)) - allocate(r2min(gsize)) call get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) do j=start_id,end_id np = (j-start_id) + 1 @@ -138,13 +139,15 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) ! !-- Compute and store main orbital parameters needed for SDAR method ! - call get_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,k,l) + call get_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,Tkl,k,l) bin_info(isemi,k) = akl bin_info(isemi,l) = akl bin_info(iecc,k) = ekl bin_info(iecc,l) = ekl bin_info(iapo,k) = apokl bin_info(iapo,l) = apokl + bin_info(iorb,k) = Tkl + bin_info(iorb,l) = Tkl else ! No matches... Only a single group_info(icomp,k) = k bin_info(:,k) = 0. @@ -160,26 +163,29 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) ! !-- Compute and store main orbital parameters needed for SDAR method ! - call get_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,k,l) + call get_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,Tkl,k,l) bin_info(isemi,k) = akl bin_info(isemi,l) = akl bin_info(iecc,k) = ekl bin_info(iecc,l) = ekl bin_info(iapo,k) = apokl bin_info(iapo,l) = apokl + bin_info(iorb,k) = Tkl + bin_info(iorb,l) = Tkl endif enddo end subroutine find_binaries -subroutine get_r2min(xyzmh_ptmass,group_info,r2min_id,n_group) +subroutine get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) use part, only : igarg,igcum real , intent(in) :: xyzmh_ptmass(:,:) integer, intent(in) :: group_info(:,:) integer, intent(out) :: r2min_id(:) - integer, intent(in) :: n_group + integer, intent(in) :: start_id,end_id integer :: i,j,k,l,n real :: dr(3),r2,r2min + do i=start_id,end_id n = (i-start_id)+1 j = group_info(igarg,i) @@ -201,10 +207,10 @@ subroutine get_r2min(xyzmh_ptmass,group_info,r2min_id,n_group) end subroutine get_r2min -subroutine get_orbparams(xyzmh_ptmass,vxyz_ptmass,aij,eij,apoij,i,j) - use utils_kepler, only: extract_e,extract_a +subroutine get_orbparams(xyzmh_ptmass,vxyz_ptmass,aij,eij,apoij,Tij,i,j) + use utils_kepler, only: extract_e,extract_a,extract_T real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - real, intent(out) :: aij,eij,apoij + real, intent(out) :: aij,eij,apoij,Tij integer, intent(in) :: i,j real :: dv(3),dr(3),mu,r,v2 @@ -222,6 +228,8 @@ subroutine get_orbparams(xyzmh_ptmass,vxyz_ptmass,aij,eij,apoij,i,j) call extract_e(dr(1),dr(2),dr(3),dv(1),dv(2),dv(3),mu,r,eij) + call extract_T(mu,aij,Tij) + apoij = aij*(1+eij) end subroutine get_orbparams @@ -231,7 +239,7 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) use part, only : igarg,igcum,igid,icomp integer, intent(in) :: nptmass integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) - integer, intent(inout) :: group_info(3,nptmass) + integer, intent(inout) :: group_info(4,nptmass) integer, intent(inout) :: n_group,n_ingroup,n_sing integer :: i,ncg logical :: visited(nptmass) @@ -256,11 +264,11 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) end subroutine form_group subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) - use part, only : igarg,igid + use part, only : igarg,igid,icomp integer, intent(in) :: nptmass,iroot integer, intent(out) :: ncg integer(kind=1), intent(in) :: nmatrix(nptmass,nptmass) - integer, intent(inout) :: group_info(3,nptmass) + integer, intent(inout) :: group_info(4,nptmass) integer, intent(inout) :: n_ingroup logical, intent(inout) :: visited(nptmass) integer :: stack(nptmass) @@ -373,7 +381,7 @@ end subroutine matrix_construction ! !--------------------------------------------- -subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,bin_info & +subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,bin_info, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) use part, only:igarg,igcum use io, only:id,master @@ -422,7 +430,7 @@ end subroutine evolve_groups subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,& bin_info,group_info,fxyz_ptmass,gtgrad) - use part, only: igarg,ikap + use part, only: igarg,ikap,iorb real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & fxyz_ptmass(:,:),gtgrad(:,:),bin_info(:,:) integer, intent(in) :: group_info(:,:) @@ -444,7 +452,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ismultiple = gsize > 2 if (ismultiple) then - call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,W,start_id,end_id,ds_init=ds_init) + call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,W,start_id,end_id,ds_init=ds_init) else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) @@ -453,7 +461,9 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ! call get_kappa_bin(xyzmh_ptmass,bin_info,prim,sec) kappa1 = 1./bin_info(ikap,prim) - call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,W,kappa1,prim,sec,ds_init=ds_init) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,W,kappa1,prim,sec,& + ds_init=ds_init,Tij=bin_info(iorb,prim)) + print*,ds_init endif @@ -467,7 +477,6 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ds(:) = ds_init switch = 1 - !print*,ds_init, tcoord,tnext,W do while (.true.) @@ -482,7 +491,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ do i=1,ck_size call drift_TTL (tcoord,W,ds(switch)*cks(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) time_table(i) = tcoord - call kick_TTL (ds(switch)*dks(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,start_id,end_id) + call kick_TTL (ds(switch)*dks(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,start_id,end_id) enddo else prim = group_info(igarg,start_id) @@ -544,7 +553,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ endif enddo - !print*,step_count_int,tcoord,tnext,ds_init + print*,step_count_int,step_count_tsyn,tcoord,tnext,ds_init deallocate(bdata) @@ -666,9 +675,10 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,s_id,e_id) end subroutine drift_TTL -subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,s_id,e_id) +subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,s_id,e_id) use part, only: igarg - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(inout) :: gtgrad(:,:),bin_info(:,:) integer,intent(in) :: group_info(:,:) real, intent(in) :: h real, intent(inout) :: W @@ -676,7 +686,7 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,s real :: om,dw,dtk integer :: i,k - call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id) + call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id) dtk = h/om @@ -713,7 +723,7 @@ subroutine oneStep_bin(tcoord,W,ds,kappa1,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,g real, intent(inout) :: tcoord,W integer, intent(in) :: i,j integer :: k - real :: dtd,dtd_sd,dtk,dvel1(3),dvel2(3),dw,om + real :: dtd,dtk,dvel1(3),dvel2(3),dw,om real :: vcom(3),mtot,m1,m2 m1 = xyzmh_ptmass(4,i) @@ -725,23 +735,22 @@ subroutine oneStep_bin(tcoord,W,ds,kappa1,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,g tcoord = tcoord + dtd time_table(k) = tcoord - if (kappa1 < 1.0) then - dtd_sd = dtd*kappa1 - vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,j))/mtot - 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 - else - dtd_sd = dtd - endif + vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,j))/mtot + 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 - xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd_sd*vxyz_ptmass(1,i) - xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd_sd*vxyz_ptmass(2,i) - xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd_sd*vxyz_ptmass(3,i) - xyzmh_ptmass(1,j) = xyzmh_ptmass(1,j) + dtd_sd*vxyz_ptmass(1,j) - xyzmh_ptmass(2,j) = xyzmh_ptmass(2,j) + dtd_sd*vxyz_ptmass(2,j) - xyzmh_ptmass(3,j) = xyzmh_ptmass(3,j) + dtd_sd*vxyz_ptmass(3,j) - if(kappa1 < 1.0) call correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,i,j) + if(kappa1 < 1.0) then + call correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,dtd,i,j) + else + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd*vxyz_ptmass(3,i) + xyzmh_ptmass(1,j) = xyzmh_ptmass(1,j) + dtd*vxyz_ptmass(1,j) + xyzmh_ptmass(2,j) = xyzmh_ptmass(2,j) + dtd*vxyz_ptmass(2,j) + xyzmh_ptmass(3,j) = xyzmh_ptmass(3,j) + dtd*vxyz_ptmass(3,j) + + endif call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j) @@ -776,6 +785,7 @@ subroutine oneStep_bin(tcoord,W,ds,kappa1,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,g vxyz_ptmass(1,j) = vxyz_ptmass(1,j) + dvel2(1) vxyz_ptmass(2,j) = vxyz_ptmass(2,j) + dvel2(2) vxyz_ptmass(3,j) = vxyz_ptmass(3,j) + dvel2(3) + enddo @@ -786,43 +796,42 @@ subroutine correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,dtd,i,j) real, intent(in) :: vxyz_ptmass(:,:),vcom(3) real, intent(in) :: kappa1,dtd integer, intent(in) :: i,j - real :: vrel(3),kappa11 + real :: vrel(3) - kappa11 = kappa1 - 1. vrel(1) = vxyz_ptmass(1,i) - vcom(1) vrel(2) = vxyz_ptmass(2,i) - vcom(2) vrel(3) = vxyz_ptmass(3,i) - vcom(3) - xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + vrel(1)*kappa11 - xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + vrel(2)*kappa11 - xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + vrel(3)*kappa11 + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vrel(1)*kappa1 + vcom(1)*dtd + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd*vrel(2)*kappa1 + vcom(2)*dtd + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd*vrel(3)*kappa1 + vcom(3)*dtd vrel(1) = vxyz_ptmass(1,j) - vcom(1) vrel(2) = vxyz_ptmass(2,j) - vcom(2) vrel(3) = vxyz_ptmass(3,j) - vcom(3) - xyzmh_ptmass(1,j) = xyzmh_ptmass(1,j) + vrel(1)*kappa11 - xyzmh_ptmass(2,j) = xyzmh_ptmass(2,j) + vrel(2)*kappa11 - xyzmh_ptmass(3,j) = xyzmh_ptmass(3,j) + vrel(3)*kappa11 + xyzmh_ptmass(1,j) = xyzmh_ptmass(1,j) + dtd*vrel(1)*kappa1 + vcom(1)*dtd + xyzmh_ptmass(2,j) = xyzmh_ptmass(2,j) + dtd*vrel(2)*kappa1 + vcom(2)*dtd + xyzmh_ptmass(3,j) = xyzmh_ptmass(3,j) + dtd*vrel(3)*kappa1 + vcom(3)*dtd end subroutine correct_com_drift -subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id,potonly,ds_init) - use part, only: igarg +subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id,potonly,ds_init) + use part, only: igarg,iorb,ikap,icomp real, intent(in) :: xyzmh_ptmass(:,:) - real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) + real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:),bin_info(:,:) integer, intent(in) :: group_info(:,:) real, intent(out) :: om integer, intent(in) :: s_id,e_id logical, optional, intent(in) :: potonly real, optional, intent(out) :: ds_init - real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3,dt_init - real :: gravf,gtki,gravfi(3),gtgradi(3),f2 - integer :: i,j,k,l + real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3,dt_init,om_init + real :: gravf,gtk,gtki,gravfi(3),gtgradi(3),Ti,kappa1i + integer :: i,j,k,l,compi logical :: init om = 0. dt_init = huge(om) @@ -831,13 +840,16 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id if (present(ds_init)) then init = .true. ds_init = 0. + om_init = 0. else init = .false. endif do k=s_id,e_id - i = group_info(igarg,k) + i = group_info(igarg,k) + compi = group_info(icomp,i) + kappa1i = 1./bin_info(ikap,i) gravfi(1) = 0. gravfi(2) = 0. gravfi(3) = 0. @@ -858,10 +870,20 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id r2 = dx**2+dy**2+dz**2 ddr = 1./sqrt(r2) mj = xyzmh_ptmass(4,j) - gtki = gtki + mj*ddr + if (j == compi) then + gtk = mj*ddr*kappa1i + else + gtk = mj*ddr + endif + gtki = gtki + gtk + if (init) om_init = om_init + mj*ddr if (.not.present(potonly)) then ddr3 = ddr*ddr*ddr - gravf = mj*(1./ddr3) + if (j == compi) then + gravf = mj*(1./ddr3)*kappa1i + else + gravf = mj*(1./ddr3) + endif gravfi(1) = gravfi(1) + dx*gravf gravfi(2) = gravfi(2) + dy*gravf gravfi(3) = gravfi(3) + dz*gravf @@ -881,20 +903,20 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id endif if (init) then - f2 = gravfi(1)**2+gravfi(2)**2+gravfi(3)**2 - if (f2 > 0.) then - dt_init = min(dt_init,0.00002*sqrt(abs(gtki)/f2)) + if(compi /=i) then + Ti = bin_info(iorb,i) + dt_init = min(dt_init,0.002*Ti) endif endif om = om + gtki*mi enddo om = om*0.5 - if (init) ds_init = dt_init*om + if (init) ds_init = dt_init*om_init*0.5 end subroutine get_force_TTL -subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,potonly,ds_init) +subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,potonly,ds_init,Tij) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: i,j @@ -902,8 +924,9 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,poton real, intent(out) :: om logical, optional, intent(in) :: potonly real, optional, intent(out) :: ds_init - real :: dx,dy,dz,r2,ddr,ddr3,mi,mj,dsi,dsj - real :: gravfi,gravfj,gtki,gtkj,fxi,fyi,fzi,fxj,fyj,fzj,f2i,f2j + real, optional, intent(in) :: Tij + real :: dx,dy,dz,r2,ddr,ddr3,mi,mj + real :: gravfi,gravfj,gtki,gtkj,fxi,fyi,fzi,fxj,fyj,fzj mi = xyzmh_ptmass(4,i) mj = xyzmh_ptmass(4,j) @@ -953,22 +976,20 @@ 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 - f2i = fxi**2+fyi**2+fzi**2 - f2j = fxj**2+fyj**2+fzj**2 - dsi = sqrt(abs(gtki)/f2i) - dsj = sqrt(abs(gtkj)/f2j) - ds_init = 0.000125*min(dsi,dsj)*om + ds_init = 0.002*Tij*om/kappa1 endif end subroutine get_force_TTL_bin subroutine get_kappa_bin(xyzmh_ptmass,bin_info,i,j) - use part, only:ipert,iapo,ikap + use part, only:ipert,iapo,ikap,isemi,iecc real, intent(inout) :: bin_info(:,:) real, intent(in) :: xyzmh_ptmass(:,:) integer, intent(in) :: i,j - real :: kappa,m1,m2,pert,mu,rapo + real :: kappa,m1,m2,pert,mu,rapo,rapo3 + + m1 = xyzmh_ptmass(4,i) m2 = xyzmh_ptmass(4,j) @@ -976,39 +997,47 @@ subroutine get_kappa_bin(xyzmh_ptmass,bin_info,i,j) pert = bin_info(ipert,i) rapo = bin_info(iapo,i) rapo3 = rapo*rapo*rapo - kappa = kref*mu*(rapo3*pert) - bin_info(ikap,i) = kappa - bin_info(ikap,j) = kappa + kappa = kref/((rapo3/mu)*pert) + print*,xyzmh_ptmass(2,i),pert,kappa,rapo,bin_info(isemi,i),bin_info(iecc,i) + if (kappa > 1.) then + bin_info(ikap,i) = kappa + bin_info(ikap,j) = kappa + else + bin_info(ikap,i) = 1. + bin_info(ikap,j) = 1. + endif end subroutine get_kappa_bin -subroutine get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) - use part, only: igarg,igcum +subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + use part, only: igarg,igcum,ikap use io, only: id,master integer, intent(in) :: n_group real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) + real, intent(inout) :: bin_info(:,:) integer, intent(in) :: group_info(:,:) real, intent(inout) :: epot_sinksink integer :: i,start_id,end_id,gsize,prim,sec - real :: phitot,phigroup + real :: phitot,phigroup,kappa1 phitot = 0. if (n_group>0) then if (id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,fxyz_ptmass)& - !$omp shared(group_info,gtgrad,n_group)& - !$omp private(i,start_id,end_id,gsize,prim,sec,phigroup)& + !$omp shared(group_info,gtgrad,n_group,bin_info)& + !$omp private(i,start_id,end_id,gsize,prim,sec,phigroup,kappa1)& !$omp reduction(+:phitot) do i=1,n_group start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) gsize = (end_id - start_id) + 1 if (gsize>2) then - call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,phigroup,start_id,end_id,.true.) + call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,phigroup,start_id,end_id,.true.) else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) + kappa1 = 1./bin_info(ikap,prim) call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phigroup,kappa1,prim,sec,.true.) endif phitot = phitot + phigroup diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 504e7b9d3..eec7793a2 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -428,7 +428,7 @@ end subroutine substep_sph subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & linklist_ptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info, & - nmatrix,n_group,n_ingroup,n_sing,isionised) + bin_info,nmatrix,n_group,n_ingroup,n_sing,isionised) use io, only:iverbose,id,master,iprint,fatal use options, only:iexternalforce use part, only:fxyz_ptmass_sinksink,ndptmass @@ -443,7 +443,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, intent(inout) :: dptmass(ndptmass,nptmass),fsink_old(:,:),gtgrad(:,:) + real, intent(inout) :: dptmass(ndptmass,nptmass),fsink_old(:,:),gtgrad(:,:),bin_info(:,:) integer(kind=1), intent(in) :: nbinmax integer , intent(inout) :: linklist_ptmass(:) integer(kind=1), intent(inout) :: ibin_wake(:),nmatrix(nptmass,nptmass) @@ -488,12 +488,14 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass) if (use_regnbody) then - call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call 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,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,group_info=group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,& + group_info=group_info,bin_info=bin_info) else call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) @@ -507,18 +509,19 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & 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, & - fsink_old,group_info) + fsink_old,group_info=group_info,bin_info=bin_info) call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass) - call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + 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 drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass, & - group_info=group_info,isionised=isionised) + group_info=group_info,bin_info=bin_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,& @@ -539,10 +542,10 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & fxyz_ptmass_sinksink,accreted) if (use_regnbody) then - call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,nmatrix) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass, & - group_info=group_info) + group_info=group_info,bin_info=bin_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) @@ -836,7 +839,7 @@ 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,fsink_old,group_info,& - isionised) + bin_info,isionised) use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & @@ -860,8 +863,9 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real, intent(inout) :: dtextforce real, intent(in) :: timei,dki,dt logical, intent(in) :: extf_vdep_flag - real, optional, intent(inout) :: fsink_old(4,nptmass) + real, optional, intent(inout) :: fsink_old(4,nptmass) integer, optional, intent(in) :: group_info(:,:) + real, optional, intent(inout) :: bin_info(:,:) logical, optional, intent(in) :: isionised(:) integer :: merge_ij(nptmass) integer :: merge_n @@ -912,12 +916,12 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (wsub) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & - extrapfac,fsink_old,group_info) + 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) + extrapfac,fsink_old,group_info,bin_info) endif else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& @@ -933,11 +937,13 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, else if (wsub) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) + 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) + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & + group_info=group_info,bin_info=bin_info) if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif fxyz_ptmass_sinksink(:,1:nptmass) = fxyz_ptmass (:,1:nptmass) diff --git a/src/main/utils_kepler.f90 b/src/main/utils_kepler.f90 index deb5de94b..778b83b3d 100644 --- a/src/main/utils_kepler.f90 +++ b/src/main/utils_kepler.f90 @@ -19,6 +19,10 @@ module utils_kepler use physcon,only: pi implicit none + public :: Espec,extract_a,extract_a_dot,extract_e + public :: extract_T,extract_ea,extract_kep_elmt + + private contains subroutine Espec(v2,r,mu,B) real, intent(in) :: v2,r,mu @@ -35,6 +39,14 @@ subroutine extract_a(r,mu,v2,aij) end subroutine extract_a +subroutine extract_T(mu,aij,Tij) + real, intent(in) :: mu,aij + real, intent(out) ::Tij + + Tij = 2*pi*sqrt(abs(aij)**3/mu) !! absolute value of a to take into account hyperbolic encounter + +end subroutine extract_T + subroutine extract_a_dot(r2,r,mu,v2,v,acc,adot) real, intent(in) :: r2,r,mu,v2,v,acc real, intent(out) :: adot diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index 429558843..6c1657254 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -42,7 +42,7 @@ module setup !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas - use units, only:set_units,umass !,udist + use units, only:set_units,umass,unit_velocity !,udist use physcon, only:solarm,kpc,pi,au,years,pc use io, only:fatal,iprint,master use eos, only:gmw @@ -82,9 +82,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, dtmax = 1.e-5 tmax = 0.001 use_fourthorder = .true. - use_regnbody = .false. + use_regnbody = .true. m_gas = 1.e-4 - ntot = 2**21 + ntot = 0 ! ! read setup parameters from the .setup file ! if file does not exist, then ask for user input @@ -122,7 +122,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, vcom = vcom/mtot print*,"xcom",xcom - print*,"vcom",vcom + print*,"vcom",vcom/1e5*unit_velocity do i=1,nptmass xyzmh_ptmass(1:3,i) = xyzmh_ptmass(1:3,i) - xcom(1:3) From 7d24ccbdd4a8611dcb32388511d924212d4dbe9f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Sat, 27 Jul 2024 00:17:15 +0200 Subject: [PATCH 730/814] (subgroups) first iteration of the slow down with multiples --- src/main/subgroup.f90 | 111 +++++++++++++++++++++++++++++++++++++----- 1 file changed, 98 insertions(+), 13 deletions(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 7d46491d4..97377a62a 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -401,6 +401,8 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,bin_info, & call get_timings(t1,tcpu1) + call find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) + if (id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& @@ -452,6 +454,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ismultiple = gsize > 2 if (ismultiple) then + call update_kappa(xyzmh_ptmass,group_info,bin_info,s_id,e_id) call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,W,start_id,end_id,ds_init=ds_init) else prim = group_info(igarg,start_id) @@ -489,7 +492,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ W_old = W if (ismultiple) then do i=1,ck_size - call drift_TTL (tcoord,W,ds(switch)*cks(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) + call drift_TTL (tcoord,W,ds(switch)*cks(i),xyzmh_ptmass,vxyz_ptmass,group_info,gsize,start_id,end_id) time_table(i) = tcoord call kick_TTL (ds(switch)*dks(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,start_id,end_id) enddo @@ -652,15 +655,19 @@ subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tco end subroutine restore_state -subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,s_id,e_id) - use part, only: igarg - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer,intent(in) :: group_info(:,:) - real, intent(inout) :: tcoord - real, intent(in) :: h,W - integer,intent(in) :: s_id,e_id - integer :: k,i - real :: dtd +subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,gsize,s_id,e_id) + use part, only: igarg,icomp,ikap + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(in) :: group_info(:,:) + real, intent(inout) :: tcoord + real, intent(in) :: h,W + integer, intent(in) :: s_id,e_id,gsize + integer, allocatable :: binstack(:) + integer :: k,i,compi + real :: dtd,vcom(3),m1,m2,mtot + + allocate(binstack((gsize/4)+1)) + binstack = 0 dtd = h/W @@ -668,11 +675,28 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,s_id,e_id) do k=s_id,e_id i = group_info(igarg,k) - xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) - xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd*vxyz_ptmass(2,i) - xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd*vxyz_ptmass(3,i) + compi = group_info(icomp,i) + if (compi/=i) then ! It's a binary. identify companion and drift binary. + m1 = xyzmh_ptmass(4,i) + m2 = xyzmh_ptmass(4,compi) + mtot = m1+m2 + kappa1i = bin_info(ikap,i) + if (any(binstack == i)) cycle! If already treated i will be in binstack + vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,compi))/mtot + vcom(2) = (m1*vxyz_ptmass(2,i)+m2*vxyz_ptmass(2,compi))/mtot + vcom(3) = (m1*vxyz_ptmass(3,i)+m2*vxyz_ptmass(3,compi))/mtot + + call correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1i,dtd,i,compi) + + else + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd*vxyz_ptmass(3,i) + endif enddo + deallocate(binstack) + end subroutine drift_TTL subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,s_id,e_id) @@ -686,6 +710,11 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass real :: om,dw,dtk integer :: i,k + + if (h==0.) then + call find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) + call update_kappa(xyzmh_ptmass,group_info,bin_info,s_id,e_id) + endif call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id) @@ -916,6 +945,62 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, end subroutine get_force_TTL +subroutine update_kappa(xyzmh_ptmass,group_info,bin_info,s_id,e_id) + use part, only:iarg,icomp,ipert,ikap + real , intent(in) :: xyzmh_ptmass(:,:) + real , intent(inout) :: bin_info(:,:) + integer, intent(in) :: group_info(:,:) + integer, intent(in) :: s_id,e_id + integer, allocatable :: binstack(:) + integer :: k,l,i,j,compi + real :: pouti,r2,dx,dy,dz,ddr,ddr3,xi,yi,zi,m1,m2,mu + real :: kappai,rapo,rapo3 + + + do k=s_id,e_id + i = group_info(igarg,k) + compi = group_info(icomp,i) + if (compi == i) cycle + if (any(binstack == i)) cycle + pouti = bin_info(ipert,i) + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + m1 = xyzmh_ptmass(4,i) + m2 = xyzmh_ptmass(4,j) + do l=s_id,e_id + if (k == l) cycle + j = group_info(igarg,l) + if (j == compi) + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + r2 = dx**2+dy**2+dz**2 + ddr = 1./sqrt(r2) + ddr3 = ddr*ddr*ddr + mj = xyzmh_ptmass(4,j) + pouti = pouti +mj*ddr3 + enddo + + mu = (m1*m2)/(m1+m2) + rapo = bin_info(iapo,i) + rapo3 = rapo*rapo*rapo + kappai = kref/((rapo3/mu)*pouti) + + if (kappai>1.) then + bin_info(ikap,i) = kappai + bin_info(ikap,compi) = kappai + else + bin_info(ikap,i) = 1. + bin_info(ikap,compi) = 1. + endif + + + + enddo + +end subroutine update_kappa + subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,potonly,ds_init,Tij) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) From 0ed83b10e72e0d3e43d2665d16305c53ec7bf59d Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Jul 2024 09:49:17 +0200 Subject: [PATCH 731/814] (subgroup) update internal binaries in multiples --- src/main/subgroup.f90 | 78 +++++++++++++++++++++++++------------------ 1 file changed, 46 insertions(+), 32 deletions(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 97377a62a..61abf03d6 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -115,7 +115,6 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) integer, intent(in) :: n_group integer, allocatable :: r2min_id(:) integer :: i,j,k,l,np,ns,start_id,end_id,gsize - real :: akl,ekl,apokl,Tkl ! need to be zeroed for safety reasons bin_info(:,:) = 0. @@ -125,36 +124,8 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) end_id = group_info(igcum,i+1) gsize = (end_id - start_id) + 1 if (gsize > 2) then - allocate(r2min_id(gsize)) - call get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) - do j=start_id,end_id - np = (j-start_id) + 1 - k = group_info(igarg,j) - if (group_info(icomp,k) > 0) then - ns = r2min_id(np) - if (r2min_id(ns) == np) then ! We found a binary into a subgroup : tag as binary component and compute parameters - l = group_info(igarg,ns+start_id) - group_info(icomp,k) = l - group_info(icomp,l) = k - ! - !-- Compute and store main orbital parameters needed for SDAR method - ! - call get_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,Tkl,k,l) - bin_info(isemi,k) = akl - bin_info(isemi,l) = akl - bin_info(iecc,k) = ekl - bin_info(iecc,l) = ekl - bin_info(iapo,k) = apokl - bin_info(iapo,l) = apokl - bin_info(iorb,k) = Tkl - bin_info(iorb,l) = Tkl - else ! No matches... Only a single - group_info(icomp,k) = k - bin_info(:,k) = 0. - endif - endif - enddo - deallocate(r2min_id) + call binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,& + gsize,start_id,end_id) else k = group_info(igarg,start_id) l = group_info(igarg,end_id) @@ -177,6 +148,48 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) end subroutine find_binaries +subroutine binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsize,start_id,end_id) + use part, only: igarg,icomp,isemi,iecc,iapo,iorb + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(inout) :: group_info(:,:) + real, intent(inout) :: bin_info(:,:) + integer, intent(in) :: start_id, end_id,gsize + integer, allocatable :: r2min_id + real :: akl,ekl,apokl,Tkl + integer :: np,ns,j,k,l + allocate(r2min_id(gsize)) + call get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) + do j=start_id,end_id + np = (j-start_id) + 1 + k = group_info(igarg,j) + if (group_info(icomp,k) > 0) then + ns = r2min_id(np) + if (r2min_id(ns) == np) then ! We found a binary into a subgroup : tag as binary component and compute parameters + l = group_info(igarg,ns+start_id) + group_info(icomp,k) = l + group_info(icomp,l) = k + ! + !-- Compute and store main orbital parameters needed for SDAR method + ! + call get_orbparams(xyzmh_ptmass,vxyz_ptmass,akl,ekl,apokl,Tkl,k,l) + bin_info(isemi,k) = akl + bin_info(isemi,l) = akl + bin_info(iecc,k) = ekl + bin_info(iecc,l) = ekl + bin_info(iapo,k) = apokl + bin_info(iapo,l) = apokl + bin_info(iorb,k) = Tkl + bin_info(iorb,l) = Tkl + else ! No matches... Only a single + group_info(icomp,k) = k + bin_info(:,k) = 0. + endif + endif + enddo + deallocate(r2min_id) + +end subroutine binaries_in_multiples + subroutine get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) use part, only : igarg,igcum real , intent(in) :: xyzmh_ptmass(:,:) @@ -712,7 +725,8 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass if (h==0.) then - call find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) + call binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,& + (e_id-s_id+1),s_id,e_id) call update_kappa(xyzmh_ptmass,group_info,bin_info,s_id,e_id) endif call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id) From a7072bfb70230392cf2954c40483595940297b2f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Jul 2024 10:04:30 +0200 Subject: [PATCH 732/814] (subgroup) fix compilation errors and warnings --- src/main/subgroup.f90 | 95 ++++++++++++++++++++++--------------------- 1 file changed, 48 insertions(+), 47 deletions(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 61abf03d6..5ebaa56ce 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -113,8 +113,8 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) integer, intent(inout) :: group_info(:,:) real, intent(inout) :: bin_info(:,:) integer, intent(in) :: n_group - integer, allocatable :: r2min_id(:) - integer :: i,j,k,l,np,ns,start_id,end_id,gsize + integer :: i,k,l,start_id,end_id,gsize + real :: akl,ekl,apokl,Tkl ! need to be zeroed for safety reasons bin_info(:,:) = 0. @@ -154,7 +154,7 @@ subroutine binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gs integer, intent(inout) :: group_info(:,:) real, intent(inout) :: bin_info(:,:) integer, intent(in) :: start_id, end_id,gsize - integer, allocatable :: r2min_id + integer, allocatable :: r2min_id(:) real :: akl,ekl,apokl,Tkl integer :: np,ns,j,k,l allocate(r2min_id(gsize)) @@ -403,7 +403,7 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,bin_info, & integer, intent(in) :: n_group,nptmass real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) real, intent(inout) :: bin_info(:,:) - integer, intent(in) :: group_info(:,:) + integer, intent(inout) :: group_info(:,:) real, intent(in) :: tnext,time integer :: i,start_id,end_id,gsize real(kind=4) :: t1,t2,tcpu1,tcpu2 @@ -446,12 +446,12 @@ end subroutine evolve_groups subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,& bin_info,group_info,fxyz_ptmass,gtgrad) use part, only: igarg,ikap,iorb - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & - fxyz_ptmass(:,:),gtgrad(:,:),bin_info(:,:) - integer, intent(in) :: group_info(:,:) - integer, intent(in) :: start_id,end_id,gsize - real, intent(in) :: tnext,time - real, allocatable :: bdata(:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & + fxyz_ptmass(:,:),gtgrad(:,:),bin_info(:,:) + integer, intent(inout) :: group_info(:,:) + integer, intent(in) :: start_id,end_id,gsize + real, intent(in) :: tnext,time + real, allocatable :: bdata(:) real :: ds(2) real :: time_table(ck_size) integer :: switch @@ -467,7 +467,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ismultiple = gsize > 2 if (ismultiple) then - call update_kappa(xyzmh_ptmass,group_info,bin_info,s_id,e_id) + call update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,start_id,end_id) call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,W,start_id,end_id,ds_init=ds_init) else prim = group_info(igarg,start_id) @@ -505,7 +505,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ W_old = W if (ismultiple) then do i=1,ck_size - call drift_TTL (tcoord,W,ds(switch)*cks(i),xyzmh_ptmass,vxyz_ptmass,group_info,gsize,start_id,end_id) + call drift_TTL (tcoord,W,ds(switch)*cks(i),xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsize,start_id,end_id) time_table(i) = tcoord call kick_TTL (ds(switch)*dks(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,start_id,end_id) enddo @@ -577,8 +577,8 @@ end subroutine integrate_to_time subroutine regularstepfactor(fac_in,fac_out) - real, intent(in) :: fac_in - real, intent(out):: fac_out + real, intent(in) :: fac_in + real, intent(out) :: fac_out fac_out = 1.0 if (fac_in<1) then do while (fac_out>fac_in) @@ -622,10 +622,10 @@ end subroutine new_ds_sync_sup subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bdata) use part, only: igarg - real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer,intent(in) :: group_info(:,:) - real, intent(out) ::bdata(:) - integer,intent(in) :: start_id,end_id + real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(in) :: group_info(:,:) + real, intent(out) ::bdata(:) + integer, intent(in) :: start_id,end_id integer :: i,j,k j=0 do k=start_id,end_id @@ -644,12 +644,12 @@ end subroutine backup_data subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) use part, only: igarg - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer,intent(in) :: group_info(:,:) - real, intent(out) :: tcoord,W - real, intent(in) :: t_old,W_old - real, intent(in) :: bdata(:) - integer, intent(in) :: start_id,end_id + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(in) :: group_info(:,:) + real, intent(out) :: tcoord,W + real, intent(in) :: t_old,W_old + real, intent(in) :: bdata(:) + integer, intent(in) :: start_id,end_id integer :: k,i,j j = 0 do k=start_id,end_id @@ -668,16 +668,16 @@ subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tco end subroutine restore_state -subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,gsize,s_id,e_id) +subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsize,s_id,e_id) use part, only: igarg,icomp,ikap - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),bin_info(:,:) integer, intent(in) :: group_info(:,:) real, intent(inout) :: tcoord real, intent(in) :: h,W integer, intent(in) :: s_id,e_id,gsize integer, allocatable :: binstack(:) integer :: k,i,compi - real :: dtd,vcom(3),m1,m2,mtot + real :: dtd,vcom(3),m1,m2,mtot,kappa1i allocate(binstack((gsize/4)+1)) binstack = 0 @@ -693,7 +693,7 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,gsize,s_id,e m1 = xyzmh_ptmass(4,i) m2 = xyzmh_ptmass(4,compi) mtot = m1+m2 - kappa1i = bin_info(ikap,i) + kappa1i = 1./bin_info(ikap,i) if (any(binstack == i)) cycle! If already treated i will be in binstack vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,compi))/mtot vcom(2) = (m1*vxyz_ptmass(2,i)+m2*vxyz_ptmass(2,compi))/mtot @@ -714,20 +714,21 @@ end subroutine drift_TTL subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,s_id,e_id) use part, only: igarg - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) - real, intent(inout) :: gtgrad(:,:),bin_info(:,:) - integer,intent(in) :: group_info(:,:) - real, intent(in) :: h - real, intent(inout) :: W - integer,intent(in) :: s_id,e_id + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(inout) :: gtgrad(:,:),bin_info(:,:) + integer, intent(inout) :: group_info(:,:) + real, intent(in) :: h + real, intent(inout) :: W + integer, intent(in) :: s_id,e_id real :: om,dw,dtk - integer :: i,k + integer :: i,k,gsize + gsize = (e_id-s_id+1) if (h==0.) then call binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,& - (e_id-s_id+1),s_id,e_id) - call update_kappa(xyzmh_ptmass,group_info,bin_info,s_id,e_id) + gsize,s_id,e_id) + call update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) endif call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id) @@ -959,21 +960,22 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, end subroutine get_force_TTL -subroutine update_kappa(xyzmh_ptmass,group_info,bin_info,s_id,e_id) - use part, only:iarg,icomp,ipert,ikap +subroutine update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) + use part, only:igarg,icomp,ipert,ikap,iapo real , intent(in) :: xyzmh_ptmass(:,:) real , intent(inout) :: bin_info(:,:) integer, intent(in) :: group_info(:,:) - integer, intent(in) :: s_id,e_id + integer, intent(in) :: s_id,e_id,gsize integer, allocatable :: binstack(:) integer :: k,l,i,j,compi - real :: pouti,r2,dx,dy,dz,ddr,ddr3,xi,yi,zi,m1,m2,mu + real :: pouti,r2,dx,dy,dz,ddr,ddr3,xi,yi,zi,m1,m2,mj,mu real :: kappai,rapo,rapo3 + allocate(binstack(gsize)) do k=s_id,e_id i = group_info(igarg,k) - compi = group_info(icomp,i) + compi = group_info(icomp,i) if (compi == i) cycle if (any(binstack == i)) cycle pouti = bin_info(ipert,i) @@ -981,11 +983,11 @@ subroutine update_kappa(xyzmh_ptmass,group_info,bin_info,s_id,e_id) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) m1 = xyzmh_ptmass(4,i) - m2 = xyzmh_ptmass(4,j) + m2 = xyzmh_ptmass(4,compi) do l=s_id,e_id if (k == l) cycle j = group_info(igarg,l) - if (j == compi) + if (j == compi) cycle dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) @@ -1008,11 +1010,10 @@ subroutine update_kappa(xyzmh_ptmass,group_info,bin_info,s_id,e_id) bin_info(ikap,i) = 1. bin_info(ikap,compi) = 1. endif - - - enddo + deallocate(binstack) + end subroutine update_kappa subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,potonly,ds_init,Tij) From edcf53fa8c616cb2169ec477ba3ce3fca4ca9f73 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Jul 2024 10:10:20 +0200 Subject: [PATCH 733/814] (HIIRegion) update comment header --- src/main/H2regions.f90 | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 6b8af754d..8d81b4a12 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -8,7 +8,7 @@ module HIIRegion ! ! HIIRegion ! -! :References: None +! :References: Fujii et al. (2021), Hopkins et al. (2012) ! ! :Owner: Yrisch ! @@ -17,15 +17,10 @@ module HIIRegion ! :Dependencies: dim, eos, infile_utils, io, linklist, part, physcon, ! sortutils, timing, units ! +! contains routines to model HII region expansion due to ionization and radiation pressure.. +! routine originally made by Hopkins et al. (2012),reused by Fujii et al. (2021) +! and adapted in Phantom by Yann Bernard - ! - ! - ! contains routine for Stromgren radius calculation and Radiative pressure velocity kick - ! routine originally made by Hopkins et al. (2012) Fujii et al. (2021) - ! adapted in Phantom by Yann BERNARD - ! reference : Fujii et al. 2021 SIRIUS Project Paper III - ! - ! implicit none public :: update_ionrates,update_ionrate, HII_feedback,initialize_H2R,read_options_H2R,write_options_H2R From d6a6b20039bdb3fc98656ac195995cb61c242587 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Jul 2024 11:14:25 +0200 Subject: [PATCH 734/814] (subgroup) fix wrong companion id in group_info --- src/main/subgroup.f90 | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 5ebaa56ce..d25abcf65 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -129,8 +129,8 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) else k = group_info(igarg,start_id) l = group_info(igarg,end_id) - group_info(icomp,l) = k - group_info(icomp,k) = l + group_info(icomp,end_id) = k + group_info(icomp,start_id) = l ! !-- Compute and store main orbital parameters needed for SDAR method ! @@ -162,12 +162,12 @@ subroutine binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gs do j=start_id,end_id np = (j-start_id) + 1 k = group_info(igarg,j) - if (group_info(icomp,k) > 0) then + if (group_info(icomp,j) > 0) then ns = r2min_id(np) if (r2min_id(ns) == np) then ! We found a binary into a subgroup : tag as binary component and compute parameters l = group_info(igarg,ns+start_id) - group_info(icomp,k) = l - group_info(icomp,l) = k + group_info(icomp,np) = l + group_info(icomp,ns+start_id) = k ! !-- Compute and store main orbital parameters needed for SDAR method ! @@ -414,7 +414,7 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,bin_info, & call get_timings(t1,tcpu1) - call find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) + !call find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) if (id==master) then !$omp parallel do default(none)& @@ -479,7 +479,6 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ kappa1 = 1./bin_info(ikap,prim) call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,W,kappa1,prim,sec,& ds_init=ds_init,Tij=bin_info(iorb,prim)) - print*,ds_init endif @@ -688,7 +687,7 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsi do k=s_id,e_id i = group_info(igarg,k) - compi = group_info(icomp,i) + compi = group_info(icomp,k) if (compi/=i) then ! It's a binary. identify companion and drift binary. m1 = xyzmh_ptmass(4,i) m2 = xyzmh_ptmass(4,compi) @@ -892,7 +891,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, do k=s_id,e_id i = group_info(igarg,k) - compi = group_info(icomp,i) + compi = group_info(icomp,k) kappa1i = 1./bin_info(ikap,i) gravfi(1) = 0. gravfi(2) = 0. @@ -975,7 +974,7 @@ subroutine update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) do k=s_id,e_id i = group_info(igarg,k) - compi = group_info(icomp,i) + compi = group_info(icomp,k) if (compi == i) cycle if (any(binstack == i)) cycle pouti = bin_info(ipert,i) From 0c2831d1c8b233426b502f7f27361a2986c56cfb Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Jul 2024 13:44:26 +0200 Subject: [PATCH 735/814] fix few comments from daniel --- src/main/evolve.F90 | 10 +++--- src/main/writeheader.F90 | 2 +- src/setup/set_orbit.f90 | 75 ---------------------------------------- 3 files changed, 6 insertions(+), 81 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 20cede37b..e7ea0fbdf 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -41,7 +41,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) 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 + use dim, only:maxvxyzu,mhd,periodic,idumpfile,ind_timesteps use fileutils, only:getnextfilename use options, only:nfulldump,twallmax,nmaxdumps,rhofinal1,iexternalforce,rkill use readwrite_infile, only:write_infile @@ -306,10 +306,10 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (iH2R > 0 .and. id==master) then istepHII = 1 -#ifdef IND_TIMESTEPS - istepHII = 2**nbinmax/HIIuprate - if (istepHII==0) istepHII = 1 -#endif + if(ind_timestep) then + istepHII = 2**nbinmax/HIIuprate + if (istepHII==0) istepHII = 1 + endif if (mod(istepfrac,istepHII)==0 .or. istepfrac==1 .or. (icreate_sinks == 2 .and. ipart_createstars /= 0)) then call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) endif diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index 1852d1b7c..a7b5ff448 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -182,7 +182,7 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) if (drag_implicit) then write(iprint,"(1x,a)") 'Two-fluid dust implicit scheme is ON' else - write(iprint,"(1x,a)") 'Two-fluid dust explicit scheme is OFF' + write(iprint,"(1x,a)") 'Two-fluid dust explicit scheme is ON' endif endif if (use_dustgrowth) write(iprint,"(1x,a)") 'Dust growth is ON' diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index 8a1308afd..38f3348b3 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -27,81 +27,6 @@ module setorbit ! :Runtime parameters: None ! ! :Dependencies: infile_utils, physcon, setbinary, setflyby, units -! - -! While Campbell elements can be used for unbound orbits, they require -! specifying the true anomaly at the start of the simulation. This is -! not always easy to determine, so the flyby option is provided as an -! alternative. There one specifies the initial separation instead, however -! the choice of angles is more restricted -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: infile_utils, physcon, setbinary, setflyby, units -! - -! While Campbell elements can be used for unbound orbits, they require -! specifying the true anomaly at the start of the simulation. This is -! not always easy to determine, so the flyby option is provided as an -! alternative. There one specifies the initial separation instead, however -! the choice of angles is more restricted -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: infile_utils, physcon, setbinary, setflyby, units -! - -! While Campbell elements can be used for unbound orbits, they require -! specifying the true anomaly at the start of the simulation. This is -! not always easy to determine, so the flyby option is provided as an -! alternative. There one specifies the initial separation instead, however -! the choice of angles is more restricted -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: infile_utils, physcon, setbinary, setflyby, units -! - -! While Campbell elements can be used for unbound orbits, they require -! specifying the true anomaly at the start of the simulation. This is -! not always easy to determine, so the flyby option is provided as an -! alternative. There one specifies the initial separation instead, however -! the choice of angles is more restricted -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: infile_utils, physcon, setbinary, setflyby, units -! - -! While Campbell elements can be used for unbound orbits, they require -! specifying the true anomaly at the start of the simulation. This is -! not always easy to determine, so the flyby option is provided as an -! alternative. There one specifies the initial separation instead, however -! the choice of angles is more restricted -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: physcon ! implicit none public :: set_orbit From 160171a7258a3c2ee93fc7134d223b1051efebd3 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Jul 2024 13:52:43 +0200 Subject: [PATCH 736/814] stupid typo... --- src/main/evolve.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index e7ea0fbdf..a5bf47b1d 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -306,7 +306,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (iH2R > 0 .and. id==master) then istepHII = 1 - if(ind_timestep) then + if(ind_timesteps) then istepHII = 2**nbinmax/HIIuprate if (istepHII==0) istepHII = 1 endif From 018c251156f0b4cd07d1385d185a913e2ba84613 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 29 Jul 2024 13:47:29 +0100 Subject: [PATCH 737/814] Upstream changes added --- src/main/evolve.F90 | 17 +- src/main/inject_sim.f90 | 370 ++ src/main/ionization.f90 | 10 +- src/main/kdtree.F90 | 18 +- src/main/kernel_WendlandC2.f90 | 18 +- src/main/kernel_WendlandC4.f90 | 37 +- src/main/kernel_WendlandC6.f90 | 21 + src/main/kernel_cubic.f90 | 20 + src/main/kernel_quartic.f90 | 25 + src/main/kernel_quintic.f90 | 29 + src/main/metric_minkowski.f90 | 5 +- src/main/mpi_dens.F90 | 3 + src/main/mpi_derivs.F90 | 17 + src/main/mpi_memory.f90 | 317 -- src/main/mpi_tree.F90 | 3 + src/main/mpi_utils.F90 | 59 + src/main/nicil_supplement.F90 | 236 - src/main/options.f90 | 11 +- src/main/partinject.F90 | 4 +- src/main/porosity.f90 | 2 +- src/main/ptmass.F90 | 47 +- src/setup/readwrite_kepler.f90 | 6 +- src/setup/readwrite_mesa.f90 | 2 +- src/setup/set_binary.f90 | 13 +- src/setup/set_hierarchical.f90 | 327 +- src/setup/set_hierarchical_utils.f90 | 10 +- src/setup/set_orbit.f90 | 15 + src/setup/set_star.f90 | 218 +- src/setup/set_unifdis.f90 | 1 - src/setup/setup_binary.f90 | 144 +- src/setup/setup_chinchen.f90 | 5 +- src/setup/setup_cluster.f90 | 6 +- src/setup/setup_galdisc.f90 | 20 +- src/setup/setup_grdisc.F90 | 107 +- src/setup/setup_grtde.f90 | 18 +- src/utils/analysis_CoM.f90 | 2 +- src/utils/analysis_angmom.f90 | 4 +- src/utils/analysis_angmomvec.f90 | 4 +- src/utils/analysis_average_orb_en.f90 | 4 +- src/utils/analysis_bzrms.f90 | 6 +- src/utils/analysis_clumpfind.F90 | 22 +- src/utils/analysis_clumpfindWB23.F90 | 2 +- .../analysis_collidingcloudevolution.f90 | 2 +- src/utils/analysis_common_envelope.f90 | 4494 +++++++++++++++++ 44 files changed, 5725 insertions(+), 976 deletions(-) create mode 100644 src/main/inject_sim.f90 delete mode 100644 src/main/mpi_memory.f90 delete mode 100644 src/main/nicil_supplement.F90 create mode 100644 src/utils/analysis_common_envelope.f90 diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index cd41228a4..92c22f776 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -77,7 +77,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) use partinject, only:update_injected_particles #endif use dim, only:do_radiation - use options, only:exchange_radiation_energy,implicit_radiation,icooling + use options, only:exchange_radiation_energy,implicit_radiation use part, only:rad,radprop use radiation_utils, only:update_radenergy use timestep, only:dtrad @@ -89,8 +89,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) #endif 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, & - iphase,iactive + fxyz_ptmass_sinksink,ntot,poten,ndustsmall,accrete_particles_outside_sphere use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & set_integration_precision @@ -138,9 +137,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) logical :: use_global_dt integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold character(len=120) :: dumpfile_orig - integer :: imax - real :: umax - + tprint = 0. nsteps = 0 nsteplast = 0 @@ -287,10 +284,6 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (do_radiation .and. exchange_radiation_energy .and. .not.implicit_radiation) then call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) endif - - if (icooling == 9) then - write (*,*) "Before step", maxval(vxyzu(4,:)),minval(vxyzu(4,:)) - endif nsteps = nsteps + 1 ! !--evolve data for one timestep @@ -309,10 +302,6 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) endif - if (icooling == 9) then - write (*,*) "after step",maxval(vxyzu(4,1:npart)),minval(vxyzu(4,1:npart)) - endif - dtlast = dt !--timings for step call diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 new file mode 100644 index 000000000..a305b8dc8 --- /dev/null +++ b/src/main/inject_sim.f90 @@ -0,0 +1,370 @@ +!--------------------------------------------------------------------------! +! 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 inject +! +! Handles particle injections from another simulations (for TDE outflow only currently) +! +! :References: None +! +! :Owner: Fitz) Hu +! +! :Runtime parameters: +! - r_inject : *radius to inject tde outflow (in cm)* +! +! :Dependencies: dump_utils, fileutils, infile_utils, io, part, partinject, +! readwrite_dumps_common, readwrite_dumps_fortran, timestep, units +! + use fileutils, only:getnextfilename + + implicit none + character(len=*), parameter, public :: inject_type = 'sim' + + public :: init_inject,inject_particles,write_options_inject,read_options_inject, & + set_default_options_inject,update_injected_par + private :: read_injected_par +! +!--runtime settings for this module +! + +! global variables + + character(len=120) :: start_dump,final_dump,pre_dump,next_dump + integer :: npart_sim + real :: r_inject,r_inject_cgs=-1,next_time!,e_inject + real, allocatable :: xyzh_pre(:,:),xyzh_next(:,:),vxyzu_next(:,:),pxyzu_next(:,:) + logical, allocatable :: injected(:) + + character(len=*), parameter :: label = 'inject_tdeoutflow' + character(len=*), parameter :: injected_filename = 'injected_par' + +contains + +!----------------------------------------------------------------------- +!+ +! Initialize -- find the start dump to inject +!+ +!----------------------------------------------------------------------- +subroutine init_inject(ierr) + use io, only:error + use timestep, only:time + use units, only:udist + + integer, intent(out) :: ierr + integer, parameter :: max_niter=5000, idisk=23 + integer :: niter + + ! + !--find the tde dump at the right time + ! + next_time = -1. + next_dump = getnextfilename(start_dump) + call get_dump_time_npart(trim(next_dump),next_time,ierr,npart_out=npart_sim) + ierr = 0 + niter = 0 + + do while (next_time < time .and. niter < max_niter) + niter = niter + 1 + pre_dump = next_dump + next_dump = getnextfilename(next_dump) + call get_dump_time_npart(trim(next_dump),next_time,ierr) + if (ierr /= 0) then + ierr = 0 + call error('inject','error reading time and npart from '//trim(next_dump)) + cycle + endif + enddo + start_dump = next_dump + + write(*,'(a,1x,es10.2)') ' Start read sims and inject particle from '//trim(next_dump)//' at t =',next_time + + r_inject = r_inject_cgs/udist ! to code unit + allocate(xyzh_pre(4,npart_sim),xyzh_next(4,npart_sim),vxyzu_next(4,npart_sim),pxyzu_next(4,npart_sim),injected(npart_sim)) + xyzh_pre = 0. + injected = .false. + call read_injected_par() + !e_inject = -1./r_inject + +end subroutine init_inject + +!----------------------------------------------------------------------- +!+ +! Main routine handling wind injection. +!+ +!----------------------------------------------------------------------- +subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + npart,npart_old,npartoftype,dtinject) + real, intent(in) :: time, dtlast + real, intent(inout) :: xyzh(:,:), vxyzu(:,:), xyzmh_ptmass(:,:), vxyz_ptmass(:,:) + integer, intent(inout) :: npart,npart_old + integer, intent(inout) :: npartoftype(:) + real, intent(out) :: dtinject + integer :: ierr + real :: tfac + + ! + !--inject particles only if time has reached + ! + tfac = 1. + if (time >= next_time) then + ! read next dump + call read_dump(next_dump,xyzh_next,ierr,vxyzu_dump=vxyzu_next,pxyzu_dump=pxyzu_next) + + npart_old = npart + call inject_required_part_tde(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next,pxyzu_next) + + ! copy to pre for next injection use + pre_dump = next_dump + xyzh_pre = xyzh_next + + call find_next_dump(next_dump,next_time,ierr) + start_dump = next_dump + + write(*,'(i10,1x,a27,1x,a)') npart-npart_old, 'particles are injected from', trim(pre_dump) + + if (pre_dump == final_dump) then + write(*,'(a)') ' Reach the final dumpfile. Stop injecting ...' + next_time = huge(0.) + endif + + tfac = 1.d-40 ! set a tiny timestep so the code has time to adjust for timestep + endif + + ! update time to next inject + dtinject = tfac*(next_time - time) +end subroutine inject_particles + +subroutine read_dump(filename,xyzh_dump,ierr,vxyzu_dump,pxyzu_dump) + use dump_utils, only: read_array_from_file + character(len=*), intent(in) :: filename + real, intent(out) :: xyzh_dump(:,:) + integer, intent(out) :: ierr + real, intent(out), optional :: vxyzu_dump(:,:),pxyzu_dump(:,:) + integer, parameter :: iunit = 578 + real(kind=4) :: h(npart_sim) + + ! + !--read xyzh + ! + call read_array_from_file(iunit,filename,'x',xyzh_dump(1,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'y',xyzh_dump(2,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'z',xyzh_dump(3,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'h',h,ierr,iprint_in=.false.) + xyzh_dump(4,:) = h + + ! + !--read vxyzu + ! + if (present(vxyzu_dump)) then + call read_array_from_file(iunit,filename,'vx',vxyzu_dump(1,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'vy',vxyzu_dump(2,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'vz',vxyzu_dump(3,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'u',vxyzu_dump(4,:),ierr,iprint_in=.false.) + endif + + ! + !--read vxyzu + ! + if (present(pxyzu_dump)) then + call read_array_from_file(iunit,filename,'px',pxyzu_dump(1,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'py',pxyzu_dump(2,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'pz',pxyzu_dump(3,:),ierr,iprint_in=.false.) + call read_array_from_file(iunit,filename,'entropy',pxyzu_dump(4,:),ierr,iprint_in=.false.) + endif + +end subroutine read_dump + +subroutine get_dump_time_npart(filename,time,ierr,npart_out) + use io, only:iprint,id,nprocs + use dump_utils, only:dump_h,open_dumpfile_r,read_header,free_header + use part, only:maxtypes + use readwrite_dumps_fortran, only:unfill_header + use readwrite_dumps_common, only:get_options_from_fileid + + character(len=*), intent(in) :: filename + real, intent(out) :: time + integer, intent(out) :: ierr + integer, intent(out), optional :: npart_out + integer, parameter :: idisk=389 + character(len=120) :: fileid + logical :: tagged,phantomdump,smalldump,use_dustfrac + type(dump_h) :: hdr + integer(kind=8) :: nparttot + integer :: nblocks,npartoftype(maxtypes),npart + real :: hfactfile,alphafile + + call open_dumpfile_r(idisk,filename,fileid,ierr) + call get_options_from_fileid(fileid,tagged,phantomdump,smalldump,use_dustfrac,ierr) + call read_header(idisk,hdr,ierr,tagged=tagged) + call unfill_header(hdr,phantomdump,tagged,nparttot, & + nblocks,npart,npartoftype, & + time,hfactfile,alphafile,iprint,id,nprocs,ierr) + call free_header(hdr,ierr) + close(idisk) + + if (present(npart_out)) npart_out = npart + +end subroutine get_dump_time_npart + +subroutine find_next_dump(next_dump,next_time,ierr) + character(len=*), intent(inout) :: next_dump + real, intent(out) :: next_time + integer, intent(out) :: ierr + + next_dump = getnextfilename(next_dump) + call get_dump_time_npart(next_dump,next_time,ierr) + +end subroutine find_next_dump + +subroutine inject_required_part_tde(npart,npartoftype,xyzh,vxyzu,xyzh_pre,xyzh_next,vxyzu_next,pxyzu_next) + use part, only:igas,pxyzu,isdead_or_accreted + use partinject, only:add_or_update_particle + integer, intent(inout) :: npart, npartoftype(:) + real, intent(inout) :: xyzh(:,:), vxyzu(:,:) + real, intent(in) :: xyzh_pre(:,:), xyzh_next(:,:), vxyzu_next(:,:), pxyzu_next(:,:) + integer :: i,partid + real :: r_next,r_pre,vr_next!,e_next + + ! + !--check all the particles + ! + do i=1,npart_sim + if (.not. isdead_or_accreted(xyzh_next(4,i)) .and. .not. injected(i)) then + r_next = sqrt(dot_product(xyzh_next(1:3,i),xyzh_next(1:3,i))) + r_pre = sqrt(dot_product(xyzh_pre(1:3,i),xyzh_pre(1:3,i))) + vr_next = (dot_product(xyzh_next(1:3,i),vxyzu_next(1:3,i)))/r_next + !e_next = 0.5*vr_next**2 - 1./r_next + + if (r_next > r_inject .and. r_pre < r_inject .and. vr_next > 0.) then! .and. e_next > e_inject) then + ! inject particle by copy the data into position + partid = npart+1 + call add_or_update_particle(igas,xyzh_next(1:3,i),vxyzu_next(1:3,i),xyzh_next(4,i), & + vxyzu_next(4,i),partid,npart,npartoftype,xyzh,vxyzu) + pxyzu(:,partid) = pxyzu_next(:,i) + injected(i) = .true. + endif + endif + enddo + +end subroutine inject_required_part_tde + +subroutine read_injected_par() + use io, only:fatal,warning + integer, parameter :: iunit=242 + logical :: iexist + integer :: nread,i + + inquire(file=trim(injected_filename),exist=iexist) + + if (iexist) then + open(iunit,file=trim(injected_filename),status='old') + read(iunit,*) nread + + ! check if npart in file is the same as npart_sim + if (nread /= npart_sim) call fatal('inject_sim','npart in '//trim(injected_filename)// & + ' does not match npart_sim') + + do i=1,nread + read(iunit,*) injected(i) + enddo + close(iunit) + else + call warning('inject_sim',trim(injected_filename)//' not found, assume no particles are injected') + injected = .false. + endif + +end subroutine + +subroutine update_injected_par() + use io, only:error + integer, parameter :: iunit=284 + logical :: iexist + integer :: i + + if (allocated(injected)) then + inquire(file=trim(injected_filename),exist=iexist) + if (iexist) then + open(iunit,file=trim(injected_filename),status='replace') + else + open(iunit,file=trim(injected_filename),status='new') + endif + + write(iunit,*) npart_sim + do i=1,npart_sim + write(iunit,*) injected(i) + enddo + close(iunit) + endif +end subroutine + +!----------------------------------------------------------------------- +!+ +! Writes input options to the input file +!+ +!----------------------------------------------------------------------- +subroutine write_options_inject(iunit) + use infile_utils, only: write_inopt + integer, intent(in) :: iunit + character(len=10), parameter :: start_dump_default = 'dump_00000', & + final_dump_default = 'dump_02000' + real, parameter :: r_inject_default = 5.e14 + + ! write something meaningful in infile + if (r_inject_cgs <= 0.) then + start_dump = start_dump_default + r_inject_cgs = r_inject_default + final_dump = final_dump_default + endif + + write(iunit,"(/,a)") '# options controlling particle injection' + call write_inopt("'"//trim(start_dump)//"'",'start_dump', & + 'dumpfile to start for injection (with relative path if in other direc)',iunit) + call write_inopt(r_inject_cgs,'r_inject','radius to inject tde outflow (in cm)',iunit) + call write_inopt("'"//trim(final_dump)//"'",'final_dump', & + 'stop injection after this dump (with relative path if in other direc)',iunit) + +end subroutine write_options_inject + +!----------------------------------------------------------------------- +!+ +! Reads input options from the input file. +!+ +!----------------------------------------------------------------------- +subroutine read_options_inject(name,valstring,imatch,igotall,ierr) + use io, only:fatal + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer,intent(out) :: ierr + character(len=30), parameter :: label = 'read_options_inject' + integer, save :: ngot + + imatch = .true. + igotall = .false. + select case(trim(name)) + case('start_dump') + read(valstring,*,iostat=ierr) start_dump + ngot = ngot + 1 + case('r_inject') + read(valstring,*,iostat=ierr) r_inject_cgs + ngot = ngot + 1 + if (r_inject_cgs < 0.) call fatal(label,'invalid setting for r_inject (<0)') + case('final_dump') + read(valstring,*,iostat=ierr) final_dump + ngot = ngot + 1 + case default + imatch = .false. + end select + + igotall = (ngot >= 3) + +end subroutine read_options_inject + +subroutine set_default_options_inject(flag) + integer, optional, intent(in) :: flag + +end subroutine set_default_options_inject + +end module inject diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index 032bc9ad6..02691af62 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -14,7 +14,8 @@ module ionization_mod ! ! :Runtime parameters: None ! -! :Dependencies: eos_idealplusrad, io, part, physcon, units, vectorutils +! :Dependencies: dim, eos_idealplusrad, io, part, physcon, units, +! vectorutils ! implicit none @@ -338,13 +339,15 @@ end subroutine get_erec_components ! gas particle. Inputs and outputs in code units !+ !---------------------------------------------------------------- -subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,ethi) - use part, only:rhoh +subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,ethi,radprop) + use dim, only:do_radiation + use part, only:rhoh,iradxi use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp use physcon, only:radconst,Rg use units, only:unit_density,unit_pressure,unit_ergg,unit_pressure integer, intent(in) :: ieos real, intent(in) :: particlemass,presi,tempi,xyzh(4),vxyzu(4) + real, intent(in), optional :: radprop(:) real, intent(out) :: ethi real :: hi,densi_cgs,mui @@ -357,6 +360,7 @@ subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,ethi) ethi = particlemass * ethi / unit_ergg case default ! assuming internal energy = thermal energy ethi = particlemass * vxyzu(4) + if (do_radiation) ethi = ethi + particlemass*radprop(iradxi) end select end subroutine calc_thermal_energy diff --git a/src/main/kdtree.F90 b/src/main/kdtree.F90 index 9b70a7f1f..e9a0c9e9f 100644 --- a/src/main/kdtree.F90 +++ b/src/main/kdtree.F90 @@ -30,8 +30,6 @@ module kdtree integer, public, allocatable :: inoderange(:,:) integer, public, allocatable :: inodeparts(:) type(kdnode), allocatable :: refinementnode(:) - integer, allocatable :: list(:) - !$omp threadprivate(list) ! !--tree parameters @@ -81,9 +79,6 @@ subroutine allocate_kdtree call allocate_array('inoderange', inoderange, 2, ncellsmax+1) call allocate_array('inodeparts', inodeparts, maxp) if (mpi) call allocate_array('refinementnode', refinementnode, ncellsmax+1) - !$omp parallel - call allocate_array('list', list, maxp) - !$omp end parallel end subroutine allocate_kdtree @@ -93,10 +88,6 @@ subroutine deallocate_kdtree if (allocated(inodeparts)) deallocate(inodeparts) if (mpi .and. allocated(refinementnode)) deallocate(refinementnode) - !$omp parallel - if (allocated(list)) deallocate(list) - !$omp end parallel - end subroutine deallocate_kdtree @@ -206,7 +197,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, list, .false.) + ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, .false.) if (wassplit) then ! add children to back of queue if (istack+2 > istacksize) call fatal('maketree',& @@ -256,7 +247,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, list, .false.) + ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, .false.) if (wassplit) then ! add children to top of stack if (istack+2 > istacksize) call fatal('maketree',& @@ -465,7 +456,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, list, & + ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, & global_build) use dim, only:maxtypes,mpi use part, only:massoftype,igas,iamtype,maxphase,maxp,npartoftype @@ -484,7 +475,6 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, integer, intent(inout) :: maxlevel, minlevel real, intent(in) :: xyzh(:,:) logical, intent(out) :: wassplit - integer, intent(out) :: list(:) ! not actually sent out, but to avoid repeated memory allocation/deallocation logical, intent(in) :: global_build real :: xyzcofm(ndim) @@ -1552,7 +1542,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, list, & + ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, & .true.) if (.not.wassplit) then diff --git a/src/main/kernel_WendlandC2.f90 b/src/main/kernel_WendlandC2.f90 index 882b2d4a4..4dd74aa6f 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, q6 + real :: q4 if (q < 2.) then q4 = q2*q2 @@ -104,6 +104,22 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + + if (q < 2.) then + gsoft = 3.*q2*q*(35.*q2*q - 240.*q2 + 560.*q - 448.)/256. + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations diff --git a/src/main/kernel_WendlandC4.f90 b/src/main/kernel_WendlandC4.f90 index ea1202d65..6a0ded877 100644 --- a/src/main/kernel_WendlandC4.f90 +++ b/src/main/kernel_WendlandC4.f90 @@ -37,8 +37,9 @@ pure subroutine get_kernel(q2,q,wkern,grkern) !--Wendland 2/3D C^4 if (q < 2.) then - wkern = (-q/2. + 1.)**6*(35.*q2/12. + 3.*q + 1.) - grkern = 11.6666666666667*q2*(0.5*q - 1.)**5 + 4.66666666666667*q*(0.5*q - 1.)**5 + wkern = (1 - q/2.)**6*(35.*q2/12. + 3.*q + 1.) + grkern = (1 - q/2.)**6*(35.*q/6. + 3.) - 3.*(1. - q/2.)**5*(35.*q2/12. + 3.*q + & + 1.) else wkern = 0. grkern = 0. @@ -50,7 +51,7 @@ pure elemental real function wkern(q2,q) real, intent(in) :: q2,q if (q < 2.) then - wkern = (-q/2. + 1.)**6*(35.*q2/12. + 3.*q + 1.) + wkern = (1 - q/2.)**6*(35.*q2/12. + 3.*q + 1.) else wkern = 0. endif @@ -61,7 +62,8 @@ pure elemental real function grkern(q2,q) real, intent(in) :: q2,q if (q < 2.) then - grkern = 11.6666666666667*q2*(0.5*q - 1.)**5 + 4.66666666666667*q*(0.5*q - 1.)**5 + grkern = (1 - q/2.)**6*(35.*q/6. + 3.) - 3.*(1. - q/2.)**5*(35.*q2/12. + 3.*q + & + 1.) else grkern = 0. endif @@ -77,8 +79,9 @@ pure subroutine get_kernel_grav1(q2,q,wkern,grkern,dphidh) q4 = q2*q2 q6 = q4*q2 q8 = q6*q2 - wkern = (-q/2. + 1.)**6*(35.*q2/12. + 3.*q + 1.) - grkern = 11.6666666666667*q2*(0.5*q - 1.)**5 + 4.66666666666667*q*(0.5*q - 1.)**5 + wkern = (1 - q/2.)**6*(35.*q2/12. + 3.*q + 1.) + grkern = (1 - q/2.)**6*(35.*q/6. + 3.) - 3.*(1. - q/2.)**5*(35.*q2/12. + 3.*q + & + 1.) dphidh = -1155.*q6*q4/32768. + 55.*q8*q/128. - 17325.*q8/8192. + 165.*q6*q/32. - & 5775.*q6/1024. + 1155.*q4/256. - 495.*q2/128. + 55./32. else @@ -109,6 +112,26 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4, q6 + + if (q < 2.) then + q4 = q2*q2 + q6 = q4*q2 + gsoft = 3.*q2*q*(175.*q6 - 1848.*q4*q + 7700.*q4 - 15400.*q2*q + 13200.*q2 - & + 4928.)/2048. + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations @@ -118,7 +141,7 @@ pure elemental real function wkern_drag(q2,q) !--double hump Wendland 2/3D C^4 kernel if (q < 2.) then - wkern_drag = q2*(-q/2. + 1.)**6*(35.*q2/12. + 3.*q + 1.) + wkern_drag = q2*(1. - q/2.)**6*(35.*q2/12. + 3.*q + 1.) else wkern_drag = 0. endif diff --git a/src/main/kernel_WendlandC6.f90 b/src/main/kernel_WendlandC6.f90 index b7b690789..c6e54af66 100644 --- a/src/main/kernel_WendlandC6.f90 +++ b/src/main/kernel_WendlandC6.f90 @@ -112,6 +112,27 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4, q6, q8 + + if (q < 2.) then + q4 = q2*q2 + q6 = q4*q2 + q8 = q6*q2 + gsoft = 3.*q2*q*(2860.*q8*q - 40425.*q8 + 240240.*q6*q - 764400.*q6 + & + 1345344.*q4*q - 1121120.*q4 + 549120.*q2 - 256256.)/65536. + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations diff --git a/src/main/kernel_cubic.f90 b/src/main/kernel_cubic.f90 index bf16cead5..6ec8230a9 100644 --- a/src/main/kernel_cubic.f90 +++ b/src/main/kernel_cubic.f90 @@ -119,6 +119,26 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4 + + if (q < 1.) then + gsoft = q2*q*(1.5*q - 2.4) + elseif (q < 2.) then + q4 = q2*q2 + gsoft = (q4*(-0.5*q2 + 2.4*q - 3.) + 0.2)/q2 + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations diff --git a/src/main/kernel_quartic.f90 b/src/main/kernel_quartic.f90 index a698e32b6..de96a3432 100644 --- a/src/main/kernel_quartic.f90 +++ b/src/main/kernel_quartic.f90 @@ -148,6 +148,31 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4, q6 + + if (q < 0.5) then + gsoft = 6.*q2*q*(4.*q2 - 7.)/35. + elseif (q < 1.5) then + q4 = q2*q2 + q6 = q4*q2 + gsoft = (-1024.*q6*q + 4480.*q6 - 5376.*q4*q + 560.*q4 - 1.)/(2240.*q2) + elseif (q < 2.5) then + q4 = q2*q2 + q6 = q4*q2 + gsoft = (512.*q6*q - 4480.*q6 + 13440.*q4*q - 14000.*q4 + 2185.)/(4480.*q2) + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations diff --git a/src/main/kernel_quintic.f90 b/src/main/kernel_quintic.f90 index 64482f474..82e735192 100644 --- a/src/main/kernel_quintic.f90 +++ b/src/main/kernel_quintic.f90 @@ -152,6 +152,35 @@ pure subroutine kernel_softening(q2,q,potensoft,fsoft) end subroutine kernel_softening +!------------------------------------------ +! gradient acceleration kernel needed for +! use in Forward symplectic integrator +!------------------------------------------ +pure subroutine kernel_grad_soft(q2,q,gsoft) + real, intent(in) :: q2,q + real, intent(out) :: gsoft + real :: q4, q6, q8 + + if (q < 1.) then + gsoft = q2*q*(-175.*q2*q + 480.*q2 - 672.)/840. + elseif (q < 2.) then + q4 = q2*q2 + q6 = q4*q2 + q8 = q6*q2 + gsoft = (175.*q8 - 1440.*q6*q + 4200.*q6 - 4704.*q4*q + 1050.*q4 - & + 15.)/(1680.*q2) + elseif (q < 3.) then + q4 = q2*q2 + q6 = q4*q2 + q8 = q6*q2 + gsoft = (-35.*q8 + 480.*q6*q - 2520.*q6 + 6048.*q4*q - 5670.*q4 + & + 1521.)/(1680.*q2) + else + gsoft = -3./q2 + endif + +end subroutine kernel_grad_soft + !------------------------------------------ ! double-humped version of the kernel for ! use in drag force calculations diff --git a/src/main/metric_minkowski.f90 b/src/main/metric_minkowski.f90 index 3562abad8..8164301c0 100644 --- a/src/main/metric_minkowski.f90 +++ b/src/main/metric_minkowski.f90 @@ -202,8 +202,9 @@ subroutine read_options_metric(name,valstring,imatch,igotall,ierr) logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr - ! imatch = .true. - ! igotall = .true. + imatch = .true. + igotall = .true. + ierr = 0 end subroutine read_options_metric diff --git a/src/main/mpi_dens.F90 b/src/main/mpi_dens.F90 index d578658e3..5948afce0 100644 --- a/src/main/mpi_dens.F90 +++ b/src/main/mpi_dens.F90 @@ -74,6 +74,7 @@ module mpidens integer :: maxlength = 0 integer :: n = 0 integer :: number + integer :: idum ! to avoid ifort warning end type stackdens contains @@ -227,6 +228,8 @@ subroutine free_mpitype_of_celldens(dtype) integer :: mpierr call MPI_Type_free(dtype,mpierr) +#else + dtype = 0 #endif end subroutine free_mpitype_of_celldens diff --git a/src/main/mpi_derivs.F90 b/src/main/mpi_derivs.F90 index a9b2b2641..1847cbd6c 100644 --- a/src/main/mpi_derivs.F90 +++ b/src/main/mpi_derivs.F90 @@ -137,7 +137,12 @@ subroutine init_celldens_exchange(xbufrecv,ireq,thread_complete,ncomplete_mpi,dt ncomplete_mpi = 0 !$omp end master thread_complete(omp_thread_num()+1) = .false. +#else + ncomplete_mpi = 0 + ireq = 0 + dtype = 0 #endif + end subroutine init_celldens_exchange subroutine init_cellforce_exchange(xbufrecv,ireq,thread_complete,ncomplete_mpi,dtype) @@ -177,6 +182,10 @@ subroutine init_cellforce_exchange(xbufrecv,ireq,thread_complete,ncomplete_mpi,d ncomplete_mpi = 0 !$omp end master thread_complete(omp_thread_num()+1) = .false. +#else + ncomplete_mpi = 0 + ireq = 0 + dtype = 0 #endif end subroutine init_cellforce_exchange @@ -209,6 +218,8 @@ subroutine send_celldens(cell,targets,irequestsend,xsendbuf,counters,dtype) counters(newproc+1,isent) = counters(newproc+1,isent) + 1 endif enddo +#else + xsendbuf = cell #endif end subroutine send_celldens @@ -237,6 +248,8 @@ subroutine send_cellforce(cell,targets,irequestsend,xsendbuf,counters,dtype) counters(newproc+1,isent) = counters(newproc+1,isent) + 1 endif enddo +#else + xsendbuf = cell #endif end subroutine send_cellforce @@ -260,6 +273,8 @@ subroutine check_send_finished(irequestsend,idone) enddo !--never test self; always set to true idone(id+1) = .true. +#else + idone = .true. #endif end subroutine check_send_finished @@ -619,6 +634,8 @@ subroutine check_complete(counters,ncomplete_mpi) endif endif enddo +#else + ncomplete_mpi = 1 #endif end subroutine check_complete diff --git a/src/main/mpi_memory.f90 b/src/main/mpi_memory.f90 deleted file mode 100644 index 5d635f2d4..000000000 --- a/src/main/mpi_memory.f90 +++ /dev/null @@ -1,317 +0,0 @@ -!--------------------------------------------------------------------------! -! 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 mpimemory -! -! None -! -! :References: None -! -! :Owner: Conrad Chan -! -! :Runtime parameters: None -! -! :Dependencies: dim, io, mpidens, mpiforce -! - use io, only:fatal,iprint - use mpidens, only:celldens,stackdens - use mpiforce, only:cellforce,stackforce - - implicit none - - interface allocate_stack - module procedure allocate_stack_dens,allocate_stack_force - end interface allocate_stack - - interface swap_stacks ! force doesn't require a stack swap - module procedure swap_stacks_dens - end interface swap_stacks - - interface push_onto_stack - module procedure push_onto_stack_dens,push_onto_stack_force - end interface push_onto_stack - - interface get_cell - module procedure get_cell_dens,get_cell_force - end interface get_cell - - interface write_cell - module procedure write_cell_dens,write_cell_force - end interface write_cell - - interface reserve_stack - module procedure reserve_stack_dens,reserve_stack_force - end interface reserve_stack - - public :: allocate_mpi_memory - public :: deallocate_mpi_memory - public :: allocate_stack - public :: swap_stacks - public :: push_onto_stack - public :: get_cell - public :: write_cell - public :: reserve_stack - public :: reset_stacks - public :: increase_mpi_memory - - ! stacks to be referenced from density and force routines - type(stackdens), public :: dens_stack_1 - type(stackdens), public :: dens_stack_2 - type(stackdens), public :: dens_stack_3 - type(stackforce), public :: force_stack_1 - type(stackforce), public :: force_stack_2 - - integer, public :: stacksize - - private - - ! primary chunk of memory requested using alloc - type(celldens), allocatable, target :: dens_cells(:,:) - type(cellforce), allocatable, target :: force_cells(:,:) - -contains - -subroutine allocate_mpi_memory(npart, stacksize_in) - integer, optional, intent(in) :: npart - integer, optional, intent(in) :: stacksize_in - integer :: allocstat - - allocstat = 0 - - if (present(stacksize_in)) stacksize = stacksize_in - if (present(npart)) call calculate_stacksize(npart) - - if (allocated(dens_cells)) then - if (stacksize /= size(dens_cells,1)) then - call fatal('stack', 'dens_cells already allocated with a different size') - endif - endif - - if (allocated(force_cells)) then - if (stacksize /= size(force_cells,1)) then - call fatal('stack', 'force_cells already allocated with a different size') - endif - endif - - if (.not. allocated(dens_cells)) allocate(dens_cells(stacksize,3), stat=allocstat) - if (allocstat /= 0) call fatal('stack','fortran memory allocation error') - call allocate_stack(dens_stack_1, 1) - call allocate_stack(dens_stack_2, 2) - call allocate_stack(dens_stack_3, 3) - - if (.not. allocated(force_cells)) allocate(force_cells(stacksize,2), stat=allocstat) - if (allocstat /= 0) call fatal('stack','fortran memory allocation error') - call allocate_stack(force_stack_1, 1) - call allocate_stack(force_stack_2, 2) - -end subroutine allocate_mpi_memory - -subroutine increase_mpi_memory - use io, only:id - real, parameter :: factor = 1.5 - integer :: stacksize_new - integer :: allocstat - - ! temporary memory for increasing stack sizes - type(celldens), allocatable, target :: dens_cells_tmp(:,:) - type(cellforce), allocatable, target :: force_cells_tmp(:,:) - - stacksize_new = int(real(stacksize) * factor) - write(iprint, *) 'MPI dens stack exceeded on', id, 'increasing size to', stacksize_new - - ! Expand density - call move_alloc(dens_cells, dens_cells_tmp) - allocate(dens_cells(stacksize_new,3), stat=allocstat) - if (allocstat /= 0) call fatal('stack', 'error increasing dens stack size') - dens_cells(1:stacksize,:) = dens_cells_tmp(:,:) - deallocate(dens_cells_tmp) - - ! Expand force - call move_alloc(force_cells, force_cells_tmp) - allocate(force_cells(stacksize_new,2), stat=allocstat) - if (allocstat /= 0) call fatal('stack', 'error increasing force stack size') - force_cells(1:stacksize,:) = force_cells_tmp(:,:) - deallocate(force_cells_tmp) - - stacksize = stacksize_new - call allocate_stack(force_stack_1, 1) - call allocate_stack(force_stack_2, 2) - call allocate_stack(dens_stack_1, dens_stack_1%number) - call allocate_stack(dens_stack_2, dens_stack_2%number) - call allocate_stack(dens_stack_3, dens_stack_3%number) -end subroutine increase_mpi_memory - -subroutine calculate_stacksize(npart) - use dim, only:mpi,minpart - use io, only:nprocs,id,master - integer, intent(in) :: npart - integer, parameter :: safety = 8 - - ! size of the stack needed for communication, - ! should be at least the maximum number of cells that need - ! to be exported to other tasks. - ! - ! if it is not large enough, it will be automatically expanded - - ! number of particles per cell, divided by number of tasks - if (mpi .and. nprocs > 1) then - ! assume that every cell will be exported, with some safety factor - stacksize = (npart / minpart / nprocs) * safety - - if (id == master) then - write(iprint, *) 'MPI memory stack size = ', stacksize - write(iprint, *) ' (total number of cells that can be exported by a single task)' - endif - else - stacksize = 0 - endif - -end subroutine calculate_stacksize - -subroutine deallocate_mpi_memory - if (allocated(dens_cells )) deallocate(dens_cells ) - if (allocated(force_cells)) deallocate(force_cells) -end subroutine deallocate_mpi_memory - -subroutine allocate_stack_dens(stack, i) - type(stackdens), intent(inout) :: stack - integer, intent(in) :: i - - stack%number = i - stack%cells => dens_cells(1:stacksize,stack%number) - stack%maxlength = stacksize - -end subroutine allocate_stack_dens - -subroutine allocate_stack_force(stack, i) - type(stackforce), intent(inout) :: stack - integer, intent(in) :: i - - stack%number = i - stack%cells => force_cells(1:stacksize,stack%number) - stack%maxlength = stacksize - -end subroutine allocate_stack_force - -subroutine swap_stacks_dens(stack_a, stack_b) - type(stackdens), intent(inout) :: stack_a - type(stackdens), intent(inout) :: stack_b - - integer :: temp_n - integer :: temp_number - - if (stack_a%maxlength /= stack_b%maxlength) call fatal('stack', 'stack swap of unequal size') - - ! counters - temp_n = stack_a%n - stack_a%n = stack_b%n - stack_b%n = temp_n - - ! addresses - temp_number = stack_a%number - stack_a%number = stack_b%number - stack_b%number = temp_number - - ! change pointers - stack_a%cells => dens_cells(1:stacksize,stack_a%number) - stack_b%cells => dens_cells(1:stacksize,stack_b%number) - -end subroutine swap_stacks_dens - -subroutine push_onto_stack_dens(stack,cell) - type(stackdens), intent(inout) :: stack - type(celldens), intent(in) :: cell - - integer :: i - - call reserve_stack(stack,i) - - ! no other thread will write to the same position, so it is threadsafe to write without a critical section - stack%cells(i) = cell -end subroutine push_onto_stack_dens - -subroutine push_onto_stack_force(stack,cell) - type(stackforce), intent(inout) :: stack - type(cellforce), intent(in) :: cell - - integer :: i - - call reserve_stack(stack,i) - - ! no other thread will write to the same position, so it is threadsafe to write without a critical section - stack%cells(i) = cell -end subroutine push_onto_stack_force - -type(celldens) function get_cell_dens(stack,i) - type(stackdens), intent(in) :: stack - integer, intent(in) :: i - - if (stack%n < i) call fatal('dens','attempting to read invalid stack address') - get_cell_dens = stack%cells(i) -end function get_cell_dens - -type(cellforce) function get_cell_force(stack,i) - type(stackforce), intent(in) :: stack - integer, intent(in) :: i - - if (stack%n < i) call fatal('force','attempting to read invalid stack address') - get_cell_force = stack%cells(i) -end function get_cell_force - -subroutine write_cell_dens(stack,cell) - type(stackdens), intent(inout) :: stack - type(celldens), intent(inout) :: cell - - if (cell%waiting_index > stack%maxlength) call fatal('dens','attempting to write to invalid stack address') - stack%cells(cell%waiting_index) = cell - -end subroutine write_cell_dens - -subroutine write_cell_force(stack,cell) - type(stackforce), intent(inout) :: stack - type(cellforce), intent(inout) :: cell - - if (cell%waiting_index > stack%maxlength) call fatal('force','attempting to write to invalid stack address') - stack%cells(cell%waiting_index) = cell - -end subroutine write_cell_force - -subroutine reserve_stack_dens(stack,i) - type(stackdens), intent(inout) :: stack - integer, intent(out) :: i - - !$omp atomic capture - stack%n = stack%n + 1 - i = stack%n - !$omp end atomic - - if (i > stack%maxlength) call fatal('dens','MPI stack exceeded') - -end subroutine reserve_stack_dens - -subroutine reserve_stack_force(stack,i) - type(stackforce), intent(inout) :: stack - integer, intent(out) :: i - - !$omp atomic capture - stack%n = stack%n + 1 - i = stack%n - !$omp end atomic - - if (i > stack%maxlength) call fatal('force','MPI stack exceeded') - -end subroutine reserve_stack_force - -subroutine reset_stacks - dens_stack_1%n=0 - dens_stack_2%n=0 - dens_stack_3%n=0 - - force_stack_1%n=0 - force_stack_2%n=0 -end subroutine reset_stacks - -end module mpimemory diff --git a/src/main/mpi_tree.F90 b/src/main/mpi_tree.F90 index fe49e3c22..8b24ace8c 100644 --- a/src/main/mpi_tree.F90 +++ b/src/main/mpi_tree.F90 @@ -132,6 +132,9 @@ subroutine get_group_cofm(xyzcofm,totmass_node,level,cofmsum,totmassg) call MPI_ALLREDUCE(totmass_node,totmassg,1,MPI_REAL8,MPI_SUM,comm_cofm(level+1),mpierr) call MPI_ALLREDUCE(cofmpart,cofmsum,3,MPI_REAL8,MPI_SUM,comm_cofm(level+1),mpierr) cofmsum = cofmsum / totmassg +#else + cofmsum = xyzcofm*totmass_node + totmassg = totmass_node #endif end subroutine get_group_cofm diff --git a/src/main/mpi_utils.F90 b/src/main/mpi_utils.F90 index e725bc020..03816c05d 100644 --- a/src/main/mpi_utils.F90 +++ b/src/main/mpi_utils.F90 @@ -110,6 +110,7 @@ module mpiutils public :: fill_buffer, unfill_buf public :: reduceloc_mpi public :: waitmyturn,endmyturn + public :: start_threadwrite,end_threadwrite private @@ -227,6 +228,64 @@ subroutine endmyturn(myid) end subroutine endmyturn +!-------------------------------------------------------------------- +!+ +! utility for initialising each thread +!+ +!-------------------------------------------------------------------- +subroutine start_threadwrite(id,iunit,filename) +#ifdef MPI + use mpi +#endif + use io, only:error,iverbose + implicit none + integer, intent(in) :: id, iunit + character(len=*), intent(in) :: filename + integer :: nowgo,ierr + + if (iverbose >= 3) print *,id,' : starting write...' + nowgo = 0 + if (id > 0) then +#ifdef MPI + call MPI_RECV(nowgo,1,MPI_INTEGER,id-1,99,MPI_COMM_WORLD,status,mpierr) +#endif + open(unit=iunit,file=filename,status='old',form='unformatted',position='append',iostat=ierr) + if (ierr /= 0) then + call error('start_threadwrite','can''t append to dumpfile '//trim(filename)) + else + if (iverbose >= 3) print*,'thread ',id,': opened file '//trim(filename) + endif + endif + +end subroutine start_threadwrite + +!-------------------------------------------------------------------- +!+ +! utility for finalising each thread +!+ +!-------------------------------------------------------------------- +subroutine end_threadwrite(id) + use io, only:iverbose +#ifdef MPI + use mpi + use io, only:nprocs +#endif + implicit none + integer, intent(in) :: id +#ifdef MPI + integer :: nowgo +#endif + + if (iverbose >= 3) print *,' thread ',id,' : finished write.' +#ifdef MPI + if (id < nprocs-1) then + nowgo = 1 + call MPI_SEND(nowgo,1,MPI_INTEGER,id+1,99,MPI_COMM_WORLD,mpierr) + endif +#endif + +end subroutine end_threadwrite + !-------------------------------------------------------------------- !+ ! MPI barrier interface (no-op if called in non-mpi code) diff --git a/src/main/nicil_supplement.F90 b/src/main/nicil_supplement.F90 deleted file mode 100644 index 33533c07b..000000000 --- a/src/main/nicil_supplement.F90 +++ /dev/null @@ -1,236 +0,0 @@ -!--------------------------------------------------------------------------! -! 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 nicil_sup -! -! Contains wrapper routines so that NICIL can be used in Phantom -! -! :References: Wurster (2016) -! Wurster (2021) -! -! :Owner: Daniel Price -! -! :Runtime parameters: -! - C_AD : *constant coefficient for ambipolar diffusion* -! - C_HE : *constant coefficient for the Hall effect (incl. sign)* -! - C_OR : *constant coefficient for ohmic resistivity* -! - Cdt_diff : *coefficient to control the Ohmic & ambipolar timesteps* -! - Cdt_hall : *coefficient to control the Hall timestep* -! - a0_grain : *grain radius (cm)* -! - alpha_AD : *power law exponent for ambipolar diffusion* -! - an_grain : *minimum grain radius (cm)* -! - ax_grain : *maximum grain radius (cm)* -! - eta_const_type : *Coefficient type: phys.cnst+B+rho (1), C_NI+B+rho (2), C_NI (3)* -! - eta_constant : *Use constant coefficients for all non-ideal MHD terms* -! - fdg : *dust-to-gas mass ratio* -! - gamma_AD : *ion-neutral coupling coefficient for ambipolar diffusion* -! - hall_lt_zero : *sign of the hall coefficient (<0 if T)* -! - n_e_cnst : *constant electron number density* -! - rho_bulk : *bulk grain density (g/cm^3)* -! - rho_i_cnst : *ionisation density for ambipolar diffusion* -! - rho_n_cnst : *neutral density for ambipolar diffusion* -! - use_ambi : *Calculate the coefficient for ambipolar diffusion* -! - use_hall : *Calculate the coefficient for the Hall effect* -! - use_ohm : *Calculate the coefficient for Ohmic resistivity* -! - zeta : *cosmic ray ionisation rate (s^-1)* -! -! :Dependencies: infile_utils, nicil, physcon -! - use nicil, only: use_ohm,use_hall,use_ambi,na, & - fdg,rho_bulk,a0_grain,an_grain,ax_grain,zeta_cgs,Cdt_diff,Cdt_hall, & - eta_constant,eta_const_type,icnstphys,icnstsemi,icnst,C_OR,C_HE,C_AD, & - n_e_cnst,hall_lt_zero,rho_i_cnst,rho_n_cnst,alpha_AD,gamma_AD - implicit none - ! - !--Subroutines - public :: use_consistent_gmw,write_options_nicil,read_options_nicil - - private - -contains - -!----------------------------------------------------------------------- -!+ -! Ensures a consistent meanmolecular mass is used -!+ -!----------------------------------------------------------------------- -subroutine use_consistent_gmw(ierr,gmw_eos,gmw_nicil) - use nicil, only:meanmolmass - integer, intent(out) :: ierr - real, intent(out) :: gmw_nicil - real, intent(inout) :: gmw_eos - - gmw_nicil = meanmolmass - if (abs(meanmolmass-gmw_eos) > epsilon(gmw_eos)) then - ierr = 1 - gmw_eos = meanmolmass - endif - -end subroutine use_consistent_gmw -!----------------------------------------------------------------------- -!+ -! writes input options to the input file -!+ -!----------------------------------------------------------------------- -subroutine write_options_nicil(iunit) - use infile_utils, only:write_inopt - integer, intent(in) :: iunit - - write(iunit,"(/,a)") '# options controlling non-ideal MHD' - call write_inopt(use_ohm , 'use_ohm' ,'Calculate the coefficient for Ohmic resistivity',iunit) - call write_inopt(use_hall, 'use_hall' ,'Calculate the coefficient for the Hall effect',iunit) - call write_inopt(use_ambi, 'use_ambi' ,'Calculate the coefficient for ambipolar diffusion',iunit) - call write_inopt(eta_constant,'eta_constant','Use constant coefficients for all non-ideal MHD terms',iunit) - if ( eta_constant ) then - call write_inopt(eta_const_type,'eta_const_type','Coefficient type: phys.cnst+B+rho (1), C_NI+B+rho (2), C_NI (3)',iunit) - if ( eta_const_type==1 ) then - if ( use_ohm .or. use_hall ) then - call write_inopt(n_e_cnst,'n_e_cnst' ,'constant electron number density',iunit) - if ( use_hall ) call write_inopt(hall_lt_zero, 'hall_lt_zero' ,'sign of the hall coefficient (<0 if T)',iunit) - endif - if ( use_ambi ) then - call write_inopt(gamma_AD, 'gamma_AD', 'ion-neutral coupling coefficient for ambipolar diffusion',iunit) - call write_inopt(rho_i_cnst, 'rho_i_cnst','ionisation density for ambipolar diffusion',iunit) - call write_inopt(rho_n_cnst, 'rho_n_cnst','neutral density for ambipolar diffusion',iunit) - call write_inopt(alpha_AD, 'alpha_AD', 'power law exponent for ambipolar diffusion',iunit) - endif - elseif ( eta_const_type==2 ) then - if ( use_ohm ) call write_inopt(C_OR,'C_OR', 'semi-constant coefficient for ohmic resistivity',iunit) - if ( use_hall ) call write_inopt(C_HE,'C_HE', 'semi-constant coefficient for the Hall effect (incl. sign)',iunit) - if ( use_ambi ) call write_inopt(C_AD,'C_AD', 'semi-constant coefficient for ambipolar diffusion',iunit) - elseif ( eta_const_type==3 ) then - if ( use_ohm ) call write_inopt(C_OR,'C_OR', 'constant coefficient for ohmic resistivity',iunit) - if ( use_hall ) call write_inopt(C_HE,'C_HE', 'constant coefficient for the Hall effect (incl. sign)',iunit) - if ( use_ambi ) call write_inopt(C_AD,'C_AD', 'constant coefficient for ambipolar diffusion',iunit) - endif - endif - call write_inopt(Cdt_diff, 'Cdt_diff', 'coefficient to control the Ohmic & ambipolar timesteps',iunit) - call write_inopt(Cdt_hall, 'Cdt_hall', 'coefficient to control the Hall timestep',iunit) - if ( .not. eta_constant ) then - write(iunit,"(/,a)") '# options controlling ionisation' - call write_inopt(fdg, 'fdg', 'dust-to-gas mass ratio',iunit) - call write_inopt(rho_bulk, 'rho_bulk', 'bulk grain density (g/cm^3)',iunit) - if ( na==1 ) then - call write_inopt(a0_grain, 'a0_grain', 'grain radius (cm)',iunit) - else - call write_inopt(an_grain, 'an_grain', 'minimum grain radius (cm)',iunit) - call write_inopt(ax_grain, 'ax_grain', 'maximum grain radius (cm)',iunit) - endif - call write_inopt(zeta_cgs, 'zeta', 'cosmic ray ionisation rate (s^-1)',iunit) - endif - -end subroutine write_options_nicil -!----------------------------------------------------------------------- -!+ -! reads input options from the input file -!+ -!----------------------------------------------------------------------- -subroutine read_options_nicil(name,valstring,imatch,igotall,ierr) - use physcon, only:fourpi - character(len=*), intent(in) :: name,valstring - logical, intent(out) :: imatch,igotall - integer, intent(out) :: ierr - integer :: ngotmax - integer, save :: ngot = 0 - - !--Initialise parameters - imatch = .true. - igotall = .false. - !--Number of input parameters - ngotmax = 6 - - !--Read input parameters - select case(trim(name)) - case('use_ohm') - read(valstring,*,iostat=ierr) use_ohm - ngot = ngot + 1 - case('use_hall') - read(valstring,*,iostat=ierr) use_hall - ngot = ngot + 1 - case('use_ambi') - read(valstring,*,iostat=ierr) use_ambi - ngot = ngot + 1 - case('eta_constant') - read(valstring,*,iostat=ierr) eta_constant - ngot = ngot + 1 - if (eta_constant) then - ngotmax = ngotmax + 1 - else - ngotmax = ngotmax + 4 - if (na==1) ngotmax = ngotmax + 1 - endif - case('eta_const_type') - read(valstring,*,iostat=ierr) eta_const_type - ngot = ngot + 1 - if (eta_const_type==1) then - if (use_ohm ) ngotmax = ngotmax + 1 - if (use_hall) ngotmax = ngotmax + 2 - if (use_ambi) ngotmax = ngotmax + 4 - elseif (eta_const_type==2 .or. eta_const_type==3) then - if (use_ohm ) ngotmax = ngotmax + 1 - if (use_hall) ngotmax = ngotmax + 1 - if (use_ambi) ngotmax = ngotmax + 1 - endif - case('C_OR') - read(valstring,*,iostat=ierr) C_OR - ngot = ngot + 1 - case('C_HE') - read(valstring,*,iostat=ierr) C_HE - ngot = ngot + 1 - case('C_AD') - read(valstring,*,iostat=ierr) C_AD - ngot = ngot + 1 - case('n_e_cnst') - read(valstring,*,iostat=ierr) n_e_cnst - ngot = ngot + 1 - case('hall_lt_zero') - read(valstring,*,iostat=ierr) hall_lt_zero - ngot = ngot + 1 - case('gamma_AD') - read(valstring,*,iostat=ierr) gamma_AD - ngot = ngot + 1 - case('rho_i_cnst') - read(valstring,*,iostat=ierr) rho_i_cnst - ngot = ngot + 1 - case('rho_n_cnst') - read(valstring,*,iostat=ierr) rho_n_cnst - ngot = ngot + 1 - case('alpha_AD') - read(valstring,*,iostat=ierr) alpha_AD - ngot = ngot + 1 - case('fdg') - read(valstring,*,iostat=ierr) fdg - ngot = ngot + 1 - case('rho_bulk') - read(valstring,*,iostat=ierr) rho_bulk - ngot = ngot + 1 - case('a0_grain') - read(valstring,*,iostat=ierr) a0_grain - ngot = ngot + 1 - case('an_grain') - read(valstring,*,iostat=ierr) an_grain - ngot = ngot + 1 - case('ax_grain') - read(valstring,*,iostat=ierr) ax_grain - ngot = ngot + 1 - case('zeta') - read(valstring,*,iostat=ierr) zeta_cgs - ngot = ngot + 1 - case('Cdt_diff') - read(valstring,*,iostat=ierr) Cdt_diff - ngot = ngot + 1 - case('Cdt_hall') - read(valstring,*,iostat=ierr) Cdt_hall - ngot = ngot + 1 - case default - imatch = .false. - end select - if ( ngot >= ngotmax ) igotall = .true. - -end subroutine read_options_nicil - -!----------------------------------------------------------------------- -end module nicil_sup diff --git a/src/main/options.f90 b/src/main/options.f90 index 36bc7e5eb..f49271fca 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -29,13 +29,14 @@ module options real, public :: avdecayconst integer, public :: nfulldump,nmaxdumps,iexternalforce real, public :: tolh,damp,rkill - real(kind=4), public :: twallmax + integer, parameter :: sp = 4 ! single precision + real(kind=sp), public :: twallmax ! artificial viscosity, thermal conductivity, resistivity real, public :: alpha,alphau,beta real, public :: alphamax - real, public :: alphaB, psidecayfac, overcleanfac, hdivbbmax_max + real, public :: alphaB, psidecayfac, overcleanfac integer, public :: ishock_heating,ipdv_heating,icooling,iresistive_heating integer, public :: ireconav @@ -51,7 +52,7 @@ module options logical, public :: use_mcfost, use_Voronoi_limits_file, use_mcfost_stellar_parameters, mcfost_computes_Lacc logical, public :: mcfost_uses_PdV, mcfost_dust_subl integer, public :: ISM - real(kind=4), public :: mcfost_keep_part + real(kind=sp), public :: mcfost_keep_part character(len=80), public :: Voronoi_limits_file ! radiation @@ -133,8 +134,6 @@ subroutine set_default_options alphaB = 1.0 psidecayfac = 1.0 ! psi decay factor (MHD only) overcleanfac = 1.0 ! factor to increase signal velocity for (only) time steps and psi cleaning - hdivbbmax_max = 1.0 ! if > overcleanfac, then use B/(h*|div B|) as a coefficient for dtclean; - ! ! this is the max value allowed; test suggest =512 for magnetised colliding flows beta = 2.0 ! beta viscosity term avdecayconst = 0.1 ! decay time constant for viscosity switches @@ -150,7 +149,7 @@ subroutine set_default_options mcfost_computes_Lacc = .false. mcfost_dust_subl = .false. mcfost_uses_PdV = .true. - mcfost_keep_part = real(0.999,kind=4) + mcfost_keep_part = 0.999_sp ISM = 0 ! radiation diff --git a/src/main/partinject.F90 b/src/main/partinject.F90 index dadfffb35..8f621fbb3 100644 --- a/src/main/partinject.F90 +++ b/src/main/partinject.F90 @@ -43,7 +43,7 @@ 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!,dust_temp + use part, only:mhd,Bevol,dBevol,Bxyz,divBsymm,gr,pxyzu!,dust_temp use part, only:divcurlv,divcurlB,ndivcurlv,ndivcurlB,ntot,ibin,imu,igamma use part, only:iorig,norig use io, only:fatal @@ -105,6 +105,8 @@ subroutine add_or_update_particle(itype,position,velocity,h,u,particle_number,np divBsymm(particle_number) = 0. endif + if (gr) pxyzu(:,particle_number) = 0. + if (ndivcurlv > 0) divcurlv(:,particle_number) = 0. if (ndivcurlB > 0) divcurlB(:,particle_number) = 0. if (maxalpha==maxp) alphaind(:,particle_number) = 0. diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 547584f34..7b5071b17 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -6,7 +6,7 @@ !--------------------------------------------------------------------------! module porosity ! -! Contains routine for porosity evolution (growth, bouncing, +! Contains routine for porosity evolution (growth, bouncing, ! fragmentation, compaction, disruption) ! ! :References: diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 65dab95a1..e75d1c29d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -59,6 +59,7 @@ module ptmass ! settings affecting routines in module (read from/written to input file) integer, public :: icreate_sinks = 0 + integer, public :: isink_potential = 0 real, public :: rho_crit_cgs = 1.e-10 real, public :: r_crit = 5.e-3 real, public :: h_acc = 1.e-3 @@ -69,7 +70,6 @@ module ptmass real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius real, public :: f_crit_override = 0.0 ! 1000. - logical, public :: use_regnbody = .false. ! subsystems switch logical, public :: use_fourthorder = .true. integer, public :: n_force_order = 3 @@ -160,7 +160,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, 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 + real :: fxj,fyj,fzj,dsx,dsy,dsz,fac,r integer :: j logical :: tofrom,extrap ! @@ -241,14 +241,30 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, ! acceleration of gas due to point mass particle f1 = pmassj*dr3 + + ! acceleration of sink from gas + if (tofrom) f2 = pmassi*dr3 + + ! modified potential + select case (isink_potential) + case(1) + ! Ayliffe & Bate (2010) equation 2 (prevent accretion on to sink) + Rsink = xyzmh_ptmass(iReff,j) + r=1./ddr + if (Rsink > 0. .and. r < 2*Rsink) then + fac = (1. - (2. - r/Rsink)**4) + f1 = f1*fac + f2 = f2*fac + phi = phi - pmassj*(r**3/3.-4.*r**2*Rsink+24.*r*Rsink**2 & + -16.*Rsink**4/r-32.*Rsink**3*log(r))/Rsink**4 + endif + end select + ftmpxi = ftmpxi - dx*f1 ftmpyi = ftmpyi - dy*f1 ftmpzi = ftmpzi - dz*f1 phi = phi - pmassj*ddr ! potential (GM/r) - ! acceleration of sink from gas - if (tofrom) f2 = pmassi*dr3 - ! additional accelerations due to oblateness if (abs(J2) > 0.) then shat = unitvec(xyzmh_ptmass(ispinx:ispinz,j)) @@ -658,25 +674,28 @@ subroutine ptmass_vdependent_correction(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyz real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: fxyz_ptmass(4,nptmass) integer, intent(in) :: iexternalforce - real :: fxi,fyi,fzi,fextv(3) + real :: fxi,fyi,fzi,vxhalfi,vyhalfi,vzhalfi,fextv(3) integer :: i !$omp parallel do schedule(static) default(none) & !$omp shared(vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dkdt,nptmass,iexternalforce) & - !$omp private(fxi,fyi,fzi,fextv) & + !$omp private(vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi,fextv) & !$omp private(i) do i=1,nptmass if (xyzmh_ptmass(4,i) > 0.) then + vxhalfi = vxyz_ptmass(1,i) + vyhalfi = vxyz_ptmass(2,i) + vzhalfi = vxyz_ptmass(3,i) fxi = fxyz_ptmass(1,i) fyi = fxyz_ptmass(2,i) fzi = fxyz_ptmass(3,i) call update_vdependent_extforce(iexternalforce,& - vxyz_ptmass(1,i),vxyz_ptmass(2,i),vxyz_ptmass(3,i), & - fxi,fyi,fzi,fextv,dkdt,xyzmh_ptmass(1,i),xyzmh_ptmass(2,i), & + vxhalfi,vyhalfi,vzhalfi,fxi,fyi,fzi,fextv,dkdt, & + xyzmh_ptmass(1,i),xyzmh_ptmass(2,i), & xyzmh_ptmass(3,i)) - fxyz_ptmass(1,i) = fxi + fextv(1) - fxyz_ptmass(2,i) = fyi + fextv(2) - fxyz_ptmass(3,i) = fzi + fextv(3) + fxyz_ptmass(1,i) = fxi + fxyz_ptmass(2,i) = fyi + fxyz_ptmass(3,i) = fzi endif enddo !$omp end parallel do @@ -1931,6 +1950,7 @@ subroutine write_options_ptmass(iunit) integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling sink particles' + call write_inopt(isink_potential,'isink_potential','sink potential(0=1/r,1=surf)',iunit) if (gravity) then call write_inopt(icreate_sinks,'icreate_sinks','allow automatic sink particle creation',iunit) if (icreate_sinks > 0) then @@ -1977,6 +1997,9 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) icreate_sinks ngot = ngot + 1 if (icreate_sinks < 0) call fatal(label,'sink creation option out of range') + case('isink_potential') + read(valstring,*,iostat=ierr) isink_potential + ngot = ngot + 1 case('rho_crit_cgs') read(valstring,*,iostat=ierr) rho_crit_cgs if (rho_crit_cgs < 0.) call fatal(label,'rho_crit < 0') diff --git a/src/setup/readwrite_kepler.f90 b/src/setup/readwrite_kepler.f90 index 21d138b8b..41f73b86f 100644 --- a/src/setup/readwrite_kepler.f90 +++ b/src/setup/readwrite_kepler.f90 @@ -100,11 +100,11 @@ subroutine read_kepler_file(filepath,ng_max,n_rows,rtab,rhotab,ptab,temperature, !--This is used as a test for saving composition. ! ierr = 0 - open(newunit=iu, file=trim(fullfilepath)) + open(newunit=iu,file=trim(fullfilepath)) !The row with the information about column headings is at nheaderlines-1. !we skip the first nheaderlines-2 rows and then read the nheaderlines-1 to find the substrings call skip_header(iu,nheaderlines-2,ierr) - read(iu, '(a)', iostat=ierr) line + read(iu, '(a)',iostat=ierr) line !read the column labels and store them in an array. allocate(all_label(n_cols)) @@ -125,7 +125,7 @@ subroutine read_kepler_file(filepath,ng_max,n_rows,rtab,rhotab,ptab,temperature, ! !--Read the file again and save the data in stardata tensor. ! - open(newunit=iu, file=trim(fullfilepath)) + open(newunit=iu,file=trim(fullfilepath)) call skip_header(iu,nheaderlines,ierr) do k=1,n_rows read(iu,*,iostat=ierr) stardata(k,:) diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index a053eb985..d69a8ff72 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.f90 @@ -230,7 +230,7 @@ subroutine write_mesa(outputpath,m,pres,temp,r,rho,ene,Xfrac,Yfrac,csound,mu) optionalcols(:,noptionalcols) = csound endif - open(newunit=iu, file = outputpath, status = 'replace') + open(newunit=iu,file=outputpath,status='replace') do i = 1,noptionalcols+ncols-1 write(iu,'(a24,2x)',advance="no") trim(headers(i)) enddo diff --git a/src/setup/set_binary.f90 b/src/setup/set_binary.f90 index e1208a837..3027f47d7 100644 --- a/src/setup/set_binary.f90 +++ b/src/setup/set_binary.f90 @@ -34,6 +34,7 @@ module setbinary end interface get_eccentricity_vector real, parameter :: pi = 4.*atan(1.) + real, parameter :: deg_to_rad = pi/180. integer, parameter :: & ierr_m1 = 1, & ierr_m2 = 2, & @@ -186,19 +187,19 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & if (present(posang_ascnode) .and. present(arg_peri) .and. present(incl)) then ! Campbell elements ecc = eccentricity - omega = arg_peri*pi/180. + omega = arg_peri*deg_to_rad ! our conventions here are Omega is measured East of North - big_omega = posang_ascnode*pi/180. + 0.5*pi - inc = incl*pi/180. + big_omega = posang_ascnode*deg_to_rad + 0.5*pi + inc = incl*deg_to_rad if (present(f)) then ! get eccentric, parabolic or hyperbolic anomaly from true anomaly ! (https://en.wikipedia.org/wiki/Eccentric_anomaly#From_the_true_anomaly) - theta = f*pi/180. + theta = f*deg_to_rad E = get_E_from_true_anomaly(theta,ecc) elseif (present(mean_anomaly)) then ! get eccentric anomaly from mean anomaly by solving Kepler equation - bigM = mean_anomaly*pi/180. + bigM = mean_anomaly*deg_to_rad E = get_E_from_mean_anomaly(bigM,ecc) else ! set binary at apastron @@ -324,7 +325,7 @@ subroutine set_binary(m1,m2,semimajoraxis,eccentricity, & ! rotate if inclination is non-zero ! if (present(incl) .and. .not.(present(arg_peri) .and. present(posang_ascnode))) then - xangle = incl*pi/180. + xangle = incl*deg_to_rad cosi = cos(xangle) sini = sin(xangle) do i=i1,i2 diff --git a/src/setup/set_hierarchical.f90 b/src/setup/set_hierarchical.f90 index 22dad2a68..c52aeabd6 100644 --- a/src/setup/set_hierarchical.f90 +++ b/src/setup/set_hierarchical.f90 @@ -493,31 +493,33 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & !--- Load/Create HIERARCHY file: xyzmh_ptmass index | hierarchical index | star mass | companion star mass | semi-major axis | eccentricity | period | inclination | argument of pericenter | ascending node longitude inquire(file=trim(filename), exist=iexist) - if (present(subst) .and. subst>10) then - if (iexist) then - open(1, file = trim(filename), status = 'old') - lines=0 - do - read(1, *, iostat=io) data(lines+1,:) - if (io/=0) exit - lines = lines + 1 - enddo - close(1) - else - print "(1x,a)",'ERROR: set_multiple: there is no HIERARCHY file, cannot perform subtitution.' - ierr = ierr_HIER2 + if (present(subst)) then + if (subst>10) then + if (iexist) then + open(1,file=trim(filename),status='old') + lines=0 + do + read(1, *,iostat=io) data(lines+1,:) + if (io/=0) exit + lines = lines + 1 + enddo + close(1) + else + print "(1x,a)",'ERROR: set_multiple: there is no HIERARCHY file, cannot perform subtitution.' + ierr = ierr_HIER2 + endif endif else if (iexist) then print "(1x,a)",'WARNING: set_multiple: deleting an existing HIERARCHY file.' - open(1, file=trim(filename), status='old') - close(1, status='delete') + open(1,file=trim(filename),status='old') + close(1,status='delete') endif mtot = m1 + m2 period = sqrt(4.*pi**2*semimajoraxis**3/mtot) - open(1, file = trim(filename), status = 'new') + open(1,file=trim(filename),status='new') if (present(incl)) then if (present(posang_ascnode) .and. present(arg_peri)) then write(1,*) 1, 11, m1, m2, semimajoraxis, eccentricity, period, incl, arg_peri, posang_ascnode @@ -535,75 +537,78 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & subst_index = 0 !--- Checks to avoid bad substitutions - if (present(subst) .and. subst>10) then - write(hier_prefix, *) subst - io=0 - mtot = 0. - do i=1,lines - if (data(i,2)==abs(subst)) then ! Check that star to be substituted exists in HIERARCHY file - if (data(i,1)==0) then ! Check that star to be substituted has not already been substituted - print "(1x,a)",'ERROR: set_multiple: star '//trim(hier_prefix)//' substituted yet.' - ierr = ierr_subststar - endif - subst_index = int(data(i,1)) - data(i,1) = 0 - - if (subst>0) then - rel_posang_ascnode = data(i, 10) - - if (rel_posang_ascnode /= 0) then - print "(1x,a)",'ERROR: set_multiple: at the moment phantom can subst only Omega=0 binaries.' - ierr = ierr_Omegasubst + if (present(subst)) then + if (subst>10) then + write(hier_prefix, *) subst + io=0 + mtot = 0. + do i=1,lines + if (data(i,2)==abs(subst)) then ! Check that star to be substituted exists in HIERARCHY file + if (data(i,1)==0) then ! Check that star to be substituted has not already been substituted + print "(1x,a)",'ERROR: set_multiple: star '//trim(hier_prefix)//' substituted yet.' + ierr = ierr_subststar + endif + subst_index = int(data(i,1)) + data(i,1) = 0 + + if (subst>0) then + rel_posang_ascnode = data(i, 10) + + if (rel_posang_ascnode /= 0) then + print "(1x,a)",'ERROR: set_multiple: at the moment phantom can subst only Omega=0 binaries.' + ierr = ierr_Omegasubst + endif + + rel_arg_peri= data(i, 9) + rel_incl = data(i, 8) + else + rel_posang_ascnode = posang_ascnode + rel_arg_peri = arg_peri + rel_incl = incl endif - rel_arg_peri= data(i, 9) - rel_incl = data(i, 8) - else - rel_posang_ascnode = posang_ascnode - rel_arg_peri = arg_peri - rel_incl = incl - endif + mtot = data(i, 3) + m_comp = data(i, 4) + a_comp = data(i, 5) + e_comp = data(i, 6) - mtot = data(i, 3) - m_comp = data(i, 4) - a_comp = data(i, 5) - e_comp = data(i, 6) + q_comp = mtot/m_comp + if (q_comp>1) q_comp=q_comp**(-1) - q_comp = mtot/m_comp - if (q_comp>1) q_comp=q_comp**(-1) + ! Mardling & Aarseth (2001) criterion check + period_ratio = sqrt((a_comp*a_comp*a_comp)/(m_comp+mtot)/& + (semimajoraxis*semimajoraxis*semimajoraxis)*(mtot)) ! Po/Pi + criterion = 4.7*(1-e_comp)**(-1.8)*(1+e_comp)**(0.6)*(1+q_comp)**(0.1) - ! Mardling&Aarseth (2001) criterion check + if (criterion > period_ratio) then + print "(1x,a)",'WARNING: set_multiple: orbital parameters do not satisfy '//& + 'Mardling & Aarseth stability criterion.' + endif - period_ratio = sqrt((a_comp*a_comp*a_comp)/(m_comp+mtot)/(semimajoraxis*semimajoraxis*semimajoraxis)*(mtot)) ! Po/Pi - criterion = 4.7*(1-e_comp)**(-1.8)*(1+e_comp)**(0.6)*(1+q_comp)**(0.1) + q2=m2/m1 + mprimary = mtot/(1+q2) + msecondary = mtot*q2/(1+q2) - if (criterion > period_ratio) then - print "(1x,a)",'WARNING: set_multiple: orbital parameters does not satisfy Mardling and Aarseth stability criterion.' + io=1 + exit endif + enddo - q2=m2/m1 - mprimary = mtot/(1+q2) - msecondary = mtot*q2/(1+q2) + if (io == 0) then + print "(1x,a)",'ERROR: set_multiple: star '//trim(hier_prefix)//' not present in HIERARCHY file.' + ierr = ierr_missstar + endif - io=1 - exit + if (subst_index > 0 .and. subst_index <= size(xyzmh_ptmass(1,:))) then ! check for seg fault + x_subst(:)=xyzmh_ptmass(1:3,subst_index) + v_subst(:)=vxyz_ptmass(:,subst_index) endif - enddo + !i1 = subst_index + !i2 = nptmass + 1 + !nptmass = nptmass + 1 - if (io == 0) then - print "(1x,a)",'ERROR: set_multiple: star '//trim(hier_prefix)//' not present in HIERARCHY file.' - ierr = ierr_missstar + period = sqrt(4.*pi**2*semimajoraxis**3/mtot) endif - - if (subst_index > 0 .and. subst_index <= size(xyzmh_ptmass(1,:))) then ! check for seg fault - x_subst(:)=xyzmh_ptmass(1:3,subst_index) - v_subst(:)=vxyz_ptmass(:,subst_index) - endif - !i1 = subst_index - !i2 = nptmass + 1 - !nptmass = nptmass + 1 - - period = sqrt(4.*pi**2*semimajoraxis**3/mtot) else mprimary = m1 msecondary = m2 @@ -620,111 +625,113 @@ subroutine set_multiple(m1,m2,semimajoraxis,eccentricity, & f=f,accretion_radius1=accretion_radius1,accretion_radius2=accretion_radius2, & xyzmh_ptmass=xyzmh_ptmass,vxyz_ptmass=vxyz_ptmass,nptmass=nptmass, ierr=ierr) - if (present(subst) .and. subst>10) then - !--- lower nptmass, copy one of the new sinks to the subst star - nptmass = nptmass-1 - i1 = subst_index - i2 = nptmass + if (present(subst)) then + if (subst>10) then + !--- lower nptmass, copy one of the new sinks to the subst star + nptmass = nptmass-1 + i1 = subst_index + i2 = nptmass - ! positions and accretion radii - xyzmh_ptmass(1:6,i1) = xyzmh_ptmass(1:6,nptmass+1) + ! positions and accretion radii + xyzmh_ptmass(1:6,i1) = xyzmh_ptmass(1:6,nptmass+1) - ! test Jolien + ! test Jolien ! print "(5(2x,a,g12.3,/),2x,a,g12.3)", & ! 'i1 :',i1, & ! 'mass i1:',xyzmh_ptmass(4,i1), & ! 'i2 :',i2, & ! 'mass i2:',xyzmh_ptmass(4,i2) - ! velocities - vxyz_ptmass(:,i1) = vxyz_ptmass(:,nptmass+1) - - !--- - ! Rotate the substituting binary with orientational parameters - ! referring to the substituted star's orbital plane - if (subst>0) then - - omega = rel_arg_peri*pi/180. - !big_omega = rel_posang_ascnode*pi/180.! + 0.5*pi - inc = rel_incl*pi/180. - - ! Retrieve eulerian angles of the substituted star orbit's semi-major axis (y axis) - if (omega <= pi/2) then - beta_y = omega - sign_alpha=-1 - if (inc <= pi) then - sign_gamma=1 + ! velocities + vxyz_ptmass(:,i1) = vxyz_ptmass(:,nptmass+1) + + !--- + ! Rotate the substituting binary with orientational parameters + ! referring to the substituted star's orbital plane + if (subst>0) then + + omega = rel_arg_peri*pi/180. + !big_omega = rel_posang_ascnode*pi/180.! + 0.5*pi + inc = rel_incl*pi/180. + + ! Retrieve eulerian angles of the substituted star orbit's semi-major axis (y axis) + if (omega <= pi/2) then + beta_y = omega + sign_alpha=-1 + if (inc <= pi) then + sign_gamma=1 + else + sign_gamma=-1 + endif else - sign_gamma=-1 + beta_y = 2*pi-omega + sign_alpha=1 + if (inc <= pi) then + sign_gamma=-1 + else + sign_gamma=1 + endif endif - else - beta_y = 2*pi-omega - sign_alpha=1 + gamma_y=acos(sign_gamma*sin(beta_y)*sin(inc)) + alpha_y=acos(sign_alpha*sqrt(abs(sin(beta_y)**2-cos(gamma_y)**2))) ! Needs abs cause float approx for cos + + ! Retrieve eulerian angles of the axis perpendicular to the substituted star orbital plane (z axis) + beta_z = pi/2. + gamma_z = inc + alpha_z = pi/2. - inc if (inc <= pi) then - sign_gamma=-1 - else - sign_gamma=1 + gamma_z=inc + if (inc <= pi/2.) then + alpha_z = pi/2.-inc + elseif (inc > pi/2.) then + alpha_z = inc-pi/2. + endif + elseif (inc < 2.*pi .and. inc > pi) then + gamma_z = 2.*pi-inc + if (inc <= 3.*pi/2.) then + alpha_z = inc-pi/2 + elseif (inc > 3.*pi/2.) then + alpha_z = 5.*pi/2.-inc + endif endif - endif - gamma_y=acos(sign_gamma*sin(beta_y)*sin(inc)) - alpha_y=acos(sign_alpha*sqrt(abs(sin(beta_y)**2-cos(gamma_y)**2))) ! Needs abs cause float approx for cos - ! Retrieve eulerian angles of the axis perpendicular to the substituted star orbital plane (z axis) - beta_z = pi/2. - gamma_z = inc - alpha_z = pi/2. - inc - if (inc <= pi) then - gamma_z=inc - if (inc <= pi/2.) then - alpha_z = pi/2.-inc - elseif (inc > pi/2.) then - alpha_z = inc-pi/2. - endif - elseif (inc < 2.*pi .and. inc > pi) then - gamma_z = 2.*pi-inc - if (inc <= 3.*pi/2.) then - alpha_z = inc-pi/2 - elseif (inc > 3.*pi/2.) then - alpha_z = 5.*pi/2.-inc - endif + ! Rotate substituting sinks by argument of pericenter around the z axis + call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, arg_peri*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, arg_peri*pi/180) + call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, arg_peri*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, arg_peri*pi/180) + + ! Rotate substituting sinks by inclination around the y axis + call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_y,beta_y,gamma_y, incl*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i1),alpha_y,beta_y,gamma_y, incl*pi/180) + call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_y,beta_y,gamma_y, incl*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i2),alpha_y,beta_y,gamma_y, incl*pi/180) + + ! Rotate substituting sinks by ascending node longitude around the z axis + call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) + call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) + call gen_rotate(vxyz_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) endif - ! Rotate substituting sinks by argument of pericenter around the z axis - call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, arg_peri*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, arg_peri*pi/180) - call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, arg_peri*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, arg_peri*pi/180) - - ! Rotate substituting sinks by inclination around the y axis - call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_y,beta_y,gamma_y, incl*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i1),alpha_y,beta_y,gamma_y, incl*pi/180) - call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_y,beta_y,gamma_y, incl*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i2),alpha_y,beta_y,gamma_y, incl*pi/180) - - ! Rotate substituting sinks by ascending node longitude around the z axis - call gen_rotate(xyzmh_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i1),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) - call gen_rotate(xyzmh_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) - call gen_rotate(vxyz_ptmass(1:3,i2),alpha_z,beta_z,gamma_z, posang_ascnode*pi/180) - endif - - ! Move the substituting binary's center of mass in the substituted star position - xyzmh_ptmass(1:3,i1) = xyzmh_ptmass(1:3,i1)+x_subst - xyzmh_ptmass(1:3,i2) = xyzmh_ptmass(1:3,i2)+x_subst - ! Set the substituting binary's center of mass velocity - vxyz_ptmass(:,i1) = vxyz_ptmass(:,i1)+v_subst - vxyz_ptmass(:,i2) = vxyz_ptmass(:,i2)+v_subst - - ! Write updated HIERARCHY file with the two new stars and the substituted one - open(1, file = trim(filename), status = 'old') - do i=1,lines - write(1,*) int(data(i,1)), int(data(i,2)), data(i,3:) - enddo - write(1,*) i1, trim(hier_prefix)//"1", mprimary, msecondary, semimajoraxis, eccentricity, & + ! Move the substituting binary's center of mass in the substituted star position + xyzmh_ptmass(1:3,i1) = xyzmh_ptmass(1:3,i1)+x_subst + xyzmh_ptmass(1:3,i2) = xyzmh_ptmass(1:3,i2)+x_subst + ! Set the substituting binary's center of mass velocity + vxyz_ptmass(:,i1) = vxyz_ptmass(:,i1)+v_subst + vxyz_ptmass(:,i2) = vxyz_ptmass(:,i2)+v_subst + + ! Write updated HIERARCHY file with the two new stars and the substituted one + open(1,file=trim(filename),status='old') + do i=1,lines + write(1,*) int(data(i,1)), int(data(i,2)), data(i,3:) + enddo + write(1,*) i1, trim(hier_prefix)//"1", mprimary, msecondary, semimajoraxis, eccentricity, & period, incl, arg_peri, posang_ascnode - write(1,*) i2, trim(hier_prefix)//"2", msecondary, mprimary, semimajoraxis, eccentricity, & + write(1,*) i2, trim(hier_prefix)//"2", msecondary, mprimary, semimajoraxis, eccentricity, & period, incl, arg_peri, posang_ascnode - close(1) + close(1) + endif endif end subroutine set_multiple diff --git a/src/setup/set_hierarchical_utils.f90 b/src/setup/set_hierarchical_utils.f90 index 50aa1866e..6921d5daa 100644 --- a/src/setup/set_hierarchical_utils.f90 +++ b/src/setup/set_hierarchical_utils.f90 @@ -247,10 +247,10 @@ subroutine load_hierarchy_file(prefix, data, lines, ierr) inquire(file=trim(filename), exist=iexist) if (iexist) then - open(2, file = trim(filename), status = 'old') + open(2,file=trim(filename),status='old') lines=0 do - read(2, *, iostat=io) data(lines+1,:) + read(2, *,iostat=io) data(lines+1,:) if (io/=0) exit lines = lines + 1 enddo @@ -301,7 +301,7 @@ subroutine update_hierarchy_file(prefix, hs, data, lines, hier_prefix, i1, i2, i endif if (lines > 0) then - open(newunit=iu, file = trim(filename), status = 'old') + open(newunit=iu,file=trim(filename),status='old') do i=1,lines write(iu,*) int(data(i,1)), int(data(i,2)), data(i,3:) enddo @@ -309,7 +309,7 @@ subroutine update_hierarchy_file(prefix, hs, data, lines, hier_prefix, i1, i2, i inquire(file=trim(filename), exist=iexist) if (iexist) print "(1x,a)",'WARNING: set_multiple: deleting an existing HIERARCHY file.' - open(newunit=iu, file = trim(filename), status = 'replace') + open(newunit=iu,file=trim(filename),status='replace') endif write(iu,*) i1, trim(hier_prefix)//"1", mprimary, msecondary, semimajoraxis, eccentricity, & period, incl, arg_peri, posang_ascnode @@ -462,7 +462,7 @@ subroutine find_hierarchy_index(level, int_sinks, inner_sinks_num, prefix) character(len=10) :: label = ' ' - read(level, *, iostat=io) h_index + read(level, *,iostat=io) h_index call load_hierarchy_file(prefix, data, lines, ierr) diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index 6940ad2aa..23a25885d 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -29,6 +29,21 @@ module setorbit ! :Dependencies: infile_utils, physcon, setbinary, setflyby, units ! +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils, physcon, setbinary, setflyby, units +! + ! While Campbell elements can be used for unbound orbits, they require ! specifying the true anomaly at the start of the simulation. This is ! not always easy to determine, so the flyby option is provided as an diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index fa316c63f..cea8982c8 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -15,7 +15,9 @@ module setstar ! ! :Owner: Daniel Price ! -! :Runtime parameters: None +! :Runtime parameters: +! - nstars : *number of stars to add (0-'//achar(size(star)+48)//')* +! - relax : *relax stars into equilibrium* ! ! :Dependencies: centreofmass, dim, eos, extern_densprofile, infile_utils, ! io, mpiutils, part, physcon, prompting, radiation_utils, relaxstar, @@ -50,11 +52,18 @@ module setstar end type star_t public :: star_t - public :: set_star,set_defaults_star,shift_star - public :: write_options_star,read_options_star,set_star_interactive + public :: set_star,set_stars + public :: set_defaults_star,set_defaults_stars + public :: shift_star,shift_stars + public :: write_options_star,write_options_stars + public :: read_options_star,read_options_stars + public :: set_star_interactive public :: ikepler,imesa,ibpwpoly,ipoly,iuniform,ifromfile,ievrard public :: need_polyk + integer, parameter :: istar_offset = 3 ! offset for particle type to distinguish particles + ! placed in stars from other particles in the simulation + private contains @@ -91,6 +100,21 @@ subroutine set_defaults_star(star) end subroutine set_defaults_star +!-------------------------------------------------------------------------- +!+ +! same as above but does it for multiple stars +!+ +!-------------------------------------------------------------------------- +subroutine set_defaults_stars(stars) + type(star_t), intent(out) :: stars(:) + integer :: i + + do i=1,size(stars) + call set_defaults_star(stars(i)) + enddo + +end subroutine set_defaults_stars + !-------------------------------------------------------------------------- !+ ! Master routine to setup a star from a specified file or density profile @@ -132,7 +156,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& integer, intent(out) :: ierr real, intent(in), optional :: x0(3),v0(3) integer, intent(in), optional :: itype - procedure(mask_prototype) :: mask + 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(:) @@ -278,7 +302,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& ! if (present(itype)) then do i=npart_old+1,npart - call set_particle_type(i,itype) + call set_particle_type(i,itype+istar_offset) enddo endif ! @@ -318,6 +342,46 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& end subroutine set_star +!-------------------------------------------------------------------------- +!+ +! As above but loops over all stars +!+ +!-------------------------------------------------------------------------- +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,& + relax,use_var_comp,write_rho_to_file,& + rhozero,npart_total,mask,ierr) + use unifdis, only:mask_prototype + type(star_t), intent(inout) :: star(:) + integer, intent(in) :: id,master,nstars + integer, intent(inout) :: npart,npartoftype(:),nptmass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),eos_vars(:,:),rad(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(inout) :: massoftype(:) + 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(in) :: X_in,Z_in + real, intent(out) :: rhozero + integer(kind=8), intent(out) :: npart_total + integer, intent(out) :: ierr + procedure(mask_prototype) :: mask + integer :: i + + 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,& + X_in,Z_in,relax,use_var_comp,write_rho_to_file,& + rhozero,npart_total,mask,ierr,itype=i) + endif + enddo + +end subroutine set_stars + !----------------------------------------------------------------------- !+ ! shift star to the desired position and velocity @@ -347,13 +411,14 @@ subroutine shift_star(npart,xyz,vxyz,x0,v0,itype,corotate) omega = L/dot_product(rcyl,rcyl) print*,'Adding spin to star: omega = ',omega endif + if (present(itype)) print "(a,i0,a,2(es10.3,','),es10.3,a)",' MOVING STAR ',itype,' to (x,y,z) = (',x0(1:3),')' over_parts: do i=1,npart if (present(itype)) then ! get type of current particle call get_particle_type(i,mytype) ! skip particles that do not match the specified type - if (mytype /= itype) cycle over_parts + if (mytype /= itype+istar_offset) cycle over_parts ! reset type back to gas call set_particle_type(i,igas) endif @@ -367,6 +432,39 @@ subroutine shift_star(npart,xyz,vxyz,x0,v0,itype,corotate) end subroutine shift_star +!----------------------------------------------------------------------- +!+ +! As above but 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,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 + logical, intent(in), optional :: corotate + integer :: i + logical :: do_corotate + + do_corotate = .false. + if (present(corotate)) do_corotate = corotate + + 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),& + v0=vxyz_ptmass_in(1:3,i),itype=i,corotate=do_corotate) + else + nptmass = nptmass + 1 + xyzmh_ptmass(:,nptmass) = xyzmh_ptmass_in(:,i) + vxyz_ptmass(:,nptmass) = vxyz_ptmass_in(:,i) + endif + enddo + +end subroutine shift_stars + !----------------------------------------------------------------------- !+ ! print a distance in both code units and physical units @@ -674,6 +772,7 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) 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 ! set defaults call set_defaults_star(star) @@ -703,18 +802,18 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) 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.) - star%lcore = lcore_lsun*real(solarl/unit_luminosity) + 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 if (star%isinkcore) then - call read_inopt(mcore_msun,'mcore'//trim(c),db,errcount=nerr,min=0.) - star%mcore = mcore_msun*real(solarm/umass) - call read_inopt(hsoft_rsun,'hsoft'//trim(c),db,errcount=nerr,min=0.) - star%hsoft = hsoft_rsun*real(solarr/udist) + 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) endif else call read_inopt(star%outputfilename,'outputfilename'//trim(c),db,errcount=nerr) @@ -725,13 +824,13 @@ 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.) - star%rcore = rcore_rsun*real(solarr/udist) + 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) 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.) - star%mcore = mcore_msun*real(solarm/umass) + 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) endif endif case(ievrard) @@ -745,15 +844,94 @@ 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.) - star%mstar = mstar_msun*real(solarm/umass) + 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) if (need_rstar(star%iprofile)) then - call read_inopt(rstar_rsun,'Rstar'//trim(c),db,errcount=nerr,min=0.) - star%rstar = rstar_rsun*real(solarr/udist) + 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) endif endif endif end subroutine read_options_star +!----------------------------------------------------------------------- +!+ +! write_options routine that writes options for multiple stars +!+ +!----------------------------------------------------------------------- +subroutine write_options_stars(star,relax,iunit,nstar) + use relaxstar, only:write_options_relax + use infile_utils, only:write_inopt + type(star_t), intent(in) :: star(:) + integer, intent(in) :: iunit + logical, intent(in) :: relax + integer, intent(in), optional :: nstar + integer :: i,nstars + + ! 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) + nstars = nstar + else + nstars = size(star) + endif + + ! write options for each star + do i=1,nstars + call write_options_star(star(i),iunit,label=achar(i+48)) + enddo + + ! write relaxation options if any stars are made of gas + if (nstars > 0) then + if (any(star(1:nstars)%iprofile > 0)) then + write(iunit,"(/,a)") '# relaxation options' + call write_inopt(relax,'relax','relax stars into equilibrium',iunit) + call write_options_relax(iunit) + endif + endif + +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) + 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 + integer :: i,nstars + + ! optionally ask for number of stars + if (present(nstar)) then + call read_inopt(nstar,'nstars',db,nerr,min=0,max=size(star)) + nstars = nstar + else + nstars = size(star) + 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)) + 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) + endif + endif + +end subroutine read_options_stars + end module setstar diff --git a/src/setup/set_unifdis.f90 b/src/setup/set_unifdis.f90 index b4dece1de..782d6c3af 100644 --- a/src/setup/set_unifdis.f90 +++ b/src/setup/set_unifdis.f90 @@ -56,7 +56,6 @@ subroutine set_unifdis(lattice,id,master,xmin,xmax,ymin,ymax, & nptot,npy,npz,npnew_in,rhofunc,massfunc,inputiseed,verbose,centre,dir,geom,mask,err) use random, only:ran2 use stretchmap, only:set_density_profile - !use mpidomain, only:i_belong character(len=*), intent(in) :: lattice integer, intent(in) :: id,master integer, intent(inout) :: np diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 28a0efac9..0b6c87bd5 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -13,28 +13,21 @@ module setup ! :Owner: Daniel Price ! ! :Runtime parameters: -! - O : *position angle of ascending node (deg)* -! - a : *semi-major axis (e.g. 1 au), period (e.g. 10*days) or rp if e=1* -! - corotate : *set stars in corotation* -! - eccentricity : *eccentricity* -! - f : *initial true anomaly (180=apoastron)* -! - inc : *inclination (deg)* -! - relax : *relax stars into equilibrium* -! - w : *argument of periapsis (deg)* +! - corotate : *set stars in corotation* ! ! :Dependencies: centreofmass, dim, eos, externalforces, infile_utils, io, -! mpidomain, options, part, physcon, relaxstar, setbinary, setstar, -! setunits, setup_params, units +! kernel, mpidomain, options, part, physcon, setorbit, setstar, setunits, +! setup_params ! - use setstar, only:star_t + use setstar, only:star_t + use setorbit, only:orbit_t use dim, only:gr implicit none public :: setpart - real :: a,ecc,inc,O,w,f logical :: relax,corotate - type(star_t) :: star(2) - character(len=20) :: semi_major_axis + type(star_t) :: star(2) + type(orbit_t) :: orbit private @@ -49,19 +42,18 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& polyk,gamma,hfact,time,fileprefix) use part, only:gr,nptmass,xyzmh_ptmass,vxyz_ptmass,& ihacc,ihsoft,eos_vars,rad,nsinkproperties,iJ2,iReff,ispinx,ispinz - use setbinary, only:set_binary,get_a_from_period - use units, only:is_time_unit,in_code_units,utime - use physcon, only:solarm,au,pi,solarr,days + use setorbit, only:set_defaults_orbit,set_orbit use options, only:iexternalforce use externalforces, only:iext_corotate,iext_geopot,iext_star,omega_corotate,mass1,accradius1 use io, only:master,fatal - use setstar, only:set_star,set_defaults_star,shift_star + use setstar, only:set_defaults_stars,set_stars,shift_stars use eos, only:X_in,Z_in,ieos use setup_params, only:rhozero,npart_total use mpidomain, only:i_belong use centreofmass, only:reset_centreofmass use setunits, only:mass_unit,dist_unit use physcon, only:deg_to_rad + use kernel, only:hfact_default integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -72,9 +64,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& character(len=20), intent(in) :: fileprefix real, intent(out) :: vxyzu(:,:) character(len=120) :: filename - integer :: ierr,i,nstar,nptmass_in,iextern_prev + 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 + logical, parameter :: set_oblateness = .false. ! !--general parameters ! @@ -83,6 +76,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& time = 0. polyk = 0. gamma = 1. + hfact = hfact_default ! !--space available for injected gas particles ! in case only sink particles are used @@ -95,18 +89,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& vxyzu(:,:) = 0. nptmass = 0 nstar = 2 - do i=1,nstar - call set_defaults_star(star(i)) - enddo + call set_defaults_stars(star) + call set_defaults_orbit(orbit) relax = .true. corotate = .false. - semi_major_axis = '10.' - a = 10. - ecc = 0. - inc = 0. - O = 0. - w = 270. - f = 180. ieos = 2 if (id==master) print "(/,65('-'),1(/,a),/,65('-'),/)",& @@ -130,54 +116,27 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& iextern_prev = iexternalforce iexternalforce = 0 gamma = 5./3. - do i=1,nstar - 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,& - X_in,Z_in,relax,use_var_comp,write_profile,& - rhozero,npart_total,i_belong,ierr,itype=i) - endif - enddo + call set_stars(id,master,nstar,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) - ! - !--if a is negative or is given time units, interpret this as a period - ! - a = in_code_units(semi_major_axis,ierr) - if (is_time_unit(semi_major_axis) .and. ierr == 0) then - a = -abs(a) - print "(a,g0,a,g0,a)",' Using PERIOD = ',abs(a),' = ',abs(a)*utime/days,' days' - endif - if (a < 0.) a = get_a_from_period(star(1)%mstar,star(2)%mstar,abs(a)) - ! - !--now setup orbit using fake sink particles - ! nptmass_in = 0 - if (iexternalforce==iext_corotate) then - call set_binary(star(1)%mstar,star(2)%mstar,a,ecc,star(1)%hacc,star(2)%hacc,& - xyzmh_ptmass_in,vxyz_ptmass_in,nptmass_in,ierr,omega_corotate,& - posang_ascnode=O,arg_peri=w,incl=inc,f=f,verbose=(id==master)) - add_spin = .false. ! already in corotating frame + 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) + add_spin = .false. else - call set_binary(star(1)%mstar,star(2)%mstar,a,ecc,star(1)%hacc,star(2)%hacc,& - xyzmh_ptmass_in,vxyz_ptmass_in,nptmass_in,ierr,& - posang_ascnode=O,arg_peri=w,incl=inc,f=f,verbose=(id==master)) + 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) add_spin = corotate endif - if (ierr /= 0) call fatal ('setup_binary','error in call to set_binary') + if (ierr /= 0) call fatal ('setup_binary','error in call to set_orbit') ! !--place stars into orbit, or add real sink particles if iprofile=0 ! - do i=1,nstar - if (star(i)%iprofile > 0) then - call shift_star(npart,xyzh,vxyzu,x0=xyzmh_ptmass_in(1:3,i),& - v0=vxyz_ptmass_in(1:3,i),itype=i,corotate=add_spin) - else - nptmass = nptmass + 1 - xyzmh_ptmass(:,nptmass) = xyzmh_ptmass_in(:,i) - vxyz_ptmass(:,nptmass) = vxyz_ptmass_in(:,i) - endif - enddo + call shift_stars(nstar,star,xyzmh_ptmass_in,vxyz_ptmass_in,xyzh,vxyzu,& + xyzmh_ptmass,vxyz_ptmass,npart,nptmass,corotate=add_spin) ! !--restore options ! @@ -192,7 +151,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& accradius1 = xyzmh_ptmass(ihacc,nptmass+1) xyzmh_ptmass(:,nptmass) = xyzmh_ptmass(:,nptmass+1) vxyz_ptmass(:,nptmass) = vxyz_ptmass(:,nptmass+1) - else + elseif (set_oblateness) then ! set J2 for sink particle 1 to be equal to oblateness of Saturn xyzmh_ptmass(iJ2,1) = 0.01629 angle = 30.*deg_to_rad @@ -210,8 +169,8 @@ end subroutine setpart !---------------------------------------------------------------- subroutine write_setupfile(filename) use infile_utils, only:write_inopt - use setstar, only:write_options_star - use relaxstar, only:write_options_relax + use setstar, only:write_options_stars + use setorbit, only:write_options_orbit use setunits, only:write_options_units character(len=*), intent(in) :: filename integer :: iunit @@ -221,23 +180,9 @@ subroutine write_setupfile(filename) write(iunit,"(a)") '# input file for binary setup routines' call write_options_units(iunit,gr) - call write_options_star(star(1),iunit,label='1') - call write_options_star(star(2),iunit,label='2') - - write(iunit,"(/,a)") '# orbit settings' - call write_inopt(semi_major_axis,'a','semi-major axis (e.g. 1 au), period (e.g. 10*days) or rp if e=1',iunit) - call write_inopt(ecc,'ecc','eccentricity',iunit) - call write_inopt(inc,'inc','inclination (deg)',iunit) - call write_inopt(O,'O','position angle of ascending node (deg)',iunit) - call write_inopt(w,'w','argument of periapsis (deg)',iunit) - call write_inopt(f,'f','initial true anomaly (180=apoastron)',iunit) + call write_options_stars(star,relax,iunit) call write_inopt(corotate,'corotate','set stars in corotation',iunit) - - if (any(star(:)%iprofile > 0)) then - write(iunit,"(/,a)") '# relaxation options' - call write_inopt(relax,'relax','relax stars into equilibrium',iunit) - call write_options_relax(iunit) - endif + call write_options_orbit(orbit,iunit) close(iunit) end subroutine write_setupfile @@ -250,8 +195,8 @@ end subroutine write_setupfile subroutine read_setupfile(filename,ieos,polyk,ierr) use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db use io, only:error,fatal - use setstar, only:read_options_star - use relaxstar, only:read_options_relax + use setstar, only:read_options_stars + use setorbit, only:read_options_orbit use setunits, only:read_options_and_set_units character(len=*), intent(in) :: filename integer, intent(inout) :: ieos @@ -265,25 +210,12 @@ 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_star(star(1),need_iso,ieos,polyk,db,nerr,label='1') - call read_options_star(star(2),need_iso,ieos,polyk,db,nerr,label='2') + call read_options_stars(star,need_iso,ieos,polyk,relax,db,nerr) if (need_iso==1) call fatal('setup_binary','incompatible setup for eos') - - call read_inopt(semi_major_axis,'a',db,errcount=nerr) - call read_inopt(ecc,'ecc',db,min=0.,errcount=nerr) - call read_inopt(inc,'inc',db,errcount=nerr) - call read_inopt(O,'O',db,errcount=nerr) - call read_inopt(w,'w',db,errcount=nerr) - call read_inopt(f,'f',db,errcount=nerr) - call read_inopt(corotate,'corotate',db,errcount=nerr) - - if (any(star(:)%iprofile > 0)) then - call read_inopt(relax,'relax',db,errcount=nerr) - call read_options_relax(db,nerr) - endif - + call read_options_orbit(orbit,db,nerr) call close_db(db) + if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' ierr = nerr diff --git a/src/setup/setup_chinchen.f90 b/src/setup/setup_chinchen.f90 index 708700567..66c97168a 100644 --- a/src/setup/setup_chinchen.f90 +++ b/src/setup/setup_chinchen.f90 @@ -34,7 +34,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use physcon, only:solarm,au,pi use options, only:iexternalforce use externalforces, only:iext_binary - use extern_binary, only:mass2 + use extern_binary, only:mass2,mass1 use io, only:master use timestep, only:dtmax integer, intent(in) :: id @@ -79,7 +79,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, vxyz_ptmass(1,1) = 0.489765446 iexternalforce = iext_binary - mass2 = m1 + mass1 = 0.5 + mass2 = mass1 dtmax = 0.1*(9.*pi) end subroutine setpart diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index cd3e60944..36b0d137d 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -112,9 +112,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, dist_fac = 1.0 ! distance code unit: dist_fac * pc endif - !--Set units - call set_units(dist=dist_fac*pc,mass=mass_fac*solarm,G=1.) - if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state !--Read values from .setup @@ -131,6 +128,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call write_setupfile(fileset) endif + !--Set units + call set_units(dist=dist_fac*pc,mass=mass_fac*solarm,G=1.) + !--Define remaining variables using the inputs polyk = kboltz*Temperature/(mu*mass_proton_cgs)*(utime/udist)**2 rmax = Rcloud_pc*(pc/udist) diff --git a/src/setup/setup_galdisc.f90 b/src/setup/setup_galdisc.f90 index e6dbcd55b..37e1ac6c2 100644 --- a/src/setup/setup_galdisc.f90 +++ b/src/setup/setup_galdisc.f90 @@ -175,7 +175,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, totvolH = 4./3.*pi*(5.0*rcyl)**3 !halo galsetupic = 'galsetic.txt' - OPEN(21,file=galsetupic,form='formatted') + open(21,file=galsetupic,form='formatted') do i=1,5 if (i==1) then read(21,*)sometext,npartoftype(igas) @@ -208,7 +208,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Gas loop totmassG=0. if (yn_gas==1) then - OPEN(24,file='asciifile_G',form='formatted') + open(24,file='asciifile_G',form='formatted') i=1 over_npartG: do while(i <= npartoftype(igas)) read(24,*)xis,yis,zis,mis,vxis,vyis,vzis,phaseis @@ -227,7 +227,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif i=i+1 enddo over_npartG - CLOSE(24) + close(24) massoftype(igas) = totmassG/real( npartoftype(igas)) rhozero3 = totmassG/totvol h3 = hfact*(massoftype(igas) /rhozero3)**(1./3.) @@ -245,7 +245,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Disc loop totmassD=0. if (yn_star==1) then - OPEN(22,file='asciifile_D',form='formatted') + open(22,file='asciifile_D',form='formatted') i= npartoftype(igas) + 1 over_npartS: do while(i <= npartoftype(igas) + npartoftype(istar)) read(22,*)xis,yis,zis,mis,vxis,vyis,vzis,phaseis @@ -264,7 +264,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif i=i+1 enddo over_npartS - CLOSE(22) + close(22) massoftype(istar) = totmassD/real( npartoftype(istar)) rhozero1 = totmassD/totvol h1 = hfact*(massoftype(istar)/rhozero1)**(1./3.) @@ -282,7 +282,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Bulge loop totmassB=0. if (yn_bulge==1) then - OPEN(23,file='asciifile_B',form='formatted') + open(23,file='asciifile_B',form='formatted') i=npartoftype(istar)+npartoftype(igas) + 1 over_npartB: do while(i <=npartoftype(igas)+npartoftype(istar)+npartoftype(ibulge)) read(23,*)xis,yis,zis,mis,vxis,vyis,vzis,phaseis @@ -301,7 +301,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif i=i+1 enddo over_npartB - CLOSE(23) + close(23) massoftype(ibulge) = totmassB/real( npartoftype(ibulge)) rhozero2 = totmassB/totvolB h2 = hfact*(massoftype(ibulge)/rhozero2)**(1./3.) @@ -319,7 +319,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Halo loop totmassH=0. if (yn_halo==1) then - OPEN(23,file='asciifile_H',form='formatted') + open(23,file='asciifile_H',form='formatted') i=npartoftype(ibulge)+npartoftype(istar)+npartoftype(igas) + 1 over_npartH: do while(i <=npartoftype(igas)+npartoftype(istar)+npartoftype(ibulge)+npartoftype(idarkmatter)) read(23,*)xis,yis,zis,mis,vxis,vyis,vzis,phaseis @@ -338,7 +338,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, endif i=i+1 enddo over_npartH - CLOSE(23) + close(23) massoftype(idarkmatter) = totmassH/real( npartoftype(idarkmatter)) rhozero4 = totmassH/totvolH h4 = hfact*(massoftype(idarkmatter)/rhozero4)**(1./3.) @@ -422,7 +422,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, h1 = hfact*(massoftype(1)/rhozero)**(1./3.) - if (TRIM(partdist)=='o') then + if (trim(partdist)=='o') then !--Loop for pseudo-random placement (from observed distribution) print "(a)",' Realistic gas distribution requires location of CDF(r) files:' itot=0 diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index e6fa50dc4..ed22b212c 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -29,17 +29,23 @@ module setup ! - spin : *spin parameter of black hole |a|<1* ! - theta : *inclination of disc (degrees)* ! -! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, -! io, kernel, metric, options, part, physcon, prompting, setdisc, +! :Dependencies: dim, eos, extern_lensethirring, externalforces, +! infile_utils, io, kernel, metric, mpidomain, options, part, physcon, +! prompting, setdisc, setorbit, setstar, setunits, setup_params, ! timestep, units ! - use options, only:alpha + use options, only:alpha + use setstar, only:star_t + use setorbit, only:orbit_t implicit none public :: setpart real, private :: mhole,mdisc,r_in,r_out,r_ref,spin,honr,theta,p_index,q_index,accrad,gamma_ad - integer, private :: np - logical, private :: ismooth + integer, private :: np,nstars + logical, private :: ismooth,relax + integer, parameter :: max_stars = 10 + type(star_t), private :: star(max_stars) + type(orbit_t),private :: orbit(max_stars) private @@ -52,10 +58,10 @@ module setup !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) use setdisc, only:set_disc - use part, only:igas + use part, only:igas,nsinkproperties,eos_vars,rad,xyzmh_ptmass,vxyz_ptmass,nptmass use io, only:master use externalforces, only:accradius1,accradius1_hard - use options, only:iexternalforce,alphau,iexternalforce + use options, only:iexternalforce,alphau,iexternalforce,ipdv_heating,ishock_heating use units, only:set_units,umass use physcon, only:solarm,pi #ifdef GR @@ -66,8 +72,13 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, #endif use prompting, only:prompt use timestep, only:tmax,dtmax - use eos, only:ieos + use eos, only:ieos,use_var_comp,X_in,Z_in use kernel, only:hfact_default + use setstar, only:shift_star,set_stars + use setorbit, only:set_defaults_orbit,set_orbit + use setunits, only:mass_unit + use mpidomain, only:i_belong + use setup_params, only:rhozero integer, intent(in) :: id integer, intent(out) :: npart integer, intent(out) :: npartoftype(:) @@ -78,13 +89,16 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real, intent(inout) :: time character(len=20), intent(in) :: fileprefix character(len=120) :: filename - integer :: ierr - logical :: iexist + integer :: ierr,nptmass_in,i + integer(kind=8) :: npart_total + logical :: iexist,write_profile real :: cs2 + 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 @@ -99,7 +113,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! Set default problem parameters ! - + mass_unit = '1e6*solarm' mhole = 1.e6 ! (solarm) mdisc = 10. ! (solarm) r_in = 4. ! (GM/c^2) @@ -112,14 +126,25 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, theta = 3. ! inclination angle (degrees) p_index= 1.5 q_index= 0.75 - gamma_ad= 1.001 + gamma_ad= 5./3. np = 1e6 accrad = 4. ! (GM/c^2) + accradius1 = accrad + gamma = gamma_ad + ! default units + call set_units(G=1.,c=1.,mass=mhole*solarm) ! Set central mass to M=1 in code units + + ! stars + nstars = 0 + do i=1,size(orbit) + call set_defaults_orbit(orbit(i)) + enddo + relax = .true. ! !-- Read runtime parameters from setup file ! - if (id==master) print "(/,65('-'),1(/,a),/,65('-'),/)",'Disc setup' + 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) @@ -186,7 +211,36 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, npartoftype(1) = npart - return + ! + ! 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,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 **' + end subroutine setpart @@ -195,12 +249,18 @@ end subroutine setpart ! subroutine write_setupfile(filename) 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, 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 grdisc setup' + call write_options_units(iunit,gr=.true.) + + write(iunit,"(/,a)") '# disc parameters' call write_inopt(mhole ,'mhole' ,'mass of black hole (solar mass)' , iunit) call write_inopt(mdisc ,'mdisc' ,'mass of disc (solar mass)' , iunit) call write_inopt(r_in ,'r_in' ,'inner edge of disc (GM/c^2, code units)' , iunit) @@ -216,6 +276,12 @@ subroutine write_setupfile(filename) call write_inopt(gamma_ad,'gamma' ,'adiabatic gamma' , iunit) call write_inopt(accrad ,'accrad' ,'accretion radius (GM/c^2, code units)' , iunit) call write_inopt(np ,'np' ,'number of particles in disc' , iunit) + + write(iunit,"(/,a)") '# stars' + call write_options_stars(star,relax,iunit,nstar=nstars) + do i=1,nstars + call write_options_orbit(orbit(i),iunit,label=achar(i+48)) + enddo close(iunit) end subroutine write_setupfile @@ -223,16 +289,21 @@ end subroutine write_setupfile 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_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 integer, parameter :: iunit = 21 - integer :: nerr + integer :: nerr,need_iso,i type(inopts), allocatable :: db(:) print "(a)",'reading setup options from '//trim(filename) nerr = 0 ierr = 0 call open_db_from_file(db,filename,iunit,ierr) + call read_options_and_set_units(db,nerr,gr=.true.) call read_inopt(mhole ,'mhole' ,db,min=0.,errcount=nerr) call read_inopt(mdisc ,'mdisc' ,db,min=0.,errcount=nerr) call read_inopt(r_in ,'r_in' ,db,min=0.,errcount=nerr) @@ -248,6 +319,10 @@ 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) + do i=1,nstars + call read_options_orbit(orbit(i),db,nerr,label=achar(i+48)) + enddo call close_db(db) if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index a6d04d9ef..65df28533 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -22,8 +22,9 @@ module setup ! - theta : *inclination of orbit (degrees)* ! ! :Dependencies: eos, externalforces, gravwaveutils, infile_utils, io, -! kernel, metric, mpidomain, part, physcon, relaxstar, setbinary, -! setstar, setup_params, timestep, units, vectorutils +! kernel, metric, mpidomain, options, part, physcon, relaxstar, +! setbinary, setstar, setup_params, systemutils, timestep, units, +! vectorutils ! use setstar, only:star_t implicit none @@ -45,7 +46,7 @@ module setup !---------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas,& - gravity,eos_vars,rad + gravity,eos_vars,rad,gr use setbinary, only:set_binary use setstar, only:set_star,shift_star use units, only:set_units,umass,udist @@ -60,6 +61,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use vectorutils, only:rotatevec use gravwaveutils, only:theta_gw,calc_gravitwaves use setup_params, only:rhozero,npart_total + use systemutils, only:get_command_option + use options, only:iexternalforce integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -70,7 +73,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, character(len=20), intent(in) :: fileprefix real, intent(out) :: vxyzu(:,:) character(len=120) :: filename - integer :: ierr + integer :: ierr,np_default logical :: iexist,write_profile,use_var_comp real :: rtidal,rp,semia,period,hacc1,hacc2 real :: vxyzstar(3),xyzstar(3) @@ -100,7 +103,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, 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 - star%np = 1e6 + 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 beta = 5. ecc = 0.8 @@ -109,7 +113,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, theta = 0. write_profile = .false. use_var_comp = .false. - relax = .false. + relax = .true. ! !-- Read runtime parameters from setup file ! @@ -226,6 +230,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, theta_gw = -theta*180./pi endif + if (.not.gr) iexternalforce = 1 + if (npart == 0) call fatal('setup','no particles setup') if (ierr /= 0) call fatal('setup','ERROR during setup') diff --git a/src/utils/analysis_CoM.f90 b/src/utils/analysis_CoM.f90 index 199caa247..b50fa4f5c 100644 --- a/src/utils/analysis_CoM.f90 +++ b/src/utils/analysis_CoM.f90 @@ -40,7 +40,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! ! Open file (appendif exists) ! - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_com.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_com.dat' inquire(file=fileout,exist=iexist) if ( .not.iexist .or. firstcall ) then firstcall = .false. diff --git a/src/utils/analysis_angmom.f90 b/src/utils/analysis_angmom.f90 index f27a87c2c..ce25dbc04 100644 --- a/src/utils/analysis_angmom.f90 +++ b/src/utils/analysis_angmom.f90 @@ -88,7 +88,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) ! Write angular momentum information if (first) then first = .false. - open(newunit=iu, file='angmom.ev',status='replace') + open(newunit=iu,file='angmom.ev',status='replace') write(iu,"('#',5(1x,'[',i2.2,1x,a11,']',2x))") & 1,'time',& 2,'L_{gas}', & @@ -96,7 +96,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) 4,'L_{spin}', & 5,'L_{total}' else - open(newunit=iu, file='angmom.ev',position='append') + open(newunit=iu,file='angmom.ev',position='append') endif write(iu,'(6(es18.10,1X))') time*utime/years,Ltot_mag*unit_angmom,Lsink_mag*unit_angmom,& Lspin_mag*unit_angmom,L_total_mag*unit_angmom diff --git a/src/utils/analysis_angmomvec.f90 b/src/utils/analysis_angmomvec.f90 index 31c6d6c3d..eac98cd34 100644 --- a/src/utils/analysis_angmomvec.f90 +++ b/src/utils/analysis_angmomvec.f90 @@ -42,7 +42,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) ! Write angular momentum vector information if (first) then first = .false. - open(unit=iu, file='angmomvec.ev',status='replace') + open(unit=iu,file='angmomvec.ev',status='replace') write(iu,"('#',6(1x,'[',i2.2,1x,a11,']',2x))") & 1,'time',& 2,'Lx', & @@ -51,7 +51,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) 5,'inc', & 6,'rot' else - open(unit=iu, file='angmomvec.ev',position='append') + open(unit=iu,file='angmomvec.ev',position='append') endif write(iu,'(6(es18.10,1X))') time,Lhat,inc,rot close(iu) diff --git a/src/utils/analysis_average_orb_en.f90 b/src/utils/analysis_average_orb_en.f90 index f9c99a3af..c1c99003e 100644 --- a/src/utils/analysis_average_orb_en.f90 +++ b/src/utils/analysis_average_orb_en.f90 @@ -41,14 +41,14 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) if (first) then first = .false. - open(unit=iu, file='orbitalenergy.ev',status='replace') + open(unit=iu,file='orbitalenergy.ev',status='replace') write(iu,"('#',4(1x,'[',i2.2,1x,a11,']',2x))") & 1,'time',& 2,'ekin',& 3,'epot',& 4,'etot' else - open(unit=iu, file='orbitalenergy.ev',position='append') + open(unit=iu,file='orbitalenergy.ev',position='append') endif write(iu,'(4(es18.10,1X))') time,ekin_av,epot_av,e_av close(iu) diff --git a/src/utils/analysis_bzrms.f90 b/src/utils/analysis_bzrms.f90 index e5b6443e2..d8425a483 100644 --- a/src/utils/analysis_bzrms.f90 +++ b/src/utils/analysis_bzrms.f90 @@ -51,7 +51,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) logical :: iexist ! !--Open file (appendif exists) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_bzrms.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_bzrms.dat' inquire(file=fileout,exist=iexist) if ( .not.iexist .or. firstcall ) then firstcall = .false. @@ -83,7 +83,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif ! !--Read the setup file to get the values of interest - filename=trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'.setup' + filename=trim(dumpfile(1:index(dumpfile,'_')-1))//'.setup' inquire(file=filename,exist=iexist) if (iexist) then call read_setupfile(filename,mhd) @@ -95,7 +95,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) endif ! !--Get coefficient values from the .in file - filename=trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'.in' + filename=trim(dumpfile(1:index(dumpfile,'_')-1))//'.in' inquire(file=filename,exist=iexist) C_AD = 0.0 C_HE = 0.0 diff --git a/src/utils/analysis_clumpfind.F90 b/src/utils/analysis_clumpfind.F90 index 697a4e1c1..809036724 100644 --- a/src/utils/analysis_clumpfind.F90 +++ b/src/utils/analysis_clumpfind.F90 @@ -121,11 +121,11 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! Check if a neighbour file is present - neighbourfile = 'neigh_'//TRIM(dumpfile) + neighbourfile = 'neigh_'//trim(dumpfile) inquire(file=neighbourfile,exist = existneigh) if (existneigh) then - print*, 'Neighbour file ', TRIM(neighbourfile), ' found' + print*, 'Neighbour file ', trim(neighbourfile), ' found' call read_neighbours(neighbourfile,npart) else ! If there is no neighbour file, generate the list @@ -146,7 +146,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) allocate(dpoten(npart)) ! Holding array for potential (real*8) - dpoten = DBLE(poten) + dpoten = dble(poten) ! Add potential contribution from all sinks first @@ -219,7 +219,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) over_parts: do l = 1,npart - percent = 100.0*REAL(l)/REAL(npart) + percent = 100.0*real(l)/real(npart) if (percent > percentcount) then write(*,'(I3," % complete")') int(percentcount) @@ -377,7 +377,7 @@ subroutine read_analysis_options(dumpfile) if (inputexist) then print '(a,a,a)', "File ",inputfile, " found: reading analysis options" - open(10,file=inputfile, form='formatted') + open(10,file=inputfile,form='formatted') read(10,*) boundchoice read(10,*) sinkchoice read(10,*) skipchoice @@ -413,7 +413,7 @@ subroutine read_analysis_options(dumpfile) if (skipsmalldumps) skipchoice = 'y' ! Write choices to new inputfile - open(10,file=inputfile, status='new', form='formatted') + open(10,file=inputfile,status='new',form='formatted') write(10,*) boundchoice, " Test clumps for gravitational boundness?" write(10,*) sinkchoice, " Include sinks' contribution to potential?" write(10,*) skipchoice, " Skip small dumps (velocity data missing)?" @@ -465,7 +465,7 @@ subroutine amend_options_file(dumpfile) character(len=*),intent(in) :: dumpfile ! Open the options file, and wind forward to the line of interest - open(10,file='clumpfind.options', form='formatted') + open(10,file='clumpfind.options',form='formatted') read(10,*) read(10,*) read(10,*) @@ -979,7 +979,7 @@ subroutine write_clump_data(nclump,deletedclumps,npart,time,dumpfile,tag) clumpfile = trim(tag)//"_clumpcat_"//trim(dumpfile) - open(10,file=clumpfile, status='unknown') + open(10,file=clumpfile,status='unknown') write(10,*) nclump-deletedclumps, time do iclump=1,nclump @@ -1006,7 +1006,7 @@ subroutine write_clump_data(nclump,deletedclumps,npart,time,dumpfile,tag) if (member(i) > 0) member(i) = clump(member(i))%ID enddo - open(10,file=clumpfile, form='unformatted') + open(10,file=clumpfile,form='unformatted') write(10) (member(i), i=1,npart) close(10) @@ -1033,7 +1033,7 @@ subroutine read_oldclump_data(noldclump,npart,oldtime,olddumpfile,tag) clumpfile = trim(tag)//"_clumpcat_"//trim(olddumpfile) - open(10,file=clumpfile, status='unknown') + open(10,file=clumpfile,status='unknown') read(10,*) noldclump, oldtime allocate(oldclump(noldclump)) @@ -1054,7 +1054,7 @@ subroutine read_oldclump_data(noldclump,npart,oldtime,olddumpfile,tag) allocate(oldmember(npart)) - open(10,file=clumpfile, form='unformatted') + open(10,file=clumpfile,form='unformatted') read(10) (oldmember(i), i=1,npart) close(10) diff --git a/src/utils/analysis_clumpfindWB23.F90 b/src/utils/analysis_clumpfindWB23.F90 index da430b9ff..00e59de56 100644 --- a/src/utils/analysis_clumpfindWB23.F90 +++ b/src/utils/analysis_clumpfindWB23.F90 @@ -687,7 +687,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) !--Write results to file (both all the clumps at the current time, and to the file for each clump) write(filename,'(2a)') trim(dumpfile),'clumps' - open (unit=iunit,file=trim(filename)) + open(unit=iunit,file=trim(filename)) write(iunit,'(a,I6,a,Es18.6)') '#Nclumps = ',nclump,'; Time = ',time write(iunit,"('#',24(1x,'[',i2.2,1x,a11,']',2x))") & 1,'clump ID', & diff --git a/src/utils/analysis_collidingcloudevolution.f90 b/src/utils/analysis_collidingcloudevolution.f90 index 52cfdec52..110cd4842 100644 --- a/src/utils/analysis_collidingcloudevolution.f90 +++ b/src/utils/analysis_collidingcloudevolution.f90 @@ -44,7 +44,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ! ! Initialise values & Open file ! - write(fileout,'(2a)') trim(dumpfile(1:INDEX(dumpfile,'_')-1)),'_MassEvolution.dat' + write(fileout,'(2a)') trim(dumpfile(1:index(dumpfile,'_')-1)),'_MassEvolution.dat' if ( firstcall ) then firstcall = .false. dthresh_cgs(1) = 1.0d-23 diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 new file mode 100644 index 000000000..a527f4b41 --- /dev/null +++ b/src/utils/analysis_common_envelope.f90 @@ -0,0 +1,4494 @@ +!--------------------------------------------------------------------------! +! 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 analysis +! +! Analysis routine for common envelope simulations +! +! :References: None +! +! :Owner: Mike Lau +! +! :Runtime parameters: None +! +! :Dependencies: centreofmass, dim, dust_formation, energies, eos, +! eos_gasradrec, eos_mesa, extern_corotate, io, ionization_mod, kernel, +! mesa_microphysics, part, physcon, prompting, ptmass, setbinary, +! sortutils, table_utils, units, vectorutils +! + + use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,poten,ihsoft,ihacc,& + rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted,& + radprop + use dim, only:do_radiation + use units, only:print_units,umass,utime,udist,unit_ergg,unit_density,& + unit_pressure,unit_velocity,unit_Bfield,unit_energ + use physcon, only:gg,pi,c,Rg + use io, only:fatal + use prompting, only:prompt + use centreofmass, only:get_centreofmass, reset_centreofmass + use energies, only:compute_energies,ekin,etherm,epot,etot + use ptmass, only:get_accel_sink_gas,get_accel_sink_sink + use kernel, only:kernel_softening,radkern,wkern,cnormk + use ionization_mod,only:calc_thermal_energy + use eos, only:equationofstate,ieos,init_eos,X_in,Z_in,gmw,get_spsound,done_init_eos + use eos_gasradrec, only:irecomb + use eos_mesa, only:get_eos_kappa_mesa,get_eos_pressure_temp_mesa,& + get_eos_various_mesa,get_eos_pressure_temp_gamma1_mesa + use setbinary, only:Rochelobe_estimate,L1_point + use sortutils, only:set_r2func_origin,r2func_origin,indexxfunc + use table_utils, only:logspace + implicit none + character(len=20), parameter, public :: analysistype = 'common_envelope' + integer :: analysis_to_perform + integer :: dump_number = 0 + real :: omega_corotate=0,init_radius,rho_surface,gamma + logical, dimension(5) :: switch = .false. + public :: do_analysis + public :: tconv_profile,get_interior_mass ! public = no unused fn warning + public :: planet_destruction,total_dust_mass ! make public to avoid compiler warning + private + +contains + +subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: num,npart,iunit + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real, intent(in) :: particlemass,time + logical :: requires_eos_opts + + !chose analysis type + if (dump_number==0) then + print "(40(a,/))", & + ' 1) Sink separation', & + ' 2) Bound and unbound quantities', & + ' 3) Energies', & + ' 4) Profile from centre of mass', & + ' 5) Roche-lobe utils', & + ' 6) Star stabilisation suite', & + ' 7) Simulation units and particle properties', & + ' 8) Output .divv', & + ' 9) EoS testing', & + '10) Profile of newly unbound particles', & + '11) Sink properties', & + '12) MESA EoS compute total entropy and other average td quantities', & + '13) Gravitational drag on sinks', & + '14) CoM of gas around primary core', & + '15) J-E plane', & + '16) Rotation profile', & + '17) Energy profile', & + '18) Recombination statistics', & + '19) Optical depth profile', & + '20) Particle tracker', & + '21) Unbound ion fraction', & + '22) Optical depth at recombination', & + '23) Envelope binding energy', & + '24) Print dumps number matching separation', & + '25) Companion mass coordinate vs. time', & + '26) Energy histogram',& + '27) Analyse disk',& + '28) Recombination energy vs time',& + '29) Binding energy profile',& + '30) planet_rvm',& + '31) Velocity histogram',& + '32) Unbound temperature',& + '33) Planet mass distribution',& + '34) Planet profile',& + '35) Velocity profile',& + '36) Angular momentum profile',& + '37) Keplerian velocity profile',& + '38) Total dust mass' + analysis_to_perform = 1 + call prompt('Choose analysis type ',analysis_to_perform,1,38) + 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) + + ! List of analysis options that require specifying EOS options + requires_eos_opts = any((/2,3,4,5,6,8,9,10,13,17,18,19,20,21,22,23,26,27,28,29,30,32,38/) == analysis_to_perform) + if (dump_number == 0 .and. requires_eos_opts) call set_eos_options(analysis_to_perform) + + select case(analysis_to_perform) + case(1) !sink separation + call separation_vs_time(time) + case(2) !bound and unbound quantities + call bound_mass(time,npart,particlemass,xyzh,vxyzu) + case(3) !Energies and bound mass + call calculate_energies(time,npart,particlemass,xyzh,vxyzu) + case(4) !Profile from COM (can be used for stellar profile) + call create_profile(time, num, npart, particlemass, xyzh, vxyzu) + case(5) !Mass within roche lobes + call roche_lobe_values(time,npart,particlemass,xyzh,vxyzu) + case(6) !Star stabilisation suite + 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(9) !EoS testing + call eos_surfaces + case(10) !New unbound particle profiles in time + call unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) + case(11) !sink properties + call sink_properties(time,npart,particlemass,xyzh,vxyzu) + case(12) !MESA EoS compute total entropy and other average thermodynamical quantities + call bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) + case(13) !Gravitational drag on sinks + call gravitational_drag(time,npart,particlemass,xyzh,vxyzu) + case(14) + call get_core_gas_com(time,npart,xyzh,vxyzu) + case(15) + call J_E_plane(num,npart,particlemass,xyzh,vxyzu) + case(16) ! Rotation profile + call rotation_profile(time,num,npart,xyzh,vxyzu) + case(17) ! Energy profile + call energy_profile(time,npart,particlemass,xyzh,vxyzu) + case(18) ! Recombination statistics + call recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) + case(19) ! Optical depth profile + call tau_profile(time,num,npart,particlemass,xyzh) + case(20) ! Particle tracker + call track_particle(time,particlemass,xyzh,vxyzu) + case(21) ! Unbound ion fractions + call unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) + case(22) ! Optical depth at recombination + call recombination_tau(time,npart,particlemass,xyzh,vxyzu) + case(23) ! Calculate binding energy outside core + call env_binding_ene(npart,particlemass,xyzh,vxyzu) + case(24) ! Print dump number corresponding to given set of sink-sink separations + call print_dump_numbers(dumpfile) + case(25) ! Companion mass coordinate (spherical mass shells) vs. time + call m_vs_t(time,npart,particlemass,xyzh) + case(26) ! Energy histogram + call energy_hist(time,npart,particlemass,xyzh,vxyzu) + case(27) ! Analyse disk around companion + call analyse_disk(num,npart,particlemass,xyzh,vxyzu) + case(28) ! Recombination energy vs. time + call erec_vs_t(time,npart,particlemass,xyzh) + case(29) ! Binding energy profile + call create_bindingEnergy_profile(time,num,npart,particlemass,xyzh,vxyzu) + case(30) ! Planet coordinates and mass + call planet_rvm(time,particlemass,xyzh,vxyzu) + case(31) ! Velocity histogram + call velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) + case(32) ! Unbound temperatures + call unbound_temp(time,npart,particlemass,xyzh,vxyzu) + case(33) ! Planet mass distribution + call planet_mass_distribution(time,num,npart,xyzh) + case(34) ! Calculate planet profile + call planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) + case(35) ! Velocity profile + call velocity_profile(time,num,npart,particlemass,xyzh,vxyzu) + case(36) ! Angular momentum profile + call angular_momentum_profile(time,num,npart,particlemass,xyzh,vxyzu) + case(37) ! Keplerian velocity profile + call vkep_profile(time,num,npart,particlemass,xyzh,vxyzu) + case(38) !Total dust mass + call total_dust_mass(time,npart,particlemass,xyzh) + end select + !increase dump number counter + dump_number = dump_number + 1 + +end subroutine do_analysis + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!! Analysis routines !!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +subroutine total_dust_mass(time,npart,particlemass,xyzh) + use part, only:nucleation,idK3,idK0,idK1, idJstar + use dust_formation, only:set_abundances, mass_per_H + use physcon, only:atomic_mass_unit + real, intent(in) :: time,particlemass,xyzh(:,:) + integer, intent(in) :: npart + integer :: i,ncols,j + real, dimension(2) :: dust_mass + character(len=17), allocatable :: columns(:) + real, allocatable :: temp(:) !npart + real :: median,mass_factor,grain_size + real, parameter :: a0 = 1.28e-4 !radius of a carbon atom in micron + + call set_abundances !initialize mass_per_H + dust_mass = 0. + ncols = 2 + print *,'size(nucleation,1) = ',size(nucleation,1) + print *,'size(nucleation,2) = ',size(nucleation,2) + allocate(columns(ncols),temp(npart)) + columns = (/'Dust mass [Msun]', & + 'median size [um]'/) + j=0 + mass_factor = 12.*atomic_mass_unit*particlemass/mass_per_H + do i = 1,npart + if (.not. isdead_or_accreted(xyzh(4,i))) then + dust_mass(1) = dust_mass(1) + nucleation(idK3,i) *mass_factor + grain_size = a0*nucleation(idK1,i)/(nucleation(idK0,i)+1.0E-99) !in micron + if (grain_size > a0) then + j = j+1 + temp(j) = grain_size + endif + endif + enddo + + call sort(temp,j) + if (mod(j,2)==0) then !npart + median = (temp(j/2)+temp(j/2+1))/2.0 !(temp(npart/2)+temp(npart/2+1))/2.0 + else + median = (temp(j/2)+temp(j/2+1))/2.0 !temp(npart/2+1) + endif + + dust_mass(2) = median + + call write_time_file('total_dust_mass_vs_time', columns, time, dust_mass, ncols, dump_number) + !after execution of the analysis routine, a file named "total_dust_mass_vs_time.ev" appears + deallocate(columns,temp) + +end subroutine total_dust_mass + +! -------------------------------------------------------------------- +! integer function FindMinimum(): +! This function returns the location of the minimum in the section +! between Start and End. +! -------------------------------------------------------------------- + +integer function FindMinimum(x, Start, Fin) + implicit none + integer, intent(in) :: start, fin + real, dimension(Fin), intent(in) :: x + real :: minimum + integer :: location + integer :: i + + minimum = x(start) ! assume the first is the min + location = start ! record its position + do i = start+1, fin ! start with next elements + if (x(i) < minimum) then ! if x(i) less than the min? + minimum = x(i) ! yes, a new minimum found + location = i ! record its position + endif + enddo + findminimum = location ! return the position +end function FindMinimum + +! -------------------------------------------------------------------- +! subroutine Sort(): +! This subroutine receives an array x() and sorts it into ascending +! order. +! -------------------------------------------------------------------- + +subroutine Sort(x, longitud) + implicit none + integer, intent(in) :: longitud + real, dimension(longitud), intent(inout) :: x + integer :: i + integer :: location + + do i = 1, longitud-1 ! except for the last + location = findminimum(x, i, longitud) ! find min from this to last + call swap(x(i), x(location)) ! swap this and the minimum + enddo +end subroutine Sort + + +!---------------------------------------------------------------- +!+ +! Separation vs. time +!+ +!---------------------------------------------------------------- +subroutine separation_vs_time(time) + real, intent(in) :: time + character(len=17), allocatable :: columns(:) + real :: sink_separation(4,nptmass-1) + integer :: i,ncols + ncols = 4*(nptmass-1) + allocate(columns(ncols)) + + do i=1,(nptmass-1) + call separation_vector(xyzmh_ptmass(1:3,1),xyzmh_ptmass(1:3,i+1),sink_separation(1:4,i)) + + write(columns((i*4)-3), '(A11,I1)') ' x sep. ', i + write(columns((i*4)-2), '(A11,I1)') ' y sep. ', i + write(columns((i*4)-1), '(A11,I1)') ' z sep. ', i + write(columns((i*4)), '(A11,I1)') ' sep. ', i + enddo + + call write_time_file('separation_vs_time', columns, time, sink_separation, ncols, dump_number) + deallocate(columns) +end subroutine separation_vs_time + + +!---------------------------------------------------------------- +!+ +! Output planet position (x,y,z,r) and velocity (vx,vy,vz,|v|) +! relative to core, instantaneous mass according to different +! criteria (m1,m2,m3,m4,m5), max. density, and min. entropy +! +! For small dumps, only (x,y,z,r) and rhomax may be determined. +! All other quantities will be outputted as zero. +!+ +!---------------------------------------------------------------- +subroutine planet_rvm(time,particlemass,xyzh,vxyzu) + use eos, only:entropy + 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, allocatable :: data_cols(:),mass(:),vthreshold(:) + integer :: i,j,ncols,maxrho_ID,ientropy,Nmasks + integer, save :: nplanet + integer, allocatable, save :: planetIDs(:) + logical :: isfulldump + + if (.not. done_init_eos) call fatal("planet_rvm","EOS has not been initialised.") + + ncols = 15 + allocate(data_cols(ncols),columns(ncols)) + columns = (/' x sep', & + ' y sep', & + ' z sep', & + ' sep', & + ' vx', & + ' vy', & + ' vz', & + ' v', & + ' m1', & + ' m2', & + ' m3', & + ' m4', & + ' m5', & + ' rhomax', & + ' smin'/) + + if (dump_number == 0) call get_planetIDs(nplanet,planetIDs) + isfulldump = (vxyzu(4,1) > 0.) + + ! Find highest density and lowest entropy in planet + rhoprev = 0. + maxrho_ID = 1 + smin = huge(0.) + ientropy = 1 + ieos = 2 + gamma = 5./3. + do i = 1,nplanet + rhoi = rhoh(xyzh(4,planetIDs(i)), particlemass) + if (rhoi > rhoprev) then + maxrho_ID = planetIDs(i) + rhoprev = rhoi + endif + + if (isfulldump) then + presi = (gamma-1.)*vxyzu(4,i) + si = entropy(rhoi*unit_density,presi*unit_pressure,gmw,ientropy) + smin = min(smin,si) + endif + enddo + + planet_com = xyzh(1:3,maxrho_ID) + sep = planet_com - xyzmh_ptmass(1:3,1) + + if (isfulldump) then + planet_vel = vxyzu(1:3,maxrho_ID) + vel = planet_vel - vxyz_ptmass(1:3,1) + else + vel = 0. + smin = 0. + endif + + ! Sum planet mass according to criterion + Nmasks = 5 ! Number of velocity thresholds for calculating planet mass + allocate(mass(Nmasks),vthreshold(Nmasks)) + mass = 0. + if (isfulldump) then + Rthreshold = 0.21 ! Radius criterion to be considered part of planet + vthreshold = (/0.1,0.3,0.5,0.7,0.9/) ! Allowed fractional deviation in particle velocity from velocity of densest planet particle + do i = 1,nplanet + sepi = separation(xyzh(1:3,planetIDs(i)), planet_com) + do j = 1,Nmasks + if ( (sepi < Rthreshold) .and. (abs(1. - dot_product(vxyzu(1:3,planetIDs(i)),planet_vel)/& + dot_product(planet_vel,planet_vel)) < vthreshold(j)) ) then ! vi dot vp / vp^2 > threshold + mass(j:Nmasks) = mass(j:Nmasks) + 1. + exit + endif + enddo + enddo + mass = mass * particlemass + endif + + data_cols = (/ sep(1), sep(2), sep(3), distance(planet_com),& + vel(1), vel(2), vel(3), distance(vel),& + mass(1), mass(2), mass(3), mass(4), mass(5), rhoprev, smin /) + call write_time_file('planet_rvm', columns, time, data_cols, ncols, dump_number) + + deallocate(data_cols,columns,mass,vthreshold) + +end subroutine planet_rvm + + +!---------------------------------------------------------------- +!+ +! Output radial distribution of planetary material +!+ +!---------------------------------------------------------------- +subroutine planet_mass_distribution(time,num,npart,xyzh) + integer, intent(in) :: npart,num + real, intent(in) :: time + real, intent(inout) :: xyzh(:,:) + real, allocatable :: rad_part(:),dist_part(:),hist_var(:) + real :: mina,maxa,xyz_origin(3) + character(len=17) :: filename + character(len=100) :: data_formatter,headerline + integer :: i,iu,nbins + integer, save :: nplanet + integer, allocatable, save :: planetIDs(:) + + if (dump_number == 0) call get_planetIDs(nplanet,planetIDs) + + nbins = 1000 ! Radial bins + mina = 0. + maxa = 4.2 + + allocate(rad_part(nplanet),dist_part(nplanet),hist_var(nbins)) + filename = ' planet_m_dist.ev' + xyz_origin = xyzmh_ptmass(1:3,1) + + dist_part = 0. + rad_part = 0. + do i = 1,nplanet + rad_part(i) = separation(xyzh(1:3,planetIDs(i)),xyz_origin) + dist_part(i) = 1. + enddo + + call histogram_setup(rad_part,dist_part,hist_var,nplanet,maxa,mina,nbins,.false.,.false.) + + write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" + if (num == 0) then + open(newunit=iu,file=trim(adjustl(filename)),status='replace') + write(headerline, "(a,i5,a,f5.2,a,f5.2)") "# Planet mass distribution, nbins = ", nbins,", min a = ", mina, ", max a = ", maxa + write(iu, "(a)") headerline + close(unit=iu) + endif + open(newunit=iu,file=trim(adjustl(filename)), position='append') + write(iu,data_formatter) time,hist_var(:) + close(unit=iu) + + deallocate(rad_part,dist_part,hist_var) + +end subroutine planet_mass_distribution + + +!---------------------------------------------------------------- +!+ +! Companion mass coordinate (spherical mass shells) vs. time +!+ +!---------------------------------------------------------------- +subroutine m_vs_t(time,npart,particlemass,xyzh) + integer, intent(in) :: npart + real, intent(in) :: time,particlemass,xyzh(:,:) + character(len=17) :: colname + real :: sinksinksep,mass(1) + integer :: i,k + integer, allocatable :: iorder(:) + + allocate(iorder(npart)) + + call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) ! Order particles by distance from core + call indexxfunc(npart,r2func_origin,xyzh,iorder) + + sinksinksep = separation(xyzmh_ptmass(1:3,1), xyzmh_ptmass(1:3,2)) + do i=1,npart + k = iorder(i) + if (separation(xyzh(1:3,k), xyzmh_ptmass(1:3,1)) > sinksinksep) exit + enddo + + mass = i*particlemass + xyzmh_ptmass(4,1) + write(colname, '(A11)') ' mass coord' + call write_time_file(' m_vs_t',colname,time,mass,1,dump_number) + + deallocate(iorder) + +end subroutine m_vs_t + + +!---------------------------------------------------------------- +!+ +! Bound mass +!+ +!---------------------------------------------------------------- +subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) + use part, only:eos_vars,itemp,radprop + use ptmass, only:get_accel_sink_gas + use vectorutils, only:cross_product3D + integer, intent(in) :: npart + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real :: etoti,ekini,epoti,phii,einti,ethi + real :: E_H2,E_HI,E_HeI,E_HeII + real, save :: Xfrac,Yfrac,Zfrac + real :: rhopart,ponrhoi,spsoundi,tempi,dum1,dum2,dum3 + real, dimension(3) :: rcrossmv + real, dimension(28) :: bound + integer :: i,bound_i,ncols + integer, parameter :: ib=1,ibt=9,ibe=17 + character(len=17), allocatable :: columns(:) + + if (.not. done_init_eos) call fatal("bound_mass","EOS has not been initialised.") + + ncols = 28 + bound = 0. + allocate(columns(ncols)) + columns = (/' b num part', & ! Total bound number of particles + ' b mass', & ! Total bound gas mass + ' b ang mom', & ! Total bound gas angular momentum wrt CoM of entire system + ' b tot en', & ! Total bound energy of gas + ' ub num part', & + ' ub mass', & + ' ub ang mom', & + ' ub tot en', & + ' bt num part', & ! As in comments above, but including thermal energy in criterion + ' bt mass', & + ' bt ang mom', & + ' bt tot en', & + 'ubt num part', & + ' ubt mass', & + ' ubt ang mom', & + ' ubt tot en', & + ' be num part', & + ' be mass', & + ' be ang mom', & + ' be tot en', & + 'ube num part', & + ' ube mass', & + ' ube ang mom', & + ' ube tot en', & + ' HeII bm', & ! Bound mass including recombination energy of HeII + ' HeII+HeI bm', & ! Bound mass including recombination energy of HeII, HeI + ' He+HI bm', & ! Bound mass including recombination energy of HeII, HeI, HI + ' He+HI+H2 bm'/) ! Bound mass including recombination energy of HeII, HeI, HI, H2 + + Zfrac = 0. + if (dump_number == 0) then + if (ieos /= 10 .and. ieos /= 20) then ! For MESA EoS, just use X_in and Z_in from eos module + Xfrac = 0.69843 + Zfrac = 0.01426 + call prompt('Enter hydrogen mass fraction to assume for recombination:',Xfrac,0.,1.) + call prompt('Enter metallicity to assume for recombination:',Zfrac,0.,1.) + else + Xfrac = X_in + Zfrac = Z_in + endif + Yfrac = 1. - Xfrac - Zfrac + endif + + ! Ionisation energies per particle (in code units) + E_H2 = 0.5*Xfrac*0.0022866 * particlemass + E_HI = Xfrac*0.0068808 * particlemass + E_HeI = 0.25*Yfrac*0.012442 * particlemass + E_HeII = 0.25*Yfrac*0.027536 * particlemass + + 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 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)) + 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 + etoti = 0. + epoti = 0. + ekini = 0. + einti = 0. + ethi = 0. + phii = 0. + ponrhoi = 0. + rcrossmv = (/ 0., 0., 0. /) + endif + + ! Bound criterion + if ((epoti + ekini < 0.) .or. isdead_or_accreted(xyzh(4,i))) then + bound_i = ib + else + bound_i = ib + 4 ! Unbound + endif + + bound(bound_i) = bound(bound_i) + 1 + bound(bound_i + 1) = bound(bound_i + 1) + particlemass + bound(bound_i + 2) = bound(bound_i + 2) + distance(rcrossmv) + bound(bound_i + 3) = bound(bound_i + 3) + etoti + + ! Bound criterion INCLUDING thermal energy + if ((epoti + ekini + ethi < 0.) .or. isdead_or_accreted(xyzh(4,i))) then + bound_i = ibt + else + bound_i = ibt + 4 + endif + + bound(bound_i) = bound(bound_i) + 1 + bound(bound_i + 1) = bound(bound_i + 1) + particlemass + bound(bound_i + 2) = bound(bound_i + 2) + distance(rcrossmv) + bound(bound_i + 3) = bound(bound_i + 3) + etoti + + ! Bound criterion using enthalpy + if ((epoti + ekini + ethi + ponrhoi*particlemass < 0.) .or. isdead_or_accreted(xyzh(4,i))) then + bound_i = ibe + else + bound_i = ibe + 4 + endif + + bound(bound_i) = bound(bound_i) + 1 + bound(bound_i + 1) = bound(bound_i + 1) + particlemass + bound(bound_i + 2) = bound(bound_i + 2) + distance(rcrossmv) + bound(bound_i + 3) = bound(bound_i + 3) + etoti + + ! Bound criterion including HeI + HeII ionisation energy + if ((epoti + ekini + ethi + E_HeII < 0.) .or. isdead_or_accreted(xyzh(4,i))) then + bound(25) = bound(25) + particlemass + endif + + ! Bound criterion including HeI + HeII ionisation energy + if ((epoti + ekini + ethi + E_HeII + E_HeI < 0.) .or. isdead_or_accreted(xyzh(4,i))) then + bound(26) = bound(26) + particlemass + endif + + ! Bound criterion including HeI + HeII + HI ionisation energy + if ((epoti + ekini + ethi + E_HeII + E_HeI + E_HI < 0.) .or. isdead_or_accreted(xyzh(4,i))) then + bound(27) = bound(27) + particlemass + endif + + ! Bound criterion including HeI + HeII + HI + H2 ionisation energy + if ((epoti + ekini + ethi + E_HeII + E_HeI + E_HI + E_H2 < 0.) .or. isdead_or_accreted(xyzh(4,i))) then + bound(28) = bound(28) + particlemass + endif + enddo + + call write_time_file('boundunbound_vs_time', columns, time, bound, ncols, dump_number) + deallocate(columns) + +end subroutine bound_mass + + +!---------------------------------------------------------------- +!+ +! Calculate energies +!+ +!---------------------------------------------------------------- +subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) + use vectorutils, only:cross_product3D + 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 :: rhopart,ponrhoi,spsoundi,tempi,r_ij,radvel + real, dimension(3) :: rcrossmv + character(len=17), allocatable :: columns(:) + integer :: i,j,ncols + logical :: inearsink + integer, parameter :: ie_tot = 1 + integer, parameter :: ie_pot = ie_tot + 1 + integer, parameter :: ie_kin = ie_pot + 1 + integer, parameter :: ie_therm = ie_kin + 1 + integer, parameter :: ipot_sink = ie_therm + 1 + integer, parameter :: ikin_sink = ipot_sink + 1 + integer, parameter :: iorb_sink = ikin_sink + 1 + integer, parameter :: iorb_comp = iorb_sink + 1 + integer, parameter :: ipot_env = iorb_comp + 1 + integer, parameter :: ie_env = ipot_env + 1 + integer, parameter :: ikin_bound = ie_env + 1 + integer, parameter :: ikin_unbound = ikin_bound + 1 + integer, parameter :: imass_bound = ikin_unbound + 1 + integer, parameter :: imass_unbound = imass_bound + 1 + integer, parameter :: ipot_pp = imass_unbound + 1 + integer, parameter :: ipot_ps = ipot_pp + 1 + integer, parameter :: ijz_tot = ipot_ps + 1 + integer, parameter :: ijz_bound = ijz_tot + 1 + integer, parameter :: ijz_unbound = ijz_bound + 1 + integer, parameter :: ijz_orb = ijz_unbound + 1 + integer, parameter :: ie_gas = ijz_orb + 1 + integer, parameter :: fallbackmass = ie_gas + 1 + integer, parameter :: fallbackmom = fallbackmass + 1 + real, dimension(fallbackmom) :: encomp + + ncols = 23 + allocate(columns(ncols)) + columns = (/'total energy',& + ' pot energy',& + ' kin energy',& + 'therm energy',& + ' sink pot',& ! does not include sink-gas potential energy + ' sink kin',& + ' sink orb',& ! sink kin + sink pot + ' comp orb',& + ' env pot',& + ' env energy',& + ' bound kin',& + ' unbound kin',& + ' bound mass',& + 'unbound mass',& + ' p-p pot',& + ' p-s pot',& + ' tot ang mom',& + ' b ang mom',& + ' ub ang mom',& + ' orb ang mom',& + ' gas energy',& + ' fallback',& + 'fallback mom'/) + + encomp(5:) = 0. + call compute_energies(time) + ekin = 0. + + do i=1,npart + encomp(ipot_pp) = encomp(ipot_pp) + poten(i) ! poten already includes factor of 1/2 to correct for double counting + encomp(ipot_env) = encomp(ipot_env) + poten(i) + + call cross_product3D(xyzh(1:3,i), particlemass * vxyzu(1:3,i), rcrossmv) + 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) + + encomp(ipot_ps) = encomp(ipot_ps) + particlemass * phii + + phii1 = 0. + call get_accel_sink_gas(1,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,fxi,fyi,fzi,phii1) + encomp(ipot_env) = encomp(ipot_env) + phii1 * particlemass + + do j=1,nptmass + if (xyzmh_ptmass(4,j) > 0.) then + r_ij = separation(xyzmh_ptmass(1:3,j),xyzh(1:3,i)) + if (r_ij < 80.) then + inearsink = .true. + endif + endif + enddo + + 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 (etoti < 0) then + encomp(ikin_bound) = encomp(ikin_bound) + ekini + encomp(imass_bound) = encomp(imass_bound) + particlemass + encomp(ijz_bound) = encomp(ijz_bound) + jz + radvel = dot_product(vxyzu(1:3,i),xyzh(1:3,i)) / distance(xyzh(1:3,i)) + + if (inearsink .eqv. .false.) then + if (radvel < 0.) then + encomp(fallbackmass) = encomp(fallbackmass) + particlemass + encomp(fallbackmom) = encomp(fallbackmom) + particlemass * radvel + endif + endif + + else + encomp(ikin_unbound) = encomp(ikin_unbound) + ekini + encomp(imass_unbound) = encomp(imass_unbound) + particlemass + encomp(ijz_unbound) = encomp(ijz_unbound) + jz + endif + enddo + + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + call cross_product3D(xyzmh_ptmass(1:3,i), xyzmh_ptmass(4,i)*vxyz_ptmass(1:3,i), rcrossmv) + jz = rcrossmv(3) + encomp(ijz_tot) = jz + encomp(ijz_tot) + encomp(ijz_orb) = jz + encomp(ijz_orb) + encomp(ikin_sink) = encomp(ikin_sink) + 0.5 * xyzmh_ptmass(4,i) * distance(vxyz_ptmass(1:3,i))**2 + if (i==2) encomp(iorb_comp) = encomp(iorb_comp) + 0.5 * xyzmh_ptmass(4,i) * distance(vxyz_ptmass(1:3,i))**2 + endif + enddo + + do i=1,nptmass-1 + if (xyzmh_ptmass(4,i) > 0.) then + do j=i+1,nptmass + if (xyzmh_ptmass(4,j) > 0.) then + r_ij = separation(xyzmh_ptmass(1:3,i),xyzmh_ptmass(1:3,j)) + encomp(ipot_sink) = encomp(ipot_sink) - xyzmh_ptmass(4,i) * xyzmh_ptmass(4,j) / r_ij ! Newtonian expression is fine as long as rij > hsofti + hsoftj + if (i==1 .and. j==2) encomp(iorb_comp) = encomp(iorb_comp) - xyzmh_ptmass(4,i) * xyzmh_ptmass(4,j) / r_ij + endif + enddo + endif + enddo + + ekin = encomp(ikin_bound) + encomp(ikin_unbound) + encomp(ikin_sink) + encomp(iorb_sink) = encomp(ipot_sink) + encomp(ikin_sink) + encomp(ie_env) = encomp(ipot_env) + etherm + encomp(ikin_bound) + epot = encomp(ipot_pp) + encomp(ipot_ps) + encomp(ipot_sink) + etot = epot + ekin + etherm + encomp(ie_gas) = encomp(ikin_bound) + encomp(ikin_unbound) + encomp(ipot_ps) + + encomp(ie_tot) = etot + encomp(ie_pot) = epot + encomp(ie_kin) = ekin + encomp(ie_therm) = etherm + + call write_time_file('energy', columns, time, encomp, ncols, dump_number) + deallocate(columns) + +end subroutine calculate_energies + + +!!!!! Create profile !!!!! +subroutine create_profile(time, num, npart, particlemass, xyzh, vxyzu) + integer, intent(in) :: npart, num + real, intent(in) :: time, particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17), allocatable :: columns(:) + real, save :: profile_vector(3) + integer :: ncols + character(len=15) :: name_in + real, allocatable :: profile(:,:) + + if (dump_number == 0) then + profile_vector=(/1.,0.,0./) + call prompt('Would you like simple profiles?', switch(1), .true.) + call prompt('Choose profile vector x-component ',profile_vector(1)) + call prompt('Choose profile vector y-component ',profile_vector(2)) + call prompt('Choose profile vector z-component ',profile_vector(3)) + endif + + if (switch(1)) then + ncols = 8 + else + ncols = 18 + endif + + if (all(profile_vector <= tiny(profile_vector))) then + write(*,*)'Using all particles!' + call stellar_profile(time,ncols,particlemass,npart,xyzh,vxyzu,profile,switch(1)) + write(name_in, "(a)") 'part_profile' + else + write(*,*)'Profile_vector is:',profile_vector + call stellar_profile(time,ncols,particlemass,npart,xyzh,vxyzu,profile,switch(1),profile_vector) + write(name_in, "(a,i1,i1,i1)") 'ray_profile_',int(profile_vector(1:3)) + endif + + allocate(columns(18)) + columns = (/' radius',& + ' mass coord',& + ' azimuth',& + ' density',& + ' velocity',& + ' rad. vel.',& + ' vxy tan.',& + ' omega',& !Simple creates up to here + ' int. energy',& + ' pressure',& + ' sound speed',& + ' temp',& + ' kappa',& + ' mfp',& + ' energy',& + ' HII frac',& + ' HeII frac',& + ' HeIII frac'/) + + call write_file(name_in, 'profile', columns, profile, size(profile(1,:)), ncols, num) + + deallocate(profile,columns) +end subroutine create_profile + + +!!!!! Roche lobe values !!!!! +subroutine roche_lobe_values(time,npart,particlemass,xyzh,vxyzu) + use vectorutils, only:cross_product3D + integer, intent(in) :: npart + real, intent(in) :: time, particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17), allocatable :: columns(:) + integer :: i, j, nFB, nR1T, ncols + integer, parameter :: iRL1 = 1 + integer, parameter :: iMRL1 = 2 + integer, parameter :: iBMRL1 = 3 + integer, parameter :: ijzRL1 = 4 + integer, parameter :: iRL2 = 5 + integer, parameter :: iMRL2 = 6 + integer, parameter :: iBMRL2 = 7 + integer, parameter :: ijzRL2 = 8 + integer, parameter :: iR1 = 9 + integer, parameter :: iR1T = 10 + integer, parameter :: iRej = 11 + integer, parameter :: iMej = 12 + integer, parameter :: iBMej = 13 + integer, parameter :: ijzej = 14 + integer, parameter :: iBjzej = 15 + integer, parameter :: iMF = 16 + integer, parameter :: ijzMF = 17 + integer, parameter :: iDR = 18 + integer, parameter :: iFB = 19 + integer, parameter :: iFBV = 20 + integer, parameter :: iFBJz = 21 + real, dimension(iFBJz) :: MRL + real :: etoti, ekini, einti, epoti, phii, jz + logical, dimension(:), allocatable, save:: transferred + real, save :: m1, m2 + real :: sep, sep1, sep2 + real :: rhovol, rhomass, rhopart, R1, rad_vel, sepCoO + real :: temp_const, ponrhoi, spsoundi, tempi + real, dimension(3) :: rcrossmv, CoO, com_xyz, com_vxyz + real, allocatable :: xyz_a(:,:) + integer :: npart_a, mean_rad_num + integer, allocatable :: iorder(:) + + allocate(iorder(npart),xyz_a(3,npart)) + + MRL = 0. + rhovol = 0. + rhomass = 0. + nFB = 0 + nR1T = 0 + temp_const = (unit_pressure / unit_density) * 1.34 / Rg + + if (dump_number == 0) then + m1 = npart * particlemass + xyzmh_ptmass(4,1) + m2 = xyzmh_ptmass(4,2) + allocate(transferred(npart)) + transferred(1:npart) = .false. + + rho_surface = rhoh(xyzh(4,1), particlemass) + do i=1,npart + rhopart = rhoh(xyzh(4,i), particlemass) + if (rhopart < rho_surface) then + rho_surface = rhopart + endif + enddo + endif + + mean_rad_num = npart / 200 + npart_a = 0 + + do i=1,npart + rhopart = rhoh(xyzh(4,i), particlemass) + if (rhopart > rho_surface) then + if (separation(xyzh(1:3,i), xyzmh_ptmass(1:3,1)) < & + separation(xyzh(1:3,i), xyzmh_ptmass(1:3,2))) then + rhomass = rhomass + particlemass + rhovol = rhovol + particlemass / rhopart + npart_a = npart_a + 1 + xyz_a(1:3,npart_a) = xyzh(1:3,i) + endif + endif + enddo + + call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) + call indexxfunc(npart_a,r2func_origin,xyz_a,iorder) + + R1 = 0 + do i=npart_a-mean_rad_num,npart_a + j = iorder(i) + R1 = R1 + separation(xyz_a(1:3,j),xyzmh_ptmass(1:3,1)) + enddo + + R1 = R1 / real(mean_rad_num) + + sep = separation(xyzmh_ptmass(1:3,1),xyzmh_ptmass(1:3,2)) + MRL(iRL1) = Rochelobe_estimate(m2,m1,sep) + MRL(iRL2) = Rochelobe_estimate(m1,m2,sep) + + !R1 = (3. * rhovol/(4. * pi))**(1./3.) + CoO(1:3) = (xyzmh_ptmass(1:3,1) + xyzmh_ptmass(1:3,2)) / 2. + MRL(iR1) = R1 + MRL(iRej) = separation(CoO(1:3),xyzmh_ptmass(1:3,1)) + R1 + + 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) + + sep1 = separation(xyzmh_ptmass(1:3,1),xyzh(1:3,i)) + sep2 = separation(xyzmh_ptmass(1:3,2),xyzh(1:3,i)) + sepCoO = separation(CoO(1:3),xyzh(1:3,i)) + + call cross_product3D(xyzh(1:3,i)-com_xyz(1:3), particlemass * vxyzu(1:3,i), rcrossmv) + jz = rcrossmv(3) + + if (sep1 < MRL(iRL1)) then + MRL(iMRL1) = MRL(iMRL1) + particlemass + MRL(ijzRL1) = MRL(ijzRL1) + jz + if (etoti < 0) then + MRL(iBMRL1) = MRL(iBMRL1) + particlemass + endif + endif + + if (sep2 < MRL(iRL2)) then + MRL(iMRL2) = MRL(iMRL2) + particlemass + MRL(ijzRL2) = MRL(ijzRL2) + jz + + if (transferred(i) .eqv. .false.) then + MRL(iMF) = MRL(iMF) + particlemass + MRL(ijzMF) = MRL(ijzMF) + jz + transferred(i) = .true. + endif + + if (etoti < 0) then + MRL(iBMRL2) = MRL(iBMRL2) + particlemass + endif + endif + + if ((sep1 - xyzh(4,i) < R1) .and. (sep1 + xyzh(4,i) > R1)) then !!!!FIX THIS + call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) + MRL(iR1T) = MRL(iR1T) + ponrhoi * temp_const + nR1T = nR1T + 1 + endif + + if (sepCoO > MRL(iRej)) then + rad_vel = dot_product(vxyzu(1:3,i),xyzh(1:3,i)) / distance(xyzh(1:3,i)) + + MRL(iMej) = MRL(iMej) + particlemass + MRL(ijzej) = MRL(ijzej) + jz + + if (etoti < 0) then + MRL(iBMej) = MRL(iBMej) + particlemass + MRL(iBjzej) = MRL(iBjzej) + jz + endif + + if (rad_vel < 0) then + MRL(iFB) = MRL(iFB) + particlemass + MRL(iFBV) = MRL(iFBV) + rad_vel + MRL(iFBJz) = MRL(iFBJz) + jz + nFB = nFB + 1 + endif + endif + enddo + + if (nR1T == 0) then + MRL(iR1T) = 0 + else + MRL(iR1T) = MRL(iR1T) / real(nR1T) + endif + + if (nFB == 0) then + MRL(iFBV) = 0 + else + MRL(iFBV) = MRL(iFBV) / real(nFB) + endif + + + + MRL(iMRL1) = MRL(iMRL1) + xyzmh_ptmass(4,1) + MRL(iMRL2) = MRL(iMRL2) + xyzmh_ptmass(4,2) + + MRL(iDR) = (R1 - MRL(iRL1)) / R1 + + call cross_product3D(xyzmh_ptmass(1:3,1) - com_xyz(1:3),xyzmh_ptmass(4,1) * vxyz_ptmass(1:3,1),rcrossmv) + MRL(ijzRL1) = MRL(ijzRL1) + rcrossmv(3) + + call cross_product3D(xyzmh_ptmass(1:3,2) - com_xyz(1:3),xyzmh_ptmass(4,2) * vxyz_ptmass(1:3,2),rcrossmv) + MRL(ijzRL2) = MRL(ijzRL2) + rcrossmv(3) + + m1 = rhomass + xyzmh_ptmass(4,1) + m2 = MRL(iMRL2) + + ncols = 21 + allocate(columns(ncols)) + columns = (/' RL1',& + ' Mass in RL1',& + ' B Mass RL1',& + ' jz in RL1',& + ' RL2',& + ' Mass in RL2',& + ' B Mass RL2',& + ' jz in RL2',& + ' R1',& + ' R1 temp',& + ' R_ejecta',& + 'Mass ejected',& + 'B Mass eject',& + ' jz ejected',& + ' B jz eject',& + ' Mass flow',& + 'Mass flow jz',& + ' R1-RL1/R1',& + ' Fallback',& + 'Fallback vel',& + ' Fallback Jz'/) + + call write_time_file('roche_lobes', columns, time, MRL, ncols, dump_number) + deallocate(columns,iorder) + +end subroutine roche_lobe_values + +!---------------------------------------------------------------- +!+ +! Star stabilisation +!+ +!---------------------------------------------------------------- +subroutine star_stabilisation_suite(time,npart,particlemass,xyzh,vxyzu) + use part, only:fxyzu + use eos, only:equationofstate + integer, intent(in) :: npart + real, intent(in) :: time, particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17), allocatable :: columns(:) + integer :: i,j,k,ncols,mean_rad_num,npart_a + 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 + integer, parameter :: ivoleqrad = 1 + integer, parameter :: idensrad = 2 + integer, parameter :: imassout = 3 + integer, parameter :: imassfracout = 4 + integer, parameter :: ipartrad = 5 + integer, parameter :: ipart2hrad = 6 + integer, parameter :: ipdensrad = 7 + integer, parameter :: ip2hdensrad = 8 + integer, parameter :: ivirialpart = 9 + integer, parameter :: ivirialfluid = 10 + + ncols = 10 + allocate(columns(ncols),star_stability(ncols),iorder(npart),iorder_a(npart)) + columns = (/'vol. eq. rad',& + ' density rad',& + 'mass outside',& + 'frac outside',& + ' part rad',& + ' part 2h rad',& + ' p dens rad',& + 'p2h dens rad',& + 'part. virial',& ! Residual of virial theorem for self-gravitating particles + 'fluid virial'/) ! Residual of virial theorem for fluid + + ! Get order of particles by distance from sink particle core + call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) + call indexxfunc(npart,r2func_origin,xyzh,iorder) + + ! Get density of outermost particle in initial star dump + if (dump_number == 0) then + rho_surface = rhoh(xyzh(4,iorder(npart)), particlemass) + endif + + npart_a = 0 + totvol = 0. + rhovol = 0. + virialpart = 0. + totekin = 0. + totepot = 0. + virialintegral= 0. + do i = 1,npart + 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) + totekin = totekin + ekini + totepot = totepot + 0.5*epoti ! Factor of 1/2 to correct for double counting + if (rhopart > rho_surface) then + ! Sum "volume" of particles within "surface" of initial star dump + rhovol = rhovol + particlemass / rhopart + npart_a = npart_a + 1 ! Count number of particles within "surface" of initial star dump + endif + ! Calculate residual of Virial theorem for fluid + if (ieos == 2) then + call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,gamma_local=gamma) + else + call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) + endif + virialintegral = virialintegral + 3. * ponrhoi * particlemass + enddo + virialpart = virialpart / (abs(totepot) + 2.*abs(totekin)) ! Normalisation for the virial + virialfluid = (virialintegral + totepot) / (abs(virialintegral) + abs(totepot)) + + ! Sort particles within "surface" by radius + call indexxfunc(npart_a,r2func_origin,xyzh,iorder_a) + + mean_rad_num = npart / 200 ! 0.5 percent of particles + star_stability = 0. + ! Loop over the outermost npart/200 particles that are within the "surface" + do i = npart_a - mean_rad_num,npart_a + j = iorder(i) + k = iorder_a(i) + star_stability(ipartrad) = star_stability(ipartrad) + separation(xyzh(1:3,j),xyzmh_ptmass(1:3,1)) + star_stability(ipart2hrad) = star_stability(ipart2hrad) + separation(xyzh(1:3,j),xyzmh_ptmass(1:3,1)) + xyzh(4,j) + star_stability(ipdensrad) = star_stability(ipdensrad) + separation(xyzh(1:3,k),xyzmh_ptmass(1:3,1)) + star_stability(ip2hdensrad) = star_stability(ip2hdensrad) + separation(xyzh(1:3,k),xyzmh_ptmass(1:3,1)) + xyzh(4,j) + enddo + + star_stability(ipartrad) = star_stability(ipartrad) / real(mean_rad_num) + star_stability(ipart2hrad) = star_stability(ipart2hrad) / real(mean_rad_num) + star_stability(ipdensrad) = star_stability(ipdensrad) / real(mean_rad_num) + star_stability(ip2hdensrad) = star_stability(ip2hdensrad) / real(mean_rad_num) + star_stability(ivoleqrad) = (3. * totvol/(4. * pi))**(1./3.) + star_stability(idensrad) = (3. * rhovol/(4. * pi))**(1./3.) + star_stability(ivirialpart) = virialpart + star_stability(ivirialfluid)= virialfluid + + if (dump_number == 0) then + init_radius = star_stability(ivoleqrad) + endif + + star_stability(imassout) = 0. + total_mass = xyzmh_ptmass(4,1) + do i = 1,npart + if (separation(xyzmh_ptmass(1:3,1),xyzh(1:3,i)) > init_radius) then + star_stability(imassout) = star_stability(imassout) + particlemass + endif + total_mass = total_mass + particlemass + enddo + + star_stability(imassfracout) = star_stability(imassout) / total_mass + call write_time_file('star_stability', columns, time, star_stability, ncols, dump_number) + deallocate(columns,star_stability,iorder,iorder_a) + +end subroutine star_stabilisation_suite + + +!---------------------------------------------------------------- +!+ +! Print simulation parameters +!+ +!---------------------------------------------------------------- +subroutine print_simulation_parameters(npart,particlemass) + integer, intent(in) :: npart + real, intent(in) :: particlemass + integer :: i + + write(*,"(/,3(a,es10.3,1x),a)") ' Mass: ',umass, 'g Length: ',udist, 'cm Time: ',utime,'s' + write(*,"(3(a,es10.3,1x),a)") ' Density: ',unit_density, 'g/cm^3 Energy: ',unit_energ,'erg En/m: ',unit_ergg,'erg/g' + write(*,"(3(a,es10.3,1x),a)") ' Velocity: ',unit_velocity,'cm/s Bfield: ',unit_Bfield,'G Pressure: ',& + unit_pressure,'g/cm s^2' + write(*,"(2(a,es10.3,1x),/)") ' G: ', gg*umass*utime**2/udist**3,' c: ',c*utime/udist + + do i=1,nptmass + if (xyzmh_ptmass(4,i) > 0.) then + write(*,'(A,I2,A,ES10.3,A,ES10.3)') 'Point mass ',i,': M = ',xyzmh_ptmass(4,i),' and h_soft = ',xyzmh_ptmass(ihsoft,i) + endif + enddo + write(*,"(A,ES10.3)") 'Sink-sink separation: ', separation(xyzmh_ptmass(1:3,1), xyzmh_ptmass(1:3,2)) + + write(*,'(A,I7,A,ES10.3)') 'Gas particles : ',npart,' particles, each of mass ',particlemass + +end subroutine print_simulation_parameters + + +!---------------------------------------------------------------- +!+ +! Write quantities (up to four) to divv file +!+ +!---------------------------------------------------------------- +subroutine output_divv_files(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 + 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(:) + real :: ekini,einti,epoti,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(:) + 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, parameter :: Scrit = 2. ! Critical saturation ratio + logical :: verbose = .false. + + allocate(quant(4,npart)) + Nquantities = 14 + if (dump_number == 0) then + print "(14(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) + endif + + ! 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 + + !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)) + 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 + epsC = eps(3) - nucleation(idK3,i) + if (epsC < 0.) then + print *,'eps(C) =',eps(3),', K3=',nucleation(idK3,i),', epsC=',epsC,', T=',tempi,' rho=',rho_cgs + print *,'JKmuS=',nucleation(:,i) + stop '[S-dust_formation] epsC < 0!' + endif + if (tempi > 450.) then + !call chemical_equilibrium_light to obtain pC, and pC2H2 + call chemical_equilibrium_light(rho_cgs, tempi, epsC, pC, pC2, pC2H, pC2H2, nucleation(idmu,i), nucleation(idgamma,i)) + S = pC/psat_C(tempi) + if (S > Scrit) then + !call nucleation_function to obtain JstarS + call calc_nucleation(tempi, pC, 0., 0., 0., pC2H2, S, JstarS, taustar, taugr) + JstarS = JstarS/ nH_tot + endif + endif + !Check if the variables have meaningful values close to condensation temperatures + if (tempi >= 1400. .and. tempi <= 1500. .and. verbose ) then + print *,'size(nucleation,1) = ',size(nucleation,1) + print *,'size(nucleation,2) = ',size(nucleation,2) + print *,'nucleation(idK3,i) = ',nucleation(idK3,i) + 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 + 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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum1) + if (quantities_to_calculate(k)==1) then + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),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 + case default + print*,"Error: Requested quantity is invalid." + stop + 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) + enddo + close(iu) + deallocate(quant) + +end subroutine output_divv_files + + + +!!!!! EoS surfaces !!!!! +subroutine eos_surfaces + integer :: i, j, ierr + real :: rho_array(1000) = (/ (10**(i/10000.), i=-180000,-30150,150) /) + real :: eni_array(1000) = (/ (10**(i/10000.), i=120000,149970,30) /) + real :: temp_array(400) = (/ (10**(i/1000.), i=3000,6990,10) /) + real :: kappa_array(1000,400) + real :: gam1_array(1000,1000) + real :: pres_array(1000,1000) + real :: dum(1000,1000) + real :: kappat, kappar + + + do i=1,size(rho_array) + do j=1,size(eni_array) + if (j < size(temp_array) + 1) then + call get_eos_kappa_mesa(rho_array(i),temp_array(j),kappa_array(i,j),kappat,kappar) + endif + call get_eos_pressure_temp_gamma1_mesa(rho_array(i),eni_array(j),pres_array(i,j),dum(i,j),gam1_array(i,j),ierr) + !call get_eos_pressure_temp_mesa(rho_array(i),eni_array(j),pres_array(i,j),temp) + !pres_array(i,j) = eni_array(j)*rho_array(i)*0.66667 / pres_array(i,j) + enddo + enddo + + open(unit=1000,file='mesa_eos_pressure.out',status='replace') + + !Write data to file + do i=1,1000 + write(1000,"(1000(3x,es18.11e2,1x))") pres_array(i,:) + enddo + + close(unit=1000) + + open(unit=1002,file='mesa_eos_gamma.out',status='replace') + + !Write data to file + do i=1,1000 + write(1002,"(1000(3x,es18.11e2,1x))") gam1_array(i,:) + enddo + + close(unit=1002) + + open(unit=1001,file='mesa_eos_kappa.out',status='replace') + + !Write data to file + do i=1,1000 + write(1001,"(400(3x,es18.11e2,1x))") kappa_array(i,:) + enddo + + close(unit=1001) + +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 + use mesa_microphysics, only:getvalue_mesa + use ionization_mod, only:ionisation_fraction + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + integer, parameter :: nparttotrack=10,ncols=17 + real :: r,v,rhopart,ponrhoi,Si,spsoundi,tempi,machi,xh0,xh1,xhe0,xhe1,xhe2,& + ekini,einti,epoti,ethi,etoti,dum,phii,pgas,mu + 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 /) + columns = (/ ' r',& + ' v',& + ' rho',& + ' temp',& + 'entropy',& + 'spsound',& + ' mach',& + ' ekin',& + ' epot',& + ' eth',& + ' eint',& + ' etot',& + ' xHI',& + ' xHII',& + ' xHeI',& + ' xHeII',& + ' xHeIII' /) + + call compute_energies(time) + + do i=1,nparttotrack + write (filenames(i),"(a1,i7.7)") "p", partID(i) + enddo + + do k=1,nparttotrack + i = partID(k) + 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) + 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 + 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 + 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) + 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) + + ! Write file + datatable = (/ r,v,rhopart,eos_vars(itemp,i),Si,spsoundi,machi,ekini,epoti,ethi,einti,etoti,xh0,xh1,xhe0,xhe1,xhe2 /) + call write_time_file(trim(adjustl(filenames(k))),columns,time,datatable,ncols,dump_number) + enddo + +end subroutine track_particle + + +!---------------------------------------------------------------- +!+ +! Optical depth profile +!+ +!---------------------------------------------------------------- +subroutine tau_profile(time,num,npart,particlemass,xyzh) + use part, only:eos_vars,itemp + integer, intent(in) :: npart,num + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:) + integer :: nbins + real, allocatable :: rad_part(:),kappa_part(:),rho_part(:) + real, allocatable :: kappa_hist(:),rho_hist(:),tau_r(:),sepbins(:) + real :: maxloga,minloga,kappa,kappat,kappar + character(len=17) :: filename + character(len=40) :: data_formatter + integer :: i,unitnum + + call compute_energies(time) + nbins = 500 + + allocate(rad_part(npart),kappa_part(npart),rho_part(npart)) + rad_part = 0. + kappa_part = 0. + rho_part = 0. + minloga = 0.5 + maxloga = 4.3 + + allocate(rho_hist(nbins),kappa_hist(nbins),sepbins(nbins),tau_r(nbins)) + filename = ' grid_tau.ev' + + do i=1,npart + rho_part(i) = rhoh(xyzh(4,i), particlemass) + rad_part(i) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) + call get_eos_kappa_mesa(rho_part(i)*unit_density,eos_vars(itemp,i),kappa,kappat,kappar) + kappa_part(i) = kappa ! In cgs units? + enddo + + call histogram_setup(rad_part(1:npart),kappa_part,kappa_hist,npart,maxloga,minloga,nbins,.true.,.true.) + call histogram_setup(rad_part(1:npart),rho_part,rho_hist,npart,maxloga,minloga,nbins,.true.,.true.) + + + ! Integrate optical depth inwards + sepbins = (/ (10**(minloga + (i-1) * (maxloga-minloga)/real(nbins)), i=1,nbins) /) ! Create log-uniform bins + ! Convert to cgs units (kappa has already been outputted in cgs) + rho_hist = rho_hist * unit_density + sepbins = sepbins * udist ! udist should be Rsun in cm + + tau_r(nbins) = 0. + do i=nbins,2,-1 + tau_r(i-1) = tau_r(i) + kappa_hist(i) * rho_hist(i) * (sepbins(i+1) - sepbins(i)) + enddo + + ! Write data row + write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" + if (num == 0) then + unitnum = 1000 + open(unit=unitnum,file=trim(adjustl(filename)),status='replace') + write(unitnum, "(a)") '# Optical depth profile' + close(unit=unitnum) + endif + unitnum=1002 + open(unit=unitnum,file=trim(adjustl(filename)), position='append') + write(unitnum,data_formatter) time,tau_r + close(unit=unitnum) + deallocate(rad_part,kappa_part,rho_part) + deallocate(rho_hist,kappa_hist,sepbins,tau_r) + +end subroutine tau_profile + +!---------------------------------------------------------------- +!+ +! Sound crossing time profile +!+ +!---------------------------------------------------------------- +subroutine tconv_profile(time,num,npart,particlemass,xyzh,vxyzu) + use part, only:itemp + use eos, only:get_spsound + use units, only:unit_velocity + integer, intent(in) :: npart,num + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + integer :: nbins + real, allocatable :: rad_part(:),cs_part(:) + real, allocatable :: cs_hist(:),tconv(:),sepbins(:) + real :: maxloga,minloga,rhoi + character(len=17) :: filename + character(len=40) :: data_formatter + integer :: i,unitnum + + call compute_energies(time) + nbins = 500 + allocate(rad_part(npart),cs_part(npart)) + rad_part = 0. + cs_part = 0. + minloga = 0.5 + maxloga = 4.3 + + allocate(cs_hist(nbins),sepbins(nbins),tconv(nbins)) + filename = ' grid_tconv.ev' + + do i=1,npart + rhoi = rhoh(xyzh(4,i), particlemass) + rad_part(i) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) + cs_part(i) = get_spsound(eos_type=ieos,xyzi=xyzh(:,i),rhoi=rhoi,vxyzui=vxyzu(:,i),gammai=gamma,mui=gmw,Xi=X_in,Zi=Z_in) + enddo + + call histogram_setup(rad_part(1:npart),cs_part,cs_hist,npart,maxloga,minloga,nbins,.true.,.true.) + + ! Integrate sound-crossing time from surface inwards + sepbins = (/ (10**(minloga + (i-1) * (maxloga-minloga)/real(nbins)), i=1,nbins) /) ! Create log-uniform bins + ! Convert to cgs units + cs_hist = cs_hist * unit_velocity + sepbins = sepbins * udist ! udist should be Rsun in cm + + tconv(nbins) = 0. + do i=nbins,2,-1 + if (cs_hist(i) < tiny(1.)) then + tconv(i-1) = tconv(i) + else + tconv(i-1) = tconv(i) + (sepbins(i+1) - sepbins(i)) / cs_hist(i) + endif + enddo + + ! Write data row + write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" + if (num == 0) then + unitnum = 1000 + open(unit=unitnum,file=trim(adjustl(filename)),status='replace') + write(unitnum, "(a)") '# Sound crossing time profile' + close(unit=unitnum) + endif + unitnum=1002 + open(unit=unitnum,file=trim(adjustl(filename)), position='append') + write(unitnum,data_formatter) time,tconv + close(unit=unitnum) + + deallocate(rad_part,cs_part) + +end subroutine tconv_profile + + +!---------------------------------------------------------------- +!+ +! Histogram of optical depth at hydrogen recombination +!+ +!---------------------------------------------------------------- +subroutine recombination_tau(time,npart,particlemass,xyzh,vxyzu) + use part, only:eos_vars,itemp + use ionization_mod, only:ionisation_fraction + integer, intent(in) :: npart + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + integer :: nbins + integer, allocatable :: recombined_pid(:) + real, allocatable :: rad_part(:),kappa_part(:),rho_part(:) + real, allocatable, save:: tau_recombined(:) + 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 + real, parameter :: recomb_th=0.9 + integer :: i,j,nrecombined,bin_ind + + call compute_energies(time) + allocate(rad_part(npart),kappa_part(npart),rho_part(npart),recombined_pid(npart)) + rad_part = 0. + kappa_part = 0. + rho_part = 0. + nbins = 300 ! Number of radial bins + minloga = 0.5 + maxloga = 4.3 + allocate(rho_hist(nbins),kappa_hist(nbins),sepbins(nbins),sepbins_cm(nbins),tau_r(nbins)) + if (dump_number == 0) then + allocate(tau_recombined(npart),prev_recombined(npart)) + tau_recombined = -1. ! Store tau of newly-recombined particles. -ve data means particle never recombined] + prev_recombined = .false. ! All hydrogen is ionised at the start + endif + + j=0 + do i=1,npart + rho_part(i) = rhoh(xyzh(4,i), particlemass) + rad_part(i) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) + call equationofstate(ieos,ponrhoi,spsoundi,rho_part(i),xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) + 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_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rho_part(i),eos_vars(itemp,i),ethi) + etoti = ekini + epoti + ethi + if ((xh0 > recomb_th) .and. (.not. prev_recombined(i)) .and. (etoti < 0.)) then ! Recombination event and particle is still bound + j=j+1 + recombined_pid(j) = i + prev_recombined(i) = .true. + else + prev_recombined(i) = .false. + endif + enddo + nrecombined = j + + call histogram_setup(rad_part(1:npart),kappa_part,kappa_hist,npart,maxloga,minloga,nbins,.true.,.true.) + call histogram_setup(rad_part(1:npart),rho_part,rho_hist,npart,maxloga,minloga,nbins,.true.,.true.) + + ! Integrate optical depth inwards + sepbins = (/ (10.**(minloga + (i-1) * (maxloga-minloga)/real(nbins)), i=1,nbins) /) ! Create log-uniform bins + + ! Convert to cgs units (kappa has already been outputted in cgs) + rho_hist = rho_hist * unit_density + sepbins_cm = sepbins * udist ! udist should be Rsun in g + + ! Integrate bins in tau(r) + tau_r(nbins) = 0. + do i=nbins,2,-1 + tau_r(i-1) = tau_r(i) + kappa_hist(i) * rho_hist(i) * (sepbins_cm(i+1) - sepbins_cm(i)) + enddo + + ! Integrate optical depth for each newly recombined particle + do j=1,nrecombined + i = recombined_pid(j) + bin_ind = 1 + nint( nbins * ( log10(rad_part(i))-minloga ) / (maxloga-minloga) ) ! Find radial bin of recombined particle + tau_recombined(i) = tau_r(bin_ind) + enddo + ! Trick write_time_file into writing my data table + if (dump_number == 320) then + do i=1,npart + call write_time_file("recombination_tau",(/' tau'/),-1.,tau_recombined(i),1,i-1) ! Set num = i-1 so that header will be written for particle 1 and particle 1 only + enddo + endif + deallocate(recombined_pid,rad_part,kappa_part,rho_part) + +end subroutine recombination_tau + + +!---------------------------------------------------------------- +!+ +! Energy histogram +!+ +!---------------------------------------------------------------- +subroutine energy_hist(time,npart,particlemass,xyzh,vxyzu) + use part, only:eos_vars,itemp + integer, intent(in) :: npart + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17), allocatable :: filename(:) + 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, allocatable :: quant(:) + logical :: ilogbins + + nhists = 3 + nbins = 500 + allocate(filename(nhists),coord(npart,nhists),hist(nbins),Emin(nhists),Emax(nhists)) + Emin = (/ -0.0446, 0., 0. /) + Emax = (/ 0.0315, 0.0105, 0.0105 /) + ilogbins = .false. + filename = (/ ' hist_kp.ev', & + ' hist_erec.ev', & + ' hist_eth.ev' /) + + allocate(quant(npart)) + quant = (/ (1., i=1,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + if (ieos==10 .or. ieos==20) then + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) + else + ethi = einti + endif + coord(i,1) = (ekini + epoti)/particlemass + coord(i,2) = vxyzu(4,i) - ethi/particlemass + coord(i,3) = ethi/particlemass + enddo + + write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" + do i=1,nhists + call histogram_setup(coord(:,i),quant,hist,npart,Emax(i),Emin(i),nbins,.false.,ilogbins) + if (dump_number == 0) then + unitnum = 1000 + open(unit=unitnum,file=trim(adjustl(filename(i))),status='replace') + close(unit=unitnum) + endif + unitnum=1001+i + open(unit=unitnum,file=trim(adjustl(filename(i))),status='old', position='append') + write(unitnum,data_formatter) time,hist + close(unit=unitnum) + enddo + deallocate(filename,coord,hist,Emin,Emax,quant) + +end subroutine energy_hist + + +!---------------------------------------------------------------- +!+ +! Energy profile +!+ +!---------------------------------------------------------------- +subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) + use part, only:eos_vars,itemp + use eos, only:entropy + use mesa_microphysics, only:getvalue_mesa + use ionization_mod, only:ionisation_fraction + integer, intent(in) :: npart + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + integer :: nbins + real, allocatable :: coord(:) + real, allocatable :: hist(:),quant(:,:) + real :: ekini,einti,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 + integer :: i,k,unitnum,ierr,ientropy,nvars + integer, allocatable :: iorder(:) + integer, save :: iquantity + logical :: ilogbins + logical, save :: use_mass_coord + + if (dump_number==0) then + iquantity = 1 + use_mass_coord = .false. + print "(5(/,a))",'1. Energy',& + '2. Entropy',& + '3. Bernoulli energy',& + '4. Ion fractions',& + '5. Sound speed' + call prompt("Select quantity to calculate",iquantity,1,5) + call prompt("Bin in mass coordinates instead of radius?",use_mass_coord) + endif + + nbins = 500 + allocate(hist(nbins)) + if (use_mass_coord) then + mincoord = 3.8405 ! Min. mass coordinate + maxcoord = 12.0 ! Max. mass coordinate + ilogbins = .false. + else + mincoord = 0.5 ! Min. log(r) + maxcoord = 4.3 ! Max. log(r) + ilogbins = .true. + endif + + call compute_energies(time) + + ! Allocate arrays for single variable outputs + if (iquantity==1 .or. iquantity==2 .or. iquantity==3 .or. iquantity==5) then + nvars = 1 + else + nvars = 5 + endif + allocate(filename(nvars),headerline(nvars),quant(npart,nvars),coord(npart)) + + coord = 0. + quant = 0. + select case (iquantity) + case(1) ! Energy + filename = ' grid_Etot.ev' + headerline = '# Energy profile ' + case(2) ! Entropy + filename = ' grid_entropy.ev' + headerline = '# Entropy profile' + select case(ieos) + case(2) + ientropy = 1 + case(12) + ientropy = 2 + case(10,20) + ientropy = 3 + case default + ientropy = -1 + end select + case(3) ! Bernoulli energy (per unit mass) + filename = 'grid_bernoulli.ev' + headerline = '# Bernoulli prof.' + case(4) ! Ion fraction profiles + filename = (/ ' grid_HI.ev', & + ' grid_HII.ev', & + ' grid_HeI.ev', & + ' grid_HeII.ev', & + ' grid_HeIII.ev' /) + headerline = (/ ' # HI', & + ' # HII', & + ' # HeI', & + ' # HeII', & + ' # HeIII' /) + case(5) ! Sound speed + filename = ' grid_cs.ev' + headerline = '# cs profile ' + end select + + allocate(iorder(npart)) + if (use_mass_coord) then + call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) ! Order particles by distance from core + call indexxfunc(npart,r2func_origin,xyzh,iorder) + else + iorder = (/(i, i=1,npart, 1)/) ! Have iorder(k) be same as k + endif + + do k=1,npart + i = iorder(k) ! Loop from innermost to outermost particle + if (use_mass_coord) then + coord(i) = real(k-1) ! Number of particles interior to particle k + else + coord(i) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) + endif + + 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)) + select case (iquantity) + case(1) ! Energy + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) + quant(i,1) = ekini + epoti + ethi + case(2) ! Entropy + if ((ieos==10) .and. (ientropy==2)) 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 + else + mu = gmw + endif + if ((ieos==10) .and. (ientropy==3)) then + quant(i,1) = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) + else + 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) + 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) + quant(i,1) = xh0 + quant(i,2) = xh1 + quant(i,3) = xhe0 + quant(i,4) = xhe1 + quant(i,5) = xhe2 + case(5) ! Sound speed + quant(i,1) = spsoundi + end select + enddo + + if (use_mass_coord) coord = coord * particlemass + xyzmh_ptmass(4,1) + + write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" + do i=1,nvars + call histogram_setup(coord,quant(:,i),hist,npart,maxcoord,mincoord,nbins,.true.,ilogbins) + if (dump_number == 0) then + unitnum = 1000 + open(unit=unitnum,file=trim(adjustl(filename(i))),status='replace') + write(unitnum, "(a)") trim(headerline(i)) + close(unit=unitnum) + endif + unitnum=1001+i + open(unit=unitnum,file=trim(adjustl(filename(i))),status='old', position='append') + write(unitnum,data_formatter) time,hist + close(unit=unitnum) + enddo + deallocate(iorder,coord,headerline,filename,quant,hist) + +end subroutine energy_profile + + +!---------------------------------------------------------------- +!+ +! Rotation profiles +!+ +!---------------------------------------------------------------- +subroutine rotation_profile(time,num,npart,xyzh,vxyzu) + use vectorutils, only:cross_product3D + integer, intent(in) :: npart,num + real, intent(in) :: time + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + integer :: nbins + real, allocatable :: rad_part(:) + real, allocatable :: hist_var(:),dist_part(:,:) + real :: minloga,maxloga,sep_vector(3),vel_vector(3),J_vector(3),xyz_origin(3),vxyz_origin(3),omega,vphi + character(len=17), allocatable :: grid_file(:) + character(len=40) :: data_formatter + integer :: i,unitnum,nfiles,iradius + + nbins = 500 + minloga = 0.5 + maxloga = 4.3 + iradius = 1 ! 1: Bin by cylindrical radius; 2: Bin by spherical radius; 3: Bin by cylindrical radius from CM + + nfiles = 2 + allocate(hist_var(nbins),grid_file(nfiles),dist_part(nfiles,npart),rad_part(npart)) + rad_part = 0. + dist_part = 0. + grid_file = (/ ' grid_omega.ev', & + ' grid_Jz.ev' /) + + select case (iradius) + case(1,2) ! Take donor core as origin + xyz_origin = xyzmh_ptmass(1:3,1) + vxyz_origin = vxyz_ptmass(1:3,1) + case(3) ! Take sink CM as origin + xyz_origin = (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)) + vxyz_origin = (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)) + end select + + do i=1,npart + select case (iradius) + case(1,3) ! Bin by cylindrical radius + rad_part(i) = sqrt( dot_product(xyzh(1:2,i) - xyz_origin(1:2), xyzh(1:2,i) - xyz_origin(1:2)) ) + case(2) ! Bin by spherical radius + rad_part(i) = separation(xyzh(1:3,i),xyz_origin) + end select + + call get_gas_omega(xyz_origin,vxyz_origin,xyzh(1:3,i),vxyzu(1:3,i),vphi,omega) + dist_part(1,i) = vphi + + sep_vector = xyzh(1:3,i) - xyz_origin(1:3) + vel_vector = vxyzu(1:3,i) - vxyz_origin(1:3) + call cross_product3D(vel_vector, sep_vector, J_vector) + dist_part(2,i) = dot_product(J_vector, (/0.,0.,1./)) + enddo + + do i=1,nfiles + call histogram_setup(rad_part(1:npart),dist_part(i,1:npart),hist_var,npart,maxloga,minloga,nbins,.true.,.true.) + write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" + if (num == 0) then + unitnum = 1000 + open(unit=unitnum,file=trim(adjustl(grid_file(i))),status='replace') + write(unitnum, "(a)") '# z-component of angular velocity' + close(unit=unitnum) + endif + unitnum=1001+i + open(unit=unitnum,file=trim(adjustl(grid_file(i))), position='append') + write(unitnum,data_formatter) time,hist_var(:) + close(unit=unitnum) + enddo + deallocate(hist_var,grid_file,dist_part,rad_part) + +end subroutine rotation_profile + + +!---------------------------------------------------------------- +!+ +! Velocity distribution +!+ +!---------------------------------------------------------------- +subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) + use part, only:eos_vars,itemp + real, intent(in) :: time,particlemass + integer, intent(in) :: npart,num + real, intent(inout) :: 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, 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),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) + vr(i) = dot_product(xyzh(1:3,i),vxyzu(1:3,i)) / sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) + + if (ekini+epoti > 0.) then + vbound(i) = -1.e15 + vunbound(i) = vr(i) + else + vbound(i) = vr(i) + vunbound(i) = -1.e15 + endif + enddo + + ncols = npart + write(data_formatter, "(a,I6.6,a)") "(", ncols+1, "(2x,es18.11e2))" + file_name1 = "vel_bound.ev" + file_name2 = "vel_unbound.ev" + + if (dump_number == 0) then + open(newunit=iu1,file=file_name1,status='replace') + open(newunit=iu2,file=file_name2,status='replace') + else + open(newunit=iu1,file=file_name1, position='append') + open(newunit=iu2,file=file_name2, position='append') + endif + + write(iu1,data_formatter) time,vbound + write(iu2,data_formatter) time,vunbound + close(unit=iu1) + close(unit=iu2) + + deallocate(vbound,vunbound,vr) + +end subroutine velocity_histogram + + +!---------------------------------------------------------------- +!+ +! Velocity profile +!+ +!---------------------------------------------------------------- +subroutine velocity_profile(time,num,npart,particlemass,xyzh,vxyzu) + real, intent(in) :: time,particlemass + integer, intent(in) :: npart,num + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=40) :: data_formatter + character(len=40) :: file_name + integer :: i,nbins,iu,count + real :: rmin,rmax,xyz_origin(3),vxyz_origin(3),vphi,omega,& + theta1,theta2,tantheta1,tantheta2,tantheta + real, allocatable, dimension(:) :: rad_part,dist_part,hist + + nbins = 500 + rmin = 0. + rmax = 5. + + allocate(hist(nbins),dist_part(npart),rad_part(npart)) + dist_part = 0. + file_name = ' vphi_profile.ev' + + ! Select origin + xyz_origin = xyzmh_ptmass(1:3,1) + vxyz_origin = vxyz_ptmass(1:3,1) + + ! Masking in polar angle + theta1 = 75. ! Polar angle in deg + theta2 = 105. + tantheta1 = tan(theta1*3.14159/180.) + tantheta2 = tan(theta2*3.14159/180.) + + count = 0 + do i = 1,npart + rad_part(i) = sqrt( dot_product(xyzh(1:2,i) - xyz_origin(1:2), xyzh(1:2,i) - xyz_origin(1:2)) ) ! Cylindrical radius + + ! Masking in polar angle + tantheta = rad_part(i)/(xyzh(3,i) - xyzmh_ptmass(3,1)) + if ( (tantheta>0. .and. tanthetatantheta2) ) cycle + + call get_gas_omega(xyz_origin,vxyz_origin,xyzh(1:3,i),vxyzu(1:3,i),vphi,omega) + dist_part(i) = vphi + count = count + 1 + enddo + + call histogram_setup(rad_part,dist_part,hist,count,rmax,rmin,nbins,.true.,.false.) + write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" + if (num == 0) then + open(newunit=iu,file=trim(adjustl(file_name)),status='replace') + write(iu, "(a)") '# Azimuthal velocity profile' + close(unit=iu) + endif + open(newunit=iu,file=trim(adjustl(file_name)), position='append') + write(iu,data_formatter) time,hist + close(unit=iu) + deallocate(hist,dist_part,rad_part) + +end subroutine velocity_profile + + +!---------------------------------------------------------------- +!+ +! Specific z-angular momentum profile +!+ +!---------------------------------------------------------------- +subroutine angular_momentum_profile(time,num,npart,particlemass,xyzh,vxyzu) + real, intent(in) :: time,particlemass + integer, intent(in) :: npart,num + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=40) :: data_formatter + character(len=40) :: file_name + integer :: i,nbins,iu,count + real :: rmin,rmax,xyz_origin(3),vxyz_origin(3),& + theta1,theta2,tantheta1,tantheta2,tantheta + real, allocatable, dimension(:) :: rad_part,dist_part,hist + + nbins = 500 + rmin = 0. + rmax = 5. + + allocate(hist(nbins),dist_part(npart),rad_part(npart)) + dist_part = 0. + file_name = ' jz_profile.ev' + + ! Select origin + xyz_origin = xyzmh_ptmass(1:3,1) + vxyz_origin = vxyz_ptmass(1:3,1) + + ! Masking in polar angle + theta1 = 75. ! Polar angle in deg + theta2 = 105. + tantheta1 = tan(theta1*3.14159/180.) + tantheta2 = tan(theta2*3.14159/180.) + + count = 0 + do i = 1,npart + rad_part(i) = sqrt( dot_product(xyzh(1:2,i) - xyz_origin(1:2), xyzh(1:2,i) - xyz_origin(1:2)) ) ! Cylindrical radius + + ! Masking in polar angle + tantheta = rad_part(i)/(xyzh(3,i) - xyzmh_ptmass(3,1)) + if ( (tantheta>0. .and. tanthetatantheta2) ) cycle + + dist_part(i) = ( (xyzh(1,i)-xyz_origin(1))*(vxyzu(2,i)-vxyz_origin(2)) - & + (xyzh(2,i)-xyz_origin(2))*(vxyzu(1,i)-vxyz_origin(1)) ) + count = count + 1 + enddo + + call histogram_setup(rad_part,dist_part,hist,count,rmax,rmin,nbins,.true.,.false.) + write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" + if (num == 0) then + open(newunit=iu,file=trim(adjustl(file_name)),status='replace') + write(iu, "(a)") '# z-angular momentum profile' + close(unit=iu) + endif + open(newunit=iu,file=trim(adjustl(file_name)), position='append') + write(iu,data_formatter) time,hist + close(unit=iu) + +end subroutine angular_momentum_profile + + +!---------------------------------------------------------------- +!+ +! Keplerian velocity profile +!+ +!---------------------------------------------------------------- +subroutine vkep_profile(time,num,npart,particlemass,xyzh,vxyzu) + use sortutils, only:set_r2func_origin,r2func_origin,find_rank + use part, only:iorder=>ll + real, intent(in) :: time,particlemass + integer, intent(in) :: npart,num + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=40) :: data_formatter,file_name + integer :: i,nbins,iu + real :: rmin,rmax,massi,Mtot + real, allocatable :: hist(:),rad_part(:),dist_part(:) + + nbins = 500 + rmin = 0. + rmax = 5. + + allocate(hist(nbins),rad_part(npart),dist_part(npart)) + dist_part = 0. + file_name = ' vkep_profile.ev' + + call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) + call find_rank(npart,r2func_origin,xyzh(1:3,:),iorder) + + Mtot = npart*particlemass + do i = 1,npart + massi = Mtot * real(iorder(i)-1) / real(npart) + xyzmh_ptmass(4,1) + rad_part(i) = separation( xyzh(1:3,i), xyzmh_ptmass(1:3,1) ) + dist_part(i) = sqrt(massi/rad_part(i)) + enddo + + call histogram_setup(rad_part,dist_part,hist,npart,rmax,rmin,nbins,.true.,.false.) + write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" + if (num == 0) then + open(newunit=iu,file=trim(adjustl(file_name)),status='replace') + write(iu, "(a)") '# Keplerian velocity profile' + close(unit=iu) + endif + open(newunit=iu,file=trim(adjustl(file_name)), position='append') + write(iu,data_formatter) time,hist + close(unit=iu) + deallocate(hist,dist_part,rad_part) + +end subroutine vkep_profile + + +!---------------------------------------------------------------- +!+ +! Planet profile +!+ +!---------------------------------------------------------------- +subroutine planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) + character(len=*), intent(in) :: dumpfile + integer, intent(in) :: num + real, intent(in) :: particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=40) :: file_name + integer :: i,maxrho_ID,iu + integer, save :: nplanet + integer, allocatable, save :: planetIDs(:) + real :: rhoprev + real, dimension(3) :: planet_com,planet_vcom,vnorm,ri,Rvec + real, allocatable :: R(:),z(:),rho(:) + + if (dump_number ==0 ) call get_planetIDs(nplanet,planetIDs) + allocate(R(nplanet),z(nplanet),rho(nplanet)) + + ! Find highest density in planet + rhoprev = 0. + maxrho_ID = planetIDs(1) + do i = 1,nplanet + rho(i) = rhoh(xyzh(4,planetIDs(i)), particlemass) + if (rho(i) > rhoprev) then + maxrho_ID = planetIDs(i) + rhoprev = rho(i) + endif + enddo + planet_com = xyzh(1:3,maxrho_ID) + planet_vcom = vxyzu(1:3,maxrho_ID) + vnorm = planet_vcom / sqrt(dot_product(planet_vcom,planet_vcom)) + + ! Write to file + file_name = trim(dumpfile)//".planetpart" + open(newunit=iu,file=file_name,status='replace') + + ! Record R and z cylindrical coordinates w.r.t. planet_com + do i = 1,nplanet + ri = xyzh(1:3,planetIDs(i)) - planet_com ! Particle position w.r.t. planet_com + z(i) = dot_product(ri, vnorm) + Rvec = ri - z(i)*vnorm + R(i) = sqrt(dot_product(Rvec,Rvec)) + ! write(iu,"(es13.6,2x,es13.6,2x,es13.6)") R(i),z(i),rho(i) + write(iu,"(es13.6,2x,es13.6,2x,es13.6,2x,es13.6,2x,es13.6)") xyzh(1,i),xyzh(2,i),xyzh(3,i),rho(i),vxyzu(4,i) + enddo + + close(unit=iu) + deallocate(R,z,rho) + +end subroutine planet_profile + + +!---------------------------------------------------------------- +!+ +! Unbound profiles +!+ +!---------------------------------------------------------------- +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,einti,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 + + call compute_energies(time) + npart_hist = 0 ! Stores number of particles fulfilling each of the four bound/unbound criterion + nbins = 500 + rad_part = 0. ! (4,npart_hist)-array storing separations of particles + dist_part = 0. + 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' /) + + if (dump_number == 0) then + allocate(prev_bound(2,npart)) + allocate(prev_unbound(2,npart)) + prev_bound = .false. + prev_unbound = .false. + endif + + + 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),radprop(:,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 + + ! 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 + endif + 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,& + .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 + unitnum = 1000 + open(unit=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') + + write(unitnum,"()") + write(unitnum,data_formatter) time,hist_var(:) + + close(unit=unitnum) + enddo + deallocate(hist_var) + +end subroutine unbound_profiles + + +!---------------------------------------------------------------- +!+ +! Unbound ion fractions: Look at distribution of ion fraction when given particle is unbound +!+ +!---------------------------------------------------------------- +subroutine unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) + use ionization_mod, only:get_xion,ionisation_fraction + integer, intent(in) :: npart + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17) :: columns(5) + integer :: i + real :: etoti,ekini,einti,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(:,:) + + columns = (/' xion1', & + ' xion2', & + ' xion3', & + ' xion4', & + ' 1-xion3' /) + + if (dump_number == 0) then + allocate(prev_unbound(npart),prev_bound(npart)) + prev_bound = .false. + prev_unbound = .false. + allocate(ionfrac(npart,5)) + ionfrac = -1. ! Initialise ion states to -1 + endif + + call compute_energies(time) + 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_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) + etoti = ekini + epoti + ethi + + if ((etoti > 0.) .and. (.not. prev_unbound(i))) then + if (ieos == 10) then ! MESA EoS + call ionisation_fraction(rhopart*unit_density,tempi,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) + elseif (ieos == 20) then ! Gas + radiation + recombination EoS + call get_xion(log10(rhopart*unit_density),tempi,X_in,1.-X_in-Z_in,xion) + xh0 = xion(1) ! H2 ionisation fraction + xh1 = xion(2) ! H ionisation fraction + xhe1 = xion(3) ! He ionisation to He+ fraction + xhe2 = xion(4) ! He+ ionisation to He++ fraction + xhe0 = 1.-xion(3) + else ! Not supported + print*,"Error, not sensible to use unbound_ionfrac when not using MESA EoS (ieos=10) or gas+rad+rec EoS (ieos=20)" + stop + endif + ionfrac(i,1) = xh0 + ionfrac(i,2) = xh1 + ionfrac(i,3) = xhe1 + ionfrac(i,4) = xhe2 + ionfrac(i,5) = xhe0 + prev_unbound(i) = .true. + elseif (etoti < 0.) then + prev_unbound(i) = .false. + endif + enddo + + ! Trick write_time_file into writing my data table + print*,'Dump number is ',dump_number + if (dump_number == 258) then + do i=1,npart + call write_time_file("unbound_ionfrac",columns,-1.,ionfrac(i,1:5),5,i-1) ! Set num = i-1 so that header will be written for particle 1 and particle 1 only + enddo + endif + +end subroutine unbound_ionfrac + + +!---------------------------------------------------------------- +!+ +! Unbound temperature +!+ +!---------------------------------------------------------------- +subroutine unbound_temp(time,npart,particlemass,xyzh,vxyzu) + use part, only:eos_vars,itemp + use ionization_mod, only:get_xion + integer, intent(in) :: npart + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17) :: columns(1) + integer :: i,final_count(7) + real :: etoti,ekini,einti,epoti,ethi,phii,dum,rhopart,& + ponrhoi,spsoundi,temp_bins(7) + logical, allocatable, save :: prev_unbound(:),prev_bound(:) + real, allocatable, save :: temp_unbound(:) + + columns = (/' temp'/) + + if (dump_number == 0) then + allocate(prev_unbound(npart),prev_bound(npart),temp_unbound(npart)) + prev_bound = .false. + prev_unbound = .false. + temp_unbound = 0. ! Initialise temperatures to 0. + endif + + 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_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) + etoti = ekini + epoti + ethi + + if ((etoti > 0.) .and. (.not. prev_unbound(i))) then + temp_unbound(i) = eos_vars(itemp,i) + prev_unbound(i) = .true. + elseif (etoti < 0.) then + prev_unbound(i) = .false. + endif + enddo + + print*,'dump_number=',dump_number + ! Trick write_time_file into writing my data table + if (dump_number == 167) then + temp_bins = (/ 2.e3, 5.5e3, 8.e3, 1.5e4, 2.e4, 4.e4, 1.e15 /) + final_count = 0 + do i=1,npart + if (temp_unbound(i) > 1.e-15) then + if (temp_unbound(i) < temp_bins(1)) then + final_count(1:7) = final_count(1:7) + 1 + elseif (temp_unbound(i) < temp_bins(2)) then + final_count(2:7) = final_count(2:7) + 1 + elseif (temp_unbound(i) < temp_bins(3)) then + final_count(3:7) = final_count(3:7) + 1 + elseif (temp_unbound(i) < temp_bins(4)) then + final_count(4:7) = final_count(4:7) + 1 + elseif (temp_unbound(i) < temp_bins(5)) then + final_count(5:7) = final_count(5:7) + 1 + elseif (temp_unbound(i) < temp_bins(6)) then + final_count(6:7) = final_count(6:7) + 1 + elseif (temp_unbound(i) < temp_bins(7)) then + final_count(7) = final_count(7) + 1 + endif + endif + call write_time_file("unbound_temp",columns,-1.,temp_unbound(i),1,i-1) ! Set num = i-1 so that header will be written for particle 1 and particle 1 only + enddo + + print*,final_count + endif + +end subroutine unbound_temp + + +!---------------------------------------------------------------- +!+ +! Recombination statistics +!+ +!---------------------------------------------------------------- +subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) + use part, only:eos_vars,itemp + use ionization_mod, only:ionisation_fraction + integer, intent(in) :: npart,num + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real :: etoti,ekini,einti,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 :: i + real, parameter :: recomb_th=0.05 + + call compute_energies(time) + + allocate(isbound(npart),H_state(npart),He_state(npart)) + do i=1,npart + ! 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_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) + etoti = ekini + epoti + ethi + + call get_eos_pressure_temp_mesa(rhopart*unit_density,vxyzu(4,i)*unit_ergg,pressure,temperature) ! This should depend on ieos + call ionisation_fraction(rhopart*unit_density,temperature,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) + + ! Is unbound? + if (etoti > 0.) then + isbound(i) = .false. + else + isbound(i) = .true. + endif + + ! H ionisation state + if (xh0 > recomb_th) then + H_state(i) = 1 + elseif (xh1 > recomb_th) then + H_state(i) = 2 + else + H_state(i) = 0 ! This should not happen + endif + + ! H ionisation state + if (xhe0 > recomb_th) then + He_state(i) = 1 + elseif (xhe1 > recomb_th) then + He_state(i) = 2 + elseif (xhe2 > recomb_th) then + He_state(i) = 3 + else + He_state(i) = 0 ! This should not happen + 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 + + if (num == 0) then ! Write header line + open(unit=1000,file="H_state.ev",status='replace') + write(1000, "(a)") '# Ion fraction statistics' + close(unit=1000) + open(unit=1001,file="He_state.ev",status='replace') + write(1001, "(a)") '# Ion fraction statistics' + close(unit=1001) + open(unit=1002,file="isbound.ev",status='replace') + write(1002, "(a)") '# Ion fraction statistics' + close(unit=1002) + endif + + open(unit=1000,file="H_state.ev", position='append') + 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=1000,file="isbound.ev", position='append') + write(1000,logical_format) time,isbound(:) + close(unit=1000) + + deallocate(isbound,H_state,He_state) + +end subroutine recombination_stats + + +!---------------------------------------------------------------- +!+ +! Sink properties +!+ +!---------------------------------------------------------------- +subroutine sink_properties(time,npart,particlemass,xyzh,vxyzu) + use vectorutils, only:cross_product3D + integer, intent(in) :: npart + real, intent(in) :: time, particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17), allocatable :: columns(:) + character(len=17) :: filename + real :: sinkcomp(35) + real :: ang_mom(3) + real :: phitot, dtsinksink, fonrmax + real :: fxi, fyi, fzi, phii + real, dimension(4,maxptmass) :: fssxyz_ptmass + real, dimension(4,maxptmass) :: fxyz_ptmass + real, dimension(3,maxptmass) :: dsdt_ptmass + real, dimension(3) :: com_xyz,com_vxyz + integer :: i,ncols,merge_n,merge_ij(nptmass) + + ncols = 31 + allocate(columns(ncols)) + columns = (/' x', & + ' y', & + ' z', & + ' r', & + ' vx', & + ' vy', & + ' vz', & + ' |v|', & + ' px', & + ' py', & + ' pz', & + ' |p|', & + ' fssx', & + ' fssy', & + ' fssz', & + ' |fss|', & + ' fsx', & + ' fsy', & + ' fsz', & + ' |fs|', & + ' ang mom x', & + ' ang mom y', & + ' ang mom z', & + ' |ang mom|', & + ' kin en', & + ' CoM x ', & + ' CoM y ', & + ' CoM z ', & + ' CoM vx', & + ' CoM vy', & + ' CoM vz' /) + + fxyz_ptmass = 0. + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) + fssxyz_ptmass = fxyz_ptmass + do i=1,npart + call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,& + fxi,fyi,fzi,phii,particlemass,fxyz_ptmass,dsdt_ptmass,fonrmax) + enddo + + ! Determine position and velocity of the CoM + call orbit_com(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,com_xyz,com_vxyz) + + do i=1,nptmass + sinkcomp = 0. + write (filename, "(A16,I0)") "sink_properties_", i + + ! position xyz + sinkcomp(1:3) = xyzmh_ptmass(1:3,i) + ! position modulus + sinkcomp(4) = distance(xyzmh_ptmass(1:3,i)) + ! velocity xyz + sinkcomp(5:7) = vxyz_ptmass(1:3,i) + ! velocity modulus + sinkcomp(8) = distance(vxyz_ptmass(1:3,i)) + ! momentum xyz + sinkcomp(9:11) = xyzmh_ptmass(4,i)*vxyz_ptmass(1:3,i) + ! momentum modulus + sinkcomp(12) = xyzmh_ptmass(4,i)*sinkcomp(8) + ! force xyz + sinkcomp(13:15) = fssxyz_ptmass(1:3,i) + ! force modulus + sinkcomp(16) = distance(fssxyz_ptmass(1:3,i)) + ! tot force xyz + sinkcomp(17:19) = fxyz_ptmass(1:3,i) + ! tot force modulus + sinkcomp(20) = distance(fxyz_ptmass(1:3,i)) + ! angular momentum xyz + call cross_product3D(xyzmh_ptmass(1:3,i), xyzmh_ptmass(4,i)*vxyz_ptmass(1:3,i), ang_mom) + sinkcomp(21:23) = ang_mom + ! angular momentum modulus + sinkcomp(24) = distance(ang_mom(1:3)) + ! kinetic energy + sinkcomp(25) = 0.5*xyzmh_ptmass(4,i)*sinkcomp(8)**2 + ! CoM position + sinkcomp(26:28) = com_xyz(1:3) + ! CoM velocity + sinkcomp(29:31) = com_vxyz(1:3) + + call write_time_file(filename, columns, time, sinkcomp, ncols, dump_number) + enddo + deallocate(columns) + +end subroutine sink_properties + + + +subroutine env_binding_ene(npart,particlemass,xyzh,vxyzu) + use part, only:eos_vars,itemp + integer, intent(in) :: npart + real, intent(in) :: particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + integer :: i + real :: ethi,phii,rhoi,ponrhoi,spsoundi,tempi,dum1,dum2,dum3 + real :: bind_g,bind_th,bind_int,eth_tot,eint_tot + + bind_g = 0. + bind_th = 0. + bind_int = 0. + eint_tot = 0. + eth_tot = 0. + do i=1,npart + ! Gas-gas potential + bind_g = bind_g + poten(i) ! Double counting factor of 1/2 already included in poten + + ! Sink-sink potential + phii = 0. + call get_accel_sink_gas(1,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass(:,1),dum1,dum2,dum3,phii) ! Include only core particle; no companion + bind_g = bind_g + particlemass * phii + + rhoi = rhoh(xyzh(4,i), particlemass) + call equationofstate(ieos,ponrhoi,spsoundi,rhoi,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhoi,eos_vars(itemp,i),ethi) + + eth_tot = eth_tot + ethi + eint_tot = eint_tot + particlemass * vxyzu(4,i) + enddo + bind_th = bind_g + eth_tot + bind_int = bind_g + eint_tot + + print*,bind_g*unit_energ, bind_th*unit_energ, bind_int*unit_energ + +end subroutine env_binding_ene + + +subroutine bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) + integer, intent(in) :: npart + real, intent(in) :: time, particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17), allocatable :: columns(:) + integer :: i, ncols + real, dimension(8) :: entropy_array + real :: etoti, ekini, einti, epoti, phii, rhopart + 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 + integer, parameter :: ient_ub = 2 + integer, parameter :: itemp_b = 3 + integer, parameter :: itemp_ub = 4 + integer, parameter :: ipres_b = 5 + integer, parameter :: ipres_ub = 6 + integer, parameter :: idens_b = 7 + integer, parameter :: idens_ub = 8 + + !zeroes the entropy variable and others + entropy_array = 0. + + !setup + if (dump_number == 0) then + call prompt('Would you like to use thermal energy in the computation of the bound/unbound status?', switch(1),.false.) + endif + + 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) + + rhopart = rhoh(xyzh(4,i), particlemass) + + !gets entropy for the current particle + call get_eos_various_mesa(rhopart*unit_density,vxyzu(4,i) * unit_ergg, & + pres_1,proint_1,peint_1,temp_1,troint_1, & + teint_1,entrop_1,abad_1,gamma1_1,gam_1) + + !sums entropy and other quantities for bound particles and unbound particles + + if (.not. switch(1)) then + etoti = etoti - einti + endif + + if (etoti < 0.0) then !bound + entropy_array(ient_b) = entropy_array(ient_b) + entrop_1 + entropy_array(itemp_b) = entropy_array(itemp_b) + temp_1 + entropy_array(ipres_b) = entropy_array(ipres_b) + pres_1 + entropy_array(idens_b) = entropy_array(idens_b) + rhopart*unit_density + + else !unbound + entropy_array(ient_ub) = entropy_array(ient_ub) + entrop_1 + entropy_array(itemp_ub) = entropy_array(itemp_ub) + temp_1 + entropy_array(ipres_ub) = entropy_array(ipres_ub) + pres_1 + entropy_array(idens_ub) = entropy_array(idens_ub) + rhopart*unit_density + + endif + + enddo + + !average + entropy_array(itemp_b) = entropy_array(itemp_b) / npart + entropy_array(itemp_ub) = entropy_array(itemp_ub) / npart + entropy_array(ipres_b) = entropy_array(ipres_b) / npart + entropy_array(ipres_ub) = entropy_array(ipres_ub) / npart + entropy_array(idens_b) = entropy_array(idens_b) / npart + entropy_array(idens_ub) = entropy_array(idens_ub) / npart + + !writes on file + ncols = 8 + allocate(columns(ncols)) + columns = (/' b entr',& + ' unb entr',& + ' avg b temp',& + ' avg unb temp',& + ' avg b pres',& + ' avg unb pres',& + ' avg b dens',& + ' avg unb dens'/) + call write_time_file('entropy_vs_time', columns, time, entropy_array, ncols, dump_number) + deallocate(columns) +end subroutine bound_unbound_thermo + + +!---------------------------------------------------------------- +!+ +! Gravitational drag +!+ +!---------------------------------------------------------------- +subroutine gravitational_drag(time,npart,particlemass,xyzh,vxyzu) + use prompting, only:prompt + use vectorutils, only:cross_product3D + integer, intent(in) :: npart + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17), allocatable :: columns(:) + character(len=17) :: filename + integer :: i,j,k,ncols,sizeRcut,vol_npart,merge_ij(nptmass),merge_n + integer, allocatable :: iorder(:) + real, dimension(:), allocatable, save :: ang_mom_old,time_old + real, dimension(:,:), allocatable :: drag_force + real, dimension(4,maxptmass) :: fxyz_ptmass,fxyz_ptmass_sinksink + real, dimension(3,maxptmass) :: dsdt_ptmass + real, dimension(3) :: avg_vel,avg_vel_par,avg_vel_perp,& + com_xyz,com_vxyz,unit_vel,unit_vel_perp,& + pos_wrt_CM,vel_wrt_CM,ang_mom,com_vec,& + unit_sep,unit_sep_perp,vel_contrast_vec,Fgrav + real :: drag_perp,drag_par,drag_perp_proj,& + vel_contrast,mdot,sep,Jdot,R2,& + rho_avg,cs,racc,fonrmax,fxi,fyi,fzi,& + phii,phitot,dtsinksink,interior_mass,sinksinksep,& + volume,vol_mass,vKep,omega,maxsep,cos_psi,mass_coregas,& + com_sink_sep,Fgrav_mag + real, dimension(:), allocatable :: Rcut + real, dimension(:,:,:), allocatable :: force_cut_vec + logical, save :: iacc,icentreonCM + integer, save :: iavgopt + + ! OPTIONS + if (dump_number == 0) then + print*,'Options for averaging gas properties:' + print "(6(/,a))",'1. Average over sphere centred on the companion (not recommended)',& + '2. Average over sphere centred on opposite side of orbit',& + '3. Average over annulus',& + '4. Average over annulus but excluding sphere centred on the companion',& + '5. Average over sphere twice as far on the opposite side of the orbit',& + '6. Average over sphere half as far on the opposite side of the orbit' + iavgopt = 2 + call prompt('Select option above : ',iavgopt,1,6) + icentreonCM = .false. + select case (iavgopt) + case(2,5,6) + call prompt('Centre averaging sphere on the CM (otherwise, centre on primary core)?: ',icentreonCM) + case(3,4) + call prompt('Centre annulus on the CM (otherwise, centre on primary core)?: ',icentreonCM) + end select + + write(*,"(a,i2)") 'Using ieos = ',ieos + if ( xyzmh_ptmass(ihacc,2) > 0 ) then + write(*,"(a,f13.7,a)") 'Companion has accretion radius = ', xyzmh_ptmass(ihacc,2), '(code units)' + write(*,"(a)") 'Will analyse accretion' + iacc = .true. + else + iacc = .false. + endif + endif + + ncols = 31 + allocate(columns(ncols),iorder(npart),force_cut_vec(4,maxptmass,5)) + allocate(drag_force(ncols,nptmass)) + columns = (/' drag_perp', & ! 1 Component of net force (excluding sink-sink) perpendicular to sink separation (projection on (r2-r1) x z) + ' drag_par', & ! 2 Component of net force (excluding sink-sink) projected along sink separation, -(r2-r1) + 'drag_perp_pr', & ! 3 'drag_perp' projected along the -v direction + ' F_dot_v', & ! 4 Dot product of 'drag_perp_pr' and sink velocity (<0 means energy dissipation) + ' drag_torque', & ! 5 torque / r of sink + ' cos_psi', & ! 6 Cosine of angle between (r2-r1) x z and -v + ' Fgrav', & ! 7 Magnitude of gravitational force from core and gas around it inferred from net force minus drag + 'mass_coregas', & ! 8 Mass of core+gas inferred from net force minus drag + ' drag_BHL', & ! 9 Bondi-Hoyle-Lyttleton drag force + ' mdot_BHL', & ! 10 Bond-Hoyle-Lyttleton mass accretion rate + ' v_con', & ! 11 Magnitude of average background gas velocity minus sink velocity, positive when vsink dot vgas < 0 + ' v_con_par', & ! 12 Projection of velocity contrast on -vsink + ' v_Kep', & ! 13 Keplerian velocity of companion, sqrt(M( 0.) then + rho_avg = vol_mass / volume + avg_vel_par(1:3) = dot_product(avg_vel, unit_vel) * unit_vel + avg_vel_perp(1:3) = avg_vel(1:3) - avg_vel_par(1:3) + vel_contrast_vec = avg_vel - vxyz_ptmass(1:3,i) + vel_contrast = sign( distance(vel_contrast_vec), -dot_product(vxyz_ptmass(1:3,i), avg_vel) ) + racc = 2. * xyzmh_ptmass(4,i) / (vel_contrast**2 + cs**2) ! Accretion radius + mdot = 4.*pi * xyzmh_ptmass(4,i)**2 * rho_avg / (cs**2 + vel_contrast**2)**1.5 ! BHL mass accretion rate + endif + + + ! Sum acceleration (fxyz_ptmass) on companion due to gravity of gas particles + force_cut_vec = 0. + fxyz_ptmass = 0. + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) + + sizeRcut = 5 + if (i == 1) allocate(Rcut(sizeRcut)) + call logspace(Rcut,0.4,2.5) + !Rcut = Rcut * racc ! Bin by fraction of accretion radius + Rcut = Rcut * separation( xyzmh_ptmass(1:3,1), xyzmh_ptmass(1:3,2) ) ! Bin by fraction of sink-sink separation + + do j = 1,npart + if (.not. isdead_or_accreted(xyzh(4,j))) then + ! Get total gravitational force from gas + call get_accel_sink_gas(nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),xyzmh_ptmass,& + fxi,fyi,fzi,phii,particlemass,fxyz_ptmass,dsdt_ptmass,fonrmax) + ! Get force from gas within distance cutoff + do k = 1,sizeRcut + if ( separation(xyzh(1:3,j), xyzmh_ptmass(1:4,i)) < Rcut(k) ) then + call get_accel_sink_gas(nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),xyzmh_ptmass,& + fxi,fyi,fzi,phii,particlemass,force_cut_vec(1:4,:,k),dsdt_ptmass,fonrmax) + endif + enddo + endif + enddo + + ! Calculate angular momentum of companion wrt orbit CoM + pos_wrt_CM = xyzmh_ptmass(1:3,i) - com_xyz(1:3) + vel_wrt_CM = vxyz_ptmass(1:3,i) - com_vxyz(1:3) + call cross_product3D(pos_wrt_CM, xyzmh_ptmass(4,i) * vel_wrt_CM, ang_mom) + Jdot = (ang_mom(3) - ang_mom_old(i)) / (time - time_old(i)) ! Average change in angular momentum + R2 = distance(xyzmh_ptmass(1:3,i) - com_xyz(1:3)) + ang_mom_old(i) = ang_mom(3) ! Set ang_mom_old for next dump + time_old(i) = time + + ! Calculate mass interior to companion + call set_r2func_origin(xyzmh_ptmass(1,3-i),xyzmh_ptmass(2,3-i),xyzmh_ptmass(3,3-i)) ! Order particles by distance from donor core + call indexxfunc(npart,r2func_origin,xyzh,iorder) + sinksinksep = separation(xyzmh_ptmass(1:3,1), xyzmh_ptmass(1:3,2)) + interior_mass = xyzmh_ptmass(4,3-i) ! Include mass of donor core + select case(iavgopt) + case(5) ! Calculate mass interior to R/2 + maxsep = 2.*sinksinksep + case(6) ! Calculate mass interior to 2*R + maxsep = 0.5*sinksinksep + case default ! Calculate mass interior to R + maxsep = sinksinksep + end select + do j = 1,npart + k = iorder(j) + sep = separation(xyzmh_ptmass(1:3,3-i), xyzh(1:3,k)) + if (sep > maxsep) exit + interior_mass = interior_mass + particlemass + enddo + vKep = sqrt(interior_mass / sinksinksep) + + ! Calculate perpendicular force projected along -v + cos_psi = cos_vector_angle(-unit_sep_perp, -vxyz_ptmass(1:3,i)) ! Theta is angle between (r2-r1) x z and -v + drag_par = - dot_product(fxyz_ptmass(1:3,i),unit_sep) * xyzmh_ptmass(4,i) ! Total force projected along -(r2-r1) + drag_perp = dot_product(fxyz_ptmass(1:3,i),-unit_sep_perp) * xyzmh_ptmass(4,i) ! Total force projected along -(r2-r1) x z + drag_perp_proj = drag_perp / cos_psi ! Perpendicular force projected along -v + + ! Calculate core + gas mass based on projected gravitational force + Fgrav = fxyz_ptmass(1:3,i) * xyzmh_ptmass(4,i) - drag_perp_proj * (-unit_vel) ! Ftot,gas + Fsinksink = Fdrag + Fgrav + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass_sinksink,phitot,dtsinksink,0,0.,merge_ij,merge_n,dsdt_ptmass) + Fgrav = Fgrav + fxyz_ptmass_sinksink(1:3,i) * xyzmh_ptmass(4,i) + Fgrav_mag = distance(Fgrav) + mass_coregas = Fgrav_mag * sinksinksep**2 / xyzmh_ptmass(4,i) + + ! Calculate CoM inferred from core + gas mass + com_vec = (mass_coregas * xyzmh_ptmass(1:3,3-i) + xyzmh_ptmass(4,i) * xyzmh_ptmass(1:3,i)) / (mass_coregas + xyzmh_ptmass(4,i)) + com_sink_sep = separation(com_vec, xyzmh_ptmass(1:3,i)) + + drag_force(1,i) = drag_perp + drag_force(2,i) = drag_par + drag_force(3,i) = drag_perp_proj + drag_force(4,i) = drag_perp_proj * (-distance(vxyz_ptmass(1:3,i))) + drag_force(5,i) = Jdot / R2 + drag_force(6,i) = cos_psi + drag_force(7,i) = Fgrav_mag + drag_force(8,i) = mass_coregas + drag_force(9,i) = mdot * vel_contrast ! BHL drag force + drag_force(10,i) = mdot + drag_force(11,i) = vel_contrast + drag_force(12,i) = dot_product(vel_contrast_vec, -unit_vel) + drag_force(13,i) = vKep + drag_force(14,i) = interior_mass + drag_force(15,i) = omega + drag_force(16,i) = cs + drag_force(17,i) = rho_avg + drag_force(18,i) = racc + drag_force(19,i) = com_sink_sep + drag_force(20,i) = separation(com_xyz(1:3),xyzmh_ptmass(1:3,i)) + drag_force(21,i) = sinksinksep + drag_force(22,i) = - dot_product(force_cut_vec(1:3,i,1),unit_sep) * xyzmh_ptmass(4,i) + drag_force(23,i) = - dot_product(force_cut_vec(1:3,i,1),unit_sep_perp) * xyzmh_ptmass(4,i) + drag_force(24,i) = - dot_product(force_cut_vec(1:3,i,2),unit_sep) * xyzmh_ptmass(4,i) + drag_force(25,i) = - dot_product(force_cut_vec(1:3,i,2),unit_sep_perp) * xyzmh_ptmass(4,i) + drag_force(26,i) = - dot_product(force_cut_vec(1:3,i,3),unit_sep) * xyzmh_ptmass(4,i) + drag_force(27,i) = - dot_product(force_cut_vec(1:3,i,3),unit_sep_perp) * xyzmh_ptmass(4,i) + drag_force(28,i) = - dot_product(force_cut_vec(1:3,i,4),unit_sep) * xyzmh_ptmass(4,i) + drag_force(29,i) = - dot_product(force_cut_vec(1:3,i,4),unit_sep_perp) * xyzmh_ptmass(4,i) + drag_force(30,i) = - dot_product(force_cut_vec(1:3,i,5),unit_sep) * xyzmh_ptmass(4,i) + drag_force(31,i) = - dot_product(force_cut_vec(1:3,i,5),unit_sep_perp) * xyzmh_ptmass(4,i) + + ! Write to output + write (filename, "(A16,I0)") "sink_drag_", i + call write_time_file(trim(adjustl(filename)), columns, time, drag_force(:,i), ncols, dump_number) + enddo + deallocate(columns,drag_force,force_cut_vec,Rcut) + +end subroutine gravitational_drag + + +subroutine J_E_plane(num,npart,particlemass,xyzh,vxyzu) + use vectorutils, only:cross_product3D + integer, intent(in) :: npart,num + 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, allocatable :: data(:,:) + + ncols = 7 + allocate(columns(ncols),data(ncols,npart)) + columns = (/' E',& + ' Jxcom',& + ' Jycom',& + ' Jzcom',& + ' Jxcore',& + ' Jycore',& + ' Jzcore'/) + + 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) + 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 + call cross_product3D(xyzh(1:3,i)-com_xyz(1:3), vxyz_ptmass(1:3,i)-com_vxyz(1:3), angmom_com) + data(2:4,i) = angmom_com + enddo + + data(1,:) = data(1,:) / particlemass ! specific energy + + call write_file('JEplane','JEplane',columns,data,size(data(1,:)),ncols,num) + deallocate(columns,data) + +end subroutine J_E_plane + +!------------------------------------------------------------------- +!+ +! Planet destruction +!+ +!------------------------------------------------------------------- +subroutine planet_destruction(time,npart,particlemass,xyzh,vxyzu) + use kernel, only:wkern + integer, intent(in) :: npart + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17), allocatable :: columns(:) + character(len=18) :: filename + real, allocatable :: planetDestruction(:) + integer :: ncols,i,j + real, save :: time_old + real, allocatable, save :: particleRho(:) + character(len=50) :: planetRadiusPromptString + real, allocatable, save :: planetRadii(:) !In units of Rsun + + real, dimension(3) :: currentGasVel, currentVelContrast + real :: currentRho(1) !Is a one element array because sphInterpolation returns a 1 dimensional array. + real :: currentRhoScaled,currentVelContrastScaled,currentPlanetRhoScaled + real :: currentPlanetMassScaled,currentPlanetRadiusScaled + real, allocatable, save :: currentKhAblatedMass(:) + + ncols=5 + allocate(columns(ncols),planetDestruction(ncols)) + columns=(/" rhoGas", & + " kh_rhoCrit", & + " kh_lmax", & + " kh_mdot", & + " kh_ablatedM" /) + + !Kelvin-Helmholtz instability planet destruction as described in "On the survival of brown dwarfs + !and planets by their giant host star" (https://arxiv.org/abs/1210.0879). Description of columns: + !rhoGas: background gas density at sink. In units of g/cm^3. + !kh_rhoCrit: paper equation 5. In units of g/cm^3. + !kh_lmax: paper equation 6. In units of Jupiter radii. + !kh_mdot: paper equation 7. In units of Jupiter mass/year. + !kh_ablatedM: kh_mdot integrated over time. In units of Jupiter masses. + + currentRho = 0. + do i=1,nptmass + if (i==1) cycle !The first sink is assumed to be the core. + + if ((dump_number==0) .and. (i==2)) then !This is only done once. + allocate(planetRadii(nptmass)) + planetRadii=0.1 + do j=2,nptmass + write(planetRadiusPromptString,"(A13,I0,A32)") "Enter planet ",j-1," radius in units of solar radii" + call prompt(planetRadiusPromptString,planetRadii(i),0.0,1.0) + enddo + + allocate(particleRho(npart)) + allocate(currentKhAblatedMass(nptmass)) + + time_old=0.0 + particleRho=getParticleRho(xyzh(4,:),particlemass) + currentKhAblatedMass=0.0 + endif + + + currentRho=sphInterpolation(npart,particlemass,particleRho,xyzh,xyzmh_ptmass(1:3,i),reshape(particleRho,(/1,npart/))) + currentGasVel=sphInterpolation(npart,particlemass,particleRho,xyzh,xyzmh_ptmass(1:3,i),vxyzu(1:3,:)) + currentVelContrast=vxyz_ptmass(1:3,i)-currentGasVel + + currentPlanetRadiusScaled=planetRadii(i)/0.1 !In units of 0.1 Rsun. + currentPlanetMassScaled=xyzmh_ptmass(4,i)*104.74 !In units of 10 jupiter masses. + currentPlanetRhoScaled=(xyzmh_ptmass(4,i)/((4.0/3.0)*pi*(planetRadii(i)**3.0)))*0.44 !In units of 13.34 g/cm^3 + currentRhoScaled=currentRho(1)*59000.0 !In units of 10^-4 g/cm^3. + currentVelContrastScaled=distance(currentVelContrast)*4.37 !In units of 100 km/s. + + planetDestruction(1)=currentRho(1)*5.9 + planetDestruction(2)=3.82*(currentPlanetRhoScaled**(4.0/3.0))*(currentPlanetMassScaled**(2.0/3.0))& + *(currentVelContrastScaled**(-2.0)) + planetDestruction(3)=0.0000263*(currentVelContrastScaled**2.0)*currentRhoScaled*(currentPlanetRhoScaled**((-5.0)/3.0))& + *(currentPlanetMassScaled**((-1.0)/3.0)) + planetDestruction(4)=11.0*currentVelContrastScaled*currentRhoScaled*(currentPlanetRadiusScaled**2.0)& + *(planetDestruction(3)/(currentPlanetRadiusScaled*0.973)) + + currentKhAblatedMass(i)=currentKhAblatedMass(i)+((time-time_old)*planetDestruction(4)*0.0000505) + planetDestruction(5)=currentKhAblatedMass(i) + + + write(filename, "(A17,I0)") "sink_destruction_",i + call write_time_file(filename, columns, time, planetDestruction, ncols, dump_number) + enddo + + time_old=time + + deallocate(columns,planetDestruction) +end subroutine planet_destruction + +!----------------------------------------------------------------------------------------- +!+ +!Binding energy profile +!+ +!----------------------------------------------------------------------------------------- +subroutine create_bindingEnergy_profile(time,num,npart,particlemass,xyzh,vxyzu) + real, intent(in) :: time,particlemass + integer, intent(in) :: num,npart + real, intent(in) :: xyzh(4,npart),vxyzu(4,npart) + + character(len=17), allocatable :: columns(:) + real, allocatable :: profile(:,:) + integer :: ncols,i,j + integer, allocatable :: iorder(:) + real :: currentInteriorMass,currentParticleGPE,currentCoreParticleSeparation + real :: previousBindingEnergy,previousBindingEnergyU + + ncols=3 + allocate(columns(ncols),iorder(npart)) + allocate(profile(ncols,npart)) + columns=(/" radius",& + " bEnergy",& !Binding energy without internal energy. + " bEnergy (u)"/) !Binding energy with internal energy. + + + call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) + call indexxfunc(npart,r2func_origin,xyzh,iorder) + currentInteriorMass=xyzmh_ptmass(4,1)+(npart*particlemass) !Initally set to the entire mass of the star. + + do i=npart,1,-1 !Loops over all particles from outer to inner. + j=iorder(i) + currentInteriorMass=currentInteriorMass-particlemass + currentCoreParticleSeparation=separation(xyzmh_ptmass(1:3,1),xyzh(1:3,j)) + currentParticleGPE=(currentInteriorMass*particlemass)/currentCoreParticleSeparation + + !The binding energy at a particular radius is the sum of the gravitational potential energies + !(and internal energies in the case of the third column) of all particles beyond that radius. + if (i==npart) then + previousBindingEnergy=0.0 + previousBindingEnergyU=0.0 + else + previousBindingEnergy=profile(2,i+1) + previousBindingEnergyU=profile(3,i+1) + endif + + profile(1,i)=currentCoreParticleSeparation + profile(2,i)=previousBindingEnergy+currentParticleGPE + profile(3,i)=previousBindingEnergyU+currentParticleGPE-(vxyzu(4,j)*particlemass) + enddo + + call write_file('bEnergyProfile','bEnergyProfiles',columns,profile,npart,ncols,num) + deallocate(columns,iorder,profile) + +end subroutine create_bindingEnergy_profile + + +subroutine get_core_gas_com(time,npart,xyzh,vxyzu) + use sortutils, only:set_r2func_origin,r2func_origin,indexxfunc + integer, intent(in) :: npart + real, intent(in) :: time + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real :: sep,maxsep,core_gas_com(3),core_gas_vcom(3),xyz_gas(4,npart),vxyz_gas(3,npart) + real, allocatable :: mytable(:) + character(len=17), allocatable :: columns(:) + character(len=17) :: filename + integer, save :: ngas + integer, allocatable, save :: iorder(:) + integer :: ncols,j,k + + ncols = 12 + allocate(columns(ncols)) + allocate(mytable(ncols)) + mytable = 0. + columns = (/' gas_com_x', & + ' gas_com_y', & + ' gas_com_z', & + ' gas_com_vx', & + ' gas_com_vy', & + ' gas_com_vz', & + ' core_x', & + ' core_y', & + ' core_z', & + ' core_vx', & + ' core_vy', & + ' core_vz' /) + + + ! Record particles that are closest to primary core + if (dump_number == 0) then + allocate(iorder(npart)) + maxsep = 10. ! 10 Rsun + ngas = 0 + call set_r2func_origin(xyzmh_ptmass(1,1),xyzmh_ptmass(2,1),xyzmh_ptmass(3,1)) ! Order particles by distance from donor core + call indexxfunc(npart,r2func_origin,xyzh,iorder) + + do j=1,npart + k = iorder(j) + if (j < 10) print*,k + sep = separation(xyzmh_ptmass(1:3,1), xyzh(1:3,k)) + if (sep > maxsep) exit + ngas = ngas + 1 + enddo + endif + + print*,'ngas=',ngas + + do j=1,ngas + k = iorder(j) + xyz_gas(1:4,j) = xyzh(1:4,k) + vxyz_gas(1:3,j) = vxyzu(1:3,k) + enddo + + call get_centreofmass(core_gas_com,core_gas_vcom,ngas,xyz_gas,vxyz_gas) ! Do not include sinks + + mytable(1:3) = core_gas_com(1:3) + mytable(4:6) = core_gas_vcom(1:3) + mytable(7:9) = xyzmh_ptmass(1:3,1) + mytable(10:12) = vxyz_ptmass(1:3,1) + + write (filename, "(A16,I0)") "core_gas_com" + call write_time_file(trim(adjustl(filename)),columns,time,mytable,ncols,dump_number) +end subroutine get_core_gas_com + + +!---------------------------------------------------------------- +!+ +! Print dump numbers corresponding to given sink-sink separations +!+ +!---------------------------------------------------------------- +subroutine print_dump_numbers(dumpfile) + character(len=*), intent(in) :: dumpfile + character(len=50), allocatable, save :: dumpfiles(:) + integer :: nseps + integer, save :: i + real, allocatable :: sinksinksep(:) + real :: sep + + nseps = 2 + allocate(sinksinksep(nseps)) + if (dump_number == 0) then + allocate(dumpfiles(nseps)) + i=1 + endif + sinksinksep = (/ 938., 67. /) + + sep = separation(xyzmh_ptmass(1:3,1),xyzmh_ptmass(1:3,2)) + if ( sep < sinksinksep(i) ) then + dumpfiles(i) = trim(dumpfile) + i=i+1 + endif + if (i==nseps+1) then + print "(5(a,/))",'../',dumpfiles + return + endif + +end subroutine print_dump_numbers + + +!---------------------------------------------------------------- +!+ +! Analyse disk +!+ +!---------------------------------------------------------------- +subroutine analyse_disk(num,npart,particlemass,xyzh,vxyzu) + use part, only:eos_vars,itemp + use extern_corotate, only:get_companion_force + use vectorutils, only:cross_product3D + integer, intent(in) :: num,npart + real, intent(in) :: particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + character(len=17), allocatable :: columns(:) + real, allocatable :: data(:,:) + real :: diskz,diskR2,diskR1,R,omegai,phii,rhopart,ponrhoi,spsoundi,tempi,& + epoti,ekini,ethi,Ji(3),vrel2,fxi,fyi,fzi,vphi + integer :: ncols,i + + ncols = 9 + allocate(columns(ncols),data(ncols,npart)) + data = -1. + columns = (/' R',& ! cylindrical radius w.r.t companion + ' E',& ! specific energy (kin+pot only) w.r.t. companion + ' Omega',& ! angular momentum w.r.t. companion + ' Jx',& ! specific angular momentum components + ' Jy',& + ' Jz',& + ' ekin',& + ' epot',& ! gravitational potential energy due to companion only + ' etherm'/) + + ! Set disk dimensions + diskz = 50. ! disk half-thickness + diskR1 = 5. ! disk inner radius + diskR2 = 150. ! disk outer radius + + do i=1,npart + ! Skip if particle is not within the defined disk + if (abs(xyzh(3,i) - xyzmh_ptmass(3,2)) > diskz) cycle + R = sqrt( (xyzh(1,i) - xyzmh_ptmass(1,2))**2 + (xyzh(2,i) - xyzmh_ptmass(2,2))**2 ) + if ( (R > diskR2) .or. (R < diskR1) ) cycle + + vrel2 = (vxyzu(1,i) - vxyz_ptmass(1,2))**2 + (vxyzu(2,i) - vxyz_ptmass(2,2))**2 + (vxyzu(3,i) - vxyz_ptmass(3,2))**2 + ekini = 0.5*particlemass*vrel2 + + ! Calculate gravitational potential due to companion only + phii = 0. + call get_companion_force(xyzh(1:3,i),fxi,fyi,fzi,phii) + epoti = phii*particlemass + + ! Calculate thermal 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) + + call get_gas_omega(xyzmh_ptmass(1:3,2),vxyz_ptmass(1:3,2),xyzh(1:3,i),vxyzu(1:3,i),vphi,omegai) + call cross_product3D(xyzh(1:3,i)-xyzmh_ptmass(1:3,2), vxyzu(1:3,i)-vxyz_ptmass(1:3,2), Ji) + + data(1,i) = R + data(2,i) = (ekini+epoti) / particlemass + data(3,i) = omegai + data(4:6,i) = Ji + data(7,i) = ekini + data(8,i) = epoti + data(9,i) = ethi + enddo + call write_file('companion_disk','companion_disk',columns,data,npart,ncols,num) + deallocate(columns) + +end subroutine analyse_disk + + +!---------------------------------------------------------------- +!+ +! Recombination energy vs. time +!+ +!---------------------------------------------------------------- +subroutine erec_vs_t(time,npart,particlemass,xyzh) + use ionization_mod, only:get_erec_components + integer, intent(in) :: npart + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:) + character(len=17) :: filename,columns(4) + integer :: i + real :: ereci(4),erec(4),tempi,rhoi + + columns = (/' H2', & + ' HI', & + ' HeI', & + ' HeII'/) + + erec = 0. + do i = 1,npart + rhoi = rhoh(xyzh(4,i), particlemass) + call get_erec_components( log10(rhoi*unit_density), tempi, X_in, 1.-X_in-Z_in, ereci) + erec = erec + ereci + enddo + + write (filename, "(A16,I0)") "erec_vs_t" + call write_time_file(trim(adjustl(filename)),columns,time,erec,4,dump_number) + +end subroutine erec_vs_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!! Routines used in analysis routines !!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!---------------------------------------------------------------- +!+ +! Calculate the angular velocity of an envelope gas particle +! relative to a reference point +!+ +!---------------------------------------------------------------- +subroutine get_gas_omega(xyz_centre,vxyz_centre,xyzi,vxyzi,vphi,omega) + use vectorutils, only:cross_product3D + real, intent(in) :: xyz_centre(3),vxyz_centre(3),xyzi(3),vxyzi(3) + real, intent(out) :: vphi,omega + real :: Rmag,R(3),phi_unitvec(3),R_unitvec(3) + + ! xyz_centre: Position vector of reference point + ! vxyz_centre: Velocity vector of reference point + ! R: Cylindrical radius vector + R(1:2) = xyzi(1:2) - xyz_centre(1:2) ! Separation in x-y plane + R(3) = 0. + Rmag = sqrt(dot_product(R,R)) + R_unitvec = R / Rmag + call cross_product3D((/0.,0.,1./), R_unitvec, phi_unitvec) ! phi = z x R + vphi = dot_product(vxyzi - vxyz_centre, phi_unitvec) + omega = vphi / Rmag +end subroutine get_gas_omega + + +!---------------------------------------------------------------- +!+ +! Calculate kinetic, gravitational potential (gas-gas and sink-gas), +! and internal energy of a gas particle. +!+ +!---------------------------------------------------------------- +subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,radprop,xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + ! Warning: Do not sum epoti or etoti as it is to obtain a total energy; this would not give the correct + ! total energy due to complications related to double-counting. + use ptmass, only:get_accel_sink_gas + use part, only:nptmass,iradxi + real, intent(in) :: particlemass + real(4), intent(in) :: poten + real, intent(in) :: xyzh(:),vxyzu(:),radprop(:) + real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass + real, intent(out) :: phii,epoti,ekini,einti,etoti + real :: fxi,fyi,fzi + + phii = 0.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) + if (do_radiation) einti = einti + particlemass * radprop(iradxi) + etoti = epoti + ekini + einti + +end subroutine calc_gas_energies + + +subroutine adjust_corotating_velocities(npart,particlemass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,omega_c,dump_number) + use vectorutils, only:cross_product3D + real, dimension(:,:), intent(in) :: xyzmh_ptmass,xyzh + real, dimension(:,:), intent(inout) :: vxyzu,vxyz_ptmass + real, intent(inout) :: omega_c + real, intent(in) :: particlemass + integer, intent(in) :: npart, dump_number + + logical :: switch + real :: sep, mtot + real, dimension(3) :: omega_vec, omegacrossr + integer :: i + + if (dump_number == 0) then + call prompt('Was this in a corotating frame?',switch,.false.) + + if (switch) then + sep = separation(xyzmh_ptmass(1:3,1), xyzmh_ptmass(1:3,2)) + mtot = sum(xyzmh_ptmass(4,:)) + npart*particlemass + omega_c = sqrt(mtot / sep**3) + else + omega_c = -1 + endif + endif + + if (omega_c > 0.) then + omega_vec = (/ 0.,0.,omega_c /) + + do i=1,npart + call cross_product3D(omega_vec,xyzh(1:3,i),omegacrossr) + vxyzu(1:3,i) = vxyzu(1:3,i) + omegacrossr(1:3) + enddo + + do i=1,nptmass + call cross_product3D(omega_vec,xyzmh_ptmass(1:3,i),omegacrossr) + vxyz_ptmass(1:3,i) = vxyz_ptmass(1:3,i) + omegacrossr(1:3) + enddo + endif +end subroutine adjust_corotating_velocities + + +! returns a profile from the centre of mass +! profile can either use all particles or can find particles within 2h of a given ray +! if simple flag is set to true, it will only produce a limited subset +subroutine stellar_profile(time,ncols,particlemass,npart,xyzh,vxyzu,profile,simple,ray) + use eos, only:ieos,equationofstate,X_in, Z_in + use eos_mesa, only:get_eos_kappa_mesa,get_eos_pressure_temp_mesa + use physcon, only:kboltz,mass_proton_cgs + use centreofmass, only:get_centreofmass + use energies, only:compute_energies + use part, only:xyzmh_ptmass,rhoh,ihsoft,poten + use units, only:udist,unit_ergg,unit_density,unit_pressure,unit_velocity,unit_energ + use kernel, only:kernel_softening,radkern + use ptmass, only:get_accel_sink_gas + use ionization_mod, only:ionisation_fraction + + real, intent(in) :: time + integer, intent(in) :: ncols + real, intent(in) :: particlemass + integer, intent(in) :: npart + real, intent(in) :: xyzh(:,:) + real, intent(inout) :: vxyzu(:,:) + real, intent(out), allocatable :: profile(:,:) + logical, intent(in) :: simple + real, intent(in), optional :: ray(3) + integer :: i,iprofile + 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 :: xh0, xh1, xhe0, xhe1, xhe2 + real :: temp_profile(ncols,npart) + logical :: criteria + + call compute_energies(time) + + iprofile = 0 + + do i=1,npart + if (xyzh(4,i) >= 0) then + + if (present(ray)) then + proj_mag = dot_product(xyzh(1:3,i),ray(1:3)) + proj = proj_mag * ray + orth(1:3) = xyzh(1:3,i) - proj(1:3) + orth_dist = separation(orth,(/0.,0.,0./)) + orth_ratio = orth_dist / xyzh(4,i) + if (orth_ratio < radkern .and. proj_mag > 0.) then + criteria = .true. + else + criteria = .false. + endif + else + criteria = .true. + endif + + if (criteria) then + + iprofile = iprofile + 1 + + rhopart = rhoh(xyzh(4,i), particlemass) + + temp_profile(1,iprofile) = distance(xyzh(1:3,i)) * udist + temp_profile(3,iprofile) = atan2(xyzh(2,i),xyzh(1,i)) + temp_profile(4,iprofile) = rhopart * unit_density + temp_profile(5,iprofile) = distance(vxyzu(1:3,i)) * unit_velocity + temp_profile(6,iprofile) = dot_product(vxyzu(1:3,i),xyzh(1:3,i)) / distance(xyzh(1:3,i)) * unit_velocity + temp_profile(7,iprofile) = sqrt(distance(vxyzu(1:2,i))**2 - (dot_product(vxyzu(1:2,i),xyzh(1:2,i)) & + / distance(xyzh(1:2,i)))**2) * unit_velocity + temp_profile(8,iprofile) = temp_profile(7,iprofile) / (distance(xyzh(1:2,i)) * udist) + if (simple .eqv. .false.) then + call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) + + if (ieos == 10) then + call get_eos_pressure_temp_mesa(rhopart*unit_density,vxyzu(4,i) * unit_ergg,pres,temp) + call get_eos_kappa_mesa(rhopart*unit_density,temp,kappa,kappat,kappar) + else + temp = (ponrhoi * (unit_pressure/unit_density) * 2.381 * mass_proton_cgs) / kboltz + kappa = 1. + endif + + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),& + xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + + call ionisation_fraction(rhopart*unit_density,temp,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) + + temp_profile(9,iprofile) = vxyzu(4,i) * unit_ergg + temp_profile(10,iprofile) = ponrhoi * rhopart * unit_pressure + temp_profile(11,iprofile) = spsoundi * unit_velocity + temp_profile(12,iprofile) = temp + temp_profile(13,iprofile) = kappa + temp_profile(14,iprofile) = 1. / (kappa * rhopart * unit_density) + temp_profile(15,iprofile) = etoti * unit_energ + temp_profile(16,iprofile) = xh1 + temp_profile(17,iprofile) = xhe1 + temp_profile(18,iprofile) = xhe2 + endif + endif + endif + enddo + + allocate(profile(ncols,iprofile)) + profile(1:ncols,1:iprofile) = temp_profile(1:ncols,1:iprofile) + + call quicksort(profile, 1, iprofile, ncols, 1) + + do i=1,iprofile + if (i==1) profile(2,i) = particlemass + if (i > 1) profile(2,i) = profile(2,i-1) + particlemass + enddo + + deallocate(profile) + print*, "Profile completed" + +end subroutine stellar_profile + +!---------------------------------------------------------------- +!+ +! Calculate mass interior to companion +!+ +!---------------------------------------------------------------- +subroutine get_interior_mass(xyzh,vxyzu,donor_xyzm,companion_xyzm,particlemass,npart,iavgopt,interior_mass,com_xyz,com_vxyz) + real, intent(in) :: xyzh(:,:),vxyzu(:,:),donor_xyzm(4),companion_xyzm(4),particlemass + real, intent(out) :: interior_mass,com_xyz(3),com_vxyz(3) + integer, intent(in) :: npart,iavgopt + real :: sinksinksep,maxsep,sep,xyz_int(3,npart),vxyz_int(3,npart) + integer :: j,k,npart_int + integer, allocatable :: iorder(:) + + ! Calculate mass interior to companion + allocate(iorder(npart)) + call set_r2func_origin(donor_xyzm(1),donor_xyzm(2),donor_xyzm(3)) ! Order particles by distance from donor core + call indexxfunc(npart,r2func_origin,xyzh,iorder) + sinksinksep = separation(donor_xyzm(1:3), companion_xyzm(1:3)) + interior_mass = donor_xyzm(4) ! Include mass of donor core + select case(iavgopt) + case(5) ! Calculate mass interior to R/2 + maxsep = 2.*sinksinksep + case(6) ! Calculate mass interior to 2*R + maxsep = 0.5*sinksinksep + case default ! Calculate mass interior to R + maxsep = sinksinksep + end select + npart_int = 0 + do j = 1,npart + k = iorder(j) + sep = separation(donor_xyzm(1:3), xyzh(1:3,k)) + if (sep > maxsep) exit + npart_int = npart_int + 1 + xyz_int(1:3,npart_int) = xyzh(1:3,k) + vxyz_int(1:3,npart_int) = vxyzu(1:3,k) + enddo + interior_mass = npart_int * particlemass + + call get_centreofmass(com_xyz,com_vxyz,npart_int,xyz_int,vxyz_int,nptmass,xyzmh_ptmass,vxyz_ptmass) + deallocate(iorder) + +end subroutine get_interior_mass + +!---------------------------------------------------------------- +!+ +! Get CoM position and velocity of the two point masses plus +! gas particles radius = 2*sep from the donor, where sep is the +! distance between the donor and the CoM of just the point masses. +!+ +!---------------------------------------------------------------- +subroutine orbit_com(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,com_xyz,com_vxyz) + integer, intent(in) :: npart,nptmass + real, intent(in) :: xyzh(:,:),vxyzu(:,:),xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(out), dimension(3) :: com_xyz,com_vxyz + real, allocatable :: xyz_a(:,:) + real, allocatable :: vxyz_a(:,:) + integer, allocatable :: iorder(:) + integer :: npart_a + real :: sep + integer :: i,j,k + + allocate(iorder(npart),xyz_a(4,npart),vxyz_a(3,npart)) + + ! Get order of particles by distance from CoM of point masses + com_xyz(1) = sum(xyzmh_ptmass(1,:)*xyzmh_ptmass(4,:))/nptmass + com_xyz(2) = sum(xyzmh_ptmass(2,:)*xyzmh_ptmass(4,:))/nptmass + com_xyz(3) = sum(xyzmh_ptmass(3,:)*xyzmh_ptmass(4,:))/nptmass + call set_r2func_origin(com_xyz(1),com_xyz(2),com_xyz(3)) + call indexxfunc(npart,r2func_origin,xyzh,iorder) + ! Displacement of donor core from the CoM of point masses + sep = separation(xyzmh_ptmass(1:3,1),com_xyz(1:3)) + + ! Calculate CoM of orbit, including only gas particles within radius = 2*sep from donor core + ! The point is that by including some gas particles around the donor core, we get a more accurate + ! position of the CoM about which the stellar cores orbit + i = 1 + k = 1 + do while (i < npart+1) + j = iorder(i) ! Loop from particles closest to farthest from CoM + if (isdead_or_accreted(xyzh(4,j))) then + i = i + 1 + else + if (separation(xyzh(1:3,j),com_xyz(1:3)) > 2.*sep) exit + xyz_a(1:4,k) = xyzh(1:4,j) + vxyz_a(1:3,k) = vxyzu(1:3,j) + i = i + 1 + k = k + 1 + endif + enddo + npart_a = k - 1 + call get_centreofmass(com_xyz,com_vxyz,npart_a,xyz_a,vxyz_a,nptmass,xyzmh_ptmass,vxyz_ptmass) + deallocate(iorder,xyz_a,vxyz_a) + +end subroutine orbit_com + +subroutine average_in_vol(xyzh,vxyzu,npart,particlemass,com_xyz,com_vxyz,isink,icentreonCM,iavgopt,vel,cs,omega,volume,vol_mass,& + vol_npart) + real, intent(in) :: xyzh(:,:),vxyzu(:,:),com_xyz(:),com_vxyz(:),particlemass + logical, intent(in) :: icentreonCM + real, intent(out) :: vel(:),cs,omega,volume,vol_mass + integer, intent(out) :: vol_npart + integer, intent(in) :: npart,isink,iavgopt + real :: orbit_centre(3),orbit_centre_vel(3),sphere_centre(3),Rarray(size(xyzh(1,:))),zarray(size(xyzh(1,:))),vxyzu_copy(4) + real :: Rsphere,sep,omega_out,Rsinksink,dR,dz,vphi + integer :: i,j,k,iorder(size(xyzh(1,:))) + + i = isink + if (icentreonCM) then ! Centre on orbit CoM + orbit_centre = com_xyz + orbit_centre_vel = com_vxyz + else ! Centre on primary core + orbit_centre = xyzmh_ptmass(1:3,3-i) + orbit_centre_vel = vxyz_ptmass(1:3,3-i) + endif + + Rsphere = 0.2 * separation(orbit_centre, xyzmh_ptmass(1:3,i)) + Rsinksink = separation(xyzmh_ptmass(1:2,i), xyzmh_ptmass(1:2,3-i)) ! [(x2-x1)^2 + (y2-y1)^2]^0.5 + dR = 0.2*Rsinksink + dz = 0.2*Rsinksink + vol_npart = 0 + vol_mass = 0. + omega = 0. + cs = 0. + + ! If averaging over a sphere, get order of particles from closest to farthest from sphere centre + dr = 0. + dz = 0. + Rsinksink = 0. + vol_npart = 0 + Rsphere = 0. + select case(iavgopt) + case(1,2,5,6) + select case (iavgopt) + case(1) ! Use companion position + sphere_centre = xyzmh_ptmass(1:3,i) + case(2) ! Use companion position on the opposite side of orbit + sphere_centre = 2.*orbit_centre - xyzmh_ptmass(1:3,i) ! Just r1 - (r2 - r1) + case(5) ! Averaging twice as far on opposite side of orbit + sphere_centre = 2.*(orbit_centre - xyzmh_ptmass(1:3,i)) ! Just r1 - 2(r2 - r1) + case(6) ! Averaging half as far on opposite side of orbit + sphere_centre = 1.5*orbit_centre - 0.5*xyzmh_ptmass(1:3,i) ! Just r1 - 0.5*(r2 - r1) + end select + call set_r2func_origin(sphere_centre(1),sphere_centre(2),sphere_centre(3)) + call indexxfunc(npart,r2func_origin,xyzh,iorder) + + ! Sum velocities, cs, and densities of all particles within averaging sphere + do j = 1,npart + k = iorder(j) ! Only use particles within the averaging sphere + if (.not. isdead_or_accreted(xyzh(4,k))) then + sep = separation(xyzh(1:3,k), sphere_centre) + if (sep > Rsphere) exit + vel(1:3) = vel(1:3) + vxyzu(1:3,k) + vxyzu_copy = vxyzu(:,k) + cs = cs + get_spsound(ieos,xyzh(1:3,k),rhoh(xyzh(4,k),particlemass),vxyzu_copy) + call get_gas_omega(orbit_centre,orbit_centre_vel,xyzh(1:3,k),vxyzu(1:3,k),vphi,omega_out) + omega = omega + omega_out + endif + enddo + vol_npart = j-1 ! Number of (unaccreted) particles in the sphere + vol_mass = vol_npart * particlemass + if ((iavgopt == 2) .or. (iavgopt == 5) .or. (iavgopt == 6)) vel = -vel ! To-do: get rid of this line + + ! Averaging in annulus + case(3,4) + Rarray = sqrt( (xyzh(1,:) - xyzmh_ptmass(1,3-i))**2 + (xyzh(2,:) - xyzmh_ptmass(2,3-i))**2) ! [(x-x1)^2 + (y-y1)^2]^0.5 + zarray = xyzh(3,:) - xyzmh_ptmass(3,3-i) + if (iavgopt == 4) Rsphere = 0.2*separation(xyzmh_ptmass(1:3,3-i),xyzmh_ptmass(1:3,i)) + do k = 1,npart + if ( (iavgopt == 4) .and. (separation(xyzh(1:3,k), xyzmh_ptmass(1:3,i)) < Rsphere) ) cycle + if ( (abs(Rarray(k) - Rsinksink) < 0.5*dR) .and.& + (abs(zarray(k) - xyzmh_ptmass(3,3-i)) < 0.5*dz) ) then + vel = vel + vxyzu(1:3,k) + vxyzu_copy = vxyzu(:,k) + cs = cs + get_spsound(ieos,xyzh(1:3,k),rhoh(xyzh(4,k),particlemass),vxyzu_copy) + call get_gas_omega(orbit_centre,orbit_centre_vel,xyzh(1:3,k),vxyzu(1:3,k),vphi,omega_out) + omega = omega + omega_out + vol_npart = vol_npart + 1 + endif + enddo + vol_mass = vol_npart * particlemass + end select + + ! Calculate averaging volume based on averaging option + select case (iavgopt) + case (1,2,5,6) ! Spheres + volume = 4./3.*pi*Rsphere**3 + case(3) ! Annulus + volume = 2.*pi * Rsinksink * dR * dz + case(4) ! Annulus with sphere subtracted + volume = 2.*pi * Rsinksink * dR * dz + volume = volume - 0.4*dR*dz*Rsinksink + case default + volume = 0. + print*,'Unknown averaging option' + return + end select + + ! Calculate volume averages + if (vol_npart > 0) then + vel(1:3) = vel(1:3) / float(vol_npart) + omega = omega / float(vol_npart) + cs = cs / float(vol_npart) + endif + +end subroutine average_in_vol + + +!---------------------------------------------------------------- +!+ +! Returns hist, the radial or mass-coordinate profile of a +! quantity. +! +! Inputs: +! coord: Array of radius or mass-coordinate of each particle +! quant: Array containing quantity for each particle to be binned +! bin_min: Lower bin edge for coord +! bin_max: Upper bin edge for coord +! nbins: Number of bins for coord +! logbins: If true, produce log-uniform bins +! normalise_by_bincount: If true, normalises histogram by bin +! count, thus averaging the quantity +!+ +!---------------------------------------------------------------- +subroutine histogram_setup(coord,quant,hist,npart,bin_max,bin_min,nbins,normalise_by_bincount,logbins) + integer, intent(in) :: npart,nbins + real, intent(in) :: coord(npart),quant(npart),bin_max, bin_min + logical, intent(in) :: normalise_by_bincount,logbins + real, intent(out) :: hist(nbins) + integer :: i,j,bincount(nbins) + real :: bins(nbins) + + if (logbins) then ! Create log-uniform bins + bins = (/ (10**(bin_min + (i-1) * (bin_max-bin_min)/real(nbins)), i=1,nbins) /) + else ! Create linear bins + bins = (/ (bin_min + (i-1) * (bin_max-bin_min)/real(nbins), i=1,nbins) /) + endif + + hist = 0. + bincount = 0 + + do j=1,npart + do i=1,nbins-1 + if (coord(j) >= bins(i) .and. coord(j) < bins(i+1)) then + bincount(i) = bincount(i) + 1 + hist(i) = hist(i) + quant(j) + exit ! Move onto next particle + endif + enddo + enddo + + if (normalise_by_bincount) then + do i=1,nbins + if (bincount(i) > 0) then + hist(i) = hist(i) / real(bincount(i)) + endif + enddo + endif + +end subroutine histogram_setup + +subroutine write_file(name_in, dir_in, cols, data_in, npart, ncols, num) + !outputs a file from a single dump + character(len=*), intent(in) :: name_in, dir_in + integer, intent(in) :: npart, ncols, num + character(len=*), dimension(ncols), intent(in) :: cols + character(len=20), dimension(ncols) :: columns + character(len=40) :: data_formatter, column_formatter + character(len(name_in)+9) :: file_name + + real, dimension(ncols,npart), intent(in) :: data_in + integer :: i, unitnum + + unitnum = 1000 + num + if (dump_number == 0) then + call system('mkdir ' // dir_in ) + endif + + write(file_name, "(2a,i5.5,a)") trim(name_in), "_", num, ".ev" + + open(unit=unitnum,file='./'//dir_in//'/'//file_name,status='replace') + + write(column_formatter, "(a,I2.2,a)") "('#',2x,", ncols, "('[',a15,']',3x))" + write(data_formatter, "(a,I2.2,a)") "(", ncols, "(2x,es19.11e3))" + + do i=1,ncols + write(columns(i), "(I2.2,a)") i, cols(i) + enddo + + !set column headings + write(unitnum, column_formatter) columns(:) + + !Write data to file + do i=1,npart + write(unitnum,data_formatter) data_in(:ncols,i) + enddo + + close(unit=unitnum) +end subroutine write_file + + +subroutine write_time_file(name_in, cols, time, data_in, ncols, num) + !outputs a file over a series of dumps + character(len=*), intent(in) :: name_in + integer, intent(in) :: ncols, num + character(len=*), dimension(ncols), intent(in) :: cols + character(len=20), dimension(ncols) :: columns + character(len=40) :: data_formatter, column_formatter + character(len(name_in)+9) :: file_name + real, intent(in) :: time + real, dimension(ncols), intent(in) :: data_in + integer :: i, unitnum + + write(column_formatter, "(a,I2.2,a)") "('#',2x,", ncols+1, "('[',a15,']',3x))" + write(data_formatter, "(a,I2.2,a)") "(", ncols+1, "(2x,es18.11e2))" + write(file_name,"(2a,i3.3,a)") name_in, '.ev' + + if (num == 0) then + unitnum = 1000 + + open(unit=unitnum,file=file_name,status='replace') + do i=1,ncols + write(columns(i), "(I2,a)") i+1, cols(i) + enddo + + !set column headings + write(unitnum, column_formatter) '1 time', columns(:) + close(unit=unitnum) + endif + + unitnum=1001+num + + open(unit=unitnum,file=file_name, position='append') + + write(unitnum,data_formatter) time, data_in(:ncols) + + close(unit=unitnum) + +end subroutine write_time_file + +real function distance(a) + ! Return norm of a vector of arbitrary dimension + real, intent(in), dimension(:) :: a + + distance = sqrt(dot_product(a,a)) +end function distance + +subroutine unit_vector(a,b) + real, intent(in), dimension(3) :: a + real, intent(out), dimension(3) :: b + + b(1:3) = a(1:3) / distance(a(1:3)) +end subroutine unit_vector + +real function cos_vector_angle(a,b) + real, intent(in), dimension(3) :: a,b + if (distance(a) == 0 .or. distance(b) == 0) then + cos_vector_angle = 1. + else + cos_vector_angle = dot_product(a,b) / (distance(a) * distance(b)) + endif +end function cos_vector_angle + +subroutine separation_vector(a,b,c) + !return difference between two vectors + real, intent(in), dimension(3) :: a,b + real, intent(out), dimension(4) :: c + + c(1) = a(1) - b(1) + c(2) = a(2) - b(2) + c(3) = a(3) - b(3) + c(4) = distance(c(1:3)) +end subroutine separation_vector + +real function separation(a,b) + !return the distance between two vectors + real, intent(in), dimension(:) :: a,b + + separation = distance(a - b) +end function separation + +!Creates an array of SPH particle densities for each value of h. +elemental real function getParticleRho(h,particlemass) + real, intent(in) :: h,particlemass + getParticleRho=rhoh(h,particlemass) +end function getParticleRho + +!Performs SPH interpolation on the SPH particle property toInterpolate at the location interpolateXyz. +!The smoothing length used is the smoothing length of the closest SPH particle to interpolateXyz. +function sphInterpolation(npart,particlemass,particleRho,particleXyzh,interpolateXyz,toInterpolate) result(interpolatedData) + use kernel, only:wkern + integer, intent(in) :: npart + real, intent(in) :: particlemass + real, intent(in) :: particleRho(npart) + real, intent(in) :: particleXyzh(4,npart) + real, intent(in) :: interpolateXyz(3) + real, intent(in) :: toInterpolate(:,:) + real :: interpolatedData(size(toInterpolate,1)) + + integer :: i,j + integer, allocatable :: iorder(:) + real :: currentR,currentQ,currentQ2 + real :: nearestSphH + real :: currentParticleRho,currentSphSummandFactor + + interpolatedData=0.0 + allocate(iorder(npart)) + call set_r2func_origin(interpolateXyz(1),interpolateXyz(2),interpolateXyz(3)) + call indexxfunc(npart,r2func_origin,particleXyzh,iorder) !Gets the order of SPH particles from the interpolation point. + nearestSphH=particleXyzh(4,iorder(1)) !The smoothing length of the nearest SPH particle to the ineterpolation point. + + do i=1,npart + j=iorder(i) + + currentR=separation(interpolateXyz,particleXyzh(1:3,j)) + currentQ=currentR/nearestSphH !currentR is scaled in units of nearestSphH + currentQ2=currentQ**2.0 + + !All SPH particles beyond 2 smoothing lengths are ignored. + if (currentQ>2) then + exit + endif + + !SPH interpolation is done below. + currentParticleRho=particleRho(j) + currentSphSummandFactor=(particlemass/currentParticleRho)*((1.0/((nearestSphH**3.0)*pi))*wkern(currentQ2,currentQ)) + interpolatedData=interpolatedData+(currentSphSummandFactor*toInterpolate(:,j)) + enddo + deallocate(iorder) + +end function sphInterpolation + +!Sorting routines +recursive subroutine quicksort(a, first, last, ncols, sortcol) + integer, intent(in) :: first, last, ncols, sortcol + real, dimension(ncols,last-first+1), intent(inout) :: a + real :: x + integer :: i, j, k + + x = a(sortcol, (first+last) / 2 ) + i = first + j = last + do + do while (a(sortcol, i) < x) + i=i+1 + enddo + + do while (x < a(sortcol, j)) + j=j-1 + enddo + + if (i >= j) exit + + do k=1,ncols + call swap(a(k,i),a(k,j)) + enddo + + i=i+1 + j=j-1 + enddo + if (first < i-1) call quicksort(a, first, i-1, ncols, sortcol) + if (j+1 < last) call quicksort(a, j+1, last, ncols, sortcol) +end subroutine quicksort + +subroutine swap(a,b) + real, intent(inout) :: a,b + real :: c + + c = a + a = b + b = c + +end subroutine swap + + +!---------------------------------------------------------------- +!+ +! Determine ID of planet particles based on distance from host star core +!+ +!---------------------------------------------------------------- +subroutine get_planetIDs(nplanet,planetIDs) + integer, allocatable, intent(out) :: planetIDs(:) + integer, intent(out) :: nplanet + integer :: i + + ! Determine planet particle IDs (the nplanet particles initially farthest from the donor star) + nplanet = 1262 + call prompt('Enter number of planet particles:',nplanet,0) + allocate(planetIDs(nplanet)) + do i = 1,nplanet + planetIDs(i) = i + enddo + +end subroutine get_planetIDs + + +!---------------------------------------------------------------- +!+ +! Set EOS options for analysis +!+ +!---------------------------------------------------------------- +subroutine set_eos_options(analysis_to_perform) + integer, intent(in) :: analysis_to_perform + integer :: ierr + + ieos = 2 + call prompt('Enter ieos:',ieos) + select case(ieos) + 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 + case(10,20) + gamma = 5./3. + X_in = 0.69843 + Z_in = 0.01426 + call prompt('Enter hydrogen mass fraction:',X_in,0.,1.) + call prompt('Enter metallicity:',Z_in,0.,1.) + irecomb = 0 + if (ieos==20) call prompt('Using gas+rad+rec EoS. Enter irecomb:',irecomb,0,2) + case default + call fatal('analysis_common_envelope',"EOS type not supported") + end select + call init_eos(ieos,ierr) + if (ierr /= 0) call fatal('analysis_common_envelope',"Failed to initialise EOS") + +end subroutine set_eos_options + + +!---------------------------------------------------------------- +!+ +! Calculates escape velocity for all SPH particles given the potential energy +! of the system at that time +!+ +!---------------------------------------------------------------- +subroutine calc_escape_velocities(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phii,epoti,v_esc) + use ptmass, only:get_accel_sink_gas + use part, only:nptmass + real, intent(in) :: particlemass + real(4), intent(in) :: poten + real, dimension(4), intent(in) :: xyzh,vxyzu + real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass + real :: phii,epoti + real :: fxi,fyi,fzi + real, intent(out) :: v_esc + + phii = 0.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 + v_esc = sqrt(2*abs(epoti/particlemass)) + +end subroutine calc_escape_velocities + +end module analysis From d16edd7879e77c16dbb2188ed5ab626613824c0b Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 29 Jul 2024 16:53:02 +0100 Subject: [PATCH 738/814] More upstream updates --- build/Makefile | 1 + build/Makefile_setups | 12 +- src/main/lumin_nsdisc.f90 | 1118 ----------------- src/main/mpi_force.F90 | 3 + src/main/phantom.F90 | 2 +- src/main/readwrite_dumps_common.f90 | 453 ++++++- ...ortran.F90 => readwrite_dumps_fortran.f90} | 836 ++---------- src/main/readwrite_infile.F90 | 10 +- src/utils/analysis_GalMerger.f90 | 2 +- src/utils/analysis_NSmerger.f90 | 6 +- 10 files changed, 591 insertions(+), 1852 deletions(-) delete mode 100644 src/main/lumin_nsdisc.f90 rename src/main/{readwrite_dumps_fortran.F90 => readwrite_dumps_fortran.f90} (64%) diff --git a/build/Makefile b/build/Makefile index 96454f9b3..1ad43de54 100644 --- a/build/Makefile +++ b/build/Makefile @@ -1287,6 +1287,7 @@ giza-fortran.o : $(SPLASH_DIR)/giza/interface/giza-fortran.F90 $(SPLASH_DIR)/giz compilers: @echo "I suggest one of the following, based on detected Fortran compilers..."; echo; + @if type -p ifx > /dev/null; then echo "make SYSTEM=ifx"; fi; @if type -p ifort > /dev/null; then echo "make SYSTEM=ifort"; fi; @if type -p pathf90 > /dev/null; then echo "make SYSTEM=pathf90"; fi; @if type -p pgf90 > /dev/null; then echo "make SYSTEM=pgf90"; fi; diff --git a/build/Makefile_setups b/build/Makefile_setups index d5f34b9a5..65cb620f4 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -206,7 +206,7 @@ ifeq ($(SETUP), grdisc) # accretion disc around a Kerr black hole SETUPFILE= setup_grdisc.f90 ANALYSIS= analysis_disc.f90 - GR=yes + GR=no METRIC=kerr KNOWN_SETUP=yes MULTIRUNFILE= multirun.f90 @@ -421,6 +421,16 @@ 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/lumin_nsdisc.f90 b/src/main/lumin_nsdisc.f90 deleted file mode 100644 index 90db88923..000000000 --- a/src/main/lumin_nsdisc.f90 +++ /dev/null @@ -1,1118 +0,0 @@ -!--------------------------------------------------------------------------! -! 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 lumin_nsdisc -! -! This module contains routines for calculating beta, the -! ratio of radiation to gravitational force, for an accretion disc -! surrounding a neutron star. It contains associated functions -! for calculating opacity, accretion luminosity, etc. -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: eos, infile_utils, io, physcon, units -! - - use physcon, only: pi - implicit none - - real :: LumAcc = 0.0 ! luminosity from accretion - integer, public :: BurstProfile = 0 ! Burst luminosity / profile - real, private :: Lstar = 0.0 ! total luminosity of star as a fraction of Eddington - real, private :: LEdd = 0.0 ! Eddington luminosity in code units - real, private :: frac_X = 0.7 ! Hydrogen fraction - integer, private :: rad_trans = 0 ! Radiation transport prescription - real :: AccLumEff = 1.0 ! Fraction of accretion luminosity that - ! participates in radiation force. This is - ! mostly only relevant for compact objects. - ! number of gridpoints for the rho, tau, beta grids - integer, parameter :: nr = 63, nth=16 , nph=24, nz=30 - real :: ringrid(0:nr), cyl_ringrid(0:nr), thmingrid(0:nth), phmingrid(0:nph), zmingrid(0:nz) - integer :: npgrid(0:nr-1,0:nth-1,0:nph-1), w92npart( 0:nr-1 ), cyl_npgrid(0:nr-1,0:nz,0:nph-1) - real :: densitygrid(0:nr-1,0:nth-1,0:nph-1), ldensitygrid(0:nr-1,0:nth-1,0:nph-1) - real :: tauradgrid(0:nr-1,0:nth-1,0:nph-1), ltauradgrid(0:nr-1,0:nth-1,0:nph-1) - real :: betagrid(0:nr-1,0:nth-1,0:nph-1), lbetagrid(0:nr-1,0:nth-1,0:nph-1) !the grids - - real :: cyl_densitygrid(0:nr-1,0:nz,0:nph-1), cyl_ldensitygrid(0:nr-1,0:nz,0:nph-1) - real :: cyl_tauradgrid(0:nr-1,0:nz,0:nph-1), cyl_ltauradgrid(0:nr-1,0:nz,0:nph-1) - real :: cyl_betagrid(0:nr-1,0:nz,0:nph-1), cyl_lbetagrid(0:nr-1,0:nz,0:nph-1) !cylindrical grids - - real :: w92betagrid( 0:nr-1 ), w92sumbeta( 0:nr-1 ) !cylindrical grid for comparison with W92 - real :: thetamin = 0.0, thetamax = pi, rmin = 1.0, rmax = 1001.0 - real :: zmin = -200, zmax=200 - real :: phimax = 2*pi, phimin=0 - real :: Lstar_burst - real, parameter :: eps = 1.e-6 - integer, private :: made_grid_points = 0 - - public :: beta, set_Lstar, calc_sigma, calc_scaleheight - public :: read_options_lumin_nsdisc, write_options_lumin_nsdisc - public :: LumAcc, Lstar_burst, AccLumEff, ringrid, thmingrid, thetamin, thetamax, rmin, rmax - public :: nr, nth, nph, densitygrid, tauradgrid, betagrid, lbetagrid, make_beta_grids - public :: get_grid_points, bilin_interp, get_grid_bins, sphere_segment, get_bracket_grid_points - public :: ldensitygrid, ltauradgrid, careful_log, phmingrid, phimin, phimax, w92betagrid - public :: cyl_ringrid, zmingrid, cyl_npgrid, cyl_densitygrid, cyl_ldensitygrid, cyl_tauradgrid - public :: cyl_ltauradgrid, cyl_betagrid, cyl_lbetagrid, zmin, zmax, nz - - private :: calc_kappa, eps - - private - -contains - -!---------------------------------------------------------------- -!+ -! Sets the location of the grid points -!+ -!---------------------------------------------------------------- - -subroutine make_grid_points() - use physcon, only:pi, twopi - integer :: rbin, thbin, phbin, zbin - real :: A, B, C, tempr - A = (rmax-rmin)/(nr*nr) - B = 2.*(thetamin-thetamax)/nth - C = 2.*(zmin-zmax)/nz - - do rbin=0, nr-1 - tempr = rmin + A*rbin**2 - ringrid(rbin) = tempr - w92betagrid(rbin) = tempr - cyl_ringrid(rbin) = tempr - enddo - - thmingrid(0)=thetamin - do thbin=1,nth/2-1 - thmingrid(thbin) = B*(1.0*thbin*thbin/nth-thbin)+thetamin - thmingrid(nth-thbin) = thetamax - thmingrid(thbin) - enddo - thmingrid(nth/2) = (thetamin+thetamax)/2; - - zmingrid(0)=zmin - do zbin=1,nz/2-1 - zmingrid(zbin) = C*(1.0*zbin*zbin/nz-zbin)+zmin - zmingrid(nz-zbin) = (zmax+zmin)/2. - zmingrid(zbin) - enddo - zmingrid(nz/2) = (zmin+zmax)/2. - - do phbin=0,nph-1 - phmingrid(phbin) = phbin * twopi/nph - enddo - - made_grid_points = 1 - -end subroutine make_grid_points - -!---------------------------------------------------------------- -!+ -! Given a set of coordinates r, theta, phi, finds the cell -! those coords are in -!+ -!---------------------------------------------------------------- - -subroutine get_grid_bins( r, zt, rbin, ztbin, phi, phibin ) - use physcon, only:pi, twopi - use io, only : fatal - real, intent(in) :: r, phi, zt - integer, intent(out) :: rbin, ztbin, phibin - real :: B, C, ztnew - - rbin = int( nr*sqrt( (r-rmin)/(rmax-rmin))) - - B = 2.*(thetamin-thetamax)/(nth) - C = 2.*(zmin-zmax)/nz - - select case(rad_trans) - case(2) - if ( zt < (zmin+zmax)/2. ) then - ztbin = int( (sqrt( (nz*C)**2 + 4*nz*C*(zt-zmin) ) + nz*C)/(2.*C) ) - else - ztnew = zmin + zmax - zt - ztbin = int( (sqrt( (nz*C)**2 + 4*nz*C*(ztnew-zmin) ) + nz*C)/(2.*C) ) - ztbin = nz-ztbin-1 - endif - if ( ztbin>nz ) ztbin = nz - if ( ztbin<0 ) ztbin = 0 - case default ! 0,1 - if ( zt < (thetamin+thetamax)/2. ) then - ztbin = int( (sqrt( (nth*B)**2 + 4*nth*B*(zt-thetamin) ) + nth*B)/(2.*B) ) - else - ztnew = thetamin + thetamax - zt - ztbin = int( (sqrt( (nth*B)**2 + 4*nth*B*(ztnew-thetamin) ) + nth*B)/(2.*B) ) - ztbin = nth-ztbin-1 - endif - if ( ztbin < 0 .or. ztbin>nth-1 ) then - call fatal( 'lumin_nsdisc', 'Array out of bounds error in get_grid_bins (theta)' ) - endif - end select - - phibin = int( phi*nph/twopi) - if ( rbin>nr-1 ) rbin=nr-1 ! Avoids segfaults for distant particles - if ( rbin<0 ) rbin = 0 ! Avoids segfaults for accreted particles - -end subroutine get_grid_bins - -!---------------------------------------------------------------- -!+ -! Given a bin in an array, finds the inner and outer edges, and the -! midpoint -!+ -!---------------------------------------------------------------- - -subroutine get_grid_points( array, ix, nx, maxx, xin, xout, xmid ) - use io, only : fatal - integer, intent(in) :: nx, ix - real, intent(in) :: array(0:nx-1), maxx - real, intent(out) :: xin, xout, xmid - if ( ix<0.or.ix>=nx ) then - call fatal( 'lumin_nsdisc', 'Array out of bounds error in get_grid_points' ) - endif - xin = array(ix) - - if ( ix==nx-1 ) then - xout = maxx - else - xout = array(ix+1) - endif - - xmid = ( xin + xout )/2. - -end subroutine get_grid_points - -!---------------------------------------------------------------- -!+ -! Given a bin in an array, finds the midpoints of that bin and the next -! one out. This is called in preparation for bilin_interp -!+ -!---------------------------------------------------------------- - -subroutine get_bracket_grid_points( array, ix, nx, maxx, x1, x2 ) - use io, only : fatal - integer, intent(in) :: nx, ix - real, intent(in) :: array(0:nx-1), maxx - real, intent(out) :: x1, x2 - real :: minimum, maximum, boundary - - if ( ix<0.or.ix>=nx-1 ) then - call fatal( 'lumin_nsdisc', 'Array out of bounds error in get_bracket_grid_points' ) - !this should never happen. Checks in the calling function should avoid passing bad ix values. - endif - - minimum = array(ix) - boundary = array(ix+1) - - if ( ix==nx-2 ) then - maximum = maxx - else - maximum = array(ix+2) - endif - - x1 = minimum + (boundary-minimum)/2. - x2 = boundary + (maximum-boundary)/2. - -end subroutine get_bracket_grid_points - -!---------------------------------------------------------------- -!+ -! Generates a set of grids containing rho, tau, and beta -! Calculates density by counting the number of particles in -! each spherical r,theta bin -! Calculates tau by integrating radially from NS surface -! Calculates beta = exp(-tau). You still need to multiply beta -! by L*/LEdd to get the true beta used to calculate PR drag -!+ -!---------------------------------------------------------------- - -subroutine make_beta_grids(xyzh,particlemass,npart) - use units, only: udist, umass - - integer, intent(in) :: npart - real, intent(in) :: xyzh(:,:) - real, intent(in) :: particlemass - real :: theta, r, phi, kappa, r_cyl - real :: dr, dz, cell_phin, cell_phout, cell_phmid - real :: cell_rin, cell_rout, cell_rmid, cell_thin, cell_thout, cell_thmid - real :: cell_zin, cell_zout, cell_zmid - real :: cell_volume, logzero, x, y, z - integer :: rbin, thbin, phbin, zbin, ipart, totpart - - kappa = real(calc_kappa( frac_X, 2. ) * (umass/(udist*udist))) !kappa in code units - - logzero = careful_log( 0.0 ) - - call make_grid_points() - do rbin=0, nr-1 !clear the density grid, since it is retained after every call - do phbin=0, nph-1 - do thbin=0, nth-1 - ldensitygrid( rbin, thbin, phbin ) = logzero - densitygrid( rbin, thbin, phbin ) = 0.0 - npgrid( rbin, thbin, phbin ) = 0 - enddo - do zbin=0, nz - cyl_ldensitygrid(rbin, zbin, phbin) = logzero - cyl_densitygrid(rbin, zbin, phbin) = 0.0 - cyl_npgrid(rbin, zbin, phbin) = 0 - enddo - enddo - enddo - - totpart = 0 - do ipart=1, npart !fills the density grid by counting particles and assigning - !each one to a cell - x = xyzh(1, ipart) - y = xyzh(2, ipart) - z = xyzh(3, ipart) - - if ( isnan(x).or.isnan(y).or.isnan(z) ) then - x=0. - y=0. - z=0. - endif - - r = sqrt( x**2 + y**2 + z**2 ) - r_cyl = sqrt(x**2 + y**2) - - if ( r>rmin.and.r thetamax ) theta = thetamax - if ( theta < thetamin ) theta = thetamin - - phi = pi + atan2( y, x ) - endif - if (phbin >= nph ) then !phi is cyclic - phbin = phbin - nph - endif - cell_phin = phmingrid( phbin ) - if ( phbin == nph-1 ) then - cell_phout = phimax - else - cell_phout = phmingrid( phbin+1 ) - endif - if ( r>rmin.and.r=0).and.(rbin=0).and.(thbin=0).and.(phbinzmax ) z=zmax-eps - if ( z=0).and.(rbin=0).and.(zbin=0).and.(phbin thetamax ) theta = thetamax - if ( theta < thetamin ) theta = thetamin - phi = pi + atan2( y, x ) - if ( r_cyl>= 0) then - call get_grid_bins( r_cyl, 0., rbin, thbin, 0., phbin ) - else - rbin=-1 - thbin=-1 - phbin=-1 - endif - if ( rbin>=0.and.rbin= taubig ) then - tau_to_beta = 0. - else - tau_to_beta = exp(-tau) - endif - -end function tau_to_beta - -!------------------------------------------------ -!+ -! Calculates the total luminosity of the star, -! including perhaps luminosity from accretion -!+ -!------------------------------------------------ - -subroutine set_Lstar( BurstProfile, time, dmdt, Mstar ) - use units, only:utime, umass, udist - use physcon, only:fourpi - real, intent(in) :: time, dmdt, Mstar - integer, intent(in) :: BurstProfile - real :: ptime, ptime2 - -!this assumes c=G=1. - LEdd = real(fourpi*Mstar/(calc_kappa( frac_X, 2. ) / ( udist*udist / umass ))) - ptime = real(time*utime) - ptime2 = ptime*ptime - - select case( BurstProfile ) - - case(-1) ! Test case. I will modify this one frequently. - if ( time < 9999.) then - Lstar_burst=0.0 - AccLumEff=0.0 - else - Lstar_burst=1.0 - AccLumEff=0.0 - endif - case(0) ! No luminosity, either from burning or from accretion feedback - Lstar_burst = 0.0 - AccLumEff = 0.0 - case(1) !Time-variable luminosity profile. - ! 00.00 - 00.25 = no luminosity at all to remove initial transient - ! 00.25 - 01.00 = no L*, linearly ramp up accretion feedback from 0 to 1 - ! 01.00 - 01.50 = Linear rise in L* from 0 to LEdd/2 - ! 01.50 - 10.00 = Quadratic decay back to zero - ! 10.00 - = L* = 0, AccLumEff = 1. - if ( ptime < 0.25 ) then - Lstar_burst = 0.0 - AccLumEff = 0.0 - elseif ( ptime < 1.0 ) then - Lstar_burst = 0.0 - AccLumEff = (ptime*4. - 1.)/3. - elseif ( ptime < 1.5 ) then - Lstar_burst = (ptime - 1.) - AccLumEff = 1. - elseif ( ptime < 10. ) then - Lstar_burst = (2*ptime2 - 40*ptime + 200)/289.0 - AccLumEff = 1. - else - Lstar_burst = 0.0 - AccLumEff = 1. - endif - case(2) ! No burning, but ramp up AccLumEff after initial transient - Lstar_burst = 0.0 - if ( ptime < 0.25 ) then - AccLumEff = 0.0 - elseif ( ptime < 1.0 ) then - AccLumEff = (ptime*4. - 1.)/3. - else - AccLumEff = 1.0 - endif - case(3) ! No burning, but ramp up AccLumEff half as fast as in case(2) - Lstar_burst = 0.0 - if ( ptime < 0.25 ) then - AccLumEff = 0.0 - elseif ( ptime < 1.75 ) then - AccLumEff = (ptime*4. - 1.)/6. - else - AccLumEff = 1.0 - endif - case(4) ! Remove initial transient; ramp up acclum over 3/4 second; allow to settle to 10s; - ! impose a half eddington burst at 10s - Lstar_burst = 0.0 - if ( ptime < 0.25 ) then !remove initial transient - AccLumEff = 0.0 - elseif ( ptime < 1.00 ) then !ramp up AccLum - AccLumEff = (ptime*4. - 1.)/3. - elseif ( ptime < 10.00 ) then !Settle disc - AccLumEff = 1.0 - elseif ( ptime < 10.5 ) then !Burst rise - AccLumEff = 1.0 - Lstar_burst = (ptime-10) - elseif ( ptime < 20.5 ) then !Burst decay - AccLumEff = 1.0 - Lstar_burst = (4*ptime2 - 164*ptime + 1681)/800. - else !Post burst - AccLumEff = 1.0 - Lstar_burst = 0.0 - endif - case(5) ! Eddington luminosity from beginning of simulation - Lstar_burst = 1.0 - AccLumEff = 1.0 - case(6) ! Remove initial transient; ramp up acclum over 3/4 second; allow to settle to 10s; - ! impose a half eddington burst at 10s - Lstar_burst = 0.0 - if ( ptime < 0.25 ) then !remove initial transient - AccLumEff = 0.0 - elseif ( ptime < 1.00 ) then !ramp up AccLum - AccLumEff = (ptime*4. - 1.)/3. - elseif ( ptime < 10.00 ) then !Settle disc - AccLumEff = 1.0 - elseif ( ptime < 10.5 ) then !Burst rise - AccLumEff = 1.0 - Lstar_burst = (ptime-10)*2 - elseif ( ptime < 20.5 ) then !Burst decay - AccLumEff = 1.0 - Lstar_burst = (4*ptime2 - 164*ptime + 1681)/400. - else !Post burst - AccLumEff = 1.0 - Lstar_burst = 0.0 - endif - case(7) !Fit to a type-1 nonPRE burst from 1636-536. Since I'll be starting from an already settled simulation, no need to adjust time - ptime2 = ptime-3 - Lstar_burst = 0.0 - AccLumEff = 0.0 - if ( ptime > 2. .and. ptime <3. ) then - Lstar_burst=0 - AccLumEff = ptime-2. - endif - if ( ptime>3 ) then - Lstar_burst = 9.4*ptime2**1.6*exp(-2.9*ptime2**0.4) - AccLumEff = 1. - endif - case(8) !0.1 L_Edd from beginning of simulation, used for prtest - Lstar_burst = 0.10 - AccLumEff = 0.00 - end select - - if ( AccLumEff > 1.e-16 ) then !If we are including luminosity feedback - LumAcc = AccLumEff * get_AccLum( dmdt, Mstar ) - else - LumAcc = 0.0 - endif - Lstar = Lstar_burst + LumAcc - -end subroutine set_Lstar - -!---------------------------------------------------- -!+ -! Converts accretion rate into luminosity -!+ -!---------------------------------------------------- - -real function get_AccLum( dmdt, Mstar ) !Luminosity from accretion - use units, only:get_G_code - real, intent(in) :: dmdt, Mstar - real :: ggcode, Rstar - - ggcode = get_G_code() - Rstar = 1. - - get_AccLum = (ggcode * Mstar * dmdt / Rstar) / LEdd - -end function get_AccLum - -!---------------------------------------------- -!+ -! function computing kappa opacity from hydrogen -! fraction X and temperature kT (in keV). -! Returns opacity in cm^2 g^{-1} -! -! See Lewin et al 1993, SSR, 62, 233 (p. 276 4.13b) -!+ -!---------------------------------------------- - -real function calc_kappa( X, kT ) - real, intent(in) :: X, kT - real :: k0, tempcorr - k0 = 0.2*(1.0 + X) - tempcorr = 1.0 + ( kT/39.2 )**0.86 - calc_kappa = k0/tempcorr -end function calc_kappa - -!---------------------------------------------- -!+ -! function computing the beta parameter -!+ -!---------------------------------------------- -real function beta(x,y,z) - use physcon, only:c, gg, fourpi, pi, roottwo, rpiontwo - use io, only:fatal - use units, only:umass,udist - real, intent(in) :: x,y,z - real :: r, theta, phi, rcyl, H, kappa, tau - integer :: rbin, thetabin, phibin, zbin - - beta = 0. - rcyl = sqrt( x*x + y*y ) - phi = pi + atan2(y,x) - r = sqrt(x**2 + y**2 + z**2) - theta=acos(z/r) - - select case( rad_trans ) - case( 0 ) - r = sqrt(x**2 + y**2 + z**2) - theta = acos( z/r ) - if ( theta > thetamax ) theta = thetamax - if ( theta < thetamin ) theta = thetamin - if ( r>rmin.and.rrmin.and.rcyl Lstar ) then - beta = Lstar !hopefully unnecessary sanity checks - endif - if ( beta < 0. ) beta = 0. - -end function beta - -!---------------------------------------------- -!+ -! Calculates a beta by calling bilin_interp -!+ -!--------------------------------------------- -real function beta_by_interp(r, theta, phi) - real, intent(in) :: r, theta, phi - real :: betain, betaout - integer :: rbin, thetabin, phibin - - beta_by_interp = 0 - rbin=0 - thetabin=0 - phibin=0 - call get_grid_bins( r, theta, rbin, thetabin, phi, phibin ) - - if ( rbin >= nr-1 ) rbin = nr-1 - - if ( r<=rmin ) then - betain = 0. - betaout = 0. - elseif ( frac_X < 0. ) then - betain = 1. - betaout = 1. - elseif ( rbin>=nr-1 ) then - betain = lbetagrid(nr-1, thetabin, phibin) - betain = min(exp(betain), 1.) - betaout = betain - else - betain = bilin_interp( lbetagrid, ringrid(rbin), theta, phi) - betain = exp(betain) - - betaout = bilin_interp( lbetagrid, ringrid(rbin+1), theta, phi ) - betaout = exp(betaout) - endif - - if ( npgrid( rbin, thetabin, phibin )==0) then - beta_by_interp = betain - else - beta_by_interp = (betaout + (betain-betaout)/npgrid( rbin, thetabin, phibin )) - - endif - -end function beta_by_interp - -!---------------------------------------------- -!+ -! Calculates a beta by calling bilin_interp on a cylindrical grid -!+ -!--------------------------------------------- -real function beta_by_interp_cyl(r, z, phi) - real, intent(in) :: r, z, phi - real :: betain, betaout - integer :: rbin, zbin, phibin - real :: znew - znew=z - if ( z > zmax ) znew = zmax - eps - if ( z < zmin ) znew = zmin + eps - rbin=0 - zbin=0 - phibin=0 - call get_grid_bins( r, z, rbin, zbin, phi, phibin ) - if ( r<=rmin ) then - betain = 0. - betaout = 0. - elseif ( frac_X < 0. ) then - betain = 1. - betaout = 1. - elseif ( rbin>=nr-1 ) then - betain = bilin_interp_cyl( cyl_lbetagrid, r, z, phi ) - betain = min(exp(betain), 1.) - betaout = betain - else - betain = bilin_interp_cyl( cyl_lbetagrid, r, z, phi ) - betain = exp(betain) - betaout = bilin_interp_cyl( cyl_lbetagrid, r, z, phi ) - betaout = exp(betaout) - endif - - if ( cyl_npgrid( rbin, zbin, phibin )==0) then - beta_by_interp_cyl = betain - else - beta_by_interp_cyl = (betaout + (betain-betaout)/cyl_npgrid( rbin, zbin, phibin )) - endif - -end function beta_by_interp_cyl - -!---------------------------------------------- -!+ -! Finds a value by bilinearly interpolating on a grid -!+ -!---------------------------------------------- - -real function bilin_interp( array, r, theta, phi ) - use physcon, only: twopi - real, intent(in) :: array(0:nr-1, 0:nth-1, 0:nph-1), phi, theta, r - real :: t1, t2, p1, p2, ft1p1, ft2p1,ft1p2, ft2p2, tmid, pmid - real :: ftp, dta, dtb, dpa, dpb, dummy - integer :: tbin1, tbin2, pbin1, pbin2, tbin0, pbin0, rbin0 - - bilin_interp = 0. - if ( r>rmin) then - call get_grid_bins( r, theta, rbin0, tbin0, phi, pbin0 ) - else - call get_grid_bins( rmin+eps, theta, rbin0, tbin0, phi, pbin0 ) - rbin0=0 - endif - call get_grid_points( thmingrid, tbin0, nth, thetamax, t1, t2, tmid ) - - if ( tbin0 == 0.and.thetatmid ) then - call get_bracket_grid_points( thmingrid, nth-2, nth, thetamax, t1, t2 ) - tbin1 = nth-2 - elseif ( theta > tmid ) then - call get_bracket_grid_points( thmingrid, tbin0, nth, thetamax, t1, t2 ) - tbin1 = tbin0 - else - call get_bracket_grid_points( thmingrid, tbin0-1, nth, thetamax, t1, t2 ) - tbin1 = tbin0-1 - endif - - call get_grid_points( phmingrid, pbin0, nph, phimax, p1, p2, pmid ) - - if ( pbin0 == 0.and.phipmid ) then - call get_bracket_grid_points( phmingrid, nph-2, nph, phimax, p1, dummy ) - call get_bracket_grid_points( phmingrid, 0, nph, phimax, dummy, p2 ) - p2 = p2 + twopi - pbin1 = nph-1 - pbin2 = 0 - elseif ( phi>pmid ) then - call get_bracket_grid_points( phmingrid, pbin0, nph, phimax, p1, p2 ) - pbin1 = pbin0 - pbin2 = pbin0+1 - else - call get_bracket_grid_points( phmingrid, pbin0-1, nph, phimax, p1, p2 ) - pbin1 = pbin0-1 - pbin2 = pbin0 - endif - - tbin2=tbin1+1 - - if ( pbin1<0 ) pbin1 = nph-1 - if ( pbin2>nph-1 ) pbin2 = 0 - - ft1p1 = array( rbin0, tbin1, pbin1 ) - ft1p2 = array( rbin0, tbin1, pbin2 ) - ft2p1 = array( rbin0, tbin2, pbin1 ) - ft2p2 = array( rbin0, tbin2, pbin2 ) - - dta = theta - t1 - dtb = t2 - theta - dpa = phi - p1 - dpb = p2 - phi - - ftp = ft1p1*dtb*dpb & - + ft2p1*dta*dpb & - + ft1p2*dtb*dpa & - + ft2p2*dta*dpa - - bilin_interp = ftp/( (t2-t1)*(p2-p1) ) - -end function bilin_interp - -!---------------------------------------------- -!+ -! Finds a value by bilinearly interpolating on a cylindrical grid -!+ -!---------------------------------------------- - -real function bilin_interp_cyl( array, r, z, phi ) - use physcon, only: twopi - real, intent(in) :: array(0:nr-1, 0:nz, 0:nph-1), phi, z, r - real :: r1, r2, p1, p2, fr1p1, fr2p1,fr1p2, fr2p2, rmid, pmid - real :: frp, dra, drb, dpa, dpb, dummy - integer :: rbin1, rbin2, pbin1, pbin2, zbin0, pbin0, rbin0 - real :: znew - znew=z - zbin0=0 - if ( z>zmax ) znew = zmax - eps - if ( zrmid ) then - call get_bracket_grid_points( cyl_ringrid, nr-2, nr, rmax, r1, r2 ) - rbin1 = nr-2 - elseif ( r > rmid ) then - call get_bracket_grid_points( cyl_ringrid, rbin0, nr, rmax, r1, r2 ) - rbin1 = rbin0 - else - call get_bracket_grid_points( cyl_ringrid, rbin0-1, nr, rmax, r1, r2 ) - rbin1 = rbin0-1 - endif - - call get_grid_points( phmingrid, pbin0, nph, phimax, p1, p2, pmid ) - - if ( pbin0 == 0.and.phipmid ) then - call get_bracket_grid_points( phmingrid, nph-2, nph, phimax, p1, dummy ) - call get_bracket_grid_points( phmingrid, 0, nph, phimax, dummy, p2 ) - p2 = p2 + twopi - pbin1 = nph-1 - pbin2 = 0 - elseif ( phi>pmid ) then - call get_bracket_grid_points( phmingrid, pbin0, nph, phimax, p1, p2 ) - pbin1 = pbin0 - pbin2 = pbin0+1 - else - call get_bracket_grid_points( phmingrid, pbin0-1, nph, phimax, p1, p2 ) - pbin1 = pbin0-1 - pbin2 = pbin0 - endif - - rbin2=rbin1+1 - - if ( pbin1<0 ) pbin1 = nph-1 - if ( pbin2>nph-1 ) pbin2 = 0 - - fr1p1 = array( rbin1, zbin0, pbin1 ) - fr1p2 = array( rbin1, zbin0, pbin2 ) - fr2p1 = array( rbin2, zbin0, pbin1 ) - fr2p2 = array( rbin2, zbin0, pbin2 ) - - dra = r - r1 - drb = r2 - r - dpa = phi - p1 - dpb = p2 - phi - - frp = fr1p1*drb*dpb & - + fr2p1*dra*dpb & - + fr1p2*drb*dpa & - + fr2p2*dra*dpa - - bilin_interp_cyl = frp/( (r2-r1)*(p2-p1) ) - -end function bilin_interp_cyl - -!---------------------------------------------- -!+ -! Returns the natural logarithm of a number, -! or a very large negative number if given a negative -!+ -!---------------------------------------------- - -real function careful_log( x ) - real, intent(in) :: x - real, parameter :: xbig = range(x)*log(10.) - if ( x <= 0. ) then - careful_log = -100. - else - careful_log = max(log(x), -xbig/2.) - endif -end function careful_log - -!---------------------------------------------- -!+ -! function computing the disc scale height -!+ -!---------------------------------------------- -real function calc_scaleheight( r ) - use eos, only:polyk, qfacdisc - real, intent(in) :: r - real :: omega, cs - if ( r > 0. ) then - omega = 1.0/r**(1.5) - cs = sqrt(polyk) * r**(-qfacdisc) - calc_scaleheight = (cs/omega) - else - calc_scaleheight = -1000. !sentinel value for star interior - endif -end function calc_scaleheight - -!---------------------------------------------- -!+ -! function computing the disc surface density -!+ -!---------------------------------------------- -real function calc_sigma( r ) - use units, only:umass - use physcon, only:solarm - real, intent(in) :: r - real :: R_in = 1., Mdisc - - Mdisc = real(1.4d0*solarm/umass*5.d-16) - - if ( r>r_In ) then - calc_sigma = sqrt(R_in) * Mdisc * r**(-3./2.)*(1-sqrt(R_in/r)) - else - calc_sigma = 0. - endif - -end function calc_sigma - -!----------------------------------------------------------------------- -!+ -! writes input options to the input file -!+ -!----------------------------------------------------------------------- -subroutine write_options_lumin_nsdisc(iunit) - use infile_utils, only:write_inopt - integer, intent(in) :: iunit - - write(iunit,"(/,a)") '# options relating to the neutron star disc' - call write_inopt(BurstProfile,'BurstProfile',& - 'Burst Profile',iunit) - ! Between 0 and 1 = constant luminosity - ! Any negative value = burst profile as described in set_Lstar - - call write_inopt(frac_X,'frac_X',& - 'Hydrogen fraction (-ve for zero opacity)',iunit) - - call write_inopt(rad_trans, 'rad_trans', & - 'Radiation transport prescription', iunit) - -end subroutine write_options_lumin_nsdisc - -!----------------------------------------------------------------------- -!+ -! reads input options from the input file -!+ -!----------------------------------------------------------------------- -subroutine read_options_lumin_nsdisc(name,valstring,imatch,igotall,ierr) - use io, only:fatal, warning - 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_lumin_nsdisc' - - imatch = .true. - igotall = .false. - - select case(trim(name)) - case('BurstProfile') - read(valstring,*,iostat=ierr) BurstProfile - case('frac_X') - read(valstring,*,iostat=ierr) frac_X - case('rad_trans') - read(valstring,*,iostat=ierr) rad_trans - case default - imatch = .false. - end select - igotall = (ngot >= 1) - -end subroutine read_options_lumin_nsdisc - -end module lumin_nsdisc diff --git a/src/main/mpi_force.F90 b/src/main/mpi_force.F90 index 3dab68ded..2fe66c34f 100644 --- a/src/main/mpi_force.F90 +++ b/src/main/mpi_force.F90 @@ -76,6 +76,7 @@ module mpiforce integer :: maxlength = 0 integer :: n = 0 integer :: number + integer :: ibuffer ! to avoid ifort error end type stackforce contains @@ -236,6 +237,8 @@ subroutine free_mpitype_of_cellforce(dtype) integer :: mpierr call MPI_Type_free(dtype,mpierr) +#else + dtype = 0 #endif end subroutine free_mpitype_of_cellforce diff --git a/src/main/phantom.F90 b/src/main/phantom.F90 index 3046d69ba..798802b99 100644 --- a/src/main/phantom.F90 +++ b/src/main/phantom.F90 @@ -2,7 +2,7 @@ ! 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/ ! +! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! program phantom ! diff --git a/src/main/readwrite_dumps_common.f90 b/src/main/readwrite_dumps_common.f90 index 5cf289f29..11df1d566 100644 --- a/src/main/readwrite_dumps_common.f90 +++ b/src/main/readwrite_dumps_common.f90 @@ -10,12 +10,13 @@ module readwrite_dumps_common ! ! :References: None ! -! :Owner: Daniel Mentiplay +! :Owner: Daniel Price ! ! :Runtime parameters: None ! -! :Dependencies: dim, dump_utils, dust_formation, eos, gitinfo, io, -! options, part, sphNGutils +! :Dependencies: boundary, boundary_dyn, checkconserved, dim, dump_utils, +! dust, dust_formation, eos, externalforces, fileutils, gitinfo, io, +! options, part, setup_params, sphNGutils, timestep, units ! use dump_utils, only:lenid implicit none @@ -110,6 +111,452 @@ subroutine get_options_from_fileid(fileid,tagged,phantomdump,smalldump,& end subroutine get_options_from_fileid +!-------------------------------------------------------------------- +!+ +! utility to extract header variables to phantom +!+ +!------------------------------------------------------------------- +subroutine unfill_header(hdr,phantomdump,got_tags,nparttot, & + nblocks,npart,npartoftype, & + tfile,hfactfile,alphafile,iprint,id,nprocs,ierr) + use dim, only:maxdustlarge,use_dust + use io, only:master ! check this + use eos, only:isink + use part, only:maxtypes,igas,idust,ndustsmall,ndustlarge,ndusttypes,& + npartoftypetot + use units, only:udist,umass,utime,set_units_extra,set_units + use dump_utils, only:extract,dump_h + use fileutils, only:make_tags_unique + type(dump_h), intent(in) :: hdr + logical, intent(in) :: phantomdump,got_tags + integer(kind=8), intent(out) :: nparttot + integer, intent(out) :: nblocks,npart,npartoftype(maxtypes) + real, intent(out) :: tfile,hfactfile,alphafile + integer, intent(in) :: iprint,id,nprocs + integer, intent(out) :: ierr + integer :: nparttoti,npartoftypetoti(maxtypes),ntypesinfile,nptinfile + integer :: ierr1,ierrs(3),i,counter + integer(kind=8) :: ntypesinfile8 + character(len=10) :: dust_label(maxdustlarge) + + ierr = 0 + nparttot = 0 + npartoftypetot(:) = 0 + npart = 0 + npartoftype(:) = 0 + isink = 0 + call extract('ntypes',ntypesinfile,hdr,ierr1) + if (ierr1 /= 0 .or. ntypesinfile < 1) then + if (phantomdump .and. got_tags) then + ierr = 4 + return + else + ntypesinfile = 5 + endif + endif + + ! extract quantities from integer header + call extract('nparttot',nparttoti,hdr,ierr1) + if (ierr1 /= 0) then + ierr = 5 + return + endif + if (ntypesinfile > maxtypes) then + write(*,*) 'WARNING: number of particle types in file exceeds array limits' + write(*,*) 'READING ONLY FIRST ',maxtypes,' OF ',ntypesinfile,' particle types' + ntypesinfile = maxtypes + endif + call extract('npartoftype',npartoftypetoti(1:ntypesinfile),hdr,ierr1) + if (ierr1 /= 0) then + npartoftype(1) = nparttoti ! assume only gas particles + endif + call extract('nblocks',nblocks,hdr,ierr1,default=1) + if (ierr1 /= 0) write(*,*) 'number of MPI blocks not read: assuming 1' + + nparttot = int(nparttoti,kind=8) + npartoftypetot = int(npartoftypetoti,kind=8) + if (nblocks==1) then + npartoftype(1:ntypesinfile) = int(npartoftypetot(1:ntypesinfile)) + if (npartoftype(idust) > 0) write(*,*) 'n(gas) = ',npartoftype(igas) + counter = 0 + do i=1,maxdustlarge + if (npartoftype(idust+i-1) > 0) then + counter = counter + 1 + endif + enddo + dust_label = 'dust' + call make_tags_unique(counter,dust_label) + do i=1,counter + write(*,*) 'n('//trim(dust_label(i))//') = ',npartoftype(idust+i-1) + enddo + endif + call extract('isink',isink,hdr,ierr1) + +!--non-MPI dumps + if (nprocs==1) then + if (nparttoti > huge(npart)) then + write (*,*) 'ERROR in readdump: number of particles exceeds 32 bit limit, must use int(kind=8)''s ',nparttoti + ierr = 4 + return + endif + endif + if (nblocks==1) then + npart = int(nparttoti) + nparttot = npart + if (id==master) write (iprint,*) 'npart = ',npart + endif + if (got_tags) then + call extract('ntypes',ntypesinfile8,hdr,ierr1) + ntypesinfile = int(ntypesinfile8) + endif + if (ntypesinfile > maxtypes) then + write(*,*) 'WARNING: number of particle types in file exceeds array limits' + write(*,*) 'READING ONLY FIRST ',maxtypes,' OF ',ntypesinfile,' particle types' + ntypesinfile = maxtypes + endif + call extract('nparttot',nparttot,hdr,ierr1) + if (nblocks > 1) then + call extract('npartoftype',npartoftype(1:ntypesinfile),hdr,ierr1) + endif + if (id==master) write(*,*) 'npart(total) = ',nparttot +! +!--number of dust species +! + if (use_dust) then + call extract('ndustsmall',ndustsmall,hdr,ierrs(1)) + call extract('ndustlarge',ndustlarge,hdr,ierrs(2)) + if (any(ierrs(1:2) /= 0)) then + call extract('ndustfluids',ndustsmall,hdr,ierrs(1)) ! for backwards compatibility + if (ierrs(1) /= 0) write(*,*) 'ERROR reading number of small/large grain types from file header' + endif + ndusttypes = ndustsmall + ndustlarge + endif +! +!--units +! + call extract('udist',udist,hdr,ierrs(1)) + call extract('umass',umass,hdr,ierrs(2)) + call extract('utime',utime,hdr,ierrs(3)) + if (all(ierrs(1:3)==0)) then + call set_units_extra() + else + write(iprint,*) 'ERROR reading units from dump file, assuming default' + call set_units() ! use default units + endif + ! get nptmass from header, needed to figure out if gwinspiral info is sensible + call extract('nptmass',nptinfile,hdr,ierrs(1)) +!--default real + call unfill_rheader(hdr,phantomdump,ntypesinfile,nptinfile,& + tfile,hfactfile,alphafile,iprint,ierr) + if (ierr /= 0) return + + if (id==master) write(iprint,*) 'time = ',tfile + +end subroutine unfill_header + +!-------------------------------------------------------------------- +!+ +! subroutine to fill the real header with various things +!+ +!------------------------------------------------------------------- +subroutine fill_header(sphNGdump,t,nparttot,npartoftypetot,nblocks,nptmass,hdr,ierr) + use eos, only:write_headeropts_eos,polyk2 + 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 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, & + 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 + + logical, intent(in) :: sphNGdump + real, intent(in) :: t + integer(kind=8), intent(in) :: nparttot,npartoftypetot(:) + integer, intent(in) :: nblocks,nptmass + type(dump_h), intent(inout) :: hdr + integer, intent(out) :: ierr + integer :: number + + ierr = 0 + ! default int + call add_to_iheader(int(nparttot),'nparttot',hdr,ierr) + call add_to_iheader(maxtypes,'ntypes',hdr,ierr) + call add_to_iheader(int(npartoftypetot(1:maxtypes)),'npartoftype',hdr,ierr) + call add_to_iheader(nblocks,'nblocks',hdr,ierr) + call add_to_iheader(nptmass,'nptmass',hdr,ierr) + call add_to_iheader(ndustlarge,'ndustlarge',hdr,ierr) + call add_to_iheader(ndustsmall,'ndustsmall',hdr,ierr) + call add_to_iheader(idust,'idust',hdr,ierr) + call add_to_iheader(idtmax_n_next,'idtmax_n',hdr,ierr) + call add_to_iheader(idtmax_frac_next,'idtmax_frac',hdr,ierr) + call add_to_iheader(idumpfile,'idumpfile',hdr,ierr) + call add_to_iheader(phantom_version_major,'majorv',hdr,ierr) + call add_to_iheader(phantom_version_minor,'minorv',hdr,ierr) + call add_to_iheader(phantom_version_micro,'microv',hdr,ierr) + + ! int*8 + call add_to_header(nparttot,'nparttot',hdr,ierr) + call add_to_header(int(maxtypes,kind=8),'ntypes',hdr,ierr) + call add_to_header(npartoftypetot(1:maxtypes),'npartoftype',hdr,ierr) + + ! int*4 + call add_to_header(iexternalforce,'iexternalforce',hdr,ierr) + call add_to_header(ieos,'ieos',hdr,ierr) + call write_headeropts_eos(ieos,hdr,ierr) + + ! default real variables + call add_to_rheader(t,'time',hdr,ierr) + call add_to_rheader(dtmax_user,'dtmax',hdr,ierr) + call add_to_rheader(rhozero,'rhozero',hdr,ierr) + if (sphNGdump) then ! number = 23 + call add_to_rheader(0.,'escaptot',hdr,ierr) + call add_to_rheader(0.,'tkin',hdr,ierr) + call add_to_rheader(0.,'tgrav',hdr,ierr) + call add_to_rheader(0.,'tterm',hdr,ierr) + call add_to_rheader(0.,'anglostx',hdr,ierr) + call add_to_rheader(0.,'anglosty',hdr,ierr) + call add_to_rheader(0.,'anglostz',hdr,ierr) + call add_to_rheader(0.,'specang',hdr,ierr) + call add_to_rheader(0.,'ptmassin',hdr,ierr) + call add_to_rheader(0.,'tmag',hdr,ierr) + call add_to_rheader(Bextx,'Bextx',hdr,ierr) + call add_to_rheader(Bexty,'Bexty',hdr,ierr) + call add_to_rheader(Bextz,'Bextz',hdr,ierr) + call add_to_rheader(0.,'hzero',hdr,ierr) + call add_to_rheader(1.5*polyk2,'uzero_n2',hdr,ierr) + call add_to_rheader(0.,'hmass',hdr,ierr) + call add_to_rheader(0.,'gapfac',hdr,ierr) + call add_to_rheader(0.,'pmassinitial',hdr,ierr) + else ! number = 49 + call add_to_rheader(hfact,'hfact',hdr,ierr) + call add_to_rheader(tolh,'tolh',hdr,ierr) + call add_to_rheader(C_cour,'C_cour',hdr,ierr) + call add_to_rheader(C_force,'C_force',hdr,ierr) + call add_to_rheader(alpha,'alpha',hdr,ierr) + call add_to_rheader(alphau,'alphau',hdr,ierr) + call add_to_rheader(alphaB,'alphaB',hdr,ierr) + call add_to_rheader(massoftype,'massoftype',hdr,ierr) ! array + if (do_nucleation) call write_headeropts_dust_formation(hdr,ierr) + call add_to_rheader(Bextx,'Bextx',hdr,ierr) + call add_to_rheader(Bexty,'Bexty',hdr,ierr) + call add_to_rheader(Bextz,'Bextz',hdr,ierr) + call add_to_rheader(0.,'dum',hdr,ierr) + if (iexternalforce /= 0) call write_headeropts_extern(iexternalforce,hdr,t,ierr) + if (periodic) then + call add_to_rheader(xmin,'xmin',hdr,ierr) + call add_to_rheader(xmax,'xmax',hdr,ierr) + call add_to_rheader(ymin,'ymin',hdr,ierr) + call add_to_rheader(ymax,'ymax',hdr,ierr) + call add_to_rheader(zmin,'zmin',hdr,ierr) + call add_to_rheader(zmax,'zmax',hdr,ierr) + endif + if (dynamic_bdy) then + call add_to_rheader(dxyz,'dxyz',hdr,ierr) + call add_to_iheader(irho_bkg_ini,'irho_bkg_ini',hdr,ierr) + call add_to_rheader(rho_bkg_ini,'rho_bkg_ini',hdr,ierr) + endif + call add_to_rheader(get_conserv,'get_conserv',hdr,ierr) + call add_to_rheader(etot_in,'etot_in',hdr,ierr) + call add_to_rheader(angtot_in,'angtot_in',hdr,ierr) + call add_to_rheader(totmom_in,'totmom_in',hdr,ierr) + call add_to_rheader(mdust_in(1:ndusttypes),'mdust_in',hdr,ierr) + if (use_dust) then + call add_to_rheader(grainsize(1:ndusttypes),'grainsize',hdr,ierr) + call add_to_rheader(graindens(1:ndusttypes),'graindens',hdr,ierr) + endif + endif + + ! real*8 + call add_to_header(udist,'udist',hdr,ierr) + call add_to_header(umass,'umass',hdr,ierr) + call add_to_header(utime,'utime',hdr,ierr) + call add_to_header(unit_Bfield,'umagfd',hdr,ierr) + + if (ierr /= 0) write(*,*) ' ERROR: arrays too small writing rheader' + + number = num_in_header(hdr%realtags) + if (number >= maxphead) then + write(*,*) 'error: header arrays too small for number of items in header: will be truncated' + endif + +end subroutine fill_header + +!-------------------------------------------------------------------- +!+ +! subroutine to set runtime parameters having read the real header +!+ +!------------------------------------------------------------------- +subroutine unfill_rheader(hdr,phantomdump,ntypesinfile,nptmass,& + tfile,hfactfile,alphafile,iprint,ierr) + use io, only:id,master + use dim, only:maxvxyzu,nElements,use_dust,use_dustgrowth,use_krome,do_nucleation,idumpfile + use eos, only:extract_eos_from_hdr, read_headeropts_eos + 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 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 + use boundary_dyn, only:dynamic_bdy,dxyz,irho_bkg_ini,rho_bkg_ini,rho_bkg_ini1 + use dump_utils, only:extract,dump_h + use dust, only:grainsizecgs,graindenscgs + use units, only:unit_density,udist + use timestep, only:idtmax_n,idtmax_frac + use dust_formation, only:read_headeropts_dust_formation + type(dump_h), intent(in) :: hdr + logical, intent(in) :: phantomdump + integer, intent(in) :: iprint,ntypesinfile,nptmass + real, intent(out) :: tfile,hfactfile,alphafile + integer, intent(out) :: ierr + + integer, parameter :: lu = 173 + integer :: ierrs(10),iextern_in_file + real :: xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,dtmaxi + real :: alphaufile,alphaBfile,C_courfile,C_forcefile,tolhfile + logical :: iexist + + ierr = 0 + call extract('time',tfile,hdr,ierr) + if (ierr/=0) call extract('gt',tfile,hdr,ierr) ! this is sphNG's label for time + call extract('dtmax',dtmaxi,hdr,ierr) + call extract('rhozero',rhozero,hdr,ierr) + Bextx = 0. + Bexty = 0. + Bextz = 0. + if (phantomdump) then + call extract('hfact',hfactfile,hdr,ierr) + call extract('tolh',tolhfile,hdr,ierr) + call extract('C_cour',C_courfile,hdr,ierr) + call extract('C_force',C_forcefile,hdr,ierr) + call extract('alpha',alphafile,hdr,ierr) + if (maxvxyzu >= 4) then + call extract('alphau',alphaufile,hdr,ierr) + else + alphaufile = 0. + endif + if (mhd) then + call extract('alphaB',alphaBfile,hdr,ierr) + endif + + if (extract_eos_from_hdr) call extract('ieos',ieos,hdr,ierr) + + call extract('massoftype',massoftype(1:ntypesinfile),hdr,ierr) + if (ierr /= 0) then + write(*,*) '*** ERROR reading massoftype from dump header ***' + ierr = 4 + endif + if (do_nucleation) then + call read_headeropts_dust_formation(hdr,ierr) + if (ierr /= 0) ierr = 6 + endif + + call extract('iexternalforce',iextern_in_file,hdr,ierrs(1)) + if (extract_iextern_from_hdr) iexternalforce = iextern_in_file + if (iexternalforce /= 0) then + call read_headeropts_extern(iexternalforce,hdr,nptmass,ierrs(1)) + if (ierrs(1) /= 0) ierr = 5 + elseif (iextern_in_file /= 0) then + call read_headeropts_extern(iextern_in_file,hdr,nptmass,ierrs(1)) + if (ierrs(1) /= 0) ierr = 5 + endif + + call extract('idtmax_n',idtmax_n,hdr,ierr,default=1) + call extract('idtmax_frac',idtmax_frac,hdr,ierr) + call extract('idumpfile',idumpfile,hdr,ierr) + else + massoftype(1) = 0. + hfactfile = 0. + endif + + call read_headeropts_eos(ieos,hdr,ierr) + + if (periodic) then + call extract('xmin',xmini,hdr,ierrs(1)) + call extract('xmax',xmaxi,hdr,ierrs(2)) + call extract('ymin',ymini,hdr,ierrs(3)) + call extract('ymax',ymaxi,hdr,ierrs(4)) + call extract('zmin',zmini,hdr,ierrs(5)) + call extract('zmax',zmaxi,hdr,ierrs(6)) + if (any(ierrs(1:6) /= 0)) then + write(*,"(2(/,a))") ' ERROR: dump does not contain boundary positions', & + ' but we are using periodic boundaries' + inquire(file='bound.tmp',exist=iexist) + if (iexist) then + open(unit=lu,file='bound.tmp') + read(lu,*) xmini,xmaxi,ymini,ymaxi,zmini,zmaxi + close(lu) + call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) + write(*,"(a,6(es10.3,1x))") ' READ from bound.tmp ',xmin,xmax,ymin,ymax,zmin,zmax + else + write(*,"(3(/,a),/,/,a)") ' To silence this error and restart from an older dump file ', & + ' create an ascii file called "bound.tmp" in the current directory', & + ' with xmin,xmax,ymin,ymax,zmin & zmax in it, e.g.: ', & + ' 0. 1. 0. 1. 0. 1.' + ierr = 5 ! spit fatal error + endif + else + call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) + endif + endif + + if (dynamic_bdy) then + call extract('irho_bkg_ini',irho_bkg_ini,hdr,ierrs(1)) + call extract('rho_bkg_ini',rho_bkg_ini,hdr,ierrs(1)) + call extract('dxyz',dxyz,hdr,ierrs(2)) + if (rho_bkg_ini > 0.) then + rho_bkg_ini1 = 1.0/rho_bkg_ini + else + rho_bkg_ini1 = 0. + endif + endif + + if (mhd) then + call extract('Bextx',Bextx,hdr,ierrs(1)) + call extract('Bexty',Bexty,hdr,ierrs(2)) + call extract('Bextz',Bextz,hdr,ierrs(3)) + if (id==master) then + if (any(ierrs(1:3) /= 0)) then + write(*,*) 'ERROR reading external field (setting to zero)' + else + write(*,*) 'External field found, Bext = ',Bextx,Bexty,Bextz + endif + endif + endif + + ! values to track that conserved values remain conserved + call extract('get_conserv',get_conserv,hdr,ierrs(1)) + 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)) + if (any(ierrs(1:4) /= 0)) then + write(*,*) 'ERROR reading values to verify conservation laws. Resetting initial values.' + get_conserv = 1.0 + endif + + + !--pull grain size and density arrays if they are in the header + !-- i.e. if dustgrowth is not ON + if (use_dust .and. .not.use_dustgrowth) then + call extract('grainsize',grainsize(1:ndusttypes),hdr,ierrs(1)) + call extract('graindens',graindens(1:ndusttypes),hdr,ierrs(2)) + if (any(ierrs(1:2) /= 0)) then + write(*,*) 'ERROR reading grain size/density from file header' + grainsize(1) = real(grainsizecgs/udist) + graindens(1) = real(graindenscgs/unit_density) + endif + endif + +end subroutine unfill_rheader + !--------------------------------------------------------------- !+ ! make sure required arrays have been read from Phantom file diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.f90 similarity index 64% rename from src/main/readwrite_dumps_fortran.F90 rename to src/main/readwrite_dumps_fortran.f90 index 389bb7fef..6ecf0627c 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -18,17 +18,16 @@ module readwrite_dumps_fortran ! ! :Runtime parameters: None ! -! :Dependencies: boundary, boundary_dyn, checkconserved, dim, dump_utils, -! dust, dust_formation, eos, externalforces, fileutils, io, lumin_nsdisc, -! memory, metric_tools, mpi, mpiutils, options, part, -! readwrite_dumps_common, setup_params, sphNGutils, timestep, units +! :Dependencies: boundary_dyn, dim, dump_utils, eos, io, memory, +! metric_tools, mpiutils, options, part, readwrite_dumps_common, +! sphNGutils, timestep ! use dump_utils, only:lenid,ndatatypes,i_int,i_int1,i_int2,i_int4,i_int8,& i_real,i_real4,i_real8,int1,int2,int1o,int2o,dump_h,lentag - use readwrite_dumps_common, only:check_arrays,fileident,get_options_from_fileid + use readwrite_dumps_common, only:check_arrays,fileident,get_options_from_fileid,fill_header,unfill_header implicit none - public :: write_smalldump_fortran,write_fulldump_fortran,read_smalldump_fortran,read_dump_fortran + public :: write_smalldump_fortran,write_fulldump_fortran,read_smalldump_fortran,read_dump_fortran,unfill_header logical, target, public :: opened_full_dump_fortran ! for use in analysis files if user wishes to skip small dumps logical, target, public :: dt_read_in_fortran ! to determine if dt has been read in so that ibin & ibinold can be set on restarts @@ -39,161 +38,6 @@ module readwrite_dumps_fortran private contains -!-------------------------------------------------------------------- -!+ -! utility to determine whether to read a particular block -! in the dump file, in whole or in part. -! Allows limited changes to number of threads. -!+ -!-------------------------------------------------------------------- -subroutine get_blocklimits(npartblock,nblocks,nthreads,id,iblock,noffset,npartread) - use io, only:die,fatal - integer(kind=8), intent(in) :: npartblock - integer, intent(in) :: nblocks,nthreads,id,iblock - integer, intent(out) :: noffset,npartread - integer :: nblocksperthread,nthreadsperblock - character(len=15), parameter :: tag = 'get_blocklimits' -! -!--check for errors in input -! - if (npartblock < 0) call fatal(tag,'block in dump file has npartinblock < 0') - if (npartblock > huge(npartread)) call fatal(tag,'npart in block exceeds 32 bit limit') -! -!--usual situation: nblocks = nprocessors -! read whole block if id = iblock -! - if (nblocks==nthreads) then - if (id==iblock-1) then - !--read whole block - npartread = int(npartblock) - noffset = 0 - else - !--do not read block - npartread = 0 - noffset = 0 - endif - - elseif (nblocks > nthreads .and. mod(nblocks,nthreads)==0) then -! -!--if more blocks than processes and nblocks exactly divisible by nthreads, -! then just read more than one block per thread -! - nblocksperthread = nblocks/nthreads - if (id==(iblock-1)/nblocksperthread) then - npartread = int(npartblock) - noffset = 0 - else - npartread = 0 - noffset = 0 - endif - - elseif (nthreads > nblocks .and. mod(nthreads,nblocks)==0) then -! -!--if more threads than blocks, and exactly divisible, read fractions of blocks only -! - nthreadsperblock = nthreads/nblocks - if (id/nthreadsperblock==iblock-1) then - npartread = int((npartblock-1)/nthreadsperblock) + 1 - noffset = mod(id,nthreadsperblock)*npartread - - if (mod(id,nthreadsperblock)==nthreadsperblock-1) then - !--last thread has remainder for non-exactly divisible numbers of particles - npartread = int(npartblock) - (nthreadsperblock-1)*npartread - !--die if we would need to load balance between more than the last processor. - if (npartread < 0) then - print*,' npart to read from last block =',npartread - call fatal(tag,'error assigning npart to last thread') - endif - endif - else - npartread = 0 - noffset = 0 - endif - else - noffset = 0 - npartread = 0 - print*,' ERROR: rearrangement of ',nblocks,' blocks to ',nthreads,' threads not implemented' - call die - endif - -end subroutine get_blocklimits - -!-------------------------------------------------------------------- -!+ -! utility for initialising each thread -!+ -!-------------------------------------------------------------------- -subroutine start_threadwrite(id,iunit,filename) -#ifdef MPI - use mpi - use mpiutils, only:status,mpierr -#endif - use io, only:fatal,iverbose - implicit none - integer, intent(in) :: id, iunit - character(len=*), intent(in) :: filename - integer :: nowgo,ierr - - if (iverbose >= 3) print *,id,' : starting write...' - nowgo = 0 - if (id > 0) then -#ifdef MPI - call MPI_RECV(nowgo,1,MPI_INTEGER,id-1,99,MPI_COMM_WORLD,status,mpierr) -#endif - open(unit=iunit,file=filename,status='old',form='unformatted',position='append',iostat=ierr) - if (ierr /= 0) then - call fatal('start_threadwrite','can''t append to dumpfile '//trim(filename)) - else - if (iverbose >= 3) print*,'thread ',id,': opened file '//trim(filename) - endif - endif - -end subroutine start_threadwrite - -!-------------------------------------------------------------------- -!+ -! utility for finalising each thread -!+ -!-------------------------------------------------------------------- -subroutine end_threadwrite(id) - use io, only:iverbose -#ifdef MPI - use mpi - use mpiutils, only:mpierr - use io, only:nprocs -#endif - implicit none - integer, intent(in) :: id -#ifdef MPI - integer :: nowgo -#endif - - if (iverbose >= 3) print *,' thread ',id,' : finished write.' -#ifdef MPI - if (id < nprocs-1) then - nowgo = 1 - call MPI_SEND(nowgo,1,MPI_INTEGER,id+1,99,MPI_COMM_WORLD,mpierr) - endif -#endif - -end subroutine end_threadwrite - -!-------------------------------------------------------------------- -!+ -! extract dump size used in Phantom from the fileid string -!+ -!-------------------------------------------------------------------- -subroutine get_dump_size(fileid,smalldump) - character(len=lenid), intent(in) :: fileid - logical, intent(out) :: smalldump - ! - if (fileid(1:1)=='S') then - smalldump = .true. - else - smalldump = .false. - endif - -end subroutine get_dump_size !-------------------------------------------------------------------- !+ @@ -204,7 +48,7 @@ end subroutine get_dump_size 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 + ind_timesteps,mhd_nonideal,use_krome,h2chemistry,update_muGamma,mpi 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 use part, only:xyzh,xyzh_label,vxyzu,vxyzu_label,Bevol,Bevol_label,Bxyz,Bxyz_label,npart,maxtypes, & @@ -222,12 +66,9 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) use options, only:use_dustfrac,use_porosity,use_var_comp,icooling use dump_utils, only:tag,open_dumpfile_w,allocate_header,& free_header,write_header,write_array,write_block_header - use mpiutils, only:reduce_mpi,reduceall_mpi + use mpiutils, only:reduce_mpi,reduceall_mpi,start_threadwrite,end_threadwrite use timestep, only:dtmax,idtmax_n,idtmax_frac use part, only:ibin,krome_nmols,T_gas_cool -#ifdef PRDRAG - use lumin_nsdisc, only:beta -#endif use metric_tools, only:imetric, imet_et use eos_stamatellos, only:gradP_cool,doFLD,urad_FLD,ttherm_store,teqi_store,opac_store real, intent(in) :: t @@ -240,7 +81,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) integer(kind=8) :: ilen(4) integer :: nums(ndatatypes,4) integer :: ipass,k,l,ioffset - integer :: ierr,ierrs(30) + integer :: ierr,nerr integer :: nblocks,nblockarrays,narraylengths integer(kind=8) :: nparttot logical :: sphNGdump,write_itype,use_gas @@ -252,21 +93,21 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) !--collect global information from MPI threads ! !--allow non-MPI calls to create MPI dump files -#ifdef MPI - nparttot = reduceall_mpi('+',npart) - call update_npartoftypetot -#else - if (present(ntotal)) then - nparttot = ntotal + if (mpi) then + nparttot = reduceall_mpi('+',npart) call update_npartoftypetot - if (all(npartoftypetot==0)) then - npartoftypetot(1) = ntotal - endif else - nparttot = npart - call update_npartoftypetot + if (present(ntotal)) then + nparttot = ntotal + call update_npartoftypetot + if (all(npartoftypetot==0)) then + npartoftypetot(1) = ntotal + endif + else + nparttot = npart + call update_npartoftypetot + endif endif -#endif nblocks = nprocs sphNGdump = .false. @@ -329,13 +170,13 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ! repeated nblocks times (once for each MPI process) ! nblockarrays = narraylengths*nblocks - write (idump, iostat=ierr) nblockarrays + write (idump,iostat=ierr) nblockarrays endif masterthread call start_threadwrite(id,idump,dumpfile) - ierrs = 0 + nerr = 0 nums = 0 ilen = 0_8 if (sphNGdump) then @@ -345,64 +186,65 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) endif do ipass=1,2 do k=1,ndatatypes + nerr = 0 ! ! Block 1 arrays (hydrodynamics) ! ilen(1) = int(npart,kind=8) - if (write_itype) call write_array(1,iphase,'itype',npart,k,ipass,idump,nums,ierrs(1),func=iamtype_int11) - call write_array(1,xyzh,xyzh_label,3,npart,k,ipass,idump,nums,ierrs(2)) + if (write_itype) call write_array(1,iphase,'itype',npart,k,ipass,idump,nums,nerr,func=iamtype_int11) + call write_array(1,xyzh,xyzh_label,3,npart,k,ipass,idump,nums,nerr) if (use_dustgrowth) then - call write_array(1,dustprop,dustprop_label,2,npart,k,ipass,idump,nums,ierrs(3)) - call write_array(1,VrelVf,VrelVf_label,npart,k,ipass,idump,nums,ierrs(3)) - call write_array(1,dustgasprop,dustgasprop_label,4,npart,k,ipass,idump,nums,ierrs(3)) - if (use_porosity) call write_array(1,filfac,filfac_label,npart,k,ipass,idump,nums,ierrs(3)) + call write_array(1,dustprop,dustprop_label,2,npart,k,ipass,idump,nums,nerr) + call write_array(1,VrelVf,VrelVf_label,npart,k,ipass,idump,nums,nerr) + call write_array(1,dustgasprop,dustgasprop_label,4,npart,k,ipass,idump,nums,nerr) + if (use_porosity) call write_array(1,filfac,filfac_label,npart,k,ipass,idump,nums,nerr) endif - if (h2chemistry) call write_array(1,abundance,abundance_label,nabundances,npart,k,ipass,idump,nums,ierrs(5)) - if (use_dust) call write_array(1,dustfrac,dustfrac_label,ndusttypes,npart,k,ipass,idump,nums,ierrs(7)) - if (use_dust) call write_array(1,tstop,tstop_label,ndustsmall,npart,k,ipass,idump,nums,ierrs(8)) + if (h2chemistry) call write_array(1,abundance,abundance_label,nabundances,npart,k,ipass,idump,nums,nerr) + if (use_dust) call write_array(1,dustfrac,dustfrac_label,ndusttypes,npart,k,ipass,idump,nums,nerr) + if (use_dust) call write_array(1,tstop,tstop_label,ndustsmall,npart,k,ipass,idump,nums,nerr) if (use_dustfrac) then do l=1,ndustsmall - call write_array(1,deltav(:,l,:),deltav_label,3,npart,k,ipass,idump,nums,ierrs(10)) + call write_array(1,deltav(:,l,:),deltav_label,3,npart,k,ipass,idump,nums,nerr) enddo endif if (gr) then - call write_array(1,pxyzu,pxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,dens,'dens prim',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,pxyzu,pxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,nerr) + call write_array(1,dens,'dens prim',npart,k,ipass,idump,nums,nerr) if (imetric==imet_et) then ! Output metric if imetric=iet - call write_array(1,metrics(1,1,1,:), 'gtt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metrics(1,1,1,:), 'gtt (covariant)',npart,k,ipass,idump,nums,nerr) ! call write_array(1,metrics(1,2,1,:), 'gtx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) ! call write_array(1,metrics(1,3,1,:), 'gty (covariant)',npart,k,ipass,idump,nums,ierrs(8)) ! call write_array(1,metrics(1,2,1,:), 'gtz (covariant)',npart,k,ipass,idump,nums,ierrs(8)) ! call write_array(1,metrics(1,2,1,:), 'gtx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metrics(2,2,1,:), 'gxx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metrics(3,3,1,:), 'gyy (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metrics(4,4,1,:), 'gzz (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metrics(2,2,1,:), 'gxx (covariant)',npart,k,ipass,idump,nums,nerr) + call write_array(1,metrics(3,3,1,:), 'gyy (covariant)',npart,k,ipass,idump,nums,nerr) + call write_array(1,metrics(4,4,1,:), 'gzz (covariant)',npart,k,ipass,idump,nums,nerr) - call write_array(1,metricderivs(1,1,1,:), 'dxgtt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metricderivs(2,2,1,:), 'dxgxx (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metricderivs(3,3,1,:), 'dxgyy (covariant)',npart,k,ipass,idump,nums,ierrs(8)) - call write_array(1,metricderivs(4,4,1,:), 'dxgzz (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,metricderivs(1,1,1,:), 'dxgtt (covariant)',npart,k,ipass,idump,nums,nerr) + call write_array(1,metricderivs(2,2,1,:), 'dxgxx (covariant)',npart,k,ipass,idump,nums,nerr) + call write_array(1,metricderivs(3,3,1,:), 'dxgyy (covariant)',npart,k,ipass,idump,nums,nerr) + call write_array(1,metricderivs(4,4,1,:), 'dxgzz (covariant)',npart,k,ipass,idump,nums,nerr) - call write_array(1,tmunus(1,1,:), 'tmunutt (covariant)',npart,k,ipass,idump,nums,ierrs(8)) + call write_array(1,tmunus(1,1,:), 'tmunutt (covariant)',npart,k,ipass,idump,nums,nerr) endif endif if (eos_is_non_ideal(ieos) .or. (.not.store_dust_temperature .and. icooling > 0)) then - call write_array(1,eos_vars(itemp,:),eos_vars_label(itemp),npart,k,ipass,idump,nums,ierrs(12)) + call write_array(1,eos_vars(itemp,:),eos_vars_label(itemp),npart,k,ipass,idump,nums,nerr) endif - if (eos_is_non_ideal(ieos)) call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,ierrs(12)) + if (eos_is_non_ideal(ieos)) call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,nerr) - call write_array(1,vxyzu,vxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,ierrs(4)) + call write_array(1,vxyzu,vxyzu_label,maxvxyzu,npart,k,ipass,idump,nums,nerr) ! write pressure to file if ((eos_outputs_gasP(ieos) .or. eos_is_non_ideal(ieos)) .and. k==i_real) then - call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,ierrs(13),index=igasP) + call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,nerr,index=igasP) endif ! write X, Z, mu to file if (eos_outputs_mu(ieos)) then - call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,ierrs(13),index=imu) + call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,nerr,index=imu) if (use_var_comp) then - call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,ierrs(13),index=iX) - call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,ierrs(13),index=iZ) + call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,nerr,index=iX) + call write_array(1,eos_vars,eos_vars_label,1,npart,k,ipass,idump,nums,nerr,index=iZ) endif endif ! write stamatellos cooling values @@ -413,73 +255,64 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) 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 - call write_array(1,xyzh,xyzh_label,1,npart,k,ipass,idump,nums,ierrs(14),use_kind=4,index=4) - if (maxalpha==maxp) call write_array(1,alphaind,(/'alpha'/),1,npart,k,ipass,idump,nums,ierrs(15)) + call write_array(1,xyzh,xyzh_label,1,npart,k,ipass,idump,nums,nerr,use_kind=4,index=4) + if (maxalpha==maxp) call write_array(1,alphaind,(/'alpha'/),1,npart,k,ipass,idump,nums,nerr) !if (maxalpha==maxp) then ! (uncomment this to write alphaloc to the full dumps) ! call write_array(1,alphaind,(/'alpha ','alphaloc'/),2,npart,k,ipass,idump,nums,ierrs(10)) !endif - if (ndivcurlv >= 1) call write_array(1,divcurlv,divcurlv_label,ndivcurlv,npart,k,ipass,idump,nums,ierrs(16)) + if (ndivcurlv >= 1) call write_array(1,divcurlv,divcurlv_label,ndivcurlv,npart,k,ipass,idump,nums,nerr) !if (maxdvdx==maxp) call write_array(1,dvdx,dvdx_label,9,npart,k,ipass,idump,nums,ierrs(17)) if (gravity .and. maxgrav==maxp) then - call write_array(1,poten,'poten',npart,k,ipass,idump,nums,ierrs(17)) + call write_array(1,poten,'poten',npart,k,ipass,idump,nums,nerr) endif if (ind_timesteps) then if (.not.allocated(temparr)) allocate(temparr(npart)) temparr(1:npart) = dtmax/2.**ibin(1:npart) - call write_array(1,temparr,'dt',npart,k,ipass,idump,nums,ierrs(18),use_kind=4) + call write_array(1,temparr,'dt',npart,k,ipass,idump,nums,nerr,use_kind=4) endif - call write_array(1,iorig,'iorig',npart,k,ipass,idump,nums,ierrs(29)) + call write_array(1,iorig,'iorig',npart,k,ipass,idump,nums,nerr) -#ifdef PRDRAG - if (k==i_real) then - if (.not.allocated(temparr)) allocate(temparr(npart)) - do l=1,npart - temparr(l) = real4(beta(xyzh(1,l), xyzh(2,l), xyzh(3,l))) - enddo - call write_array(1,temparr,'beta_pr',npart,k,ipass,idump,nums,ierrs(19)) - endif -#endif if (lightcurve) then - call write_array(1,luminosity,'luminosity',npart,k,ipass,idump,nums,ierrs(20)) + call write_array(1,luminosity,'luminosity',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,ierrs(21)) - call write_array(1,T_gas_cool,'temp',npart,k,ipass,idump,nums,ierrs(24)) + 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) endif if (update_muGamma .or. use_krome) then - call write_array(1,eos_vars(imu,:),eos_vars_label(imu),npart,k,ipass,idump,nums,ierrs(12)) - call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,ierrs(12)) + call write_array(1,eos_vars(imu,:),eos_vars_label(imu),npart,k,ipass,idump,nums,nerr) + call write_array(1,eos_vars(igamma,:),eos_vars_label(igamma),npart,k,ipass,idump,nums,nerr) endif - if (do_nucleation) then - call write_array(1,nucleation,nucleation_label,n_nucleation,npart,k,ipass,idump,nums,ierrs(25)) + call write_array(1,nucleation,nucleation_label,n_nucleation,npart,k,ipass,idump,nums,nerr) endif If (itau_alloc == 1) then - call write_array(1,tau,'tau',npart,k,ipass,idump,nums,ierrs(30)) + call write_array(1,tau,'tau',npart,k,ipass,idump,nums,nerr) endif If (itauL_alloc == 1) then - call write_array(1,tau_lucy,'tau_lucy',npart,k,ipass,idump,nums,ierrs(30)) + call write_array(1,tau_lucy,'tau_lucy',npart,k,ipass,idump,nums,nerr) endif if (store_dust_temperature) then - call write_array(1,dust_temp,'Tdust',npart,k,ipass,idump,nums,ierrs(26)) + call write_array(1,dust_temp,'Tdust',npart,k,ipass,idump,nums,nerr) endif if (do_radiation) then - call write_array(1,rad,rad_label,maxirad,npart,k,ipass,idump,nums,ierrs(27)) - call write_array(1,radprop,radprop_label,maxradprop,npart,k,ipass,idump,nums,ierrs(28)) + call write_array(1,rad,rad_label,maxirad,npart,k,ipass,idump,nums,nerr) + call write_array(1,radprop,radprop_label,maxradprop,npart,k,ipass,idump,nums,nerr) endif - if (any(ierrs(1:28) /= 0)) call error('write_dump','error writing hydro arrays') + if (nerr > 0) call error('write_dump','error writing hydro arrays') enddo + nerr = 0 do k=1,ndatatypes ! ! Block 2 arrays (sink particles) ! if (.not. sphNGdump .and. nptmass > 0 .and. nptmass <= maxptmass) then ilen(2) = int(nptmass,kind=8) - call write_array(2,xyzmh_ptmass,xyzmh_ptmass_label,nsinkproperties,nptmass,k,ipass,idump,nums,ierrs(1)) - call write_array(2,vxyz_ptmass,vxyz_ptmass_label,3,nptmass,k,ipass,idump,nums,ierrs(2)) - if (any(ierrs(1:2) /= 0)) call error('write_dump','error writing sink particle arrays') + call write_array(2,xyzmh_ptmass,xyzmh_ptmass_label,nsinkproperties,nptmass,k,ipass,idump,nums,nerr) + call write_array(2,vxyz_ptmass,vxyz_ptmass_label,3,nptmass,k,ipass,idump,nums,nerr) + if (nerr > 0) call error('write_dump','error writing sink particle arrays') endif enddo @@ -488,18 +321,20 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ! Block 4 arrays (MHD) ! if (mhd) then + nerr = 0 ilen(4) = int(npart,kind=8) - call write_array(4,Bxyz,Bxyz_label,3,npart,k,ipass,idump,nums,ierrs(1)) ! Bx,By,Bz - call write_array(4,Bevol,Bevol_label,1,npart,k,ipass,idump,nums,ierrs(1),index=4) ! psi + call write_array(4,Bxyz,Bxyz_label,3,npart,k,ipass,idump,nums,nerr) ! Bx,By,Bz + call write_array(4,Bevol,Bevol_label,1,npart,k,ipass,idump,nums,nerr,index=4) ! psi if (ndivcurlB >= 1) then - call write_array(4,divcurlB,divcurlB_label,ndivcurlB,npart,k,ipass,idump,nums,ierrs(2)) + call write_array(4,divcurlB,divcurlB_label,ndivcurlB,npart,k,ipass,idump,nums,nerr) else - call write_array(4,divBsymm,'divBsymm',npart,k,ipass,idump,nums,ierrs(2)) + call write_array(4,divBsymm,'divBsymm',npart,k,ipass,idump,nums,nerr) endif - if (any(ierrs(1:2) /= 0)) call error('write_dump','error writing MHD arrays') + if (nerr > 0) call error('write_dump','error writing MHD arrays') if (mhd_nonideal) then - call write_array(4,eta_nimhd,eta_nimhd_label,4,npart,k,ipass,idump,nums,ierrs(1)) - if (ierrs(1) /= 0) call error('write_dump','error writing non-ideal MHD arrays') + nerr = 0 + call write_array(4,eta_nimhd,eta_nimhd_label,4,npart,k,ipass,idump,nums,nerr) + if (nerr > 0) call error('write_dump','error writing non-ideal MHD arrays') endif endif enddo @@ -523,7 +358,6 @@ end subroutine write_fulldump_fortran ! (faked to look like the default real is real*4) !+ !------------------------------------------------------------------- - subroutine write_smalldump_fortran(t,dumpfile) use dim, only:maxp,maxtypes,use_dust,lightcurve,use_dustgrowth,h2chemistry use options, only:use_porosity @@ -538,7 +372,7 @@ subroutine write_smalldump_fortran(t,dumpfile) rad,rad_label,do_radiation,maxirad,luminosity 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 + use mpiutils, only:reduceall_mpi,start_threadwrite,end_threadwrite real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer(kind=8) :: ilen(4) @@ -567,7 +401,7 @@ subroutine write_smalldump_fortran(t,dumpfile) call open_dumpfile_w(idump,dumpfile,fileident('ST'),ierr,singleprec=.true.) if (ierr /= 0) then - call error('write_smalldump','can''t create new dumpfile '//trim(dumpfile)) + call error('write_smalldump','could not write new dumpfile '//trim(dumpfile)) return endif ! @@ -587,7 +421,7 @@ subroutine write_smalldump_fortran(t,dumpfile) !--arrays: number of array lengths ! nblockarrays = narraylengths*nblocks - write (idump, iostat=ierr) nblockarrays + write (idump,iostat=ierr) nblockarrays if (ierr /= 0) call error('write_smalldump','error writing nblockarrays') endif masterthread @@ -595,6 +429,7 @@ subroutine write_smalldump_fortran(t,dumpfile) call start_threadwrite(id,idump,dumpfile) nums = 0 + ierr = 0 ilen = 0_8 write_itype = (maxphase==maxp .and. any(npartoftypetot(2:) > 0)) do ipass=1,2 @@ -651,7 +486,6 @@ end subroutine write_smalldump_fortran ! and also from standard sphNG dump files !+ !------------------------------------------------------------------- - subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ierr,headeronly,dustydisc) use memory, only:allocate_memory use dim, only:maxp,maxvxyzu,gravity,lightcurve,mhd,maxp_hard,inject_parts,mpi @@ -659,8 +493,9 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie use part, only:xyzh,vxyzu,massoftype,npart,npartoftype,maxtypes,iphase, & maxphase,isetphase,nptmass,nsinkproperties,maxptmass,get_pmass, & xyzmh_ptmass,vxyz_ptmass - use dump_utils, only:skipblock,skip_arrays,check_tag,lenid,ndatatypes,read_header, & - open_dumpfile_r,get_error_text,ierr_realsize,free_header,read_block_header + use dump_utils, only:get_dump_size,skipblock,skip_arrays,check_tag,lenid,ndatatypes,read_header, & + open_dumpfile_r,get_error_text,ierr_realsize,free_header,read_block_header,& + get_blocklimits use mpiutils, only:reduce_mpi,reduceall_mpi use sphNGutils, only:convert_sinks_sphNG,mass_sphng use options, only:use_dustfrac @@ -680,6 +515,7 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie logical :: tagged,phantomdump,smalldump real :: dumr,alphafile character(len=lenid) :: fileidentr + character(len=12) :: string type(dump_h) :: hdr integer :: i,ierrh @@ -812,7 +648,11 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie ! Also handles MPI -> non-MPI dump conversion and vice-versa. ! Can be used by non-MPI codes to read isolated blocks only. ! - call get_blocklimits(nhydrothisblock,nblocks,nprocs,id,iblock,noffset,npartread) + call get_blocklimits(nhydrothisblock,nblocks,nprocs,id,iblock,noffset,npartread,ierr) + if (ierr /= 0) then + call error('read_dump','could not map blocks in dump to number of threads') + return + endif i1 = i2 + 1 i2 = i1 + (npartread - 1) npart = npart + npartread @@ -825,13 +665,10 @@ subroutine read_dump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,nprocs,ie endif cycle overblocks elseif (npartread > 0) then -#ifdef MPI - write(*,"(a,i5,2(a,i10),a,i5,a,i10,'-',i10)") & - 'thread ',id,' reading particles ',noffset+1,':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 -#else - write(*,"(2(a,i10),a,i5,a,i10,'-',i10)") & - ' reading particles ',noffset+1,':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 -#endif + string = '' + if (nprocs > 1) write(string,'(a,i5)') 'thread',iblock + write(*,"(2(a,i10),a,i5,a,i10,'-',i10)") trim(string)//' reading particles ',noffset+1,& + ':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 else write(*,"(a,i10,a)") ' WARNING! block contains no SPH particles, reading ',nptmass,' point mass particles only' endif @@ -923,7 +760,7 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro use part, only:npart,npartoftype,maxtypes,nptmass,nsinkproperties,maxptmass, & massoftype use dump_utils, only:skipblock,skip_arrays,check_tag,open_dumpfile_r,get_error_text,& - ierr_realsize,read_header,extract,free_header,read_block_header + ierr_realsize,read_header,extract,free_header,read_block_header,get_blocklimits use mpiutils, only:reduce_mpi,reduceall_mpi use options, only:use_dustfrac character(len=*), intent(in) :: dumpfile @@ -941,6 +778,7 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro logical :: tagged,phantomdump,smalldump real :: alphafile character(len=lenid) :: fileidentr + character(len=12) :: string type(dump_h) :: hdr integer :: i @@ -1057,17 +895,19 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro ! Also handles MPI -> non-MPI dump conversion and vice-versa. ! Can be used by non-MPI codes to read isolated blocks only. ! - call get_blocklimits(nhydrothisblock,nblocks,nprocs,id,iblock,noffset,npartread) + call get_blocklimits(nhydrothisblock,nblocks,nprocs,id,iblock,noffset,npartread,ierr) + if (ierr /= 0) then + call error('read_dump','could not map blocks in dump to number of threads') + return + endif i1 = i2 + 1 i2 = i1 + (npartread - 1) npart = npart + npartread -#ifdef MPI if (npart > maxp) then write(*,*) 'npart > maxp in readwrite_dumps' ierr = 1 return endif -#endif if (npartread <= 0 .and. nptmass <= 0) then call skipblock(idisk1,nums(:,1),nums(:,2),nums(:,3),nums(:,4),tagged,ierr) if (ierr /= 0) then @@ -1076,13 +916,10 @@ subroutine read_smalldump_fortran(dumpfile,tfile,hfactfile,idisk1,iprint,id,npro endif cycle overblocks elseif (npartread > 0) then -#ifdef MPI - write(*,"(a,i5,2(a,i10),a,i5,a,i10,'-',i10)") & - 'thread ',id,' reading particles ',noffset+1,':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 -#else - write(*,"(2(a,i10),a,i5,a,i10,'-',i10)") & - ' reading particles ',noffset+1,':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 -#endif + string = '' + if (nprocs > 1) write(string,'(a,i5)') 'thread',iblock + write(*,"(2(a,i10),a,i5,a,i10,'-',i10)") trim(string)//' reading particles ',noffset+1,& + ':',noffset+npartread,', from block ',iblock,' lims=',i1,i2 else write(*,"(a,i10,a)") ' WARNING! block contains no SPH particles, reading ',nptmass,' point mass particles only' endif @@ -1167,6 +1004,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto logical :: got_filfac,got_divcurlv(4),got_rad(maxirad),got_radprop(maxradprop),got_pxyzu(4),got_iorig character(len=lentag) :: tag,tagarr(64) integer :: k,i,iarr,ik,ndustfraci + real, allocatable :: tmparray(:) ! !--read array type 1 arrays @@ -1201,6 +1039,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto got_iorig = .false. ndustfraci = 0 + if (use_dust) allocate(tmparray(size(dustfrac,2))) over_arraylengths: do iarr=1,narraylengths do k=1,ndatatypes @@ -1234,8 +1073,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto if (use_dust) then if (any(tag == dustfrac_label)) then ndustfraci = ndustfraci + 1 - call read_array(dustfrac(ndustfraci,:),dustfrac_label(ndustfraci),got_dustfrac(ndustfraci), & + call read_array(tmparray,dustfrac_label(ndustfraci),got_dustfrac(ndustfraci), & ik,i1,i2,noffset,idisk1,tag,match,ierr) + dustfrac(ndustfraci,i1:i2) = tmparray(i1:i2) endif endif if (h2chemistry) then @@ -1297,6 +1137,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto enddo enddo over_arraylengths + if (allocated(tmparray)) deallocate(tmparray) ! ! check for errors ! @@ -1371,453 +1212,6 @@ subroutine check_block_header(narraylengths,nblocks,ilen,nums,nparttot,nhydrothi end subroutine check_block_header -!-------------------------------------------------------------------- -!+ -! utility to extract header variables to phantom -!+ -!------------------------------------------------------------------- -subroutine unfill_header(hdr,phantomdump,got_tags,nparttot, & - nblocks,npart,npartoftype, & - tfile,hfactfile,alphafile,iprint,id,nprocs,ierr) - use dim, only:maxdustlarge,use_dust - use io, only:master ! check this - use eos, only:isink - use part, only:maxtypes,igas,idust,ndustsmall,ndustlarge,ndusttypes,& - npartoftypetot - use units, only:udist,umass,utime,set_units_extra,set_units - use dump_utils, only:extract,dump_h - use fileutils, only:make_tags_unique - type(dump_h), intent(in) :: hdr - logical, intent(in) :: phantomdump,got_tags - integer(kind=8), intent(out) :: nparttot - integer, intent(out) :: nblocks,npart,npartoftype(maxtypes) - real, intent(out) :: tfile,hfactfile,alphafile - integer, intent(in) :: iprint,id,nprocs - integer, intent(out) :: ierr - integer :: nparttoti,npartoftypetoti(maxtypes),ntypesinfile,nptinfile - integer :: ierr1,ierrs(3),i,counter - integer(kind=8) :: ntypesinfile8 - character(len=10) :: dust_label(maxdustlarge) - - ierr = 0 - nparttot = 0 - npartoftypetot(:) = 0 - npart = 0 - npartoftype(:) = 0 - isink = 0 - call extract('ntypes',ntypesinfile,hdr,ierr1) - if (ierr1 /= 0 .or. ntypesinfile < 1) then - if (phantomdump .and. got_tags) then - ierr = 4 - return - else - ntypesinfile = 5 - endif - endif - - ! extract quantities from integer header - call extract('nparttot',nparttoti,hdr,ierr1) - if (ierr1 /= 0) then - ierr = 5 - return - endif - if (ntypesinfile > maxtypes) then - write(*,*) 'WARNING: number of particle types in file exceeds array limits' - write(*,*) 'READING ONLY FIRST ',maxtypes,' OF ',ntypesinfile,' particle types' - ntypesinfile = maxtypes - endif - call extract('npartoftype',npartoftypetoti(1:ntypesinfile),hdr,ierr1) - if (ierr1 /= 0) then - npartoftype(1) = nparttoti ! assume only gas particles - endif - call extract('nblocks',nblocks,hdr,ierr1,default=1) - if (ierr1 /= 0) write(*,*) 'number of MPI blocks not read: assuming 1' - - nparttot = int(nparttoti,kind=8) - npartoftypetot = int(npartoftypetoti,kind=8) - if (nblocks==1) then - npartoftype(1:ntypesinfile) = int(npartoftypetot(1:ntypesinfile)) - if (npartoftype(idust) > 0) write(*,*) 'n(gas) = ',npartoftype(igas) - counter = 0 - do i=1,maxdustlarge - if (npartoftype(idust+i-1) > 0) then - counter = counter + 1 - endif - enddo - dust_label = 'dust' - call make_tags_unique(counter,dust_label) - do i=1,counter - write(*,*) 'n('//trim(dust_label(i))//') = ',npartoftype(idust+i-1) - enddo - endif - call extract('isink',isink,hdr,ierr1) - -!--non-MPI dumps - if (nprocs==1) then - if (nparttoti > huge(npart)) then - write (*,*) 'ERROR in readdump: number of particles exceeds 32 bit limit, must use int(kind=8)''s ',nparttoti - ierr = 4 - return - endif - endif - if (nblocks==1) then - npart = int(nparttoti) - nparttot = npart - if (id==master) write (iprint,*) 'npart = ',npart - endif - if (got_tags) then - call extract('ntypes',ntypesinfile8,hdr,ierr1) - ntypesinfile = int(ntypesinfile8) - endif - if (ntypesinfile > maxtypes) then - write(*,*) 'WARNING: number of particle types in file exceeds array limits' - write(*,*) 'READING ONLY FIRST ',maxtypes,' OF ',ntypesinfile,' particle types' - ntypesinfile = maxtypes - endif - call extract('nparttot',nparttot,hdr,ierr1) - if (nblocks > 1) then - call extract('npartoftype',npartoftype(1:ntypesinfile),hdr,ierr1) - endif - if (id==master) write(*,*) 'npart(total) = ',nparttot -! -!--number of dust species -! - if (use_dust) then - call extract('ndustsmall',ndustsmall,hdr,ierrs(1)) - call extract('ndustlarge',ndustlarge,hdr,ierrs(2)) - if (any(ierrs(1:2) /= 0)) then - call extract('ndustfluids',ndustsmall,hdr,ierrs(1)) ! for backwards compatibility - if (ierrs(1) /= 0) write(*,*) 'ERROR reading number of small/large grain types from file header' - endif - ndusttypes = ndustsmall + ndustlarge - endif -! -!--units -! - call extract('udist',udist,hdr,ierrs(1)) - call extract('umass',umass,hdr,ierrs(2)) - call extract('utime',utime,hdr,ierrs(3)) - if (all(ierrs(1:3)==0)) then - call set_units_extra() - else - write(iprint,*) 'ERROR reading units from dump file, assuming default' - call set_units() ! use default units - endif - ! get nptmass from header, needed to figure out if gwinspiral info is sensible - call extract('nptmass',nptinfile,hdr,ierrs(1)) -!--default real - call unfill_rheader(hdr,phantomdump,ntypesinfile,nptinfile,& - tfile,hfactfile,alphafile,iprint,ierr) - if (ierr /= 0) return - - if (id==master) write(iprint,*) 'time = ',tfile - -end subroutine unfill_header - -!-------------------------------------------------------------------- -!+ -! subroutine to fill the real header with various things -!+ -!------------------------------------------------------------------- -subroutine fill_header(sphNGdump,t,nparttot,npartoftypetot,nblocks,nptmass,hdr,ierr) - use eos, only:write_headeropts_eos,polyk2 - 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 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 - use dim, only:use_dust,maxtypes,use_dustgrowth,do_nucleation, & - 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 - - logical, intent(in) :: sphNGdump - real, intent(in) :: t - integer(kind=8), intent(in) :: nparttot,npartoftypetot(:) - integer, intent(in) :: nblocks,nptmass - type(dump_h), intent(inout) :: hdr - integer, intent(out) :: ierr - integer :: number - - ierr = 0 - ! default int - call add_to_iheader(int(nparttot),'nparttot',hdr,ierr) - call add_to_iheader(maxtypes,'ntypes',hdr,ierr) - call add_to_iheader(int(npartoftypetot(1:maxtypes)),'npartoftype',hdr,ierr) - call add_to_iheader(nblocks,'nblocks',hdr,ierr) - call add_to_iheader(nptmass,'nptmass',hdr,ierr) - call add_to_iheader(ndustlarge,'ndustlarge',hdr,ierr) - call add_to_iheader(ndustsmall,'ndustsmall',hdr,ierr) - call add_to_iheader(idust,'idust',hdr,ierr) - call add_to_iheader(idtmax_n_next,'idtmax_n',hdr,ierr) - call add_to_iheader(idtmax_frac_next,'idtmax_frac',hdr,ierr) - call add_to_iheader(idumpfile,'idumpfile',hdr,ierr) - call add_to_iheader(phantom_version_major,'majorv',hdr,ierr) - call add_to_iheader(phantom_version_minor,'minorv',hdr,ierr) - call add_to_iheader(phantom_version_micro,'microv',hdr,ierr) - - ! int*8 - call add_to_header(nparttot,'nparttot',hdr,ierr) - call add_to_header(int(maxtypes,kind=8),'ntypes',hdr,ierr) - call add_to_header(npartoftypetot(1:maxtypes),'npartoftype',hdr,ierr) - - ! int*4 - call add_to_header(iexternalforce,'iexternalforce',hdr,ierr) - call add_to_header(ieos,'ieos',hdr,ierr) - call write_headeropts_eos(ieos,hdr,ierr) - - ! default real variables - call add_to_rheader(t,'time',hdr,ierr) - call add_to_rheader(dtmax_user,'dtmax',hdr,ierr) - call add_to_rheader(rhozero,'rhozero',hdr,ierr) - if (sphNGdump) then ! number = 23 - call add_to_rheader(0.,'escaptot',hdr,ierr) - call add_to_rheader(0.,'tkin',hdr,ierr) - call add_to_rheader(0.,'tgrav',hdr,ierr) - call add_to_rheader(0.,'tterm',hdr,ierr) - call add_to_rheader(0.,'anglostx',hdr,ierr) - call add_to_rheader(0.,'anglosty',hdr,ierr) - call add_to_rheader(0.,'anglostz',hdr,ierr) - call add_to_rheader(0.,'specang',hdr,ierr) - call add_to_rheader(0.,'ptmassin',hdr,ierr) - call add_to_rheader(0.,'tmag',hdr,ierr) - call add_to_rheader(Bextx,'Bextx',hdr,ierr) - call add_to_rheader(Bexty,'Bexty',hdr,ierr) - call add_to_rheader(Bextz,'Bextz',hdr,ierr) - call add_to_rheader(0.,'hzero',hdr,ierr) - call add_to_rheader(1.5*polyk2,'uzero_n2',hdr,ierr) - call add_to_rheader(0.,'hmass',hdr,ierr) - call add_to_rheader(0.,'gapfac',hdr,ierr) - call add_to_rheader(0.,'pmassinitial',hdr,ierr) - else ! number = 49 - call add_to_rheader(hfact,'hfact',hdr,ierr) - call add_to_rheader(tolh,'tolh',hdr,ierr) - call add_to_rheader(C_cour,'C_cour',hdr,ierr) - call add_to_rheader(C_force,'C_force',hdr,ierr) - call add_to_rheader(alpha,'alpha',hdr,ierr) - call add_to_rheader(alphau,'alphau',hdr,ierr) - call add_to_rheader(alphaB,'alphaB',hdr,ierr) - call add_to_rheader(massoftype,'massoftype',hdr,ierr) ! array - if (do_nucleation) call write_headeropts_dust_formation(hdr,ierr) - call add_to_rheader(Bextx,'Bextx',hdr,ierr) - call add_to_rheader(Bexty,'Bexty',hdr,ierr) - call add_to_rheader(Bextz,'Bextz',hdr,ierr) - call add_to_rheader(0.,'dum',hdr,ierr) - if (iexternalforce /= 0) call write_headeropts_extern(iexternalforce,hdr,t,ierr) - if (periodic) then - call add_to_rheader(xmin,'xmin',hdr,ierr) - call add_to_rheader(xmax,'xmax',hdr,ierr) - call add_to_rheader(ymin,'ymin',hdr,ierr) - call add_to_rheader(ymax,'ymax',hdr,ierr) - call add_to_rheader(zmin,'zmin',hdr,ierr) - call add_to_rheader(zmax,'zmax',hdr,ierr) - endif - if (dynamic_bdy) then - call add_to_rheader(dxyz,'dxyz',hdr,ierr) - call add_to_iheader(irho_bkg_ini,'irho_bkg_ini',hdr,ierr) - call add_to_rheader(rho_bkg_ini,'rho_bkg_ini',hdr,ierr) - endif - call add_to_rheader(get_conserv,'get_conserv',hdr,ierr) - call add_to_rheader(etot_in,'etot_in',hdr,ierr) - call add_to_rheader(angtot_in,'angtot_in',hdr,ierr) - call add_to_rheader(totmom_in,'totmom_in',hdr,ierr) - call add_to_rheader(mdust_in(1:ndusttypes),'mdust_in',hdr,ierr) - if (use_dust) then - call add_to_rheader(grainsize(1:ndusttypes),'grainsize',hdr,ierr) - call add_to_rheader(graindens(1:ndusttypes),'graindens',hdr,ierr) - endif - endif - - ! real*8 - call add_to_header(udist,'udist',hdr,ierr) - call add_to_header(umass,'umass',hdr,ierr) - call add_to_header(utime,'utime',hdr,ierr) - call add_to_header(unit_Bfield,'umagfd',hdr,ierr) - - if (ierr /= 0) write(*,*) ' ERROR: arrays too small writing rheader' - - number = num_in_header(hdr%realtags) - if (number >= maxphead) then - write(*,*) 'error: header arrays too small for number of items in header: will be truncated' - endif - -end subroutine fill_header - -!-------------------------------------------------------------------- -!+ -! subroutine to set runtime parameters having read the real header -!+ -!------------------------------------------------------------------- -subroutine unfill_rheader(hdr,phantomdump,ntypesinfile,nptmass,& - tfile,hfactfile,alphafile,iprint,ierr) - use io, only:id,master - use dim, only:maxvxyzu,nElements,use_dust,use_dustgrowth,use_krome,do_nucleation,idumpfile - use eos, only:extract_eos_from_hdr, read_headeropts_eos - 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 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 - use boundary_dyn, only:dynamic_bdy,dxyz,irho_bkg_ini,rho_bkg_ini,rho_bkg_ini1 - use dump_utils, only:extract - use dust, only:grainsizecgs,graindenscgs - use units, only:unit_density,udist - use timestep, only:idtmax_n,idtmax_frac - use dust_formation, only:read_headeropts_dust_formation - type(dump_h), intent(in) :: hdr - logical, intent(in) :: phantomdump - integer, intent(in) :: iprint,ntypesinfile,nptmass - real, intent(out) :: tfile,hfactfile,alphafile - integer, intent(out) :: ierr - - integer, parameter :: lu = 173 - integer :: ierrs(10),iextern_in_file - real :: xmini,xmaxi,ymini,ymaxi,zmini,zmaxi,dtmaxi - real :: alphaufile,alphaBfile,C_courfile,C_forcefile,tolhfile - logical :: iexist - - ierr = 0 - call extract('time',tfile,hdr,ierr) - if (ierr/=0) call extract('gt',tfile,hdr,ierr) ! this is sphNG's label for time - call extract('dtmax',dtmaxi,hdr,ierr) - call extract('rhozero',rhozero,hdr,ierr) - Bextx = 0. - Bexty = 0. - Bextz = 0. - if (phantomdump) then - call extract('hfact',hfactfile,hdr,ierr) - call extract('tolh',tolhfile,hdr,ierr) - call extract('C_cour',C_courfile,hdr,ierr) - call extract('C_force',C_forcefile,hdr,ierr) - call extract('alpha',alphafile,hdr,ierr) - if (maxvxyzu >= 4) then - call extract('alphau',alphaufile,hdr,ierr) - else - alphaufile = 0. - endif - if (mhd) then - call extract('alphaB',alphaBfile,hdr,ierr) - endif - - if (extract_eos_from_hdr) call extract('ieos',ieos,hdr,ierr) - - call extract('massoftype',massoftype(1:ntypesinfile),hdr,ierr) - if (ierr /= 0) then - write(*,*) '*** ERROR reading massoftype from dump header ***' - ierr = 4 - endif - if (do_nucleation) then - call read_headeropts_dust_formation(hdr,ierr) - if (ierr /= 0) ierr = 6 - endif - - call extract('iexternalforce',iextern_in_file,hdr,ierrs(1)) - if (extract_iextern_from_hdr) iexternalforce = iextern_in_file - if (iexternalforce /= 0) then - call read_headeropts_extern(iexternalforce,hdr,nptmass,ierrs(1)) - if (ierrs(1) /= 0) ierr = 5 - elseif (iextern_in_file /= 0) then - call read_headeropts_extern(iextern_in_file,hdr,nptmass,ierrs(1)) - if (ierrs(1) /= 0) ierr = 5 - endif - - call extract('idtmax_n',idtmax_n,hdr,ierr,default=1) - call extract('idtmax_frac',idtmax_frac,hdr,ierr) - call extract('idumpfile',idumpfile,hdr,ierr) - else - massoftype(1) = 0. - hfactfile = 0. - endif - - call read_headeropts_eos(ieos,hdr,ierr) - - if (periodic) then - call extract('xmin',xmini,hdr,ierrs(1)) - call extract('xmax',xmaxi,hdr,ierrs(2)) - call extract('ymin',ymini,hdr,ierrs(3)) - call extract('ymax',ymaxi,hdr,ierrs(4)) - call extract('zmin',zmini,hdr,ierrs(5)) - call extract('zmax',zmaxi,hdr,ierrs(6)) - if (any(ierrs(1:6) /= 0)) then - write(*,"(2(/,a))") ' ERROR: dump does not contain boundary positions', & - ' but we are using periodic boundaries' - inquire(file='bound.tmp',exist=iexist) - if (iexist) then - open(unit=lu,file='bound.tmp') - read(lu,*) xmini,xmaxi,ymini,ymaxi,zmini,zmaxi - close(lu) - call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) - write(*,"(a,6(es10.3,1x))") ' READ from bound.tmp ',xmin,xmax,ymin,ymax,zmin,zmax - else - write(*,"(3(/,a),/,/,a)") ' To silence this error and restart from an older dump file ', & - ' create an ascii file called "bound.tmp" in the current directory', & - ' with xmin,xmax,ymin,ymax,zmin & zmax in it, e.g.: ', & - ' 0. 1. 0. 1. 0. 1.' - ierr = 5 ! spit fatal error - endif - else - call set_boundary(xmini,xmaxi,ymini,ymaxi,zmini,zmaxi) - endif - endif - - if (dynamic_bdy) then - call extract('irho_bkg_ini',irho_bkg_ini,hdr,ierrs(1)) - call extract('rho_bkg_ini',rho_bkg_ini,hdr,ierrs(1)) - call extract('dxyz',dxyz,hdr,ierrs(2)) - if (rho_bkg_ini > 0.) then - rho_bkg_ini1 = 1.0/rho_bkg_ini - else - rho_bkg_ini1 = 0. - endif - endif - - if (mhd) then - call extract('Bextx',Bextx,hdr,ierrs(1)) - call extract('Bexty',Bexty,hdr,ierrs(2)) - call extract('Bextz',Bextz,hdr,ierrs(3)) - if (id==master) then - if (any(ierrs(1:3) /= 0)) then - write(*,*) 'ERROR reading external field (setting to zero)' - else - write(*,*) 'External field found, Bext = ',Bextx,Bexty,Bextz - endif - endif - endif - - ! values to track that conserved values remain conserved - call extract('get_conserv',get_conserv,hdr,ierrs(1)) - 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)) - if (any(ierrs(1:4) /= 0)) then - write(*,*) 'ERROR reading values to verify conservation laws. Resetting initial values.' - get_conserv = 1.0 - endif - - - !--pull grain size and density arrays if they are in the header - !-- i.e. if dustgrowth is not ON - if (use_dust .and. .not.use_dustgrowth) then - call extract('grainsize',grainsize(1:ndusttypes),hdr,ierrs(1)) - call extract('graindens',graindens(1:ndusttypes),hdr,ierrs(2)) - if (any(ierrs(1:2) /= 0)) then - write(*,*) 'ERROR reading grain size/density from file header' - grainsize(1) = real(grainsizecgs/udist) - graindens(1) = real(graindenscgs/unit_density) - endif - endif - -end subroutine unfill_rheader - - !----------------------------------------------------------------- !+ ! if tags not read, give expected order of variables in header diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index ec94e4cee..a116046ef 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -108,7 +108,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) use growth, only:write_options_growth use porosity, only:write_options_porosity #ifdef INJECT_PARTICLES - use inject, only:write_options_inject + use inject, only:write_options_inject,inject_type,update_injected_par #endif use dust_formation, only:write_options_dust_formation use nicil_sup, only:write_options_nicil @@ -215,7 +215,8 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) ! thermodynamics ! call write_options_eos(iwritein) - if (maxvxyzu >= 4 .and. (ieos==2 .or. ieos==5 .or. ieos==10 .or. ieos==15 .or. ieos==12 .or. ieos==16 .or. ieos==21) ) then + if (maxvxyzu >= 4 .and. (ieos==2 .or. ieos==5 .or. ieos==10 .or. ieos==15 .or. ieos==12 .or. ieos==16 & + .or. ieos==17 .or. ieos==21) ) then call write_inopt(ipdv_heating,'ipdv_heating','heating from PdV work (0=off, 1=on)',iwritein) call write_inopt(ishock_heating,'ishock_heating','shock heating (0=off, 1=on)',iwritein) if (mhd) then @@ -269,6 +270,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) write(iwritein,"(/,a)") '# options for injecting/removing particles' #ifdef INJECT_PARTICLES call write_options_inject(iwritein) + if (inject_type=='sim') call update_injected_par() #endif call write_inopt(rkill,'rkill','deactivate particles outside this radius (<0 is off)',iwritein) @@ -685,14 +687,14 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (beta > 4.) call warn(label,'very high beta viscosity set') #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 /= 20 .and. ieos/=21)) & + ieos /=11 .and. ieos /=12 .and. ieos /= 15 .and. ieos /= 16 .and. ieos /= 17 .and. ieos /= 20 .and. ieos/=21)) & 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') if (shearparam < 0.) call fatal(label,'stupid value for shear parameter (< 0)') if (irealvisc==2 .and. shearparam > 1) call error(label,'alpha > 1 for shakura-sunyaev viscosity') if (iverbose > 99 .or. iverbose < -9) call fatal(label,'invalid verboseness setting (two digits only)') - if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos ==21)) & + if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos == 17 .or. ieos == 21)) & call fatal(label,'cooling requires adiabatic eos (ieos=2)') if (icooling > 0 .and. (ipdv_heating <= 0 .or. ishock_heating <= 0)) & call fatal(label,'cooling requires shock and work contributions') diff --git a/src/utils/analysis_GalMerger.f90 b/src/utils/analysis_GalMerger.f90 index 4dc4d3352..6f4e0c1fb 100644 --- a/src/utils/analysis_GalMerger.f90 +++ b/src/utils/analysis_GalMerger.f90 @@ -47,7 +47,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) character(len=200) :: fileout ! !--Open file (appendif exists) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_stellarCoM.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_stellarCoM.dat' inquire(file=fileout,exist=iexist) if ( .not.iexist .or. firstcall ) then firstcall = .false. diff --git a/src/utils/analysis_NSmerger.f90 b/src/utils/analysis_NSmerger.f90 index 053402dff..c96e57d0d 100644 --- a/src/utils/analysis_NSmerger.f90 +++ b/src/utils/analysis_NSmerger.f90 @@ -127,7 +127,7 @@ subroutine trace_com(dumpfile,xyzh,vxyzu,time,npart,iunit) real :: rad ! !--Open file (appendif exists) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_orbit.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_orbit.dat' inquire(file=fileout,exist=iexist) if ( firstcall .or. .not.iexist ) then open(iunit,file=fileout,status='replace') @@ -280,7 +280,7 @@ subroutine calculate_I(dumpfile,xyzh,time,npart,iunit,particlemass) real :: principle(3),evectors(3,3),ellipticity(2) ! !--Open file (appendif exists) - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_inertia.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_inertia.dat' inquire(file=fileout,exist=iexist) if ( firstcall .or. .not.iexist ) then open(iunit,file=fileout,status='replace') @@ -358,7 +358,7 @@ subroutine calculate_midplane_profile(dumpfile,xyzh,vxyzu,npart,iunit,particlema if (.not.opened_full_dump)return ! !--Open file - fileout = trim(dumpfile(1:INDEX(dumpfile,'_')-1))//'_rotataxesprofile'//trim(dumpfile(INDEX(dumpfile,'_'):))//'.dat' + fileout = trim(dumpfile(1:index(dumpfile,'_')-1))//'_rotataxesprofile'//trim(dumpfile(index(dumpfile,'_'):))//'.dat' open(iunit,file=fileout,status='replace') write(iunit,"('#',10(1x,'[',i2.2,1x,a11,']',2x))") & 1,'outer bin rad',& From 292fca23d004ed5f6a0200898329303bb2264d71 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 29 Jul 2024 18:11:10 +0100 Subject: [PATCH 739/814] Edits to make upstream changes work --- src/main/cooling_radapprox.f90 | 30 +++++++------ src/main/dens.F90 | 2 +- src/main/eos_stamatellos.f90 | 7 ++- src/main/force.F90 | 64 +++++++++++----------------- src/main/readwrite_dumps_fortran.f90 | 6 +-- src/main/step_leapfrog.F90 | 6 --- 6 files changed, 50 insertions(+), 65 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index dd62d3f50..b8b869f39 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -63,18 +63,18 @@ end subroutine init_star ! ! Do cooling calculation ! -! update energy to return evolved energy array. Called from step corrector -subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,dudti_sph,Tfloor) +! update energy to return evolved energy array. Called from substep +subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,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 + duFLD,doFLD,ttherm_store,teqi_store,opac_store,duSPH use part, only:xyzmh_ptmass,rhoh,massoftype,igas use timestep_ind, only:get_dt integer,intent(in) :: i integer(kind=1),intent(in) :: ibini - real,intent(in) :: xyzhi(:),dtsph,dudti_sph,Tfloor + real,intent(in) :: xyzhi(:),dtsph,Tfloor real,intent(inout) :: ui real :: dti,rhoi,coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot @@ -87,6 +87,9 @@ subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,dudti_sph,Tfloor) du_FLDi = duFLD(i) kappaBari = 0d0 kappaParti = 0d0 + Teqi = huge(Teqi) + tthermi = huge(tthermi) + opaci = epsilon(opaci) if (abs(ui) < epsilon(ui)) print *, "ui zero", i rhoi = rhoh(xyzhi(4),massoftype(igas)) @@ -146,22 +149,26 @@ subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,dudti_sph,Tfloor) Tmini4 = Tfloor**4d0 endif + call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi*unit_density,umini) + umini = umini/unit_ergg + 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 = dudti_sph + du_FLDi + du_tot = duSPH(i) + du_FLDi else - du_tot = dudti_sph + 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(dudti_rad/du_tot) < dtcool_crit) then ! print *, "not cooling/heating for r=",sqrt(ri2),".", dudti_rad,& - ! dudt_sph(i) + ! dusph(i) ui = ui + du_tot*dti + if (ui < umini) ui = umini return endif @@ -177,9 +184,9 @@ subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,dudti_sph,Tfloor) teqi_store(i) = Teqi if (Teqi > 9e5) then - print *,"i=",i, "dudt_sph(i)=", dudti_sph, "duradi=", dudti_rad, "Ti=", Ti, & + 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=", dudti_sph*dti + "dudt_sph * dti=", dusph(i)*dti elseif (Teqi < epsilon(Teqi)) then print *, "Teqi=0.0", "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& "Ti=", Ti, "poti=",poti, "rhoi=", rhoi @@ -191,9 +198,6 @@ subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,dudti_sph,Tfloor) 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 if ((du_tot) == 0.d0) then tthermi = 0d0 @@ -216,7 +220,7 @@ subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,dudti_sph,Tfloor) ! 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",dudti_sph + print *, "opaci=",opaci,"coldensi=",coldensi,"dusph(i)",duSPH(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) diff --git a/src/main/dens.F90 b/src/main/dens.F90 index 60d90ed93..81cd68031 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -101,7 +101,7 @@ module densityforce !real, parameter :: cnormk = 1./pi, wab0 = 1., gradh0 = -3.*wab0, radkern2 = 4F.0 integer, parameter :: isizecellcache = 1000 integer, parameter :: isizeneighcache = 0 - integer, parameter :: maxdensits = 50 + integer, parameter :: maxdensits = 100 !--statistics which can be queried later integer, private :: maxneighact,nrelink diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index a6d485982..ff3b7a404 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(:) + real,allocatable,public :: ttherm_store(:),teqi_store(:),opac_store(:),duSPH(:) 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,7 +41,8 @@ subroutine init_S07cool() allocate(urad_FLD(npart)) allocate(ttherm_store(npart)) allocate(teqi_store(npart)) - allocate(opac_store(npart)) + allocate(opac_store(npart)) + allocate(duSPH(npart)) Gpot_cool(:) = 0d0 gradP_cool(:) = 0d0 urad_FLD(:) = 0d0 @@ -49,6 +50,7 @@ subroutine init_S07cool() teqi_store(:) = 0d0 ttherm_store(:) = 0d0 opac_store(:) = 0d0 + duSPH(:) = 0d0 open (unit=iunitst,file='EOSinfo.dat',status='replace') if (doFLD) then print *, "Using Forgan+ 2009 hybrid cooling method (FLD)" @@ -67,6 +69,7 @@ subroutine finish_S07cool() if (allocated(ttherm_store)) deallocate(ttherm_store) if (allocated(teqi_store)) deallocate(teqi_store) if (allocated(opac_store)) deallocate(opac_store) + if (allocated(duSPH)) deallocate(duSPH) close(iunitst) end subroutine finish_S07cool diff --git a/src/main/force.F90 b/src/main/force.F90 index 82a63baf4..aa5438914 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -150,27 +150,26 @@ module forces idBevolyi = 10, & idBevolzi = 11, & idivBdiffi = 12, & - ihdivBBmax = 13, & !--dust array indexing - ifdragxi = 14, & - ifdragyi = 15, & - ifdragzi = 16, & - iddustevoli = 17, & - iddustevoliend = 17 + (maxdustsmall-1), & - idudtdusti = 18 + (maxdustsmall-1), & - idudtdustiend = 18 + 2*(maxdustsmall-1), & - ideltavxi = 19 + 2*(maxdustsmall-1), & - ideltavxiend = 19 + 3*(maxdustsmall-1), & - ideltavyi = 20 + 3*(maxdustsmall-1), & - ideltavyiend = 20 + 4*(maxdustsmall-1), & - ideltavzi = 21 + 4*(maxdustsmall-1), & - ideltavziend = 21 + 5*(maxdustsmall-1), & - idvix = 22 + 5*(maxdustsmall-1), & - idviy = 23 + 5*(maxdustsmall-1), & - idviz = 24 + 5*(maxdustsmall-1), & - idensgasi = 25 + 5*(maxdustsmall-1), & - icsi = 26 + 5*(maxdustsmall-1), & - idradi = 26 + 5*(maxdustsmall-1) + 1 + ifdragxi = 13, & + ifdragyi = 14, & + ifdragzi = 15, & + iddustevoli = 16, & + iddustevoliend = 16 + (maxdustsmall-1), & + idudtdusti = 17 + (maxdustsmall-1), & + idudtdustiend = 17 + 2*(maxdustsmall-1), & + ideltavxi = 18 + 2*(maxdustsmall-1), & + ideltavxiend = 18 + 3*(maxdustsmall-1), & + ideltavyi = 19 + 3*(maxdustsmall-1), & + ideltavyiend = 19 + 4*(maxdustsmall-1), & + ideltavzi = 20 + 4*(maxdustsmall-1), & + ideltavziend = 20 + 5*(maxdustsmall-1), & + idvix = 21 + 5*(maxdustsmall-1), & + idviy = 22 + 5*(maxdustsmall-1), & + idviz = 23 + 5*(maxdustsmall-1), & + idensgasi = 24 + 5*(maxdustsmall-1), & + icsi = 25 + 5*(maxdustsmall-1), & + idradi = 25 + 5*(maxdustsmall-1) + 1 private @@ -1669,7 +1668,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g else Bj1 = 0.0 endif - fsum(ihdivBBmax) = max( hj*abs(divcurlB(1,j))*Bj1, fsum(ihdivBBmax)) ! ! non-ideal MHD terms ! @@ -2585,7 +2583,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv use dim, only:mhd,mhd_nonideal,lightcurve,use_dust,maxdvdx,use_dustgrowth,gr,use_krome,& store_dust_temperature,do_nucleation,update_muGamma,h2chemistry use eos, only:ieos,iopacity_type - use options, only:alpha,ipdv_heating,ishock_heating,psidecayfac,overcleanfac,hdivbbmax_max, & + 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,& @@ -2618,7 +2616,7 @@ 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 + use eos_stamatellos, only:Gpot_cool,duSPH integer, intent(in) :: icall type(cellforce), intent(inout) :: cell real, intent(inout) :: fxyzu(:,:) @@ -2662,7 +2660,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv real :: Bxyzi(3),curlBi(3),dvdxi(9),straini(6) real :: xi,yi,zi,B2i,f2i,divBsymmi,betai,frac_divB,divBi,vcleani real :: pri,spsoundi,drhodti,divvi,shearvisc,fac,pdv_work - real :: psii,dtau,hdivbbmax + real :: psii,dtau real :: eni,dudtnonideal real :: dustfraci(maxdusttypes),dustfracisum real :: tstopi(maxdusttypes),tseff,dtdustdenom @@ -3007,6 +3005,7 @@ 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 = fxyz4 endif endif @@ -3030,22 +3029,7 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv ! new cleaning evolving d/dt (psi/c_h) dBevol(4,i) = -vcleani*fsum(idivBdiffi)*rho1i - psii*dtau - 0.5*psii*divvi - - ! timestep from cleaning - ! 1. the factor of 10 in hdivbbmax is empirical from checking how much - ! spurious B-fields are decreased in colliding flows - ! 2. if overcleaning is on (i.e. hdivbbmax > 1.0), then factor of 2 is - ! from empirical tests to ensure that overcleaning with individual - ! timesteps is stable - if (B2i > 0.) then - hdivbbmax = hi*abs(divBi)/sqrt(B2i) - else - hdivbbmax = 0.0 - endif - hdivbbmax = max( overcleanfac, 10.*hdivbbmax, 10.*fsum(ihdivBBmax) ) - hdivbbmax = min( hdivbbmax, hdivbbmax_max ) - if (hdivbbmax > 1.0) hdivbbmax = 2.0*hdivbbmax - dtclean = C_cour*hi/(hdivbbmax * vwavei + tiny(0.)) + dtclean = C_cour*hi/(vcleani + tiny(0.)) endif endif diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 6ecf0627c..40a8bf319 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -250,9 +250,9 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ! 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)) - 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)) + 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) endif ! smoothing length written as real*4 to save disk space call write_array(1,xyzh,xyzh_label,1,npart,k,ipass,idump,nums,nerr,use_kind=4,index=4) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index ae4ef96ff..3ab5e8362 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -127,7 +127,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use eos, only:equationofstate use substepping, only:substep,substep_gr, & substep_sph_gr,substep_sph - use cooling_radapprox, only:radcool_update_energ integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -236,8 +235,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif - !Alison icooling, vpred is right value here for u, but shouldn't be ...? -! print *, "line 234", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)),"nactive =", nactive !---------------------------------------------------------------------- ! substepping with external and sink particle forces, using dtextforce @@ -388,7 +385,6 @@ 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,1:npart) = vxyzu(4,1:npart) dt_too_small = .false. call derivs(1,npart,nactive,xyzh,vpred,fxyzu,fext,divcurlv,& divcurlB,Bpred,dBevol,radpred,drad,radprop,dustproppred,ddustprop,& @@ -399,7 +395,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) rad = radpred vxyzu(4,1:npart) = vpred(4,1:npart) endif - if (icooling == 9) vxyzu(4,1:npart) = vpred(4,1:npart) if (gr) vxyzu = vpred ! May need primitive variables elsewhere? if (dt_too_small) then @@ -489,7 +484,6 @@ 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) - if (its == 1) call radcool_update_energ(i,ibin(i),dtsph,xyzh(:,i),vxyzu(4,i),fxyzu(4,i),Tfloor) else vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) endif From e9ee98af4e31c2797df5d732a876587ef3cb7c86 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 30 Jul 2024 11:27:43 +0200 Subject: [PATCH 740/814] (subgroup) tests passed for triples... --- src/main/part.F90 | 4 +- src/main/subgroup.f90 | 166 +++++++++++++++++++++++------------------- 2 files changed, 93 insertions(+), 77 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index ad30404c9..c23bf83ce 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -312,7 +312,7 @@ module part integer, parameter :: iapo = 3 ! apocenter integer, parameter :: iorb = 4 ! orbital period integer, parameter :: ipert = 5 ! perturbation - integer, parameter :: ikap = 6 ! kappa slow down + integer, parameter :: ikap = 6 ! kappa slow down ! needed for group identification and sorting @@ -517,7 +517,7 @@ subroutine allocate_part endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) call allocate_array('group_info', group_info, 4, maxptmass) - call allocate_array('bin_info', bin_info, 5, maxptmass) + call allocate_array('bin_info', bin_info, 6, maxptmass) call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) call allocate_array("gtgrad", gtgrad, 3, maxptmass) call allocate_array('isionised', isionised, maxp) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index d25abcf65..77322c272 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -74,7 +74,6 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm logical :: large_search - large_search = present(dtext) n_group = 0 n_ingroup = 0 @@ -115,14 +114,13 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) integer, intent(in) :: n_group integer :: i,k,l,start_id,end_id,gsize real :: akl,ekl,apokl,Tkl - ! need to be zeroed for safety reasons - bin_info(:,:) = 0. ! this loop could be parallelized... do i=1,n_group start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) gsize = (end_id - start_id) + 1 + group_info(icomp,start_id:end_id) = -1 if (gsize > 2) then call binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,& gsize,start_id,end_id) @@ -157,17 +155,19 @@ subroutine binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gs integer, allocatable :: r2min_id(:) real :: akl,ekl,apokl,Tkl integer :: np,ns,j,k,l + + group_info(icomp,start_id:end_id) = -1 allocate(r2min_id(gsize)) call get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) do j=start_id,end_id np = (j-start_id) + 1 k = group_info(igarg,j) - if (group_info(icomp,j) > 0) then + if (group_info(icomp,j) < 0) then ns = r2min_id(np) if (r2min_id(ns) == np) then ! We found a binary into a subgroup : tag as binary component and compute parameters - l = group_info(igarg,ns+start_id) - group_info(icomp,np) = l - group_info(icomp,ns+start_id) = k + l = group_info(igarg,ns+(start_id-1)) + group_info(icomp,np) = l + group_info(icomp,ns+(start_id-1)) = k ! !-- Compute and store main orbital parameters needed for SDAR method ! @@ -181,13 +181,14 @@ subroutine binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gs bin_info(iorb,k) = Tkl bin_info(iorb,l) = Tkl else ! No matches... Only a single - group_info(icomp,k) = k + group_info(icomp,j) = k bin_info(:,k) = 0. endif endif enddo deallocate(r2min_id) + end subroutine binaries_in_multiples subroutine get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) @@ -414,7 +415,7 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,bin_info, & call get_timings(t1,tcpu1) - !call find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) + call find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) if (id==master) then !$omp parallel do default(none)& @@ -433,7 +434,6 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,bin_info, & call get_timings(t2,tcpu2) call increment_timer(itimer_sg_evol,t2-t1,tcpu2-tcpu1) - endif call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) @@ -519,6 +519,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ if (step_count_int > max_step) then print*,"MAX STEP NUMBER, ABORT !!!" + print*,step_count_int,step_count_tsyn,tcoord,tnext,ds_init call abort() endif @@ -568,7 +569,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ endif enddo - print*,step_count_int,step_count_tsyn,tcoord,tnext,ds_init + !print*,"integrate : ",step_count_int,step_count_tsyn,tcoord,tnext,ds_init deallocate(bdata) @@ -675,11 +676,12 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsi real, intent(in) :: h,W integer, intent(in) :: s_id,e_id,gsize integer, allocatable :: binstack(:) - integer :: k,i,compi + integer :: k,i,compi,n real :: dtd,vcom(3),m1,m2,mtot,kappa1i allocate(binstack((gsize/4)+1)) binstack = 0 + n = 0 dtd = h/W @@ -697,6 +699,8 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsi vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,compi))/mtot vcom(2) = (m1*vxyz_ptmass(2,i)+m2*vxyz_ptmass(2,compi))/mtot vcom(3) = (m1*vxyz_ptmass(3,i)+m2*vxyz_ptmass(3,compi))/mtot + n = n+1 ! stack level + binstack(n) = compi call correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1i,dtd,i,compi) @@ -712,14 +716,14 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsi end subroutine drift_TTL subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,s_id,e_id) - use part, only: igarg + use part, only: igarg,ikap real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) real, intent(inout) :: gtgrad(:,:),bin_info(:,:) integer, intent(inout) :: group_info(:,:) real, intent(in) :: h real, intent(inout) :: W integer, intent(in) :: s_id,e_id - real :: om,dw,dtk + real :: om,dw,dtk,kappa1,om_old integer :: i,k,gsize gsize = (e_id-s_id+1) @@ -727,36 +731,40 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass if (h==0.) then call binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,& gsize,s_id,e_id) + call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om_old,s_id,e_id,.true.) call update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) - endif - call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id) - + call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id) + W = W + (om-om_old) ! correct W after updating kappa... + else - dtk = h/om - do k=s_id,e_id - i=group_info(igarg,k) - vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + (0.5*dtk)*fxyz_ptmass(1,i) - vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + (0.5*dtk)*fxyz_ptmass(2,i) - vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + (0.5*dtk)*fxyz_ptmass(3,i) - enddo + call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id) - dw = 0. - do k=s_id,e_id - i=group_info(igarg,k) - dw = dw + vxyz_ptmass(1,i)*gtgrad(1,i) + & - vxyz_ptmass(2,i)*gtgrad(2,i) + & - vxyz_ptmass(3,i)*gtgrad(3,i) - enddo + dtk = h/om + do k=s_id,e_id + i=group_info(igarg,k) + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + (0.5*dtk)*fxyz_ptmass(1,i) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + (0.5*dtk)*fxyz_ptmass(2,i) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + (0.5*dtk)*fxyz_ptmass(3,i) + enddo - W = W + dw*dtk + dw = 0. + do k=s_id,e_id + i=group_info(igarg,k) + kappa1 = 1./bin_info(ikap,i) + dw = dw + kappa1*(vxyz_ptmass(1,i)*gtgrad(1,i) + & + vxyz_ptmass(2,i)*gtgrad(2,i) + & + vxyz_ptmass(3,i)*gtgrad(3,i)) + enddo - do k=s_id,e_id - i=group_info(igarg,k) - vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + (0.5*dtk)*fxyz_ptmass(1,i) - vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + (0.5*dtk)*fxyz_ptmass(2,i) - vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + (0.5*dtk)*fxyz_ptmass(3,i) - enddo + W = W + dw*dtk + do k=s_id,e_id + i=group_info(igarg,k) + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + (0.5*dtk)*fxyz_ptmass(1,i) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + (0.5*dtk)*fxyz_ptmass(2,i) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + (0.5*dtk)*fxyz_ptmass(3,i) + enddo + endif end subroutine kick_TTL @@ -923,9 +931,9 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, if (.not.present(potonly)) then ddr3 = ddr*ddr*ddr if (j == compi) then - gravf = mj*(1./ddr3)*kappa1i + gravf = -mj*ddr3*kappa1i else - gravf = mj*(1./ddr3) + gravf = -mj*ddr3 endif gravfi(1) = gravfi(1) + dx*gravf gravfi(2) = gravfi(2) + dy*gravf @@ -960,54 +968,62 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, end subroutine get_force_TTL subroutine update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) - use part, only:igarg,icomp,ipert,ikap,iapo + use part, only:igarg,icomp,ipert,ikap,iapo,iecc,isemi real , intent(in) :: xyzmh_ptmass(:,:) real , intent(inout) :: bin_info(:,:) integer, intent(in) :: group_info(:,:) integer, intent(in) :: s_id,e_id,gsize integer, allocatable :: binstack(:) - integer :: k,l,i,j,compi + integer :: k,l,i,j,compi,n real :: pouti,r2,dx,dy,dz,ddr,ddr3,xi,yi,zi,m1,m2,mj,mu - real :: kappai,rapo,rapo3 + real :: kappa,rapo,rapo3 allocate(binstack(gsize)) + binstack = 0 + n = 0 do k=s_id,e_id i = group_info(igarg,k) compi = group_info(icomp,k) - if (compi == i) cycle - if (any(binstack == i)) cycle - pouti = bin_info(ipert,i) - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) - m1 = xyzmh_ptmass(4,i) - m2 = xyzmh_ptmass(4,compi) - do l=s_id,e_id - if (k == l) cycle - j = group_info(igarg,l) - if (j == compi) cycle - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - r2 = dx**2+dy**2+dz**2 - ddr = 1./sqrt(r2) - ddr3 = ddr*ddr*ddr - mj = xyzmh_ptmass(4,j) - pouti = pouti +mj*ddr3 - enddo + if (compi == i) then + bin_info(ikap,i) = 1. + else + if (any(binstack == i)) cycle + n = n+1 ! level of the stack + binstack(n) = compi + pouti = bin_info(ipert,i) + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + m1 = xyzmh_ptmass(4,i) + m2 = xyzmh_ptmass(4,compi) + do l=s_id,e_id + if (k == l) cycle + j = group_info(igarg,l) + if (j == compi) cycle + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + r2 = dx**2+dy**2+dz**2 + ddr = 1./sqrt(r2) + ddr3 = ddr*ddr*ddr + mj = xyzmh_ptmass(4,j) + pouti = pouti + mj*ddr3 + enddo - mu = (m1*m2)/(m1+m2) - rapo = bin_info(iapo,i) - rapo3 = rapo*rapo*rapo - kappai = kref/((rapo3/mu)*pouti) + mu = (m1*m2)/(m1+m2) + rapo = bin_info(iapo,i) + rapo3 = rapo*rapo*rapo + kappa = kref/((rapo3/mu)*pouti) + !print*,pouti,kappa,rapo,bin_info(isemi,i),bin_info(iecc,i),i - if (kappai>1.) then - bin_info(ikap,i) = kappai - bin_info(ikap,compi) = kappai - else - bin_info(ikap,i) = 1. - bin_info(ikap,compi) = 1. + if (kappa>1.) then + bin_info(ikap,i) = kappa + bin_info(ikap,compi) = kappa + else + bin_info(ikap,i) = 1. + bin_info(ikap,compi) = 1. + endif endif enddo @@ -1097,7 +1113,7 @@ subroutine get_kappa_bin(xyzmh_ptmass,bin_info,i,j) rapo = bin_info(iapo,i) rapo3 = rapo*rapo*rapo kappa = kref/((rapo3/mu)*pert) - print*,xyzmh_ptmass(2,i),pert,kappa,rapo,bin_info(isemi,i),bin_info(iecc,i) + !print*,xyzmh_ptmass(2,i),pert,kappa,rapo,bin_info(isemi,i),bin_info(iecc,i) if (kappa > 1.) then bin_info(ikap,i) = kappa bin_info(ikap,j) = kappa From 0be5fa451a7316b0b2df58db2b7c304b21ba5187 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 30 Jul 2024 13:25:01 +0200 Subject: [PATCH 741/814] (subgroup) take into account the gas pertubation in kappa calculation --- build/Makefile | 2 +- src/main/initial.F90 | 14 +++++++++++--- src/main/ptmass.F90 | 18 +++++++++++++++--- src/main/subgroup.f90 | 26 +++++++++++++++++++++++++- src/main/substepping.F90 | 31 +++++++++++++++++++++++-------- src/setup/setup_starcluster.f90 | 4 ++-- 6 files changed, 77 insertions(+), 18 deletions(-) diff --git a/build/Makefile b/build/Makefile index fce6720a7..c36bb1f89 100644 --- a/build/Makefile +++ b/build/Makefile @@ -535,7 +535,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} ${SRCINJECT} \ - H2regions.f90 utils_subgroup.f90 utils_kepler.f90 subgroup.f90 \ + H2regions.f90 subgroup.f90 \ quitdump.f90 ptmass.F90\ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ diff --git a/src/main/initial.F90 b/src/main/initial.F90 index b774c8f32..c8511dc91 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -212,7 +212,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use fileutils, only:make_tags_unique use damping, only:idamp - use subgroup, only:group_identify,init_subgroup + use subgroup, only:group_identify,init_subgroup,init_kappa use HIIRegion, only:iH2R,initialize_H2R,update_ionrates character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile @@ -512,6 +512,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) 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) @@ -528,8 +529,14 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) if (ntypes > 1 .and. maxphase==maxp) then pmassi = massoftype(iamtype(iphase(i))) 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) + 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 dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) endif enddo @@ -544,6 +551,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) ! Reduce dt over MPI tasks dtsinkgas = reduceall_mpi('min',dtsinkgas) dtextforce = reduceall_mpi('min',dtextforce) + if (use_regnbody) call init_kappa(xyzmh_ptmass,bin_info,group_info,n_group) endif call init_ptmass(nptmass,logfile) if (gravity .and. icreate_sinks > 0 .and. id==master) then diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 46e827737..bca4c8178 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -151,19 +151,21 @@ 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) + dtphi2,extrapfac,fsink_old,bin_info) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec use extern_geopot, only:get_geopot_force + use part, only:ipert integer, intent(in) :: nptmass real, intent(in) :: xi,yi,zi,hi real, intent(inout) :: 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 :: ftmpxi,ftmpyi,ftmpzi @@ -171,7 +173,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft real :: fxj,fyj,fzj,dsx,dsy,dsz,fac,r integer :: j - logical :: tofrom,extrap + logical :: tofrom,extrap,kappa ! ! Determine if acceleration is from/to gas, or to gas ! @@ -189,6 +191,12 @@ 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 @@ -295,6 +303,10 @@ 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 + ! add perturbation for + bin_info(ipert,j) = bin_info(ipert,j) + f2 + endif endif enddo ! @@ -345,7 +357,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real, intent(out) :: dsdt_ptmass(3,nptmass) real, optional, intent(in) :: extrapfac real, optional, intent(in) :: fsink_old(4,nptmass) - real, optional, intent(out) :: bin_info(5,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 diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 77322c272..c85c80cad 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -24,6 +24,7 @@ module subgroup public :: evolve_groups public :: get_pot_subsys public :: init_subgroup + public :: init_kappa ! !-- parameters for group identification ! @@ -1113,7 +1114,7 @@ subroutine get_kappa_bin(xyzmh_ptmass,bin_info,i,j) rapo = bin_info(iapo,i) rapo3 = rapo*rapo*rapo kappa = kref/((rapo3/mu)*pert) - !print*,xyzmh_ptmass(2,i),pert,kappa,rapo,bin_info(isemi,i),bin_info(iecc,i) + print*,xyzmh_ptmass(2,i),pert,kappa,rapo,bin_info(isemi,i),bin_info(iecc,i) if (kappa > 1.) then bin_info(ikap,i) = kappa bin_info(ikap,j) = kappa @@ -1125,6 +1126,29 @@ subroutine get_kappa_bin(xyzmh_ptmass,bin_info,i,j) end subroutine get_kappa_bin +subroutine init_kappa(xyzmh_ptmass,bin_info,group_info,n_group) + use part, only:igcum,igarg + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(inout) :: bin_info(:,:) + integer, intent(in) :: group_info(:,:) + integer, intent(in) :: n_group + integer :: i,start_id,end_id,prim,sec,gsize + + do i=1,n_group + start_id = group_info(igcum,i) + 1 + end_id = group_info(igcum,i+1) + gsize = (end_id - start_id) + 1 + if (gsize>2) then + call update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,start_id,end_id) + else + prim = group_info(igarg,start_id) + sec = group_info(igarg,end_id) + call get_kappa_bin(xyzmh_ptmass,bin_info,prim,sec) + endif + enddo +end subroutine init_kappa + + subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) use part, only: igarg,igcum,ikap use io, only: id,master diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index eec7793a2..8104329a6 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -975,7 +975,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! !$omp parallel default(none) & - !$omp shared(maxp,maxphase) & + !$omp shared(maxp,maxphase,wsub,bin_info) & !$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) & @@ -1008,15 +1008,30 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, zi = xyzh(3,i) endif if (nptmass > 0) then - if (extrap) then - call get_accel_sink_gas(nptmass,xi,yi,zi,xyzh(4,i),xyzmh_ptmass,& + if(wsub) then + 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) + 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 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) + 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 endif endif diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index 6c1657254..970ea2b96 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -83,8 +83,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, tmax = 0.001 use_fourthorder = .true. use_regnbody = .true. - m_gas = 1.e-4 - ntot = 0 + m_gas = 1.e-3 + ntot = 2**20 ! ! read setup parameters from the .setup file ! if file does not exist, then ask for user input From 33e77f0c3d7cb5da68c656cd880a67c0926b8d61 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 30 Jul 2024 13:40:06 +0200 Subject: [PATCH 742/814] (subgroup)wrong print... --- src/main/subgroup.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index c85c80cad..00064f34b 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -1114,7 +1114,7 @@ subroutine get_kappa_bin(xyzmh_ptmass,bin_info,i,j) rapo = bin_info(iapo,i) rapo3 = rapo*rapo*rapo kappa = kref/((rapo3/mu)*pert) - print*,xyzmh_ptmass(2,i),pert,kappa,rapo,bin_info(isemi,i),bin_info(iecc,i) + !print*,xyzmh_ptmass(2,i),pert,kappa,rapo,bin_info(isemi,i),bin_info(iecc,i) if (kappa > 1.) then bin_info(ikap,i) = kappa bin_info(ikap,j) = kappa From 0a42f84b8cfa533e37d73ae8d67ea64ee6731905 Mon Sep 17 00:00:00 2001 From: Madeline Overton Date: Tue, 30 Jul 2024 11:01:30 -0700 Subject: [PATCH 743/814] Unnecessary Setup 'randomwind' is removed --- build/Makefile_setups | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/build/Makefile_setups b/build/Makefile_setups index 8578aa771..faee3ef76 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -165,18 +165,6 @@ ifeq ($(SETUP), disc) IND_TIMESTEPS=yes endif -ifeq ($(SETUP), randomwind) -# one component of binary emitting a wind - DISC_VISCOSITY=yes - SETUPFILE=setup_disc.f90 - ANALYSIS= analysis_disc.f90 - SRCINJECT=utils_binary.f90 inject_randomwind.f90 - ISOTHERMAL=yes - KNOWN_SETUP=yes - MULTIRUNFILE= multirun.f90 - IND_TIMESTEPS=yes -endif - ifeq ($(SETUP), grtde) # tidal disruption event in general relativity SETUPFILE= setup_grtde.f90 From 6895b7fb9154e42458a65db9271e1f931ef99028 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 09:39:07 +1000 Subject: [PATCH 744/814] (solarsystem) build failure on gfortran v14 fixed; allow sampling of minor body orbits --- src/setup/setup_solarsystem.f90 | 40 ++++++++++++++++++++++----------- src/utils/utils_ephemeris.f90 | 2 +- 2 files changed, 28 insertions(+), 14 deletions(-) diff --git a/src/setup/setup_solarsystem.f90 b/src/setup/setup_solarsystem.f90 index 5b06d37af..4dcb7a861 100644 --- a/src/setup/setup_solarsystem.f90 +++ b/src/setup/setup_solarsystem.f90 @@ -55,7 +55,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, character(len=20), intent(in) :: fileprefix real, intent(out) :: vxyzu(:,:) character(len=120) :: filename - integer :: ierr,nbodies,i + integer :: ierr,nbodies,i,j,n,nsample logical :: iexist real :: period,semia,mtot,hpart integer, parameter :: max_bodies = 2000000 @@ -100,7 +100,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, semia = 1. ! Earth mtot = solarm/umass - hpart = 100.*au/udist + hpart = 10.*au/udist period = 2.*pi*sqrt(semia**3/mtot) tmax = norbits*period @@ -110,23 +110,36 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call read_mpc(filename,nbodies,dat=dat) print "(a,i0,a)",' read orbital data for ',nbodies,' minor planets' + n = 0 + nsample = 1 ! can place many particles evenly sampling the orbit if desired do i=1,nbodies ! ! for each solar system object get the xyz positions from the orbital parameters ! !print*,i,'aeiOwM=',dat(i)%a,dat(i)%ecc,dat(i)%inc,dat(i)%O,dat(i)%w,dat(i)%M - call set_binary(mtot,epsilon(0.),dat(i)%a,dat(i)%ecc,0.02,1.e-15,& + do j=1,nsample + n = n + 1 + if (nsample==1) then + call set_binary(mtot,epsilon(0.),dat(i)%a,dat(i)%ecc,0.02,1.e-15,& xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,incl=dat(i)%inc,& arg_peri=dat(i)%w,posang_ascnode=dat(i)%O,& mean_anomaly=dat(i)%M,verbose=.false.) - ! - ! now delete the point masses but set a dust particle as the secondary - ! - nptmass = 0 - xyzh(1:3,i) = xyzmh_ptmass(1:3,2) - xyzh(4,i) = hpart ! give a random length scale as the smoothing length - vxyzu(1:3,i) = vxyz_ptmass(1:3,2) - call set_particle_type(i,idust) + else + call set_binary(mtot,epsilon(0.),dat(i)%a,dat(i)%ecc,0.02,1.e-15,& + xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,incl=dat(i)%inc,& + arg_peri=dat(i)%w,posang_ascnode=dat(i)%O,& + f=360.*(n-1)/nsample,verbose=.false.) + endif + ! + ! now delete the point masses but set a dust particle as the secondary + ! + nptmass = 0 + xyzh(1:3,n) = xyzmh_ptmass(1:3,2) + xyzh(4,n) = hpart ! give a random length scale as the smoothing length + vxyzu(1:3,n) = vxyz_ptmass(1:3,2) + call set_particle_type(n,idust) + enddo + enddo ! ! restore the Sun @@ -135,10 +148,11 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! set mass of all the minor bodies equal ! - npart = nbodies + npart = nbodies*nsample + print*,' n = ',n,' npart = ',npart ndustlarge = 1 ndusttypes = 1 - npartoftype(idust) = nbodies + npartoftype(idust) = nbodies*nsample massoftype(idust) = 1.e-20 grainsize(1:ndustlarge) = km/udist ! assume km-sized bodies graindens(1:ndustlarge) = 2./unit_density ! 2 g/cm^3 diff --git a/src/utils/utils_ephemeris.f90 b/src/utils/utils_ephemeris.f90 index c6d0a689c..91ad77224 100644 --- a/src/utils/utils_ephemeris.f90 +++ b/src/utils/utils_ephemeris.f90 @@ -71,7 +71,7 @@ subroutine construct_horizons_api_url(object,url,ierr) integer, intent(out) :: ierr character(len=3) :: cmd character(len=10) :: start_epoch,end_epoch - integer(kind=8) :: values(8),year,month,day + integer :: values(8),year,month,day ierr = 0 select case(trim(adjustl(object))) From 7df0b70137435610b94ca0be4fd748f26c00c010 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 09:59:21 +1000 Subject: [PATCH 745/814] (metric_et) remove dependency on eos_shen --- src/main/metric_et.f90 | 121 ++++++++++++++++++++------------------ src/main/utils_tables.f90 | 18 +++++- 2 files changed, 81 insertions(+), 58 deletions(-) diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index 97dceb66d..a4a50b22c 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -6,7 +6,7 @@ !--------------------------------------------------------------------------! module metric ! -! None +! Generic module for a tabulated metric, e.g. from the Einstein Toolkit ! ! :References: None ! @@ -14,7 +14,7 @@ module metric ! ! :Runtime parameters: None ! -! :Dependencies: einsteintk_utils, eos_shen, infile_utils +! :Dependencies: einsteintk_utils, infile_utils, table_utils ! implicit none character(len=*), parameter :: metric_type = 'et' @@ -28,7 +28,8 @@ module metric !---------------------------------------------------------------- !+ ! Compute the metric tensor in both covariant (gcov) and -! contravariant (gcon) form +! contravariant (gcon) form. Here we merely interpolate +! these values from the global grid. !+ !---------------------------------------------------------------- pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) @@ -41,8 +42,7 @@ pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) ! The subroutine that computes the metric tensor for a given position ! In this case it is interpolated from the global grid values - - ! Perform trilenar interpolation + ! Perform trilinear interpolation if ( .not. gridinit) then ierr = 1 ! This is required for phantomsetup @@ -68,8 +68,14 @@ pure subroutine get_metric_cartesian(position,gcov,gcon,sqrtg) else call interpolate_metric(position,gcov) endif + end subroutine get_metric_cartesian +!----------------------------------------------------------------------- +!+ +! dummy routine to get the metric in spherical coordinates (not used) +!+ +!----------------------------------------------------------------------- pure subroutine get_metric_spherical(position,gcov,gcon,sqrtg) real, intent(in) :: position(3) real, intent(out) :: gcov(0:3,0:3) @@ -99,28 +105,39 @@ pure subroutine get_metric_spherical(position,gcov,gcon,sqrtg) end subroutine get_metric_spherical - +!----------------------------------------------------------------------- +!+ +! cartesian metric derivatives, interpolates the derivatives from +! the grid +!+ +!----------------------------------------------------------------------- pure subroutine metric_cartesian_derivatives(position,dgcovdx, dgcovdy, dgcovdz) - use metric_et_utils, only:gridinit -! use grid, only:read_tabulated_metric - real, intent(in) :: position(3) - real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3), dgcovdz(0:3,0:3) - integer :: ierr - if (.not. gridinit) then - ierr = 1 - if (ierr /= 0) then - dgcovdx = 0. - dgcovdy = 0. - dgcovdz = 0. - else - ! gridinit = .true. - call interpolate_metric_derivs(position,dgcovdx,dgcovdy,dgcovdz) - endif - else - call interpolate_metric_derivs(position,dgcovdx,dgcovdy,dgcovdz) - endif + use metric_et_utils, only:gridinit + real, intent(in) :: position(3) + real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3), dgcovdz(0:3,0:3) + integer :: ierr + + if (.not. gridinit) then + ierr = 1 + if (ierr /= 0) then + dgcovdx = 0. + dgcovdy = 0. + dgcovdz = 0. + else + ! gridinit = .true. + call interpolate_metric_derivs(position,dgcovdx,dgcovdy,dgcovdz) + endif + else + call interpolate_metric_derivs(position,dgcovdx,dgcovdy,dgcovdz) + endif + end subroutine metric_cartesian_derivatives +!----------------------------------------------------------------------- +!+ +! dummy routine for spherical metric derivatives, not used +!+ +!----------------------------------------------------------------------- pure subroutine metric_spherical_derivatives(position,dgcovdr, dgcovdtheta, dgcovdphi) real, intent(in) :: position(3) real, intent(out), dimension(0:3,0:3) :: dgcovdr,dgcovdtheta,dgcovdphi @@ -140,6 +157,11 @@ pure subroutine metric_spherical_derivatives(position,dgcovdr, dgcovdtheta, dgco end subroutine metric_spherical_derivatives +!----------------------------------------------------------------------- +!+ +! dummy routine to convert cartesian to spherical coordinates +!+ +!----------------------------------------------------------------------- pure subroutine cartesian2spherical(xcart,xspher) real, intent(in) :: xcart(3) real, intent(out) :: xspher(3) @@ -155,6 +177,7 @@ pure subroutine cartesian2spherical(xcart,xspher) phi = atan2(y,x) xspher = (/r,theta,phi/) + end subroutine cartesian2spherical !----------------------------------------------------------------------- @@ -163,7 +186,7 @@ end subroutine cartesian2spherical !+ !----------------------------------------------------------------------- subroutine write_options_metric(iunit) - use infile_utils, only:write_inopt + !use infile_utils, only:write_inopt integer, intent(in) :: iunit write(iunit,"(/,a)") '# There are no options relating to the '//trim(metric_type)//' metric' @@ -180,12 +203,12 @@ subroutine read_options_metric(name,valstring,imatch,igotall,ierr) character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr - integer, save :: ngot = 0 + !integer, save :: ngot = 0 select case(trim(name)) - !case('metric_file') - ! read(valstring,*,iostat=ierr) metric_file - ! ngot = ngot + 1 + !case('metric_file') + ! read(valstring,*,iostat=ierr) metric_file + ! ngot = ngot + 1 case default imatch = .false. end select @@ -199,11 +222,10 @@ end subroutine read_options_metric ! Interpolates value from grid to position !+ !----------------------------------------------------------------------- - pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) ! linear and cubic interpolators should be moved to their own subroutine ! away from eos_shen - use eos_shen, only:linear_interpolator_one_d + use table_utils, only:linear_interpolator_one_d use metric_et_utils, only:gcovgrid,gcongrid,sqrtggrid,dxgrid,gridorigin!,gridsize real, intent(in) :: position(3) real, intent(out) :: gcov(0:3,0:3) @@ -219,19 +241,9 @@ pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) ! from ET during phantomsetup ! Then simply set gcov and gcon to 0 ! as these values will be overwritten during the run anyway - !print*, "Calling interp metric!" ! Get neighbours call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) - !print*,"Neighbours: ", xlower,ylower,zlower - ! This is not true as upper neighbours on the boundary will be on the side - ! take a mod of grid size -! xupper = mod(xlower + 1, gridsize(1)) -! yupper = mod(ylower + 1, gridsize(2)) -! zupper = mod(zlower + 1, gridsize(3)) - ! xupper - xlower should always just be dx provided we are using a uniform grid - ! xd = (position(1) - xlower)/(xupper - xlower) - ! yd = (position(2) - ylower)/(yupper - ylower) - ! zd = (position(3) - zlower)/(zupper - zlower) + xlowerpos = gridorigin(1) + (xlower-1)*dxgrid(1) ylowerpos = gridorigin(2) + (ylower-1)*dxgrid(2) zlowerpos = gridorigin(3) + (zlower-1)*dxgrid(3) @@ -308,11 +320,15 @@ pure subroutine interpolate_metric(position,gcov,gcon,sqrtg) sqrtg = interptmp(7) endif - end subroutine interpolate_metric +!----------------------------------------------------------------------- +!+ +! Interpolates derivatives of the metric from the grid to the position +!+ +!----------------------------------------------------------------------- pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) - use eos_shen, only:linear_interpolator_one_d + use table_utils, only:linear_interpolator_one_d use metric_et_utils, only:metricderivsgrid, dxgrid,gridorigin real, intent(out) :: dgcovdx(0:3,0:3), dgcovdy(0:3,0:3),dgcovdz(0:3,0:3) real, intent(in) :: position(3) @@ -322,13 +338,6 @@ pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) integer :: i,j call get_grid_neighbours(position, dxgrid, xlower, ylower, zlower) - !print*,"Neighbours: ", xlower,ylower,zlower -! xupper = xlower + 1 -! yupper = yupper + 1 -! zupper = zupper + 1 - ! xd = (position(1) - xlower)/(xupper - xlower) - ! yd = (position(2) - ylower)/(yupper - ylower) - ! zd = (position(3) - zlower)/(zupper - zlower) xlowerpos = gridorigin(1) + (xlower-1)*dxgrid(1) ylowerpos = gridorigin(2) + (ylower-1)*dxgrid(2) @@ -405,11 +414,13 @@ pure subroutine interpolate_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) enddo enddo - - - end subroutine interpolate_metric_derivs +!----------------------------------------------------------------------- +!+ +! Utility routine to get the lower grid neighbours of a position +!+ +!----------------------------------------------------------------------- pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) use metric_et_utils, only:gridorigin real, intent(in) :: position(3) @@ -431,9 +442,7 @@ pure subroutine get_grid_neighbours(position,dx,xlower,ylower,zlower) ylower = ylower + 1 zlower = zlower + 1 - end subroutine get_grid_neighbours - end module metric diff --git a/src/main/utils_tables.f90 b/src/main/utils_tables.f90 index 47320b69c..747b7663e 100644 --- a/src/main/utils_tables.f90 +++ b/src/main/utils_tables.f90 @@ -19,7 +19,7 @@ module table_utils implicit none public :: yinterp, linspace, logspace, diff, flip_array, interpolator - public :: find_nearest_index, interp_1d + public :: find_nearest_index, interp_1d, linear_interpolator_one_d private @@ -201,11 +201,25 @@ end subroutine find_nearest_index ! 1D linear interpolation routine !+ !----------------------------------------------------------------------- -real function interp_1d(x,x1,x2,y1,y2) +pure real function interp_1d(x,x1,x2,y1,y2) real, intent(in) :: x, x1, x2, y1, y2 interp_1d = y1 + (x-x1)*(y2-y1)/(x2-x1) end function interp_1d +!----------------------------------------------------------------------- +!+ +! similar but just interpolates between two values +! val0 and val1 where u is the fraction of the way +!+ +!----------------------------------------------------------------------- +pure subroutine linear_interpolator_one_d(val0,val1,u,val) + real, intent(out) :: val + real, intent(in) :: val0,val1,u + + val=(1.-u)*val0+u*val1 + +end subroutine linear_interpolator_one_d + end module table_utils From 3122cbd3fe8d7f3e627dd23b1bb060bd0a9ef99f Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 10:12:42 +1000 Subject: [PATCH 746/814] (randomwind) fixed warnings --- src/main/inject_randomwind.f90 | 2 +- src/main/random.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index 22dfe316a..3e9d7edc8 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -68,7 +68,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& use partinject, only:add_or_update_particle use physcon, only:twopi,gg,kboltz,mass_proton_cgs use random, only:get_random_pos_on_sphere, get_gaussian_pos_on_sphere - use units, only:umass, utime, in_code_units + use units, only:in_code_units use options, only:iexternalforce use externalforces,only:mass1 use binaryutils, only:get_orbit_bits diff --git a/src/main/random.f90 b/src/main/random.f90 index 058f29842..e4adeaba0 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -20,7 +20,7 @@ module random implicit none public :: ran2,get_random,rayleigh_deviate public :: get_random_pos_on_sphere,get_gaussian_pos_on_sphere - public :: gauss_random,divide_unit_seq + public :: gauss_random,divide_unit_seg real, parameter :: pi = 4.*atan(1.) private From c9e1e4e9f33e4d84751010f82c03b0d7a284003f Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 10:14:53 +1000 Subject: [PATCH 747/814] (randomwind) test failure fixed --- src/main/inject_randomwind.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index 3e9d7edc8..96bc565f3 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -86,7 +86,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& real, save :: have_injected,t_old real, save :: semia - if (nptmass < 2 .and. iexternalforce == 0) & + if (nptmass < 1 .and. iexternalforce == 0) & call fatal('inject_randomwind','not enough point masses for random wind injection') if (nptmass > 2) & call fatal('inject_randomwind','too many point masses for random wind injection') From 61838a3e7ff17649cc3c8698526e93a9ac7d6462 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 10:18:07 +1000 Subject: [PATCH 748/814] [header-bot] updated file headers --- src/main/H2regions.f90 | 3 --- src/main/initial.F90 | 10 +++++----- src/main/inject_randomwind.f90 | 11 +++++------ src/main/metric_et.f90 | 2 +- src/main/metric_et_utils.f90 | 17 +++++++++++++++++ src/main/readwrite_dumps_common.f90 | 2 +- src/main/readwrite_dumps_fortran.f90 | 2 +- src/setup/set_orbit.f90 | 15 +++++++++++++++ src/setup/setup_asteroidwind.f90 | 3 +-- src/setup/setup_cluster.f90 | 1 + src/utils/einsteintk_utils.f90 | 2 +- src/utils/tabulate_metric.f90 | 17 +++++++++++++++++ 12 files changed, 65 insertions(+), 20 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 8d81b4a12..5ca0ad90d 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -17,9 +17,6 @@ module HIIRegion ! :Dependencies: dim, eos, infile_utils, io, linklist, part, physcon, ! sortutils, timing, units ! -! contains routines to model HII region expansion due to ionization and radiation pressure.. -! routine originally made by Hopkins et al. (2012),reused by Fujii et al. (2021) -! and adapted in Phantom by Yann Bernard implicit none diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 626f4e9a1..c1f0b6842 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -19,11 +19,11 @@ module initial ! 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_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 +! 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/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index 96bc565f3..f2f8648e8 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -15,12 +15,11 @@ module inject ! :Owner: David Liptai ! ! :Runtime parameters: -! - mdot_str : *mdot with unit* -! - mdot : *mass injection rate in grams/second* -! - mdot_type : *injection rate (0=const, 1=cos(t), 2=r^(-2))* -! - vlag : *percentage lag in velocity of wind* -! - random_type : random position on the surface, 0 for random, 1 for gaussian -! - delta_theta : standard deviation for the gaussion distribution (random_type=1) +! - delta_theta : *standard deviation for the gaussion distribution (random_type=1)* +! - mdot : *mass injection rate with unit, e.g. 1e8*g/s, 1e-7M_s/yr* +! - mdot_type : *injection rate (0=const, 1=cos(t), 2=r^(-2))* +! - random_type : *random position on the surface, 0 for random, 1 for gaussian* +! - vlag : *percentage lag in velocity of wind* ! ! :Dependencies: binaryutils, externalforces, infile_utils, io, options, ! part, partinject, physcon, random, units diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index a4a50b22c..a4c757a73 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -14,7 +14,7 @@ module metric ! ! :Runtime parameters: None ! -! :Dependencies: einsteintk_utils, infile_utils, table_utils +! :Dependencies: metric_et_utils, table_utils ! implicit none character(len=*), parameter :: metric_type = 'et' diff --git a/src/main/metric_et_utils.f90 b/src/main/metric_et_utils.f90 index 2a8a89493..d48ec5930 100644 --- a/src/main/metric_et_utils.f90 +++ b/src/main/metric_et_utils.f90 @@ -1,4 +1,21 @@ +!--------------------------------------------------------------------------! +! 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 metric_et_utils +! +! metric_et_utils +! +! :References: None +! +! :Owner: DavidBamba +! +! :Runtime parameters: None +! +! :Dependencies: None +! implicit none real, allocatable :: gcovgrid(:,:,:,:,:) diff --git a/src/main/readwrite_dumps_common.f90 b/src/main/readwrite_dumps_common.f90 index c3059a51f..f67ae3c05 100644 --- a/src/main/readwrite_dumps_common.f90 +++ b/src/main/readwrite_dumps_common.f90 @@ -16,7 +16,7 @@ module readwrite_dumps_common ! ! :Dependencies: boundary, boundary_dyn, checkconserved, dim, dump_utils, ! dust, dust_formation, eos, externalforces, fileutils, gitinfo, io, -! options, part, ptmass, setup_params, sphNGutils, timestep, units +! options, part, setup_params, sphNGutils, timestep, units ! use dump_utils, only:lenid implicit none diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 40015c958..429c6ff32 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -19,7 +19,7 @@ module readwrite_dumps_fortran ! :Runtime parameters: None ! ! :Dependencies: boundary_dyn, dim, dump_utils, eos, io, memory, -! metric_tools, mpiutils, options, part, ptmass, readwrite_dumps_common, +! metric_tools, mpiutils, options, part, readwrite_dumps_common, ! sphNGutils, timestep ! use dump_utils, only:lenid,ndatatypes,i_int,i_int1,i_int2,i_int4,i_int8,& diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index 38f3348b3..9b05809b5 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -14,6 +14,21 @@ module setorbit ! 1) Flyby parameters (periapsis, initial separation, argument of periapsis, inclination) ! 2) position and velocity for both bodies +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils, physcon, setbinary, setflyby, units +! + ! While Campbell elements can be used for unbound orbits, they require ! specifying the true anomaly at the start of the simulation. This is ! not always easy to determine, so the flyby option is provided as an diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index 0a2af47e0..289b8329d 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -22,8 +22,7 @@ module setup ! - ipot : *wd modelled by 0=sink or 1=externalforce* ! - m1 : *mass of white dwarf (solar mass)* ! - m2 : *mass of asteroid (ceres mass)* -! - mdot : *mass injection rate -! - mdot_str : *mdot with unit* +! - mdot : *mass injection rate with unit, e.g. 1e8*g/s, 1e-7M_s/yr (from setup)* ! - norbits : *number of orbits* ! - npart_at_end : *number of particles injected after norbits* ! - rasteroid : *radius of asteroid (km)* diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index c1d1ae01a..157414cfa 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -22,6 +22,7 @@ module setup ! - mass_fac : *mass unit in Msun* ! - mu : *mean molecular mass* ! - n_particles : *number of particles in sphere* +! - relax : *relax the cloud ?* ! ! :Dependencies: HIIRegion, centreofmass, cooling, datafiles, dim, eos, ! infile_utils, io, kernel, mpidomain, options, part, physcon, prompting, diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index c3fe29ae7..45f56c13c 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -14,7 +14,7 @@ module einsteintk_utils ! ! :Runtime parameters: None ! -! :Dependencies: part +! :Dependencies: metric_et_utils, part ! use metric_et_utils, only:gridorigin,dxgrid,gridsize implicit none diff --git a/src/utils/tabulate_metric.f90 b/src/utils/tabulate_metric.f90 index 1e8232a6c..5d6a37869 100644 --- a/src/utils/tabulate_metric.f90 +++ b/src/utils/tabulate_metric.f90 @@ -1,4 +1,21 @@ +!--------------------------------------------------------------------------! +! 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/ ! +!--------------------------------------------------------------------------! program tabulate_metric +! +! tabulate_metric +! +! :References: None +! +! :Owner: DavidBamba +! +! :Usage: tabulate_metric [no arguments] +! +! :Dependencies: metric, metric_et_utils +! use metric_et_utils !use metric From d5a13a042b98faab79a77f2be419e2c1577e9fb0 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 10:18:23 +1000 Subject: [PATCH 749/814] [space-bot] whitespace at end of lines removed --- src/main/metric_et_utils.f90 | 18 +++++++++--------- src/utils/einsteintk_utils.f90 | 4 ++-- src/utils/tabulate_metric.f90 | 6 +++--- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/main/metric_et_utils.f90 b/src/main/metric_et_utils.f90 index d48ec5930..60eca7854 100644 --- a/src/main/metric_et_utils.f90 +++ b/src/main/metric_et_utils.f90 @@ -32,9 +32,9 @@ module metric_et_utils real, parameter :: ymin = -10.0, ymax = 10.0 real, parameter :: zmin = -10.0, zmax = 10.0 real, parameter :: mass = 1.0 ! Mass of the central object - + contains - + subroutine allocate_grid(nxin,nyin,nzin,dx,dy,dz,originx,originy,originz) integer, intent(in) :: nxin,nyin,nzin real, intent(in) :: dx,dy,dz,originx,originy,originz @@ -45,11 +45,11 @@ subroutine allocate_grid(nxin,nyin,nzin,dx,dy,dz,originx,originy,originz) gridsize(1) = nx gridsize(2) = ny gridsize(3) = nz - + dxgrid(1) = dx dxgrid(2) = dy dxgrid(3) = dz - + gridorigin(1) = originx gridorigin(2) = originy gridorigin(3) = originz @@ -57,14 +57,14 @@ subroutine allocate_grid(nxin,nyin,nzin,dx,dy,dz,originx,originy,originz) allocate(gcovgrid(0:3,0:3,nx,ny,nz)) allocate(gcongrid(0:3,0:3,nx,ny,nz)) allocate(sqrtggrid(nx,ny,nz)) - + !metric derivs are stored in the form ! mu comp, nu comp, deriv, gridx,gridy,gridz ! Note that this is only the spatial derivs of ! the metric and we will need an additional array ! for time derivs allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) - + end subroutine allocate_grid subroutine initialize_grid() @@ -89,11 +89,11 @@ end subroutine initialize_grid subroutine print_metric_grid() ! Subroutine for printing quantities of the ET grid - + print*, "Grid spacing (x,y,z) is : ", dxgrid print*, "Grid origin (x,y,z) is: ", gridorigin print*, "Covariant metric tensor of the grid is: ", gcovgrid(:,:,1,1,1) - + end subroutine print_metric_grid subroutine write_tabulated_metric(metric_file, ierr) @@ -130,7 +130,7 @@ subroutine read_tabulated_metric(metric_file, ierr) character(len=*), intent(in) :: metric_file integer, intent(out) :: ierr integer :: iunit - + ! Open the file for reading open(newunit=iunit, file=metric_file, status='old', form='unformatted', action='read', iostat=ierr) diff --git a/src/utils/einsteintk_utils.f90 b/src/utils/einsteintk_utils.f90 index 45f56c13c..3268df976 100644 --- a/src/utils/einsteintk_utils.f90 +++ b/src/utils/einsteintk_utils.f90 @@ -58,9 +58,9 @@ end subroutine init_etgrid subroutine print_etgrid() use metric_et_utils, only:print_metric_grid - + call print_metric_grid() - + end subroutine print_etgrid subroutine get_particle_rhs(i,vx,vy,vz,fx,fy,fz,e_rhs) diff --git a/src/utils/tabulate_metric.f90 b/src/utils/tabulate_metric.f90 index 5d6a37869..a2ddf0537 100644 --- a/src/utils/tabulate_metric.f90 +++ b/src/utils/tabulate_metric.f90 @@ -20,14 +20,14 @@ program tabulate_metric !use metric implicit none - - integer :: ierr + + integer :: ierr character(len=64) :: metric_file = 'tabuled_metric.dat' ! Init grid and tabulated metric call initialize_grid() - + ! Fill and interpolate metric in the grid call fill_grid() From c294323bd70184eb315a0c75b58c6671b5cf3226 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 10:18:23 +1000 Subject: [PATCH 750/814] [author-bot] updated AUTHORS file --- AUTHORS | 34 +++++++++++++++++++--------------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/AUTHORS b/AUTHORS index 649e5eb20..b4d2b8428 100644 --- a/AUTHORS +++ b/AUTHORS @@ -26,50 +26,54 @@ Terrence Tricco Stephane Michoulier Simone Ceppi Spencer Magnall -Caitlyn Hardiman Enrico Ragusa +Caitlyn Hardiman Cristiano Longarini Sergei Biriukov Giovanni Dipierro Roberto Iaconi -Amena Faruqi Hauke Worpel +Amena Faruqi Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi -Sahl Rowther Simon Glover +Sahl Rowther Thomas Reichardt Jean-François Gonzalez Christopher Russell Alessia Franchini Alex Pettitt Jolien Malfait +Madeline Overton Phantom benchmark bot -Kieran Hirsh Mike Lau +Kieran Hirsh Nicole Rodrigues +Nicolás Cuello David Trevascus Farzana Meru -Nicolás Cuello Chris Nixon Miguel Gonzalez-Bolivar -Benoit Commercon -Giulia Ballabio -Joe Fisher Maxime Lombart Orsola De Marco -Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> -Ariel Chitan -Chunliang Mu -Cox, Samuel -Hugh Griffiths -Jeremy Smallwood +Joe Fisher +Giulia Ballabio +Benoit Commercon +Zachary Pellow +Madeline Overton <85810161+moverton000@users.noreply.github.com> +DavidBamba Jorge Cuadra -MICHOULIER Stephane +Cox, Samuel Steven Rieder Stéven Toupin Taj Jankovič +Chunliang Mu +MICHOULIER Stephane rebeccagmartin <74937128+rebeccagmartin@users.noreply.github.com> +Ariel Chitan +Hugh Griffiths +Shunquan Huang +Jeremy Smallwood From 0b8ea0931be320c41749892d1a062637735108b5 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 10:18:43 +1000 Subject: [PATCH 751/814] [format-bot] end if -> endif; end do -> enddo; if( -> if ( --- src/main/evolve.F90 | 2 +- src/main/metric_et_utils.f90 | 4 ++-- src/main/random.f90 | 2 +- src/utils/tabulate_metric.f90 | 6 +++--- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index a5bf47b1d..c7f63d6b1 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -306,7 +306,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (iH2R > 0 .and. id==master) then istepHII = 1 - if(ind_timesteps) then + if (ind_timesteps) then istepHII = 2**nbinmax/HIIuprate if (istepHII==0) istepHII = 1 endif diff --git a/src/main/metric_et_utils.f90 b/src/main/metric_et_utils.f90 index 60eca7854..05d5b75e5 100644 --- a/src/main/metric_et_utils.f90 +++ b/src/main/metric_et_utils.f90 @@ -102,7 +102,7 @@ subroutine write_tabulated_metric(metric_file, ierr) integer :: iunit ! Open the file for writing - open(newunit=iunit, file=metric_file, status='replace', form='unformatted',action='write', iostat=ierr) + open(newunit=iunit,file=metric_file,status='replace',form='unformatted',action='write',iostat=ierr) if (ierr /= 0) then ierr = 1 return @@ -133,7 +133,7 @@ subroutine read_tabulated_metric(metric_file, ierr) ! Open the file for reading - open(newunit=iunit, file=metric_file, status='old', form='unformatted', action='read', iostat=ierr) + open(newunit=iunit,file=metric_file,status='old', form='unformatted',action='read',iostat=ierr) if (ierr /= 0) return ! Read the dimensions of the grid diff --git a/src/main/random.f90 b/src/main/random.f90 index e4adeaba0..dd2ba97c1 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -165,7 +165,7 @@ function get_gaussian_pos_on_sphere(iseed, deltheta) result(dx) gauss_theta = gauss_random(iseed) * deltheta do while (abs(gauss_theta) > 1.0) gauss_theta = gauss_random(iseed) * deltheta - end do + enddo theta = acos(gauss_theta) sintheta = sin(theta) costheta = cos(theta) diff --git a/src/utils/tabulate_metric.f90 b/src/utils/tabulate_metric.f90 index a2ddf0537..7a73bcac3 100644 --- a/src/utils/tabulate_metric.f90 +++ b/src/utils/tabulate_metric.f90 @@ -75,9 +75,9 @@ subroutine fill_grid() metricderivsgrid(:,:,1,i,j,k) = dgcovdx metricderivsgrid(:,:,2,i,j,k) = dgcovdy metricderivsgrid(:,:,3,i,j,k) = dgcovdz - end do - end do - end do + enddo + enddo + enddo end subroutine fill_grid end program tabulate_metric From f4ffc6a238ec573eb07924e9b62dae3ea4826af9 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 10:19:04 +1000 Subject: [PATCH 752/814] [indent-bot] standardised indentation --- src/main/metric_et_utils.f90 | 268 +++++++++++++++++----------------- src/utils/struct_part.f90 | 8 +- src/utils/tabulate_metric.f90 | 100 ++++++------- 3 files changed, 188 insertions(+), 188 deletions(-) diff --git a/src/main/metric_et_utils.f90 b/src/main/metric_et_utils.f90 index 05d5b75e5..05b106208 100644 --- a/src/main/metric_et_utils.f90 +++ b/src/main/metric_et_utils.f90 @@ -16,152 +16,152 @@ module metric_et_utils ! ! :Dependencies: None ! - implicit none - - real, allocatable :: gcovgrid(:,:,:,:,:) - real, allocatable :: gcongrid(:,:,:,:,:) - real, allocatable :: sqrtggrid(:,:,:) - real, allocatable :: metricderivsgrid(:,:,:,:,:,:) - real :: dxgrid(3), gridorigin(3) - integer :: gridsize(3) - logical :: gridinit = .false. - - ! Declaration of grid limits and dimensions - integer, public :: nx,ny,nz - real, parameter :: xmin = -10.0, xmax = 10.0 - real, parameter :: ymin = -10.0, ymax = 10.0 - real, parameter :: zmin = -10.0, zmax = 10.0 - real, parameter :: mass = 1.0 ! Mass of the central object - - contains - - subroutine allocate_grid(nxin,nyin,nzin,dx,dy,dz,originx,originy,originz) - integer, intent(in) :: nxin,nyin,nzin - real, intent(in) :: dx,dy,dz,originx,originy,originz + implicit none + + real, allocatable :: gcovgrid(:,:,:,:,:) + real, allocatable :: gcongrid(:,:,:,:,:) + real, allocatable :: sqrtggrid(:,:,:) + real, allocatable :: metricderivsgrid(:,:,:,:,:,:) + real :: dxgrid(3), gridorigin(3) + integer :: gridsize(3) + logical :: gridinit = .false. + + ! Declaration of grid limits and dimensions + integer, public :: nx,ny,nz + real, parameter :: xmin = -10.0, xmax = 10.0 + real, parameter :: ymin = -10.0, ymax = 10.0 + real, parameter :: zmin = -10.0, zmax = 10.0 + real, parameter :: mass = 1.0 ! Mass of the central object + +contains + +subroutine allocate_grid(nxin,nyin,nzin,dx,dy,dz,originx,originy,originz) + integer, intent(in) :: nxin,nyin,nzin + real, intent(in) :: dx,dy,dz,originx,originy,originz - nx = nxin - ny = nyin - nz = nzin - gridsize(1) = nx - gridsize(2) = ny - gridsize(3) = nz - - dxgrid(1) = dx - dxgrid(2) = dy - dxgrid(3) = dz - - gridorigin(1) = originx - gridorigin(2) = originy - gridorigin(3) = originz - - allocate(gcovgrid(0:3,0:3,nx,ny,nz)) - allocate(gcongrid(0:3,0:3,nx,ny,nz)) - allocate(sqrtggrid(nx,ny,nz)) - - !metric derivs are stored in the form - ! mu comp, nu comp, deriv, gridx,gridy,gridz - ! Note that this is only the spatial derivs of - ! the metric and we will need an additional array - ! for time derivs - allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) - - end subroutine allocate_grid - - subroutine initialize_grid() - ! Local variable declarations - real :: dx, dy, dz, x0(3) - - nx = 100 - ny = 100 - nz = 100 - - ! Calculate the step size in each direction - dx = (xmax - xmin) / (nx - 1) - dy = (ymax - ymin) / (ny - 1) - dz = (zmax - zmin) / (nz - 1) - - x0 = [0.,0.,0.] - call allocate_grid(nx,ny,nz,dx,dy,dz,x0(1),x0(2),x0(3)) - - gridinit = .true. - - end subroutine initialize_grid - - subroutine print_metric_grid() - ! Subroutine for printing quantities of the ET grid - - print*, "Grid spacing (x,y,z) is : ", dxgrid - print*, "Grid origin (x,y,z) is: ", gridorigin - print*, "Covariant metric tensor of the grid is: ", gcovgrid(:,:,1,1,1) - - end subroutine print_metric_grid - - subroutine write_tabulated_metric(metric_file, ierr) - character(len=*), intent(in) :: metric_file - integer, intent(out) :: ierr - integer :: iunit - - ! Open the file for writing - open(newunit=iunit,file=metric_file,status='replace',form='unformatted',action='write',iostat=ierr) - if (ierr /= 0) then - ierr = 1 - return - endif - - ! Write the dimensions of the grid - write(iunit) gridsize - - ! Write the grid origin and spacing - write(iunit) gridorigin - write(iunit) dxgrid - - ! Write the metric values to the file - write(iunit) gcovgrid - write(iunit) gcongrid - write(iunit) sqrtggrid - write(iunit) metricderivsgrid - - ! Close the file - close(iunit) - ierr = 0 - end subroutine write_tabulated_metric + nx = nxin + ny = nyin + nz = nzin + gridsize(1) = nx + gridsize(2) = ny + gridsize(3) = nz + + dxgrid(1) = dx + dxgrid(2) = dy + dxgrid(3) = dz + + gridorigin(1) = originx + gridorigin(2) = originy + gridorigin(3) = originz + + allocate(gcovgrid(0:3,0:3,nx,ny,nz)) + allocate(gcongrid(0:3,0:3,nx,ny,nz)) + allocate(sqrtggrid(nx,ny,nz)) + + !metric derivs are stored in the form + ! mu comp, nu comp, deriv, gridx,gridy,gridz + ! Note that this is only the spatial derivs of + ! the metric and we will need an additional array + ! for time derivs + allocate(metricderivsgrid(0:3,0:3,3,nx,ny,nz)) + +end subroutine allocate_grid + +subroutine initialize_grid() + ! Local variable declarations + real :: dx, dy, dz, x0(3) + + nx = 100 + ny = 100 + nz = 100 + + ! Calculate the step size in each direction + dx = (xmax - xmin) / (nx - 1) + dy = (ymax - ymin) / (ny - 1) + dz = (zmax - zmin) / (nz - 1) + + x0 = [0.,0.,0.] + call allocate_grid(nx,ny,nz,dx,dy,dz,x0(1),x0(2),x0(3)) + + gridinit = .true. + +end subroutine initialize_grid + +subroutine print_metric_grid() + ! Subroutine for printing quantities of the ET grid + + print*, "Grid spacing (x,y,z) is : ", dxgrid + print*, "Grid origin (x,y,z) is: ", gridorigin + print*, "Covariant metric tensor of the grid is: ", gcovgrid(:,:,1,1,1) + +end subroutine print_metric_grid + +subroutine write_tabulated_metric(metric_file, ierr) + character(len=*), intent(in) :: metric_file + integer, intent(out) :: ierr + integer :: iunit + + ! Open the file for writing + open(newunit=iunit,file=metric_file,status='replace',form='unformatted',action='write',iostat=ierr) + if (ierr /= 0) then + ierr = 1 + return + endif + + ! Write the dimensions of the grid + write(iunit) gridsize + + ! Write the grid origin and spacing + write(iunit) gridorigin + write(iunit) dxgrid + + ! Write the metric values to the file + write(iunit) gcovgrid + write(iunit) gcongrid + write(iunit) sqrtggrid + write(iunit) metricderivsgrid + + ! Close the file + close(iunit) + ierr = 0 +end subroutine write_tabulated_metric - subroutine read_tabulated_metric(metric_file, ierr) - character(len=*), intent(in) :: metric_file - integer, intent(out) :: ierr - integer :: iunit +subroutine read_tabulated_metric(metric_file, ierr) + character(len=*), intent(in) :: metric_file + integer, intent(out) :: ierr + integer :: iunit - ! Open the file for reading - open(newunit=iunit,file=metric_file,status='old', form='unformatted',action='read',iostat=ierr) - if (ierr /= 0) return + ! Open the file for reading + open(newunit=iunit,file=metric_file,status='old', form='unformatted',action='read',iostat=ierr) + if (ierr /= 0) return - ! Read the dimensions of the grid - read(iunit) gridsize + ! Read the dimensions of the grid + read(iunit) gridsize - ! Read the grid origin and spacing - read(iunit) gridorigin - read(iunit) dxgrid + ! Read the grid origin and spacing + read(iunit) gridorigin + read(iunit) dxgrid - nx = gridsize(1) - ny = gridsize(2) - nz = gridsize(3) + nx = gridsize(1) + ny = gridsize(2) + nz = gridsize(3) - call allocate_grid(nx,ny,nz,& + call allocate_grid(nx,ny,nz,& dxgrid(1),dxgrid(2),dxgrid(3),& gridorigin(1),gridorigin(2),gridorigin(3)) - ! Read the metric values from the file - read(iunit) gcovgrid - read(iunit) gcongrid - read(iunit) sqrtggrid - read(iunit) metricderivsgrid + ! Read the metric values from the file + read(iunit) gcovgrid + read(iunit) gcongrid + read(iunit) sqrtggrid + read(iunit) metricderivsgrid - gridinit = .true. + gridinit = .true. - ! Close the file - close(iunit) - ierr = 0 - end subroutine read_tabulated_metric + ! Close the file + close(iunit) + ierr = 0 +end subroutine read_tabulated_metric end module metric_et_utils diff --git a/src/utils/struct_part.f90 b/src/utils/struct_part.f90 index 99640148d..781a3c2fd 100644 --- a/src/utils/struct_part.f90 +++ b/src/utils/struct_part.f90 @@ -149,10 +149,10 @@ subroutine get_structure_fn(sf,nbins,norder,distmin,distmax,xbins,ncount,npart,x !$omp reduction(+:sf) do ipt=1,npts !$ if (.false.) then - if (mod(ipt,100)==0) then - call cpu_time(tcpu2) - print*,' ipt = ',ipt,tcpu2-tcpu1 - endif + if (mod(ipt,100)==0) then + call cpu_time(tcpu2) + print*,' ipt = ',ipt,tcpu2-tcpu1 + endif !$ endif i = list(ipt) xpt(1) = xyz(1,i) diff --git a/src/utils/tabulate_metric.f90 b/src/utils/tabulate_metric.f90 index 7a73bcac3..9216df362 100644 --- a/src/utils/tabulate_metric.f90 +++ b/src/utils/tabulate_metric.f90 @@ -16,68 +16,68 @@ program tabulate_metric ! ! :Dependencies: metric, metric_et_utils ! - use metric_et_utils - !use metric + use metric_et_utils + !use metric - implicit none + implicit none - integer :: ierr - character(len=64) :: metric_file = 'tabuled_metric.dat' + integer :: ierr + character(len=64) :: metric_file = 'tabuled_metric.dat' - ! Init grid and tabulated metric - call initialize_grid() + ! Init grid and tabulated metric + call initialize_grid() - ! Fill and interpolate metric in the grid - call fill_grid() + ! Fill and interpolate metric in the grid + call fill_grid() - ! Write Data in file - call write_tabulated_metric(metric_file, ierr) + ! Write Data in file + call write_tabulated_metric(metric_file, ierr) - if (ierr /= 0) then - print *, 'Error writing metric data to file' - else - print *, 'Metric data successfully written to file' - endif + if (ierr /= 0) then + print *, 'Error writing metric data to file' + else + print *, 'Metric data successfully written to file' + endif contains subroutine fill_grid() - use metric - integer :: i, j, k - real :: dx, dy, dz - real :: position(3) - real :: gcov(0:3,0:3) - real :: gcon(0:3,0:3) - real :: sqrtg - real :: dgcovdx(0:3,0:3) - real :: dgcovdy(0:3,0:3) - real :: dgcovdz(0:3,0:3) - ! Triple loop to fill the grid - dx = (xmax - xmin) / (nx - 1) - dy = (ymax - ymin) / (ny - 1) - dz = (zmax - zmin) / (nz - 1) + use metric + integer :: i, j, k + real :: dx, dy, dz + real :: position(3) + real :: gcov(0:3,0:3) + real :: gcon(0:3,0:3) + real :: sqrtg + real :: dgcovdx(0:3,0:3) + real :: dgcovdy(0:3,0:3) + real :: dgcovdz(0:3,0:3) + ! Triple loop to fill the grid + dx = (xmax - xmin) / (nx - 1) + dy = (ymax - ymin) / (ny - 1) + dz = (zmax - zmin) / (nz - 1) - do i = 1, nx - do j = 1, ny - do k = 1, nz - ! Calculate the current position in the grid - position(1) = xmin + (i - 1) * dx - position(2) = ymin + (j - 1) * dy - position(3) = zmin + (k - 1) * dz - ! Store the calculated values in the grid arrays - call get_metric_cartesian(position,gcov,gcon,sqrtg) - !call get_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) - call metric_cartesian_derivatives(position,dgcovdx, dgcovdy, dgcovdz) - gcovgrid(:,:,i,j,k) = gcov - gcongrid(:,:,i,j,k) = gcon - sqrtggrid(i,j,k) = sqrtg - metricderivsgrid(:,:,1,i,j,k) = dgcovdx - metricderivsgrid(:,:,2,i,j,k) = dgcovdy - metricderivsgrid(:,:,3,i,j,k) = dgcovdz - enddo - enddo - enddo + do i = 1, nx + do j = 1, ny + do k = 1, nz + ! Calculate the current position in the grid + position(1) = xmin + (i - 1) * dx + position(2) = ymin + (j - 1) * dy + position(3) = zmin + (k - 1) * dz + ! Store the calculated values in the grid arrays + call get_metric_cartesian(position,gcov,gcon,sqrtg) + !call get_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) + call metric_cartesian_derivatives(position,dgcovdx, dgcovdy, dgcovdz) + gcovgrid(:,:,i,j,k) = gcov + gcongrid(:,:,i,j,k) = gcon + sqrtggrid(i,j,k) = sqrtg + metricderivsgrid(:,:,1,i,j,k) = dgcovdx + metricderivsgrid(:,:,2,i,j,k) = dgcovdy + metricderivsgrid(:,:,3,i,j,k) = dgcovdz + enddo + enddo + enddo end subroutine fill_grid end program tabulate_metric From bf0ecdbb965c628990358c8de3c7aa34903d6281 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 10:35:10 +1000 Subject: [PATCH 753/814] update .mailmap --- .mailmap | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/.mailmap b/.mailmap index c8f50cfe7..eab7608f0 100644 --- a/.mailmap +++ b/.mailmap @@ -96,7 +96,8 @@ Megha Sharma megha sharma Megha Sharma Megha Sharma Megha Sharma Megha Sharma Megha Sharma Megha Sharma -Mike Lau Mike Lau <55525335+themikelau@users.noreply.github.com> +Mike Lau Mike Lau <55525335+themikelau@users.noreply.github.com> +Mike Lau Mike Lau Elisabeth Borchert emborchert <69176538+emborchert@users.noreply.github.com> Ward Homan ward Ward Homan wardhoman <33419533+wardhoman@users.noreply.github.com> @@ -104,6 +105,7 @@ Benedetta Veronesi benedetta veronesi Phantom benchmark bot Ubuntu Stephane Michoulier StephaneMichoulier +Stephane Michoulier MICHOULIER Stephane Jolien Malfait Jolien128 <72729152+Jolien128@users.noreply.github.com> Martina Toscani Martina Toscani @@ -116,4 +118,10 @@ Amena Faruqi Amena Faruqi Alison Young Alison Young Simone Ceppi Simone Ceppi Madeline Overton Madeline Nicole Overton +Madeline Overton Madeline Overton <85810161+moverton000@users.noreply.github.com> Nicolás Cuello Nicolas Cuello +Rebecca Martin rebeccagmartin <74937128+rebeccagmartin@users.noreply.github.com> +Stephen Nielson s-neilson <36410751+s-neilson@users.noreply.github.com> +Stephen Nielson Stephen Neilson <36410751+s-neilson@users.noreply.github.com> +Yann Bernard Yrisch +David Bamba DavidBamba From 82fe89a338abbd971a28aa2e227d3829d6725c51 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 10:38:46 +1000 Subject: [PATCH 754/814] [header-bot] updated file headers --- src/main/H2regions.f90 | 2 +- src/main/eos_HIIR.f90 | 2 +- src/main/metric_et_utils.f90 | 2 +- src/main/subgroup.f90 | 2 +- src/main/substepping.F90 | 2 +- src/main/utils_kepler.f90 | 2 +- src/main/utils_subgroup.f90 | 2 +- src/setup/set_orbit.f90 | 15 +++++++++++++++ src/setup/setup_starcluster.f90 | 2 +- src/utils/tabulate_metric.f90 | 2 +- 10 files changed, 24 insertions(+), 9 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 5ca0ad90d..507d42a7c 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -10,7 +10,7 @@ module HIIRegion ! ! :References: Fujii et al. (2021), Hopkins et al. (2012) ! -! :Owner: Yrisch +! :Owner: Yann Bernard ! ! :Runtime parameters: None ! diff --git a/src/main/eos_HIIR.f90 b/src/main/eos_HIIR.f90 index 315d97734..a0ec8b61c 100644 --- a/src/main/eos_HIIR.f90 +++ b/src/main/eos_HIIR.f90 @@ -10,7 +10,7 @@ module eos_HIIR ! ! :References: None ! -! :Owner: Yrisch +! :Owner: Yann Bernard ! ! :Runtime parameters: None ! diff --git a/src/main/metric_et_utils.f90 b/src/main/metric_et_utils.f90 index 05b106208..288520cf5 100644 --- a/src/main/metric_et_utils.f90 +++ b/src/main/metric_et_utils.f90 @@ -10,7 +10,7 @@ module metric_et_utils ! ! :References: None ! -! :Owner: DavidBamba +! :Owner: Daniel Price ! ! :Runtime parameters: None ! diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 1e6e52e28..940e8e92a 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -11,7 +11,7 @@ module subgroup ! ! :References: Makkino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 ! -! :Owner: Yrisch +! :Owner: Yann Bernard ! ! :Runtime parameters: None ! diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 504e7b9d3..a0d8d4693 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -21,7 +21,7 @@ module substepping ! Tuckerman, Berne & Martyna (1992), J. Chem. Phys. 97, 1990-2001 ! Rantala + (2020) (2023),Chin (2007a) ! -! :Owner: Yrisch +! :Owner: Yann Bernard ! ! :Runtime parameters: None ! diff --git a/src/main/utils_kepler.f90 b/src/main/utils_kepler.f90 index deb5de94b..071844eda 100644 --- a/src/main/utils_kepler.f90 +++ b/src/main/utils_kepler.f90 @@ -10,7 +10,7 @@ module utils_kepler ! ! :References: None ! -! :Owner: Yrisch +! :Owner: Yann Bernard ! ! :Runtime parameters: None ! diff --git a/src/main/utils_subgroup.f90 b/src/main/utils_subgroup.f90 index 913a57606..91f20f713 100644 --- a/src/main/utils_subgroup.f90 +++ b/src/main/utils_subgroup.f90 @@ -10,7 +10,7 @@ module utils_subgroup ! ! :References: None ! -! :Owner: Yrisch +! :Owner: Yann Bernard ! ! :Runtime parameters: None ! diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index 9b05809b5..f4ebbe1c8 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -29,6 +29,21 @@ module setorbit ! :Dependencies: infile_utils, physcon, setbinary, setflyby, units ! +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: infile_utils, physcon, setbinary, setflyby, units +! + ! While Campbell elements can be used for unbound orbits, they require ! specifying the true anomaly at the start of the simulation. This is ! not always easy to determine, so the flyby option is provided as an diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index 429558843..4a11efd07 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -11,7 +11,7 @@ module setup ! ! :References: Paumard et al. (2006) ! -! :Owner: Yrisch +! :Owner: Yann Bernard ! ! :Runtime parameters: ! - datafile : *filename for star data (m,x,y,z,vx,vy,vz)* diff --git a/src/utils/tabulate_metric.f90 b/src/utils/tabulate_metric.f90 index 9216df362..c02d2a870 100644 --- a/src/utils/tabulate_metric.f90 +++ b/src/utils/tabulate_metric.f90 @@ -10,7 +10,7 @@ program tabulate_metric ! ! :References: None ! -! :Owner: DavidBamba +! :Owner: Daniel Price ! ! :Usage: tabulate_metric [no arguments] ! From 2f7c230b93e1fa6b0bad871b507082893a52edd4 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 10:39:04 +1000 Subject: [PATCH 755/814] [author-bot] updated AUTHORS file --- AUTHORS | 40 ++++++++++++++++++---------------------- 1 file changed, 18 insertions(+), 22 deletions(-) diff --git a/AUTHORS b/AUTHORS index b4d2b8428..b3a77dfde 100644 --- a/AUTHORS +++ b/AUTHORS @@ -6,14 +6,14 @@ # Edit .mailmap if your name or email are wrong # #-------------------------------------------------------# Daniel Price -Mike Lau +Mike Lau Conrad Chan James Wurster David Liptai Lionel Siess Fangyi (Fitz) Hu Daniel Mentiplay -Yrisch +Yann Bernard Megha Sharma Arnaud Vericel Mark Hutchison @@ -32,10 +32,10 @@ Cristiano Longarini Sergei Biriukov Giovanni Dipierro Roberto Iaconi -Hauke Worpel Amena Faruqi +Hauke Worpel Alison Young -Stephen Neilson <36410751+s-neilson@users.noreply.github.com> +Stephen Nielson Martina Toscani Benedetta Veronesi Simon Glover @@ -43,37 +43,33 @@ Sahl Rowther Thomas Reichardt Jean-François Gonzalez Christopher Russell -Alessia Franchini -Alex Pettitt -Jolien Malfait Madeline Overton +Alex Pettitt Phantom benchmark bot -Mike Lau -Kieran Hirsh +Jolien Malfait +Alessia Franchini Nicole Rodrigues -Nicolás Cuello -David Trevascus +Kieran Hirsh Farzana Meru +David Trevascus +Nicolás Cuello Chris Nixon Miguel Gonzalez-Bolivar Maxime Lombart +Zachary Pellow Orsola De Marco -s-neilson <36410751+s-neilson@users.noreply.github.com> Joe Fisher -Giulia Ballabio Benoit Commercon -Zachary Pellow -Madeline Overton <85810161+moverton000@users.noreply.github.com> -DavidBamba +Giulia Ballabio +Rebecca Martin Jorge Cuadra +Hugh Griffiths +Jeremy Smallwood +David Bamba Cox, Samuel +Chunliang Mu +Shunquan Huang Steven Rieder Stéven Toupin Taj Jankovič -Chunliang Mu -MICHOULIER Stephane -rebeccagmartin <74937128+rebeccagmartin@users.noreply.github.com> Ariel Chitan -Hugh Griffiths -Shunquan Huang -Jeremy Smallwood From c1ee6a9ffa34aeb6777afca482f5d0ba50d0ef92 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 17:47:02 +1000 Subject: [PATCH 756/814] (#55) remove ifdefs, fix test failure with SETUP=flrw and properly comment subroutines --- src/main/initial.F90 | 2 +- src/main/metric_et.f90 | 2 +- src/main/metric_et_utils.f90 | 36 +++++++++++-- src/main/metric_tools.F90 | 87 ++++++++++++------------------ src/main/utils_gr.F90 | 91 ++++++++++++++++---------------- src/setup/setup_asteroidwind.f90 | 2 +- 6 files changed, 115 insertions(+), 105 deletions(-) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index c1f0b6842..d050a7f8c 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -106,7 +106,7 @@ subroutine initialise() ! if (gr .and. metric_type=='et') then call read_tabulated_metric('tabuled_metric.dat',ierr) - gridinit = .true. + if (ierr == 0) gridinit = .true. endif call init_readwrite_dumps() diff --git a/src/main/metric_et.f90 b/src/main/metric_et.f90 index a4c757a73..cd93c9c3b 100644 --- a/src/main/metric_et.f90 +++ b/src/main/metric_et.f90 @@ -189,7 +189,7 @@ subroutine write_options_metric(iunit) !use infile_utils, only:write_inopt integer, intent(in) :: iunit - write(iunit,"(/,a)") '# There are no options relating to the '//trim(metric_type)//' metric' + !write(iunit,"(/,a)") '# There are no options relating to the '//trim(metric_type)//' metric' !call write_inopt(metric_file,'metric_file','file from which to read tabulated metric (blank if used with einsteintk)',iunit) end subroutine write_options_metric diff --git a/src/main/metric_et_utils.f90 b/src/main/metric_et_utils.f90 index 288520cf5..a3c3bebf5 100644 --- a/src/main/metric_et_utils.f90 +++ b/src/main/metric_et_utils.f90 @@ -6,9 +6,9 @@ !--------------------------------------------------------------------------! module metric_et_utils ! -! metric_et_utils +! Utilities for handling tabulated metrics from the Einstein Toolkit ! -! :References: None +! :References: Magnall et al. (2023), Phys. Rev. D 108, 103534 ! ! :Owner: Daniel Price ! @@ -35,6 +35,11 @@ module metric_et_utils contains +!--------------------------------------------------------------- +!+ +! allocate memory for the metric grid +!+ +!--------------------------------------------------------------- subroutine allocate_grid(nxin,nyin,nzin,dx,dy,dz,originx,originy,originz) integer, intent(in) :: nxin,nyin,nzin real, intent(in) :: dx,dy,dz,originx,originy,originz @@ -67,6 +72,12 @@ subroutine allocate_grid(nxin,nyin,nzin,dx,dy,dz,originx,originy,originz) end subroutine allocate_grid +!--------------------------------------------------------------- +!+ +! initialise a metric grid with a uniform grid +! (currently size is hardwired but just for testing...) +!+ +!--------------------------------------------------------------- subroutine initialize_grid() ! Local variable declarations real :: dx, dy, dz, x0(3) @@ -87,8 +98,12 @@ subroutine initialize_grid() end subroutine initialize_grid +!--------------------------------------------------------------- +!+ +! print information about the metric grid +!+ +!--------------------------------------------------------------- subroutine print_metric_grid() - ! Subroutine for printing quantities of the ET grid print*, "Grid spacing (x,y,z) is : ", dxgrid print*, "Grid origin (x,y,z) is: ", gridorigin @@ -96,6 +111,11 @@ subroutine print_metric_grid() end subroutine print_metric_grid +!--------------------------------------------------------------- +!+ +! write tabulated metric to file +!+ +!--------------------------------------------------------------- subroutine write_tabulated_metric(metric_file, ierr) character(len=*), intent(in) :: metric_file integer, intent(out) :: ierr @@ -124,16 +144,21 @@ subroutine write_tabulated_metric(metric_file, ierr) ! Close the file close(iunit) ierr = 0 + end subroutine write_tabulated_metric +!--------------------------------------------------------------- +!+ +! read tabulated metric from file +!+ +!--------------------------------------------------------------- subroutine read_tabulated_metric(metric_file, ierr) character(len=*), intent(in) :: metric_file integer, intent(out) :: ierr integer :: iunit - ! Open the file for reading - open(newunit=iunit,file=metric_file,status='old', form='unformatted',action='read',iostat=ierr) + open(newunit=iunit,file=metric_file,status='old',form='unformatted',action='read',iostat=ierr) if (ierr /= 0) return ! Read the dimensions of the grid @@ -162,6 +187,7 @@ subroutine read_tabulated_metric(metric_file, ierr) ! Close the file close(iunit) ierr = 0 + end subroutine read_tabulated_metric end module metric_et_utils diff --git a/src/main/metric_tools.F90 b/src/main/metric_tools.F90 index 8fd54fdf0..b0cf56c3f 100644 --- a/src/main/metric_tools.F90 +++ b/src/main/metric_tools.F90 @@ -29,24 +29,22 @@ module metric_tools icoord_cartesian = 1, & ! Cartesian coordinates icoord_spherical = 2 ! Spherical coordinates -!--- List of metrics + !--- List of metrics integer, public, parameter :: & imet_minkowski = 1, & ! Minkowski metric imet_schwarzschild = 2, & ! Schwarzschild metric imet_kerr = 3, & ! Kerr metric imet_et = 6 ! Tabulated metric from Einstein toolkit -!--- Choice of coordinate system -! (When using this with PHANTOM, it should always be set to cartesian) + !--- Choice of coordinate system + ! (When using this with PHANTOM, it should always be set to cartesian) integer, public, parameter :: icoordinate = icoord_cartesian -!--- Choice for contravariant metric -! false -> use analytic contravariant metric -! true -> invert the covariant metric + !--- Choice for contravariant metric + ! false -> use analytic contravariant metric + ! true -> invert the covariant metric logical, private, parameter :: useinv4x4 = .true. -!------------------------------------------------------------------------------- - public :: get_metric, get_metric_derivs, print_metricinfo, init_metric, pack_metric, unpack_metric public :: pack_metricderivs public :: imetric @@ -63,8 +61,8 @@ module metric_tools !+ !------------------------------------------------------------------------------- pure subroutine get_metric(position,gcov,gcon,sqrtg) - use metric, only: get_metric_cartesian,get_metric_spherical,cartesian2spherical - use inverse4x4, only: inv4x4 + use metric, only:get_metric_cartesian,get_metric_spherical,cartesian2spherical + use inverse4x4, only:inv4x4 real, intent(in) :: position(3) real, intent(out) :: gcov(0:3,0:3), gcon(0:3,0:3), sqrtg real :: det @@ -95,8 +93,8 @@ end subroutine get_metric ! of metric. !+ !------------------------------------------------------------------------------- -subroutine get_metric_derivs(position,dgcovdx1, dgcovdx2, dgcovdx3) - use metric, only: metric_cartesian_derivatives, metric_spherical_derivatives, imetric +subroutine get_metric_derivs(position,dgcovdx1,dgcovdx2,dgcovdx3) + use metric, only:metric_cartesian_derivatives,metric_spherical_derivatives,imetric real, intent(in) :: position(3) real, intent(out) :: dgcovdx1(0:3,0:3), dgcovdx2(0:3,0:3), dgcovdx3(0:3,0:3) @@ -114,7 +112,7 @@ end subroutine get_metric_derivs ! Numerical derivatives of the covariant metric tensor !+ !------------------------------------------------------------------------------- -pure subroutine numerical_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) +pure subroutine numerical_metric_derivs(position,dgcovdx,dgcovdy,dgcovdz) real, intent(in) :: position(3) real, intent(out), dimension(0:3,0:3) :: dgcovdx,dgcovdy,dgcovdz real :: gblah(0:3,0:3), temp(3), gplus(0:3,0:3),gminus(0:3,0:3),dx,dy,dz,di,sqrtgblag @@ -150,29 +148,10 @@ pure subroutine numerical_metric_derivs(position,dgcovdx, dgcovdy, dgcovdz) end subroutine numerical_metric_derivs !------------------------------------------------------------------------------- - -! This is not being used at the moment... -!-- Do a coordinate transformation of a 4x4 rank-2 tensor with both indices down -! subroutine tensortransform_dd(position,T_old,T_new) -! use metric, only: get_jacobian -! real, intent(in), dimension(3) :: position -! real, intent(in), dimension(0:3,0:3) :: T_old -! real, intent(out), dimension(0:3,0:3) :: T_new -! real, dimension(0:3,0:3) :: dxdx -! integer :: i,j,k,l -! call get_jacobian(position,dxdx) -! T_new = 0. -! do i=0,3 -! do j=0,3 -! do k=0,3 -! do l=0,3 -! T_new(i,j) = T_new(i,j)+dxdx(k,i)*dxdx(l,j)*T_old(k,l) -! enddo -! enddo -! enddo -! enddo -! end subroutine tensortransform_dd - +!+ +! print the metric type +!+ +!------------------------------------------------------------------------------- subroutine print_metricinfo(iprint) use metric, only:metric_type integer, intent(in) :: iprint @@ -181,6 +160,11 @@ subroutine print_metricinfo(iprint) end subroutine print_metricinfo +!------------------------------------------------------------------------------- +!+ +! initialise arrays for the metric and metric derivatives +!+ +!------------------------------------------------------------------------------- subroutine init_metric(npart,xyzh,metrics,metricderivs) integer, intent(in) :: npart real, intent(in) :: xyzh(:,:) @@ -188,7 +172,6 @@ subroutine init_metric(npart,xyzh,metrics,metricderivs) real, optional, intent(out) :: metricderivs(:,:,:,:) integer :: i - !$omp parallel do default(none) & !$omp shared(npart,xyzh,metrics) & !$omp private(i) @@ -209,9 +192,11 @@ subroutine init_metric(npart,xyzh,metrics,metricderivs) end subroutine init_metric -! -!--- Subroutine to pack the metric (cov and con) into a single array -! +!------------------------------------------------------------------------------- +!+ +! subroutine to pack the metric into a 4x4x2 array +!+ +!------------------------------------------------------------------------------- pure subroutine pack_metric(xyz,metrici) real, intent(in) :: xyz(3) real, intent(out) :: metrici(:,:,:) @@ -221,6 +206,11 @@ pure subroutine pack_metric(xyz,metrici) end subroutine pack_metric +!------------------------------------------------------------------------------- +!+ +! subroutine to pack the metric derivatives into a 4x4x3 array +!+ +!------------------------------------------------------------------------------- subroutine pack_metricderivs(xyzi,metricderivsi) real, intent(in) :: xyzi(3) real, intent(out) :: metricderivsi(0:3,0:3,3) @@ -229,24 +219,19 @@ subroutine pack_metricderivs(xyzi,metricderivsi) end subroutine pack_metricderivs -! -!--- Subroutine to return metric/components from metrici array -! +!------------------------------------------------------------------------------- +!+ +! Subroutine to return metric/components from metrici array +!+ +!------------------------------------------------------------------------------- pure subroutine unpack_metric(metrici,gcov,gcon,gammaijdown,gammaijUP,alpha,betadown,betaUP) -#ifdef FINVSQRT - use fastmath, only:finvsqrt -#endif real, intent(in), dimension(0:3,0:3,2) :: metrici real, intent(out), dimension(0:3,0:3), optional :: gcov,gcon real, intent(out), dimension(1:3,1:3), optional :: gammaijdown,gammaijUP real, intent(out), optional :: alpha,betadown(3),betaUP(3) integer :: i -#ifdef FINVSQRT - if (present(alpha)) alpha = finvsqrt(-metrici(0,0,2)) -#else if (present(alpha)) alpha = sqrt(-1./metrici(0,0,2)) -#endif if (present(betaUP)) betaUP = metrici(0,1:3,2) * (-1./metrici(0,0,2)) ! = gcon(0,1:3)*alpha**2 @@ -264,6 +249,4 @@ pure subroutine unpack_metric(metrici,gcov,gcon,gammaijdown,gammaijUP,alpha,beta end subroutine unpack_metric - - end module metric_tools diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.F90 index 479476ca6..1308aeef8 100644 --- a/src/main/utils_gr.F90 +++ b/src/main/utils_gr.F90 @@ -6,9 +6,9 @@ !--------------------------------------------------------------------------! module utils_gr ! -! None +! Utility routines for the GR code ! -! :References: None +! :References: Liptai & Price (2019), MNRAS 485, 819-842 ! ! :Owner: David Liptai ! @@ -42,15 +42,14 @@ pure real function dot_product_gr(vec1,vec2,gcov) dot_product_gr = dot_product_gr + dot_product(gcov(:,i),vec1(i)*vec2(:)) enddo - return end function dot_product_gr -!------------------------------------------------------------------------------- - +!---------------------------------------------------------------- +!+ +! Function to return U^0, the time component of the 4-velocity +!+ +!---------------------------------------------------------------- pure subroutine get_u0(gcov,v,U0,ierr) -#ifdef FINVSQRT - use fastmath, only:finvsqrt -#endif real, intent(in) :: gcov(0:3,0:3), v(1:3) real, intent(out) :: U0 integer, intent(out) :: ierr @@ -60,23 +59,19 @@ pure subroutine get_u0(gcov,v,U0,ierr) v4(0) = 1. v4(1:3) = v(1:3) vv = dot_product_gr(v4,v4,gcov) -#ifdef FINVSQRT - U0 = finvsqrt(-vv) -#else U0 = 1./sqrt(-vv) -#endif if (vv > 0.) ierr = 1 end subroutine get_u0 -!------------------------------------------------------------------------------- - +!---------------------------------------------------------------- +!+ +! Function to return V^i, the velocity of an Eulerian observer +!+ +!---------------------------------------------------------------- subroutine get_bigv(metrici,v,bigv,bigv2,alpha,lorentz) use metric_tools, only:unpack_metric use io, only:fatal -#ifdef FINVSQRT - use fastmath, only:finvsqrt -#endif real, intent(in) :: metrici(0:3,0:3,2),v(1:3) real, intent(out) :: bigv(1:3),bigv2,alpha,lorentz real :: betaUP(1:3),gammaijdown(1:3,1:3) @@ -85,16 +80,16 @@ subroutine get_bigv(metrici,v,bigv,bigv2,alpha,lorentz) bigv = (v + betaUP)/alpha bigv2 = dot_product_gr(bigv,bigv,gammaijdown) if (bigv2 > 1.) call fatal('get_bigv','velocity faster than speed of light -- bigv2',val=bigv2) -#ifdef FINVSQRT - lorentz = finvsqrt(1.-bigv2) -#else lorentz = 1./sqrt(1.-bigv2) -#endif end subroutine get_bigv -!------------------------------------------------------------------------------- - +!---------------------------------------------------------------- +!+ +! get density in the fluid rest frame (primitive dens) from +! the conserved density rho* (stored as the smoothing length) +!+ +!---------------------------------------------------------------- subroutine h2dens(dens,xyzh,metrici,v) use part, only: rhoh,massoftype,igas real, intent(in) :: xyzh(1:4),metrici(:,:,:),v(1:3) @@ -108,6 +103,12 @@ subroutine h2dens(dens,xyzh,metrici,v) end subroutine h2dens +!---------------------------------------------------------------- +!+ +! get density in the fluid rest frame (primitive dens) from +! the conserved density rho* +!+ +!---------------------------------------------------------------- subroutine rho2dens(dens,rho,position,metrici,v) use metric_tools, only:unpack_metric use io, only:error @@ -116,7 +117,6 @@ subroutine rho2dens(dens,rho,position,metrici,v) integer :: ierror real :: gcov(0:3,0:3), sqrtg, U0 - call unpack_metric(metrici,gcov=gcov) call get_sqrtg(gcov, sqrtg) call get_u0(gcov,v,U0,ierror) @@ -126,6 +126,12 @@ subroutine rho2dens(dens,rho,position,metrici,v) end subroutine rho2dens +!---------------------------------------------------------------- +!+ +! get terms required on the RHS of the geodesic equation +! in the form dp_i/dt = a_i, as described in Liptai & Price (2019) +!+ +!---------------------------------------------------------------- subroutine get_geodesic_accel(axyz,npart,vxyz,metrics,metricderivs) use metric_tools, only:unpack_metric integer, intent(in) :: npart @@ -157,6 +163,11 @@ subroutine get_geodesic_accel(axyz,npart,vxyz,metrics,metricderivs) end subroutine get_geodesic_accel +!---------------------------------------------------------------- +!+ +! get determininant of the 4-metric +!+ +!---------------------------------------------------------------- subroutine get_sqrtg(gcov, sqrtg) use metric, only: metric_type real, intent(in) :: gcov(0:3,0:3) @@ -205,6 +216,11 @@ subroutine get_sqrtg(gcov, sqrtg) end subroutine get_sqrtg +!---------------------------------------------------------------- +!+ +! get determininant of the 3-metric +!+ +!---------------------------------------------------------------- subroutine get_sqrt_gamma(gcov,sqrt_gamma) use metric, only: metric_type real, intent(in) :: gcov(0:3,0:3) @@ -235,18 +251,20 @@ subroutine get_sqrt_gamma(gcov,sqrt_gamma) else sqrt_gamma = 1. - endif - end subroutine get_sqrt_gamma +!---------------------------------------------------------------- +!+ +! add a Newtonian gravitational perturbation to the metric +!+ +!---------------------------------------------------------------- subroutine perturb_metric(phi,gcovper,gcov) real, intent(in) :: phi real, intent(out) :: gcovper(0:3,0:3) real, optional, intent(in) :: gcov(0:3,0:3) - if (present(gcov)) then gcovper = gcov else @@ -257,29 +275,12 @@ subroutine perturb_metric(phi,gcovper,gcov) gcovper(3,3) = 1. endif - ! Set the pertubed metric based on the Bardeen formulation + ! Set the perturbed metric based on the Bardeen formulation gcovper(0,0) = gcovper(0,0) - 2.*phi gcovper(1,1) = gcovper(1,1) - 2.*phi gcovper(2,2) = gcovper(2,2) - 2.*phi gcovper(3,3) = gcovper(3,3) - 2.*phi - end subroutine perturb_metric -! This is not being used at the moment. -! subroutine dens2rho(rho,dens,position,v) -! use metric_tools, only: get_metric -! real, intent(in) :: dens,position(1:3),v(1:3) -! real, intent(out):: rho -! real :: gcov(0:3,0:3), gcon(0:3,0:3), sqrtg, U0 -! -! call get_metric(position,gcov,gcon,sqrtg) -! call get_u0(gcov,v,U0) -! -! rho = sqrtg*U0*dens -! -! end subroutine dens2rho - -!------------------------------------------------------------------------------- - end module utils_gr diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index 289b8329d..27ce8ce81 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.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,idust,set_particle_type,igas use setbinary, only:set_binary,get_a_from_period use spherical, only:set_sphere - use units, only:set_units,umass,udist,utime,unit_velocity,in_code_units + use units, only:set_units,umass,udist,unit_velocity,in_code_units use physcon, only:solarm,au,pi,solarr,ceresm,km,kboltz,mass_proton_cgs use externalforces, only:iext_binary, iext_einsteinprec, update_externalforce, & mass1,accradius1 From 728aafad1ceadfc7a9b2ad66cc7064a81bc002db Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 17:49:17 +1000 Subject: [PATCH 757/814] (#55) .F90->.f90 for metric utility routines --- src/main/{metric_tools.F90 => metric_tools.f90} | 0 src/main/{utils_gr.F90 => utils_gr.f90} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename src/main/{metric_tools.F90 => metric_tools.f90} (100%) rename src/main/{utils_gr.F90 => utils_gr.f90} (100%) diff --git a/src/main/metric_tools.F90 b/src/main/metric_tools.f90 similarity index 100% rename from src/main/metric_tools.F90 rename to src/main/metric_tools.f90 diff --git a/src/main/utils_gr.F90 b/src/main/utils_gr.f90 similarity index 100% rename from src/main/utils_gr.F90 rename to src/main/utils_gr.f90 From 6d780da71bb3b4ee55fbaa008f780a1a401deeaf Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 17:52:11 +1000 Subject: [PATCH 758/814] (set_orbit) fix problem with header bot giving repeated splats of same paragraph in header --- src/setup/set_orbit.f90 | 40 +++++----------------------------------- 1 file changed, 5 insertions(+), 35 deletions(-) diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index f4ebbe1c8..a44a77ff1 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -13,42 +13,12 @@ module setorbit ! 0) Campbell elements for bound or unbound orbit (aeiOwf) ! 1) Flyby parameters (periapsis, initial separation, argument of periapsis, inclination) ! 2) position and velocity for both bodies - -! While Campbell elements can be used for unbound orbits, they require -! specifying the true anomaly at the start of the simulation. This is -! not always easy to determine, so the flyby option is provided as an -! alternative. There one specifies the initial separation instead, however -! the choice of angles is more restricted -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: infile_utils, physcon, setbinary, setflyby, units -! - -! While Campbell elements can be used for unbound orbits, they require -! specifying the true anomaly at the start of the simulation. This is -! not always easy to determine, so the flyby option is provided as an -! alternative. There one specifies the initial separation instead, however -! the choice of angles is more restricted -! -! :References: None -! -! :Owner: Daniel Price ! -! :Runtime parameters: None -! -! :Dependencies: infile_utils, physcon, setbinary, setflyby, units -! - -! While Campbell elements can be used for unbound orbits, they require -! specifying the true anomaly at the start of the simulation. This is -! not always easy to determine, so the flyby option is provided as an -! alternative. There one specifies the initial separation instead, however -! the choice of angles is more restricted +! While Campbell elements can be used for unbound orbits, they require +! specifying the true anomaly at the start of the simulation. This is +! not always easy to determine, so the flyby option is provided as an +! alternative. There one specifies the initial separation instead, however +! the choice of angles is more restricted ! ! :References: None ! From d0b8020774c801d1cab5e5b51318c7cfd217ad18 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 18:55:31 +1000 Subject: [PATCH 759/814] test failure fixed --- src/main/inject_randomwind.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index f2f8648e8..d1b7d694c 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -41,6 +41,8 @@ module inject integer :: mdot_type = 0 ! injection rate (0=const, 1=cos(t), 2=r^(-2)) integer :: random_type = 0 ! random position on the surface, 0 for random, 1 for gaussian real :: delta_theta = 0.5 ! standard deviation for the gaussion distribution (random_type=1) + real :: have_injected = 0. + real :: t_old = 0. contains !----------------------------------------------------------------------- @@ -82,8 +84,6 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& real :: dmdt,rbody,h,u,speed,inject_this_step real :: m1,m2,r real :: dt - real, save :: have_injected,t_old - real, save :: semia if (nptmass < 1 .and. iexternalforce == 0) & call fatal('inject_randomwind','not enough point masses for random wind injection') @@ -116,7 +116,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& ! Add any dependency on radius to mass injection rate (and convert to code units) ! mdot = in_code_units(mdot_str,ierr) - dmdt = mdot*mdot_func(r,semia) ! Use semi-major axis as r_ref + dmdt = mdot*mdot_func(r,rbody) ! Use rbody as r_ref, currently the softening length of the body ! !-- How many particles do we need to inject? From 8c125fd92d99563c3f3493b07571b392d0c3c9e6 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 31 Jul 2024 11:18:50 +0200 Subject: [PATCH 760/814] (subgroup) fix seg fault in sink_sink force --- src/main/evolve.F90 | 2 +- src/main/ptmass.F90 | 2 +- src/main/subgroup.f90 | 5 +++++ 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index d8c065b42..2f0d063b2 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -320,7 +320,7 @@ 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) 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,group_info=group_info) + fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,group_info=group_info,bin_info=bin_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) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index bca4c8178..03247da9a 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -383,7 +383,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin extrap = .false. endif - if (present(group_info)) then + if (present(group_info) .and. present(bin_info)) then subsys = .true. else subsys = .false. diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 00064f34b..4936d9860 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -116,6 +116,11 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) integer :: i,k,l,start_id,end_id,gsize real :: akl,ekl,apokl,Tkl + bin_info(isemi,:) = 0. + bin_info(iecc,:) = 0. + bin_info(iapo,:) = 0. + bin_info(iorb,:) = 0. + ! this loop could be parallelized... do i=1,n_group start_id = group_info(igcum,i) + 1 From ac7156f1cf1d0ebfd71f4fc79bb1171864268a29 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 19:58:15 +1000 Subject: [PATCH 761/814] (HII regions) minor formatting issues fixed; do not print useless lines to .in file --- src/main/H2regions.f90 | 75 ++++++++++++++++++++++++++---------------- 1 file changed, 47 insertions(+), 28 deletions(-) diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 507d42a7c..cac51a26e 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -6,7 +6,7 @@ !--------------------------------------------------------------------------! module HIIRegion ! -! HIIRegion +! Feedback from HII regions ! ! :References: Fujii et al. (2021), Hopkins et al. (2012) ! @@ -17,7 +17,6 @@ module HIIRegion ! :Dependencies: dim, eos, infile_utils, io, linklist, part, physcon, ! sortutils, timing, units ! - implicit none public :: update_ionrates,update_ionrate, HII_feedback,initialize_H2R,read_options_H2R,write_options_H2R @@ -49,17 +48,18 @@ module HIIRegion contains - !----------------------------------------------------------------------- - !+ - ! Initialise stellar feedbacks - !+ - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!+ +! Initialise stellar feedbacks +!+ +!----------------------------------------------------------------------- subroutine initialize_H2R use io, only:iprint,iverbose,id,master use part, only:isionised use units, only:udist,umass,utime use physcon, only:mass_proton_cgs,kboltz,pc,eV,solarm - use eos , only:gmw,gamma + use eos, only:gmw,gamma + isionised(:)=.false. !calculate the useful constant in code units mH = gmw*mass_proton_cgs @@ -82,7 +82,7 @@ subroutine initialize_H2R write(iprint,"(a,es18.10,es18.10)") " Max strögrem radius (code/pc) : ", Rst_max, Rmax write(iprint,"(a,es18.10,es18.10)") " Min feedback mass (code/Msun) : ", Minmass, Mmin endif - return + end subroutine initialize_H2R !----------------------------------------------------------------------- @@ -90,7 +90,6 @@ end subroutine initialize_H2R ! Calculation of the the ionizing photon rate of all stars (Only for restart) !+ !----------------------------------------------------------------------- - subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose use units, only:umass @@ -101,6 +100,7 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) real, intent(in) :: h_acc real :: logmi,log_Q,mi,hi integer :: i + nHIIsources = 0 !$omp parallel do default(none) & !$omp shared(xyzmh_ptmass,iprint,iverbose,umass)& @@ -119,7 +119,7 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) xyzmh_ptmass(irstrom,i) = -1. nHIIsources = nHIIsources + 1 if (iverbose >= 0) then - write(iprint,"(/a,es18.10,es18.10/)")"Massive stars detected : Log Q, Mass : ",log_Q,mi + write(iprint,"(/a,es18.10,es18.10/)") "Massive stars detected : Log Q, Mass : ",log_Q,mi endif else xyzmh_ptmass(irateion,i) = -1. @@ -130,9 +130,14 @@ subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) if (iverbose > 1) then write(iprint,"(/a,i8/)") "nb_feedback sources : ",nHIIsources endif - return + end subroutine update_ionrates +!----------------------------------------------------------------------- +!+ +! update the ionizing photon rate +!+ +!----------------------------------------------------------------------- subroutine update_ionrate(i,xyzmh_ptmass,h_acc) use io, only:iprint,iverbose use units, only:umass @@ -142,6 +147,7 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: h_acc real :: logmi,log_Q,mi,hi + mi = xyzmh_ptmass(4,i) hi = xyzmh_ptmass(ihacc,i) if (mi > Minmass .and. hi < h_acc) then @@ -153,7 +159,7 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) xyzmh_ptmass(irstrom,i) = -1. nHIIsources = nHIIsources + 1 if (iverbose >= 0) then - write(iprint,"(/a,es18.10,es18.10/)")"Massive stars detected : Log Q, Mass : ",log_Q,mi + write(iprint,"(/a,es18.10,es18.10/)") "Massive stars detected : Log Q, Mass : ",log_Q,mi endif else xyzmh_ptmass(irateion,i) = -1. @@ -163,15 +169,14 @@ subroutine update_ionrate(i,xyzmh_ptmass,h_acc) if (iverbose > 1) then write(iprint,"(/a,i8/)") "nb_feedback sources : ",nHIIsources endif - return -end subroutine update_ionrate - !----------------------------------------------------------------------- - !+ - ! Main subroutine : Application of the HII feedback using Hopkins's like prescription - !+ - !----------------------------------------------------------------------- +end subroutine update_ionrate +!----------------------------------------------------------------------- +!+ +! Main subroutine : Application of the HII feedback using Hopkins's like prescription +!+ +!----------------------------------------------------------------------- subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) use part, only:rhoh,massoftype,ihsoft,igas,irateion,isdead_or_accreted,& irstrom @@ -265,10 +270,10 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) r_in = sqrt((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) mHII = ((4.*pi*(r**3-r_in**3)*rhoh(xyzh(4,j),pmass))/3) if (mHII>3*pmass) then -!$omp parallel do default(none) & -!$omp shared(mHII,listneigh,xyzh,sigd,dt) & -!$omp shared(mH,vxyzu,log_Qi,hv_on_c,npartin,pmass,xi,yi,zi) & -!$omp private(j,dx,dy,dz,vkx,vky,vkz,xj,yj,zj,r,taud) + !$omp parallel do default(none) & + !$omp shared(mHII,listneigh,xyzh,sigd,dt) & + !$omp shared(mH,vxyzu,log_Qi,hv_on_c,npartin,pmass,xi,yi,zi) & + !$omp private(j,dx,dy,dz,vkx,vky,vkz,xj,yj,zj,r,taud) do k=1,npartin j = listneigh(1) xj = xyzh(1,j) @@ -287,28 +292,40 @@ subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) vxyzu(2,j) = vxyzu(2,j) + vky*dt vxyzu(3,j) = vxyzu(3,j) + vkz*dt enddo -!$omp end parallel do + !$omp end parallel do endif endif enddo endif call get_timings(t2,tcpu2) call increment_timer(itimer_HII,t2-t1,tcpu2-tcpu1) - return + end subroutine HII_feedback +!----------------------------------------------------------------------- +!+ +! write options to input file +!+ +!----------------------------------------------------------------------- subroutine write_options_H2R(iunit) use infile_utils, only:write_inopt use physcon, only:solarm integer, intent(in) :: iunit - write(iunit,"(/,a)") '# options controlling HII region expansion feedback' - if (iH2R>0) then + + if (iH2R > 0) then + write(iunit,"(/,a)") '# options controlling HII region expansion feedback' call write_inopt(iH2R, 'iH2R', "enable the HII region expansion feedback in star forming reigon", iunit) call write_inopt(Mmin, 'Mmin', "Minimum star mass to trigger HII region (MSun)", iunit) call write_inopt(Rmax, 'Rmax', "Maximum radius for HII region (pc)", iunit) endif + end subroutine write_options_H2R +!----------------------------------------------------------------------- +!+ +! read options from input file +!+ +!----------------------------------------------------------------------- subroutine read_options_H2R(name,valstring,imatch,igotall,ierr) use io, only:fatal character(len=*), intent(in) :: name,valstring @@ -316,6 +333,7 @@ subroutine read_options_H2R(name,valstring,imatch,igotall,ierr) integer, intent(out) :: ierr integer, save :: ngot = 0 character(len=30), parameter :: label = 'read_options_H2R' + imatch = .true. select case(trim(name)) case('iH2R') @@ -334,6 +352,7 @@ subroutine read_options_H2R(name,valstring,imatch,igotall,ierr) imatch = .true. end select igotall = (ngot >= 3) + end subroutine read_options_H2R end module HIIRegion From 6d079a7a898ccb237305d3fe870aa10440361a26 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 19:58:37 +1000 Subject: [PATCH 762/814] (ptmass) avoid unneccessary cluttering of .in file --- src/main/ptmass.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index a5362c8a0..30964e48d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -2197,7 +2197,7 @@ subroutine write_options_ptmass(iunit) integer, intent(in) :: iunit write(iunit,"(/,a)") '# options controlling sink particles' - call write_inopt(isink_potential,'isink_potential','sink potential(0=1/r,1=surf)',iunit) + call write_inopt(isink_potential,'isink_potential','sink potential (0=1/r,1=surf)',iunit) if (gravity) then call write_inopt(icreate_sinks,'icreate_sinks','allow automatic sink particle creation',iunit) if (icreate_sinks > 0) then @@ -2219,8 +2219,10 @@ subroutine write_options_ptmass(iunit) endif call write_inopt(h_soft_sinksink,'h_soft_sinksink','softening length between sink particles',iunit) call write_inopt(f_acc,'f_acc','particles < f_acc*h_acc accreted without checks',iunit) - call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) - call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) + if (gravity .and. icreate_sinks) then + call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) + call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) + endif if (use_regnbody) then call write_inopt(use_regnbody, 'use_regnbody', 'allow subgroup integration method', iunit) call write_inopt(r_neigh, 'r_neigh', 'searching radius to detect subgroups', iunit) @@ -2321,7 +2323,7 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) imatch = .false. end select - if (icreate_sinks ==2) store_ll_ptmass = .true. + if (icreate_sinks == 2) store_ll_ptmass = .true. !--make sure we have got all compulsory options (otherwise, rewrite input file) if (icreate_sinks > 0) then From 6833c4c9adfd957df2739e008f4a819e0e86ec04 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 19:59:11 +1000 Subject: [PATCH 763/814] (inject_randomwind) fix mdot_type = 2; read/write r_ref from .in file for this case --- src/main/inject_randomwind.f90 | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index d1b7d694c..c55eea947 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -43,6 +43,7 @@ module inject real :: delta_theta = 0.5 ! standard deviation for the gaussion distribution (random_type=1) real :: have_injected = 0. real :: t_old = 0. + real :: r_ref = 1. contains !----------------------------------------------------------------------- @@ -116,7 +117,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& ! Add any dependency on radius to mass injection rate (and convert to code units) ! mdot = in_code_units(mdot_str,ierr) - dmdt = mdot*mdot_func(r,rbody) ! Use rbody as r_ref, currently the softening length of the body + dmdt = mdot*mdot_func(r,r_ref) ! r_ref is the radius for which mdot_fund = mdot ! !-- How many particles do we need to inject? @@ -212,9 +213,14 @@ subroutine write_options_inject(iunit) call write_inopt(npartperorbit,'npartperorbit',& 'particle injection rate in particles/binary orbit',iunit) call write_inopt(vlag,'vlag','percentage lag in velocity of wind',iunit) - call write_inopt(mdot_type,'mdot_type','injection rate (0=const, 1=cos(t), 2=r^(-2))',iunit) + call write_inopt(mdot_type,'mdot_type','injection rate (0=const, 2=r^(-2))',iunit) + if (mdot_type==2) then + call write_inopt(r_ref,'r_ref','radius at whieh Mdot=mdot for 1/r^2 injection type',iunit) + endif call write_inopt(random_type, 'random_type', 'random position on the surface, 0 for random, 1 for gaussian', iunit) - call write_inopt(delta_theta, 'delta_theta', 'standard deviation for the gaussion distribution (random_type=1)', iunit) + if (random_type==1) then + call write_inopt(delta_theta, 'delta_theta', 'standard deviation for the gaussion distribution', iunit) + endif end subroutine write_options_inject @@ -247,6 +253,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) case('mdot_type') read(valstring,*,iostat=ierr) mdot_type ngot = ngot + 1 + case('r_ref') + read(valstring,*,iostat=ierr) r_ref + ngot = ngot + 1 case('random_type') read(valstring,*,iostat=ierr) random_type ngot = ngot + 1 From fe823e9de188e004e9c04b1d5425c046d43e9c2c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 20:14:33 +1000 Subject: [PATCH 764/814] (ptmass/viscosity) minor formatting; subroutine purposes added --- src/main/ptmass.F90 | 35 +++++++++++++++++++++++++++++------ src/main/viscosity.f90 | 1 - 2 files changed, 29 insertions(+), 7 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 30964e48d..2f79f2738 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1639,6 +1639,11 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote end subroutine ptmass_create +!------------------------------------------------------------------------- +!+ +! subroutine to create a bundh of star "seeds" inside a sink particle +!+ +!------------------------------------------------------------------------- subroutine ptmass_create_seeds(nptmass,itest,xyzmh_ptmass,linklist_ptmass,time) use part, only:itbirth,ihacc use random, only:ran2 @@ -1675,7 +1680,13 @@ subroutine ptmass_create_seeds(nptmass,itest,xyzmh_ptmass,linklist_ptmass,time) end subroutine ptmass_create_seeds -subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time) +!------------------------------------------------------------------------- +!+ +! subroutine to create a bundh of stars inside a sink particle +!+ +!------------------------------------------------------------------------- +subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,& + fxyz_ptmass_sinksink,linklist_ptmass,time) use dim, only:maxptmass use physcon, only:solarm,pi use io, only:iprint,iverbose @@ -1923,22 +1934,34 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklis end subroutine merge_sinks +!----------------------------------------------------------------------- +!+ +! helper routine for managing the sink particle linked list +!+ +!----------------------------------------------------------------------- subroutine ptmass_endsize_lklist(i,k,n,linklist_ptmass) integer, intent(in) :: linklist_ptmass(:) integer, intent(in) :: i integer, intent(out) :: k,n integer :: l,g - g=i + + g = i n = 0 do while (g>0) l = g g = linklist_ptmass(l) n = n + 1 enddo - k=l -end subroutine ptmass_endsize_lklist + k = l +end subroutine ptmass_endsize_lklist +!----------------------------------------------------------------------- +!+ +! Swap between leapfrog and 4th order forward sympletic integrator +! for evolving sink particles +!+ +!----------------------------------------------------------------------- subroutine set_integration_precision if (use_fourthorder) then @@ -2219,7 +2242,7 @@ subroutine write_options_ptmass(iunit) endif call write_inopt(h_soft_sinksink,'h_soft_sinksink','softening length between sink particles',iunit) call write_inopt(f_acc,'f_acc','particles < f_acc*h_acc accreted without checks',iunit) - if (gravity .and. icreate_sinks) then + if (gravity .and. icreate_sinks > 0) then call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) endif @@ -2333,5 +2356,5 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) endif end subroutine read_options_ptmass -!----------------------------------------------------------------------- + end module ptmass diff --git a/src/main/viscosity.f90 b/src/main/viscosity.f90 index 114165a0e..c5d17fbba 100644 --- a/src/main/viscosity.f90 +++ b/src/main/viscosity.f90 @@ -37,7 +37,6 @@ subroutine set_defaults_viscosity shearparam = 0.1 ! alphadisc (if irealvisc=2) or nu if irealvisc=1 bulkvisc = 0.0 ! bulk viscosity parameter in code units - return end subroutine set_defaults_viscosity !---------------------------------------------------------------- From 53756bd72b9567be1b1c4e047d8a2b87c5abb1c3 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 20:34:27 +1000 Subject: [PATCH 765/814] (cons2prim) improved comments/documentation --- src/main/cons2prim.f90 | 61 ++++++++++++++++++++++++++++-------------- 1 file changed, 41 insertions(+), 20 deletions(-) diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index a8bb68ffc..56878217a 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -6,9 +6,19 @@ !--------------------------------------------------------------------------! module cons2prim ! -! None +! Subroutines to swap between primitive variables needed on RHS of fluid +! equations (density,velocity,internal energy) and conserved/evolved +! variables on the LHS of the fluid equations (rho*,momentum,entropy) ! -! :References: None +! This is complicated in the GR code but also useful to structure +! things this way in the non-GR code, e.g. B/rho is the evolved variable +! while B is the "primitive" variable for magnetic field. Similarly +! sqrt(rho_d) is the evolved variable for dust species but the primitive +! variable is the dust mass fraction. +! +! :References: +! Liptai & Price (2019), MNRAS 485, 819-842 +! Ballabio et al. (2018), MNRAS 477, 2766-2771 ! ! :Owner: Elisabeth Borchert ! @@ -26,12 +36,14 @@ module cons2prim contains -!------------------------------------- -! -! Primitive to conservative routines -! -!------------------------------------- - +!---------------------------------------------------------------------- +!+ +! Primitive to conservative transform (for GR): +! Construct conserved variables (rho*,momentum,entropy) +! from the primitive/fluid rest frame variables +! (density,velocity,internal energy), for ALL particles +!+ +!---------------------------------------------------------------------- subroutine prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens) use part, only:isdead_or_accreted,ien_type,eos_vars,igasP,igamma,itemp use eos, only:gamma,ieos @@ -75,6 +87,12 @@ subroutine prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens) end subroutine prim2consall +!---------------------------------------------------------------------- +!+ +! Primitive to conservative transform (for GR): +! for a single SPH particle +!+ +!---------------------------------------------------------------------- subroutine prim2consi(xyzhi,metrici,vxyzui,dens_i,pri,tempi,pxyzui,use_dens,ien_type) use cons2primsolver, only:primitive2conservative use utils_gr, only:h2dens @@ -112,12 +130,13 @@ subroutine prim2consi(xyzhi,metrici,vxyzui,dens_i,pri,tempi,pxyzui,use_dens,ien_ end subroutine prim2consi -!--------------------------------------------- -! -! Conservative to primitive routines (for GR) -! -!--------------------------------------------- - +!---------------------------------------------------------------------- +!+ +! Conservative to primitive routines (for GR): +! Solve for primitive variables (density,velocity,internal energy) +! from the evolved/conservative variables (rho*,momentum,entropy) +!+ +!---------------------------------------------------------------------- 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,& @@ -165,12 +184,15 @@ subroutine cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) end subroutine cons2primall -!------------------------------------- -! -! Primitive variables from conservative variables +!----------------------------------------------------------------------------- +!+ +! Solve for primitive variables (v,u,P,B,dustfrac) from evolved variables +! (v,energy variable,B/rho,sqrt(rho*eps)) in the non-relativistic code ! -!------------------------------------- - +! In this case no "solver" is required, but we do need to call the +! equation of state to get the pressure +!+ +!----------------------------------------------------------------------------- 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,& @@ -347,7 +369,6 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& endif endif - end subroutine cons2prim_everything end module cons2prim From 2aa5493a58c262cf1482e2c28e62859dbb599002 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 31 Jul 2024 20:36:48 +1000 Subject: [PATCH 766/814] (cullendehnen) improved comments/documentation --- src/main/cullendehnen.f90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/main/cullendehnen.f90 b/src/main/cullendehnen.f90 index 5ebd2e7c9..b8c5d2946 100644 --- a/src/main/cullendehnen.f90 +++ b/src/main/cullendehnen.f90 @@ -42,6 +42,12 @@ pure real function get_alphaloc(divvdti,spsoundi,hi,xi_limiter,alphamin,alphamax end function get_alphaloc +!------------------------------------------------------------------------------- +!+ +! return the xi_limiter function used in the Cullen & Dehnen switch +! based on the spatial velocity gradients +!+ +!------------------------------------------------------------------------------- pure real function xi_limiter(dvdx) real(kind=4), intent(in) :: dvdx(9) real :: dvxdx,dvxdy,dvxdz,dvydx,dvydy,dvydz,dvzdx,dvzdy,dvzdz From 8d710c25e3f8f1ad621053f1ac3d6c4a11f3a791 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 31 Jul 2024 16:52:39 +0200 Subject: [PATCH 767/814] (subgroup) forgot to pu bin_info in a reduction clause when computing gas pert --- src/main/ptmass.F90 | 4 ++-- src/main/substepping.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 03247da9a..35a7df04d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -158,7 +158,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec use extern_geopot, only:get_geopot_force - use part, only:ipert + use part, only:ipert,isemi integer, intent(in) :: nptmass real, intent(in) :: xi,yi,zi,hi real, intent(inout) :: fxi,fyi,fzi,phi @@ -303,7 +303,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 (kappa .and. abs(bin_info(isemi,j))>tiny(f2)) then ! add perturbation for bin_info(ipert,j) = bin_info(ipert,j) + f2 endif diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 8104329a6..05333e117 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -975,7 +975,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! !$omp parallel default(none) & - !$omp shared(maxp,maxphase,wsub,bin_info) & + !$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) & @@ -987,7 +987,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$omp firstprivate(pmassi,itype) & !$omp reduction(min:dtextforcenew,dtphi2) & !$omp reduction(max:fonrmax) & - !$omp reduction(+:fxyz_ptmass,dsdt_ptmass) + !$omp reduction(+:fxyz_ptmass,dsdt_ptmass,bin_info) !$omp do do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then From 51f071aab74591294d2f4563162e3ce6f1d3c686 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 31 Jul 2024 16:45:44 +0100 Subject: [PATCH 768/814] More updates from upstream --- AUTHORS | 40 +- build/Makefile | 8 +- src/main/H2regions.f90 | 342 +++++++++++ src/main/checksetup.f90 | 36 +- src/main/config.F90 | 4 +- src/main/cons2prim.f90 | 9 +- src/main/cooling.f90 | 8 +- src/main/cooling_radapprox.f90 | 47 +- src/main/deriv.F90 | 1 + src/main/eos.f90 | 25 +- src/main/eos_HIIR.f90 | 125 ++++ src/main/evolve.F90 | 74 ++- src/main/force.F90 | 9 +- src/main/initial.F90 | 14 +- src/main/inject_BHL.f90 | 2 +- src/main/inject_asteroidwind.f90 | 2 +- src/main/part.F90 | 27 +- src/main/{phantom.F90 => phantom.f90} | 0 src/main/physcon.f90 | 1 + src/main/ptmass.F90 | 439 +++++++++++--- src/main/random.f90 | 55 +- src/main/readwrite_dumps_common.f90 | 14 +- src/main/readwrite_dumps_fortran.f90 | 25 +- src/main/readwrite_infile.F90 | 14 +- src/main/step_leapfrog.F90 | 12 +- src/main/subgroup.f90 | 117 +++- src/main/substepping.F90 | 97 +-- src/main/utils_deriv.f90 | 2 +- src/main/utils_sort.f90 | 260 +++++++- src/main/utils_timing.f90 | 16 +- src/main/writeheader.F90 | 12 +- src/setup/set_orbit.f90 | 30 - src/setup/set_star_utils.f90 | 3 +- src/setup/setup_bondi.f90 | 295 +++++++++ src/setup/setup_cluster.f90 | 104 +++- src/setup/setup_grdisc.F90 | 7 +- src/setup/setup_starcluster.f90 | 265 +++++++++ src/setup/setup_testparticles.f90 | 2 +- src/setup/setup_wind.f90 | 821 ++++++++++++++++++++++++++ src/tests/test_fastmath.f90 | 162 +++++ src/tests/test_gr.f90 | 557 +++++++++++++++++ src/tests/test_mpi.f90 | 100 ++++ src/tests/test_ptmass.f90 | 246 +++++++- src/tests/testsuite.F90 | 2 +- src/utils/struct_part.f90 | 8 +- 45 files changed, 4089 insertions(+), 350 deletions(-) create mode 100644 src/main/H2regions.f90 create mode 100644 src/main/eos_HIIR.f90 rename src/main/{phantom.F90 => phantom.f90} (100%) create mode 100644 src/setup/setup_bondi.f90 create mode 100644 src/setup/setup_starcluster.f90 create mode 100644 src/setup/setup_wind.f90 create mode 100644 src/tests/test_fastmath.f90 create mode 100644 src/tests/test_gr.f90 create mode 100644 src/tests/test_mpi.f90 diff --git a/AUTHORS b/AUTHORS index 9f44811cf..649e5eb20 100644 --- a/AUTHORS +++ b/AUTHORS @@ -13,12 +13,12 @@ David Liptai Lionel Siess Fangyi (Fitz) Hu Daniel Mentiplay +Yrisch Megha Sharma Arnaud Vericel Mark Hutchison Mats Esseldeurs Rebecca Nealon -Yrisch Elisabeth Borchert Ward Homan Christophe Pinte @@ -26,48 +26,50 @@ Terrence Tricco Stephane Michoulier Simone Ceppi Spencer Magnall -Enrico Ragusa Caitlyn Hardiman +Enrico Ragusa Cristiano Longarini Sergei Biriukov Giovanni Dipierro Roberto Iaconi -Hauke Worpel Amena Faruqi +Hauke Worpel Alison Young Stephen Neilson <36410751+s-neilson@users.noreply.github.com> Martina Toscani Benedetta Veronesi -Thomas Reichardt Sahl Rowther Simon Glover +Thomas Reichardt Jean-François Gonzalez Christopher Russell -Phantom benchmark bot -Jolien Malfait -Alex Pettitt Alessia Franchini +Alex Pettitt +Jolien Malfait +Phantom benchmark bot Kieran Hirsh -Nicole Rodrigues Mike Lau -Nicolás Cuello -Farzana Meru +Nicole Rodrigues David Trevascus +Farzana Meru +Nicolás Cuello Chris Nixon Miguel Gonzalez-Bolivar -Maxime Lombart -Joe Fisher +Benoit Commercon Giulia Ballabio +Joe Fisher +Maxime Lombart +Orsola De Marco Zachary Pellow s-neilson <36410751+s-neilson@users.noreply.github.com> -Benoit Commercon -Orsola De Marco -MICHOULIER Stephane -Stéven Toupin -Taj Jankovič +Ariel Chitan +Chunliang Mu Cox, Samuel -Jeremy Smallwood Hugh Griffiths -Chunliang Mu +Jeremy Smallwood Jorge Cuadra +MICHOULIER Stephane Steven Rieder +Stéven Toupin +Taj Jankovič +rebeccagmartin <74937128+rebeccagmartin@users.noreply.github.com> diff --git a/build/Makefile b/build/Makefile index 1ad43de54..423141b05 100644 --- a/build/Makefile +++ b/build/Makefile @@ -506,7 +506,7 @@ SRCCHEM= fs_data.f90 mol_data.f90 utils_spline.f90 \ # equations of state # 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_HIIR.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 @@ -536,7 +536,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} ${SRCINJECT} \ - utils_subgroup.f90 utils_kepler.f90 subgroup.f90\ + H2regions.f90 utils_subgroup.f90 utils_kepler.f90 subgroup.f90 \ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ @@ -631,7 +631,7 @@ OBJDUMP= $(OBJDUMP1:.F90=.o) # must NOT contain .F90 files or pre-processing options # LIBSETUP=$(BINDIR)/libphantomsetup.a -SRCLIBSETUP=physcon.f90 geometry.f90 random.f90 utils_tables.f90 utils_vectors.f90 stretchmap.f90 \ +SRCLIBSETUP=physcon.f90 geometry.f90 utils_sort.f90 random.f90 utils_tables.f90 utils_vectors.f90 stretchmap.f90 \ utils_binary.f90 set_binary.f90 set_flyby.f90 \ set_hierarchical_utils.f90 \ set_unifdis.f90 set_sphere.f90 set_shock.f90 \ @@ -869,7 +869,7 @@ pyanalysis: libphantom.so # .PHONY: phantom2struct phantom2struct: - ${MAKE} phantomanalysis ANALYSIS="utils_timing.f90 io_structurefn.f90 random.f90 struct_part.f90 analysis_structurefn.f90"\ + ${MAKE} phantomanalysis ANALYSIS="utils_timing.f90 io_structurefn.f90 utils_sort.f90 random.f90 struct_part.f90 analysis_structurefn.f90"\ ANALYSISBIN=$@ ANALYSISONLY=yes cleanphantom2struct: diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 new file mode 100644 index 000000000..8d81b4a12 --- /dev/null +++ b/src/main/H2regions.f90 @@ -0,0 +1,342 @@ +!--------------------------------------------------------------------------! +! 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 HIIRegion +! +! HIIRegion +! +! :References: Fujii et al. (2021), Hopkins et al. (2012) +! +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: dim, eos, infile_utils, io, linklist, part, physcon, +! sortutils, timing, units +! +! contains routines to model HII region expansion due to ionization and radiation pressure.. +! routine originally made by Hopkins et al. (2012),reused by Fujii et al. (2021) +! and adapted in Phantom by Yann Bernard + + implicit none + + public :: update_ionrates,update_ionrate, HII_feedback,initialize_H2R,read_options_H2R,write_options_H2R + + integer, parameter, public :: HIIuprate = 8 ! update rate when IND_TIMESTEPS=yes + integer, public :: iH2R = 0 + real , public :: Rmax = 15 ! Maximum HII region radius (pc) to avoid artificial expansion... + real , public :: Mmin = 8 ! Minimum mass (Msun) to produce HII region + integer, public :: nHIIsources = 0 + real , public :: ar + real , public :: mH + + real, parameter :: a = -39.3178 ! + real, parameter :: b = 221.997 ! fitted parameters to compute + real, parameter :: c = -227.456 ! ionisation rate for massive + real, parameter :: d = 117.410 ! extracted from Fujii et al. (2021). + real, parameter :: e = -30.1511 ! (Expressed in function of log(solar masses) and s) + real, parameter :: f = 3.06810 ! + real, parameter :: ar_cgs = 2.7d-13 + real, parameter :: sigd_cgs = 1.d-21 + real :: sigd + real :: hv_on_c + real :: Tion + real :: Rst_max + real :: Minmass + real :: uIon + + private + +contains + + !----------------------------------------------------------------------- + !+ + ! Initialise stellar feedbacks + !+ + !----------------------------------------------------------------------- +subroutine initialize_H2R + use io, only:iprint,iverbose,id,master + use part, only:isionised + use units, only:udist,umass,utime + use physcon, only:mass_proton_cgs,kboltz,pc,eV,solarm + use eos , only:gmw,gamma + isionised(:)=.false. + !calculate the useful constant in code units + mH = gmw*mass_proton_cgs + Tion = 1.e4 + ar = ar_cgs*(utime/udist**3) + sigd = sigd_cgs*udist**2 + hv_on_c = ((18.6*eV)/2.997924d10)*(utime/(udist*umass)) + Rst_max = sqrt(((Rmax*pc)/udist)**2) + Minmass = (Mmin*solarm)/umass + if (gamma>1.) then + uIon = kboltz*Tion/(mH*(gamma-1.))*(utime/udist)**2 + else + uIon = 1.5*(kboltz*Tion/(mH))*(utime/udist)**2 + endif + + mH = mH/umass + + if (id == master .and. iverbose > 1) then + write(iprint,"(a,es18.10,es18.10)") " feedback constants mH,uIon : ", mH,uIon + write(iprint,"(a,es18.10,es18.10)") " Max strögrem radius (code/pc) : ", Rst_max, Rmax + write(iprint,"(a,es18.10,es18.10)") " Min feedback mass (code/Msun) : ", Minmass, Mmin + endif + return +end subroutine initialize_H2R + +!----------------------------------------------------------------------- +!+ +! Calculation of the the ionizing photon rate of all stars (Only for restart) +!+ +!----------------------------------------------------------------------- + +subroutine update_ionrates(nptmass,xyzmh_ptmass,h_acc) + use io, only:iprint,iverbose + use units, only:umass + use part, only:irateion,ihacc,irstrom + use physcon,only:solarm + integer, intent(in) :: nptmass + real, intent(inout) :: xyzmh_ptmass(:,:) + real, intent(in) :: h_acc + real :: logmi,log_Q,mi,hi + integer :: i + nHIIsources = 0 + !$omp parallel do default(none) & + !$omp shared(xyzmh_ptmass,iprint,iverbose,umass)& + !$omp shared(Minmass,h_acc,nptmass)& + !$omp private(logmi,log_Q,mi,hi)& + !$omp reduction(+:nHIIsources) + do i=1,nptmass + mi = xyzmh_ptmass(4,i) + hi = xyzmh_ptmass(ihacc,i) + if (mi > Minmass .and. hi < h_acc) then + logmi = log10(mi*(umass/solarm)) + ! caluclation of the ionizing photon rate of each sources + ! this calculation uses Fujii's formula derived from OSTAR2002 databases + log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) + xyzmh_ptmass(irateion,i) = log_Q + xyzmh_ptmass(irstrom,i) = -1. + nHIIsources = nHIIsources + 1 + if (iverbose >= 0) then + write(iprint,"(/a,es18.10,es18.10/)")"Massive stars detected : Log Q, Mass : ",log_Q,mi + endif + else + xyzmh_ptmass(irateion,i) = -1. + xyzmh_ptmass(irstrom,i) = -1. + endif + enddo + !$omp end parallel do + if (iverbose > 1) then + write(iprint,"(/a,i8/)") "nb_feedback sources : ",nHIIsources + endif + return +end subroutine update_ionrates + +subroutine update_ionrate(i,xyzmh_ptmass,h_acc) + use io, only:iprint,iverbose + use units, only:umass + use part, only:irateion,ihacc,irstrom + use physcon,only:solarm + integer, intent(in) :: i + real, intent(inout) :: xyzmh_ptmass(:,:) + real, intent(in) :: h_acc + real :: logmi,log_Q,mi,hi + mi = xyzmh_ptmass(4,i) + hi = xyzmh_ptmass(ihacc,i) + if (mi > Minmass .and. hi < h_acc) then + logmi = log10(mi*(umass/solarm)) + ! caluclation of the ionizing photon rate of each sources + ! this calculation uses Fujii's formula derived from OSTAR2002 databases + log_Q = (a+b*logmi+c*logmi**2+d*logmi**3+e*logmi**4+f*logmi**5) + xyzmh_ptmass(irateion,i) = log_Q + xyzmh_ptmass(irstrom,i) = -1. + nHIIsources = nHIIsources + 1 + if (iverbose >= 0) then + write(iprint,"(/a,es18.10,es18.10/)")"Massive stars detected : Log Q, Mass : ",log_Q,mi + endif + else + xyzmh_ptmass(irateion,i) = -1. + xyzmh_ptmass(irstrom,i) = -1. + endif + + if (iverbose > 1) then + write(iprint,"(/a,i8/)") "nb_feedback sources : ",nHIIsources + endif + return +end subroutine update_ionrate + + !----------------------------------------------------------------------- + !+ + ! Main subroutine : Application of the HII feedback using Hopkins's like prescription + !+ + !----------------------------------------------------------------------- + +subroutine HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised,dt) + use part, only:rhoh,massoftype,ihsoft,igas,irateion,isdead_or_accreted,& + irstrom + use linklist, only:listneigh=>listneigh_global,getneigh_pos,ifirstincell + use sortutils, only:Knnfunc,set_r2func_origin,r2func_origin + use physcon, only:pc,pi + use timing, only:get_timings,increment_timer,itimer_HII + use dim, only:maxvxyzu + use units, only:utime + integer, intent(in) :: nptmass,npart + real, intent(in) :: xyzh(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyzu(:,:) + logical, intent(inout) :: isionised(:) + real, optional, intent(in) :: dt + integer, parameter :: maxcache = 12000 + real, save :: xyzcache(maxcache,3) + integer :: i,k,j,npartin,nneigh + real(kind=4) :: t1,t2,tcpu1,tcpu2 + real :: pmass,Ndot,DNdot,logNdiff,taud,mHII,r,r_in,hcheck + real :: xi,yi,zi,log_Qi,stromi,xj,yj,zj,dx,dy,dz,vkx,vky,vkz + logical :: momflag + + momflag = .false. + r = 0. + r_in = 0. + + if (present(dt)) momflag = .true. + + ! at each new kick we reset all the particles status + isionised(:) = .false. + pmass = massoftype(igas) + + call get_timings(t1,tcpu1) + ! + !-- Rst derivation and thermal feedback + ! + if (nHIIsources > 0) then + do i=1,nptmass + npartin=0 + log_Qi = xyzmh_ptmass(irateion,i) + if (log_Qi <=0.) cycle + Ndot = log_Qi ! instead of working with very large number, we'll work in logspace now + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + stromi = xyzmh_ptmass(irstrom,i) + if (stromi >= 0. ) then + hcheck = 1.4*stromi + 0.01*Rmax + else + hcheck = Rmax + endif + do while(hcheck <= Rmax) + call getneigh_pos((/xi,yi,zi/),0.,hcheck,3,listneigh,nneigh,xyzh,xyzcache,maxcache,ifirstincell) + call set_r2func_origin(xi,yi,zi) + call Knnfunc(nneigh,r2func_origin,xyzh,listneigh) !! Here still serial version of the quicksort. Parallel version in prep.. + if (nneigh > 0) exit + hcheck = hcheck + 0.01*Rmax ! additive term to allow unresolved case to open + enddo + do k=1,nneigh + j = listneigh(k) + if (.not. isdead_or_accreted(xyzh(4,j))) then + ! ionising photons needed to fully ionise the current particle + DNdot = log10((((pmass*ar*rhoh(xyzh(4,j),pmass))/(mH**2))/utime)) + if (Ndot>DNdot) then + if (.not.(isionised(j))) then + logNdiff = DNdot -Ndot + Ndot = Ndot + log10(1-10**(logNdiff)) + isionised(j)=.true. + if (maxvxyzu >= 4) vxyzu(4,j) = uIon + endif + else + if (k > 1) then + ! end of the HII region + r = sqrt((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) + j = listneigh(1) + else + ! unresolved case + r = 0. + endif + exit + endif + endif + enddo + npartin = k + xyzmh_ptmass(irstrom,i) = r + ! + !-- Momentum feedback + ! + if (momflag .and. npartin > 3) then + j = listneigh(1) + r_in = sqrt((xi-xyzh(1,j))**2 + (yi-xyzh(2,j))**2 + (zi-xyzh(3,j))**2) + mHII = ((4.*pi*(r**3-r_in**3)*rhoh(xyzh(4,j),pmass))/3) + if (mHII>3*pmass) then +!$omp parallel do default(none) & +!$omp shared(mHII,listneigh,xyzh,sigd,dt) & +!$omp shared(mH,vxyzu,log_Qi,hv_on_c,npartin,pmass,xi,yi,zi) & +!$omp private(j,dx,dy,dz,vkx,vky,vkz,xj,yj,zj,r,taud) + do k=1,npartin + j = listneigh(1) + xj = xyzh(1,j) + yj = xyzh(2,j) + zj = xyzh(3,j) + dx = xj - xi + dy = yj - yi + dz = zj - zi + r = dx**2 + dy**2 + dz**2 + taud = (rhoh(xyzh(4,j),pmass)/mH)*sigd*r + if (taud > 1.97) taud=1.97 + vkz = (1.+1.5*exp(-taud))*((10**log_Qi)/mHII)*hv_on_c*(dz/r) + vkx = (1.+1.5*exp(-taud))*((10**log_Qi)/mHII)*hv_on_c*(dx/r) + vky = (1.+1.5*exp(-taud))*((10**log_Qi)/mHII)*hv_on_c*(dy/r) + vxyzu(1,j) = vxyzu(1,j) + vkx*dt + vxyzu(2,j) = vxyzu(2,j) + vky*dt + vxyzu(3,j) = vxyzu(3,j) + vkz*dt + enddo +!$omp end parallel do + endif + endif + enddo + endif + call get_timings(t2,tcpu2) + call increment_timer(itimer_HII,t2-t1,tcpu2-tcpu1) + return +end subroutine HII_feedback + +subroutine write_options_H2R(iunit) + use infile_utils, only:write_inopt + use physcon, only:solarm + integer, intent(in) :: iunit + write(iunit,"(/,a)") '# options controlling HII region expansion feedback' + if (iH2R>0) then + call write_inopt(iH2R, 'iH2R', "enable the HII region expansion feedback in star forming reigon", iunit) + call write_inopt(Mmin, 'Mmin', "Minimum star mass to trigger HII region (MSun)", iunit) + call write_inopt(Rmax, 'Rmax', "Maximum radius for HII region (pc)", iunit) + endif +end subroutine write_options_H2R + +subroutine read_options_H2R(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_H2R' + imatch = .true. + select case(trim(name)) + case('iH2R') + read(valstring,*,iostat=ierr) iH2R + if (iH2R < 0) call fatal(label,'HII region option out of range') + ngot = ngot + 1 + case('Mmin') + read(valstring,*,iostat=ierr) Mmin + if (Mmin < 8.) call fatal(label,'Minimimum mass can not be inferior to 8 solar masses') + ngot = ngot + 1 + case('Rmax') + read(valstring,*,iostat=ierr) Rmax + if (Rmax < 10.) call fatal(label,'Maximum radius can not be inferior to 10 pc') + ngot = ngot + 1 + case default + imatch = .true. + end select + igotall = (ngot >= 3) +end subroutine read_options_H2R + +end module HIIRegion diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 9ab68cacf..61827b35b 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -14,9 +14,9 @@ module checksetup ! ! :Runtime parameters: None ! -! :Dependencies: boundary, boundary_dyn, centreofmass, dim, dust, eos, -! externalforces, io, metric_tools, nicil, options, part, physcon, -! ptmass, ptmass_radiation, sortutils, timestep, units, utils_gr +! :Dependencies: HIIRegion, boundary, boundary_dyn, centreofmass, dim, +! dust, eos, externalforces, io, metric_tools, nicil, options, part, +! physcon, ptmass, ptmass_radiation, sortutils, timestep, units, utils_gr ! implicit none public :: check_setup @@ -105,7 +105,7 @@ subroutine check_setup(nerror,nwarn,restart) nerror = nerror + 1 endif else - if (polyk < tiny(0.) .and. ieos /= 2 .and. ieos /= 5 .and. ieos /= 17) then + if (polyk < tiny(0.) .and. ieos /= 2 .and. ieos /= 5 .and. ieos /= 17 .and. ieos/= 22) then print*,'WARNING! polyk = ',polyk,' in setup, speed of sound will be zero in equation of state' nwarn = nwarn + 1 endif @@ -239,7 +239,7 @@ subroutine check_setup(nerror,nwarn,restart) nerror = nerror + 1 endif else - if (abs(gamma-1.) > tiny(gamma) .and. (ieos /= 2 .and. ieos /= 5 .and. ieos /=9 .and. ieos /= 17)) then + if (abs(gamma-1.) > tiny(gamma) .and. (ieos /= 2 .and. ieos /= 5 .and. ieos /=9 .and. ieos /= 17 .and. ieos /=22)) then print*,'*** ERROR: using isothermal EOS, but gamma = ',gamma gamma = 1. print*,'*** Resetting gamma to 1, gamma = ',gamma @@ -437,6 +437,10 @@ subroutine check_setup(nerror,nwarn,restart) !--check Regularization imcompatibility ! call check_regnbody (nerror) +! +!--check HII region expansion feedback +! + call check_HIIRegion (nerror) if (.not.h2chemistry .and. maxvxyzu >= 4 .and. icooling == 3 .and. iexternalforce/=iext_corotate .and. nptmass==0) then if (dot_product(xcom,xcom) > 1.e-2) then @@ -528,7 +532,7 @@ end function in_range subroutine check_setup_ptmass(nerror,nwarn,hmin) use dim, only:maxptmass use part, only:nptmass,xyzmh_ptmass,ihacc,ihsoft,gr,iTeff,sinks_have_luminosity,& - ilum,iJ2,ispinx,ispinz,iReff + ilum,iJ2,ispinx,ispinz,iReff,linklist_ptmass use ptmass_radiation, only:isink_radiation use ptmass, only:use_fourthorder integer, intent(inout) :: nerror,nwarn @@ -587,6 +591,7 @@ subroutine check_setup_ptmass(nerror,nwarn,hmin) print*,' ERROR: sink ',i,' mass = ',xyzmh_ptmass(4,i) elseif (xyzmh_ptmass(4,i) < 0.) then print*,' Sink ',i,' has previously merged with another sink' + print*,' Connected to sink : ',linklist_ptmass(i) n = n + 1 endif enddo @@ -1045,5 +1050,24 @@ subroutine check_regnbody (nerror) endif end subroutine check_regnbody +subroutine check_HIIRegion(nerror) + use HIIRegion, only:iH2R + use eos, only:ieos + use dim, only:gr,mpi + integer, intent(inout) :: nerror + if (iH2R > 0 .and. ieos/=21 .and. ieos/=22) then + print "(/,a,/)", "Error: If HII activated, eos == 21 or 22 is mandatory..." + nerror = nerror + 1 + endif + if (iH2R > 0 .and. gr) then + print "(/,a,/)", "Error: Gr is not compatible with HII Region" + nerror = nerror + 1 + endif + if (iH2R > 0 .and. mpi) then + print "(/,a,/)", "Error: MPI is not compatible with HII Region" + nerror = nerror + 1 + endif +end subroutine check_HIIRegion + end module checksetup diff --git a/src/main/config.F90 b/src/main/config.F90 index 5acb64234..97b13a132 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -42,7 +42,9 @@ module dim #else integer, parameter :: maxptmass = 1000 #endif - integer, parameter :: nsinkproperties = 19 + integer, parameter :: nsinkproperties = 22 + + logical :: store_ll_ptmass = .false. ! storage of thermal energy or not #ifdef ISOTHERMAL diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 261b5a24f..915c219fa 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -175,7 +175,7 @@ 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 + ndustsmall,itemp,ikappa,idmu,idgamma,icv,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 @@ -215,7 +215,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& !$omp parallel do default (none) & !$omp shared(xyzh,vxyzu,npart,rad,eos_vars,radprop,Bevol,Bxyz) & !$omp shared(ieos,nucleation,nden_nimhd,eta_nimhd) & -!$omp shared(alpha,alphamax,iphase,maxphase,maxp,massoftype) & +!$omp shared(alpha,alphamax,iphase,maxphase,maxp,massoftype,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) & @@ -274,10 +274,11 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& uui = vxyzu(4,i) if (uui < 0.) call warning('cons2prim','Internal energy < 0',i,'u',uui) 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) + gamma_local=gammai,mu_local=mui,Xlocal=X_i,Zlocal=Z_i,isionised=isionised(i)) else !isothermal - call equationofstate(ieos,p_on_rhogas,spsound,rhogas,xi,yi,zi,temperaturei,mu_local=mui) + call equationofstate(ieos,p_on_rhogas,spsound,rhogas,xi,yi,zi,temperaturei,mu_local=mui, & + isionised=isionised(i)) endif eos_vars(igasP,i) = p_on_rhogas*rhogas diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index d333810e8..1952563f7 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -132,7 +132,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) +subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2_in,kappa_in,abund_in,ipart) use io, only:fatal use dim, only:nabundances use eos, only:gmw,gamma,ieos,get_temperature_from_u @@ -143,11 +143,13 @@ 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 + 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) + integer,intent(in),optional:: ipart real, intent(out) :: dudt ! in code units real :: mui,gammai,Tgas,Tdust,K2,kappa real :: abundi(nabn) @@ -184,6 +186,8 @@ subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2 call cooling_Gammie_explicit(xi,yi,zi,ui,dudt) 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) 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 b8b869f39..62dc0eb02 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -64,24 +64,22 @@ end subroutine init_star ! Do cooling calculation ! ! update energy to return evolved energy array. Called from substep -subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,Tfloor) +subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) 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,rhoh,massoftype,igas - use timestep_ind, only:get_dt + use part, only:xyzmh_ptmass,igas integer,intent(in) :: i - integer(kind=1),intent(in) :: ibini - real,intent(in) :: xyzhi(:),dtsph,Tfloor - real,intent(inout) :: ui - real :: dti,rhoi,coldensi,kappaBari,kappaParti,ri2 + real,intent(in) :: xi,yi,zi,rhoi,Tfloor + real,intent(in) :: ui,dt + 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 :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi - dti = get_dt(dtsph,ibini) coldensi = huge(coldensi) poti = Gpot_cool(i) du_FLDi = duFLD(i) @@ -91,14 +89,13 @@ subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,Tfloor) tthermi = huge(tthermi) opaci = epsilon(opaci) if (abs(ui) < epsilon(ui)) print *, "ui zero", i - rhoi = rhoh(xyzhi(4),massoftype(igas)) - + if (isink_star > 0) then - ri2 = (xyzhi(1)-xyzmh_ptmass(1,isink_star))**2d0 & - + (xyzhi(2)-xyzmh_ptmass(2,isink_star))**2d0 & - + (xyzhi(3)-xyzmh_ptmass(3,isink_star))**2d0 + ri2 = (xi-xyzmh_ptmass(1,isink_star))**2d0 & + + (yi-xyzmh_ptmass(2,isink_star))**2d0 & + + (zi-xyzmh_ptmass(3,isink_star))**2d0 else - ri2 = xyzhi(1)**2d0 + xyzhi(2)**2d0 + xyzhi(3)**2d0 + ri2 = xi**2d0 + yi**2d0 + zi**2d0 endif ! get opacities & Ti for ui @@ -164,11 +161,11 @@ subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,Tfloor) ! 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(dudti_rad/du_tot) < dtcool_crit) then + + 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) - ui = ui + du_tot*dti - if (ui < umini) ui = umini + dudti_cool = du_tot return endif @@ -186,7 +183,7 @@ subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,Tfloor) 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)*dti + "dudt_sph * dti=", dusph(i)*dt elseif (Teqi < epsilon(Teqi)) then print *, "Teqi=0.0", "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& "Ti=", Ti, "poti=",poti, "rhoi=", rhoi @@ -209,21 +206,21 @@ subroutine radcool_update_energ(i,ibini,dtsph,xyzhi,ui,Tfloor) ! evolve energy if (tthermi == 0d0) then - ui = ui ! condition if denominator above is zero - elseif ( (dti/tthermi) < TINY(ui) ) then - ui = ui + dudti_cool = 0d0 ! condition if denominator above is zero + elseif ( (dt/tthermi) < TINY(ui) ) then + dudti_cool = 0d0 else - ui = ui*exp(-dti/tthermi) + ueqi*(1.d0-exp(-dti/tthermi)) !code units + dudti_cool = ( ui*exp(-dt/tthermi) + ueqi*(1.d0-exp(-dt/tthermi)) - ui) / dt !code units endif - if (isnan(ui) .or. ui < epsilon(ui)) then + if (isnan(dudti_cool)) 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=",dti,"tthermi=", tthermi,"umini=", umini + print *, "dt=",dt,"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) + call warning("In Stamatellos cooling","energ=NaN or 0. ui=",val=ui) stop endif diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index 4bbab4bdf..d11d5ae4b 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -122,6 +122,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& call do_timing('link',tlast,tcpulast,start=.true.) + ! ! compute disruption of dust particles ! diff --git a/src/main/eos.f90 b/src/main/eos.f90 index a698fe23d..ef1a8293c 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -27,7 +27,7 @@ module eos ! 16 = Shen eos ! 17 = polytropic EOS with varying mu (depending on H2 formation) ! 20 = Ideal gas + radiation + various forms of recombination energy from HORMONE (Hirai et al., 2020) -! 21 = read tabulated eos (for use with icooling == 8) +! 21 = read tabulated eos (for use with icooling == 9) ! ! :References: ! Lodato & Pringle (2007) @@ -50,7 +50,7 @@ module eos use part, only:ien_etotal,ien_entropy,ien_type use dim, only:gr implicit none - integer, parameter, public :: maxeos = 21 + integer, parameter, public :: maxeos = 22 real, public :: polyk, polyk2, gamma real, public :: qfacdisc = 0.75, qfacdisc2 = 0.75 logical, public :: extract_eos_from_hdr = .false. @@ -104,7 +104,7 @@ module eos ! (and position in the case of the isothermal disc) !+ !---------------------------------------------------------------- -subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gamma_local,mu_local,Xlocal,Zlocal) +subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gamma_local,mu_local,Xlocal,Zlocal,isionised) use io, only:fatal,error,warning use part, only:xyzmh_ptmass, nptmass use units, only:unit_density,unit_pressure,unit_ergg,unit_velocity @@ -118,6 +118,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam use eos_barotropic, only:get_eos_barotropic use eos_piecewise, only:get_eos_piecewise use eos_stamatellos + use eos_HIIR, only:get_eos_HIIR_iso,get_eos_HIIR_adiab integer, intent(in) :: eos_type real, intent(in) :: rhoi,xi,yi,zi real, intent(out) :: ponrhoi,spsoundi @@ -125,6 +126,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam real, intent(in), optional :: eni real, intent(inout), optional :: mu_local,gamma_local real, intent(in) , optional :: Xlocal,Zlocal + logical, intent(in), optional :: isionised integer :: ierr, i real :: r1,r2 real :: mass_r, mass ! defined for generalised Farris prescription @@ -132,6 +134,8 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam real :: cgsrhoi,cgseni,cgspresi,presi,gam1,cgsspsoundi real :: uthermconst,kappaBar,kappaPart real :: enthi,pondensi + logical :: isionisedi + ! ! Check to see if equation of state is compatible with GR cons2prim routines ! @@ -149,7 +153,8 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam if (present(mu_local)) mui = mu_local if (present(Xlocal)) X_i = Xlocal if (present(Zlocal)) Z_i = Zlocal - + if (present(isionised)) isionisedi = isionised + select case(eos_type) case(1) ! @@ -426,6 +431,12 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam if (present(mu_local)) mu_local = 1./imui if (present(gamma_local)) gamma_local = gammai +! case(21) + ! call get_eos_HIIR_iso(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) + + case(22) + call get_eos_HIIR_adiab(polyk,temperature_coef,mui,tempi,ponrhoi,rhoi,eni,gammai,spsoundi,isionisedi) + case(21) ! !--interpolate tabulated eos from Stamatellos+(2007). For use with icooling=9 @@ -468,6 +479,7 @@ subroutine init_eos(eos_type,ierr) use eos_gasradrec, only:init_eos_gasradrec use eos_stamatellos,only:read_optab,init_S07cool,eos_file use dim, only:maxvxyzu,do_radiation + use eos_HIIR, only:init_eos_HIIR integer, intent(in) :: eos_type integer, intent(out) :: ierr integer :: ierr_mesakapp @@ -548,7 +560,10 @@ subroutine init_eos(eos_type,ierr) call read_optab(eos_file,ierr) if (ierr > 0) call fatal('init_eos','Failed to read EOS file',var='ierr',ival=ierr) call init_S07cool - + +! - case(21,22) + case(22) + call init_eos_HIIR() end select done_init_eos = .true. diff --git a/src/main/eos_HIIR.f90 b/src/main/eos_HIIR.f90 new file mode 100644 index 000000000..315d97734 --- /dev/null +++ b/src/main/eos_HIIR.f90 @@ -0,0 +1,125 @@ +!--------------------------------------------------------------------------! +! 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 eos_HIIR +! +! eos_HIIR +! +! :References: None +! +! :Owner: Yrisch +! +! :Runtime parameters: None +! +! :Dependencies: io, physcon, units +! + implicit none + + public :: get_eos_HIIR_iso,get_eos_HIIR_adiab,init_eos_HIIR + + real, parameter :: Tion = 10000. + real, parameter :: muioninv = 2. + real, parameter :: muion = 0.5 + + real, public :: polykion + + private + +contains + + !----------------------------------------------------------------------- + !+ + ! Init eos routine + !+ + !----------------------------------------------------------------------- + +subroutine init_eos_HIIR + use physcon, only:kb_on_mh + use units, only:unit_velocity + + polykion = (muioninv*kb_on_mh*Tion)/(unit_velocity**2) + + +end subroutine init_eos_HIIR + + + !----------------------------------------------------------------------- + !+ + ! Main eos routine (isothermal) + !+ + !----------------------------------------------------------------------- +subroutine get_eos_HIIR_iso(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) + real, intent(in) :: polyk,temperature_coef + real, intent(out) :: ponrhoi,spsoundi,mui,tempi + logical, intent(in) :: isionisedi + + ! + !--dual medium isothermal eos + ! + ! :math:`P = c_s^2 \rho` + ! + ! where :math:`c_s^2 \equiv K` is a constant stored in the dump file header + ! + if (isionisedi) then + ponrhoi = polykion + spsoundi = sqrt(ponrhoi) + tempi = Tion + else + ponrhoi = polyk + spsoundi = sqrt(ponrhoi) + tempi = temperature_coef*mui*ponrhoi + endif + + +end subroutine get_eos_HIIR_iso + + + !----------------------------------------------------------------------- + !+ + ! Main eos routine (adiabatic) + !+ + !----------------------------------------------------------------------- +subroutine get_eos_HIIR_adiab(polyk,temperature_coef,mui,tempi,ponrhoi,rhoi,eni,gammai,spsoundi,isionisedi) + use io, only:fatal + real, intent(in) :: polyk,temperature_coef,rhoi,gammai + real, intent(out) :: ponrhoi,spsoundi,mui,tempi + logical, intent(in) :: isionisedi + real, intent(in), optional :: eni + + + if (gammai < tiny(gammai)) call fatal('eos','gamma not set for adiabatic eos',var='gamma',val=gammai) + + + if (isionisedi) then + ponrhoi = polykion + spsoundi = sqrt(ponrhoi) + tempi = Tion + else + if (present(eni)) then + if (eni < 0.) then + !write(iprint,'(a,Es18.4,a,4Es18.4)')'Warning: eos: u = ',eni,' < 0 at {x,y,z,rho} = ',xi,yi,zi,rhoi + call fatal('eos','utherm < 0',var='u',val=eni) + endif + if (gammai > 1.0001) then + ponrhoi = (gammai-1.)*eni ! use this if en is thermal energy + else + ponrhoi = 2./3.*eni ! en is thermal energy and gamma = 1 + endif + else + ponrhoi = polyk*rhoi**(gammai-1.) + endif + spsoundi = sqrt(gammai*ponrhoi) + + tempi = temperature_coef*mui*ponrhoi + endif + + +end subroutine get_eos_HIIR_adiab + + + +end module eos_HIIR + diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 92c22f776..a5bf47b1d 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -16,12 +16,12 @@ module evolve ! ! :Runtime parameters: None ! -! :Dependencies: analysis, 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, readwrite_infile, -! step_lf_global, supertimestep, timestep, timestep_ind, timestep_sts, -! timing +! :Dependencies: HIIRegion, analysis, 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, +! readwrite_infile, step_lf_global, subgroup, substepping, supertimestep, +! timestep, timestep_ind, timestep_sts, timing ! implicit none public :: evol @@ -41,7 +41,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) 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 + use dim, only:maxvxyzu,mhd,periodic,idumpfile,ind_timesteps use fileutils, only:getnextfilename use options, only:nfulldump,twallmax,nmaxdumps,rhofinal1,iexternalforce,rkill use readwrite_infile, only:write_infile @@ -89,13 +89,19 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) #endif 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,& + linklist_ptmass,isionised,dsdt_ptmass,isdead_or_accreted + use part, only:n_group,n_ingroup,n_sing,group_info,nmatrix use quitdump, only:quit use ptmass, only:icreate_sinks,ptmass_create,ipart_rhomax,pt_write_sinkev,calculate_mdot, & - set_integration_precision + set_integration_precision,ptmass_create_stars,use_regnbody,ptmass_create_seeds,& + ipart_createseeds,ipart_createstars use io_summary, only:iosum_nreal,summary_counter,summary_printout,summary_printnow use externalforces, only:iext_spiral use boundary_dyn, only:dynamic_bdy,update_boundaries + use HIIRegion, only:HII_feedback,iH2R,HIIuprate + use subgroup, only:group_identify + use substepping, only:get_force #ifdef MFLOW use mf_write, only:mflow_write #endif @@ -137,6 +143,9 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) logical :: use_global_dt integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold character(len=120) :: dumpfile_orig + integer :: dummy,istepHII + + dummy = 0 tprint = 0. nsteps = 0 @@ -276,7 +285,49 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! creation of new sink particles ! call ptmass_create(nptmass,npart,ipart_rhomax,xyzh,vxyzu,fxyzu,fext,divcurlv,& - poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,dptmass,time) + poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,dptmass,time) + endif + + if (icreate_sinks == 2) then + ! + ! creation of new seeds into evolved sinks + ! + if (ipart_createseeds /= 0) then + call ptmass_create_seeds(nptmass,ipart_createseeds,xyzmh_ptmass,linklist_ptmass,time) + endif + ! + ! creation of new stars from sinks (cores) + ! + if (ipart_createstars /= 0) then + call ptmass_create_stars(nptmass,ipart_createstars,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink, & + linklist_ptmass,time) + endif + endif + + if (iH2R > 0 .and. id==master) then + istepHII = 1 + if(ind_timesteps) then + istepHII = 2**nbinmax/HIIuprate + if (istepHII==0) istepHII = 1 + endif + if (mod(istepfrac,istepHII)==0 .or. istepfrac==1 .or. (icreate_sinks == 2 .and. ipart_createstars /= 0)) then + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) + endif + endif + + ! Need to recompute the force when sink or stars are created + if (ipart_rhomax /= 0 .or. ipart_createseeds /= 0 .or. ipart_createstars /= 0) then + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& + fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,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) + endif + if (ipart_createseeds /= 0) ipart_createseeds = 0 ! reset pointer to zero + if (ipart_createstars /= 0) ipart_createstars = 0 ! reset pointer to zero + dummy = 0 endif ! ! Strang splitting: implicit update for half step @@ -284,6 +335,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (do_radiation .and. exchange_radiation_energy .and. .not.implicit_radiation) then call update_radenergy(npart,xyzh,fxyzu,vxyzu,rad,radprop,0.5*dt) endif + nsteps = nsteps + 1 ! !--evolve data for one timestep @@ -641,7 +693,7 @@ subroutine print_timinginfo(iprint,nsteps,nsteplast) use io, only:formatreal use timing, only:timer,timers,print_timer,itimer_fromstart,itimer_lastdump,& itimer_step,itimer_link,itimer_balance,itimer_dens,& - itimer_force,itimer_extf,itimer_ev,itimer_io,ntimers + itimer_force,itimer_ev,itimer_io,ntimers integer, intent(in) :: iprint,nsteps,nsteplast real :: dfrac,fracinstep real(kind=4) :: time_fullstep diff --git a/src/main/force.F90 b/src/main/force.F90 index aa5438914..9fcc9b849 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -213,8 +213,8 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& use kernel, only:kernel_softening use kdtree, only:expand_fgrav_in_taylor_series use linklist, only:get_distance_from_centre_of_mass - use part, only:xyzmh_ptmass,nptmass,massoftype,maxphase,is_accretable - use ptmass, only:icreate_sinks,rho_crit,r_crit2 + use part, only:xyzmh_ptmass,nptmass,massoftype,maxphase,is_accretable,ihacc + use ptmass, only:icreate_sinks,rho_crit,r_crit2,h_acc use units, only:unit_density #endif #ifdef DUST @@ -435,7 +435,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& !$omp private(iactivei,iamdusti,iamtypei) & !$omp private(dx,dy,dz,poti,fxi,fyi,fzi,potensoft0,dum,epoti) & !$omp shared(xyzmh_ptmass,nptmass) & -!$omp shared(rhomax,ipart_rhomax,icreate_sinks,rho_crit,r_crit2) & +!$omp shared(rhomax,ipart_rhomax,icreate_sinks,rho_crit,r_crit2,h_acc) & !$omp private(rhomax_thread,ipart_rhomax_thread,use_part,j) & #endif !$omp shared(id) & @@ -682,6 +682,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& ! use_part = .true. over_ptmass: do j=1,nptmass + if (icreate_sinks==2 .and. xyzmh_ptmass(ihacc,j) 0. .and. & (xyzh(1,i) - xyzmh_ptmass(1,j))**2 & + (xyzh(2,i) - xyzmh_ptmass(2,j))**2 & @@ -3005,7 +3006,7 @@ 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 = fxyz4 + if (icooling == 9) duSPH(i) = fxyz4 endif endif diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 4c9a97aa2..7b8f26032 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -14,7 +14,7 @@ module initial ! ! :Runtime parameters: None ! -! :Dependencies: analysis, boundary, boundary_dyn, centreofmass, +! :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, @@ -131,7 +131,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& nden_nimhd,dustevol,rhoh,gradh, & Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx, & - n_group,n_ingroup,n_sing,nmatrix,group_info + n_group,n_ingroup,n_sing,nmatrix,group_info,isionised use part, only:pxyzu,dens,metrics,rad,radprop,drad,ithick use densityforce, only:densityiterate use linklist, only:set_linklist @@ -212,7 +212,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use fileutils, only:make_tags_unique use damping, only:idamp - use subgroup, only:group_identify + use subgroup, only:group_identify,init_subgroup + use HIIRegion, only:iH2R,initialize_H2R,update_ionrates character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile logical, intent(in), optional :: noread @@ -496,10 +497,17 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) else rhofinal1 = 0.0 endif + if (iH2R > 0 .and. id==master) then + call initialize_H2R + else + isionised = .false. + endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass + if (iH2R > 0) call update_ionrates(nptmass,xyzmh_ptmass,h_acc) ! compute initial sink-sink forces and get timestep if (use_regnbody) then + call init_subgroup call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& iexternalforce,time,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) diff --git a/src/main/inject_BHL.f90 b/src/main/inject_BHL.f90 index a23162cc0..ae41283de 100644 --- a/src/main/inject_BHL.f90 +++ b/src/main/inject_BHL.f90 @@ -264,7 +264,7 @@ end subroutine inject_or_update_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_asteroidwind.f90 b/src/main/inject_asteroidwind.f90 index 37072a760..5e61737fe 100644 --- a/src/main/inject_asteroidwind.f90 +++ b/src/main/inject_asteroidwind.f90 @@ -152,7 +152,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/part.F90 b/src/main/part.F90 index 5b5ae5f18..d54c878e5 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -204,19 +204,24 @@ module part integer, parameter :: i_mlast = 17 ! accreted mass of last time integer, parameter :: imassenc = 18 ! mass enclosed in sink softening radius integer, parameter :: iJ2 = 19 ! 2nd gravity moment due to oblateness + integer, parameter :: irstrom = 20 ! Stromgren radius of the stars (icreate_sinks == 2) + integer, parameter :: irateion = 21 ! Inoisation rate of the stars (log)(icreate_sinks == 2) + integer, parameter :: itbirth = 22 ! birth time of the new sink integer, parameter :: ndptmass = 13 ! number of properties to conserve after a accretion phase or merge - real, allocatable :: xyzmh_ptmass(:,:) - real, allocatable :: vxyz_ptmass(:,:) - real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:),fsink_old(:,:) - real, allocatable :: dsdt_ptmass(:,:),dsdt_ptmass_sinksink(:,:) - real, allocatable :: dptmass(:,:) + integer, allocatable :: linklist_ptmass(:) + real, allocatable :: xyzmh_ptmass(:,:) + real, allocatable :: vxyz_ptmass(:,:) + real, allocatable :: fxyz_ptmass(:,:),fxyz_ptmass_sinksink(:,:),fsink_old(:,:) + real, allocatable :: dsdt_ptmass(:,:),dsdt_ptmass_sinksink(:,:) + real, allocatable :: dptmass(:,:) integer :: nptmass = 0 ! zero by default real :: epot_sinksink character(len=*), parameter :: xyzmh_ptmass_label(nsinkproperties) = & (/'x ','y ','z ','m ','h ',& 'hsoft ','maccreted','spinx ','spiny ','spinz ',& 'tlast ','lum ','Teff ','Reff ','mdotloss ',& - 'mdotav ','mprev ','massenc ','J2 '/) + 'mdotav ','mprev ','massenc ','J2 ','Rstrom ',& + 'rate_ion ','tbirth '/) character(len=*), parameter :: vxyz_ptmass_label(3) = (/'vx','vy','vz'/) ! !--self-gravity @@ -304,6 +309,10 @@ module part integer :: n_sing = 0 ! Gradient of the time transformation function real, allocatable :: gtgrad(:,:) + ! +!-- Regularisation algorithm allocation +! + logical, allocatable :: isionised(:) ! !--derivatives (only needed if derivs is called) ! @@ -449,6 +458,7 @@ subroutine allocate_part call allocate_array('fxyz_ptmass_sinksink', fxyz_ptmass_sinksink, 4, maxptmass) call allocate_array('fsink_old', fsink_old, 4, maxptmass) call allocate_array('dptmass', dptmass, ndptmass,maxptmass) + call allocate_array('linklist_ptmass', linklist_ptmass, maxptmass) call allocate_array('dsdt_ptmass', dsdt_ptmass, 3, maxptmass) call allocate_array('dsdt_ptmass_sinksink', dsdt_ptmass_sinksink, 3, maxptmass) call allocate_array('poten', poten, maxgrav) @@ -497,6 +507,7 @@ subroutine allocate_part call allocate_array('group_info', group_info, 3, maxptmass) call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) call allocate_array("gtgrad", gtgrad, 3, maxptmass) + call allocate_array('isionised', isionised, maxp) end subroutine allocate_part @@ -540,6 +551,7 @@ subroutine deallocate_part if (allocated(fxyz_ptmass_sinksink)) deallocate(fxyz_ptmass_sinksink) if (allocated(fsink_old)) deallocate(fsink_old) if (allocated(dptmass)) deallocate(dptmass) + if (allocated(linklist_ptmass)) deallocate(linklist_ptmass) if (allocated(dsdt_ptmass)) deallocate(dsdt_ptmass) if (allocated(dsdt_ptmass_sinksink)) deallocate(dsdt_ptmass_sinksink) if (allocated(poten)) deallocate(poten) @@ -580,6 +592,7 @@ subroutine deallocate_part if (allocated(group_info)) deallocate(group_info) if (allocated(nmatrix)) deallocate(nmatrix) if (allocated(gtgrad)) deallocate(gtgrad) + if (allocated(isionised)) deallocate(isionised) end subroutine deallocate_part @@ -597,10 +610,12 @@ subroutine init_part npartoftype(:) = 0 npartoftypetot(:) = 0 massoftype(:) = 0. + isionised(:) = .false. !--initialise point mass arrays to zero xyzmh_ptmass = 0. vxyz_ptmass = 0. dsdt_ptmass = 0. + linklist_ptmass = -1 ! initialise arrays not passed to setup routine to zero if (mhd) then diff --git a/src/main/phantom.F90 b/src/main/phantom.f90 similarity index 100% rename from src/main/phantom.F90 rename to src/main/phantom.f90 diff --git a/src/main/physcon.f90 b/src/main/physcon.f90 index 2577d5fd6..414ba9d14 100644 --- a/src/main/physcon.f90 +++ b/src/main/physcon.f90 @@ -92,6 +92,7 @@ module physcon real(kind=8), parameter :: hours = 3.6d3 real(kind=8), parameter :: days = 8.64d4 real(kind=8), parameter :: years = 3.1556926d7 + real(kind=8), parameter :: myr = 3.1556926d13 ! !--Energy conversion ! diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e75d1c29d..a5362c8a0 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -28,15 +28,18 @@ module ptmass ! - h_soft_sinkgas : *softening length for new sink particles* ! - h_soft_sinksink : *softening length between sink particles* ! - icreate_sinks : *allow automatic sink particle creation* +! - isink_potential : *sink potential(0=1/r,1=surf)* ! - r_crit : *critical radius for point mass creation (no new sinks < r_crit from existing sink)* ! - r_merge_cond : *sinks will merge if bound within this radius* ! - r_merge_uncond : *sinks will unconditionally merge within this separation* +! - r_neigh : *searching radius to detect subgroups* ! - rho_crit_cgs : *density above which sink particles are created (g/cm^3)* +! - use_regnbody : *allow subgroup integration method* ! -! :Dependencies: boundary, dim, eos, eos_barotropic, eos_piecewise, -! extern_geopot, externalforces, fastmath, infile_utils, io, io_summary, -! kdtree, kernel, linklist, mpidomain, mpiutils, options, part, -! ptmass_heating, units, vectorutils +! :Dependencies: HIIRegion, boundary, dim, eos, eos_barotropic, +! eos_piecewise, extern_geopot, externalforces, fastmath, infile_utils, +! io, io_summary, kdtree, kernel, linklist, mpidomain, mpiutils, options, +! part, physcon, ptmass_heating, random, subgroup, units, vectorutils ! use part, only:nsinkproperties,gravity,is_accretable,& ihsoft,ihacc,ispinx,ispiny,ispinz,imacc,iJ2,iReff @@ -50,6 +53,7 @@ module ptmass public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured public :: ptmass_accrete, ptmass_create + public :: ptmass_create_stars,ptmass_create_seeds public :: write_options_ptmass, read_options_ptmass public :: update_ptmass public :: calculate_mdot @@ -58,12 +62,17 @@ module ptmass public :: set_integration_precision ! settings affecting routines in module (read from/written to input file) - integer, public :: icreate_sinks = 0 + integer, public :: icreate_sinks = 0 ! 1-standard sink creation scheme 2-Star formation scheme using core prescription + integer, public :: iseed_sf = 313 ! seed used to sample random value for icreate == 2 prescription... + integer, public :: ipart_createstars = 0 ! particle id that needs to create stars after reaching tmax_acc + integer, public :: ipart_createseeds = 0 ! particle id that needs to create seeds after reaching tseeds integer, public :: isink_potential = 0 real, public :: rho_crit_cgs = 1.e-10 real, public :: r_crit = 5.e-3 real, public :: h_acc = 1.e-3 real, public :: f_acc = 0.8 + real, public :: tmax_acc = huge(f_acc) + real, public :: tseeds = huge(f_acc) real, public :: h_soft_sinkgas = 0.0 real, public :: h_soft_sinksink = 0.0 real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch @@ -324,7 +333,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec - use part, only:igarg,igid + use part, only:igarg,igid,ihacc integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(out) :: fxyz_ptmass(4,nptmass) @@ -336,7 +345,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real, optional, intent(in) :: extrapfac real, optional, intent(in) :: fsink_old(4,nptmass) integer, optional, intent(in) :: group_info(3,nptmass) - real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii + real :: 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 real :: fextx,fexty,fextz,phiext !,hsofti @@ -383,8 +392,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info,subsys) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & - !$omp shared(extrapfac,extrap,fsink_old) & - !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & + !$omp shared(extrapfac,extrap,fsink_old,h_acc,icreate_sinks) & + !$omp private(i,j,xi,yi,zi,pmassi,pmassj,hacci,haccj) & !$omp private(gidi,gidj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & @@ -410,7 +419,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin zi = xyzmh_ptmass(3,i) endif pmassi = xyzmh_ptmass(4,i) - !hsofti = xyzmh_ptmass(5,i) + hacci = xyzmh_ptmass(ihacc,i) if (pmassi < 0.) cycle J2i = xyzmh_ptmass(iJ2,i) @@ -440,7 +449,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dz = zi - xyzmh_ptmass(3,j) endif pmassj = xyzmh_ptmass(4,j) - !hsoftj = xyzmh_ptmass(5,j) + haccj = xyzmh_ptmass(ihacc,j) if (pmassj < 0.) cycle J2j = xyzmh_ptmass(iJ2,j) @@ -494,16 +503,32 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin endif endif if (rr2 < r_merge2) then - if (merge_ij(i)==0) then - merge_n = merge_n + 1 - merge_ij(i) = j + if (icreate_sinks == 2) then + if (hacci==h_acc .and. haccj==h_acc) then + if (merge_ij(i)==0) then + merge_n = merge_n + 1 + merge_ij(i) = j + else + ! if we have already identified a nearby sink, replace the tag with the nearest sink + dx = xi - xyzmh_ptmass(1,merge_ij(i)) + dy = yi - xyzmh_ptmass(2,merge_ij(i)) + dz = zi - xyzmh_ptmass(3,merge_ij(i)) + rr2j = dx*dx + dy*dy + dz*dz + epsilon(rr2j) + if (rr2 < rr2j) merge_ij(i) = j + endif + endif else - ! if we have already identified a nearby sink, replace the tag with the nearest sink - dx = xi - xyzmh_ptmass(1,merge_ij(i)) - dy = yi - xyzmh_ptmass(2,merge_ij(i)) - dz = zi - xyzmh_ptmass(3,merge_ij(i)) - rr2j = dx*dx + dy*dy + dz*dz + epsilon(rr2j) - if (rr2 < rr2j) merge_ij(i) = j + if (merge_ij(i)==0) then + merge_n = merge_n + 1 + merge_ij(i) = j + else + ! if we have already identified a nearby sink, replace the tag with the nearest sink + dx = xi - xyzmh_ptmass(1,merge_ij(i)) + dy = yi - xyzmh_ptmass(2,merge_ij(i)) + dz = zi - xyzmh_ptmass(3,merge_ij(i)) + rr2j = dx*dx + dy*dy + dz*dz + epsilon(rr2j) + if (rr2 < rr2j) merge_ij(i) = j + endif endif endif enddo @@ -600,22 +625,22 @@ subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,group_info,n_ingro integer, optional, intent(in) :: n_ingroup integer, optional, intent(in) :: group_info(:,:) integer :: i,k,istart_ptmass - logical :: woutsub + logical :: wsub if (present(n_ingroup)) then istart_ptmass = n_ingroup + 1 - woutsub = .true. + wsub = .true. else istart_ptmass = 1 - woutsub = .false. + wsub = .false. endif !$omp parallel do schedule(static) default(none) & !$omp shared(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) & - !$omp shared(n_ingroup,group_info,woutsub,istart_ptmass) & + !$omp shared(n_ingroup,group_info,wsub,istart_ptmass) & !$omp private(i,k) do k=istart_ptmass,nptmass - if (woutsub) then + if (wsub) then i = group_info(igarg,k) else i = k @@ -636,6 +661,7 @@ end subroutine ptmass_drift !+ !---------------------------------------------------------------- subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_ptmass) + use part, only:iJ2 integer, intent(in) :: nptmass real, intent(in) :: dkdt real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) @@ -652,9 +678,11 @@ subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_pt vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dkdt*fxyz_ptmass(1,i) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dkdt*fxyz_ptmass(2,i) vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dkdt*fxyz_ptmass(3,i) - xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) - xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) - xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) + if (xyzmh_ptmass(iJ2,i) > 0.) then + xyzmh_ptmass(ispinx,i) = xyzmh_ptmass(ispinx,i) + dkdt*dsdt_ptmass(1,i) + xyzmh_ptmass(ispiny,i) = xyzmh_ptmass(ispiny,i) + dkdt*dsdt_ptmass(2,i) + xyzmh_ptmass(ispinz,i) = xyzmh_ptmass(ispinz,i) + dkdt*dsdt_ptmass(3,i) + endif endif enddo !$omp end parallel do @@ -768,10 +796,10 @@ end function ptmass_not_obscured !---------------------------------------------------------------- subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & itypei,pmassi,xyzmh_ptmass,vxyz_ptmass,accreted, & - dptmass,time,facc,nbinmax,ibin_wakei,nfaili) + dptmass,linklist_ptmass,time,facc,nbinmax,ibin_wakei,nfaili) !$ use omputils, only:ipart_omp_lock - use part, only: ihacc,ndptmass + use part, only: ihacc,itbirth,ndptmass use kernel, only: radkern2 use io, only: iprint,iverbose,fatal use io_summary, only: iosum_ptmass,maxisink,print_acc @@ -780,6 +808,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & real, intent(inout) :: hi real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(in) :: vxyz_ptmass(3,nptmass) + integer, intent(in) :: linklist_ptmass(nptmass) logical, intent(out) :: accreted real, intent(inout) :: dptmass(ndptmass,nptmass) integer(kind=1), intent(in) :: nbinmax @@ -789,7 +818,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & real :: dx,dy,dz,r2,dvx,dvy,dvz,v2,hacc logical, parameter :: iofailreason=.false. integer :: j - real :: mpt,drdv,angmom2,angmomh2,epart,dxj,dyj,dzj,dvxj,dvyj,dvzj,rj2,vj2,epartj + real :: mpt,tbirthi,drdv,angmom2,angmomh2,epart,dxj,dyj,dzj,dvxj,dvyj,dvzj,rj2,vj2,epartj logical :: mostbound !$ external :: omp_set_lock,omp_unset_lock @@ -807,7 +836,23 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & sinkloop : do i=is,nptmass hacc = xyzmh_ptmass(ihacc,i) mpt = xyzmh_ptmass(4,i) + tbirthi = xyzmh_ptmass(itbirth,i) if (mpt < 0.) cycle + if (icreate_sinks==2) then + if (hacc < h_acc ) cycle + if (tbirthi + tmax_acc < time) then + !$omp master + if (ipart_createstars == 0) ipart_createstars = i + !$omp end master + cycle + endif + if ((tbirthi + tseeds < time) .and. (linklist_ptmass(i) == 0) .and. & + (ipart_createseeds == 0)) then + !$omp master + ipart_createseeds = i + !$omp end master + endif + endif dx = xi - xyzmh_ptmass(1,i) dy = yi - xyzmh_ptmass(2,i) dz = zi - xyzmh_ptmass(3,i) @@ -1017,8 +1062,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,dptmass,time) - use part, only:ihacc,ihsoft,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & + 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 use kdtree, only:getneigh @@ -1045,6 +1090,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote real(4), intent(in) :: divcurlv(:,:),poten(:) real, intent(inout) :: xyzmh_ptmass(:,:),dptmass(ndptmass,maxptmass) real, intent(inout) :: vxyz_ptmass(:,:),fxyz_ptmass(4,maxptmass),fxyz_ptmass_sinksink(4,maxptmass) + integer, intent(inout) :: linklist_ptmass(maxptmass) real, intent(in) :: time integer(kind=1) :: iphasei,ibin_wakei,ibin_itest integer :: nneigh @@ -1061,7 +1107,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote real :: q2i,qi,psofti,psoftj,psoftk,fsoft,epot_mass,epot_rad,pmassgas1 real :: hcheck,hcheck2,f_acc_local real(4) :: divvi,potenj_min,poteni - integer :: ifail,nacc,j,k,n,nk,itype,itypej,itypek,ifail_array(inosink_max),id_rhomax,nneigh_act + integer :: ifail,nacc,j,k,n,nk,itype,itypej,itypek,ifail_array(inosink_max),id_rhomax,nneigh_act,new_nptmass logical :: accreted,iactivej,isgasj,isdustj,calc_exact_epot,ForceCreation ifail = 0 @@ -1515,15 +1561,15 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote ! create new point mass, at position of original particle but with zero mass. Then accrete particles within hacc to form sink ! if (ifail==0) then - nptmass = nptmass + 1 - if (nptmass > maxptmass) call fatal('ptmass_create','nptmass > maxptmass') - n = nptmass - xyzmh_ptmass(:,n) = 0. ! zero all quantities by default - xyzmh_ptmass(1:3,n) = (/xi,yi,zi/) - xyzmh_ptmass(4,n) = 0. ! zero mass - xyzmh_ptmass(ihacc,n) = h_acc - xyzmh_ptmass(ihsoft,n) = h_soft_sinkgas - vxyz_ptmass(:,n) = 0. ! zero velocity, get this by accreting + new_nptmass = nptmass + 1 + if (new_nptmass > maxptmass) call fatal('ptmass_create','nptmass > maxptmass') + xyzmh_ptmass(:,new_nptmass) = 0. ! zero all quantities by default + xyzmh_ptmass(1:3,new_nptmass) = (/xi,yi,zi/) + xyzmh_ptmass(4,new_nptmass) = 0. ! zero mass + xyzmh_ptmass(ihacc,new_nptmass) = h_acc + xyzmh_ptmass(ihsoft,new_nptmass) = h_soft_sinkgas + xyzmh_ptmass(itbirth,new_nptmass) = time + vxyz_ptmass(:,new_nptmass) = 0. ! zero velocity, get this by accreting itypej = igas ! default particle type to be accreted pmassj = massoftype(igas) ! default particle mass to be accreted ! @@ -1541,28 +1587,33 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote fxj = fxyzu(1,j) + fext(1,j) fyj = fxyzu(2,j) + fext(2,j) fzj = fxyzu(3,j) + fext(3,j) - call ptmass_accrete(nptmass,nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),& + call ptmass_accrete(new_nptmass,new_nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),& vxyzu(1,j),vxyzu(2,j),vxyzu(3,j),fxj,fyj,fzj, & itypej,pmassj,xyzmh_ptmass,vxyz_ptmass,accreted, & - dptmass,time,f_acc_local,ibin_wakei,ibin_wakei) + dptmass,linklist_ptmass,time,f_acc_local,ibin_wakei,ibin_wakei) if (accreted) nacc = nacc + 1 enddo ! perform reduction just for this sink - dptmass(:,nptmass) = reduceall_mpi('+',dptmass(:,nptmass)) + dptmass(:,new_nptmass) = reduceall_mpi('+',dptmass(:,new_nptmass)) nacc = int(reduceall_mpi('+', nacc)) ! update ptmass position, spin, velocity, acceleration, and mass - fxyz_ptmass(1:4,n) = 0.0 - fxyz_ptmass_sinksink(1:4,n) = 0.0 - call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,nptmass) + fxyz_ptmass(1:4,new_nptmass) = 0.0 + fxyz_ptmass_sinksink(1:4,new_nptmass) = 0.0 + call update_ptmass(dptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,new_nptmass) if (id==id_rhomax) then - write(iprint,"(a,i3,a,4(es10.3,1x),a,i6,a,es10.3)") ' created ptmass #',nptmass,& - ' at (x,y,z,t)=(',xyzmh_ptmass(1:3,nptmass),time,') by accreting ',nacc,' particles: M=',xyzmh_ptmass(4,nptmass) + write(iprint,"(a,i3,a,4(es10.3,1x),a,i6,a,es10.3)") ' created ptmass #',new_nptmass,& + ' at (x,y,z,t)=(',xyzmh_ptmass(1:3,new_nptmass),time,') by accreting ',nacc,' particles: M=',xyzmh_ptmass(4,new_nptmass) endif if (nacc <= 0) call fatal('ptmass_create',' created ptmass but failed to accrete anything') + nptmass = new_nptmass + ! link the new sink to nothing (waiting for age > tseeds) + if (icreate_sinks == 2) then + linklist_ptmass(nptmass) = 0 + endif ! ! open new file to track new sink particle details & and update all sink-tracking files; ! fxyz_ptmass, fxyz_ptmass_sinksink are total force on sinks and sink-sink forces. @@ -1588,6 +1639,165 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote end subroutine ptmass_create +subroutine ptmass_create_seeds(nptmass,itest,xyzmh_ptmass,linklist_ptmass,time) + use part, only:itbirth,ihacc + use random, only:ran2 + use io, only:iprint + integer, intent(inout) :: nptmass + integer, intent(in) :: itest + integer, intent(inout) :: linklist_ptmass(:) + real, intent(inout) :: xyzmh_ptmass(:,:) + real, intent(in) :: time + integer :: j,nseed,n +! +!-- Draw the number of star seeds in the core +! + nseed = floor(4*ran2(iseed_sf)) + if (nseed > 0) then + n = nptmass + linklist_ptmass(itest) = n + 1 !! link the core to the seeds + do j=1,nseed + n = n + 1 + xyzmh_ptmass(:,n) = 0. + xyzmh_ptmass(4,n) = -1. + xyzmh_ptmass(ihacc,n) = -1. + linklist_ptmass(n) = n + 1 !! link this new seed to the next one + enddo + linklist_ptmass(n) = -1 !! null pointer to end the link list + write(iprint,"(a,i3,a,i3,a,es18.10)") ' Star formation prescription : creation of :',& + nseed+1, ' seeds in sink n° :', itest, " t= ",time + nptmass = n + else + write(iprint,"(a,i3,a,i3,a,es18.10)") ' Star formation prescription : creation of :',& + 1, ' seeds in sink n° :', itest, " t= ",time + linklist_ptmass(itest) = -1 !! null pointer to differentiate mono seed to gas clump + endif + +end subroutine ptmass_create_seeds + +subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,time) + use dim, only:maxptmass + use physcon, only:solarm,pi + use io, only:iprint,iverbose + use units, only:umass + use part, only:itbirth,ihacc,ihsoft,ispinx,ispiny,ispinz + use random , only:ran2,gauss_random,divide_unit_seg + use HIIRegion, only:update_ionrate,iH2R + integer, intent(in) :: nptmass,itest + integer, intent(in) :: linklist_ptmass(:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(inout) :: fxyz_ptmass(4,maxptmass),fxyz_ptmass_sinksink(4,maxptmass) + real, intent(in) :: time + real, allocatable :: masses(:) + real :: xi(3),vi(3) + integer :: k,n,l + real :: mi,hacci,minmass,mcutoff + real :: a(8),velk,rk,xk(3),vk(3),xcom(3),vcom(3),rvir + + + write(iprint,"(a,es18.10)") "ptmass_create_stars : new stars formed at : ",time + !! save xcom and vcom before placing stars + xi(1) = xyzmh_ptmass(1,itest) + xi(2) = xyzmh_ptmass(2,itest) + xi(3) = xyzmh_ptmass(3,itest) + mi = xyzmh_ptmass(4,itest) + hacci = xyzmh_ptmass(ihacc,itest) + vi(1) = vxyz_ptmass(1,itest) + vi(2) = vxyz_ptmass(2,itest) + vi(3) = vxyz_ptmass(3,itest) + + !! masses sampling method + call ptmass_endsize_lklist(itest,l,n,linklist_ptmass) + allocate(masses(n)) + minmass = 0.08/(mi*(umass/solarm)) + call divide_unit_seg(masses,minmass,n,iseed_sf) + masses = masses*mi + if (iverbose > 1) write(iprint,*) "Mass sharing : ", masses*umass/solarm + + + k=itest + do while(k>0) + !! Position and velocity sampling methods + a(:) = 0. + rvir = 0.7*h_acc + mcutoff = 0.55 + ! + !-- Positions + ! + a(1) = ran2(iseed_sf)*mcutoff + rk = rvir/sqrt((a(1)**(-2./3.)-1.0)) + a(2) = ran2(iseed_sf) + a(3) = ran2(iseed_sf) + xk(3) = (1.0-2.0*a(2))*rk + xk(2) = sqrt(rk**2-xk(3)**2)*sin(2*pi*a(3)) + xk(1) = sqrt(rk**2-xk(3)**2)*cos(2*pi*a(3)) + ! + !-- Velocities + ! + a(5) = 1. + do while(0.1*a(5)> a(6)) + a(4) = ran2(iseed_sf) + a(5) = ran2(iseed_sf) + a(6) = a(4)**2*(1.0 - a(4)**2)**3.5 + enddo + + velk = a(4)*sqrt(2.0)*(1.0 + rk**2)**(-0.25)*sqrt(2.0*mi/rvir) + a(7) = ran2(iseed_sf) + a(8) = ran2(iseed_sf) + vk(3) = (1.0-2.0*a(7))*velk + vk(2) = sqrt(velk**2-vk(3)**2)*sin(2*pi*a(8)) + vk(1) = sqrt(velk**2-vk(3)**2)*cos(2*pi*a(8)) + ! + !-- Star creation + ! + xyzmh_ptmass(ihacc,k) = hacci*1.e-3 + xyzmh_ptmass(ihsoft,k) = h_soft_sinkgas + xyzmh_ptmass(4,k) = masses(n) + xyzmh_ptmass(3,k) = xk(3) + xyzmh_ptmass(2,k) = xk(2) + xyzmh_ptmass(1,k) = xk(1) + xyzmh_ptmass(ispinx,k) = 0. ! + xyzmh_ptmass(ispiny,k) = 0. ! -- No spin for the instant + xyzmh_ptmass(ispinz,k) = 0. ! + vxyz_ptmass(1,k) = vk(1) + vxyz_ptmass(2,k) = vk(2) + vxyz_ptmass(3,k) = vk(3) + fxyz_ptmass(1:4,k) = 0. + fxyz_ptmass_sinksink(1:4,k) = 0. + if (iH2R > 0) call update_ionrate(k,xyzmh_ptmass,h_acc) + + k = linklist_ptmass(k) ! acces to the next point mass in the linked list + n = n - 1 + enddo + k = itest + do while(k>0) + xcom(1) = xyzmh_ptmass(4,k)*xyzmh_ptmass(1,k) + xcom(2) = xyzmh_ptmass(4,k)*xyzmh_ptmass(2,k) + xcom(3) = xyzmh_ptmass(4,k)*xyzmh_ptmass(3,k) + vcom(1) = xyzmh_ptmass(4,k)*vxyz_ptmass(1,k) + vcom(2) = xyzmh_ptmass(4,k)*vxyz_ptmass(2,k) + vcom(3) = xyzmh_ptmass(4,k)*vxyz_ptmass(3,k) + k = linklist_ptmass(k) ! acces to the next point mass in the linked list + enddo + + xcom = xcom/mi + vcom = vcom/mi + + k = itest + do while(k>0) + xyzmh_ptmass(1,k) = xyzmh_ptmass(1,k) - xcom(1) + xi(1) + xyzmh_ptmass(2,k) = xyzmh_ptmass(2,k) - xcom(2) + xi(2) + xyzmh_ptmass(3,k) = xyzmh_ptmass(3,k) - xcom(3) + xi(3) + vxyz_ptmass(1,k) = vxyz_ptmass(1,k) - vcom(1) + vi(1) + vxyz_ptmass(2,k) = vxyz_ptmass(2,k) - vcom(2) + vi(2) + vxyz_ptmass(3,k) = vxyz_ptmass(3,k) - vcom(3) + vi(3) + k = linklist_ptmass(k) ! acces to the next point mass in the linked list + enddo + + deallocate(masses) + +end subroutine ptmass_create_stars + !----------------------------------------------------------------------- !+ ! Merge sinks @@ -1611,15 +1821,17 @@ end subroutine ptmass_create ! negative mass. !+ !----------------------------------------------------------------------- -subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) +subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklist_ptmass,merge_ij) use io, only:iprint,warning,iverbose,id,master + use part, only:itbirth real, intent(in) :: time integer, intent(in) :: nptmass,merge_ij(nptmass) + integer, intent(inout) :: linklist_ptmass(nptmass) real, intent(inout) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: vxyz_ptmass(3,nptmass),fxyz_ptmass(4,nptmass) - integer :: i,j + integer :: i,j,k,l,n real :: rr2,xi,yi,zi,mi,vxi,vyi,vzi,xj,yj,zj,mj,vxj,vyj,vzj,Epot,Ekin - real :: mij,mij1 + real :: mij,mij1,tbirthi,tbirthj logical :: lmerge character(len=15) :: typ @@ -1628,17 +1840,25 @@ subroutine merge_sinks(time,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_i j = merge_ij(i) if (merge_ij(j) == i .and. xyzmh_ptmass(4,j) > 0.) then lmerge = .false. - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) - mi = xyzmh_ptmass(4,i) + tbirthi = xyzmh_ptmass(itbirth,i) + tbirthj = xyzmh_ptmass(itbirth,j) + if (tbirthj 0. .or. l_crit_override) then call write_inopt(f_crit_override,'f_crit_override' ,'unconditional sink formation if rho > f_crit_override*rho_crit',& iunit) @@ -1969,6 +2221,10 @@ subroutine write_options_ptmass(iunit) call write_inopt(f_acc,'f_acc','particles < f_acc*h_acc accreted without checks',iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) + if (use_regnbody) then + call write_inopt(use_regnbody, 'use_regnbody', 'allow subgroup integration method', iunit) + call write_inopt(r_neigh, 'r_neigh', 'searching radius to detect subgroups', iunit) + endif end subroutine write_options_ptmass @@ -1979,6 +2235,8 @@ end subroutine write_options_ptmass !----------------------------------------------------------------------- subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) use io, only:warning,fatal + use subgroup, only:r_neigh + use dim, only:store_ll_ptmass character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotall integer, intent(out) :: ierr @@ -2018,7 +2276,7 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) case('f_crit_override') read(valstring,*,iostat=ierr) f_crit_override if (f_crit_override < 0.) f_crit_override = 0. ! reset to zero since a negative value does not make sense - if (f_crit_override > 0. .and. f_crit_override < 100. ) call fatal(label,'Give star formation a chance! Reset to > 100') + if (f_crit_override > 0. .and. f_crit_override < 10. ) call fatal(label,'Give star formation a chance! Reset to > 10') l_crit_override = .true. case('h_soft') ! to ensure backwards compatibility read(valstring,*,iostat=ierr) h_soft @@ -2046,10 +2304,25 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) r_merge_cond if (r_merge_cond > 0. .and. r_merge_cond < r_merge_uncond) call fatal(label,'0 < r_merge_cond < r_merge_uncond') ngot = ngot + 1 + case('tmax_acc') + read(valstring,*,iostat=ierr) tmax_acc + ngot = ngot + 1 + case('tseeds') + read(valstring,*,iostat=ierr) tseeds + ngot = ngot + 1 + case('iseed_sf') + read(valstring,*,iostat=ierr) iseed_sf + ngot = ngot + 1 + case('use_regnbody') + read(valstring,*,iostat=ierr) use_regnbody + case('r_neigh') + read(valstring,*,iostat=ierr) r_neigh case default imatch = .false. end select + if (icreate_sinks ==2) store_ll_ptmass = .true. + !--make sure we have got all compulsory options (otherwise, rewrite input file) if (icreate_sinks > 0) then igotall = (ngot >= 8) diff --git a/src/main/random.f90 b/src/main/random.f90 index e77444401..b5fc3bd88 100644 --- a/src/main/random.f90 +++ b/src/main/random.f90 @@ -15,11 +15,11 @@ module random ! ! :Runtime parameters: None ! -! :Dependencies: None +! :Dependencies: sortutils ! implicit none public :: ran2,get_random,rayleigh_deviate - public :: get_random_pos_on_sphere,gauss_random + public :: get_random_pos_on_sphere,gauss_random,divide_unit_seg real, parameter :: pi = 4.*atan(1.) private @@ -167,4 +167,55 @@ real function gauss_random(iseed) end function gauss_random + +subroutine divide_unit_seg(lengths,mindist,nlengths,iseed) + use sortutils, only:indexx + integer, intent(in) :: nlengths + integer, intent(inout) :: iseed + real, intent(inout) :: lengths(nlengths) + real, intent(inout) :: mindist + real, allocatable :: points(:) + integer, allocatable :: idx(:) + integer :: i,j,np + logical :: close + real :: tmp,dist + + np = nlengths+1 + + allocate(points(np)) + allocate(idx(np)) + points(np) = 1. + points(1) = 0. + tmp = 0. + + if (mindist >= 0.1) then ! override the minimum distance if we are in a bricked situation... + mindist = 0.01 ! we'll have stars less massive than 0.08 solarmasses but it will assure to never brick the sim... + endif + + + do i=2,nlengths + close = .true. + do while (close) + tmp = ran2(iseed) + dist = tmp + do j=2,i-1 + dist = min(abs(points(j)-tmp),dist) + enddo + dist = min(abs(points(np)-tmp),dist) + close = dist 0) print "(1x,58('-'),/,1x,a,'|',5(a9,1x,'|'),/,1x,58('-'))",& diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 40a8bf319..5d589eef2 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -19,7 +19,7 @@ module readwrite_dumps_fortran ! :Runtime parameters: None ! ! :Dependencies: boundary_dyn, dim, dump_utils, eos, io, memory, -! metric_tools, mpiutils, options, part, readwrite_dumps_common, +! metric_tools, mpiutils, options, part, ptmass, readwrite_dumps_common, ! sphNGutils, timestep ! use dump_utils, only:lenid,ndatatypes,i_int,i_int1,i_int2,i_int4,i_int8,& @@ -48,13 +48,14 @@ 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,& + 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 use part, only:xyzh,xyzh_label,vxyzu,vxyzu_label,Bevol,Bevol_label,Bxyz,Bxyz_label,npart,maxtypes, & npartoftypetot,update_npartoftypetot, & alphaind,rhoh,divBsymm,maxphase,iphase,iamtype_int1,iamtype_int11, & - nptmass,nsinkproperties,xyzmh_ptmass,xyzmh_ptmass_label,vxyz_ptmass,vxyz_ptmass_label,& + nptmass,nsinkproperties,xyzmh_ptmass,xyzmh_ptmass_label,vxyz_ptmass,vxyz_ptmass_label, linklist_ptmass, & maxptmass,get_pmass,nabundances,abundance,abundance_label,mhd,& divcurlv,divcurlv_label,divcurlB,divcurlB_label,poten,dustfrac,deltav,deltav_label,tstop,& dustfrac_label,tstop_label,dustprop,dustprop_label,eos_vars,eos_vars_label,ndusttypes,ndustsmall,VrelVf,& @@ -312,6 +313,9 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ilen(2) = int(nptmass,kind=8) call write_array(2,xyzmh_ptmass,xyzmh_ptmass_label,nsinkproperties,nptmass,k,ipass,idump,nums,nerr) call write_array(2,vxyz_ptmass,vxyz_ptmass_label,3,nptmass,k,ipass,idump,nums,nerr) + if (store_ll_ptmass) then + call write_array(2,linklist_ptmass,"linklist_ptmass",nptmass,k,ipass,idump,nums,nerr) + endif if (nerr > 0) call error('write_dump','error writing sink particle arrays') endif enddo @@ -977,9 +981,9 @@ 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 + ind_timesteps,use_krome,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, & + alphaind,poten,xyzmh_ptmass,xyzmh_ptmass_label,vxyz_ptmass,vxyz_ptmass_label,linklist_ptmass, & Bevol,Bxyz,Bxyz_label,nabundances,iphase,idust, & eos_vars,eos_vars_label,maxeosvars,dustprop,dustprop_label,divcurlv,divcurlv_label,iX,iZ,imu, & VrelVf,VrelVf_label,dustgasprop,dustgasprop_label,filfac,filfac_label,pxyzu,pxyzu_label,dust_temp, & @@ -997,7 +1001,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto logical :: match logical :: got_dustfrac(maxdusttypes) logical :: got_iphase,got_xyzh(4),got_vxyzu(4),got_abund(nabundances),got_alpha(1),got_poten - logical :: got_sink_data(nsinkproperties),got_sink_vels(3),got_Bxyz(3) + logical :: got_sink_data(nsinkproperties),got_sink_vels(3),got_sink_llist,got_Bxyz(3) 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) @@ -1018,6 +1022,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto got_poten = .false. got_sink_data = .false. got_sink_vels = .false. + got_sink_llist = .false. got_Bxyz = .false. got_psi = .false. got_eosvars = .false. @@ -1123,6 +1128,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto case(2) call read_array(xyzmh_ptmass,xyzmh_ptmass_label,got_sink_data,ik,1,nptmass,0,idisk1,tag,match,ierr) call read_array(vxyz_ptmass, vxyz_ptmass_label, got_sink_vels,ik,1,nptmass,0,idisk1,tag,match,ierr) + if (store_ll_ptmass) then + call read_array(linklist_ptmass,'linklist_ptmass',got_sink_llist,ik,1,nptmass,0,idisk1,tag,match,ierr) + endif end select select case(iarr) ! MHD arrays can either be in block 1 or block 4 case(1,4) @@ -1144,8 +1152,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto call check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkproperties,massoftype,& alphafile,tfile,phantomdump,got_iphase,got_xyzh,got_vxyzu,got_alpha, & got_krome_mols,got_krome_gamma,got_krome_mu,got_krome_T, & - got_abund,got_dustfrac,got_sink_data,got_sink_vels,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,& + 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) if (.not. phantomdump) then print *, "Calling set_gas_particle_mass" diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index a116046ef..35bfa31ae 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -123,6 +123,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) use dim, only:maxvxyzu,maxptmass,gravity,sink_radiation,gr,nalpha use part, only:maxp,mhd,maxalpha,nptmass use boundary_dyn, only:write_options_boundary + use HIIRegion, only:write_options_H2R character(len=*), intent(in) :: infile,logfile,evfile,dumpfile integer, intent(in) :: iwritein,iprint integer :: ierr @@ -304,7 +305,8 @@ 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) - + call write_options_H2R(iwritein) + if (iwritein /= iprint) close(unit=iwritein) if (iwritein /= iprint) write(iprint,"(/,a)") ' input file '//trim(infile)//' written successfully.' @@ -347,6 +349,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) use damping, only:read_options_damping use gravwaveutils, only:read_options_gravitationalwaves use boundary_dyn, only:read_options_boundary + use HIIRegion, only:read_options_H2R character(len=*), parameter :: label = 'read_infile' character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile @@ -359,7 +362,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) logical :: imatch,igotallrequired,igotallturb,igotalllink,igotloops logical :: igotallbowen,igotallcooling,igotalldust,igotallextern,igotallinject,igotallgrowth,igotallporosity logical :: igotallionise,igotallnonideal,igotalleos,igotallptmass,igotalldamping - logical :: igotallprad,igotalldustform,igotallgw,igotallgr,igotallbdy + logical :: igotallprad,igotalldustform,igotallgw,igotallgr,igotallbdy,igotallH2R integer, parameter :: nrequired = 1 ireaderr = 0 @@ -391,6 +394,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) igotallgw = .true. igotallgr = .true. igotallbdy = .true. + igotallH2R = .true. use_Voronoi_limits_file = .false. open(unit=ireadin,err=999,file=infile,status='old',form='formatted') @@ -570,6 +574,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) endif if (.not.imatch) call read_options_gravitationalwaves(name,valstring,imatch,igotallgw,ierr) if (.not.imatch) call read_options_boundary(name,valstring,imatch,igotallbdy,ierr) + if (.not.imatch) call read_options_H2R(name,valstring,imatch,igotallH2R,ierr) if (len_trim(name) /= 0 .and. .not.imatch) then call warn('read_infile','unknown variable '//trim(adjustl(name))// & ' in input file, value = '//trim(adjustl(valstring))) @@ -687,8 +692,9 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) if (beta > 4.) call warn(label,'very high beta viscosity set') #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/=21)) & - call fatal(label,'only ieos=2 makes sense if storing thermal energy') + ieos /=11 .and. ieos /=12 .and. ieos /= 15 .and. ieos /= 16 .and. ieos /= 17 .and. & + ieos /= 20 .and. ieos/=21 .and. ieos/=22)) & + 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') if (shearparam < 0.) call fatal(label,'stupid value for shear parameter (< 0)') diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 3ab5e8362..a18c9f972 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -98,13 +98,13 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) iamboundary,get_ntypes,npartoftypetot,& dustfrac,dustevol,ddustevol,eos_vars,alphaind,nptmass,& dustprop,ddustprop,dustproppred,pxyzu,dens,metrics,ics,& - filfac,filfacpred,mprev,filfacprev + filfac,filfacpred,mprev,filfacprev,isionised use options, only:avdecayconst,alpha,ieos,alphamax use deriv, only:derivs use timestep, only:dterr,bignumber,tolv use mpiutils, only:reduceall_mpi use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & - dsdt_ptmass,fsink_old,ibin_wake,dptmass + dsdt_ptmass,fsink_old,ibin_wake,dptmass,linklist_ptmass use part, only:n_group,n_ingroup,n_sing,gtgrad,group_info,nmatrix use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc @@ -118,7 +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 timing, only:increment_timer,get_timings,itimer_extf + use timing, only:increment_timer,get_timings,itimer_substep use growth, only:check_dustprop use options, only:use_porosity,icooling use porosity, only:get_filfac @@ -253,14 +253,14 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) 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,fsink_old,nbinmax,ibin_wake,gtgrad,group_info, & - nmatrix,n_group,n_ingroup,n_sing) + dptmass,linklist_ptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info, & + nmatrix,n_group,n_ingroup,n_sing,isionised) else call substep_sph(dtsph,npart,xyzh,vxyzu) endif endif call get_timings(t2,tcpu2) - call increment_timer(itimer_extf,t2-t1,tcpu2-tcpu1) + call increment_timer(itimer_substep,t2-t1,tcpu2-tcpu1) timei = timei + dtsph nvfloorps = 0 diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index a754e8d61..1e6e52e28 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -15,48 +15,85 @@ module subgroup ! ! :Runtime parameters: None ! -! :Dependencies: io, mpiutils, part, utils_kepler, utils_subgroup +! :Dependencies: io, mpiutils, part, physcon, timing, units, utils_kepler, +! utils_subgroup ! use utils_subgroup implicit none public :: group_identify public :: evolve_groups public :: get_pot_subsys - ! parameters for group identification - real, parameter :: eta_pert = 20 + public :: init_subgroup + ! + !-- parameters for group identification + ! real, parameter :: time_error = 2.5e-14 - real, parameter :: max_step = 100000000 - real, parameter, public :: r_neigh = 0.001 - real, public :: t_crit = 1.e-9 - real, public :: C_bin = 0.02 - real, public :: r_search = 100.*r_neigh + real, parameter :: max_step = 1000000 + real, parameter :: C_bin = 0.02 + real, public :: r_neigh = 0.001 ! default value assume udist = 1 pc + real :: r_search private contains +!----------------------------------------------- +! +! Initialisation routine +! +!----------------------------------------------- +subroutine init_subgroup + use units, only:udist + use physcon, only:pc + + r_neigh = r_neigh*(pc/udist) + r_search = 100.*r_neigh + +end subroutine init_subgroup !----------------------------------------------- ! ! Group identification routines ! !----------------------------------------------- -subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - use io ,only:id,master,iverbose,iprint - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, intent(inout) :: group_info(3,nptmass) +subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix,dtext) + use io, only:id,master,iverbose,iprint + use timing, only:get_timings,increment_timer,itimer_sg_id + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(inout) :: group_info(3,nptmass) + integer, intent(inout) :: n_group,n_ingroup,n_sing integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) - integer, intent(inout) :: n_group,n_ingroup,n_sing + real, optional, intent(in) :: dtext + real(kind=4) :: t1,t2,tcpu1,tcpu2 + logical :: large_search + + + large_search = present(dtext) n_group = 0 n_ingroup = 0 n_sing = 0 + if (nptmass > 0) then + + call get_timings(t1,tcpu1) + + if (large_search) then + call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) + else + call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) + endif + call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + + call get_timings(t2,tcpu2) + call increment_timer(itimer_sg_id,t2-t1,tcpu2-tcpu1) - call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) - call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + endif if (id==master .and. iverbose>1) then write(iprint,"(i6,a,i6,a,i6,a)") n_group," groups identified, ",n_ingroup," in a group, ",n_sing," singles..." endif + + + end subroutine group_identify @@ -124,22 +161,28 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) end subroutine dfs -subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) +subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) use utils_kepler, only: Espec,extract_a,extract_e,extract_ea - integer, intent(in) :: nptmass + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(in) :: vxyz_ptmass(:,:) integer(kind=1), intent(out):: nmatrix(nptmass,nptmass) - real, intent(in) :: xyzmh_ptmass(:,:) - real, intent(in) :: vxyz_ptmass(:,:) + real, optional, intent(in) :: dtext real :: xi,yi,zi,vxi,vyi,vzi,mi real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu - real :: aij,eij,B,rperi + real :: aij,eij,B,rperi,dtexti integer :: i,j + if (present(dtext)) then + dtexti = dtext + else + dtexti = 0. + endif ! !!TODO MPI Proof version of the matrix construction ! !$omp parallel do default(none) & - !$omp shared(nptmass,C_bin,t_crit,nmatrix) & + !$omp shared(nptmass,dtexti,nmatrix,r_neigh) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,r_search) & !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & !$omp private(dx,dy,dz,r,r2) & @@ -153,6 +196,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) vxi = vxyz_ptmass(1,i) vyi = vxyz_ptmass(2,i) vzi = vxyz_ptmass(3,i) + if (mi < 0 ) cycle do j=1,nptmass if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) @@ -181,7 +225,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) else call extract_e(dx,dy,dz,dvx,dvy,dvz,mu,r,eij) rperi = aij*(1-eij) - if (rperi0) then + + call get_timings(t1,tcpu1) + if (id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& @@ -219,12 +271,17 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz enddo !$omp end parallel do endif + + call get_timings(t2,tcpu2) + call increment_timer(itimer_sg_evol,t2-t1,tcpu2-tcpu1) + endif call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) call bcast_mpi(vxyz_ptmass(:,1:nptmass)) + end subroutine evolve_groups subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) @@ -296,7 +353,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ if (step_count_int > max_step) then print*,"MAX STEP NUMBER, ABORT !!!" - call abort + call abort() endif if ((.not.t_end_flag).and.(dt<0.)) then @@ -582,7 +639,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id integer :: i,j,k,l logical :: init om = 0. - dt_init = 0. + dt_init = huge(om) if (present(ds_init)) then @@ -647,7 +704,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id enddo om = om*0.5 - if (init) ds_init = dt_init/om + if (init) ds_init = dt_init*om end subroutine get_force_TTL diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 1040fe6fd..6c0d39274 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -37,6 +37,7 @@ module substepping public :: substep_sph public :: substep_sph_gr public :: substep + public :: get_force private @@ -426,8 +427,8 @@ end subroutine substep_sph !---------------------------------------------------------------- subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & - fsink_old,nbinmax,ibin_wake,gtgrad,group_info,nmatrix, & - n_group,n_ingroup,n_sing) + linklist_ptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info, & + nmatrix,n_group,n_ingroup,n_sing,isionised) use io, only:iverbose,id,master,iprint,fatal use options, only:iexternalforce use part, only:fxyz_ptmass_sinksink,ndptmass @@ -444,7 +445,9 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) real, intent(inout) :: dptmass(ndptmass,nptmass),fsink_old(:,:),gtgrad(:,:) integer(kind=1), intent(in) :: nbinmax + integer , intent(inout) :: linklist_ptmass(:) integer(kind=1), intent(inout) :: ibin_wake(:),nmatrix(nptmass,nptmass) + logical, intent(in) :: isionised(:) logical :: extf_vdep_flag,done,last_step,accreted integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step @@ -481,7 +484,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! ! Main integration scheme ! - call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) + call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & + fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass) if (use_regnbody) then call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) @@ -489,12 +493,12 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,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) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,isionised=isionised) endif if (use_fourthorder) then !! FSI 4th order scheme @@ -502,46 +506,55 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! 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,fsink_old,group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass, & + fsink_old,group_info) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass) call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,group_info=group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass, & + 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,fsink_old) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,& + fsink_old) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass) call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass,& + isionised=isionised) ! the last kick phase of the scheme will perform the accretion loop after velocity update endif call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass,ibin_wake,nbinmax,timei, & + fxyz_ptmass_sinksink,accreted) if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,group_info=group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass, & + group_info=group_info) elseif (accreted) then call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass) endif else !! standard leapfrog scheme ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass,ibin_wake,nbinmax,timei, & + fxyz_ptmass_sinksink,accreted) 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) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass) endif endif @@ -629,7 +642,8 @@ end subroutine drift !---------------------------------------------------------------- subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & - fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass,ibin_wake, & + nbinmax,timei,fxyz_ptmass_sinksink,accreted) use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas,ndptmass use ptmass, only:f_acc,ptmass_accrete,pt_write_sinkev,update_ptmass,ptmass_kick use externalforces, only:accrete_particles @@ -645,6 +659,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, real, intent(inout) :: vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) real, intent(inout) :: dptmass(ndptmass,nptmass) + integer, intent(in) :: linklist_ptmass(:) real, optional, intent(inout) :: fxyz_ptmass_sinksink(:,:) real, optional, intent(in) :: timei integer(kind=1), optional, intent(inout) :: ibin_wake(:) @@ -711,7 +726,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,linklist_ptmass,f_acc) & !$omp shared(iexternalforce) & !$omp shared(nbinmax,ibin_wake) & !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & @@ -750,12 +765,15 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, fxi = fext(1,i) fyi = fext(2,i) fzi = fext(3,i) - if (ind_timesteps) ibin_wakei = ibin_wake(i) + if (ind_timesteps) then + ibin_wakei = ibin_wake(i) + itype = iphase(i) + endif call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxi,fyi,fzi,& - itype,pmassi,xyzmh_ptmass,vxyz_ptmass,& - accreted,dptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) + itype,pmassi,xyzmh_ptmass,vxyz_ptmass,accreted, & + dptmass,linklist_ptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) if (accreted) then naccreted = naccreted + 1 cycle accreteloop @@ -817,7 +835,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,fsink_old,group_info) + force_count,extf_vdep_flag,linklist_ptmass,fsink_old,group_info,& + isionised) use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & @@ -835,6 +854,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, use ptmass_radiation,only:get_rad_accel_from_ptmass,isink_radiation integer, intent(in) :: nptmass,npart,nsubsteps,ntypes integer, intent(inout) :: force_count + integer, intent(inout) :: linklist_ptmass(:) real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) real, intent(inout) :: dtextforce @@ -842,6 +862,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, logical, intent(in) :: extf_vdep_flag 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 integer :: i,itype @@ -893,7 +914,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & extrapfac,fsink_old,group_info) if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call 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) @@ -903,7 +924,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, dtf,iexternalforce,timei,merge_ij,merge_n, & dsdt_ptmass,extrapfac,fsink_old) if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call 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) @@ -914,29 +935,29 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call 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) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif + 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,merge_ij) + 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) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf endif + fxyz_ptmass_sinksink(:,1:nptmass) = fxyz_ptmass (:,1:nptmass) + dsdt_ptmass_sinksink(:,1:nptmass) = dsdt_ptmass (:,1:nptmass) endif endif else - fxyz_ptmass(:,:) = 0. - dsdt_ptmass(:,:) = 0. + fxyz_ptmass(:,1:nptmass) = 0. + dsdt_ptmass(:,1:nptmass) = 0. endif call bcast_mpi(epot_sinksink) call bcast_mpi(dtf) @@ -954,7 +975,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$omp shared(dkdt,dt,timei,iexternalforce,extf_vdep_flag,last) & !$omp shared(divcurlv,dphotflag,dphot0,nucleation,extrap) & !$omp shared(abundc,abundo,abundsi,abunde,extrapfac,fsink_old) & - !$omp shared(isink_radiation,itau_alloc,tau) & + !$omp shared(isink_radiation,itau_alloc,tau,isionised) & !$omp private(fextx,fexty,fextz,xi,yi,zi) & !$omp private(i,fonrmaxi,dtphi2i,phii,dtf) & !$omp firstprivate(pmassi,itype) & @@ -1037,7 +1058,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) + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,isionised(i)) endif endif enddo @@ -1079,7 +1100,7 @@ end subroutine get_force !+ !------------------------------------------------------------------------------------ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & - divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0) + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,isionisedi) use dim, only:h2chemistry,do_nucleation,use_krome,update_muGamma,store_dust_temperature use part, only:idK2,idmu,idkappa,idgamma,imu,igamma,nabundances use cooling_ism, only:nabn,dphotflag @@ -1100,6 +1121,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl real, intent(inout) :: abundc,abunde,abundo,abundsi real(kind=8), intent(in) :: dphot0 real, intent(in) :: dt,pmassi + logical, intent(in) :: isionisedi integer, intent(in) :: i real :: dudtcool,rhoi,dphot,pH,pH_tot @@ -1136,7 +1158,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl ! ! COOLING ! - if (icooling > 0 .and. cooling_in_step .and. icooling /= 9) then + if (icooling > 0 .and. cooling_in_step) then if (h2chemistry) then ! ! Call cooling routine, requiring total density, some distance measure and @@ -1155,6 +1177,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) 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) @@ -1162,6 +1186,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl endif #endif ! update internal energy + if (isionisedi) dudtcool = 0. if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool diff --git a/src/main/utils_deriv.f90 b/src/main/utils_deriv.f90 index 29fcb1ecc..d45676930 100644 --- a/src/main/utils_deriv.f90 +++ b/src/main/utils_deriv.f90 @@ -16,7 +16,7 @@ module derivutils ! ! :Dependencies: io, mpiutils, timing ! - use timing, only: timers,itimer_dens,itimer_force,itimer_link,itimer_extf,itimer_balance,itimer_cons2prim,& + use timing, only: timers,itimer_dens,itimer_force,itimer_link,itimer_balance,itimer_cons2prim,& itimer_radiation,itimer_rad_save,itimer_rad_neighlist,itimer_rad_arrays,itimer_rad_its,& itimer_rad_flux,itimer_rad_diff,itimer_rad_update,itimer_rad_store diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index 97031f2d2..dba9c1ecf 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -17,7 +17,7 @@ module sortutils ! :Dependencies: None ! implicit none - public :: indexx,indexxfunc,find_rank,r2func,r2func_origin,set_r2func_origin + public :: indexx,indexxfunc,Knnfunc,parqsort,find_rank,r2func,r2func_origin,set_r2func_origin interface indexx module procedure indexx_r4, indexx_i8 end interface indexx @@ -352,6 +352,264 @@ subroutine indexxfunc(n, func, xyzh, indx) end subroutine indexxfunc + +!---------------------------------------------------------------- +!+ +! customised low-memory sorting routine using Quicksort +! sort key value on-the-fly by calling the function func +! which can be any function of the particle positions. +! (Tweaked version of the original one to sort a list of +! neighbours founded using the KD tree) +!+ +!---------------------------------------------------------------- +subroutine Knnfunc(n, func, xyzh, indx) + integer, parameter :: m=7, nstack=500 + integer, intent(in) :: n + real, external :: func + real, intent(in) :: xyzh(:,:) + integer, intent(out) :: indx(n) + + integer :: i,j,k,l,ir,jstack,indxt,itemp + integer :: istack(nstack) + real :: a + + jstack = 0 + l = 1 + ir = n + +1 if (ir - l < m) then + do j = l + 1, ir + indxt = indx(j) + a = func(xyzh(:,indxt)) + do i = j - 1, 1, -1 + if (func(xyzh(:,indx(i))) <= a) goto 2 + indx(i + 1) = indx(i) + enddo + i = 0 +2 indx(i + 1) = indxt + enddo + if (jstack==0) return + ir = istack(jstack) + l = istack(jstack - 1) + jstack = jstack - 2 + else + k = (l + ir)/2 + itemp = indx(k) + indx(k) = indx(l + 1) + indx(l + 1) = itemp + if (func(xyzh(:,indx(l+1))) > func(xyzh(:,indx(ir)))) then + itemp = indx(l + 1) + indx(l + 1) = indx(ir) + indx(ir) = itemp + endif + if (func(xyzh(:,indx(l))) > func(xyzh(:,indx(ir)))) then + itemp = indx(l) + indx(l) = indx(ir) + indx(ir) = itemp + endif + if (func(xyzh(:,indx(l+1))) > func(xyzh(:,indx(l)))) then + itemp = indx(l + 1) + indx(l + 1) = indx(l) + indx(l) = itemp + endif + i = l + 1 + j = ir + indxt = indx(l) + a = func(xyzh(:,indxt)) + +3 continue + i = i + 1 + if (func(xyzh(:,indx(i))) < a) goto 3 +4 continue + j = j - 1 + if (func(xyzh(:,indx(j))) > a) goto 4 + if (j < i) goto 5 + itemp = indx(i) + indx(i) = indx(j) + indx(j) = itemp + goto 3 + +5 indx(l) = indx(j) + indx(j) = indxt + jstack = jstack + 2 + if (jstack > nstack) then + print*,'fatal error!!! stacksize exceeded in sort' + print*,'need to set parameter nstack higher in subroutine indexxfunc ' + stop + endif + if (ir - i + 1 >= j - l) then + istack(jstack) = ir + istack(jstack - 1) = i + ir = j - 1 + else + istack(jstack) = j - 1 + istack(jstack - 1) = l + l = i + endif + endif + + goto 1 +end subroutine Knnfunc + + +!---------------------------------------------------------------- +!+ +! customised low-memory sorting routine using Quicksort +! sort key value on-the-fly by calling the function func +! which can be any function of the particle positions. +! (Tweaked version of the original one to sort a list of +! neighbours founded using the KD tree) (Parallel scheme, approx 2 times faster) +!+ +!---------------------------------------------------------------- +subroutine parqsort(n, arr,func, indx) +!$ use omp_lib,only:omp_get_num_threads + implicit none + integer, parameter :: m=8, nstack=500 + integer, intent(in) :: n + real, intent(in) :: arr(n) + integer, intent(inout) :: indx(n) + real, external :: func + integer :: i,j,k,il,ir,jstack,jqueue,indxt,itemp,nthreads,t,spt,nquick + integer, save :: istack(nstack) + !$omp threadprivate(istack) + integer :: iqueue(nstack) + real :: a + + nthreads = 1 + + !$omp parallel default(none) shared(nthreads) +!$ nthreads = omp_get_num_threads() + !$omp end parallel + + + spt = n/nthreads + + jstack = 0 + jqueue = 0 + iqueue = 0 + istack = 0 + il = 1 + ir = n + + do while (.true.) + + if (ir - il <= spt) then + jqueue = jqueue + 2 + iqueue(jqueue) = ir + iqueue(jqueue - 1) = il + if (jstack==0) exit + ir = istack(jstack) + il = istack(jstack - 1) + jstack = jstack - 2 + else + k = (il + ir)/2 + i = il + j = ir + indxt = indx(k) + a = func(arr(indxt)) + + do while (j>i) + do while(func(arr(indx(i))) < a) + i = i + 1 + enddo + do while (func(arr(indx(j))) > a) + j = j - 1 + enddo + if (j>i) then + itemp = indx(i) + indx(i) = indx(j) + indx(j) = itemp + endif + enddo + jstack = jstack + 2 + if (jstack > nstack) then + print*,'fatal error!!! stacksize exceeded in sort' + print*,'need to set parameter nstack higher in subroutine indexx ' + stop + endif + if (ir - i + 1 >= j - il) then + istack(jstack) = ir + istack(jstack - 1) = i + ir = j - 1 + else + istack(jstack) = j - 1 + istack(jstack - 1) = il + il = i + endif + endif + enddo + + istack = 0 + nquick = jqueue/2 + + + !$omp parallel do default(none) & + !$omp shared(indx,arr,nquick,iqueue)& + !$omp private(i,j,k,il,ir,a,jstack,indxt,itemp) + do t=1,nquick + ir = iqueue(2*t) + il = iqueue(2*t - 1) + jstack = 0 + + do while (.true.) + if (ir - il < m) then + !print*,il,ir + do j = il , ir + indxt = indx(j) + a = func(arr(indxt)) + do i = j - 1, il, -1 + if (func(arr(indx(i))) <= a) goto 5 + indx(i + 1) = indx(i) + enddo + i = il-1 +5 indx(i + 1) = indxt + enddo + if (jstack==0) exit + ir = istack(jstack) + il = istack(jstack - 1) + jstack = jstack - 2 + else + k = (il + ir)/2 + i = il + j = ir + indxt = indx(k) + a = func(arr(indxt)) + + do while (j>i) + do while(func(arr(indx(i))) < a) + i = i + 1 + enddo + do while (func(arr(indx(j))) > a) + j = j - 1 + enddo + if (j>i) then + itemp = indx(i) + indx(i) = indx(j) + indx(j) = itemp + endif + enddo + jstack = jstack + 2 + if (jstack > nstack) then + print*,'fatal error!!! stacksize exceeded in sort' + print*,'need to set parameter nstack higher in subroutine indexx ' + stop + endif + if (ir - i + 1 >= j - il) then + istack(jstack) = ir + istack(jstack - 1) = i + ir = j - 1 + else + istack(jstack) = j - 1 + istack(jstack - 1) = il + il = i + endif + endif + enddo + enddo + +end subroutine parqsort + + !---------------------------------------------------------------- !+ ! Same as indexxfunc, except two particles can have the same diff --git a/src/main/utils_timing.f90 b/src/main/utils_timing.f90 index c9ec91558..9e2de5d71 100644 --- a/src/main/utils_timing.f90 +++ b/src/main/utils_timing.f90 @@ -60,10 +60,13 @@ module timing itimer_rad_update = 19, & itimer_rad_store = 20, & itimer_cons2prim = 21, & - itimer_extf = 22, & - itimer_ev = 23, & - itimer_io = 24 - integer, public, parameter :: ntimers = 24 ! should be equal to the largest itimer index + itimer_substep = 22, & + itimer_sg_id = 23, & + itimer_sg_evol = 24, & + itimer_HII = 25, & + itimer_ev = 26, & + itimer_io = 27 + integer, public, parameter :: ntimers = 27 ! should be equal to the largest itimer index type(timer), public :: timers(ntimers) private @@ -84,6 +87,7 @@ subroutine setup_timers call init_timer(itimer_fromstart , 'all', 0 ) call init_timer(itimer_lastdump , 'last', 0 ) call init_timer(itimer_step , 'step', 0 ) + call init_timer(itimer_HII , 'HII_regions', 0 ) call init_timer(itimer_link , 'tree', itimer_step ) call init_timer(itimer_balance , 'balance', itimer_link ) call init_timer(itimer_dens , 'density', itimer_step ) @@ -102,7 +106,9 @@ subroutine setup_timers call init_timer(itimer_rad_update , 'update', itimer_rad_its ) call init_timer(itimer_rad_store , 'store', itimer_radiation ) call init_timer(itimer_cons2prim , 'cons2prim', itimer_step ) - call init_timer(itimer_extf , 'extf', itimer_step ) + call init_timer(itimer_substep , 'substep', itimer_step ) + call init_timer(itimer_sg_id , 'subg_id', itimer_substep ) + call init_timer(itimer_sg_evol , 'subg_evol', itimer_substep ) call init_timer(itimer_ev , 'write_ev', 0 ) call init_timer(itimer_io , 'write_dump', 0 ) diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index 0d32e639b..a7b5ff448 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -80,7 +80,7 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) use io, only:iprint use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax use boundary_dyn, only:dynamic_bdy,rho_thresh_bdy,width_bkg - use options, only:tolh,alpha,alphau,alphaB,ieos,alphamax,use_dustfrac,use_porosity + use options, only:tolh,alpha,alphau,alphaB,ieos,alphamax,use_dustfrac,use_porosity,icooling use part, only:hfact,massoftype,mhd,gravity,periodic,massoftype,npartoftypetot,& labeltype,maxtypes use mpiutils, only:reduceall_mpi @@ -187,10 +187,14 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) endif if (use_dustgrowth) write(iprint,"(1x,a)") 'Dust growth is ON' if (use_porosity) write(iprint,"(1x,a)") 'Dust porosity is ON' - if (cooling_in_step) then - write(iprint,"(1x,a)") 'Cooling is calculated in step' + if (icooling > 0) then + if (cooling_in_step) then + write(iprint,"(1x,a)") 'Cooling is calculated in step' + else + write(iprint,"(1x,a)") 'Cooling is explicitly calculated in force' + endif else - write(iprint,"(1x,a)") 'Cooling is explicitly calculated in force' + write(iprint,"(1x,a)") 'Cooling is OFF' endif if (ufloor > 0.) then write(iprint,"(3(a,Es10.3),a)") ' WARNING! Imposing temperature floor of = ',Tfloor,' K = ', & diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index 23a25885d..38f3348b3 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -27,36 +27,6 @@ module setorbit ! :Runtime parameters: None ! ! :Dependencies: infile_utils, physcon, setbinary, setflyby, units -! - -! While Campbell elements can be used for unbound orbits, they require -! specifying the true anomaly at the start of the simulation. This is -! not always easy to determine, so the flyby option is provided as an -! alternative. There one specifies the initial separation instead, however -! the choice of angles is more restricted -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: infile_utils, physcon, setbinary, setflyby, units -! - -! While Campbell elements can be used for unbound orbits, they require -! specifying the true anomaly at the start of the simulation. This is -! not always easy to determine, so the flyby option is provided as an -! alternative. There one specifies the initial separation instead, however -! the choice of angles is more restricted -! -! :References: None -! -! :Owner: Daniel Price -! -! :Runtime parameters: None -! -! :Dependencies: physcon ! implicit none public :: set_orbit diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 73a5d7017..4be4dbe7e 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -397,7 +397,8 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ real :: rho_cgs,p_cgs integer :: i1 - i1 = 0 + i1 = 0 + eni = 0. if (present(npin)) i1 = npin ! starting position in particle array if (do_radiation) then diff --git a/src/setup/setup_bondi.f90 b/src/setup/setup_bondi.f90 new file mode 100644 index 000000000..f543019fd --- /dev/null +++ b/src/setup/setup_bondi.f90 @@ -0,0 +1,295 @@ +!--------------------------------------------------------------------------! +! 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 setup +! +! Setup for Bondi flow problem, for both relativistic and non-relativistic solution +! +! :References: Liptai & Price (2019), MNRAS 485, 819-842 +! +! :Owner: David Liptai +! +! :Runtime parameters: +! - isol : *(1 = geodesic flow | 2 = sonic point flow)* +! - iswind : *wind option (logical)* +! - np : *desired number of particles (stretch-mapping will only give this approx.)* +! - rmax : *outer edge* +! - rmin : *inner edge* +! +! :Dependencies: bondiexact, centreofmass, dim, externalforces, +! infile_utils, io, kernel, metric_tools, options, part, physcon, +! prompting, setup_params, spherical, stretchmap, timestep, units +! + use physcon, only:pi + use externalforces, only:accradius1,accradius1_hard + use dim, only:gr,maxvxyzu + use metric_tools, only:imet_schwarzschild,imetric + use externalforces, only:mass1 + use setup_params, only:rhozero,npart_total + use io, only:master,fatal + use spherical, only:set_sphere + use options, only:ieos,iexternalforce,nfulldump + use timestep, only:tmax,dtmax + use centreofmass, only:reset_centreofmass + use units, only:set_units,get_G_code + use physcon, only:pc,solarm,gg + use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,ihacc,igas,set_particle_type,iboundary + use stretchmap, only:get_mass_r,rho_func + use kernel, only:radkern + use prompting, only:prompt + use bondiexact, only:get_bondi_solution,rcrit,isol,iswind + implicit none + + public :: setpart + + private + + real :: gamma_eos,rmax,rmin + integer :: np + + logical, parameter :: set_boundary_particles = .false. + +contains + +!---------------------------------------------------------------- +!+ +! setup for bondi accretion +!+ +!---------------------------------------------------------------- +subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) + integer, intent(in) :: id + integer, intent(inout) :: npart + integer, intent(out) :: npartoftype(:) + real, intent(out) :: xyzh(:,:) + real, intent(out) :: massoftype(:) + real, intent(out) :: vxyzu(:,:) + real, intent(out) :: polyk,gamma,hfact + real, intent(inout) :: time + character(len=20), intent(in) :: fileprefix + integer, parameter :: ntab=10000 + real :: rhotab(ntab) + real :: vol,psep,tff,rhor,vr,ur + real :: r,pos(3),cs2,totmass,approx_m,approx_h + integer :: i,ierr,nx,nbound + character(len=100) :: filename + logical :: iexist + procedure(rho_func), pointer :: density_func +! +!-- Set code units +! + call set_units(G=1.d0,c=1.d0) + print*,' G in code units = ',get_G_code() + +! +!--Set general parameters +! + time = 0. + iexternalforce = 1 + + rmin = 7. + rmax = 8. + np = 10000 + + if (gr) then + if (imetric/=imet_schwarzschild) call fatal('setup_bondi',& + 'You are not using the Schwarzschild metric.') + endif + +! +!-- Read things from setup file +! + filename=trim(fileprefix)//'.setup' + print "(/,1x,63('-'),1(/,1x,a),/,1x,63('-'),/)", 'Bondi Flow.' + inquire(file=filename,exist=iexist) + if (iexist) then + call read_setupfile(filename,ierr) + if (ierr /= 0) then + if (id==master) call write_setupfile(filename) + call fatal('setup','failed to read in all the data from .setup. Aborting') + endif + elseif (id==master) then + print "(a,/)",trim(filename)//' not found: using interactive setup' + if (gr) then + call prompt(' Enter solution type isol (1 = geodesic | 2 = sonic point flow) ',isol,1,2) + call prompt(' Do you want a wind (y/n)? ',iswind) + endif + call prompt(' Enter inner edge: ',rmin,0.) + call prompt(' Enter outer edge: ',rmax,rmin) + call prompt(' Enter the desired number of particles: ',np,0) + call write_setupfile(filename) + print*,' Edit '//trim(filename)//' and rerun phantomsetup' + stop + endif + + if (gr) then + ieos = 2 + gamma = 5./3. + polyk = 1. + else + gamma = 1. + ieos = 1 + cs2 = mass1/(2.*rcrit) + polyk = cs2 + endif + + gamma_eos = gamma ! Note, since non rel bondi is isothermal, solution doesn't depend on gamma + accradius1 = 0. + accradius1_hard = 0. + + if (gr) then + rmin = rmin*mass1 + rmax = rmax*mass1 + endif + + vol = 4./3.*pi*(rmax**3 - rmin**3) + nx = int(np**(1./3.)) + psep = vol**(1./3.)/real(nx) + + call get_rhotab(rhotab,rmin,rmax,mass1,gamma) + + density_func => rhofunc + totmass = get_mass_r(density_func,rmax,rmin) + approx_m = totmass/np + approx_h = hfact*(approx_m/rhofunc(rmin))**(1./3.) + rhozero = totmass/vol + + tff = sqrt(3.*pi/(32.*rhozero)) + tmax = 10.*tff + dtmax = tmax/150. + + print*,'' + print*,' Setup for gas: ' + print*,' min,max radius = ',rmin,rmax + print*,' volume = ',vol ,' particle separation = ',psep + print*,' vol/psep**3 = ',vol/psep**3,' totmass = ',totmass + print*,' free fall time = ',tff ,' tmax = ',tmax + print*,'' + +!--- Add stretched sphere + npart = 0 + npart_total = 0 + call set_sphere('closepacked',id,master,rmin,rmax,psep,hfact,npart,& + xyzh,rhotab=rhotab,nptot=npart_total) + massoftype(:) = totmass/npart + print "(a,i0,/)",' npart = ',npart + + nbound = 0 + do i=1,npart + + pos = xyzh(1:3,i) + r = sqrt(dot_product(pos,pos)) + call get_bondi_solution(rhor,vr,ur,r,mass1,gamma) + vxyzu(1:3,i) = vr*pos/r + if (maxvxyzu >= 4) vxyzu(4,i) = ur + + if (set_boundary_particles) then + if (r + radkern*xyzh(4,i)>rmax .or. r - radkern*xyzh(4,i)= 4) ieos_in = 2 ! Adiabatic equation of state + case(2) ! Young Massive Cluster (S. Jaffa, University of Hertfordshire) default_cluster = "Young Massive Cluster" Rcloud_pc = 5.0 ! Input radius [pc] @@ -110,9 +123,40 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ieos_in = 1 ! Isothermal equation of state mass_fac = 1.0d5 ! mass code unit: mass_fac * solarm dist_fac = 1.0 ! distance code unit: dist_fac * pc - endif + if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state + + case(3) + ! Young Massive Cluster (Yann Bernard, IPAG) + default_cluster = "Embedded cluster" + Rcloud_pc = 10.0 ! Input radius [pc] + Mcloud_msun = 1.0d4 ! Input mass [Msun] + ieos_in = 21 ! Isothermal equation of state + HII + mass_fac = 1.0d4 ! mass code unit: mass_fac * solarm + dist_fac = 1.0 ! distance code unit: dist_fac * pc + iH2R = 1 ! switch HII regions + Rsink_au = 4000. ! Sink radius [au] + mu = 2.35 ! mean molecular weight + if (maxvxyzu >= 4) then + ieos_in = 22 ! Adiabatic equation of state + HII + gamma = 5./3. + Tfloor = 6. + icooling = 6 + Temperature = 40. + endif + + + case default + ! from Bate, Bonnell & Bromm (2003) + default_cluster = "Bate, Bonnell & Bromm (2003)" + Rcloud_pc = 0.1875 ! Input radius [pc] + Mcloud_msun = 50. ! Input mass [Msun] + ieos_in = 8 ! Barotropic equation of state + mass_fac = 1.0 ! mass code unit: mass_fac * solarm + dist_fac = 0.1 ! distance code unit: dist_fac * pc + if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state + end select + - if (maxvxyzu >= 4) ieos_in = 2 ! Adiabatic equation of state !--Read values from .setup if (setexists) then @@ -132,7 +176,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_units(dist=dist_fac*pc,mass=mass_fac*solarm,G=1.) !--Define remaining variables using the inputs - polyk = kboltz*Temperature/(mu*mass_proton_cgs)*(utime/udist)**2 + polyk = gamma*kboltz*Temperature/(mu*mass_proton_cgs)*(utime/udist)**2 rmax = Rcloud_pc*(pc/udist) r2 = rmax*rmax totmass = Mcloud_msun*(solarm/umass) @@ -153,6 +197,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_particle_type(i,igas) enddo + if (relax) then + call shuffleparticles(iprint,npart,xyzh,massoftype(1),rsphere=rmax,dsphere=rhozero,dmedium=0.,& + is_setup=.true.,prefix=trim(fileprefix)) + endif !--Set velocities (from pre-made velocity cubes) write(*,"(1x,a)") 'Setting up velocity field on the particles...' vxyzu(:,:) = 0. @@ -167,6 +215,14 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call normalise_vfield(npart,vxyzu,ierr,ke=epotgrav) if (ierr /= 0) call fatal('setup','error normalising velocity field') + if (maxvxyzu >= 4) then + if (gamma > 1.) then + vxyzu(4,:) = polyk/(gamma*(gamma-1.)) + else + vxyzu(4,:) = 1.5*polyk + endif + endif + !--Setting the centre of mass of the cloud to be zero call reset_centreofmass(npart,xyzh,vxyzu) @@ -175,9 +231,23 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, tmax = 2.*t_ff dtmax = 0.002*t_ff h_acc = Rsink_au*au/udist - r_crit = 2.*h_acc - icreate_sinks = 1 - rho_crit_cgs = 1.d-10 + if (icluster == 3) then + r_crit = h_acc + icreate_sinks = 2 + rho_crit_cgs = 1.d-18 + h_soft_sinkgas = h_acc + tmax_acc = 0.5*(myr/utime) + tseeds = 0.1*(myr/utime) + r_merge_uncond = h_acc + use_regnbody = .true. + r_neigh = 5e-2*h_acc + f_crit_override = 100. + else + r_crit = 2.*h_acc + icreate_sinks = 1 + rho_crit_cgs = 1.d-10 + endif + ieos = ieos_in gmw = mu ! for consistency; gmw will never actually be used endif @@ -211,7 +281,8 @@ subroutine get_input_from_prompts() call prompt('Enter the radius of the sink particles (in au)',Rsink_au) call prompt('Enter the Temperature of the cloud (used for initial sound speed)',Temperature) call prompt('Enter the mean molecular mass (used for initial sound speed)',mu) - if (maxvxyzu < 4) call prompt('Enter the EOS id (1: isothermal, 8: barotropic)',ieos_in) + call prompt('Do you want to relax your cloud',relax) + if (maxvxyzu < 4) call prompt('Enter the EOS id (1: isothermal, 8: barotropic, 21: HII region expansion)',ieos_in) end subroutine get_input_from_prompts !---------------------------------------------------------------- @@ -235,6 +306,7 @@ subroutine write_setupfile(filename) write(iunit,"(/,a)") '# options for sphere' call write_inopt(Mcloud_msun,'M_cloud','mass of cloud in solar masses',iunit) call write_inopt(Rcloud_pc,'R_cloud','radius of cloud in pc',iunit) + call write_inopt(relax, 'relax', 'relax the cloud ?', iunit) write(iunit,"(/,a)") '# options required for initial sound speed' call write_inopt(Temperature,'Temperature','Temperature',iunit) call write_inopt(mu,'mu','mean molecular mass',iunit) diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index ed22b212c..2ae3e5427 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -29,10 +29,9 @@ module setup ! - spin : *spin parameter of black hole |a|<1* ! - theta : *inclination of disc (degrees)* ! -! :Dependencies: dim, eos, extern_lensethirring, externalforces, -! infile_utils, io, kernel, metric, mpidomain, options, part, physcon, -! prompting, setdisc, setorbit, setstar, setunits, setup_params, -! timestep, units +! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, +! io, kernel, metric, mpidomain, options, part, physcon, prompting, +! setdisc, setorbit, setstar, setunits, setup_params, timestep, units ! use options, only:alpha use setstar, only:star_t diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 new file mode 100644 index 000000000..429558843 --- /dev/null +++ b/src/setup/setup_starcluster.f90 @@ -0,0 +1,265 @@ +!--------------------------------------------------------------------------! +! 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 setup +! +! Setup for simulations of the Galactic Centre +! Adapted by Daniel Price in collaboration with Jorge Cuadra +! +! :References: Paumard et al. (2006) +! +! :Owner: Yrisch +! +! :Runtime parameters: +! - datafile : *filename for star data (m,x,y,z,vx,vy,vz)* +! - h_sink : *sink particle radii in parsec* +! - m_gas : *gas mass resolution in solar masses* +! +! :Dependencies: datafiles, dim, eos, infile_utils, io, part, physcon, +! prompting, ptmass, spherical, timestep, units +! + implicit none + public :: setpart + + ! + ! setup options and default values for these + ! + character(len=120) :: datafile = 'clusterbin.txt' + real :: m_gas = 1.e-6 ! gas mass resolution in Msun + real :: h_sink = 1.e-14 ! sink particle radii in arcsec at 8kpc + + private + +contains + +!---------------------------------------------------------------- +!+ +! setup for galactic centre simulation (no gas) +!+ +!---------------------------------------------------------------- +subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas + use units, only:set_units,umass !,udist + use physcon, only:solarm,kpc,pi,au,years,pc + use io, only:fatal,iprint,master + use eos, only:gmw + use timestep, only:dtmax,tmax + use spherical, only:set_sphere + use datafiles, only:find_phantom_datafile + use ptmass, only:use_fourthorder,use_regnbody + integer, intent(in) :: id + integer, intent(inout) :: npart + integer, intent(out) :: npartoftype(:) + real, intent(out) :: xyzh(:,:) + real, intent(out) :: massoftype(:) + real, intent(out) :: polyk,gamma,hfact + real, intent(inout) :: time + character(len=20), intent(in) :: fileprefix + real, intent(out) :: vxyzu(:,:) + character(len=len(fileprefix)+6) :: setupfile + character(len=len(datafile)) :: filename + integer :: ntot + integer :: ierr,i + real :: xcom(3),vcom(3),mtot + real :: psep +! +! units (mass = mass of black hole, length = 1 arcsec at 8kpc) +! + call set_units(mass=solarm,dist=1*pc,G=1.d0) +! +! general parameters +! + xcom = 0. + vcom = 0. + time = 0. + hfact = 1.2 + polyk = 0. + gamma = 5./3. + gmw = 0.6 ! completely ionized, solar abu; eventually needs to be WR abu + dtmax = 1.e-5 + tmax = 0.001 + use_fourthorder = .true. + use_regnbody = .false. + m_gas = 1.e-4 + ntot = 2**21 + ! + ! read setup parameters from the .setup file + ! if file does not exist, then ask for user input + ! + setupfile = trim(fileprefix)//'.setup' + call read_setupfile(setupfile,iprint,ierr) + if (ierr /= 0 .and. id==master) then + call interactive_setup() ! read setup options from user + call write_setupfile(setupfile,iprint) ! write .setup file with defaults + endif +! +! space available for injected gas particles +! + npart = 0 + npartoftype(:) = 0 + massoftype = m_gas*(solarm/umass) ! mass resolution + + xyzh(:,:) = 0. + vxyzu(:,:) = 0. + xyzmh_ptmass(:,:) = 0. + vxyz_ptmass (:,:) = 0. +! +! Read positions, masses and velocities of stars from file +! + filename = find_phantom_datafile(datafile,"starcluster") + call read_ptmass_data(filename,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr) + + mtot = sum(xyzmh_ptmass(4,:)) + + do i=1,nptmass + xcom(1:3) = xcom(1:3) + xyzmh_ptmass(4,i)*xyzmh_ptmass(1:3,i) + vcom(1:3) = vcom(1:3) + xyzmh_ptmass(4,i)*vxyz_ptmass(1:3,i) + enddo + xcom = xcom/mtot + vcom = vcom/mtot + + print*,"xcom",xcom + print*,"vcom",vcom + + do i=1,nptmass + xyzmh_ptmass(1:3,i) = xyzmh_ptmass(1:3,i) - xcom(1:3) + vxyz_ptmass(1:3,i) = vxyz_ptmass(1:3,i) - vcom(1:3) + xyzmh_ptmass(ihacc,i) = h_sink + xyzmh_ptmass(ihsoft,i) = h_sink + enddo + + +! +! setup initial sphere of particles to prevent initialisation problems +! + psep = 1.0 + call set_sphere('random',id,master,0.,10.,psep,hfact,npart,xyzh,np_requested=ntot) + vxyzu(4,:) = 5.317e-4 + npartoftype(igas) = npart + + print*,"npart : ", npart + + if (nptmass == 0) call fatal('setup','no particles setup') + if (ierr /= 0) call fatal('setup','ERROR during setup') + +end subroutine setpart + +!---------------------------------------------------------------- +!+ +! read sink particle masses, positions and velocities from file +!+ +!---------------------------------------------------------------- +subroutine read_ptmass_data(filename,xyzmh_ptmass,vxyz_ptmass,n,ierr) + use io, only:error + use units, only : unit_velocity + character(len=*), intent(in) :: filename + real, intent(out) :: xyzmh_ptmass(:,:), vxyz_ptmass(:,:) + integer, intent(inout) :: n + integer, intent(out) :: ierr + integer :: iunit,n_input + + n_input = n + open(newunit=iunit,file=filename,status='old',action='read',iostat=ierr) + if (ierr /= 0) then + print "(/,2(a,/))",' ERROR opening "'//trim(filename)//'" for read of point mass data', & + ' -> this file should contain m,x,y,z,vx,vy,vz for each point mass, one per line' + endif + do while(ierr==0) + n = n + 1 + if (n > size(xyzmh_ptmass(1,:))) then + ierr = 66 + else + read(iunit,*,iostat=ierr) xyzmh_ptmass(4,n),xyzmh_ptmass(1:3,n),vxyz_ptmass(1:3,n) + endif + vxyz_ptmass(1:3,n) = (vxyz_ptmass(1:3,n)*1.e5)/unit_velocity + if (ierr /= 0) n = n - 1 + enddo + print "(a,i4,a)",' READ',n - n_input,' point masses from '//trim(filename) + if (ierr==66) then + call error('read_ptmass_data','array size exceeded in read_ptmass_data, recompile with MAXPTMASS=n',var='n',ival=n+1) + endif + + ! end of file error is OK + if (ierr < 0) ierr = 0 + +end subroutine read_ptmass_data + +!------------------------------------------ +!+ +! Write setup parameters to .setup file +!+ +!------------------------------------------ +subroutine write_setupfile(filename,iprint) + use infile_utils, only:write_inopt + use dim, only:tagline + character(len=*), intent(in) :: filename + integer, intent(in) :: iprint + integer :: lu,ierr1,ierr2 + + write(iprint,"(a)") ' Writing '//trim(filename)//' with setup options' + open(newunit=lu,file=filename,status='replace',form='formatted') + write(lu,"(a)") '# '//trim(tagline) + write(lu,"(a)") '# input file for Phantom galactic centre setup' + + write(lu,"(/,a)") '# datafile' + call write_inopt(datafile,'datafile','filename for star data (m,x,y,z,vx,vy,vz)',lu,ierr1) + + write(lu,"(/,a)") '# resolution' + call write_inopt(m_gas, 'm_gas','gas mass resolution in solar masses',lu,ierr2) + call write_inopt(h_sink, 'h_sink','sink particle radii in parsec',lu,ierr2) + close(lu) + +end subroutine write_setupfile + +!------------------------------------------ +!+ +! Read setup parameters from input file +!+ +!------------------------------------------ +subroutine read_setupfile(filename,iprint,ierr) + use infile_utils, only:open_db_from_file,inopts,close_db,read_inopt + use dim, only:maxvxyzu + character(len=*), intent(in) :: filename + integer, parameter :: lu = 21 + integer, intent(in) :: iprint + integer, intent(out) :: ierr + integer :: nerr + type(inopts), allocatable :: db(:) + + call open_db_from_file(db,filename,lu,ierr) + if (ierr /= 0) return + write(iprint, '(1x,2a)') 'Setup_Nbody_test: Reading setup options from ',trim(filename) + + nerr = 0 + call read_inopt(datafile,'datafile',db,errcount=nerr) + call read_inopt(m_gas,'m_gas',db,errcount=nerr) + call read_inopt(h_sink,'h_sink',db,errcount=nerr) + + if (nerr > 0) then + print "(1x,a,i2,a)",'Setup_Nbody_test: ',nerr,' error(s) during read of setup file' + ierr = 1 + endif + call close_db(db) + +end subroutine read_setupfile + +!------------------------------------------ +!+ +! Prompt user for setup options +!+ +!------------------------------------------ +subroutine interactive_setup() + use prompting, only:prompt + + print "(2(/,a),/)",'*** Nbody test setup. You can put any cluster of stars that you want to evolve with gas.',& + ' ... With or without primordial binaries, mass(msun), pos (pc), vel(kms)***' + call prompt('Enter filename for star data',datafile,noblank=.true.) + call prompt('Enter sink particle radii in parsec',h_sink,1.e-15,1.e-4) + print "(a)" + +end subroutine interactive_setup + +end module setup diff --git a/src/setup/setup_testparticles.f90 b/src/setup/setup_testparticles.f90 index edbd8ab47..fbc4f0410 100644 --- a/src/setup/setup_testparticles.f90 +++ b/src/setup/setup_testparticles.f90 @@ -100,7 +100,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, period = 0. if (gr) call prompt('black hole spin',spin,-1.,1.) - call prompt('select orbit type (1=cirlce, 2=precession, 3=epicycle, 4=vertical-oscillation, 0=custom)',orbtype,0,4) + call prompt('select orbit type (1=circle, 2=precession, 3=epicycle, 4=vertical-oscillation, 0=custom)',orbtype,0,4) select case(orbtype) case(1) ! circular diff --git a/src/setup/setup_wind.f90 b/src/setup/setup_wind.f90 new file mode 100644 index 000000000..e41b19227 --- /dev/null +++ b/src/setup/setup_wind.f90 @@ -0,0 +1,821 @@ +!--------------------------------------------------------------------------! +! 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 setup +! +! initial conditions for binary wind accretion / AGB star wind injection +! +! :References: +! Siess et al. 2022, A&A, 667, 75 +! +! :Owner: Lionel Siess +! +! :Runtime parameters: +! - Reff2a : *tight binary primary effective radius (au)* +! - Reff2b : *tight binary secondary effective radius (au)* +! - T_wind : *wind temperature (K)* +! - Teff2a : *tight binary primary effective temperature (K)* +! - Teff2b : *tight binary secondary effective temperature (K)* +! - binary2_a : *tight binary semi-major axis* +! - binary2_e : *tight binary eccentricity* +! - eccentricity : *eccentricity of the binary system* +! - icompanion_star : *set to 1 for a binary system, 2 for a triple system* +! - inclination : *inclination of the tight binary system w.r.t. outer binary (deg)* +! - lum2a : *tight binary primary luminosity (Lsun)* +! - lum2b : *tight binary secondary luminosity (Lsun)* +! - mass_of_particles : *particle mass (Msun, overwritten if iwind_resolution <>0)* +! - primary_Reff : *primary star effective radius (au)* +! - primary_Teff : *primary star effective temperature (K)* +! - primary_lum : *primary star luminosity (Lsun)* +! - primary_mass : *primary star mass (Msun)* +! - primary_racc : *primary star accretion radius (au)* +! - q2 : *tight binary mass ratio* +! - racc2a : *tight binary primary accretion radius* +! - racc2b : *tight binary secondary accretion radius* +! - secondary_Reff : *secondary star effective radius (au)* +! - secondary_Teff : *secondary star effective temperature)* +! - secondary_lum : *secondary star luminosity (Lsun)* +! - secondary_mass : *secondary star mass (Msun)* +! - secondary_racc : *secondary star accretion radius (au)* +! - semi_major_axis : *semi-major axis of the binary system (au)* +! - subst : *star to substitute* +! - temp_exponent : *temperature profile T(r) = T_wind*(r/Reff)^(-temp_exponent)* +! - wind_gamma : *adiabatic index (initial if Krome chemistry used)* +! +! :Dependencies: dim, eos, infile_utils, inject, io, part, physcon, +! prompting, setbinary, sethierarchical, spherical, units +! + use dim, only:isothermal + implicit none + public :: setpart + + private + real, public :: wind_gamma + real, public :: T_wind + real :: temp_exponent + integer :: icompanion_star,iwind + real :: semi_major_axis,semi_major_axis_au,eccentricity + real :: default_particle_mass + real :: primary_lum_lsun,primary_mass_msun,primary_Reff_au,primary_racc_au + real :: secondary_lum_lsun,secondary_mass_msun,secondary_Reff_au,secondary_racc_au + real :: lum2a_lsun,lum2b_lsun,Teff2a,Teff2b,Reff2a_au,Reff2b_au + real :: binary2_a_au,racc2a_au,racc2b_au,binary2_i,q2 + real :: primary_Reff,primary_Teff,primary_lum,primary_mass,primary_racc + real :: secondary_Reff,secondary_Teff,secondary_lum,secondary_mass,secondary_racc + real :: Reff2a,Reff2b + real :: racc2a,racc2b + real :: lum2a,lum2b + real :: binary2_a + real :: binary2_e + integer :: subst + +contains +!---------------------------------------------------------------- +!+ +! default parameter choices +!+ +!---------------------------------------------------------------- +subroutine set_default_parameters_wind() + + wind_gamma = 5./3. + if (isothermal) then + T_wind = 100000. + temp_exponent = 0.5 + ! primary_racc_au = 0.465 + ! primary_mass_msun = 1.5 + ! primary_lum_lsun = 0. + ! primary_Reff_au = 0.465240177008 !100 Rsun + else + T_wind = 3000. + !primary_racc_au = 1. + !primary_mass_msun = 1.5 + !primary_lum_lsun = 20000. + !primary_Reff_au = 0. + endif + icompanion_star = 0 + semi_major_axis = 4.0 + eccentricity = 0. + primary_Teff = 3000. + secondary_Teff = 0. + semi_major_axis_au = 4.0 + default_particle_mass = 1.e-11 + primary_lum_lsun = 5315. + primary_mass_msun = 1.5 + primary_Reff_au = 1. + primary_racc_au = 1. + secondary_lum_lsun = 0. + secondary_mass_msun = 1.0 + secondary_Reff_au = 0. + secondary_racc_au = 0.1 + lum2a_lsun = 0. + lum2b_lsun = 0. + Teff2a = 0. + Teff2b = 0. + Reff2a_au = 0. + Reff2b_au = 0. + binary2_a_au = 0.3 + racc2a_au = 0.1 + racc2b_au = 0.1 + binary2_i = 0. + +end subroutine set_default_parameters_wind + +!---------------------------------------------------------------- +!+ +! setup for uniform particle distributions +!+ +!---------------------------------------------------------------- +subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) + use part, only: xyzmh_ptmass, vxyz_ptmass, nptmass, igas, iTeff, iLum, iReff + use physcon, only: au, solarm, mass_proton_cgs, kboltz, solarl + use units, only: umass,set_units,unit_velocity,utime,unit_energ,udist + use inject, only: set_default_options_inject + use setbinary, only: set_binary + use sethierarchical, only: set_multiple + use io, only: master + use eos, only: gmw,ieos,isink,qfacdisc + use spherical, only: set_sphere + 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 + real, intent(inout) :: time + character(len=*), intent(in) :: fileprefix + character(len=len(fileprefix)+6) :: filename + integer :: ierr,k + logical :: iexist + + call set_units(dist=au,mass=solarm,G=1.) + call set_default_parameters_wind() + filename = trim(fileprefix)//'.in' + inquire(file=filename,exist=iexist) + if (.not. iexist) call set_default_options_inject() + +!--general parameters +! + time = 0. + filename = trim(fileprefix)//'.setup' + inquire(file=filename,exist=iexist) + if (iexist) call read_setupfile(filename,ierr) + if (.not. iexist .or. ierr /= 0) then + if (id==master) then + call setup_interactive() + call write_setupfile(filename) + endif + endif + +! +!--space available for injected gas particles +! + npart = 0 + npartoftype(:) = 0 + xyzh(:,:) = 0. + vxyzu(:,:) = 0. + xyzmh_ptmass(:,:) = 0. + vxyz_ptmass(:,:) = 0. + + if (icompanion_star == 1) then + call set_binary(primary_mass, & + secondary_mass, & + semi_major_axis, & + eccentricity, & + primary_racc, & + secondary_racc, & + xyzmh_ptmass, vxyz_ptmass, nptmass, ierr) + xyzmh_ptmass(iTeff,1) = primary_Teff + xyzmh_ptmass(iReff,1) = primary_Reff + xyzmh_ptmass(iLum,1) = primary_lum + xyzmh_ptmass(iTeff,2) = secondary_Teff + xyzmh_ptmass(iReff,2) = secondary_Reff + xyzmh_ptmass(iLum,2) = secondary_lum + elseif (icompanion_star == 2) then + !-- hierarchical triple + nptmass = 0 + print "(/,a)",'----------- Hierarchical triple -----------' + print "(a,g10.3,a)",' First hierarchical level primary mass: ', primary_mass_msun + print "(a,g10.3,a)",' First hierarchical level secondary mass: ', secondary_mass_msun + print "(a,g10.3)", ' Wide binary mass ratio: ', secondary_mass/primary_mass + print "(a,g10.3)", ' Tight binary mass ratio: ', q2 + print "(a,g10.3)", ' Star to be substituted: ', abs(subst) +! print "(a,g10.3,a)",' Accretion Radius 1: ', primary_racc!, trim(dist_unit) +! print "(a,g10.3,a)",' Accretion Radius 2a: ', racc2a!, trim(dist_unit) +! print "(a,g10.3,a)",' Accretion Radius 2b: ', racc2b!, trim(dist_unit) + + if (subst>0) then + print "(a,g10.3,a)",' Tight binary orientation referred to: substituted star orbital plane' + else + print "(a,g10.3,a)",' Tight binary orientation referred to: sky' + endif + + + call set_multiple(primary_mass,secondary_mass,semimajoraxis=semi_major_axis,eccentricity=eccentricity, & + accretion_radius1=primary_racc,accretion_radius2=secondary_racc, & + xyzmh_ptmass=xyzmh_ptmass,vxyz_ptmass=vxyz_ptmass,nptmass=nptmass,ierr=ierr) + + if (subst == 12) then + call set_multiple(secondary_mass/(q2+1),secondary_mass*q2/(q2+1),semimajoraxis=binary2_a,eccentricity=binary2_e, & + accretion_radius1=racc2a,accretion_radius2=racc2b, & + xyzmh_ptmass=xyzmh_ptmass,vxyz_ptmass=vxyz_ptmass,nptmass=nptmass,& + posang_ascnode=0.,arg_peri=0.,incl=binary2_i,subst=subst,ierr=ierr) + + xyzmh_ptmass(iTeff,1) = primary_Teff + xyzmh_ptmass(iReff,1) = primary_Reff + xyzmh_ptmass(iLum,1) = primary_lum + xyzmh_ptmass(iTeff,2) = Teff2a + xyzmh_ptmass(iReff,2) = Reff2a + xyzmh_ptmass(iLum,2) = lum2a + xyzmh_ptmass(iTeff,3) = Teff2b + xyzmh_ptmass(iReff,3) = Reff2b + xyzmh_ptmass(iLum,3) = lum2b + + elseif (subst == 11) then + call set_multiple(primary_mass*q2/(q2+1),primary_mass/(q2+1),semimajoraxis=binary2_a,eccentricity=binary2_e, & + accretion_radius1=racc2b,accretion_radius2=primary_racc, & + xyzmh_ptmass=xyzmh_ptmass,vxyz_ptmass=vxyz_ptmass,nptmass=nptmass,& + posang_ascnode=0.,arg_peri=0.,incl=binary2_i,subst=subst,ierr=ierr) + + xyzmh_ptmass(iTeff,1) = primary_Teff + xyzmh_ptmass(iReff,1) = primary_Reff + xyzmh_ptmass(iLum,1) = primary_lum + xyzmh_ptmass(iTeff,2) = secondary_Teff + xyzmh_ptmass(iReff,2) = secondary_Reff + xyzmh_ptmass(iLum,2) = secondary_lum + xyzmh_ptmass(iTeff,3) = Teff2b + xyzmh_ptmass(iReff,3) = Reff2b + xyzmh_ptmass(iLum,3) = lum2b + endif + + print *,'Sink particles summary' + print *,' # mass racc lum Reff' + do k=1,nptmass + print '(i4,2(2x,f9.5),2(2x,es10.3))',k,xyzmh_ptmass(4:5,k),xyzmh_ptmass(iLum,k)/(solarl*utime/unit_energ),& + xyzmh_ptmass(iReff,k)*udist/au + enddo + print *,'' + + else + nptmass = 1 + xyzmh_ptmass(4,1) = primary_mass + xyzmh_ptmass(5,1) = primary_racc + xyzmh_ptmass(iTeff,1) = primary_Teff + xyzmh_ptmass(iReff,1) = primary_Reff + xyzmh_ptmass(iLum,1) = primary_lum + endif + + ! + ! for binary wind simulations the particle mass is IRRELEVANT + ! since it will be over-written on the first call to init_inject + ! + massoftype(igas) = default_particle_mass * (solarm / umass) + + if (isothermal) then + gamma = 1. + if (iwind == 3) then + ieos = 6 + qfacdisc = 0.5*temp_exponent + isink = 1 + T_wind = primary_Teff + else + isink = 1 + ieos = 1 + endif + else + T_wind = 0. + gamma = wind_gamma + endif + polyk = kboltz*T_wind/(mass_proton_cgs * gmw * unit_velocity**2) + +end subroutine setpart + +!---------------------------------------------------------------- +!+ +! determine which problem to set up interactively +!+ +!---------------------------------------------------------------- +subroutine setup_interactive() + use prompting, only:prompt + use physcon, only:au,solarm + use units, only:umass,udist + use io, only:fatal + integer :: ichoice + + if (isothermal) then + iwind = 2 + else + iwind = 1 + call prompt('Type of wind: 1=adia, 2=isoT, 3=T(r)',iwind,1,3) + if (iwind == 2 .or. iwind == 3) then + call fatal('setup','If you choose options 2 or 3, the code must be compiled with SETUP=isowind') + endif + if (iwind == 3) T_wind = primary_Teff + endif + + icompanion_star = 0 + call prompt('Add binary?',icompanion_star,0,2) + + !Hierarchical triple system + if (icompanion_star == 2) then + !select the tight binary + ichoice = 1 + print "(a)",'Star to be substituted by a tight binary' + print "(a)",' 1: primary (2+1)' ,' 2: companion (1+2)' + call prompt('Select star to be substituted',ichoice,1,2) + subst = ichoice+10 + + !select orbital parameters for outer binary + semi_major_axis_au = 15. + eccentricity = 0. + ichoice = 1 + print "(a)",'Orbital parameters first hierarchical level binary' + print "(a)",' 1: semi-axis = 15 au, eccentricity = 0',' 0: custom' + call prompt('select semi-major axis and ecccentricity',ichoice,0,1) + if (ichoice == 0) then + call prompt('enter semi-major axis in au',semi_major_axis_au,0.,100.) + call prompt('enter eccentricity',eccentricity,0.) + endif + semi_major_axis = semi_major_axis_au * au / udist + ichoice = 1 + + !replace companion by tight binary system : 1+2 + if (subst == 12) then + print "(a)",'Primary star parameters (the single wind launching central star)' + print "(a)",' 2: Mass = 1.2 Msun, accretion radius = 0.2568 au',& + ' 1: Mass = 1.5 Msun, accretion radius = 1.2568 au', & + ' 0: custom' + call prompt('select mass and radius of primary',ichoice,0,2) + select case(ichoice) + case(2) + primary_mass_msun = 1.2 + primary_racc_au = 0.2568 + case(1) + primary_mass_msun = 1.5 + primary_racc_au = 1.2568 + case default + primary_mass_msun = 1.5 + primary_racc_au = 1. + call prompt('enter primary mass',primary_mass_msun,0.,100.) + call prompt('enter accretion radius in au ',primary_racc_au,0.) + end select + primary_mass = primary_mass_msun * (solarm / umass) + primary_racc = primary_racc_au * (au / udist) + + ichoice = 1 + print "(a)",'Total mass of tight binary system (1+2)' + print "(a)",' 1: Total mass tight binary = 1.0 Msun',' 0: custom' + secondary_mass_msun = 1. + call prompt('select mass',ichoice,0,1) + select case(ichoice) + case(0) + call prompt('enter total mass tigh binary',secondary_mass_msun,0.,100.) + end select + secondary_mass = secondary_mass_msun * (solarm / umass) + + ichoice = 1 + print "(a)",'Mass ratio and accretion radii of stars in tight orbit:' + print "(a)",' 1: mass ratio m2b/m2a = 1, accretion radius a = 0.01 au, accretion radius b = 0.01 au',' 0: custom' + call prompt('select mass ratio and accretion radii of tight binary',ichoice,0,1) + select case(ichoice) + case(1) + q2 = 1. + racc2a_au = 0.1 + racc2b_au = 0.1 + case default + q2 = 1. + racc2a_au = 0.1 + racc2b_au = 0.1 + call prompt('enter tight binary mass ratio',q2,0.) + call prompt('enter accretion radius a in au ',racc2a_au,0.) + call prompt('enter accretion radius b in au ',racc2b_au,0.) + end select + racc2a = racc2a_au * (au / udist) + racc2b = racc2b_au * (au / udist) + secondary_racc = racc2a !needs to be /=0 otherwise NaNs in set_multiple + + !replace primary by tight binary system : 2+1 + elseif (subst == 11) then + print "(a)",'Stellar parameters of the remote single star (2+1)' + print "(a)",' 1: Mass = 1.0 Msun, accretion radius = 0.1 au',' 0: custom' + call prompt('select mass and radius of remote single star',ichoice,0,1) + select case(ichoice) + case(1) + secondary_mass_msun = 1. + secondary_racc_au = 0.1 + case default + secondary_mass_msun = 1. + secondary_racc_au = 0.1 + call prompt('enter mass of remote single star',secondary_mass_msun,0.,100.) + call prompt('enter accretion radius in au ',secondary_racc_au,0.) + end select + secondary_mass = secondary_mass_msun * (solarm / umass) + secondary_racc = secondary_racc_au * (au / udist) + + ichoice = 1 + print "(a)",'wind-launching star accretion radius in tigh orbit (called primary)' + print "(a)",' 2: accretion radius primary = 0.2568 au',& + ' 1: accretion radius primary = 1.2568 au', & + ' 0: custom' + call prompt('select accretion radius of wind launching star',ichoice,0,2) + select case(ichoice) + case(2) + primary_racc_au = 0.2568 + case(1) + primary_racc_au = 1.2568 + case default + primary_racc_au = 1. + call prompt('enter accretion radius in au ',primary_racc_au,0.) + end select + primary_racc = primary_racc_au * (au / udist) + + ichoice = 1 + print "(a)",'Total mass of the tight binary system (2+1):' + print "(a)",' 2: Total mass tight binary = 1.2 Msun',& + ' 1: Total mass tight binary = 1.5 Msun', & + ' 0: custom' + call prompt('select total mass tight binary',ichoice,0,2) + select case(ichoice) + case(2) + primary_mass_msun = 1.2 + case(1) + primary_mass_msun = 1.5 + case default + primary_mass_msun = 1.5 + call prompt('enter primary mass',primary_mass_msun,0.,100.) + end select + primary_mass = primary_mass_msun * (solarm / umass) + + ichoice = 1 + print "(a)",'Mass ratio and accretion radius of secondary in tight orbit:' + print "(a)",' 1: mass ratio m1b/m1a = 0.3, accretion radius b = 0.01 au',' 0: custom' + call prompt('select mass ratio and accretion radius of tight binary',ichoice,0,1) + select case(ichoice) + case(1) + q2 = 0.3 + racc2b_au = 0.1 + case default + q2 = 0.3 + racc2b_au = 0.1 + call prompt('enter tight binary mass ratio',q2,0.) + call prompt('enter accretion radius b in au ',racc2b_au,0.) + end select + racc2b = racc2b_au * (au / udist) + endif + + ichoice = 1 + print "(a)",'Orbital parameters of tight system:' + print "(a)",' 1: semi-axis = 4 au, eccentricity = 0',' 0: custom' + call prompt('select tight binary semi-major axis and eccentricity',ichoice,0,1) + select case(ichoice) + case(1) + binary2_a_au = 4. + binary2_e = 0. + case default + binary2_a_au = 4. + binary2_e = 0. + call prompt('enter semi-major axis in au',binary2_a_au,0.,semi_major_axis_au) + call prompt('enter eccentricity',binary2_e,0.) + end select + binary2_a = binary2_a_au * au / udist + + ichoice = 1 + print "(a)",'inclination of orbit tight binary w.r.t. outer binary:' + print "(a)",' 1: inclination = 0 deg',' 0: custom' + call prompt('select inclination',ichoice,0,1) + select case(ichoice) + case(1) + binary2_i = 0. + case default + binary2_i = 0. + call prompt('enter inclination',binary2_i,0.,90.) + end select + + !binary or single star case + else + if (icompanion_star == 1) then + print "(a)",'Primary star parameters' + else + print "(a)",'Stellar parameters' + endif + ichoice = 2 + print "(a)",' 3: Mass = 1.2 Msun, accretion radius = 1. au (trans-sonic)',& + ' 2: Mass = 1.2 Msun, accretion radius = 0.2568 au',& + ' 1: Mass = 1.0 Msun, accretion radius = 1.2568 au', & + ' 0: custom' + call prompt('select mass and radius of primary',ichoice,0,3) + select case(ichoice) + case(3) + primary_lum_lsun = 2.d4 + primary_Teff = 5.d4 + primary_mass_msun = 1.2 + primary_racc_au = 1. + wind_gamma = 1.4 + case(2) + primary_mass_msun = 1.2 + primary_racc_au = 0.2568 + case(1) + primary_mass_msun = 1. + primary_racc_au = 1.2568 + case default + primary_mass_msun = 1. + primary_racc_au = 1. + call prompt('enter primary mass',primary_mass_msun,0.,100.) + call prompt('enter accretion radius in au ',primary_racc_au,0.) + end select + primary_mass = primary_mass_msun * (solarm / umass) + primary_racc = primary_racc_au * (au / udist) + + if (icompanion_star == 1) then + ichoice = 1 + print "(a)",'Secondary star parameters' + print "(a)",' 1: Mass = 1.0 Msun, accretion radius = 0.1 au',' 0: custom' + call prompt('select mass and radius of secondary',ichoice,0,1) + select case(ichoice) + case(1) + secondary_mass_msun = 1. + secondary_racc_au = 0.1 + case default + secondary_mass_msun = 1. + secondary_racc_au = 0.1 + call prompt('enter secondary mass',secondary_mass_msun,0.,100.) + call prompt('enter accretion radius in au ',secondary_racc_au,0.) + end select + secondary_mass = secondary_mass_msun * (solarm / umass) + secondary_racc = secondary_racc_au * (au / udist) + + ichoice = 1 + print "(a)",'Orbital parameters' + print "(a)",' 1: semi-axis = 3.7 au, eccentricity = 0',' 0: custom' + call prompt('select semi-major axis and ecccentricity',ichoice,0,1) + select case(ichoice) + case(1) + semi_major_axis_au = 3.7 + eccentricity = 0. + case default + semi_major_axis_au = 1. + eccentricity = 0. + call prompt('enter semi-major axis in au',semi_major_axis_au,0.,100.) + call prompt('enter eccentricity',eccentricity,0.) + end select + semi_major_axis = semi_major_axis_au * au / udist + endif + endif + +end subroutine setup_interactive + +!---------------------------------------------------------------- +!+ +! get luminosity and effective radius in code units +! from various combinations of L, Teff and Reff in physical inuts +!+ +!---------------------------------------------------------------- +subroutine get_lum_and_Reff(lum_lsun,reff_au,Teff,lum,Reff) + use physcon, only:au,steboltz,solarl,pi + use units, only:udist,unit_luminosity + real, intent(inout) :: lum_lsun,reff_au,Teff + real, intent(out) :: lum,Reff + + if (Teff <= tiny(0.) .and. lum_lsun > 0. .and. Reff_au > 0.) then + primary_Teff = (lum_lsun*solarl/(4.*pi*steboltz*(Reff_au*au)**2))**0.25 + elseif (Reff_au <= 0. .and. lum_lsun > 0. .and. Teff > 0.) then + Reff_au = sqrt(lum_lsun*solarl/(4.*pi*steboltz*Teff**4))/au + elseif (Reff_au > 0. .and. lum_lsun <= 0. .and. Teff > 0.) then + lum_lsun = 4.*pi*steboltz*Teff**4*(primary_Reff_au*au)**2/solarl + endif + + lum = lum_lsun*(solarl/unit_luminosity) + Reff = Reff_au*(au/udist) + +end subroutine get_lum_and_Reff + +!---------------------------------------------------------------- +!+ +! write parameters to setup file +!+ +!---------------------------------------------------------------- +subroutine write_setupfile(filename) + use infile_utils, only:write_inopt + character(len=*), intent(in) :: filename + integer, parameter :: iunit = 20 + + print "(a)",' writing setup options file '//trim(filename) + open(unit=iunit,file=filename,status='replace',form='formatted') + write(iunit,"(a)") '# input file for wind setup routine' + + call get_lum_and_Reff(primary_lum_lsun,primary_Reff_au,primary_Teff,primary_lum,primary_Reff) + + if (icompanion_star == 2) then + call get_lum_and_Reff(secondary_lum_lsun,secondary_Reff_au,secondary_Teff,secondary_lum,secondary_Reff) + + call write_inopt(icompanion_star,'icompanion_star','set to 1 for a binary system, 2 for a triple system',iunit) + !-- hierarchical triple + write(iunit,"(/,a)") '# options for hierarchical triple' + call write_inopt(subst,'subst','star to substitute',iunit) + write(iunit,"(/,a)") '# input of primary (wind launching star)' + if (subst == 12) then + call write_inopt(primary_mass_msun,'primary_mass','primary star mass (Msun)',iunit) + call write_inopt(primary_racc_au,'primary_racc','primary star accretion radius (au)',iunit) + call write_inopt(primary_lum_lsun,'primary_lum','primary star luminosity (Lsun)',iunit) + call write_inopt(primary_Teff,'primary_Teff','primary star effective temperature (K)',iunit) + call write_inopt(primary_Reff_au,'primary_Reff','primary star effective radius (au)',iunit) + call write_inopt(semi_major_axis_au,'semi_major_axis','semi-major axis of the binary system (au)',iunit) + call write_inopt(eccentricity,'eccentricity','eccentricity of the binary system',iunit) + write(iunit,"(/,a)") '# input secondary to be replaced by tight binary' + call write_inopt(secondary_mass_msun,'secondary_mass','total mass of secondary tight binary (Msun)',iunit) + call write_inopt(q2,'q2','tight binary mass ratio',iunit) + !-- tight orbital parameters + call write_inopt(binary2_a,'binary2_a','tight binary semi-major axis',iunit) + call write_inopt(binary2_e,'binary2_e','tight binary eccentricity',iunit) + !-- accretion radii, luminosity, radii + call write_inopt(racc2a_au,'racc2a','tight binary primary accretion radius',iunit) + call write_inopt(racc2b_au,'racc2b','tight binary secondary accretion radius',iunit) + call write_inopt(lum2a_lsun,'lum2a','tight binary primary luminosity (Lsun)',iunit) + call write_inopt(lum2b_lsun,'lum2b','tight binary secondary luminosity (Lsun)',iunit) + call write_inopt(Teff2a,'Teff2a','tight binary primary effective temperature (K)',iunit) + call write_inopt(Teff2b,'Teff2b','tight binary secondary effective temperature (K)',iunit) + call write_inopt(Reff2a_au,'Reff2a','tight binary primary effective radius (au)',iunit) + call write_inopt(Reff2b_au,'Reff2b','tight binary secondary effective radius (au)',iunit) + elseif (subst == 11) then + call write_inopt(primary_racc_au,'primary_racc','primary star accretion radius (au)',iunit) + call write_inopt(primary_lum_lsun,'primary_lum','primary star luminosity (Lsun)',iunit) + call write_inopt(primary_Teff,'primary_Teff','primary star effective temperature (K)',iunit) + call write_inopt(primary_Reff_au,'primary_Reff','primary star effective radius (au)',iunit) + write(iunit,"(/,a)") '# input tight binary to create close companion' + call write_inopt(primary_mass_msun,'primary_mass','primary star mass (Msun)',iunit) + call write_inopt(q2,'q2','tight binary mass ratio',iunit) + !-- tight orbital parameters + call write_inopt(binary2_a,'binary2_a','tight binary semi-major axis',iunit) + call write_inopt(binary2_e,'binary2_e','tight binary eccentricity',iunit) + !-- accretion radii + call write_inopt(racc2b_au,'racc2b','tight binary secondary accretion radius',iunit) + call write_inopt(lum2b_lsun,'lum2b','tight binary secondary luminosity (Lsun)',iunit) + call write_inopt(Teff2b,'Teff2b','tight binary secondary effective temperature (K)',iunit) + call write_inopt(Reff2b_au,'Reff2b','tight binary secondary effective radius (au)',iunit) + write(iunit,"(/,a)") '# input of secondary, outer binary' + call write_inopt(secondary_mass_msun,'secondary_mass','secondary star mass (Msun)',iunit) + call write_inopt(secondary_racc_au,'secondary_racc','secondary star accretion radius (au)',iunit) + call write_inopt(secondary_lum_lsun,'secondary_lum','secondary star luminosity (Lsun)',iunit) + call write_inopt(secondary_Teff,'secondary_Teff','secondary star effective temperature)',iunit) + call write_inopt(secondary_Reff_au,'secondary_Reff','secondary star effective radius (au)',iunit) + call write_inopt(semi_major_axis_au,'semi_major_axis','semi-major axis of the binary system (au)',iunit) + call write_inopt(eccentricity,'eccentricity','eccentricity of the binary system',iunit) + endif + call write_inopt(binary2_i,'inclination','inclination of the tight binary system w.r.t. outer binary (deg)',iunit) + !binary or single star + else + call write_inopt(primary_mass_msun,'primary_mass','primary star mass (Msun)',iunit) + call write_inopt(primary_racc_au,'primary_racc','primary star accretion radius (au)',iunit) + call write_inopt(primary_lum_lsun,'primary_lum','primary star luminosity (Lsun)',iunit) + call write_inopt(primary_Teff,'primary_Teff','primary star effective temperature (K)',iunit) + call write_inopt(primary_Reff_au,'primary_Reff','primary star effective radius (au)',iunit) + call write_inopt(icompanion_star,'icompanion_star','set to 1 for a binary system, 2 for a triple system',iunit) + if (icompanion_star == 1) then + call get_lum_and_Reff(secondary_lum_lsun,secondary_Reff_au,secondary_Teff,secondary_lum,secondary_Reff) + + call write_inopt(secondary_mass_msun,'secondary_mass','secondary star mass (Msun)',iunit) + call write_inopt(secondary_racc_au,'secondary_racc','secondary star accretion radius (au)',iunit) + call write_inopt(secondary_lum_lsun,'secondary_lum','secondary star luminosity (Lsun)',iunit) + call write_inopt(secondary_Teff,'secondary_Teff','secondary star effective temperature)',iunit) + call write_inopt(secondary_Reff_au,'secondary_Reff','secondary star effective radius (au)',iunit) + call write_inopt(semi_major_axis_au,'semi_major_axis','semi-major axis of the binary system (au)',iunit) + call write_inopt(eccentricity,'eccentricity','eccentricity of the binary system',iunit) + endif + endif + + call write_inopt(default_particle_mass,'mass_of_particles','particle mass (Msun, overwritten if iwind_resolution <>0)',iunit) + + if (isothermal) then + wind_gamma = 1. + if (iwind == 3) then + call write_inopt(primary_Teff,'T_wind','wind temperature at injection radius (K)',iunit) + call write_inopt(temp_exponent,'temp_exponent','temperature profile T(r) = T_wind*(r/Reff)^(-temp_exponent)',iunit) + else + call write_inopt(T_wind,'T_wind','wind temperature (K)',iunit) + endif + else + call write_inopt(wind_gamma,'wind_gamma','adiabatic index (initial if Krome chemistry used)',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 physcon, only:au,steboltz,solarl,solarm,pi + use units, only:udist,umass,utime,unit_energ + character(len=*), intent(in) :: filename + integer, intent(out) :: ierr + integer, parameter :: iunit = 21 + type(inopts), allocatable :: db(:) + integer :: nerr,ichange + + nerr = 0 + ichange = 0 + print "(a)",' reading setup options from '//trim(filename) + call open_db_from_file(db,filename,iunit,ierr) + call read_inopt(primary_mass_msun,'primary_mass',db,min=0.,max=1000.,errcount=nerr) + primary_mass = primary_mass_msun * (solarm / umass) + call read_inopt(primary_lum_lsun,'primary_lum',db,min=0.,max=1e7,errcount=nerr) + primary_lum = primary_lum_lsun * (solarl * utime / unit_energ) + call read_inopt(primary_Teff,'primary_Teff',db,min=0.,errcount=nerr) + call read_inopt(primary_Reff_au,'primary_Reff',db,min=0.,errcount=nerr) + primary_Reff = primary_Reff_au * au / udist + call read_inopt(primary_racc_au,'primary_racc',db,min=0.,errcount=nerr) + primary_racc = primary_racc_au * au / udist + if (primary_racc < tiny(0.)) then + print *,'ERROR: primary accretion radius not defined' + nerr = nerr+1 + endif + + call read_inopt(icompanion_star,'icompanion_star',db,min=0,errcount=nerr) + if (icompanion_star == 1) then + call read_inopt(secondary_mass_msun,'secondary_mass',db,min=0.,max=1000.,errcount=nerr) + secondary_mass = secondary_mass_msun * (solarm / umass) + call read_inopt(secondary_lum_lsun,'secondary_lum',db,min=0.,max=1e7,errcount=nerr) + secondary_lum = secondary_lum_lsun * (solarl * utime / unit_energ) + call read_inopt(secondary_Teff,'secondary_Teff',db,min=0.,errcount=nerr) + call read_inopt(secondary_Reff_au,'secondary_Reff',db,min=0.,errcount=nerr) + secondary_Reff = secondary_Reff_au * au / udist + call read_inopt(secondary_racc_au,'secondary_racc',db,min=0.,errcount=nerr) + secondary_racc = secondary_racc_au * au / udist + if (secondary_racc < tiny(0.)) then + print *,'ERROR: secondary accretion radius not defined' + nerr = nerr+1 + endif + call read_inopt(semi_major_axis_au,'semi_major_axis',db,min=0.,errcount=nerr) + semi_major_axis = semi_major_axis_au * au / udist + call read_inopt(eccentricity,'eccentricity',db,min=0.,errcount=nerr) + elseif (icompanion_star == 2) then + !-- hierarchical triple + call read_inopt(subst,'subst',db,errcount=nerr) + !replace primary by tight binary system : 2+1 + if (subst == 11) then + call read_inopt(secondary_lum_lsun,'secondary_lum',db,min=0.,max=1000.,errcount=nerr) + secondary_lum = secondary_lum_lsun * (solarl * utime / unit_energ) + call read_inopt(secondary_Teff,'secondary_Teff',db,min=0.,max=1000.,errcount=nerr) + call read_inopt(secondary_Reff_au,'secondary_Reff',db,min=0.,max=1000.,errcount=nerr) + secondary_Reff = secondary_Reff_au * au / udist + call read_inopt(secondary_racc_au,'secondary_racc',db,min=0.,max=1000.,errcount=nerr) + secondary_racc = secondary_racc_au * au / udist + elseif (subst == 12) then + call read_inopt(lum2a_lsun,'lum2a',db,errcount=nerr) + lum2a = lum2a_lsun * (solarl * utime / unit_energ) + !secondary_lum_lsun = lum2a_lsun + call read_inopt(Teff2a,'Teff2a',db,errcount=nerr) + call read_inopt(Reff2a_au,'Reff2a',db,errcount=nerr) + Reff2a = Reff2a_au * au / udist + !secondary_Reff = Reff2a + call read_inopt(racc2a_au,'racc2a',db,errcount=nerr) + racc2a = racc2a_au * au / udist + endif + call read_inopt(secondary_mass_msun,'secondary_mass',db,min=0.,max=1000.,errcount=nerr) + secondary_mass = secondary_mass_msun * (solarm / umass) + call read_inopt(semi_major_axis_au,'semi_major_axis',db,min=0.,errcount=nerr) + semi_major_axis = semi_major_axis_au * au / udist + call read_inopt(eccentricity,'eccentricity',db,min=0.,errcount=nerr) + !-- masses + call read_inopt(q2,'q2',db,min=0.,max=1.,errcount=nerr) + !-- tight parameters + call read_inopt(binary2_a_au,'binary2_a',db,errcount=nerr) + binary2_a = binary2_a_au * au / udist + call read_inopt(binary2_e,'binary2_e',db,errcount=nerr) + !-- accretion radii,... + call read_inopt(racc2b_au,'racc2b',db,errcount=nerr) + racc2b = racc2b_au * au / udist + if (racc2b < tiny(0.)) then + print *,'WARNING: secondary accretion radius not defined' + !nerr = nerr+1 + endif + call read_inopt(lum2b_lsun,'lum2b',db,errcount=nerr) + lum2b = lum2b_lsun * (solarl * utime / unit_energ) + call read_inopt(Teff2b,'Teff2b',db,errcount=nerr) + call read_inopt(Reff2b_au,'Reff2b',db,errcount=nerr) + Reff2b = Reff2b_au * au / udist + call read_inopt(binary2_i,'inclination',db,errcount=nerr) + endif + + call read_inopt(default_particle_mass,'mass_of_particles',db,min=0.,errcount=nerr) + + if (isothermal) then + wind_gamma = 1. + call read_inopt(T_wind,'T_wind',db,min=0.,errcount=nerr) + if (iwind == 3) call read_inopt(temp_exponent,'temp_exponent',db,min=0.,max=5.,errcount=nerr) + else + call read_inopt(wind_gamma,'wind_gamma',db,min=1.,max=4.,errcount=nerr) + endif + call close_db(db) + ierr = nerr + call write_setupfile(filename) + +end subroutine read_setupfile + +end module setup diff --git a/src/tests/test_fastmath.f90 b/src/tests/test_fastmath.f90 new file mode 100644 index 000000000..358b25133 --- /dev/null +++ b/src/tests/test_fastmath.f90 @@ -0,0 +1,162 @@ +!--------------------------------------------------------------------------! +! 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 testmath +! +! This module performs unit tests of the fast sqrt routines +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: fastmath, io, mpiutils, random +! + implicit none + public :: test_math + + private + +contains + +subroutine test_math(ntests,npass,usefsqrt,usefinvsqrt) + use io, only:id,master + use fastmath, only:checksqrt,testsqrt,finvsqrt + use random, only:ran2 + use mpiutils, only:barrier_mpi + integer, intent(inout) :: ntests,npass + logical, intent(out) :: usefsqrt,usefinvsqrt + integer, parameter :: n = 1000000 + integer, parameter :: stderr = 0 + integer :: ierr,iseed,nerr,i + real, allocatable :: x(:),f(:),y(:) + real :: t1,t2,errmax,tnative + + if (id==master) write(*,"(a,/)") '--> TESTING FAST SQRT ROUTINES' + + usefsqrt = .true. + usefinvsqrt = .true. +! +!--check for errors first +! + call testsqrt(ierr,output=.false.) + if (ierr /= 0) then + ! report errors on any threads + write(*, "(a)") ' *** ERROR with fast sqrt on this architecture ***' + usefsqrt = .false. + usefinvsqrt = .false. + write(*,"(/,a,/)") '<-- FAST SQRT TEST FAILED' + return + endif + + allocate(x(n),f(n),y(n),stat=ierr) + if (ierr /= 0) return + + iseed = -5234 + do i=1,n + x(i) = ran2(iseed)*1.e8 + enddo + + ntests = ntests + 1 + nerr = 0 + do i=1,n + call checksqrt(x(i),5.e-7*x(i),ierr,.false.) + nerr = max(ierr,nerr) + enddo + if (nerr > 0) then + usefsqrt = .false. + usefinvsqrt = .false. + else + npass = npass + 1 + endif + +! +!--check timings for inverse sqrt +! + call cpu_time(t1) + do i=1,n + f(i) = 1./sqrt(x(i)) + enddo + call cpu_time(t2) + tnative = t2-t1 + if (id==master) write(*,"(a,es10.3,a)") ' native 1/sqrt done in ',tnative,' cpu-s' + y = f + + call barrier_mpi + + call cpu_time(t1) + do i=1,n + f(i) = finvsqrt(x(i)) + enddo + call cpu_time(t2) + + ! run tests on all threads, but only report detailed results on master thread + if (id==master) write(*,"(a,es10.3,a)") ' fast 1/sqrt done in ',t2-t1,' cpu-s' + + if ((t2-t1) > tnative) then + if (id==master) write(*,"(a,f4.1)") ' so finvsqrt(x) is SLOWER than 1/sqrt(x) by factor of ',& + (t2-t1)/tnative + usefinvsqrt = .false. + else + if (id==master) write(*,"(a,f4.1)") ' so finvsqrt(x) is FASTER than 1/sqrt(x) by factor of ', & + tnative/(t2-t1) + endif + + errmax = 0. + do i=1,n + errmax = max(errmax,abs(y(i) - f(i))/y(i)) + enddo + if (id==master) write(*,"(1x,a,es10.3)") 'max relative error is ',errmax + if (errmax > 1.e-7) usefinvsqrt = .false. + + if (id==master) write(*,*) + call barrier_mpi +! +!--check timings for sqrt +! + call cpu_time(t1) + do i=1,n + f(i) = sqrt(x(i)) + enddo + call cpu_time(t2) + tnative = t2-t1 + if (id==master) write(*,"(a,es10.3,a)") ' native sqrt done in ',tnative,' cpu-s' + y = f + call barrier_mpi + + call cpu_time(t1) + do i=1,n + f(i) = x(i)*finvsqrt(x(i)) + enddo + call cpu_time(t2) + if (id==master) write(*,"(a,es10.3,a)") ' x*finvsqrt(x) done in ',t2-t1,' cpu-s' + + if ((t2-t1) > tnative) then + if (id==master) write(*,"(a,f4.1)") ' so x*finvsqrt(x) is SLOWER than sqrt(x) by factor of ',& + (t2-t1)/tnative + usefsqrt = .false. + else + if (id==master) write(*,"(a,f4.1)") ' so x*finvsqrt(x) is FASTER than sqrt(x) by factor of ',tnative/(t2-t1) + endif + + errmax = 0. + do i=1,n + errmax = max(errmax,abs(y(i) - f(i))/(y(i) + epsilon(y))) + enddo + if (id==master) write(*,"(1x,a,es10.3)") 'max relative error is ',errmax + if (errmax > 1.e-7) usefinvsqrt = .false. + + if (allocated(x)) deallocate(x) + if (allocated(f)) deallocate(f) + if (allocated(y)) deallocate(y) + + if (id==master) write(*,"(/,a,/)") '<-- FAST SQRT TEST COMPLETE' + call barrier_mpi + +end subroutine test_math + +end module testmath diff --git a/src/tests/test_gr.f90 b/src/tests/test_gr.f90 new file mode 100644 index 000000000..905a15a0d --- /dev/null +++ b/src/tests/test_gr.f90 @@ -0,0 +1,557 @@ +!--------------------------------------------------------------------------! +! 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 testgr +! +! Unit tests of General Relativity +! +! :References: Liptai & Price (2019), MNRAS +! +! :Owner: David Liptai +! +! :Runtime parameters: None +! +! :Dependencies: cons2prim, cons2primsolver, eos, extern_gr, inverse4x4, +! io, metric, metric_tools, part, physcon, substepping, testutils, units, +! utils_gr, vectorutils +! + use testutils, only:checkval,checkvalbuf,checkvalbuf_end,update_test_scores + implicit none + + public :: test_gr + + private + +contains +!----------------------------------------------------------------------- +!+ +! Unit tests for General Relativity +!+ +!----------------------------------------------------------------------- +subroutine test_gr(ntests,npass) + use io, only:id,master + use units, only:set_units + use physcon, only:solarm + integer, intent(inout) :: ntests,npass + + call set_units(mass=1.d6*solarm,G=1.d0,c=1.d0) + if (id==master) write(*,"(/,a,/)") '--> TESTING GENERAL RELATIVITY' + call test_combinations_all(ntests,npass) + call test_precession(ntests,npass) + call test_inccirc(ntests,npass) + if (id==master) write(*,"(/,a)") '<-- GR TESTS COMPLETE' + +end subroutine test_gr + +!----------------------------------------------------------------------- +!+ +! Test of orbital precession in the Kerr metric +!+ +!----------------------------------------------------------------------- +subroutine test_precession(ntests,npass) + use metric_tools, only:imetric,imet_kerr,imet_schwarzschild + use metric, only:a + integer, intent(inout) :: ntests,npass + integer :: nerr(6),norbits,nstepsperorbit + real :: dt,period,x0,vy0,tmax,angtol,postol + real :: angmom(3),angmom0(3),xyz(3),vxyz(3) + + write(*,'(/,a)') '--> testing substep_gr (precession)' + if (imetric /= imet_kerr .and. imetric /= imet_schwarzschild) then + write(*,'(/,a)') ' Skipping test! Metric is not Kerr (or Schwarzschild).' + return + endif + + a = 0. + x0 = 90. + vy0 = 0.0521157 + xyz = (/x0,0. ,0./) + vxyz = (/0.,vy0,0./) + period = 2390. ! approximate + norbits = 4 + tmax = norbits*period + nstepsperorbit = 1000 + dt = 0.239 !period/nstepsperorbit + + call integrate_geodesic(tmax,dt,xyz,vxyz,angmom0,angmom) + + angtol = 1.08e-15 + postol = 1.4e-5 + call checkval(angmom(1),angmom0(1),angtol,nerr(1),'error in angmomx') + call checkval(angmom(2),angmom0(2),angtol,nerr(2),'error in angmomy') + call checkval(angmom(3),angmom0(3),angtol,nerr(3),'error in angmomz') + call checkval(xyz(1), 77.606726748045929,postol,nerr(4),'error in final x position') + call checkval(xyz(2),-45.576259888019351,postol,nerr(5),'error in final y position') + call checkval(xyz(3),0.0 ,postol,nerr(6),'error in final z position') + + call update_test_scores(ntests,nerr,npass) + +end subroutine test_precession + +!----------------------------------------------------------------------- +!+ +! Test of inclined circular orbit in the Kerr metric +!+ +!----------------------------------------------------------------------- +subroutine test_inccirc(ntests,npass) + use physcon, only:pi + use metric_tools, only:imetric,imet_kerr + use metric, only:a + integer, intent(inout) :: ntests,npass + integer :: nerr(6),norbits,nstepsperorbit + real :: dt,period,tmax + real :: angmom(3),angmom0(3),xyz(3),vxyz(3) + real :: m,omega,phi,q,r,rdot,rho2,theta,thetadot,vx,vy,vz,x1,y1,z1 + real :: R2,rfinal + + write(*,'(/,a)') '--> testing substep_gr (inclined circular orbit)' + + if (imetric /= imet_kerr) then + write(*,'(/,a)') ' Skipping test! Metric is not Kerr.' + return + endif + + a = 1. + r = 10. + theta = 45.*pi/180. ! convert to radians + phi = 0. + m = 1. + q = sqrt(r**2 - a**2*cos(theta)**2) + rho2 = r**2 + a**2*cos(theta)**2 + omega = q*sqrt(m)/(sin(theta)*(rho2*sqrt(r)+a*q*sqrt(m)*sin(theta))) !shakura 1987 + rdot = 0. + thetadot = 0. + + ! Cartesian coordinates + x1 = sqrt(r**2+a**2)*sin(theta)*cos(phi) + y1 = sqrt(r**2+a**2)*sin(theta)*sin(phi) + z1 = r*cos(theta) + vx = r/sqrt(r**2+a**2)*sin(theta)*cos(phi)*rdot + sqrt(r**2+a**2)*(cos(theta)*cos(phi)*thetadot-sin(theta)*sin(phi)*omega) + vy = r/sqrt(r**2+a**2)*sin(theta)*sin(phi)*rdot + sqrt(r**2+a**2)*(cos(theta)*sin(phi)*thetadot+sin(theta)*cos(phi)*omega) + vz = cos(theta)*rdot-r*sin(theta)*thetadot + + xyz = (/x1,y1,z1/) + vxyz = (/vx,vy,vz/) + + period = 2390. ! approximate + norbits = 4 + tmax = norbits*period + nstepsperorbit = 1000 + dt = 0.239 !period/nstepsperorbit + + call integrate_geodesic(tmax,dt,xyz,vxyz,angmom0,angmom) + + R2 = dot_product(xyz,xyz) + rfinal = sqrt(0.5*(R2-a**2) + 0.5*sqrt((R2-a**2)**2 + 4.*a**2*xyz(3)**2)) + + nerr = 0 + call checkval(angmom(1),angmom0(1),6.e-10,nerr(1),'error in angmomx') + call checkval(angmom(2),angmom0(2),6.e-10,nerr(2),'error in angmomy') + call checkval(angmom(3),angmom0(3),6.e-10,nerr(3),'error in angmomz') + call checkval(rfinal ,r ,5.08e-6,nerr(4),'error in final r position') + + call update_test_scores(ntests,nerr,npass) + +end subroutine test_inccirc + +!----------------------------------------------------------------------- +!+ +! test the geodesic integrator using test particle integration +! and the substep_gr routine +!+ +!----------------------------------------------------------------------- +subroutine integrate_geodesic(tmax,dt,xyz,vxyz,angmom0,angmom) + use io, only:iverbose + use part, only:igas,npartoftype,massoftype,set_particle_type,get_ntypes,ien_type + use substepping, only:substep_gr + use eos, only:ieos + use cons2prim, only:prim2consall + use metric_tools, only:init_metric,unpack_metric + use extern_gr, only:get_grforce_all + real, intent(in) :: tmax,dt + real, intent(inout) :: xyz(3), vxyz(3) + real, intent(out) :: angmom0(3),angmom(3) + integer :: nsteps,ntypes,npart + real :: time,dtextforce,massi,blah + real :: xyzh(4,1),vxyzu(4,1),fext(3,1),pxyzu(4,1),dens(1),metrics(0:3,0:3,2,1),metricderivs(0:3,0:3,3,1) + + npart = 1 + + xyzh = 0. + vxyzu = 0. + pxyzu = 0. + fext = 0. + metrics = 0. + metricderivs = 0. + + xyzh(1:3,1) = xyz(:) + vxyzu(1:3,1) = vxyz(:) + xyzh(4,:) = 1. + vxyzu(4,:) = 0. + massi = 1.e-10 + call set_particle_type(1,igas) + + npartoftype(igas) = npart + massoftype(igas) = massi + ntypes = get_ntypes(npartoftype) + + ! + ! initialise runtime parameters + ! + ieos = 11 + iverbose = 1 + time = 0 + blah = dt + ien_type = 1 + + call init_metric(npart,xyzh,metrics,metricderivs) + call prim2consall(npart,xyzh,metrics,vxyzu,dens,pxyzu,use_dens=.false.) + call get_grforce_all(npart,xyzh,metrics,metricderivs,vxyzu,dens,fext,dtextforce) + call calculate_angmom(xyzh(1:3,1),metrics(:,:,:,1),massi,vxyzu(1:3,1),angmom0) + + nsteps = 0 + do while (time <= tmax) + nsteps = nsteps + 1 + time = time + dt + dtextforce = blah + call substep_gr(npart,ntypes,dt,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) + enddo + + call calculate_angmom(xyzh(1:3,1),metrics(:,:,:,1),massi,vxyzu(1:3,1),angmom) + + xyz(:) = xyzh(1:3,1) + vxyz(:) = vxyzu(1:3,1) + +end subroutine integrate_geodesic + +!----------------------------------------------------------------------- +!+ +! compute the angular momentum for the orbit +!+ +!----------------------------------------------------------------------- +subroutine calculate_angmom(xyzi,metrici,massi,vxyzi,angmomi) + use metric_tools, only:unpack_metric + use vectorutils, only:cross_product3D + use utils_gr, only:dot_product_gr + real, intent(in) :: xyzi(3),metrici(:,:,:),massi,vxyzi(3) + real, intent(out) :: angmomi(3) + real :: alpha_gr,beta_gr_UP(3),bigvi(3),fourvel_space(3),lorentzi,v2i,gammaijdown(3,3) + + call unpack_metric(metrici,betaUP=beta_gr_UP,alpha=alpha_gr,gammaijdown=gammaijdown) + bigvi = (vxyzi+beta_gr_UP)/alpha_gr + v2i = dot_product_gr(bigvi,bigvi,gammaijdown) + lorentzi = 1./sqrt(1.-v2i) + fourvel_space = (lorentzi/alpha_gr)*vxyzi + call cross_product3D(xyzi,fourvel_space,angmomi) ! position cross with four-velocity + angmomi=angmomi*massi + +end subroutine calculate_angmom + +!----------------------------------------------------------------------- +!+ +! Test various combinations of position, velocity and fluid quantities +!+ +!----------------------------------------------------------------------- +subroutine test_combinations_all(ntests,npass) + use eos, only:ieos + integer, intent(inout) :: ntests,npass + integer, parameter :: eos_to_test(2) = (/2,12/) + integer :: i + + do i = 1,size(eos_to_test) + ieos = eos_to_test(i) + call test_combinations(ntests,npass) + enddo + +end subroutine test_combinations_all + +!----------------------------------------------------------------------- +!+ +! Test various combinations of position, velocity and fluid quantities +!+ +!----------------------------------------------------------------------- +subroutine test_combinations(ntests,npass) + use physcon, only:pi + use eos, only:gamma,equationofstate,ieos + use utils_gr, only:dot_product_gr + use metric_tools, only:get_metric,get_metric_derivs,imetric,imet_kerr + use metric, only:metric_type + integer, intent(inout) :: ntests,npass + real :: radii(5),theta(5),phi(5),vx(5),vy(5),vz(5) + real :: utherm(7),density(7),errmax,errmaxg,errmaxc,errmaxd + real :: position(3),v(3),v4(0:3),sqrtg,gcov(0:3,0:3),gcon(0:3,0:3) + real :: ri,thetai,phii,vxi,vyi,vzi,x,y,z,p,t,dens,u,pondens,spsound + real :: dgdx1(0:3,0:3),dgdx2(0:3,0:3),dgdx3(0:3,0:3) + integer :: i,j,k,l,m,n,ii,jj + integer :: ncheck_metric,nfail_metric,ncheck_cons2prim,nfail_cons2prim + integer :: ncheckg,nfailg,ncheckd,nfaild + real, parameter :: tol = 2.e-15 + real, parameter :: tolc = 1.e-12 + real, parameter :: told = 4.e-7 + + write(*,'(/,a)') '--> testing metric and cons2prim with combinations of variables' + write(*,'(a)') ' metric type = '//trim(metric_type) + write(*,'(a,I4,/)') ' eos = ', ieos + + ntests = ntests + 4 + ncheck_metric = 0 + nfail_metric = 0 + ncheckg = 0 + nfailg = 0 + ncheck_cons2prim = 0 + nfail_cons2prim = 0 + ncheckd = 0 + nfaild = 0 + errmax = 0. + errmaxg = 0. + errmaxc = 0. + errmaxd = 0. + + ! ieos=12 + gamma = 5./3. + + radii = (/2.1,2.5,3.0,5.0,10.0/) + theta = (/0.,pi/4.,pi/2.,3.*pi/4.,pi/) + phi = (/0.,pi/4.,pi/2.,pi,3.*pi/2./) + + vx = (/0.,0.25,0.5,0.75,1./) + vy = vx + vz = vx + + utherm = (/1.e-3,1.,10.,100.,1000.,1.e5,1.e7/) + density = (/1.e-10,1.e-5,1.e-3,1.,10.,100.,1000./) + + t = -1. ! initial temperature guess to avoid complier warning + + do i=1,size(radii) + ri = radii(i) + do j=1,size(theta) + thetai = theta(j) + do k=1,size(phi) + phii = phi(k) + x = ri*sin(thetai)*cos(phii) + y = ri*sin(thetai)*sin(phii) + z = ri*cos(thetai) + position = (/x,y,z/) + + call get_metric(position,gcov,gcon,sqrtg) + call test_metric_i(gcov,gcon,sqrtg,ncheck_metric,nfail_metric,errmax,ncheckg,nfailg,errmaxg,tol) + + ! Check below is because Kerr metric derivatives currently badly behaved at the poles + ! Would be nice to remove this... + if ((imetric /= imet_kerr) .or. (x**2 + y**2 > 1.e-12)) then + call get_metric_derivs(position,dgdx1,dgdx2,dgdx3) + call test_metric_derivs_i(position,dgdx1,dgdx2,dgdx3,ncheckd,nfaild,errmaxd,told) + endif + + do l=1,size(vx) + vxi=vx(l) + do m=1,size(vy) + vyi=vy(m) + do n=1,size(vz) + vzi=vz(n) + + v = (/vxi,vyi,vzi/) + v4(0) = 1. + v4(1:3) = v(:) + + ! Only allow valid combinations of position and velocity to be tested. + ! i.e. Not faster than the speed of light locally (U0 real, not imaginary). + if (dot_product_gr(v4,v4,gcov) < 0.) then + do ii=1,size(utherm) + u = utherm(ii) + do jj=1,size(density) + dens = density(jj) + call equationofstate(ieos,pondens,spsound,dens,x,y,z,t,u) + p = pondens*dens + call test_cons2prim_i(position,v,dens,u,p,ncheck_cons2prim,nfail_cons2prim,errmaxc,tolc) + enddo + enddo + endif + + enddo + enddo + enddo + enddo + enddo + enddo + + call checkvalbuf_end('inv * metric = identity',ncheck_metric,nfail_metric,errmax,tol) + call checkvalbuf_end('sqrt g = -det(g)',ncheckg,nfailg,errmaxg,tol) + call checkvalbuf_end('d/dx^i g_munu',ncheckd,nfaild,errmaxd,told) + call checkvalbuf_end('conservative to primitive',ncheck_cons2prim,nfail_cons2prim,errmaxc,tolc) + if (nfail_metric==0) npass = npass + 1 + if (nfailg==0) npass = npass + 1 + if (nfaild==0) npass = npass + 1 + if (nfail_cons2prim==0) npass = npass + 1 + +end subroutine test_combinations + +!---------------------------------------------------------------- +!+ +! Test of the metric +!+ +!---------------------------------------------------------------- +subroutine test_metric_i(gcov,gcon,sqrtg,ncheck,nfail,errmax,ncheckg,nfailg,errmaxg,tol) + use inverse4x4, only:inv4x4 + integer, intent(inout) :: ncheck,nfail,ncheckg,nfailg + real, intent(in) :: gcov(0:3,0:3),gcon(0:3,0:3),sqrtg,tol + real, intent(inout) :: errmax,errmaxg + real, dimension(0:3,0:3) :: gg + real :: sum,det + integer :: i,j + + ! Product of metric and its inverse + gg = 0. + gg = matmul(gcov,gcon) + sum = 0 + do j=0,3 + do i=0,3 + sum = sum + gg(i,j) + enddo + enddo + + ! Check to see that the product is 4 (trace of identity) + call checkvalbuf(sum,4.,tol,'[F]: gddgUU ',nfail,ncheck,errmax) + + !if (nfail /= 0) then + ! print*,' metric ' + ! print "(4(es10.3,1x))",gcov + ! print*,' inverse ' + ! print "(4(es10.3,1x))",gcon + ! print*,' gg ' + ! print "(4(es10.3,1x))",gg + ! print*, 'gdown*gup /= Identity' + !endif + + ! Check that the determinant of the metric matches the one returned + call inv4x4(gcov,gg,det) + call checkvalbuf(-det,sqrtg,tol,'sqrt(g) ',nfailg,ncheckg,errmaxg) + +end subroutine test_metric_i + +!---------------------------------------------------------------- +!+ +! Check that analytic metric derivs give similar answer to +! numerical differences of the metric +!+ +!---------------------------------------------------------------- +subroutine test_metric_derivs_i(x,dgdx1,dgdx2,dgdx3,ncheck,nfail,errmax,tol) + use metric_tools, only:numerical_metric_derivs + real, intent(in) :: x(1:3),dgdx1(0:3,0:3),dgdx2(0:3,0:3),dgdx3(0:3,0:3),tol + integer, intent(inout) :: ncheck,nfail + real, intent(inout) :: errmax + real :: dgdx_1(0:3,0:3),dgdx_2(0:3,0:3),dgdx_3(0:3,0:3) + integer :: j,i + + call numerical_metric_derivs(x,dgdx_1,dgdx_2,dgdx_3) + do j=0,3 + do i=0,3 + call checkvalbuf(dgdx1(i,j),dgdx_1(i,j),tol,'dgcov/dx',nfail,ncheck,errmax) + call checkvalbuf(dgdx2(i,j),dgdx_2(i,j),tol,'dgcov/dy',nfail,ncheck,errmax) + call checkvalbuf(dgdx3(i,j),dgdx_3(i,j),tol,'dgcov/dz',nfail,ncheck,errmax) + enddo + enddo + +end subroutine test_metric_derivs_i + +!---------------------------------------------------------------- +!+ +! Test of the conservative to primitive variable solver +!+ +!---------------------------------------------------------------- +subroutine test_cons2prim_i(x,v,dens,u,p,ncheck,nfail,errmax,tol) + use cons2primsolver, only:conservative2primitive,primitive2conservative + 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 + + real, intent(in) :: x(1:3),v(1:3),dens,p,tol + real, intent(inout) :: u + integer, intent(inout) :: ncheck,nfail + real, intent(inout) :: errmax + real :: metrici(0:3,0:3,2) + real :: rho2,pmom2(1:3),en2,temp + real :: p2,u2,t2,dens2,gamma2,v2(1:3) + real :: pondens2,spsound2 + real :: v_out(1:3),dens_out,u_out,p_out,gamma_out + real :: toli + integer :: ierr,i,j,nfailprev,ien_type + real, parameter :: tolg = 1.e-7, tolp = 1.5e-6 + + ! perturb the state + dens2 = 2.*dens + u2 = 2.*u + t2 = -1. + + call equationofstate(ieos,pondens2,spsound2,dens2,x(1),x(2),x(3),t2,u2) + P2 = pondens2 * dens2 + v2 = v + + over_energy_variables: do i = 1,3 + ! Used for initial guess in conservative2primitive + v_out = v + dens_out = dens + u_out = u + p_out = p + gamma_out = 1. + p/(dens*u) + errmax = 0. + nfailprev = nfail + temp = 1.e7 ! arbitrary initial guess + gamma2 = 1. + P2/(dens2*u2) + + call pack_metric(x,metrici) + if (ieos == 12 .and. i /= 3) then + ! entropy_K and etotal cannot use with gasplusrad eos + cycle + elseif (i == 1) then + ien_type = ien_entropy + toli = 1.5e-11 + elseif (i == 2) then + ien_type = ien_etotal + toli = 1.5e-9 + else + ien_type = ien_entropy_s + toli = 1.5e-11 + endif + + call primitive2conservative(x,metrici,v,dens2,u2,P2,rho2,pmom2,en2,ien_type) + call conservative2primitive(x,metrici,v_out,dens_out,u_out,p_out,temp,gamma_out,rho2,pmom2,en2,ierr,ien_type) + + call checkvalbuf(ierr,0,0,'[F]: ierr (convergence)',nfail,ncheck) + do j=1,3 + call checkvalbuf(v_out(j),v2(j),toli,'[F]: v_out',nfail,ncheck,errmax) + enddo + call checkvalbuf(dens_out,dens2,toli,'[F]: dens_out',nfail,ncheck,errmax) + call checkvalbuf(u_out,u2,toli,'[F]: u_out',nfail,ncheck,errmax) + call checkvalbuf(p_out,p2,tolp,'[F]: p_out',nfail,ncheck,errmax) + call checkvalbuf(gamma_out,gamma2,tolg,'[F]: gamma_out',nfail,ncheck,errmax) + + if (nfail > nfailprev .and. nfail < 10) then + print*,'-- cons2prim test failed with' + print*,' ien_type =',ien_type + print*,' ieos =',ieos + print*,' - IN:' + print*,' x =',x + print*,' v =',v2 + print*,' dens =',dens2 + print*,' u =',u2 + print*,' p =',p2 + print*,' gamma=',gamma2 + print*,' - OUT:' + print*,' v =',v_out + print*,' dens =',dens_out + print*,' u =',u_out + print*,' p =',p_out + print*,' gamma=',gamma_out + print*,'' + endif + enddo over_energy_variables + +end subroutine test_cons2prim_i + +end module testgr diff --git a/src/tests/test_mpi.f90 b/src/tests/test_mpi.f90 new file mode 100644 index 000000000..e318998d9 --- /dev/null +++ b/src/tests/test_mpi.f90 @@ -0,0 +1,100 @@ +!--------------------------------------------------------------------------! +! 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 testmpi +! +! MPI unit tests +! +! :References: None +! +! :Owner: David Liptai +! +! :Runtime parameters: None +! +! :Dependencies: io, mpiforce, mpimemory, physcon, testutils, units +! + use testutils, only:checkval,checkvalbuf,checkvalbuf_end,update_test_scores + implicit none + + public :: test_mpi + + private + +contains + +subroutine test_mpi(ntests,npass) + use io, only:id,master + use units, only:set_units + use physcon, only:solarm + integer, intent(inout) :: ntests,npass + + call set_units(mass=1.d6*solarm,G=1.d0,c=1.d0) + if (id==master) write(*,"(/,a,/)") '--> TESTING MPI' + call test_increase_mpi_memory(ntests,npass) + if (id==master) write(*,"(/,a)") '<-- MPI TESTS COMPLETE' + +end subroutine test_mpi + +subroutine test_increase_mpi_memory(ntests,npass) + use mpimemory, only:allocate_mpi_memory,increase_mpi_memory,& + deallocate_mpi_memory,stacksize,force_stack_1,& + push_onto_stack + use mpiforce, only:cellforce + integer, intent(inout) :: ntests,npass + integer, parameter :: new_stacksize=100 + type(cellforce) :: cell + integer :: nerr(3), ncheck(3), i, stacksize_orig + real :: maxerr(3) + + nerr = 0 + ncheck = 0 + maxerr = 0. + + ! Save original stacksize, assuming they're the same for dens and force + stacksize_orig = stacksize + + ! Deallocate existing stack + call deallocate_mpi_memory + + ! Allocate the stacks again at a smaller size. + call allocate_mpi_memory(stacksize_in=new_stacksize) + + ! Write some data to each cell + do i=1,new_stacksize + cell%xpos = [1.,2.,3.] * i + call push_onto_stack(force_stack_1, cell) + enddo + + ! Ensure size of force_stack_1 is what we expect it to be + call checkval(force_stack_1%n,new_stacksize,0,nerr(1),'stacksize after pushing cells') + call update_test_scores(ntests,nerr,npass) + + ! Trigger a stacksize increase - if this doesn't segfault, that's a good sign + call increase_mpi_memory + + ! Ensure stack size hasn't changed + call checkval(force_stack_1%n,new_stacksize,0,nerr(1),'stacksize after mem increase') + call update_test_scores(ntests,nerr,npass) + + ! Check cell data is the same as what was written into cells above + do i=1,new_stacksize + call checkvalbuf(force_stack_1%cells(i)%xpos(1),1.*i,1.e-15,'error in xpos(1) after mem increase',nerr(1),ncheck(1),maxerr(1)) + call checkvalbuf(force_stack_1%cells(i)%xpos(2),2.*i,1.e-15,'error in xpos(2) after mem increase',nerr(2),ncheck(2),maxerr(2)) + call checkvalbuf(force_stack_1%cells(i)%xpos(3),3.*i,1.e-15,'error in xpos(3) after mem increase',nerr(3),ncheck(3),maxerr(3)) + enddo + + call checkvalbuf_end('error in xpos(1) after mem increase asfgd',ncheck(1),nerr(1),maxerr(1),1.e-15) + call checkvalbuf_end('error in xpos(2) after mem increase asfgd',ncheck(2),nerr(2),maxerr(2),1.e-15) + call checkvalbuf_end('error in xpos(3) after mem increase asfgd',ncheck(3),nerr(3),maxerr(3),1.e-15) + call update_test_scores(ntests,nerr,npass) + + ! Reallocate previous stack + call deallocate_mpi_memory + call allocate_mpi_memory(stacksize_in=stacksize_orig) + +end subroutine test_increase_mpi_memory + +end module testmpi diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 966a77727..19de0ed9c 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -14,11 +14,11 @@ module testptmass ! ! :Runtime parameters: None ! -! :Dependencies: boundary, checksetup, deriv, dim, energies, eos, -! 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, 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 ! use testutils, only:checkval,update_test_scores implicit none @@ -40,7 +40,7 @@ subroutine test_ptmass(ntests,npass,string) integer, intent(inout) :: ntests,npass integer :: itmp,ierr,itest,istart logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening - logical :: do_test_chinese_coin,do_test_merger + logical :: do_test_chinese_coin,do_test_merger,do_test_potential,do_test_HII logical :: testall if (id==master) write(*,"(/,a,/)") '--> TESTING PTMASS MODULE' @@ -50,7 +50,9 @@ subroutine test_ptmass(ntests,npass,string) do_test_createsink = .false. do_test_softening = .false. do_test_merger = .false. + do_test_potential = .false. do_test_chinese_coin = .false. + do_test_HII = .false. testall = .false. istart = 1 select case(trim(string)) @@ -64,6 +66,8 @@ subroutine test_ptmass(ntests,npass,string) do_test_softening = .true. case('ptmassmerger') do_test_merger = .true. + case('ptmasspotential') + do_test_potential = .true. case('ptmasschinchen','ptmasscoin','chinchen','coin','chinesecoin') do_test_chinese_coin = .true. case('ptmassfsi','fsi') @@ -71,6 +75,9 @@ subroutine test_ptmass(ntests,npass,string) do_test_binary = .true. do_test_softening = .true. do_test_merger = .true. + case('ptmassHII') + do_test_HII = .true. + case default testall = .true. end select @@ -111,6 +118,10 @@ subroutine test_ptmass(ntests,npass,string) if (do_test_merger .or. testall) call test_merger(ntests,npass) enddo ! + ! Test of sink particle potentials + ! + if (do_test_potential .or. testall) call test_sink_potential(ntests,npass) + ! ! Tests of accrete_particle routine ! if (do_test_accretion .or. testall) then @@ -123,6 +134,8 @@ subroutine test_ptmass(ntests,npass,string) ! if (do_test_createsink .or. testall) call test_createsink(ntests,npass) + if (do_test_HII) call test_HIIregion(ntests,npass) + !reset stuff and clean up temporary files itmp = 201 nptmass = 0 @@ -621,7 +634,8 @@ subroutine test_accretion(ntests,npass,itest) use io, only:id,master use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,massoftype, & npart,npartoftype,xyzh,vxyzu,fxyzu,igas,ihacc,& - isdead_or_accreted,set_particle_type,ndptmass,hfact + isdead_or_accreted,set_particle_type,ndptmass,hfact,& + linklist_ptmass use ptmass, only:ptmass_accrete,update_ptmass use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi @@ -701,7 +715,7 @@ subroutine test_accretion(ntests,npass,itest) call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxyzu(1,i),fxyzu(2,i),fxyzu(3,i), & igas,massoftype(igas),xyzmh_ptmass,vxyz_ptmass, & - accreted,dptmass_thread,t,1.0,ibin_wakei,ibin_wakei) + accreted,dptmass_thread,linklist_ptmass,t,1.0,ibin_wakei,ibin_wakei) endif enddo !$omp enddo @@ -766,17 +780,19 @@ subroutine test_createsink(ntests,npass) use part, only:init_part,npart,npartoftype,igas,xyzh,massoftype,hfact,rhoh,& iphase,isetphase,fext,divcurlv,vxyzu,fxyzu,poten, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,ndptmass, & - dptmass,fxyz_ptmass_sinksink + dptmass,fxyz_ptmass_sinksink,linklist_ptmass use ptmass, only:ptmass_accrete,update_ptmass,icreate_sinks,& - ptmass_create,finish_ptmass,ipart_rhomax,h_acc,rho_crit,rho_crit_cgs + ptmass_create,finish_ptmass,ipart_rhomax,h_acc,rho_crit,rho_crit_cgs, & + ptmass_create_stars,tmax_acc,tseeds,ipart_createseeds,ipart_createstars,& + ptmass_create_seeds use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceloc_mpi,reduceall_mpi use spherical, only:set_sphere use stretchmap, only:rho_func integer, intent(inout) :: ntests,npass - integer :: i,itest,itestp,nfailed(3),imin(1) + integer :: i,itest,itestp,nfailed(4),imin(1) integer :: id_rhomax,ipart_rhomax_global - real :: psep,totmass,r2min,r2,t + real :: psep,totmass,r2min,r2,t,coremass,starsmass real :: etotin,angmomin,totmomin,rhomax,rhomax_test procedure(rho_func), pointer :: density_func @@ -785,8 +801,10 @@ subroutine test_createsink(ntests,npass) iverbose = 1 rho_crit = rho_crit_cgs - do itest=1,2 + do itest=1,3 select case(itest) + case(3) + if (id==master) write(*,"(/,a)") '--> testing sink particle creation (cores and stars prescription)' case(2) if (id==master) write(*,"(/,a)") '--> testing sink particle creation (sin)' case default @@ -827,7 +845,16 @@ subroutine test_createsink(ntests,npass) ! and make sure that gravitational potential energy has been computed ! tree_accuracy = 0. - icreate_sinks = 1 + if (itest==3) then + icreate_sinks = 2 + linklist_ptmass = -1 + tmax_acc = 0. + tseeds = 0. + ipart_createseeds = 1 + ipart_createstars = 1 + else + icreate_sinks = 1 + endif call get_derivs_global() @@ -886,12 +913,31 @@ subroutine test_createsink(ntests,npass) call reduceloc_mpi('max',ipart_rhomax_global,id_rhomax) endif call ptmass_create(nptmass,npart,itestp,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& - massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,dptmass,0.) + massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,dptmass,0.) + if (itest==3) then + coremass = 0. + starsmass = 0. + xyzmh_ptmass(4,1) = xyzmh_ptmass(4,1)*6e33 + coremass = xyzmh_ptmass(4,1) + call ptmass_create_seeds(nptmass,ipart_createseeds,xyzmh_ptmass,linklist_ptmass,0.) + call ptmass_create_stars(nptmass,ipart_createstars,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & + fxyz_ptmass_sinksink,linklist_ptmass,0.) + do i=1,nptmass + starsmass = starsmass + xyzmh_ptmass(4,i) + enddo + xyzmh_ptmass(4,1) = coremass/6e33 + xyzmh_ptmass(4,:) = 0. + endif ! ! check that creation succeeded ! nfailed(:) = 0 - call checkval(nptmass,1,0,nfailed(1),'nptmass=1') + if (itest == 3) then + call checkval(nptmass,3,3,nfailed(1),'nptmass=nseeds') + call checkval(starsmass-coremass,0.,0.,nfailed(4),'Mass conservation') + else + call checkval(nptmass,1,0,nfailed(1),'nptmass=1') + endif call update_test_scores(ntests,nfailed,npass) ! ! check that linear and angular momentum and energy is conserved @@ -1111,6 +1157,174 @@ subroutine test_merger(ntests,npass) end subroutine test_merger +subroutine test_HIIregion(ntests,npass) + use dim, only:maxp,maxphase,maxvxyzu + use io, only:id,master,iverbose,iprint + use eos_HIIR, only:polykion,init_eos_HIIR + use eos, only:gmw,ieos,polyk,gamma + use deriv, only:get_derivs_global + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass, & + npart,ihacc,irstrom,xyzh,vxyzu,hfact,igas, & + npartoftype,fxyzu,massoftype,isionised,init_part,& + iphase,isetphase,irateion,irstrom + use ptmass, only:h_acc + use step_lf_global, only:init_step,step + use spherical, only:set_sphere + use units, only:set_units,utime,unit_velocity,udist,umass + use physcon, only:pc,solarm,years,pi,kboltz,mass_proton_cgs + use kernel, only: hfact_default + use kdtree, only:tree_accuracy + use testutils, only: checkval,update_test_scores + use HIIRegion, only:initialize_H2R,update_ionrate,HII_feedback,iH2R,nHIIsources,ar,mH + integer, intent(inout) :: ntests,npass + integer :: np,i,nfailed(1) + real :: totmass,psep + real :: Rstrom,ci,k,rho0 + real :: totvol,nx,rmin,rmax,temp + if (id==master) write(iprint,"(/,a)") '--> testing HII region expansion around massive stars...' + + call set_units(dist=pc,mass=solarm,G=1.d0) + call init_eos_HIIR() + iverbose = 0 + ! + ! initialise arrays to zero + ! + call init_part() + gmw = 1.0 + + xyzmh_ptmass(:,:) = 0. + vxyz_ptmass(:,:) = 0. + + h_acc = 0.002 + + xyzmh_ptmass(4,1) = -1. + xyzmh_ptmass(irateion,1) = 49. ! rate_ion [s^-1] + nptmass = 1 + nHIIsources = 1 + + hfact = 1.2 + gamma = 1. + rmin = 0. + rmax = 2.91*pc/udist + ieos = 21 + tree_accuracy = 0.5 + temp = 1000. +! +!--setup particles +! + np = 1000000 + totvol = 4./3.*pi*rmax**3 + nx = int(np**(1./3.)) + psep = totvol**(1./3.)/real(nx) + npart = 0 + ! only set up particles on master, otherwise we will end up with n duplicates + if (id==master) then + call set_sphere('cubic',id,master,rmin,rmax,psep,hfact,npart,xyzh,np_requested=np) + endif + np = npart + + +! +!--set particle properties +! + totmass = 8.e3*solarm/umass + npartoftype(:) = 0 + npartoftype(igas) = npart + massoftype(:) = 0.0 + massoftype(igas) = totmass/npartoftype(igas) + if (maxphase==maxp) then + do i=1,npart + iphase(i) = isetphase(igas,iactive=.true.) + enddo + endif + + + iH2R = 1 + if (id==master) then + call initialize_H2R + !call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) + endif + + rho0 = totmass/totvol + + Rstrom = 10**((1./3)*(log10(((3*mH**2)/(4*pi*ar*rho0**2)))+xyzmh_ptmass(irateion,1)+log10(utime))) + xyzmh_ptmass(irstrom,1) = -1. + ci = sqrt(polykion) + k = 0.005 + + polyk = (kboltz*temp)/(gmw*mass_proton_cgs)*((unit_velocity)**2) + vxyzu(:,:) = 0. + fxyzu(:,:) = 0. + if (maxvxyzu >= 4) then + vxyzu(4,:) = polyk + ieos = 22 + endif + + call get_derivs_global() + + call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyz_ptmass,isionised) + + call checkval(xyzmh_ptmass(irstrom,1),Rstrom,1.e-2,nfailed(1),'Initial strömgren radius') + + call update_test_scores(ntests,nfailed,npass) + +end subroutine test_HIIregion + +!----------------------------------------------------------------------- +!+ +! Test sink particle surface force, simply that the acceleration +! is the gradient of the potential +!+ +!----------------------------------------------------------------------- +subroutine test_sink_potential(ntests,npass) + use io, only:id,master + use testutils, only:checkval,update_test_scores + use ptmass, only:get_accel_sink_gas,isink_potential + use part, only:npart,npartoftype,nptmass,xyzmh_ptmass,ihacc,iReff + use units, only:set_units + integer, intent(inout) :: ntests,npass + integer :: nfailed(1) + real :: phi1,phi,eps,x0(3) + real :: dphidx,hi,xi,yi,zi,dumxi,dumyi,dumzi,fxi,fyi,fzi,rp + + if (id==master) write(*,"(/,a)") '--> testing sink particle surface force' + nptmass = 1 + npart = 0 + npartoftype = 0 + hi = 0. + x0 = [100.,100.,100.] + rp = 2. + isink_potential = 1 + ! place a single point mass at a random location + xyzmh_ptmass(:,:) = 0. + xyzmh_ptmass(1:3,1) = x0 + xyzmh_ptmass(4,1) = 3.14159 + xyzmh_ptmass(ihacc,1) = 0. + xyzmh_ptmass(iReff,1) = rp ! surface radius = 2 + + call set_units(mass=1.d0,dist=1.d0,G=1.d0) + + ! evaluate sink-gas acceleration at some position + xi = x0(1) + 1.00001*rp + yi = x0(2) + 1.*rp + zi = x0(3) + 1.*rp + fxi = 0.; fyi = 0.; fzi = 0.; phi = 0. + call get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi) + ! evaluate sink-gas acceleration at some position + epsilon + eps = 1.e-6 + dumxi = 0.; dumyi = 0.; dumzi = 0.; phi1 = 0. + call get_accel_sink_gas(nptmass,xi+eps,yi,zi,hi,xyzmh_ptmass,dumxi,dumyi,dumzi,phi1) + ! get the derivative of phi and check it equals the acceleration + dphidx = -(phi1 - phi)/eps + + call checkval(dphidx,fxi,3.3e-8,nfailed(1),'dphi/dx = acceleration') + call update_test_scores(ntests,nfailed(1:1),npass) + + ! reset options + isink_potential = 0 + +end subroutine test_sink_potential + !----------------------------------------------------------------------- !+ ! Helper function used in sink particle creation test diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index a5c129f0d..daa5e8f4f 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -447,7 +447,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) "|_| /_/ \_\____/____/ " write(*,"(a)") 'TEST SUITE PASSED' - call system("say OK") + call system("say fantastic!") else write(*,"(5(a,/))") & " _____ _ ___ _ ", & diff --git a/src/utils/struct_part.f90 b/src/utils/struct_part.f90 index 781a3c2fd..99640148d 100644 --- a/src/utils/struct_part.f90 +++ b/src/utils/struct_part.f90 @@ -149,10 +149,10 @@ subroutine get_structure_fn(sf,nbins,norder,distmin,distmax,xbins,ncount,npart,x !$omp reduction(+:sf) do ipt=1,npts !$ if (.false.) then - if (mod(ipt,100)==0) then - call cpu_time(tcpu2) - print*,' ipt = ',ipt,tcpu2-tcpu1 - endif + if (mod(ipt,100)==0) then + call cpu_time(tcpu2) + print*,' ipt = ',ipt,tcpu2-tcpu1 + endif !$ endif i = list(ipt) xpt(1) = xyz(1,i) From 7a0c0cefc551ab4e2c03e6dba13c1f296610b9fc Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 31 Jul 2024 17:27:47 +0100 Subject: [PATCH 769/814] Changes Stamatellos EOS to ieos=23 --- src/main/cooling.f90 | 2 +- src/main/cooling_radapprox.f90 | 2 +- src/main/eos.f90 | 26 +++++++++++++------------- src/main/readwrite_infile.F90 | 6 +++--- src/main/step_leapfrog.F90 | 10 +++------- 5 files changed, 21 insertions(+), 25 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 1952563f7..abfe84a1b 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -86,7 +86,7 @@ subroutine init_cooling(id,master,iprint,ierr) call init_cooling_ism() if (icooling==8) cooling_in_step = .false. case(9) - if (ieos /= 21 ) call fatal('cooling','icooling=9 requires ieos=21',& + if (ieos /= 23 ) call fatal('cooling','icooling=9 requires ieos=23',& 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) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index 62dc0eb02..f5edfaf8b 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -467,7 +467,7 @@ subroutine read_options_cooling_radapprox(name,valstring,imatch,igotallstam,ierr ngot = ngot + 1 case('ieos') read(valstring,*,iostat=ierr) ieosread - if (ieosread /= 21) call fatal('ieosread','For icooling=9, you need ieos=21') + if (ieosread /= 23) call fatal('ieosread','For icooling=9, you need ieos=23') case default imatch = .false. end select diff --git a/src/main/eos.f90 b/src/main/eos.f90 index ef1a8293c..d1869ca66 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -27,7 +27,7 @@ module eos ! 16 = Shen eos ! 17 = polytropic EOS with varying mu (depending on H2 formation) ! 20 = Ideal gas + radiation + various forms of recombination energy from HORMONE (Hirai et al., 2020) -! 21 = read tabulated eos (for use with icooling == 9) +! 23 = read tabulated eos (for use with icooling == 9) ! ! :References: ! Lodato & Pringle (2007) @@ -50,7 +50,7 @@ module eos use part, only:ien_etotal,ien_entropy,ien_type use dim, only:gr implicit none - integer, parameter, public :: maxeos = 22 + integer, parameter, public :: maxeos = 23 real, public :: polyk, polyk2, gamma real, public :: qfacdisc = 0.75, qfacdisc2 = 0.75 logical, public :: extract_eos_from_hdr = .false. @@ -431,13 +431,13 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam if (present(mu_local)) mu_local = 1./imui if (present(gamma_local)) gamma_local = gammai -! case(21) - ! call get_eos_HIIR_iso(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) + case(21) + call get_eos_HIIR_iso(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) case(22) call get_eos_HIIR_adiab(polyk,temperature_coef,mui,tempi,ponrhoi,rhoi,eni,gammai,spsoundi,isionisedi) - case(21) + case(23) ! !--interpolate tabulated eos from Stamatellos+(2007). For use with icooling=9 ! @@ -556,14 +556,14 @@ subroutine init_eos(eos_type,ierr) ierr = ierr_option_conflict endif - case(21) + case(21,22) + call init_eos_HIIR() + + case(23) call read_optab(eos_file,ierr) if (ierr > 0) call fatal('init_eos','Failed to read EOS file',var='ierr',ival=ierr) call init_S07cool -! - case(21,22) - case(22) - call init_eos_HIIR() end select done_init_eos = .true. @@ -595,7 +595,7 @@ subroutine finish_eos(eos_type,ierr) ! call finish_eos_mesa - case(21) + case(23) ! Stamatellos deallocation call finish_S07cool @@ -1288,7 +1288,7 @@ logical function eos_outputs_mu(ieos) select case(ieos) case(20) eos_outputs_mu = .true. - case(21) + case(23) eos_outputs_mu = .true. case default eos_outputs_mu = .false. @@ -1374,7 +1374,7 @@ subroutine eosinfo(eos_type,iprint) write(*,'(1x,a,f10.6,a,f10.6)') 'Using fixed composition X = ',X_in,", Z = ",Z_in endif - case(21) + case(23) write(iprint,"(/,a,a)") 'Using tabulated Eos from file:', eos_file, 'and calculated gamma.' end select write(iprint,*) @@ -1430,7 +1430,7 @@ subroutine read_headeropts_eos(ieos,hdr,ierr) if (maxvxyzu >= 4) then if (use_krome) then write(iprint,*) 'KROME eos: initial gamma = 1.666667' - elseif (ieos==21) then + elseif (ieos==23) then write(iprint,*) 'Tabulated eos with derived gamma' else write(iprint,*) 'adiabatic eos: gamma = ',gamma diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 35bfa31ae..8a7272e4f 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -217,7 +217,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) ! call write_options_eos(iwritein) if (maxvxyzu >= 4 .and. (ieos==2 .or. ieos==5 .or. ieos==10 .or. ieos==15 .or. ieos==12 .or. ieos==16 & - .or. ieos==17 .or. ieos==21) ) then + .or. ieos==17 .or. ieos==21) .or. ieos==23 ) then call write_inopt(ipdv_heating,'ipdv_heating','heating from PdV work (0=off, 1=on)',iwritein) call write_inopt(ishock_heating,'ishock_heating','shock heating (0=off, 1=on)',iwritein) if (mhd) then @@ -693,14 +693,14 @@ 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/=21 .and. ieos/=22)) & + ieos /= 20 .and. ieos/=21 .and. ieos/=22 .and. ieos/=23)) & 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') if (shearparam < 0.) call fatal(label,'stupid value for shear parameter (< 0)') if (irealvisc==2 .and. shearparam > 1) call error(label,'alpha > 1 for shakura-sunyaev viscosity') if (iverbose > 99 .or. iverbose < -9) call fatal(label,'invalid verboseness setting (two digits only)') - if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos == 17 .or. ieos == 21)) & + if (icooling > 0 .and. .not.(ieos == 2 .or. ieos == 5 .or. ieos == 17 .or. ieos == 21 .or. ieos == 23)) & call fatal(label,'cooling requires adiabatic eos (ieos=2)') if (icooling > 0 .and. (ipdv_heating <= 0 .or. ishock_heating <= 0)) & call fatal(label,'cooling requires shock and work contributions') diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index a18c9f972..d6167ab5b 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -167,7 +167,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) store_itype = (maxphase==maxp .and. ntypes > 1) ialphaloc = 2 nvfloorp = 0 -! print *, "L197 predictor, maxmin abs fxyzu=", maxval(abs(fxyzu(4,1:npart))),minval(abs(fxyzu(4,1:npart))) !$omp parallel do default(none) & !$omp shared(npart,xyzh,vxyzu,fxyzu,iphase,hdtsph,store_itype) & !$omp shared(rad,drad,pxyzu) & @@ -405,7 +404,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call fatal('step','step too small: bin would exceed maximum') endif endif -! print *, "line 407", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)), "nactive=", nactive + ! ! if using super-timestepping, determine what dt will be used on the next loop ! @@ -422,7 +421,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ! forces we must iterate until velocities agree. !------------------------------------------------------------------------- -! print *, "line 423", "max u=", maxval(vxyzu(4,:)), "max pred", maxval(vpred(4,:)) its = 0 converged = .false. errmaxmean = 0.0 @@ -697,11 +695,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) print *, "after 2nd derivs:vpred", maxval(vpred(4,:)), minval(vpred(4,:)) endif endif - if (icooling == 9) then + if (icooling == 9 .and. iverbose >=2) then print *, "end of iteration", maxval(vpred(4,:)), minval(vpred(4,:)) - print *, "end of iteration", maxval(vxyzu(4,:)), minval(vxyzu(4,:)) - print *, "end of iteration, dudt", maxval(fxyzu(4,1:npart)), minval(fxyzu(4,1:npart)) - print *, "End of iteration, nactive=", nactive + print *, "end of iteration", maxval(vxyzu(4,:)), minval(vxyzu(4,:)) endif enddo iterations From 832d111611c04f0796ea185aae5d8d5fd2cf646d Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 31 Jul 2024 17:38:57 +0100 Subject: [PATCH 770/814] [indent-bot] standardised indentation --- src/main/cooling.f90 | 4 +- src/main/cooling_radapprox.f90 | 284 ++++++++++++++--------------- src/main/dens.F90 | 218 +++++++++++----------- src/main/eos.f90 | 14 +- src/main/eos_stamatellos.f90 | 58 +++--- src/main/force.F90 | 14 +- src/main/inject_bondi.f90 | 2 +- src/main/inject_firehose.f90 | 2 +- src/main/inject_galcen_winds.f90 | 2 +- src/main/inject_keplerian.f90 | 2 +- src/main/inject_keplerianshear.f90 | 2 +- src/main/inject_rochelobe.f90 | 2 +- src/main/inject_sim.f90 | 4 +- src/main/inject_sne.f90 | 2 +- src/main/inject_steadydisc.f90 | 2 +- src/main/inject_unifwind.f90 | 2 +- src/main/inject_wind.f90 | 2 +- src/main/inject_windtunnel.f90 | 2 +- src/main/porosity.f90 | 6 +- src/main/radiation_utils.f90 | 10 +- src/main/readwrite_infile.F90 | 2 +- src/main/step_leapfrog.F90 | 8 +- src/utils/moddump_radiotde.f90 | 2 +- 23 files changed, 323 insertions(+), 323 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index abfe84a1b..0bb572586 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -144,7 +144,7 @@ subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2 use cooling_koyamainutsuka, only:cooling_KoyamaInutsuka_explicit,& cooling_KoyamaInutsuka_implicit use cooling_radapprox, only:radcool_update_energ - + 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 @@ -223,7 +223,7 @@ subroutine write_options_cooling(iunit) case(7) call write_options_cooling_gammie_PL(iunit) case(9) - call write_options_cooling_radapprox(iunit) + call write_options_cooling_radapprox(iunit) case default call write_options_cooling_solver(iunit) end select diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index f5edfaf8b..cbc532954 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -63,7 +63,7 @@ end subroutine init_star ! ! Do cooling calculation ! -! update energy to return evolved energy array. Called from substep +! update energy to return evolved energy array. Called from substep subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) use io, only:warning use physcon, only:steboltz,pi,solarl,Rg,kb_on_mh,piontwo,rpiontwo @@ -80,149 +80,149 @@ subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) real :: cs2,Om2,Hmod2 real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi - coldensi = huge(coldensi) - poti = Gpot_cool(i) - du_FLDi = duFLD(i) - kappaBari = 0d0 - kappaParti = 0d0 - Teqi = huge(Teqi) - tthermi = huge(tthermi) - opaci = epsilon(opaci) - if (abs(ui) < epsilon(ui)) print *, "ui zero", i - - if (isink_star > 0) then - ri2 = (xi-xyzmh_ptmass(1,isink_star))**2d0 & + coldensi = huge(coldensi) + poti = Gpot_cool(i) + du_FLDi = duFLD(i) + kappaBari = 0d0 + kappaParti = 0d0 + Teqi = huge(Teqi) + tthermi = huge(tthermi) + opaci = epsilon(opaci) + if (abs(ui) < epsilon(ui)) print *, "ui zero", i + + 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 - else - ri2 = xi**2d0 + yi**2d0 + zi**2d0 - endif + + (zi-xyzmh_ptmass(3,isink_star))**2d0 + else + ri2 = xi**2d0 + yi**2d0 + zi**2d0 + endif - ! get opacities & Ti for ui - call getopac_opdep(ui*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,& + ! get opacities & Ti for ui + call getopac_opdep(ui*unit_ergg,rhoi*unit_density,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 - call warning("In radapprox cooling","cooling method not recognised",ival=od_method) - return - end select + 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 + call warning("In radapprox cooling","cooling method not recognised",ival=od_method) + return + 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 + 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 - call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi*unit_density,umini) - umini = umini/unit_ergg + call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi*unit_density,umini) + umini = umini/unit_ergg - 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 + 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 = duSPH(i) + 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 - return - endif - - Teqi = du_tot * opaci*unit_ergg/utime ! physical units - Teqi = Teqi/4.d0/steboltz - Teqi = Teqi + Tmini4 - du_tot = du_tot + dudti_rad - if (Teqi < Tmini4) then - Teqi = Tmini4**(1.0/4.0) - else - Teqi = Teqi**(1.0/4.0) - endif - teqi_store(i) = Teqi + if (doFLD) then + du_tot = duSPH(i) + du_FLDi + else + du_tot = duSPH(i) + endif - if (Teqi > 9e5) then - print *,"i=",i, "duSPH(i)=", duSPH(i), "duradi=", dudti_rad, "Ti=", Ti, & + ! 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 + return + endif + + Teqi = du_tot * opaci*unit_ergg/utime ! physical units + Teqi = Teqi/4.d0/steboltz + Teqi = Teqi + Tmini4 + du_tot = du_tot + dudti_rad + 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 - elseif (Teqi < epsilon(Teqi)) then - print *, "Teqi=0.0", "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& + elseif (Teqi < epsilon(Teqi)) then + print *, "Teqi=0.0", "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& "Ti=", Ti, "poti=",poti, "rhoi=", rhoi - elseif (Teqi < Tfloor) then - print *, "Teqi=",Teqi, "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& + elseif (Teqi < Tfloor) then + print *, "Teqi=",Teqi, "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& "Ti=", Ti, "poti=",poti, "rhoi=", rhoi - endif - - call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) - ueqi = ueqi/unit_ergg - - ! calculate thermalization timescale - if ((du_tot) == 0.d0) then - tthermi = 0d0 - else - tthermi = abs((ueqi - ui)/(du_tot)) - endif + endif - 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 - ! 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 *, "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 + call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) + ueqi = ueqi/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 + 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 + ! 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 *, "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 @@ -230,7 +230,7 @@ end subroutine radcool_update_energ ! ! Do cooling calculation ! -! update energy to return evolved energy array. Called from evolve.F90 +! 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 @@ -262,7 +262,7 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) !$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 shared(maxp,maxphase,ibin) reduction(+:n_uevo) - + overpart: do i=1,npart if (maxphase==maxp) then if (iamtype(iphase(i)) /= igas) cycle @@ -279,13 +279,13 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) 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 + + (xyzh(3,i)-xyzmh_ptmass(3,isink_star))**2d0 else - ri2 = xyzh(1,i)**2d0 + xyzh(2,i)**2d0 + xyzh(3,i)**2d0 + ri2 = xyzh(1,i)**2d0 + xyzh(2,i)**2d0 + xyzh(3,i)**2d0 endif ! get opacities & Ti for ui @@ -311,7 +311,7 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) 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 @@ -339,14 +339,14 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) 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 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) @@ -373,10 +373,10 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) print *, "Teqi=0.0", "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& "Ti=", Ti, "poti=",poti, "rhoi=", rhoi endif - + 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 @@ -388,7 +388,7 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) endif ttherm_store(i) = tthermi - + ! evolve energy if (tthermi == 0d0) then energ(i) = ui ! condition if denominator above is zero @@ -397,7 +397,7 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) 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 diff --git a/src/main/dens.F90 b/src/main/dens.F90 index 81cd68031..14e3c9c07 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -1664,44 +1664,44 @@ 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) - use io, only:error - use dim, only:maxp - use kernel,only:get_kernel,wab0 - use part, only:get_partinfo,iamgas,igas,maxphase,massoftype - use part, only:rhoanddhdrho - use physcon, only:radconst - use units, only:unit_density,unit_ergg,unit_opacity,get_radconst_code - use eos_stamatellos, only:getopac_opdep + use io, only:error + use dim, only:maxp + use kernel,only:get_kernel,wab0 + use part, only:get_partinfo,iamgas,igas,maxphase,massoftype + use part, only:rhoanddhdrho + use physcon, only:radconst + use units, only:unit_density,unit_ergg,unit_opacity,get_radconst_code + use eos_stamatellos, only:getopac_opdep #ifdef PERIODIC - use boundary, only:dxbound,dybound,dzbound + use boundary, only:dxbound,dybound,dzbound #endif - type(celldens), intent(in) :: cell - 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(:,:) - real, intent(inout) :: lambda(:),urad_FLD(:) - - 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 :: xj,yj,zj,dx,dy,dz - real :: rij2,rij,q2i,qi,hj1,hj,hj21,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 - integer :: ngradh_err - real :: uradself - - ngradh_err = 0 - over_parts: do icell = 1,cell%npcell + type(celldens), intent(in) :: cell + 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(:,:) + real, intent(inout) :: lambda(:),urad_FLD(:) + + 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 :: xj,yj,zj,dx,dy,dz + real :: rij2,rij,q2i,qi,hj1,hj,hj21,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 + integer :: ngradh_err + real :: uradself + + ngradh_err = 0 + over_parts: do icell = 1,cell%npcell i = inodeparts(cell%arr_index(icell)) ! note: only active particles have been sent here if (maxphase==maxp) then @@ -1731,103 +1731,103 @@ subroutine calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gra ! get Ti from tabulated eos call getopac_opdep(vxyzu(4,i)*unit_ergg,rhoi*unit_density,kappabari, & kappaparti,Ti,gmwi) - + loop_over_neighbours: do n=1,nneigh j = abs(listneigh(n)) if (i==j) cycle loop_over_neighbours xj = xyzh(1,j) yj = xyzh(2,j) zj = xyzh(3,j) - + dx = cell%xpartvec(ixi,icell) - xj dy = cell%xpartvec(iyi,icell) - yj dz = cell%xpartvec(izi,icell) - zj #ifdef PERIODIC - if (abs(dx) > 0.5*dxbound) dx = dx - dxbound*SIGN(1.0,dx) - if (abs(dy) > 0.5*dybound) dy = dy - dybound*SIGN(1.0,dy) - if (abs(dz) > 0.5*dzbound) dz = dz - dzbound*SIGN(1.0,dz) + if (abs(dx) > 0.5*dxbound) dx = dx - dxbound*SIGN(1.0,dx) + if (abs(dy) > 0.5*dybound) dy = dy - dybound*SIGN(1.0,dy) + if (abs(dz) > 0.5*dzbound) dz = dz - dzbound*SIGN(1.0,dz) #endif - rij2 = dx*dx + dy*dy + dz*dz + TINY(0.) - rij = SQRT(rij2) - q2i = rij2*hi21 - qi = SQRT(q2i) - - hj1 = 1./xyzh(4,j) - hj = 1./hj1 - hj21 = hj1*hj1 - q2j = rij2*hj21 - - is_sph_neighbour: if (q2i < radkern2 .or. q2j < radkern2) then - if (maxphase==maxp) then - call get_partinfo(iphase(j),iactivej,iamgasj,iamdustj,iamtypej) - else - iactivej = .true. - iamtypej = igas - iamgasj = .true. - endif - if (.not. iamgasj) cycle loop_over_neighbours - if (.not. iactivej) cycle loop_over_neighbours - ! get kernel quantities - if (gradh(1,i) > 0.) then - gradhi = gradh(1,i) - !elseif (ngradh_err < 20) then - ! call error('force','stored gradh is zero, resetting to 1') - ! gradhi = 1. + rij2 = dx*dx + dy*dy + dz*dz + TINY(0.) + rij = SQRT(rij2) + q2i = rij2*hi21 + qi = SQRT(q2i) + + hj1 = 1./xyzh(4,j) + hj = 1./hj1 + hj21 = hj1*hj1 + q2j = rij2*hj21 + + is_sph_neighbour: if (q2i < radkern2 .or. q2j < radkern2) then + if (maxphase==maxp) then + call get_partinfo(iphase(j),iactivej,iamgasj,iamdustj,iamtypej) + else + iactivej = .true. + iamtypej = igas + iamgasj = .true. + endif + if (.not. iamgasj) cycle loop_over_neighbours + if (.not. iactivej) cycle loop_over_neighbours + ! get kernel quantities + if (gradh(1,i) > 0.) then + gradhi = gradh(1,i) + !elseif (ngradh_err < 20) then + ! call error('force','stored gradh is zero, resetting to 1') + ! gradhi = 1. ! ngradh_err = ngradh_err + 1 - else - gradhi = 1. - ngradh_err = ngradh_err + 1 - endif - call get_kernel(q2i,qi,wabi,grkerni) - wkerni = wabi*cnormk*hi21*hi1 - 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,& + else + gradhi = 1. + ngradh_err = ngradh_err + 1 + endif + call get_kernel(q2i,qi,wabi,grkerni) + wkerni = wabi*cnormk*hi21*hi1 + 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,& kappaBarj,kappaPartj,Tj,gmwj) - uradi = uradi + get_radconst_code()*(Tj**4.0d0)*wkerni*pmassj/rhoj - - ! calculate components of gradient - runix = dx/rij - runiy = dy/rij - runiz = dz/rij - - dT4 = Ti**4d0 - Tj**4d0 - dradxi = dradxi + get_radconst_code()*pmassj*dT4*dwkerni*runix/rhoj - dradyi = dradyi + get_radconst_code()*pmassj*dT4*dwkerni*runiy/rhoj - dradzi = dradzi + get_radconst_code()*pmassj*dT4*dwkerni*runiz/rhoj - - endif is_sph_neighbour - - enddo loop_over_neighbours - - ! add self contribution - - uradi = uradi + cnormk*hi31*get_radconst_code()*(Ti**4d0) & + uradi = uradi + get_radconst_code()*(Tj**4.0d0)*wkerni*pmassj/rhoj + + ! calculate components of gradient + runix = dx/rij + runiy = dy/rij + runiz = dz/rij + + dT4 = Ti**4d0 - Tj**4d0 + dradxi = dradxi + get_radconst_code()*pmassj*dT4*dwkerni*runix/rhoj + dradyi = dradyi + get_radconst_code()*pmassj*dT4*dwkerni*runiy/rhoj + dradzi = dradzi + get_radconst_code()*pmassj*dT4*dwkerni*runiz/rhoj + + endif is_sph_neighbour + + enddo loop_over_neighbours + + ! add self contribution + + uradi = uradi + cnormk*hi31*get_radconst_code()*(Ti**4d0) & *wab0*pmassi/rhoi - if (uradi > 1.d0) print *, "cnormk,hi31,radconst,Ti,wab0,pmassi,rhoi",& + if (uradi > 1.d0) print *, "cnormk,hi31,radconst,Ti,wab0,pmassi,rhoi",& cnormk,hi31,get_radconst_code(),Ti,wab0,pmassi,rhoi,"wabi,wkerni,pmassj,rhoj", & wabi,wkerni,pmassj,rhoj !$omp critical - if (iamgasi .and. uradi > 0d0) urad_FLD(i) = uradi + if (iamgasi .and. uradi > 0d0) urad_FLD(i) = uradi !$omp end critical - !Now calculate flux limiter coefficients - !Calculate in code units (converted to code units in forcei) - dradi = SQRT(dradxi*dradxi + dradyi*dradyi + dradzi*dradzi) ! should this be normalised somehow? - if ((dradi.eq.0.0d0).or.(uradi.eq.0.0d0)) then - R_rad = 0.0d0 - else - R_rad = dradi/(uradi*rhoi*kappaParti/unit_opacity) - endif + !Now calculate flux limiter coefficients + !Calculate in code units (converted to code units in forcei) + dradi = SQRT(dradxi*dradxi + dradyi*dradyi + dradzi*dradzi) ! should this be normalised somehow? + if ((dradi.eq.0.0d0).or.(uradi.eq.0.0d0)) then + R_rad = 0.0d0 + else + R_rad = dradi/(uradi*rhoi*kappaParti/unit_opacity) + endif !$omp critical - lambda(i) = (2.0d0+R_rad)/(6.0d0+3.0d0*R_rad+R_rad*R_rad) + lambda(i) = (2.0d0+R_rad)/(6.0d0+3.0d0*R_rad+R_rad*R_rad) !$omp end critical - if (isnan(lambda(i))) then - print *, "lambda isnan when calculated. i, R_Rad, uradi,dradi,rhoi,",& + if (isnan(lambda(i))) then + print *, "lambda isnan when calculated. i, R_Rad, uradi,dradi,rhoi,",& "kappaParti, Ti",i,R_Rad,uradi,dradi,rhoi,kappaParti,Ti - endif + endif enddo over_parts ! if (ngradh_err > 0) print *, "ngradh_errors = ", ngradh_err diff --git a/src/main/eos.f90 b/src/main/eos.f90 index d1869ca66..861e5e072 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -50,7 +50,7 @@ module eos use part, only:ien_etotal,ien_entropy,ien_type use dim, only:gr implicit none - integer, parameter, public :: maxeos = 23 + integer, parameter, public :: maxeos = 23 real, public :: polyk, polyk2, gamma real, public :: qfacdisc = 0.75, qfacdisc2 = 0.75 logical, public :: extract_eos_from_hdr = .false. @@ -154,7 +154,7 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam if (present(Xlocal)) X_i = Xlocal if (present(Zlocal)) Z_i = Zlocal if (present(isionised)) isionisedi = isionised - + select case(eos_type) case(1) ! @@ -432,11 +432,11 @@ subroutine equationofstate(eos_type,ponrhoi,spsoundi,rhoi,xi,yi,zi,tempi,eni,gam if (present(gamma_local)) gamma_local = gammai case(21) - call get_eos_HIIR_iso(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) - + call get_eos_HIIR_iso(polyk,temperature_coef,mui,tempi,ponrhoi,spsoundi,isionisedi) + case(22) call get_eos_HIIR_adiab(polyk,temperature_coef,mui,tempi,ponrhoi,rhoi,eni,gammai,spsoundi,isionisedi) - + case(23) ! !--interpolate tabulated eos from Stamatellos+(2007). For use with icooling=9 @@ -598,7 +598,7 @@ subroutine finish_eos(eos_type,ierr) case(23) ! Stamatellos deallocation call finish_S07cool - + end select done_init_eos=.false. @@ -1290,7 +1290,7 @@ logical function eos_outputs_mu(ieos) eos_outputs_mu = .true. case(23) eos_outputs_mu = .true. -case default + case default eos_outputs_mu = .false. end select diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index ff3b7a404..11eaa0813 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -32,17 +32,17 @@ module eos_stamatellos contains subroutine init_S07cool() - use part, only:npart,maxradprop + use part, only:npart,maxradprop 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(urad_FLD(npart)) + allocate(ttherm_store(npart)) + allocate(teqi_store(npart)) allocate(opac_store(npart)) - allocate(duSPH(npart)) + allocate(duSPH(npart)) Gpot_cool(:) = 0d0 gradP_cool(:) = 0d0 urad_FLD(:) = 0d0 @@ -51,7 +51,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 @@ -69,7 +69,7 @@ subroutine finish_S07cool() if (allocated(ttherm_store)) deallocate(ttherm_store) if (allocated(teqi_store)) deallocate(teqi_store) if (allocated(opac_store)) deallocate(opac_store) - if (allocated(duSPH)) deallocate(duSPH) + if (allocated(duSPH)) deallocate(duSPH) close(iunitst) end subroutine finish_S07cool @@ -108,7 +108,7 @@ end subroutine read_optab ! Main subroutine for interpolating tables to get EOS values ! subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) - use io, only:fatal + use io, only:fatal real, intent(in) :: ui,rhoi real, intent(out) :: kappaBar,kappaPart,Ti,gmwi @@ -130,7 +130,7 @@ subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) 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) endif - + if (rhoi < rhomin) then rhoi_ = rhomin else @@ -235,7 +235,7 @@ subroutine getintenerg_opdep(Teqi, rhoi, ueqi) call warning('getintenerg_opdep','Ti out of range',var='Ti',val=Teqi) endif - + ! interpolate through OPTABLE to obtain equilibrium internal energy if (rhoi < 1.0e-24) then @@ -254,7 +254,7 @@ subroutine getintenerg_opdep(Teqi, rhoi, ueqi) j = j + 1 enddo - + m = (OPTABLE(i-1,j-1,3) - OPTABLE(i-1,j,3))/(OPTABLE(i-1,j-1,2) - OPTABLE(i-1,j,2)) c = OPTABLE(i-1,j,3) - m*OPTABLE(i-1,j,2) @@ -277,25 +277,25 @@ subroutine getintenerg_opdep(Teqi, rhoi, ueqi) end subroutine getintenerg_opdep subroutine get_k_fld(rhoi,eni,i,ki,Ti) - use physcon, only:c,fourpi - 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,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) - kappaPart = kappaPart/unit_opacity - ! steboltz constant = 4pi/c * arad - ki = 16d0*(fourpi/c)*get_radconst_code()*lambda_FLD(i)*Ti**3 /rhoi/kappaPart - if (isnan(ki)) then - print *, "WARNING k isnan, lambda_FLDi,Ti,rhoi,kappaPart", & + use physcon, only:c,fourpi + 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,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) + kappaPart = kappaPart/unit_opacity + ! steboltz constant = 4pi/c * arad + ki = 16d0*(fourpi/c)*get_radconst_code()*lambda_FLD(i)*Ti**3 /rhoi/kappaPart + if (isnan(ki)) then + print *, "WARNING k isnan, lambda_FLDi,Ti,rhoi,kappaPart", & lambda_FLD(i), Ti, rhoi,kappaPart - endif - endif + endif + endif end subroutine get_k_fld end module eos_stamatellos diff --git a/src/main/force.F90 b/src/main/force.F90 index 9fcc9b849..466156540 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -1203,7 +1203,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g call get_k_fld(rhoi,eni,i,kfldi,Ti) endif endif - + loop_over_neighbours2: do n = 1,nneigh j = abs(listneigh(n)) @@ -1606,7 +1606,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g diffterm = 0d0 print *, "setting diffterm = 0", i, j, rhoj elseif ((kfldj + kfldi) < tiny(0.)) then - diffterm = 0d0 + diffterm = 0d0 else diffterm = 4d0*pmassj/rhoi/rhoj diffterm = diffterm * kfldi * kfldj / (kfldi+kfldj) @@ -1621,7 +1621,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g endif endif endif - + !--artificial thermal conductivity (need j term) if (maxvxyzu >= 4) then if (gr) then @@ -1748,9 +1748,9 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g endif if (icooling == 9) then - Gpot_cool(i) = Gpot_cool(i) + pmassj*phii + Gpot_cool(i) = Gpot_cool(i) + pmassj*phii endif - + !--add contribution to particle i's force if (mhd) then !--div B in symmetric form (for source term subtraction) @@ -2008,7 +2008,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g !-- add contribution of 'distant neighbour' (outside r_kernel) gas particle to potential if (iamtypej == igas .and. icooling == 9) Gpot_cool(i) = Gpot_cool(i) + pmassj*phii - + !--self gravity contribution to total energy equation if (gr .and. gravity .and. ien_type == ien_etotal) then fgravxi = fgravxi - dx*fgravj @@ -2021,7 +2021,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g enddo loop_over_neighbours2 if (icooling == 9) gradP_cool(i) = sqrt(gradpx*gradpx + gradpy*gradpy + gradpz*gradpz) - + if (gr .and. gravity .and. ien_type == ien_etotal) then fsum(idudtdissi) = fsum(idudtdissi) + vxi*fgravxi + vyi*fgravyi + vzi*fgravzi endif diff --git a/src/main/inject_bondi.f90 b/src/main/inject_bondi.f90 index 9af9af121..1c2fc22bc 100644 --- a/src/main/inject_bondi.f90 +++ b/src/main/inject_bondi.f90 @@ -220,7 +220,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_firehose.f90 b/src/main/inject_firehose.f90 index 7db1c2759..cf1e5bfb0 100644 --- a/src/main/inject_firehose.f90 +++ b/src/main/inject_firehose.f90 @@ -213,7 +213,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_galcen_winds.f90 b/src/main/inject_galcen_winds.f90 index 5422ba9ff..d52baaf8a 100644 --- a/src/main/inject_galcen_winds.f90 +++ b/src/main/inject_galcen_winds.f90 @@ -226,7 +226,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_keplerian.f90 b/src/main/inject_keplerian.f90 index 7e4f8e221..45376c6ba 100644 --- a/src/main/inject_keplerian.f90 +++ b/src/main/inject_keplerian.f90 @@ -201,7 +201,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_keplerianshear.f90 b/src/main/inject_keplerianshear.f90 index cea2359ae..773fc7d72 100644 --- a/src/main/inject_keplerianshear.f90 +++ b/src/main/inject_keplerianshear.f90 @@ -189,7 +189,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_rochelobe.f90 b/src/main/inject_rochelobe.f90 index 054a264b1..96cd13aca 100644 --- a/src/main/inject_rochelobe.f90 +++ b/src/main/inject_rochelobe.f90 @@ -281,7 +281,7 @@ end subroutine phi_derivs subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_sim.f90 b/src/main/inject_sim.f90 index a305b8dc8..127d1805d 100644 --- a/src/main/inject_sim.f90 +++ b/src/main/inject_sim.f90 @@ -276,7 +276,7 @@ subroutine read_injected_par() injected = .false. endif -end subroutine +end subroutine read_injected_par subroutine update_injected_par() use io, only:error @@ -298,7 +298,7 @@ subroutine update_injected_par() enddo close(iunit) endif -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_sne.f90 b/src/main/inject_sne.f90 index 2152ef1eb..867ad2b88 100644 --- a/src/main/inject_sne.f90 +++ b/src/main/inject_sne.f90 @@ -138,7 +138,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_steadydisc.f90 b/src/main/inject_steadydisc.f90 index eb6d6c128..d7071af77 100644 --- a/src/main/inject_steadydisc.f90 +++ b/src/main/inject_steadydisc.f90 @@ -206,7 +206,7 @@ end subroutine inject_particles_in_annulus subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_unifwind.f90 b/src/main/inject_unifwind.f90 index d2205b97b..80f203a63 100644 --- a/src/main/inject_unifwind.f90 +++ b/src/main/inject_unifwind.f90 @@ -128,7 +128,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_wind.f90 b/src/main/inject_wind.f90 index 43de42245..ed7597fcf 100644 --- a/src/main/inject_wind.f90 +++ b/src/main/inject_wind.f90 @@ -505,7 +505,7 @@ end subroutine inject_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 79ee0aac0..62cdf2f33 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -258,7 +258,7 @@ end subroutine inject_or_update_particles subroutine update_injected_par ! -- placeholder function ! -- does not do anything and will never be used -end subroutine +end subroutine update_injected_par !----------------------------------------------------------------------- !+ diff --git a/src/main/porosity.f90 b/src/main/porosity.f90 index 7b5071b17..a70b3801c 100755 --- a/src/main/porosity.f90 +++ b/src/main/porosity.f90 @@ -789,18 +789,18 @@ end function get_coeffrest real function compute_vstick(mass,size) real, intent(in) ::mass,size compute_vstick = 8.76*((surfenerg**5 * size**4)/(mass**3*youngmod**2))**(1./6.) -end function +end function compute_vstick !--velocity limit between elastic and inelastic bouncing regime real function compute_vyield(vstick) real, intent(in) ::vstick compute_vyield = 10.*vstick -end function +end function compute_vyield !--velocity limit between partial sticking + bouncing regime and full bouncing regime real function compute_vend(vstick) real, intent(in) ::vstick compute_vend = 24343220.*vstick -end function +end function compute_vend end module porosity diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index 468a0be97..95dfb16de 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -437,11 +437,11 @@ subroutine get_opacity(opacity_type,density,temperature,kappa,u) 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 + ! + ! opacity for Stamatellos/Lombardi EOS + ! + call getopac_opdep(u*unit_ergg,density*unit_density,kapBar,kappaPart,Ti,gmwi) + kappa = kappaPart/unit_opacity case default ! ! infinite opacity diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 8a7272e4f..3fbc5581e 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -306,7 +306,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) call write_options_gravitationalwaves(iwritein) call write_options_boundary(iwritein) call write_options_H2R(iwritein) - + if (iwritein /= iprint) close(unit=iwritein) if (iwritein /= iprint) write(iprint,"(/,a)") ' input file '//trim(infile)//' written successfully.' diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index d6167ab5b..31f81dd81 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -127,7 +127,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use eos, only:equationofstate use substepping, only:substep,substep_gr, & substep_sph_gr,substep_sph - + integer, intent(inout) :: npart integer, intent(in) :: nactive real, intent(in) :: t,dtsph @@ -322,7 +322,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else vpred(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif - + !--floor the thermal energy if requested and required if (ufloor > 0.) then if (vpred(4,i) < ufloor) then @@ -486,7 +486,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) endif endif - + if (use_dustgrowth .and. itype==idust) dustprop(:,i) = dustprop(:,i) + dti*ddustprop(:,i) if (itype==igas) then if (mhd) Bevol(:,i) = Bevol(:,i) + dti*dBevol(:,i) @@ -512,7 +512,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif endif - + !--floor the thermal energy if requested and required if (ufloor > 0.) then if (vxyzu(4,i) < ufloor) then diff --git a/src/utils/moddump_radiotde.f90 b/src/utils/moddump_radiotde.f90 index 28af40a44..e984c3792 100644 --- a/src/utils/moddump_radiotde.f90 +++ b/src/utils/moddump_radiotde.f90 @@ -409,7 +409,7 @@ subroutine calc_rho0(rhof) enddo write(*,'(a11,1x,es10.2,1x,a12,1x,i3,1x,a10)') ' Get rho0 =', rhof_rho0*unit_density, 'g/cm^-3 with', iter, 'iterations' -end subroutine +end subroutine calc_rho0 !---------------------------------------------------------------- !+ From 4d61c3a0d681bca6560d5249d53f5296365637f1 Mon Sep 17 00:00:00 2001 From: Shunquan Huang Date: Wed, 31 Jul 2024 18:42:14 -0700 Subject: [PATCH 771/814] new features for randomwind --- src/main/geometry.f90 | 2 +- src/main/inject_randomwind.f90 | 138 ++++++++++++++++++++++++------- src/setup/setup_asteroidwind.f90 | 18 ++-- 3 files changed, 117 insertions(+), 41 deletions(-) diff --git a/src/main/geometry.f90 b/src/main/geometry.f90 index e0fcf88d2..d90782a91 100644 --- a/src/main/geometry.f90 +++ b/src/main/geometry.f90 @@ -203,7 +203,7 @@ subroutine set_rotation_angles(a,b,sin_a,sin_b,cos_a,cos_b) endif if (present(cos_b)) then cosb = cos_b - if (.not.present(cos_b)) sinb = sqrt(1. - cosb**2) + if (.not.present(sin_b)) sinb = sqrt(1. - cosb**2) endif end subroutine set_rotation_angles diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index e0f78cf44..69f6c235c 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -16,11 +16,20 @@ module inject ! ! :Runtime parameters: ! - mdot_str : *mdot with unit* +! - wind_type : wind setup (0=asteroidwind, 1=randomwind) ! - mdot : *mass injection rate in grams/second* ! - mdot_type : *injection rate (0=const, 1=cos(t), 2=r^(-2))* -! - vlag : *percentage lag in velocity of wind* +! - vlag : *percentage lag in velocity of wind* ! - random_type : random position on the surface, 0 for random, 1 for gaussian ! - delta_theta : standard deviation for the gaussion distribution (random_type=1) +! - theta : the inclination of the star or planet (random_type=1, +! if theta = 90, more particles are injected in z direction) +! - phi : the orientation of the star, (random_type=1, +! if theta=90 and phi=90 more particles are injected in x-z plane) +! - inject_pt : the partical that produce wind (when wind_type=1) +! - wind_speed_factor : factor to scale the wind speed based on the Keplerian speed at rinject (when wind_type=1) +! - wind_speed : wind speed +! - r_inject_str : rinject with unit (when wind_type=1) ! ! :Dependencies: binaryutils, externalforces, infile_utils, io, options, ! part, partinject, physcon, random, units @@ -30,6 +39,7 @@ module inject implicit none character(len=*), parameter, public :: inject_type = 'asteroidwind' character(len=20), public :: mdot_str = "5.e8*g/s" + character(len=20), public :: r_inject_str = "0.5*AU" real, public :: mdot = 1.e8 ! mass injection rate in grams/second public :: init_inject,inject_particles,write_options_inject,read_options_inject,& @@ -38,10 +48,17 @@ module inject private real :: npartperorbit = 1000. ! particle injection rate in particles per orbit + integer :: wind_type = 0 ! wind setup (0=asteroidwind, 1=randomwind) real :: vlag = 0.0 ! percentage lag in velocity of wind integer :: mdot_type = 0 ! injection rate (0=const, 1=cos(t), 2=r^(-2)) integer :: random_type = 0 ! random position on the surface, 0 for random, 1 for gaussian real :: delta_theta = 0.5 ! standard deviation for the gaussion distribution (random_type=1) + real :: theta = 0. ! the inclination of the star or planet + real :: phi = 0. ! the orientation of the star + integer :: inject_pt = 2 ! the partical that produce wind (when wind_type=1) + real :: wind_speed = 1.0 ! wind speed in code unit (when wind_type=1) + real :: wind_speed_factor = 1.2 ! factor to scale the wind speed based on the Keplerian speed at rinject + !real :: rinject = 1.0 contains !----------------------------------------------------------------------- @@ -68,7 +85,8 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& use partinject, only:add_or_update_particle use physcon, only:twopi,gg,kboltz,mass_proton_cgs use random, only:get_random_pos_on_sphere, get_gaussian_pos_on_sphere - use units, only:umass, utime, in_code_units + use units, only:in_code_units + use vectorutils, only:cross_product3D, rotatevec use options, only:iexternalforce use externalforces,only:mass1 use binaryutils, only:get_orbit_bits @@ -80,45 +98,62 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& integer :: ierr real, dimension(3) :: xyz,vxyz,r1,r2,v2,vhat,v1 integer :: i,ipart,npinject,seed,pt - real :: dmdt,rasteroid,h,u,speed,inject_this_step - real :: m1,m2,r - real :: dt + real :: dmdt,rinject,h,u,speed,inject_this_step,m1,m2,r,dt + real :: dx(3), vecz(3), veczprime(3), rotaxis(3) + real :: theta_rad, phi_rad, cost, sint, cosp, sinp real, save :: have_injected,t_old real, save :: semia - - if (nptmass < 2 .and. iexternalforce == 0) & - call fatal('inject_asteroidwind','not enough point masses for asteroid wind injection') - if (nptmass > 2) & - call fatal('inject_asteroidwind','too many point masses for asteroid wind injection') - - if (nptmass == 2) then + + ! initial some parameter to avoid warning... + pt = 1 + rinject = 1.0 + r = 1.0 + + ! calculate the wind velocity and other quantities for different wind type + select case (wind_type) + case(0) ! set up asteroid wind + if (nptmass < 2 .and. iexternalforce == 0) & + call fatal('inject_asteroidwind','not enough point masses for asteroid wind injection') + if (nptmass > 2) & + call fatal('inject_asteroidwind','too many point masses for asteroid wind injection') + if (nptmass == 2) then pt = 2 r1 = xyzmh_ptmass(1:3,1) m1 = xyzmh_ptmass(4,1) v1 = vxyz_ptmass(1:3,1) - else + else pt = 1 r1 = 0. m1 = mass1 v1 = 0. - endif - - r2 = xyzmh_ptmass(1:3,pt) - rasteroid = xyzmh_ptmass(ihsoft,pt) - m2 = xyzmh_ptmass(4,pt) - v2 = vxyz_ptmass(1:3,pt) + endif + r2 = xyzmh_ptmass(1:3,pt) + rinject = xyzmh_ptmass(ihsoft,pt) + m2 = xyzmh_ptmass(4,pt) + v2 = vxyz_ptmass(1:3,pt) + speed = sqrt(dot_product(v2,v2)) + vhat = v2/speed + r = sqrt(dot_product(r1-r2,r1-r2)) + wind_speed = (1.-vlag/100)*speed + u = 0. ! setup is isothermal so utherm is not stored + h = hfact*(rinject/2.) + + case(1) ! set up random wind + if (inject_pt > nptmass) call fatal('inject_randomwind', 'not enough point masses for inject target, check inject_pt') + r2 = xyzmh_ptmass(1:3,inject_pt) + rinject = in_code_units(r_inject_str, ierr) + v2 = vxyz_ptmass(1:3,pt) + wind_speed = wind_speed_factor*sqrt(xyzmh_ptmass(4, inject_pt)/rinject) + u = 0. ! setup is isothermal so utherm is not stored + h = hfact - speed = sqrt(dot_product(v2,v2)) - vhat = v2/speed - - r = sqrt(dot_product(r1-r2,r1-r2)) + end select ! ! Add any dependency on radius to mass injection rate (and convert to code units) ! mdot = in_code_units(mdot_str,ierr) dmdt = mdot*mdot_func(r,semia) ! Use semi-major axis as r_ref - ! !-- How many particles do we need to inject? ! (Seems to need at least eight gas particles to not crash) <-- This statement may or may not be true... @@ -129,23 +164,38 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& ! Calculate how many extra particles from previous step to now dt = time - t_old inject_this_step = dt*dmdt/massoftype(igas) - npinject = max(0, int(0.5 + have_injected + inject_this_step - npartoftype(igas) )) - ! Save for next step (faster than integrating the whole thing each time) t_old = time have_injected = have_injected + inject_this_step endif - + ! + !-- set up the tilt of the star, and vectors for rotation + ! + theta_rad = theta*pi/180. + phi_rad = phi*pi/180. + cost = cos(theta_rad) + sint = sin(theta_rad) + cosp = cos(phi_rad) + sinp = sin(phi_rad) + vecz = (/0.,0.,1./) + veczprime = (/sint*cosp,sint*sinp,cost/) + call cross_product3D(vecz, veczprime, rotaxis) ! !-- Randomly inject particles around the asteroids outer 'radius'. ! Only inject them on the side that is facing the central sink ! do i=1,npinject - xyz = r2 + rasteroid*get_pos_on_sphere(seed, delta_theta) - vxyz = (1.-vlag/100)*speed*vhat - u = 0. ! setup is isothermal so utherm is not stored - h = hfact*(rasteroid/2.) + select case (wind_type) + case (0) + xyz = r2 + rinject*get_pos_on_sphere(seed, delta_theta) + vxyz = wind_speed*vhat + case (1) + dx = get_pos_on_sphere(seed, delta_theta) + call rotatevec(dx, rotaxis, theta_rad) + call cross_product3D(veczprime, dx, vhat) + vxyz = v2 + wind_speed*vhat + end select ipart = npart + 1 call add_or_update_particle(igas,xyz,vxyz,h,u,ipart,npart,npartoftype,xyzh,vxyzu) enddo @@ -209,6 +259,7 @@ subroutine write_options_inject(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit + call write_inopt(wind_type, 'wind_type', 'wind setup (0=asteroidwind, 1=randomwind)', iunit) call write_inopt(mdot_str,'mdot','mass injection rate with unit, e.g. 1e8*g/s, 1e-7M_s/yr',iunit) call write_inopt(npartperorbit,'npartperorbit',& 'particle injection rate in particles/binary orbit',iunit) @@ -216,6 +267,13 @@ subroutine write_options_inject(iunit) call write_inopt(mdot_type,'mdot_type','injection rate (0=const, 1=cos(t), 2=r^(-2))',iunit) call write_inopt(random_type, 'random_type', 'random position on the surface, 0 for random, 1 for gaussian', iunit) call write_inopt(delta_theta, 'delta_theta', 'standard deviation for the gaussion distribution (random_type=1)', iunit) + call write_inopt(theta, 'theta', 'the tilt inclination of the star or planet (random_type=1)', iunit) + call write_inopt(phi, 'phi', 'the tilt orientation of the star, (random_type=1)', iunit) + call write_inopt(inject_pt, 'inject_pt', 'the partical that produce wind (when wind_type=1)', iunit) + + call write_inopt(wind_speed_factor, & + & 'wind_speed_factor', 'factor to scale the wind speed based on the Keplerian speed at rinject', iunit) + call write_inopt(r_inject_str, 'r_inject', 'inject radius with units, e.g. 1*AU, 1e8m, (when wind_type=1)', iunit) end subroutine write_options_inject @@ -238,6 +296,9 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) read(valstring,'(A)',iostat=ierr) mdot_str ngot = ngot + 1 ! if (mdot < 0.) call fatal(label,'mdot < 0 in input options') + case('wind_type') + read(valstring,*,iostat=ierr) wind_type + ngot = ngot + 1 case('npartperorbit') read(valstring,*,iostat=ierr) npartperorbit ngot = ngot + 1 @@ -254,6 +315,21 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) case('delta_theta') read(valstring,*,iostat=ierr) delta_theta ngot = ngot + 1 + case('theta') + read(valstring,*,iostat=ierr) theta + ngot = ngot + 1 + case('phi') + read(valstring,*,iostat=ierr) phi + ngot = ngot + 1 + case('inject_pt') + read(valstring,*,iostat=ierr) inject_pt + ngot = ngot + 1 + case('wind_speed_factor') + read(valstring,*,iostat=ierr) wind_speed_factor + ngot = ngot + 1 + case('r_inject') + read(valstring,'(A)',iostat=ierr) r_inject_str + ngot = ngot + 1 case default imatch = .false. end select diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index 0a2af47e0..47b021259 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -26,7 +26,7 @@ module setup ! - mdot_str : *mdot with unit* ! - norbits : *number of orbits* ! - npart_at_end : *number of particles injected after norbits* -! - rasteroid : *radius of asteroid (km)* +! - rinject : *radius of asteroid (km)* ! - semia : *semi-major axis (solar radii)* ! ! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, @@ -38,7 +38,7 @@ module setup implicit none public :: setpart - real :: m1,m2,ecc,semia,hacc1,rasteroid,norbits,gastemp + real :: m1,m2,ecc,semia,hacc1,rinject,norbits,gastemp integer :: npart_at_end,dumpsperorbit,ipot private @@ -49,7 +49,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,idust,set_particle_type,igas use setbinary, only:set_binary,get_a_from_period use spherical, only:set_sphere - use units, only:set_units,umass,udist,utime,unit_velocity,in_code_units + use units, only:set_units,umass,udist,unit_velocity,in_code_units use physcon, only:solarm,au,pi,solarr,ceresm,km,kboltz,mass_proton_cgs use externalforces, only:iext_binary, iext_einsteinprec, update_externalforce, & mass1,accradius1 @@ -83,7 +83,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ecc = 0.54 ! (eccentricity) semia = 0.73 ! (solar radii) hacc1 = 0.1679 ! (solar radii) - rasteroid = 2338.3 ! (km) + rinject = 2338.3 ! (km) gastemp = 5000. ! (K) norbits = 1000. mdot = 5.e8 ! Mass injection rate (will change later by the mdot_str) @@ -125,7 +125,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, semia = semia*solarr/udist hacc1 = hacc1*solarr/udist - rasteroid = rasteroid*km/udist + rinject = rinject*km/udist ! !--general parameters @@ -159,7 +159,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Set a binary orbit given the desired orbital parameters ! call set_binary(m1,m2,semia,ecc,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr) - xyzmh_ptmass(ihsoft,2) = rasteroid ! Asteroid radius softening + xyzmh_ptmass(ihsoft,2) = rinject ! Asteroid radius softening else @@ -179,7 +179,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, xyzmh_ptmass(4,1) = m2 xyzmh_ptmass(ihacc,1) = hacc2 ! asteroid should not accrete - xyzmh_ptmass(ihsoft,1) = rasteroid ! asteroid radius softening + xyzmh_ptmass(ihsoft,1) = rinject ! asteroid radius softening endif ! we use the estimated injection rate and the final time to set the particle mass @@ -218,7 +218,7 @@ subroutine write_setupfile(filename) call write_inopt(ecc, 'ecc', 'eccentricity', iunit) call write_inopt(semia, 'semia', 'semi-major axis (solar radii)', iunit) call write_inopt(hacc1, 'hacc1', 'white dwarf (sink) accretion radius (solar radii)',iunit) - call write_inopt(rasteroid, 'rasteroid', 'radius of asteroid (km)', iunit) + call write_inopt(rinject, 'rinject', 'radius of asteroid (km)', iunit) call write_inopt(gastemp, 'gastemp', 'gas temperature in K', iunit) call write_inopt(norbits, 'norbits', 'number of orbits', iunit) call write_inopt(dumpsperorbit,'dumpsperorbit','number of dumps per orbit', iunit) @@ -248,7 +248,7 @@ subroutine read_setupfile(filename,ierr) call read_inopt(ecc, 'ecc', db,min=0.,errcount=nerr) call read_inopt(semia, 'semia', db,min=0.,errcount=nerr) call read_inopt(hacc1, 'hacc1', db,min=0.,errcount=nerr) - call read_inopt(rasteroid, 'rasteroid', db,min=0.,errcount=nerr) + call read_inopt(rinject, 'rinject', db,min=0.,errcount=nerr) call read_inopt(gastemp, 'gastemp', db,min=0.,errcount=nerr) call read_inopt(norbits, 'norbits', db,min=0.,errcount=nerr) call read_inopt(dumpsperorbit,'dumpsperorbit',db,min=0 ,errcount=nerr) From ea350d88e466ddf10a9326f167041e3e000ea2ad Mon Sep 17 00:00:00 2001 From: Shunquan Huang Date: Wed, 31 Jul 2024 21:59:09 -0700 Subject: [PATCH 772/814] fix a bug when theta=0 and some typo --- src/main/inject_randomwind.f90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index 69f6c235c..00cb7abfb 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -180,7 +180,11 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& sinp = sin(phi_rad) vecz = (/0.,0.,1./) veczprime = (/sint*cosp,sint*sinp,cost/) - call cross_product3D(vecz, veczprime, rotaxis) + if (abs(theta_rad-0)<1e-6) then + rotaxis = (/0.,0.,1./) + else + call cross_product3D(vecz, veczprime, rotaxis) + endif ! !-- Randomly inject particles around the asteroids outer 'radius'. ! Only inject them on the side that is facing the central sink @@ -269,8 +273,7 @@ subroutine write_options_inject(iunit) call write_inopt(delta_theta, 'delta_theta', 'standard deviation for the gaussion distribution (random_type=1)', iunit) call write_inopt(theta, 'theta', 'the tilt inclination of the star or planet (random_type=1)', iunit) call write_inopt(phi, 'phi', 'the tilt orientation of the star, (random_type=1)', iunit) - call write_inopt(inject_pt, 'inject_pt', 'the partical that produce wind (when wind_type=1)', iunit) - + call write_inopt(inject_pt, 'inject_pt', 'the particle that excites wind (when wind_type=1)', iunit) call write_inopt(wind_speed_factor, & & 'wind_speed_factor', 'factor to scale the wind speed based on the Keplerian speed at rinject', iunit) call write_inopt(r_inject_str, 'r_inject', 'inject radius with units, e.g. 1*AU, 1e8m, (when wind_type=1)', iunit) From ae2f84c336a22d7d060ea24a694b7e8f41404ea0 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 1 Aug 2024 10:22:29 +0200 Subject: [PATCH 773/814] (subgroup) wrong index in binaries in multiple --- src/main/ptmass.F90 | 3 ++- src/main/subgroup.f90 | 5 ++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 35a7df04d..1fd8a2b2f 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1719,7 +1719,6 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas real :: a(8),velk,rk,xk(3),vk(3),xcom(3),vcom(3),rvir - write(iprint,"(a,es18.10)") "ptmass_create_stars : new stars formed at : ",time !! save xcom and vcom before placing stars xi(1) = xyzmh_ptmass(1,itest) xi(2) = xyzmh_ptmass(2,itest) @@ -1730,6 +1729,8 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas vi(2) = vxyz_ptmass(2,itest) vi(3) = vxyz_ptmass(3,itest) + write(iprint,"(a,es18.10,a,es18.10)") "ptmass_create_stars : new stars formed at : ",time,"Mass : ",mi + !! masses sampling method call ptmass_endsize_lklist(itest,l,n,linklist_ptmass) allocate(masses(n)) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 4936d9860..62ca5841e 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -108,7 +108,6 @@ end subroutine group_identify subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) use part, only: igarg,igcum,icomp,isemi,iecc,iapo,iorb - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer, intent(inout) :: group_info(:,:) real, intent(inout) :: bin_info(:,:) @@ -126,11 +125,11 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) gsize = (end_id - start_id) + 1 - group_info(icomp,start_id:end_id) = -1 if (gsize > 2) then call binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,& gsize,start_id,end_id) else + group_info(icomp,start_id:end_id) = -1 k = group_info(igarg,start_id) l = group_info(igarg,end_id) group_info(icomp,end_id) = k @@ -172,7 +171,7 @@ subroutine binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gs ns = r2min_id(np) if (r2min_id(ns) == np) then ! We found a binary into a subgroup : tag as binary component and compute parameters l = group_info(igarg,ns+(start_id-1)) - group_info(icomp,np) = l + group_info(icomp,j) = l group_info(icomp,ns+(start_id-1)) = k ! !-- Compute and store main orbital parameters needed for SDAR method From ff647d920f69f4a046109b36566ca78c3eeda5cb Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 1 Aug 2024 16:13:37 +0100 Subject: [PATCH 774/814] Bugs fixed in icooling=9 --- src/main/cooling_radapprox.f90 | 3 +++ src/main/dens.F90 | 9 ++++++++- src/main/step_leapfrog.F90 | 1 + 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index cbc532954..89c563a71 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -166,6 +166,9 @@ subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) ! 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 endif diff --git a/src/main/dens.F90 b/src/main/dens.F90 index 14e3c9c07..9465f506d 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -348,7 +348,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol endif call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad) - if (icooling==9 .and. doFLD) then + 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) endif if (do_export) then @@ -1706,6 +1706,9 @@ subroutine calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gra ! note: only active particles have been sent here if (maxphase==maxp) then call get_partinfo(cell%iphase(icell),iactivei,iamgasi,iamdusti,iamtypei) + if (.not. iamgasi) then + print *, "error not gas", i + endif else iactivei = .true. iamtypei = igas @@ -1729,6 +1732,10 @@ subroutine calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gra !calculate rhoi call rhoanddhdrho(hi,hi1,rhoi,rho1i,dhdrhoi,pmassi) ! get Ti from tabulated eos + if (vxyzu(4,i) < epsilon(vxyzu(4,i))) then + 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) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 31f81dd81..c0ab8c974 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -384,6 +384,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 == 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,& From be08f63effe0bebbd0b285cfeb16e87f942f57b3 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 2 Aug 2024 16:08:58 +1000 Subject: [PATCH 775/814] (#580) fix failing github actions tests by moving data files to Zenodo --- .gitignore | 3 +++ scripts/test_analysis_ce.sh | 2 +- src/main/datafiles.f90 | 46 ++++++++++++++++++++++++++++++++---- src/main/utils_datafiles.f90 | 5 ---- 4 files changed, 45 insertions(+), 11 deletions(-) diff --git a/.gitignore b/.gitignore index 4b9ae030f..0a86fba6e 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,9 @@ build/phantom-version.h *~ */*~ */*/*~ +eos_binary_table.dat +helm_data.tab +forcing.dat *.bindata *.pyc #* diff --git a/scripts/test_analysis_ce.sh b/scripts/test_analysis_ce.sh index c390f9ef8..a149860b8 100755 --- a/scripts/test_analysis_ce.sh +++ b/scripts/test_analysis_ce.sh @@ -12,7 +12,7 @@ rm -f *.ev *txt # grab the data file from the server if it doesn't already exist file=binary_01000 if [ ! -f $file ]; then - curl -k https://users.monash.edu.au/~dprice/phantom/data/tests/test_analysis_ce/binary_01000 -o binary_01000; err=$?; + curl -k https://zenodo.org/records/13163487/files/binary_01000 -o binary_01000; err=$?; if [ $err -gt 0 ]; then exit $err; fi diff --git a/src/main/datafiles.f90 b/src/main/datafiles.f90 index b5f68a30d..4fe49b13f 100644 --- a/src/main/datafiles.f90 +++ b/src/main/datafiles.f90 @@ -7,8 +7,8 @@ module datafiles ! ! Interface to routine to search for external data files -! This module just provides the url and environment variable -! settings that are specific to Phantom +! This module just provides the url and environment variable +! settings that are specific to Phantom ! ! :References: None ! @@ -19,11 +19,14 @@ module datafiles ! :Dependencies: datautils, io, mpiutils ! implicit none - character(len=*), parameter :: data_url = & - 'https://users.monash.edu.au/~dprice/phantom/' contains +!---------------------------------------------------------------- +!+ +! Find a datafile in the Phantom data directory +!+ +!---------------------------------------------------------------- function find_phantom_datafile(filename,loc) use datautils, only:find_datafile use io, only:id,master @@ -34,7 +37,8 @@ function find_phantom_datafile(filename,loc) search_dir = 'data/'//trim(adjustl(loc)) if (id == master) then ! search for and download datafile if necessary - find_phantom_datafile = find_datafile(filename,dir=search_dir,env_var='PHANTOM_DIR',url=data_url) + find_phantom_datafile = find_datafile(filename,dir=search_dir,env_var='PHANTOM_DIR',& + url=map_dir_to_web(trim(search_dir))) endif call barrier_mpi() if (id /= master) then ! find datafile location, do not attempt to download it @@ -44,4 +48,36 @@ function find_phantom_datafile(filename,loc) end function find_phantom_datafile +!---------------------------------------------------------------- +!+ +! Find the web location for files that are not in the Phantom +! git repo, which need to be downloaded into the data directory +! at runtime +!+ +!---------------------------------------------------------------- +function map_dir_to_web(search_dir) result(url) + character(len=*), intent(in) :: search_dir + character(len=120) :: url + + !print*,' search_dir=',trim(search_dir) + select case(search_dir) + case('data/eos/mesa') + url = 'https://zenodo.org/records/13148447/files/' + case('data/eos/shen') + url = 'https://zenodo.org/records/13163155/files/' + case('data/eos/helmholtz') + url = 'https://zenodo.org/records/13163286/files/' + case('data/forcing') + url = 'https://zenodo.org/records/13162225/files/' + case('data/velfield') + url = 'https://zenodo.org/records/13162515/files/' + case('data/galaxy_merger') + url = 'https://zenodo.org/records/13162815/files/' + case default + url = 'https://users.monash.edu.au/~dprice/'//trim(search_dir) + end select + !print*,'url=',trim(new_url) + +end function map_dir_to_web + end module datafiles diff --git a/src/main/utils_datafiles.f90 b/src/main/utils_datafiles.f90 index f3212a0dd..2e6173808 100644 --- a/src/main/utils_datafiles.f90 +++ b/src/main/utils_datafiles.f90 @@ -79,11 +79,6 @@ function find_datafile(filename,dir,env_var,url,verbose) result(filepath) ! try to download the file from a remote url ! my_url = url - if (present(dir)) then - if (len_trim(dir) > 0) my_url = trim(url)//'/'//trim(dir)//'/' - else - my_url = url - endif call download_datafile(trim(my_url),trim(mydir),trim(filename),filepath,ierr) if (ierr == 0) then inquire(file=trim(filepath),exist=iexist) From ef72b3885c00cfdee72b0bec03106a88887c1a67 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 2 Aug 2024 18:02:57 +1000 Subject: [PATCH 776/814] (#580) fix starcluster setup + update docs --- docs/developer-guide/datafiles.rst | 29 ++++++++++++++++++++++++----- src/main/datafiles.f90 | 2 ++ 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/docs/developer-guide/datafiles.rst b/docs/developer-guide/datafiles.rst index 68f97fd03..5ceaa8f03 100644 --- a/docs/developer-guide/datafiles.rst +++ b/docs/developer-guide/datafiles.rst @@ -57,10 +57,29 @@ For large data files, the procedure is as follows: 2. Add the name of the file to the **.gitignore** file in the root-level phantom directory -3. Then, send your file to daniel.price@monash.edu (e.g. via Dropbox) to - store on the phantom website -4. Implement the call in the code as previously using the +3. Then, upload your file(s) to a repository on zenodo.org, obtain + the DOI for the repository, and submit it in the phantom zenodo community + + https://zenodo.org/communities/phantom/ + + This will allow the file to be downloaded + by Phantom users at runtime +4. Edit the datafiles.f90 module to include the URL for the file in the + **map_dir_to_web** routine. This routine maps the directory where the + file should be located to the URL where the file can be downloaded + from. For example, if the file is in the + **star_data_files/red_giant** directory, you would add a case to the + routine like so: + +:: + + case('data/star_data_files/red_giant') + url = 'https://zenodo.org/records/12345678/files/' + + where the URL is the URL of the repository on zenodo.org + +5. Implement the call in the code as previously using the find_phantom_datafile routine. This will automatically retrieve the - file from the web into your phantom/data directory at runtime (using - wget). Alternatively you can manually place the file in the + file from the web into your phantom/data directory at runtime. + Alternatively you can manually download the file to the appropriate folder diff --git a/src/main/datafiles.f90 b/src/main/datafiles.f90 index 4fe49b13f..df791da0b 100644 --- a/src/main/datafiles.f90 +++ b/src/main/datafiles.f90 @@ -73,6 +73,8 @@ function map_dir_to_web(search_dir) result(url) url = 'https://zenodo.org/records/13162515/files/' case('data/galaxy_merger') url = 'https://zenodo.org/records/13162815/files/' + case('data/starcluster') + url = 'https://zenodo.org/records/13164858/files/' case default url = 'https://users.monash.edu.au/~dprice/'//trim(search_dir) end select From 8c95e8c0d2bd99e0b2257e62e765854571759a6a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 2 Aug 2024 10:31:44 +0200 Subject: [PATCH 777/814] (evolve) new condition to recompute forces after creating a sink --- src/main/evolve.F90 | 8 ++++---- src/main/substepping.F90 | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 2f0d063b2..989b9580e 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -143,7 +143,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) logical :: use_global_dt integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold character(len=120) :: dumpfile_orig - integer :: dummy,istepHII + integer :: dummy,istepHII,nptmass_old dummy = 0 @@ -279,7 +279,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! across all nodes nskip = int(ntot) #endif - + nptmass_old = nptmass if (gravity .and. icreate_sinks > 0 .and. ipart_rhomax /= 0) then ! ! creation of new sink particles @@ -310,13 +310,13 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) istepHII = 2**nbinmax/HIIuprate if (istepHII==0) istepHII = 1 endif - if (mod(istepfrac,istepHII)==0 .or. istepfrac==1 .or. (icreate_sinks == 2 .and. ipart_createstars /= 0)) then + if (mod(istepfrac,istepHII) == 0 .or. istepfrac == 1 .or. (icreate_sinks == 2 .and. ipart_createstars /= 0)) then call HII_feedback(nptmass,npart,xyzh,xyzmh_ptmass,vxyzu,isionised) endif endif ! Need to recompute the force when sink or stars are created - if (ipart_rhomax /= 0 .or. ipart_createseeds /= 0 .or. ipart_createstars /= 0) then + if (nptmass > nptmass_old .or. ipart_createseeds /= 0 .or. ipart_createstars /= 0) then if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,nmatrix) call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 05333e117..ddc4171dd 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -944,8 +944,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, 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 (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf 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 @@ -955,8 +955,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, 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) - if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf 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) endif From b5fcdb25e25e5a737f1d17e066adf65fff3179ec Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 2 Aug 2024 11:07:07 +0200 Subject: [PATCH 778/814] (subgroup) kill the code if kappa is bellow 1 when needed --- src/main/subgroup.f90 | 51 ++++++++++++++++++++++++++++++++++--------- 1 file changed, 41 insertions(+), 10 deletions(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 62ca5841e..c1583fe4b 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -451,6 +451,7 @@ end subroutine evolve_groups subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,& bin_info,group_info,fxyz_ptmass,gtgrad) use part, only: igarg,ikap,iorb + use io, only: fatal real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & fxyz_ptmass(:,:),gtgrad(:,:),bin_info(:,:) integer, intent(inout) :: group_info(:,:) @@ -481,7 +482,11 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ !-- We need to compute the force a the beginning of the step ( and kappa if slow down) ! call get_kappa_bin(xyzmh_ptmass,bin_info,prim,sec) - kappa1 = 1./bin_info(ikap,prim) + if (bin_info(ikap,prim) >= 1.) then + kappa1 = 1./bin_info(ikap,prim) + else + call fatal('subgroup','kappa value bellow 1... something wrong here!',var='kappa',val=bin_info(ikap,prim)) + endif call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,W,kappa1,prim,sec,& ds_init=ds_init,Tij=bin_info(iorb,prim)) endif @@ -675,6 +680,7 @@ end subroutine restore_state subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsize,s_id,e_id) use part, only: igarg,icomp,ikap + use io, only: fatal real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),bin_info(:,:) integer, intent(in) :: group_info(:,:) real, intent(inout) :: tcoord @@ -682,7 +688,7 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsi integer, intent(in) :: s_id,e_id,gsize integer, allocatable :: binstack(:) integer :: k,i,compi,n - real :: dtd,vcom(3),m1,m2,mtot,kappa1i + real :: dtd,vcom(3),m1,m2,mtot,kappai,kappa1i allocate(binstack((gsize/4)+1)) binstack = 0 @@ -699,7 +705,13 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsi m1 = xyzmh_ptmass(4,i) m2 = xyzmh_ptmass(4,compi) mtot = m1+m2 - kappa1i = 1./bin_info(ikap,i) + kappai = bin_info(ikap,i) + if (kappai >= 1.) then + kappa1i = 1./kappai + else + kappa1i = 1. + call fatal('subgroup','kappa value bellow 1... something wrong here!',var='kappai',val=kappai) + endif if (any(binstack == i)) cycle! If already treated i will be in binstack vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,compi))/mtot vcom(2) = (m1*vxyz_ptmass(2,i)+m2*vxyz_ptmass(2,compi))/mtot @@ -722,13 +734,14 @@ end subroutine drift_TTL subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,s_id,e_id) use part, only: igarg,ikap + use io, only: fatal real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) real, intent(inout) :: gtgrad(:,:),bin_info(:,:) integer, intent(inout) :: group_info(:,:) real, intent(in) :: h real, intent(inout) :: W integer, intent(in) :: s_id,e_id - real :: om,dw,dtk,kappa1,om_old + real :: om,dw,dtk,kappa1i,kappai,om_old integer :: i,k,gsize gsize = (e_id-s_id+1) @@ -755,8 +768,14 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass dw = 0. do k=s_id,e_id i=group_info(igarg,k) - kappa1 = 1./bin_info(ikap,i) - dw = dw + kappa1*(vxyz_ptmass(1,i)*gtgrad(1,i) + & + kappai = bin_info(ikap,i) + if (kappai >= 1.) then + kappa1i = 1./kappai + else + kappa1i = 1. + call fatal('subgroup','kappa value bellow 1... something wrong here!',var='kappai',val=kappai) + endif + dw = dw + kappa1i*(vxyz_ptmass(1,i)*gtgrad(1,i) + & vxyz_ptmass(2,i)*gtgrad(2,i) + & vxyz_ptmass(3,i)*gtgrad(3,i)) enddo @@ -878,6 +897,7 @@ end subroutine correct_com_drift subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id,potonly,ds_init) use part, only: igarg,iorb,ikap,icomp + use io, only: fatal real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:),bin_info(:,:) integer, intent(in) :: group_info(:,:) @@ -886,7 +906,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, logical, optional, intent(in) :: potonly real, optional, intent(out) :: ds_init real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3,dt_init,om_init - real :: gravf,gtk,gtki,gravfi(3),gtgradi(3),Ti,kappa1i + real :: gravf,gtk,gtki,gravfi(3),gtgradi(3),Ti,kappa1i,kappai integer :: i,j,k,l,compi logical :: init om = 0. @@ -905,7 +925,13 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, do k=s_id,e_id i = group_info(igarg,k) compi = group_info(icomp,k) - kappa1i = 1./bin_info(ikap,i) + kappai = bin_info(ikap,i) + if (kappai >= 1.) then + kappa1i = 1./kappai + else + kappa1i = 1. + call fatal('subgroup','kappa value bellow 1... something wrong here!',var='kappai',val=kappai) + endif gravfi(1) = 0. gravfi(2) = 0. gravfi(3) = 0. @@ -1155,7 +1181,7 @@ end subroutine init_kappa subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) use part, only: igarg,igcum,ikap - use io, only: id,master + use io, only: id,master,fatal integer, intent(in) :: n_group real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) real, intent(inout) :: bin_info(:,:) @@ -1180,7 +1206,12 @@ subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,g else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) - kappa1 = 1./bin_info(ikap,prim) + if (bin_info(ikap,prim) >= 1.) then + kappa1 = 1./bin_info(ikap,prim) + else + kappa1 = 1. + call fatal('subgroup','kappa value bellow 1... something wrong here!',var='kappa',val=bin_info(ikap,prim)) + endif call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phigroup,kappa1,prim,sec,.true.) endif phitot = phitot + phigroup From 73f3faa185b5282793e232eb6cee225ca2f288a6 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 2 Aug 2024 11:44:12 +0200 Subject: [PATCH 779/814] (bots) run the bots after a mailmap update --- .mailmap | 1 + AUTHORS | 2 +- src/main/H2regions.f90 | 8 ++++---- src/main/eos_HIIR.f90 | 2 +- src/main/evolve.F90 | 2 +- src/main/initial.F90 | 2 +- src/main/readwrite_dumps_common.f90 | 2 +- src/main/readwrite_dumps_fortran.f90 | 2 +- src/main/subgroup.f90 | 6 +++--- src/main/substepping.F90 | 4 ++-- src/main/utils_kepler.f90 | 2 +- src/main/utils_subgroup.f90 | 2 +- src/setup/setup_cluster.f90 | 1 + src/setup/setup_starcluster.f90 | 2 +- 14 files changed, 20 insertions(+), 18 deletions(-) diff --git a/.mailmap b/.mailmap index 8332207b8..c9fc89a99 100644 --- a/.mailmap +++ b/.mailmap @@ -116,3 +116,4 @@ Amena Faruqi Amena Faruqi Alison Young Alison Young Simone Ceppi Simone Ceppi Nicolás Cuello Nicolas Cuello +Yann BERNARD Yrisch diff --git a/AUTHORS b/AUTHORS index 649e5eb20..388763102 100644 --- a/AUTHORS +++ b/AUTHORS @@ -12,8 +12,8 @@ James Wurster David Liptai Lionel Siess Fangyi (Fitz) Hu +Yann BERNARD Daniel Mentiplay -Yrisch Megha Sharma Arnaud Vericel Mark Hutchison diff --git a/src/main/H2regions.f90 b/src/main/H2regions.f90 index 8d81b4a12..b462936f8 100644 --- a/src/main/H2regions.f90 +++ b/src/main/H2regions.f90 @@ -7,19 +7,19 @@ module HIIRegion ! ! HIIRegion +! contains routines to model HII region expansion due to ionization and radiation pressure.. +! routine originally made by Hopkins et al. (2012),reused by Fujii et al. (2021) +! and adapted in Phantom by Yann Bernard ! ! :References: Fujii et al. (2021), Hopkins et al. (2012) ! -! :Owner: Yrisch +! :Owner: Yann BERNARD ! ! :Runtime parameters: None ! ! :Dependencies: dim, eos, infile_utils, io, linklist, part, physcon, ! sortutils, timing, units ! -! contains routines to model HII region expansion due to ionization and radiation pressure.. -! routine originally made by Hopkins et al. (2012),reused by Fujii et al. (2021) -! and adapted in Phantom by Yann Bernard implicit none diff --git a/src/main/eos_HIIR.f90 b/src/main/eos_HIIR.f90 index 315d97734..d8b63ddcc 100644 --- a/src/main/eos_HIIR.f90 +++ b/src/main/eos_HIIR.f90 @@ -10,7 +10,7 @@ module eos_HIIR ! ! :References: None ! -! :Owner: Yrisch +! :Owner: Yann BERNARD ! ! :Runtime parameters: None ! diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 989b9580e..d3a4e4c89 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -306,7 +306,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (iH2R > 0 .and. id==master) then istepHII = 1 - if(ind_timesteps) then + if (ind_timesteps) then istepHII = 2**nbinmax/HIIuprate if (istepHII==0) istepHII = 1 endif diff --git a/src/main/initial.F90 b/src/main/initial.F90 index c8511dc91..d9faafdb1 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -529,7 +529,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) if (ntypes > 1 .and. maxphase==maxp) then pmassi = massoftype(iamtype(iphase(i))) endif - if (use_regnbody)then + 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) diff --git a/src/main/readwrite_dumps_common.f90 b/src/main/readwrite_dumps_common.f90 index c3059a51f..f67ae3c05 100644 --- a/src/main/readwrite_dumps_common.f90 +++ b/src/main/readwrite_dumps_common.f90 @@ -16,7 +16,7 @@ module readwrite_dumps_common ! ! :Dependencies: boundary, boundary_dyn, checkconserved, dim, dump_utils, ! dust, dust_formation, eos, externalforces, fileutils, gitinfo, io, -! options, part, ptmass, setup_params, sphNGutils, timestep, units +! options, part, setup_params, sphNGutils, timestep, units ! use dump_utils, only:lenid implicit none diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 40015c958..429c6ff32 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -19,7 +19,7 @@ module readwrite_dumps_fortran ! :Runtime parameters: None ! ! :Dependencies: boundary_dyn, dim, dump_utils, eos, io, memory, -! metric_tools, mpiutils, options, part, ptmass, readwrite_dumps_common, +! metric_tools, mpiutils, options, part, readwrite_dumps_common, ! sphNGutils, timestep ! use dump_utils, only:lenid,ndatatypes,i_int,i_int1,i_int2,i_int4,i_int8,& diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index c1583fe4b..972da5a43 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -11,7 +11,7 @@ module subgroup ! ! :References: Makkino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 ! -! :Owner: Yrisch +! :Owner: Yann BERNARD ! ! :Runtime parameters: None ! @@ -815,7 +815,7 @@ subroutine oneStep_bin(tcoord,W,ds,kappa1,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,g vcom(3) = (m1*vxyz_ptmass(3,i)+m2*vxyz_ptmass(3,j))/mtot - if(kappa1 < 1.0) then + if (kappa1 < 1.0) then call correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,dtd,i,j) else xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) @@ -985,7 +985,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, endif if (init) then - if(compi /=i) then + if (compi /=i) then Ti = bin_info(iorb,i) dt_init = min(dt_init,0.002*Ti) endif diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index ddc4171dd..954b7a9f4 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -21,7 +21,7 @@ module substepping ! Tuckerman, Berne & Martyna (1992), J. Chem. Phys. 97, 1990-2001 ! Rantala + (2020) (2023),Chin (2007a) ! -! :Owner: Yrisch +! :Owner: Yann BERNARD ! ! :Runtime parameters: None ! @@ -1008,7 +1008,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, zi = xyzh(3,i) endif if (nptmass > 0) then - if(wsub) then + if (wsub) then if (extrap) then call get_accel_sink_gas(nptmass,xi,yi,zi,xyzh(4,i),xyzmh_ptmass,& fextx,fexty,fextz,phii,pmassi,fxyz_ptmass, & diff --git a/src/main/utils_kepler.f90 b/src/main/utils_kepler.f90 index 778b83b3d..99d427ff3 100644 --- a/src/main/utils_kepler.f90 +++ b/src/main/utils_kepler.f90 @@ -10,7 +10,7 @@ module utils_kepler ! ! :References: None ! -! :Owner: Yrisch +! :Owner: Yann BERNARD ! ! :Runtime parameters: None ! diff --git a/src/main/utils_subgroup.f90 b/src/main/utils_subgroup.f90 index 913a57606..bf71ef7bb 100644 --- a/src/main/utils_subgroup.f90 +++ b/src/main/utils_subgroup.f90 @@ -10,7 +10,7 @@ module utils_subgroup ! ! :References: None ! -! :Owner: Yrisch +! :Owner: Yann BERNARD ! ! :Runtime parameters: None ! diff --git a/src/setup/setup_cluster.f90 b/src/setup/setup_cluster.f90 index c1d1ae01a..157414cfa 100644 --- a/src/setup/setup_cluster.f90 +++ b/src/setup/setup_cluster.f90 @@ -22,6 +22,7 @@ module setup ! - mass_fac : *mass unit in Msun* ! - mu : *mean molecular mass* ! - n_particles : *number of particles in sphere* +! - relax : *relax the cloud ?* ! ! :Dependencies: HIIRegion, centreofmass, cooling, datafiles, dim, eos, ! infile_utils, io, kernel, mpidomain, options, part, physcon, prompting, diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index 970ea2b96..44d8f318c 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -11,7 +11,7 @@ module setup ! ! :References: Paumard et al. (2006) ! -! :Owner: Yrisch +! :Owner: Yann BERNARD ! ! :Runtime parameters: ! - datafile : *filename for star data (m,x,y,z,vx,vy,vz)* From 11ceac5b1f9d9c22212ff90b3dbe3f00d8d6d1b8 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 2 Aug 2024 13:01:40 +0200 Subject: [PATCH 780/814] (subgroup) fix bad zeroing of bin_info --- src/main/subgroup.f90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 972da5a43..ec1b200d5 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -185,9 +185,12 @@ subroutine binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gs bin_info(iapo,l) = apokl bin_info(iorb,k) = Tkl bin_info(iorb,l) = Tkl - else ! No matches... Only a single + else ! No matches... Only a single group_info(icomp,j) = k - bin_info(:,k) = 0. + bin_info(isemi,k) = 0. + bin_info(iecc,k) = 0. + bin_info(iapo,k) = 0. + bin_info(iorb,k) = 0. endif endif enddo @@ -1210,7 +1213,7 @@ subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,g kappa1 = 1./bin_info(ikap,prim) else kappa1 = 1. - call fatal('subgroup','kappa value bellow 1... something wrong here!',var='kappa',val=bin_info(ikap,prim)) + call fatal('subgroup','kappa value bellow 1... something wrong here!(energy)',var='kappa',val=bin_info(ikap,prim)) endif call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phigroup,kappa1,prim,sec,.true.) endif From 3cc5a1c057a9e075e86212fa260c2f3b617e22b4 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 2 Aug 2024 13:27:40 +0200 Subject: [PATCH 781/814] (subgroup) kappa can be equal to zero if a new group is dectected at the last substep --- src/main/initial.F90 | 4 ++-- src/main/subgroup.f90 | 19 +++++++++++-------- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index d9faafdb1..0c2340dc1 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -212,7 +212,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use fileutils, only:make_tags_unique use damping, only:idamp - use subgroup, only:group_identify,init_subgroup,init_kappa + use subgroup, only:group_identify,init_subgroup,update_kappa use HIIRegion, only:iH2R,initialize_H2R,update_ionrates character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile @@ -551,7 +551,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) ! Reduce dt over MPI tasks dtsinkgas = reduceall_mpi('min',dtsinkgas) dtextforce = reduceall_mpi('min',dtextforce) - if (use_regnbody) call init_kappa(xyzmh_ptmass,bin_info,group_info,n_group) + if (use_regnbody) call update_kappa(xyzmh_ptmass,bin_info,group_info,n_group) endif call init_ptmass(nptmass,logfile) if (gravity .and. icreate_sinks > 0 .and. id==master) then diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index ec1b200d5..a59901ebb 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -24,7 +24,7 @@ module subgroup public :: evolve_groups public :: get_pot_subsys public :: init_subgroup - public :: init_kappa + public :: update_kappa ! !-- parameters for group identification ! @@ -476,7 +476,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ismultiple = gsize > 2 if (ismultiple) then - call update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,start_id,end_id) + call get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,start_id,end_id) call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,W,start_id,end_id,ds_init=ds_init) else prim = group_info(igarg,start_id) @@ -753,7 +753,7 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass call binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,& gsize,s_id,e_id) call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om_old,s_id,e_id,.true.) - call update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) + call get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id) W = W + (om-om_old) ! correct W after updating kappa... else @@ -1001,7 +1001,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, end subroutine get_force_TTL -subroutine update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) +subroutine get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) use part, only:igarg,icomp,ipert,ikap,iapo,iecc,isemi real , intent(in) :: xyzmh_ptmass(:,:) real , intent(inout) :: bin_info(:,:) @@ -1063,7 +1063,7 @@ subroutine update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) deallocate(binstack) -end subroutine update_kappa +end subroutine get_kappa subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,potonly,ds_init,Tij) real, intent(in) :: xyzmh_ptmass(:,:) @@ -1159,7 +1159,7 @@ subroutine get_kappa_bin(xyzmh_ptmass,bin_info,i,j) end subroutine get_kappa_bin -subroutine init_kappa(xyzmh_ptmass,bin_info,group_info,n_group) +subroutine update_kappa(xyzmh_ptmass,bin_info,group_info,n_group) use part, only:igcum,igarg real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: bin_info(:,:) @@ -1172,14 +1172,14 @@ subroutine init_kappa(xyzmh_ptmass,bin_info,group_info,n_group) end_id = group_info(igcum,i+1) gsize = (end_id - start_id) + 1 if (gsize>2) then - call update_kappa(xyzmh_ptmass,group_info,bin_info,gsize,start_id,end_id) + call get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,start_id,end_id) else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) call get_kappa_bin(xyzmh_ptmass,bin_info,prim,sec) endif enddo -end subroutine init_kappa +end subroutine update_kappa subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) @@ -1193,6 +1193,9 @@ subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,g integer :: i,start_id,end_id,gsize,prim,sec real :: phitot,phigroup,kappa1 phitot = 0. + + call update_kappa(xyzmh_ptmass,bin_info,group_info,n_group) + if (n_group>0) then if (id==master) then !$omp parallel do default(none)& From d225c73922210cea223d1358cff719ba02a72d22 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 2 Aug 2024 16:02:40 +0200 Subject: [PATCH 782/814] (ptmass) update star and seed creation id in a separated function --- src/main/ptmass.F90 | 38 +++++++++++++++++++++++++------------- src/main/substepping.F90 | 4 +++- 2 files changed, 28 insertions(+), 14 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 1fd8a2b2f..02bc2cb1d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -53,7 +53,7 @@ module ptmass public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured public :: ptmass_accrete, ptmass_create - public :: ptmass_create_stars,ptmass_create_seeds + public :: ptmass_create_stars,ptmass_create_seeds,ptmass_check_stars public :: write_options_ptmass, read_options_ptmass public :: update_ptmass public :: calculate_mdot @@ -691,6 +691,7 @@ subroutine ptmass_kick(nptmass,dkdt,vxyz_ptmass,fxyz_ptmass,xyzmh_ptmass,dsdt_pt real, intent(inout) :: vxyz_ptmass(3,nptmass), xyzmh_ptmass(nsinkproperties,nptmass) real, intent(in) :: fxyz_ptmass(4,nptmass) real, intent(in) :: dsdt_ptmass(3,nptmass) + integer :: i @@ -864,18 +865,7 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & if (mpt < 0.) cycle if (icreate_sinks==2) then if (hacc < h_acc ) cycle - if (tbirthi + tmax_acc < time) then - !$omp master - if (ipart_createstars == 0) ipart_createstars = i - !$omp end master - cycle - endif - if ((tbirthi + tseeds < time) .and. (linklist_ptmass(i) == 0) .and. & - (ipart_createseeds == 0)) then - !$omp master - ipart_createseeds = i - !$omp end master - endif + if (tbirthi + tmax_acc < time) cycle endif dx = xi - xyzmh_ptmass(1,i) dy = yi - xyzmh_ptmass(2,i) @@ -1823,6 +1813,28 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas end subroutine ptmass_create_stars +subroutine ptmass_check_stars(xyzmh_ptmass,linklist_ptmass,nptmass,time) + use part, only : itbirth + real, intent(in) :: time + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(:,:) + integer, intent(in) :: linklist_ptmass(:) + integer :: i + real :: tbirthi,hacci + do i=1,nptmass + hacci = xyzmh_ptmass(ihacc,i) + tbirthi = xyzmh_ptmass(itbirth,i) + if (hacci < h_acc ) cycle + if (tbirthi + tmax_acc < time) then + if (ipart_createstars == 0) ipart_createstars = i + endif + if ((tbirthi + tseeds < time) .and. (linklist_ptmass(i) == 0) .and. & + (ipart_createseeds == 0)) then + ipart_createseeds = i + endif + enddo +end subroutine ptmass_check_stars + !----------------------------------------------------------------------- !+ ! Merge sinks diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 954b7a9f4..b24f54318 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -434,7 +434,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & use part, only:fxyz_ptmass_sinksink,ndptmass use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent - use ptmass, only:use_fourthorder,use_regnbody,ck,dk + use ptmass, only:use_fourthorder,use_regnbody,ck,dk,ptmass_check_stars,icreate_sinks use subgroup, only:group_identify,evolve_groups integer, intent(in) :: npart,ntypes,nptmass integer, intent(inout) :: n_group,n_ingroup,n_sing @@ -574,6 +574,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & endif enddo substeps + if (icreate_sinks == 2) call ptmass_check_stars(xyzmh_ptmass,linklist_ptmass,nptmass,timei) + if (nsubsteps > 1) then if (iverbose >=1 .and. id==master) then write(iprint,"(a,i6,3(a,es10.3))") ' using ',nsubsteps,' substeps '//& From 272bd009b8317d8148825d0c14f4e54a832a1b6f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 2 Aug 2024 16:07:22 +0200 Subject: [PATCH 783/814] clean up after previous commit --- src/main/ptmass.F90 | 5 ++--- src/main/substepping.F90 | 17 ++++++++--------- src/tests/test_ptmass.f90 | 3 +-- 3 files changed, 11 insertions(+), 14 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 02bc2cb1d..8ce47eb07 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -821,7 +821,7 @@ end function ptmass_not_obscured !---------------------------------------------------------------- subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & itypei,pmassi,xyzmh_ptmass,vxyz_ptmass,accreted, & - dptmass,linklist_ptmass,time,facc,nbinmax,ibin_wakei,nfaili) + dptmass,time,facc,nbinmax,ibin_wakei,nfaili) !$ use omputils, only:ipart_omp_lock use part, only: ihacc,itbirth,ndptmass @@ -833,7 +833,6 @@ subroutine ptmass_accrete(is,nptmass,xi,yi,zi,hi,vxi,vyi,vzi,fxi,fyi,fzi, & real, intent(inout) :: hi real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(in) :: vxyz_ptmass(3,nptmass) - integer, intent(in) :: linklist_ptmass(nptmass) logical, intent(out) :: accreted real, intent(inout) :: dptmass(ndptmass,nptmass) integer(kind=1), intent(in) :: nbinmax @@ -1604,7 +1603,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote call ptmass_accrete(new_nptmass,new_nptmass,xyzh(1,j),xyzh(2,j),xyzh(3,j),xyzh(4,j),& vxyzu(1,j),vxyzu(2,j),vxyzu(3,j),fxj,fyj,fzj, & itypej,pmassj,xyzmh_ptmass,vxyz_ptmass,accreted, & - dptmass,linklist_ptmass,time,f_acc_local,ibin_wakei,ibin_wakei) + dptmass,time,f_acc_local,ibin_wakei,ibin_wakei) if (accreted) nacc = nacc + 1 enddo diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index b24f54318..9495292f4 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -485,7 +485,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! Main integration scheme ! call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & - fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_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, & @@ -512,7 +512,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & fsink_old,group_info=group_info,bin_info=bin_info) call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass) + fext,fxyz_ptmass,dsdt_ptmass,dptmass) call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,bin_info, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) @@ -527,7 +527,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,& fsink_old) call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass) + fext,fxyz_ptmass,dsdt_ptmass,dptmass) call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) @@ -538,7 +538,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & endif call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass,ibin_wake,nbinmax,timei, & + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei, & fxyz_ptmass_sinksink,accreted) if (use_regnbody) then @@ -553,7 +553,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & else !! standard leapfrog scheme ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass,ibin_wake,nbinmax,timei, & + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei, & fxyz_ptmass_sinksink,accreted) if (accreted) then call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & @@ -647,7 +647,7 @@ end subroutine drift !---------------------------------------------------------------- subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & - fext,fxyz_ptmass,dsdt_ptmass,dptmass,linklist_ptmass,ibin_wake, & + 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 ptmass, only:f_acc,ptmass_accrete,pt_write_sinkev,update_ptmass,ptmass_kick @@ -664,7 +664,6 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, real, intent(inout) :: vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) real, intent(inout) :: dptmass(ndptmass,nptmass) - integer, intent(in) :: linklist_ptmass(:) real, optional, intent(inout) :: fxyz_ptmass_sinksink(:,:) real, optional, intent(in) :: timei integer(kind=1), optional, intent(inout) :: ibin_wake(:) @@ -731,7 +730,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,linklist_ptmass,f_acc) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & !$omp shared(iexternalforce) & !$omp shared(nbinmax,ibin_wake) & !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & @@ -778,7 +777,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxi,fyi,fzi,& itype,pmassi,xyzmh_ptmass,vxyz_ptmass,accreted, & - dptmass,linklist_ptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) + dptmass,timei,f_acc,nbinmax,ibin_wakei,nfaili) if (accreted) then naccreted = naccreted + 1 cycle accreteloop diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 19de0ed9c..1317e3315 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -635,7 +635,6 @@ subroutine test_accretion(ntests,npass,itest) use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,massoftype, & npart,npartoftype,xyzh,vxyzu,fxyzu,igas,ihacc,& isdead_or_accreted,set_particle_type,ndptmass,hfact,& - linklist_ptmass use ptmass, only:ptmass_accrete,update_ptmass use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi @@ -715,7 +714,7 @@ subroutine test_accretion(ntests,npass,itest) call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxyzu(1,i),fxyzu(2,i),fxyzu(3,i), & igas,massoftype(igas),xyzmh_ptmass,vxyz_ptmass, & - accreted,dptmass_thread,linklist_ptmass,t,1.0,ibin_wakei,ibin_wakei) + accreted,dptmass_thread,t,1.0,ibin_wakei,ibin_wakei) endif enddo !$omp enddo From 1e62556616fbd9f3044a4ffe8060766b875b4993 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Sat, 3 Aug 2024 01:22:07 +0200 Subject: [PATCH 784/814] (subgroup) fix strange behaviors of group finding algo when new ptmass is created --- src/main/evolve.F90 | 3 ++- src/main/subgroup.f90 | 38 ++++++++++++++++++++++++++------------ 2 files changed, 28 insertions(+), 13 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index d3a4e4c89..bf500d306 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -318,7 +318,8 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! Need to recompute the force when sink or stars are created if (nptmass > nptmass_old .or. ipart_createseeds /= 0 .or. ipart_createstars /= 0) then if (use_regnbody) then - call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,nmatrix) + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,nmatrix,& + new_ptmass=.true.) 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,group_info=group_info,bin_info=bin_info) else diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index a59901ebb..591df817c 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -61,27 +61,33 @@ end subroutine init_subgroup ! !----------------------------------------------- subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass, & - group_info,bin_info,nmatrix,dtext) + group_info,bin_info,nmatrix,dtext,new_ptmass) use io, only:id,master,iverbose,iprint use timing, only:get_timings,increment_timer,itimer_sg_id - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - real, intent(inout) :: bin_info(:,:) - integer, intent(inout) :: group_info(4,nptmass) - integer, intent(inout) :: n_group,n_ingroup,n_sing - integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) - real, optional, intent(in) :: dtext + use part, only: igarg,igcum,igid + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(inout) :: bin_info(:,:) + integer, intent(inout) :: group_info(4,nptmass) + integer, intent(inout) :: n_group,n_ingroup,n_sing + integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) + logical, optional, intent(in) :: new_ptmass + real, optional, intent(in) :: dtext real(kind=4) :: t1,t2,tcpu1,tcpu2 - logical :: large_search + logical :: large_search,reset_nm large_search = present(dtext) + reset_nm = present(new_ptmass) n_group = 0 n_ingroup = 0 n_sing = 0 if (nptmass > 0) then call get_timings(t1,tcpu1) + group_info(:,:) = 0 + + if (reset_nm) nmatrix = 0 if (large_search) then call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) @@ -331,7 +337,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) real, intent(in) :: vxyz_ptmass(:,:) integer(kind=1), intent(out):: nmatrix(nptmass,nptmass) real, optional, intent(in) :: dtext - real :: xi,yi,zi,vxi,vyi,vzi,mi + real :: xi,yi,zi,vxi,vyi,vzi,mi,mj real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu real :: aij,eij,B,rperi,dtexti integer :: i,j @@ -348,7 +354,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) !$omp shared(nptmass,dtexti,nmatrix,r_neigh) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,r_search) & !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & - !$omp private(dx,dy,dz,r,r2) & + !$omp private(dx,dy,dz,r,r2,mj) & !$omp private(dvx,dvy,dvz,v2) & !$omp private(mu,aij,eij,B,rperi) do i=1,nptmass @@ -359,12 +365,20 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) vxi = vxyz_ptmass(1,i) vyi = vxyz_ptmass(2,i) vzi = vxyz_ptmass(3,i) - if (mi < 0 ) cycle + if (mi < 0 ) then + nmatrix(i,:) = 0 + cycle + endif do j=1,nptmass if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) + mj = xyzmh_ptmass(4,j) + if (mj < 0 ) then + nmatrix(i,j) = 0 + cycle + endif r2 = dx**2+dy**2+dz**2 r = sqrt(r2) if (r Date: Mon, 5 Aug 2024 08:55:03 +1000 Subject: [PATCH 785/814] (datafiles) update docs --- docs/developer-guide/datafiles.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/developer-guide/datafiles.rst b/docs/developer-guide/datafiles.rst index 5ceaa8f03..0dc469ac6 100644 --- a/docs/developer-guide/datafiles.rst +++ b/docs/developer-guide/datafiles.rst @@ -8,7 +8,7 @@ order for your modules to be portable. Small files ----------- -For *very small files* (under 1Mb), you can simply add these to the git +For *very small files* (under 100Kb), you can simply add these to the git repository in a subdirectory of the phantom/data directory: :: From 115c12c7720da583f44490b3d233d8c98bcf77a1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 5 Aug 2024 16:34:40 +0200 Subject: [PATCH 786/814] (subgroup) update the matrix construction routine that was crap.... --- src/main/evolve.F90 | 2 +- src/main/subgroup.f90 | 62 +++++++++++++++++++++------------------- src/main/substepping.F90 | 3 +- 3 files changed, 36 insertions(+), 31 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index bf500d306..093e869ec 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -319,7 +319,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (nptmass > nptmass_old .or. ipart_createseeds /= 0 .or. ipart_createstars /= 0) then 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.) + 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,group_info=group_info,bin_info=bin_info) else diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 591df817c..0649c8529 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -64,7 +64,6 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm group_info,bin_info,nmatrix,dtext,new_ptmass) use io, only:id,master,iverbose,iprint use timing, only:get_timings,increment_timer,itimer_sg_id - use part, only: igarg,igcum,igid integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(inout) :: bin_info(:,:) @@ -331,7 +330,7 @@ end subroutine dfs subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) - use utils_kepler, only: Espec,extract_a,extract_e,extract_ea + use utils_kepler, only: extract_a,extract_e,extract_ea integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(:,:) real, intent(in) :: vxyz_ptmass(:,:) @@ -339,7 +338,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) real, optional, intent(in) :: dtext real :: xi,yi,zi,vxi,vyi,vzi,mi,mj real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu - real :: aij,eij,B,rperi,dtexti + real :: aij,eij,rperi,dtexti integer :: i,j if (present(dtext)) then dtexti = dtext @@ -356,7 +355,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & !$omp private(dx,dy,dz,r,r2,mj) & !$omp private(dvx,dvy,dvz,v2) & - !$omp private(mu,aij,eij,B,rperi) + !$omp private(mu,aij,eij,rperi) do i=1,nptmass xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) @@ -365,8 +364,8 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) vxi = vxyz_ptmass(1,i) vyi = vxyz_ptmass(2,i) vzi = vxyz_ptmass(3,i) - if (mi < 0 ) then - nmatrix(i,:) = 0 + if (mi <= 0. ) then + nmatrix(i,:) = 0 ! killed point masses can't be in a group cycle endif do j=1,nptmass @@ -375,36 +374,41 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) mj = xyzmh_ptmass(4,j) - if (mj < 0 ) then - nmatrix(i,j) = 0 + if (mj <= 0. ) then + nmatrix(i,j) = 0 ! killed point masses can't be in a group cycle endif r2 = dx**2+dy**2+dz**2 r = sqrt(r2) - if (rr_search) then - nmatrix(i,j) = 0 - cycle - endif - mu = mi + xyzmh_ptmass(4,j) - dvx = vxi - vxyz_ptmass(1,j) - dvy = vyi - vxyz_ptmass(2,j) - dvz = vzi - vxyz_ptmass(3,j) - v2 = dvx**2+dvy**2+dvz**2 - call Espec(v2,r,mu,B) - call extract_a(r,mu,v2,aij) - if (B<0) then - if (aij0) then ! check if the system is bounded + if (aij Date: Tue, 6 Aug 2024 10:58:22 +1000 Subject: [PATCH 787/814] [header-bot] updated file headers --- src/main/inject_randomwind.f90 | 30 +++++++++++++----------------- src/main/metric_tools.f90 | 2 +- src/main/ptmass.F90 | 2 +- src/main/utils_gr.f90 | 2 +- src/setup/setup_asteroidwind.f90 | 2 +- 5 files changed, 17 insertions(+), 21 deletions(-) diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index 4570d778c..0830b37cd 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -12,27 +12,23 @@ module inject ! :References: ! Trevascus et al. (2021), MNRAS 505, L21-L25 ! -! :Owner: David Liptai +! :Owner: Shunquan Huang ! ! :Runtime parameters: -! - mdot_str : *mdot with unit* -! - wind_type : wind setup (0=asteroidwind, 1=randomwind) -! - mdot : *mass injection rate in grams/second* -! - mdot_type : *injection rate (0=const, 1=cos(t), 2=r^(-2))* -! - vlag : *percentage lag in velocity of wind* -! - random_type : random position on the surface, 0 for random, 1 for gaussian -! - delta_theta : standard deviation for the gaussion distribution (random_type=1) -! - theta : the inclination of the star or planet (random_type=1, -! if theta = 90, more particles are injected in z direction) -! - phi : the orientation of the star, (random_type=1, -! if theta=90 and phi=90 more particles are injected in x-z plane) -! - inject_pt : the partical that produce wind (when wind_type=1) -! - wind_speed_factor : factor to scale the wind speed based on the Keplerian speed at rinject (when wind_type=1) -! - wind_speed : wind speed -! - r_inject_str : rinject with unit (when wind_type=1) +! - delta_theta : *standard deviation for the gaussion distribution* +! - inject_pt : *the particle that excites wind (when wind_type=1)* +! - mdot : *mass injection rate with unit, e.g. 1e8*g/s, 1e-7M_s/yr* +! - mdot_type : *injection rate (0=const, 2=r^(-2))* +! - phi : *the tilt orientation of the star, (random_type=1)* +! - r_inject : *inject radius with units, e.g. 1*AU, 1e8m, (when wind_type=1)* +! - r_ref : *radius at whieh Mdot=mdot for 1/r^2 injection type* +! - random_type : *random position on the surface, 0 for random, 1 for gaussian* +! - theta : *the tilt inclination of the star or planet (random_type=1)* +! - vlag : *percentage lag in velocity of wind* +! - wind_type : *wind setup (0=asteroidwind, 1=randomwind)* ! ! :Dependencies: binaryutils, externalforces, infile_utils, io, options, -! part, partinject, physcon, random, units +! part, partinject, physcon, random, units, vectorutils ! use io, only:error use physcon, only:pi diff --git a/src/main/metric_tools.f90 b/src/main/metric_tools.f90 index b0cf56c3f..05b485fcb 100644 --- a/src/main/metric_tools.f90 +++ b/src/main/metric_tools.f90 @@ -19,7 +19,7 @@ module metric_tools ! ! :Runtime parameters: None ! -! :Dependencies: fastmath, inverse4x4, metric +! :Dependencies: inverse4x4, metric ! use metric, only:imetric implicit none diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 2f79f2738..505e32623 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -28,7 +28,7 @@ module ptmass ! - h_soft_sinkgas : *softening length for new sink particles* ! - h_soft_sinksink : *softening length between sink particles* ! - icreate_sinks : *allow automatic sink particle creation* -! - isink_potential : *sink potential(0=1/r,1=surf)* +! - isink_potential : *sink potential (0=1/r,1=surf)* ! - r_crit : *critical radius for point mass creation (no new sinks < r_crit from existing sink)* ! - r_merge_cond : *sinks will merge if bound within this radius* ! - r_merge_uncond : *sinks will unconditionally merge within this separation* diff --git a/src/main/utils_gr.f90 b/src/main/utils_gr.f90 index 1308aeef8..6ecc4be43 100644 --- a/src/main/utils_gr.f90 +++ b/src/main/utils_gr.f90 @@ -14,7 +14,7 @@ module utils_gr ! ! :Runtime parameters: None ! -! :Dependencies: fastmath, io, metric, metric_tools, part +! :Dependencies: io, metric, metric_tools, part ! implicit none diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index 717f596ae..6a34c93b4 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -25,7 +25,7 @@ module setup ! - mdot : *mass injection rate with unit, e.g. 1e8*g/s, 1e-7M_s/yr (from setup)* ! - norbits : *number of orbits* ! - npart_at_end : *number of particles injected after norbits* -! - rinject : *radius of asteroid (km)* +! - rinject : *radius of asteroid (km)* ! - semia : *semi-major axis (solar radii)* ! ! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, From d28ed996414cd47f64e9755ffca60cae263890f6 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 6 Aug 2024 10:58:50 +1000 Subject: [PATCH 788/814] [space-bot] whitespace at end of lines removed --- src/main/inject_randomwind.f90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index 0830b37cd..54c6f77b9 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -51,13 +51,13 @@ module inject real :: delta_theta = 0.5 ! standard deviation for the gaussion distribution (random_type=1) real :: have_injected = 0. real :: t_old = 0. - real :: r_ref = 1. ! reference radius for mdot_type=2 + real :: r_ref = 1. ! reference radius for mdot_type=2 real :: theta = 0. ! the inclination of the star or planet real :: phi = 0. ! the orientation of the star integer :: inject_pt = 2 ! the partical that produce wind (when wind_type=1) real :: wind_speed = 1.0 ! wind speed in code unit (when wind_type=1) real :: wind_speed_factor = 1.2 ! factor to scale the wind speed based on the Keplerian speed at rinject - !real :: rinject = 1.0 + !real :: rinject = 1.0 contains !----------------------------------------------------------------------- @@ -85,7 +85,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& use physcon, only:twopi,gg,kboltz,mass_proton_cgs use random, only:get_random_pos_on_sphere, get_gaussian_pos_on_sphere use units, only:in_code_units - use vectorutils, only:cross_product3D, rotatevec + use vectorutils, only:cross_product3D, rotatevec use options, only:iexternalforce use externalforces,only:mass1 use binaryutils, only:get_orbit_bits @@ -100,12 +100,12 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& real :: dmdt,rinject,h,u,speed,inject_this_step,m1,m2,r,dt real :: dx(3), vecz(3), veczprime(3), rotaxis(3) real :: theta_rad, phi_rad, cost, sint, cosp, sinp - + ! initialise some parameter to avoid warning... pt = 1 rinject = 1.0 r = 1.0 - + ! calculate the wind velocity and other quantities for different wind type select case (wind_type) case(1) ! set up random wind @@ -174,13 +174,13 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& sint = sin(theta_rad) cosp = cos(phi_rad) sinp = sin(phi_rad) - vecz = (/0.,0.,1./) + vecz = (/0.,0.,1./) veczprime = (/sint*cosp,sint*sinp,cost/) if (abs(theta_rad-0)<1e-6) then - rotaxis = (/0.,0.,1./) + rotaxis = (/0.,0.,1./) else call cross_product3D(vecz, veczprime, rotaxis) - endif + endif ! !-- Randomly inject particles around the body's outer 'radius'. ! @@ -278,7 +278,7 @@ subroutine write_options_inject(iunit) call write_inopt(inject_pt, 'inject_pt', 'the particle that excites wind (when wind_type=1)', iunit) call write_inopt(r_inject_str, 'r_inject', 'inject radius with units, e.g. 1*AU, 1e8m, (when wind_type=1)', iunit) endif - call write_inopt(wind_speed_factor, & + call write_inopt(wind_speed_factor, & & 'wind_speed_factor', 'factor to scale the wind speed based on the Keplerian speed at rinject', iunit) end subroutine write_options_inject From ef312b07edb206c0192114d23d9c782f2e7e705d Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 6 Aug 2024 10:58:50 +1000 Subject: [PATCH 789/814] [author-bot] updated AUTHORS file --- AUTHORS | 37 +++++++++++++++++++------------------ 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/AUTHORS b/AUTHORS index b3a77dfde..9f3013a96 100644 --- a/AUTHORS +++ b/AUTHORS @@ -26,8 +26,8 @@ Terrence Tricco Stephane Michoulier Simone Ceppi Spencer Magnall -Enrico Ragusa Caitlyn Hardiman +Enrico Ragusa Cristiano Longarini Sergei Biriukov Giovanni Dipierro @@ -38,38 +38,39 @@ Alison Young Stephen Nielson Martina Toscani Benedetta Veronesi -Simon Glover Sahl Rowther +Simon Glover Thomas Reichardt Jean-François Gonzalez -Christopher Russell Madeline Overton -Alex Pettitt -Phantom benchmark bot +Christopher Russell Jolien Malfait +Phantom benchmark bot Alessia Franchini -Nicole Rodrigues +Alex Pettitt Kieran Hirsh +Nicole Rodrigues Farzana Meru -David Trevascus Nicolás Cuello -Chris Nixon +David Trevascus Miguel Gonzalez-Bolivar -Maxime Lombart -Zachary Pellow -Orsola De Marco +Chris Nixon +Shunquan Huang Joe Fisher Benoit Commercon +Zachary Pellow Giulia Ballabio +Maxime Lombart +Orsola De Marco +Steven Rieder +Stéven Toupin +Taj Jankovič +Jeremy Smallwood +Ariel Chitan Rebecca Martin Jorge Cuadra -Hugh Griffiths -Jeremy Smallwood David Bamba +Shunquan Huang Cox, Samuel Chunliang Mu -Shunquan Huang -Steven Rieder -Stéven Toupin -Taj Jankovič -Ariel Chitan +Hugh Griffiths From 1bb03aeed5a614c791c16486d967d0541dba14aa Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 6 Aug 2024 10:59:32 +1000 Subject: [PATCH 790/814] [indent-bot] standardised indentation --- src/main/inject_randomwind.f90 | 76 +++++++++++++++++----------------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index 54c6f77b9..7c830098c 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -109,39 +109,39 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& ! calculate the wind velocity and other quantities for different wind type select case (wind_type) case(1) ! set up random wind - if (inject_pt > nptmass) call fatal('inject_randomwind', 'not enough point masses for inject target, check inject_pt') - r2 = xyzmh_ptmass(1:3,inject_pt) - rinject = in_code_units(r_inject_str, ierr) - v2 = vxyz_ptmass(1:3,pt) - wind_speed = wind_speed_factor*sqrt(xyzmh_ptmass(4, inject_pt)/rinject) - u = 0. ! setup is isothermal so utherm is not stored - h = hfact + if (inject_pt > nptmass) call fatal('inject_randomwind', 'not enough point masses for inject target, check inject_pt') + r2 = xyzmh_ptmass(1:3,inject_pt) + rinject = in_code_units(r_inject_str, ierr) + v2 = vxyz_ptmass(1:3,pt) + wind_speed = wind_speed_factor*sqrt(xyzmh_ptmass(4, inject_pt)/rinject) + u = 0. ! setup is isothermal so utherm is not stored + h = hfact case default ! set up asteroid wind - if (nptmass < 1 .and. iexternalforce == 0) & + if (nptmass < 1 .and. iexternalforce == 0) & call fatal('inject_asteroidwind','not enough point masses for asteroid wind injection') - if (nptmass > 2) & + if (nptmass > 2) & call fatal('inject_asteroidwind','too many point masses for asteroid wind injection') - if (nptmass == 2) then - pt = 2 - r1 = xyzmh_ptmass(1:3,1) - m1 = xyzmh_ptmass(4,1) - v1 = vxyz_ptmass(1:3,1) - else - pt = 1 - r1 = 0. - m1 = mass1 - v1 = 0. - endif - r2 = xyzmh_ptmass(1:3,pt) - rinject = xyzmh_ptmass(ihsoft,pt) - m2 = xyzmh_ptmass(4,pt) - v2 = vxyz_ptmass(1:3,pt) - speed = sqrt(dot_product(v2,v2)) - vhat = v2/speed - r = sqrt(dot_product(r1-r2,r1-r2)) - wind_speed = (1.-vlag/100)*speed - u = 0. ! setup is isothermal so utherm is not stored - h = hfact*(rinject/2.) + if (nptmass == 2) then + pt = 2 + r1 = xyzmh_ptmass(1:3,1) + m1 = xyzmh_ptmass(4,1) + v1 = vxyz_ptmass(1:3,1) + else + pt = 1 + r1 = 0. + m1 = mass1 + v1 = 0. + endif + r2 = xyzmh_ptmass(1:3,pt) + rinject = xyzmh_ptmass(ihsoft,pt) + m2 = xyzmh_ptmass(4,pt) + v2 = vxyz_ptmass(1:3,pt) + speed = sqrt(dot_product(v2,v2)) + vhat = v2/speed + r = sqrt(dot_product(r1-r2,r1-r2)) + wind_speed = (1.-vlag/100)*speed + u = 0. ! setup is isothermal so utherm is not stored + h = hfact*(rinject/2.) end select ! @@ -177,7 +177,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& vecz = (/0.,0.,1./) veczprime = (/sint*cosp,sint*sinp,cost/) if (abs(theta_rad-0)<1e-6) then - rotaxis = (/0.,0.,1./) + rotaxis = (/0.,0.,1./) else call cross_product3D(vecz, veczprime, rotaxis) endif @@ -187,13 +187,13 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& do i=1,npinject select case (wind_type) case (1) - dx = get_pos_on_sphere(seed, delta_theta) - call rotatevec(dx, rotaxis, theta_rad) - call cross_product3D(veczprime, dx, vhat) - vxyz = v2 + wind_speed*vhat + dx = get_pos_on_sphere(seed, delta_theta) + call rotatevec(dx, rotaxis, theta_rad) + call cross_product3D(veczprime, dx, vhat) + vxyz = v2 + wind_speed*vhat case default - xyz = r2 + rinject*get_pos_on_sphere(seed, delta_theta) - vxyz = wind_speed*vhat + xyz = r2 + rinject*get_pos_on_sphere(seed, delta_theta) + vxyz = wind_speed*vhat end select ipart = npart + 1 call add_or_update_particle(igas,xyz,vxyz,h,u,ipart,npart,npartoftype,xyzh,vxyzu) @@ -279,7 +279,7 @@ subroutine write_options_inject(iunit) call write_inopt(r_inject_str, 'r_inject', 'inject radius with units, e.g. 1*AU, 1e8m, (when wind_type=1)', iunit) endif call write_inopt(wind_speed_factor, & - & 'wind_speed_factor', 'factor to scale the wind speed based on the Keplerian speed at rinject', iunit) + & 'wind_speed_factor', 'factor to scale the wind speed based on the Keplerian speed at rinject', iunit) end subroutine write_options_inject From 0224d430ae720df80081147bca174d717d61de34 Mon Sep 17 00:00:00 2001 From: Ana Lourdes Juarez Date: Tue, 6 Aug 2024 17:06:51 +1000 Subject: [PATCH 791/814] Delete cases to write_options_eos --- src/main/eos.f90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 5426c7e8a..10f619129 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -1444,8 +1444,6 @@ subroutine write_options_eos(iunit) endif select case(ieos) - case(2) - call write_inopt(gamma,'gamma','Adiabatic index',iunit) case(8) call write_options_eos_barotropic(iunit) case(9) @@ -1453,8 +1451,6 @@ subroutine write_options_eos(iunit) case(10) call write_inopt(X_in,'X','hydrogen mass fraction',iunit) call write_inopt(Z_in,'Z','metallicity',iunit) - case(12) - call write_inopt(gamma,'gamma','Adiabatic index',iunit) case(15) ! helmholtz eos call eos_helmholtz_write_inopt(iunit) case(20) From aa079db3809233f728755d3f9ccf8f13b067aa94 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 8 Aug 2024 17:45:22 +1000 Subject: [PATCH 792/814] Update analysis.rst [skip ci] --- docs/user-guide/analysis.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/user-guide/analysis.rst b/docs/user-guide/analysis.rst index 9e5729a26..2c29b7e67 100644 --- a/docs/user-guide/analysis.rst +++ b/docs/user-guide/analysis.rst @@ -7,7 +7,7 @@ Visualisation of Phantom output Dump files ~~~~~~~~~~ -That's what `splash `_ is for! Use splash to interactively inspect the dump +That's what `splash `_ is for! Use splash to interactively inspect the dump files produced by phantom, e.g.: .. code-block:: bash From d862dc58f98055589f7c4925ed5bee080ff1c753 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 8 Aug 2024 17:47:00 +1000 Subject: [PATCH 793/814] Update dumpfile.rst [skip ci] --- docs/user-guide/dumpfile.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/user-guide/dumpfile.rst b/docs/user-guide/dumpfile.rst index 44ac8a9bb..70f916b7f 100644 --- a/docs/user-guide/dumpfile.rst +++ b/docs/user-guide/dumpfile.rst @@ -11,10 +11,10 @@ splash ~~~~~~ For SPH simulations the raw data is not so useful since to visualise fields in a smooth manner one needs to use the SPH kernel. This is the -purpose of `splash `_, to enable you to produce smooth plots and visualisations +purpose of `splash `_, to enable you to produce smooth plots and visualisations from the code. It reads the raw data files and gives you plots and visualisations:: - splash file_00000 -r 6 + splash file_00000 -r 6 --movie sarracen ~~~~~~~~ From 2498935ea579122cb246cb4abd72e35ec0ee464a Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 8 Aug 2024 17:51:16 +1000 Subject: [PATCH 794/814] Create splash.rst [skip ci] --- docs/external-utilities/splash.rst | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 docs/external-utilities/splash.rst diff --git a/docs/external-utilities/splash.rst b/docs/external-utilities/splash.rst new file mode 100644 index 000000000..2d5a8ff17 --- /dev/null +++ b/docs/external-utilities/splash.rst @@ -0,0 +1,25 @@ +Splash +====== + +Splash is a free and open source visualisation tool for SPH data, developed closely alongside Phantom. + +- Docs: https://splash-viz.readthedocs.io/ +- Repo: https://github.com/danieljprice/splash + +Examples +-------- + +:: + splash -r density dump_0* + +Plots column density render of all snapshots from a simulation + +:: + splash -r density dump_0* --movie + +Make an mp4 movie of the above + +:: + splash *.ev + +Plot energy vs time files, including automatic recognition of column labels From acc832d89317066590e502d59c5ae4e6b8a0cdb9 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 8 Aug 2024 17:51:39 +1000 Subject: [PATCH 795/814] Update index.rst [skip ci] --- docs/external-utilities/index.rst | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/external-utilities/index.rst b/docs/external-utilities/index.rst index 765df897e..8dd463312 100644 --- a/docs/external-utilities/index.rst +++ b/docs/external-utilities/index.rst @@ -6,6 +6,7 @@ There are several external utilities that are useful with Phantom. .. toctree:: :maxdepth: 1 + splash sarracen mcfost phantom-config From 3dde5e822d28ceccfa42bbfde306ed5ead689636 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 8 Aug 2024 15:22:57 +0200 Subject: [PATCH 796/814] (ptmass) resolve momentum conservation error... --- src/main/ptmass.F90 | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 8ce47eb07..de2906d8b 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1717,6 +1717,8 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas vi(1) = vxyz_ptmass(1,itest) vi(2) = vxyz_ptmass(2,itest) vi(3) = vxyz_ptmass(3,itest) + vcom = 0. + xcom = 0. write(iprint,"(a,es18.10,a,es18.10)") "ptmass_create_stars : new stars formed at : ",time,"Mass : ",mi @@ -1785,12 +1787,12 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas enddo k = itest do while(k>0) - xcom(1) = xyzmh_ptmass(4,k)*xyzmh_ptmass(1,k) - xcom(2) = xyzmh_ptmass(4,k)*xyzmh_ptmass(2,k) - xcom(3) = xyzmh_ptmass(4,k)*xyzmh_ptmass(3,k) - vcom(1) = xyzmh_ptmass(4,k)*vxyz_ptmass(1,k) - vcom(2) = xyzmh_ptmass(4,k)*vxyz_ptmass(2,k) - vcom(3) = xyzmh_ptmass(4,k)*vxyz_ptmass(3,k) + xcom(1) = xcom(1) + xyzmh_ptmass(4,k) * xyzmh_ptmass(1,k) + xcom(2) = xcom(2) + xyzmh_ptmass(4,k) * xyzmh_ptmass(2,k) + xcom(3) = xcom(3) + xyzmh_ptmass(4,k) * xyzmh_ptmass(3,k) + vcom(1) = vcom(1) + xyzmh_ptmass(4,k) * vxyz_ptmass(1,k) + vcom(2) = vcom(2) + xyzmh_ptmass(4,k) * vxyz_ptmass(2,k) + vcom(3) = vcom(3) + xyzmh_ptmass(4,k) * vxyz_ptmass(3,k) k = linklist_ptmass(k) ! acces to the next point mass in the linked list enddo From ce3bffb8a9266b9218d90edb8a299e5986b30213 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 8 Aug 2024 16:17:07 +0200 Subject: [PATCH 797/814] update mailmap --- .mailmap | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.mailmap b/.mailmap index eab7608f0..0064720ab 100644 --- a/.mailmap +++ b/.mailmap @@ -123,5 +123,5 @@ Nicolás Cuello Nicolas Cuello rebeccagmartin <74937128+rebeccagmartin@users.noreply.github.com> Stephen Nielson s-neilson <36410751+s-neilson@users.noreply.github.com> Stephen Nielson Stephen Neilson <36410751+s-neilson@users.noreply.github.com> -Yann Bernard Yrisch +Yann Bernard Yrisch David Bamba DavidBamba From d2921ab6f7fcc188f0f7849dce75a9ebc7e507df Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 8 Aug 2024 16:55:07 +0200 Subject: [PATCH 798/814] Add few header comments... --- src/main/ptmass.F90 | 16 ++++- src/main/subgroup.f90 | 136 ++++++++++++++++++++++++++++++++++++------ 2 files changed, 131 insertions(+), 21 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 4f6448977..e53753dff 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1654,7 +1654,7 @@ end subroutine ptmass_create !------------------------------------------------------------------------- !+ -! subroutine to create a bundh of star "seeds" inside a sink particle +! subroutine to create a bunch of star "seeds" inside a sink particle !+ !------------------------------------------------------------------------- subroutine ptmass_create_seeds(nptmass,itest,xyzmh_ptmass,linklist_ptmass,time) @@ -1695,7 +1695,7 @@ end subroutine ptmass_create_seeds !------------------------------------------------------------------------- !+ -! subroutine to create a bundh of stars inside a sink particle +! subroutine to create a bunch of stars inside a sink (core) particle !+ !------------------------------------------------------------------------- subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,& @@ -1743,8 +1743,10 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas k=itest + ! + !-- Position and velocity sampling using Plummer methods + ! do while(k>0) - !! Position and velocity sampling methods a(:) = 0. rvir = 0.7*h_acc mcutoff = 0.55 @@ -1796,6 +1798,9 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas k = linklist_ptmass(k) ! acces to the next point mass in the linked list n = n - 1 enddo + ! + !-- Center the system on CoM and add bulk motion from the parental sink + ! k = itest do while(k>0) xcom(1) = xcom(1) + xyzmh_ptmass(4,k) * xyzmh_ptmass(1,k) @@ -1825,6 +1830,11 @@ subroutine ptmass_create_stars(nptmass,itest,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmas end subroutine ptmass_create_stars +!------------------------------------------------------------------------- +!+ +! subroutine to check if a core needs to create seeds or stars +!+ +!------------------------------------------------------------------------- subroutine ptmass_check_stars(xyzmh_ptmass,linklist_ptmass,nptmass,time) use part, only : itbirth real, intent(in) :: time diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 6a4cfc696..97c1fb214 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -6,10 +6,13 @@ !--------------------------------------------------------------------------! module subgroup ! -! this module contains everything to identify -! and integrate regularized groups... +! This module contains everything to identify and integrate regularized groups. +! TTL (Mikkola and Aarseth 2002) is used to regularize this subgroups. Indentification is done +! using a fixed searching radius and few arguments on bounding systems (see Rantala et al. 2023) +! Slow down method is now directly implemented in the integration. Kappa is computed using Mikkola +! Aarseth (1996) criterion... ! -! :References: Makkino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 +! :References: Mikkola et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 ! ! :Owner: Yann Bernard ! @@ -57,7 +60,7 @@ end subroutine init_subgroup !----------------------------------------------- ! -! Group identification routines +! Group identification routines (Subgroups + binary orbital parameters) ! !----------------------------------------------- subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass, & @@ -111,6 +114,11 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm end subroutine group_identify +!------------------------------------------------------------------ +! +! routine to find binary properties in multiple and binary systems +! +!------------------------------------------------------------------ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) use part, only: igarg,igcum,icomp,isemi,iecc,iapo,iorb real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) @@ -156,6 +164,11 @@ subroutine find_binaries(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,n_group) end subroutine find_binaries +!-------------------------------------------------------------------------- +! +! specialized routine to find orbital parameters of binaries in multiples +! +!-------------------------------------------------------------------------- subroutine binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsize,start_id,end_id) use part, only: igarg,icomp,isemi,iecc,iapo,iorb real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) @@ -204,6 +217,11 @@ subroutine binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gs end subroutine binaries_in_multiples +!-------------------------------------------- +! +! routine to find common nearest neighbours +! +!-------------------------------------------- subroutine get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) use part, only : igarg,igcum real , intent(in) :: xyzmh_ptmass(:,:) @@ -234,6 +252,11 @@ subroutine get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) end subroutine get_r2min +!---------------------------------------------------------- +! +! routine to extract main orbital parameters needed for SD +! +!---------------------------------------------------------- subroutine get_orbparams(xyzmh_ptmass,vxyz_ptmass,aij,eij,apoij,Tij,i,j) use utils_kepler, only: extract_e,extract_a,extract_T real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) @@ -241,13 +264,14 @@ subroutine get_orbparams(xyzmh_ptmass,vxyz_ptmass,aij,eij,apoij,Tij,i,j) integer, intent(in) :: i,j real :: dv(3),dr(3),mu,r,v2 - dv(1) = vxyz_ptmass(1,j)-vxyz_ptmass(1,i) - dv(2) = vxyz_ptmass(2,j)-vxyz_ptmass(2,i) - dv(3) = vxyz_ptmass(3,j)-vxyz_ptmass(3,i) - dr(1) = xyzmh_ptmass(1,j)-xyzmh_ptmass(1,i) - dr(2) = xyzmh_ptmass(2,j)-xyzmh_ptmass(2,i) - dr(3) = xyzmh_ptmass(3,j)-xyzmh_ptmass(3,i) - mu = xyzmh_ptmass(4,i) + xyzmh_ptmass(4,j) + dv(1) = vxyz_ptmass(1,j) - vxyz_ptmass(1,i) + dv(2) = vxyz_ptmass(2,j) - vxyz_ptmass(2,i) + dv(3) = vxyz_ptmass(3,j) - vxyz_ptmass(3,i) + dr(1) = xyzmh_ptmass(1,j) - xyzmh_ptmass(1,i) + dr(2) = xyzmh_ptmass(2,j) - xyzmh_ptmass(2,i) + dr(3) = xyzmh_ptmass(3,j) - xyzmh_ptmass(3,i) + mu = xyzmh_ptmass(4,i) + xyzmh_ptmass(4,j) + r = sqrt(dr(1)**2+dr(2)**2+dr(3)**2) v2 = dv(1)**2+dv(2)**2+dv(3)**2 @@ -261,7 +285,11 @@ subroutine get_orbparams(xyzmh_ptmass,vxyz_ptmass,aij,eij,apoij,Tij,i,j) end subroutine get_orbparams - +!-------------------------------------------------------------------------- +! +! interface routine to read the adjacency matrix to identify groups member +! +!-------------------------------------------------------------------------- subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) use part, only : igarg,igcum,igid,icomp integer, intent(in) :: nptmass @@ -290,6 +318,11 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) enddo end subroutine form_group +!-------------------------------------------------------------------------- +! +! simple deep first search algorithm to form subgroups of point masses +! +!-------------------------------------------------------------------------- subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) use part, only : igarg,igid,icomp integer, intent(in) :: nptmass,iroot @@ -328,7 +361,11 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) enddo end subroutine dfs - +!------------------------------------------------------------------------------------------ +! +! Adjacency matrix construction routine using fixed searching radius (Rantala et al. 2023) +! +!------------------------------------------------------------------------------------------ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass,dtext) use utils_kepler, only: extract_a,extract_e,extract_ea integer, intent(in) :: nptmass @@ -417,10 +454,9 @@ end subroutine matrix_construction !--------------------------------------------- ! -! Routines needed to integrate subgroups +! Interface routine to integrate subgroups ! !--------------------------------------------- - subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,bin_info, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) use part, only:igarg,igcum @@ -469,6 +505,12 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,bin_info, & end subroutine evolve_groups +!------------------------------------------------------------------------------------ +! +! Main integration routine to evolve subgroups, containing Kick and Drift routines +! and time synchronisation algorithm. cf : Wang et al. (2020) +! +!------------------------------------------------------------------------------------ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,& bin_info,group_info,fxyz_ptmass,gtgrad) use part, only: igarg,ikap,iorb @@ -699,6 +741,11 @@ subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tco end subroutine restore_state +!--------------------------------------- +! +! TTL Drift routine for multiples only. +! +!--------------------------------------- subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsize,s_id,e_id) use part, only: igarg,icomp,ikap use io, only: fatal @@ -753,6 +800,11 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsi end subroutine drift_TTL +!--------------------------------------- +! +! TTL Kick routine for multiples only. +! +!--------------------------------------- subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,s_id,e_id) use part, only: igarg,ikap use io, only: fatal @@ -813,6 +865,11 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass end subroutine kick_TTL +!-------------------------------------------------------------------------- +! +! Compressed and optimized Drift-Kick routine for binaries (group size = 2) +! +!-------------------------------------------------------------------------- subroutine oneStep_bin(tcoord,W,ds,kappa1,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,i,j) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:),time_table(:) real, intent(in) :: ds,kappa1 @@ -887,6 +944,13 @@ subroutine oneStep_bin(tcoord,W,ds,kappa1,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,g end subroutine oneStep_bin +!------------------------------------------------------------------ +! +! SD method alters binary intrinsec motion but conserve CoM motion. +! this routine will update the position of binaries by slowing down +! the internal motion but correct the CoM drift operation... +! +!------------------------------------------------------------------ subroutine correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,dtd,i,j) real, intent(inout) :: xyzmh_ptmass(:,:) real, intent(in) :: vxyz_ptmass(:,:),vcom(3) @@ -915,7 +979,13 @@ subroutine correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,dtd,i,j) end subroutine correct_com_drift - +!--------------------------------------- +! +! TTL Force routine for multiples only. +! Potential and initial time step are +! computed here as well. +! +!--------------------------------------- subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id,potonly,ds_init) use part, only: igarg,iorb,ikap,icomp use io, only: fatal @@ -1019,6 +1089,12 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, end subroutine get_force_TTL +!-------------------------------------------------------- +! +! routine that compute the slowing down factor depending +! on outside pertubartions for multiples only +! +!-------------------------------------------------------- subroutine get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) use part, only:igarg,icomp,ipert,ikap,iapo,iecc,isemi real , intent(in) :: xyzmh_ptmass(:,:) @@ -1083,6 +1159,14 @@ subroutine get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) end subroutine get_kappa + +!--------------------------------------- +! +! TTL Force routine for binaries only. +! Potential and initial time step are +! computed here as well. +! +!--------------------------------------- subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,potonly,ds_init,Tij) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) @@ -1149,6 +1233,13 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,poton end subroutine get_force_TTL_bin + +!-------------------------------------------------------- +! +! routine that compute the slowing down factor depending +! on outside pertubartions for binaries only +! +!-------------------------------------------------------- subroutine get_kappa_bin(xyzmh_ptmass,bin_info,i,j) use part, only:ipert,iapo,ikap,isemi,iecc real, intent(inout) :: bin_info(:,:) @@ -1176,7 +1267,12 @@ subroutine get_kappa_bin(xyzmh_ptmass,bin_info,i,j) end subroutine get_kappa_bin - +!-------------------------------------------------------- +! +! interface routine that update the slowing down factor +! for each subgroups in the simulation +! +!-------------------------------------------------------- subroutine update_kappa(xyzmh_ptmass,bin_info,group_info,n_group) use part, only:igcum,igarg real, intent(in) :: xyzmh_ptmass(:,:) @@ -1199,7 +1295,11 @@ subroutine update_kappa(xyzmh_ptmass,bin_info,group_info,n_group) enddo end subroutine update_kappa - +!-------------------------------------------------------- +! +! Routine to compute potential energy in subgroups +! +!-------------------------------------------------------- subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) use part, only: igarg,igcum,ikap use io, only: id,master,fatal From 5cb3e5a44837f8073dbf7596daf167956356bef2 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 8 Aug 2024 17:09:29 +0200 Subject: [PATCH 799/814] [tab-bot] tabs removed --- AUTHORS | 38 +++++++++++++++--------------- src/main/inject_randomwind.f90 | 2 +- src/setup/set_binary.f90 | 2 +- src/setup/setup_masstransfer.f90 | 40 ++++++++++++++------------------ src/utils/struct_part.f90 | 8 +++---- 5 files changed, 42 insertions(+), 48 deletions(-) diff --git a/AUTHORS b/AUTHORS index 08f9c3b98..b1dd08d0b 100644 --- a/AUTHORS +++ b/AUTHORS @@ -12,9 +12,8 @@ James Wurster David Liptai Lionel Siess Fangyi (Fitz) Hu -Yann BERNARD +Yann Bernard Daniel Mentiplay -Yann Bernard Megha Sharma Arnaud Vericel Mark Hutchison @@ -43,35 +42,36 @@ Sahl Rowther Simon Glover Thomas Reichardt Jean-François Gonzalez -Madeline Overton Christopher Russell -Jolien Malfait -Phantom benchmark bot +Madeline Overton Alessia Franchini Alex Pettitt +Jolien Malfait +Phantom benchmark bot Kieran Hirsh Nicole Rodrigues +Ana Lourdes Juarez +David Trevascus Farzana Meru Nicolás Cuello -David Trevascus -Miguel Gonzalez-Bolivar Chris Nixon -Shunquan Huang -Joe Fisher +Miguel Gonzalez-Bolivar Benoit Commercon -Zachary Pellow Giulia Ballabio +Joe Fisher Maxime Lombart Orsola De Marco -Steven Rieder -Stéven Toupin -Taj Jankovič -Jeremy Smallwood +Shunquan Huang +Zachary Pellow Ariel Chitan -Rebecca Martin -Jorge Cuadra -David Bamba -Shunquan Huang -Cox, Samuel Chunliang Mu +Cox, Samuel +David Bamba Hugh Griffiths +Jeremy Smallwood +Jorge Cuadra +Rebecca Martin +Shunquan Huang +Steven Rieder +Stéven Toupin +Taj Jankovič diff --git a/src/main/inject_randomwind.f90 b/src/main/inject_randomwind.f90 index 7c830098c..cb8abf630 100644 --- a/src/main/inject_randomwind.f90 +++ b/src/main/inject_randomwind.f90 @@ -12,7 +12,7 @@ module inject ! :References: ! Trevascus et al. (2021), MNRAS 505, L21-L25 ! -! :Owner: Shunquan Huang +! :Owner: Daniel Price ! ! :Runtime parameters: ! - delta_theta : *standard deviation for the gaussion distribution* diff --git a/src/setup/set_binary.f90 b/src/setup/set_binary.f90 index fa05d3c78..d5ae33da4 100644 --- a/src/setup/set_binary.f90 +++ b/src/setup/set_binary.f90 @@ -413,7 +413,7 @@ function get_period_from_a(m1,m2,a) result(period) real, intent(in) :: m1,m2,a real :: period -period= sqrt(((2.*pi)**2*a**3)/(m1 + m2)) + period= sqrt(((2.*pi)**2*a**3)/(m1 + m2)) end function get_period_from_a diff --git a/src/setup/setup_masstransfer.f90 b/src/setup/setup_masstransfer.f90 index 43cc861a8..15bf86aed 100644 --- a/src/setup/setup_masstransfer.f90 +++ b/src/setup/setup_masstransfer.f90 @@ -10,24 +10,18 @@ module setup ! ! :References: None ! -! :Owner: Daniel Price +! :Owner: Ana Lourdes Juarez ! ! :Runtime parameters: -! - a : *semi-major axis* -! - mdon : *donor/primary star mass* -! - macc : *accretor/companion star mass* -! - corotate : *set stars in corotation* -! - eccentricity : *eccentricity* -! - f : *initial true anomaly (180=apoastron)* -! - inc : *inclination (deg)* -! - relax : *relax stars into equilibrium* -! - w : *argument of periapsis (deg)* +! - a : *semi-major axis* +! - hacc : *accretion radius of the companion star* +! - macc : *mass of the companion star* +! - mdon : *mass of the donor star* ! -! :Dependencies: centreofmass, dim, eos, externalforces, infile_utils, io, -! mpidomain, options, part, physcon, relaxstar, setbinary, setstar, -! setunits, setup_params, units +! :Dependencies: centreofmass, eos, extern_corotate, externalforces, +! infile_utils, io, options, part, setbinary, setunits, timestep ! - + implicit none public :: setpart real :: a,mdon,macc,hacc @@ -45,7 +39,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& polyk,gamma,hfact,time,fileprefix) use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc use setbinary, only:set_binary,get_period_from_a -use centreofmass, only:reset_centreofmass + use centreofmass, only:reset_centreofmass use options, only:iexternalforce use externalforces, only:iext_corotate,omega_corotate use extern_corotate, only:icompanion_grav,companion_xpos,companion_mass,hsoft @@ -113,7 +107,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& ! !--if a is negative or is given time units, interpret this as a period ! - + period = get_period_from_a(mdon,macc,a) tmax = 10.*period dtmax = tmax/200. @@ -125,24 +119,24 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& call reset_centreofmass(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) - + if (ierr /= 0) call fatal ('setup_binary','error in call to set_binary') - + companion_mass = mdon companion_xpos = xyzmh_ptmass(1,1) mass_ratio = mdon / macc hsoft = 0.1 * 0.49 * mass_ratio**(2./3.) / (0.6*mass_ratio**(2./3.) + & log( 1. + mass_ratio**(1./3.) ) ) * a ! - !--delete donor sink + !--delete donor sink ! nptmass=1 xyzmh_ptmass(:,1) = xyzmh_ptmass(:,2) vxyz_ptmass(1:3,1) = 0. - + !--restore options ! - + end subroutine setpart @@ -193,7 +187,7 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) type(inopts), allocatable :: db(:) nerr = 0 - ierr = 0 + ierr = 0 call open_db_from_file(db,filename,iunit,ierr) call read_options_and_set_units(db,nerr) @@ -205,7 +199,7 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) call read_inopt(hacc,'hacc',db,errcount=nerr) call close_db(db) - if (nerr > 0) then + if (nerr > 0) then print "(1x,i2,a)",nerr,' error(s) during read of setup file: re-writing...' ierr = nerr endif diff --git a/src/utils/struct_part.f90 b/src/utils/struct_part.f90 index 781a3c2fd..99640148d 100644 --- a/src/utils/struct_part.f90 +++ b/src/utils/struct_part.f90 @@ -149,10 +149,10 @@ subroutine get_structure_fn(sf,nbins,norder,distmin,distmax,xbins,ncount,npart,x !$omp reduction(+:sf) do ipt=1,npts !$ if (.false.) then - if (mod(ipt,100)==0) then - call cpu_time(tcpu2) - print*,' ipt = ',ipt,tcpu2-tcpu1 - endif + if (mod(ipt,100)==0) then + call cpu_time(tcpu2) + print*,' ipt = ',ipt,tcpu2-tcpu1 + endif !$ endif i = list(ipt) xpt(1) = xyz(1,i) From 9207cf91ce9dbd5f4c90292686eec4ba43248404 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 8 Aug 2024 17:10:23 +0200 Subject: [PATCH 800/814] [header-bot] updated file headers --- src/main/cons2prim.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 56878217a..d3a6a507e 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: Elisabeth Borchert +! :Owner: Daniel Price ! ! :Runtime parameters: None ! From 5dc8e8ee83268e330abd366351ca382caaecd7d5 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 8 Aug 2024 17:32:58 +0200 Subject: [PATCH 801/814] (test_ptmass) remove missed coma... --- src/tests/test_ptmass.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 1317e3315..1d6549a92 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -634,7 +634,7 @@ subroutine test_accretion(ntests,npass,itest) use io, only:id,master use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,massoftype, & npart,npartoftype,xyzh,vxyzu,fxyzu,igas,ihacc,& - isdead_or_accreted,set_particle_type,ndptmass,hfact,& + isdead_or_accreted,set_particle_type,ndptmass,hfact use ptmass, only:ptmass_accrete,update_ptmass use energies, only:compute_energies,angtot,etot,totmom use mpiutils, only:bcast_mpi,reduce_in_place_mpi From 7441516f6c2b91d54e0e03e52e9011d540d80158 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 9 Aug 2024 08:51:58 +1000 Subject: [PATCH 802/814] Update splash.rst [skip ci] --- docs/external-utilities/splash.rst | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/docs/external-utilities/splash.rst b/docs/external-utilities/splash.rst index 2d5a8ff17..9960759fa 100644 --- a/docs/external-utilities/splash.rst +++ b/docs/external-utilities/splash.rst @@ -9,17 +9,20 @@ Splash is a free and open source visualisation tool for SPH data, developed clos Examples -------- -:: +Plot column density render of all snapshots from a simulation: + splash -r density dump_0* -Plots column density render of all snapshots from a simulation +Make an mp4 movie of the above, like so: -:: splash -r density dump_0* --movie -Make an mp4 movie of the above +which produces something like: + + https://zenodo.org/records/11438154/files/Priceetal24_figure1_logdensity_schwarzschild_4m_adiabatic.mp4 + +splash can also be used to plot the energy vs time files: -:: - splash *.ev + splash *.ev -Plot energy vs time files, including automatic recognition of column labels +including automatic recognition of column labels From 60ec4694b716e2fee3292abe2d93f93146d2d601 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 9 Aug 2024 09:00:11 +1000 Subject: [PATCH 803/814] Update splash.rst [skip ci] --- docs/external-utilities/splash.rst | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/docs/external-utilities/splash.rst b/docs/external-utilities/splash.rst index 9960759fa..ba16857e3 100644 --- a/docs/external-utilities/splash.rst +++ b/docs/external-utilities/splash.rst @@ -9,19 +9,23 @@ Splash is a free and open source visualisation tool for SPH data, developed clos Examples -------- -Plot column density render of all snapshots from a simulation: +Plot column density render of all snapshots from a simulation:: splash -r density dump_0* -Make an mp4 movie of the above, like so: +Make an mp4 movie of the above, like so:: splash -r density dump_0* --movie -which produces something like: +which produces something like - https://zenodo.org/records/11438154/files/Priceetal24_figure1_logdensity_schwarzschild_4m_adiabatic.mp4 +.. raw:: html -splash can also be used to plot the energy vs time files: +
          + +
          + +splash can also be used to plot the energy vs time files:: splash *.ev From 915923c1d9f293d25106d016253fa3420527b004 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 9 Aug 2024 10:10:59 +0200 Subject: [PATCH 804/814] (substep) bin_info needs a reduction in get force which was impossible with optional argument --- src/main/evolve.F90 | 4 ++-- src/main/ptmass.F90 | 7 ++++--- src/main/substepping.F90 | 29 ++++++++++++++++------------- 3 files changed, 22 insertions(+), 18 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 093e869ec..fb7c5cc8d 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -321,10 +321,10 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) 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,group_info=group_info,bin_info=bin_info) + 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) + fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,bin_info) endif if (ipart_createseeds /= 0) ipart_createseeds = 0 ! reset pointer to zero if (ipart_createstars /= 0) ipart_createstars = 0 ! reset pointer to zero diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index e53753dff..188c56d2f 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -303,9 +303,10 @@ 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 .and. abs(bin_info(isemi,j))>tiny(f2)) then - ! add perturbation for - bin_info(ipert,j) = bin_info(ipert,j) + f2 + if (kappa) then + if(abs(bin_info(isemi,j))>tiny(f2)) then + bin_info(ipert,j) = bin_info(ipert,j) + f2 + endif endif endif enddo diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 97a32f5ff..b6eda445a 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -494,13 +494,14 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & 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,& - group_info=group_info,bin_info=bin_info) + 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,isionised=isionised) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,& + bin_info,isionised=isionised) endif if (use_fourthorder) then !! FSI 4th order scheme @@ -509,7 +510,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & 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, & - fsink_old,group_info=group_info,bin_info=bin_info) + 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) @@ -521,11 +522,11 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass, & - group_info=group_info,bin_info=bin_info,isionised=isionised) + 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,& - fsink_old) + bin_info,fsink_old) call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& fext,fxyz_ptmass,dsdt_ptmass,dptmass) @@ -533,7 +534,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass,& - isionised=isionised) + bin_info,isionised=isionised) ! the last kick phase of the scheme will perform the accretion loop after velocity update endif @@ -546,10 +547,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, & - group_info=group_info,bin_info=bin_info) + bin_info,group_info=group_info) elseif (accreted) then call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,linklist_ptmass,& + bin_info) endif else !! standard leapfrog scheme ! the last kick phase of the scheme will perform the accretion loop after velocity update @@ -558,7 +560,8 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & fxyz_ptmass_sinksink,accreted) 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) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,linklist_ptmass,& + bin_info) endif endif @@ -840,8 +843,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,fsink_old,group_info,& - bin_info,isionised) + 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 ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & @@ -865,9 +868,9 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real, intent(inout) :: dtextforce real, intent(in) :: timei,dki,dt logical, intent(in) :: extf_vdep_flag + real, intent(inout) :: bin_info(:,:) real, optional, intent(inout) :: fsink_old(4,nptmass) integer, optional, intent(in) :: group_info(:,:) - real, optional, intent(inout) :: bin_info(:,:) logical, optional, intent(in) :: isionised(:) integer :: merge_ij(nptmass) integer :: merge_n From 916d6207ba99c58bce5426a8b46ec65d06cc9f1d Mon Sep 17 00:00:00 2001 From: Christopher Russell Date: Mon, 12 Aug 2024 10:42:12 -0400 Subject: [PATCH 805/814] update to exact integration scheme for radiative cooling, specifically eq. A7 --- src/main/cooling_solver.f90 | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/main/cooling_solver.f90 b/src/main/cooling_solver.f90 index 8775b5c7f..9203b4aae 100644 --- a/src/main/cooling_solver.f90 +++ b/src/main/cooling_solver.f90 @@ -266,13 +266,26 @@ subroutine exact_cooling(ui, dudt, rho, dt, mu, gamma, Tdust, K2, kappa) !argument of Y^(-1) in eq 26 dy = -Qref*dt*T_on_u/Tref y = y + dy + !find new k for eq A7 (not necessarily the same as k for eq A5) + do while(y>yk .AND. k>1) + k = k-1 + call calc_cooling_rate(Q, dlnQ_dlnT, rho, Tgrid(k), Tdust, mu, gamma, K2, kappa) + dlnQ_dlnT = log(Qi/Q)/log(Tgrid(k+1)/Tgrid(k)) + Qi = Q + ! eqs A6 to get Yk + if (abs(dlnQ_dlnT-1.) < tol) then + yk = yk - Qref*Tgrid(k)/(Q*Tref)*log(Tgrid(k)/Tgrid(k+1)) + else + yk = yk - Qref*Tgrid(k)/(Q*Tref*(1.-dlnQ_dlnT))*(1.-(Tgrid(k)/Tgrid(k+1))**(dlnQ_dlnT-1.)) + endif + enddo !compute Yinv (eqs A7) if (abs(dlnQ_dlnT-1.) < tol) then Temp = max(Tgrid(k)*exp(-Q*Tref*(y-yk)/(Qref*Tgrid(k))),T_floor) else Yinv = 1.-(1.-dlnQ_dlnT)*Q*Tref/(Qref*Tgrid(k))*(y-yk) if (Yinv > 0.) then - Temp = Tgrid(k)*(Yinv**(1./(1.-dlnQ_dlnT))) + Temp = max(Tgrid(k)*(Yinv**(1./(1.-dlnQ_dlnT))),T_floor) else Temp = T_floor endif From 605a3861cd220276db6e1e70c461617d02c1d527 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 22 Aug 2024 17:02:31 +0200 Subject: [PATCH 806/814] (subgroups) first attempt to replicate Wang's Kozai test... --- src/tests/test_ptmass.f90 | 220 +++++++++++++++++++++++++++++++++++++- 1 file changed, 219 insertions(+), 1 deletion(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 1d6549a92..5dcd5672a 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -40,7 +40,7 @@ subroutine test_ptmass(ntests,npass,string) integer, intent(inout) :: ntests,npass integer :: itmp,ierr,itest,istart logical :: do_test_binary,do_test_accretion,do_test_createsink,do_test_softening - logical :: do_test_chinese_coin,do_test_merger,do_test_potential,do_test_HII + logical :: do_test_chinese_coin,do_test_merger,do_test_potential,do_test_HII,do_test_SDAR logical :: testall if (id==master) write(*,"(/,a,/)") '--> TESTING PTMASS MODULE' @@ -53,6 +53,7 @@ subroutine test_ptmass(ntests,npass,string) do_test_potential = .false. do_test_chinese_coin = .false. do_test_HII = .false. + do_test_SDAR = .false. testall = .false. istart = 1 select case(trim(string)) @@ -77,6 +78,8 @@ subroutine test_ptmass(ntests,npass,string) do_test_merger = .true. case('ptmassHII') do_test_HII = .true. + case('ptmassSDAR') + do_test_SDAR = .true. case default testall = .true. @@ -136,6 +139,8 @@ subroutine test_ptmass(ntests,npass,string) if (do_test_HII) call test_HIIregion(ntests,npass) + if (do_test_SDAR) call test_SDAR(ntests,npass) + !reset stuff and clean up temporary files itmp = 201 nptmass = 0 @@ -1156,6 +1161,11 @@ subroutine test_merger(ntests,npass) end subroutine test_merger +!----------------------------------------------------------------------- +!+ +! Test HII region expansion around sink particles +!+ +!----------------------------------------------------------------------- subroutine test_HIIregion(ntests,npass) use dim, only:maxp,maxphase,maxvxyzu use io, only:id,master,iverbose,iprint @@ -1269,6 +1279,214 @@ subroutine test_HIIregion(ntests,npass) end subroutine test_HIIregion +!----------------------------------------------------------------------- +!+ +! Test SDAR integration method on a stable triple system +!+ +!----------------------------------------------------------------------- +subroutine test_SDAR(ntests,npass) + use dim, only:periodic,gravity,ind_timesteps + use io, only:id,master,iverbose + use physcon, only:pi,deg_to_rad + use ptmass, only:get_accel_sink_sink,h_soft_sinksink, & + get_accel_sink_gas,f_acc,use_fourthorder,use_regnbody + use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fext,& + npart,npartoftype,massoftype,xyzh,vxyzu,fxyzu,& + hfact,igas,epot_sinksink,init_part,iJ2,ispinx,ispiny,ispinz,iReff,istar + use part, only:group_info,bin_info,n_group,n_ingroup,n_sing,nmatrix + use energies, only:angtot,etot,totmom,compute_energies,hp,hx + use timestep, only:dtmax,C_force,tolv + use kdtree, only:tree_accuracy + use eos, only:ieos + use setbinary, only:set_binary + use units, only:set_units + use mpiutils, only:bcast_mpi,reduce_in_place_mpi + use step_lf_global, only:init_step,step + use testutils, only:checkvalf,checkvalbuf,checkvalbuf_end + use checksetup, only:check_setup + use deriv, only:get_derivs_global + use timing, only:getused,printused + use options, only:ipdv_heating,ishock_heating + use subgroup, only:group_identify,r_neigh + use centreofmass, only:reset_centreofmass + integer, intent(inout) :: ntests,npass + integer :: i,ierr,nfailed(3),nerr,nwarn + integer :: merge_ij(3),merge_n,nparttot + real :: m1,m2,a,ecc,incl,hacc1,hacc2,dt,dtext,t,dtnew,tolen,tolmom,tolang + real :: angmomin,etotin,totmomin,dum,dum2,omega,errmax,dtsinksink,tmax + 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 + ! + !--no gas particles + ! + call init_part() + iverbose = 0 + tree_accuracy = 0. + h_soft_sinksink = 0. + ipdv_heating = 0 + ishock_heating = 0 + use_regnbody = .true. + r_neigh = 10. + use_fourthorder = .true. + + tolv = 1e-2 + + ! + !--setup triple system with Kozai-Lidov resonance + ! + npart = 0 + npartoftype = 0 + nptmass = 0 + m1 = 2.0 + m2 = 1.0 + a = 1.0000 + ecc = 0.990000 + incl = 0.10/deg_to_rad + hacc1 = 1e-4 + hacc2 = 1e-4 + C_force = 0.25 + omega = sqrt((m1+m2)/a**3) + t = 0. + call set_units(mass=1.d0,dist=1.d0,G=1.d0) + call set_binary(m1,m2,a,ecc,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,& + posang_ascnode=0.0,arg_peri=0.0,incl=incl,mean_anomaly=179.999999,verbose=.false.) + + + xsec(1:3) = xyzmh_ptmass(1:3,2) + vsec(1:3) = vxyz_ptmass(1:3,2) + m1 = 0.90 + m2 = 0.10 + a = 0.00099431556644 + ecc = 0.90000 + incl = 1.5/deg_to_rad + + nptmass = nptmass - 1 + xyzmh_ptmass(:,2) = 0. + vxyz_ptmass(:,2) = 0. + + call set_binary(m1,m2,a,ecc,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,& + posang_ascnode=0.0,arg_peri=0.0,incl=incl,mean_anomaly=179.999999,verbose=.false.) + + xyzmh_ptmass(1:3,2) = xyzmh_ptmass(1:3,2) + xsec(1:3) + vxyz_ptmass(1:3,2) = vxyz_ptmass(1:3,2) + vsec(1:3) + xyzmh_ptmass(1:3,3) = xyzmh_ptmass(1:3,3) + xsec(1:3) + vxyz_ptmass(1:3,3) = vxyz_ptmass(1:3,3) + vsec(1:3) + + + call reset_centreofmass(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) + + + + if (ierr /= 0) nerr = nerr + 1 + + ! + ! check that no errors occurred when setting up initial conditions + ! + nfailed = 0 + call check_setup(nerr,nwarn) + call checkval(nerr,0,0,nfailed(1),'no errors during disc setup') + call update_test_scores(ntests,nfailed,npass) + + tolv = 1.e-2 + iverbose = 0 + ieos = 1 + ! + ! initialise forces + ! + if (id==master) then + 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_sinksink,epot_sinksink,& + dtsinksink,0,0.,merge_ij,merge_n,dsdt_sinksink,& + group_info=group_info,bin_info=bin_info) + endif + fxyz_ptmass(:,1:nptmass) = 0. + dsdt_ptmass(:,1:nptmass) = 0. + call bcast_mpi(epot_sinksink) + call bcast_mpi(dtsinksink) + + fext(:,:) = 0. + do i=1,npart + 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),dum,massoftype(igas),fxyz_ptmass,dsdt_ptmass,dum,dum2) + enddo + if (id==master) then + fxyz_ptmass(:,1:nptmass) = fxyz_ptmass(:,1:nptmass) + fxyz_sinksink(:,1:nptmass) + dsdt_ptmass(:,1:nptmass) = dsdt_ptmass(:,1:nptmass) + dsdt_sinksink(:,1:nptmass) + endif + call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) + call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) + + ! + !--take the sink-sink timestep specified by the get_forces routine + ! + dt = 0.01 + + dtmax = dt ! required prior to derivs call, as used to set ibin + ! + !--compute SPH forces + ! + if (npart > 0) then + fxyzu(:,:) = 0. + call get_derivs_global() + endif + ! + !--evolve this for a number of orbits + ! + call compute_energies(t) + etotin = etot + totmomin = totmom + angmomin = angtot + ! + !--check that initial potential on the two sinks is correct + ! +! nfailed(:) = 0 +! if (itest==1) then +! call checkval(epot_sinksink,-m1*m2/a,epsilon(0.),nfailed(1),'potential energy') +! call update_test_scores(ntests,nfailed,npass) +! ! +! !--check initial angular momentum on the two sinks is correct +! ! +! call checkval(angtot,m1*m2*sqrt(a/(m1 + m2)),1e6*epsilon(0.),nfailed(1),'angular momentum') +! call update_test_scores(ntests,nfailed,npass) +! endif + tmax = 45.*3 + t = 0. + errmax = 0. + f_acc = 1. + ! + !--integration loop + ! + if (id==master) call getused(t1) + call init_step(npart,t,dtmax) + do while (t < tmax) + dtext = dt + call step(npart,npart,t,dt,dtext,dtnew) + write(1,*) t+dt,bin_info(:,2) + call compute_energies(t) + errmax = max(errmax,abs(etot - etotin)) + t = t + dt + enddo + + call compute_energies(t) + + if (id==master) call printused(t1) + nfailed(:) = 0 + tolmom = 2.e-14 + tolang = 2.e-14 + ! + !--check energy conservation + ! + call checkval(angtot,angmomin,tolang,nfailed(1),'angular momentum') + call checkval(totmom,totmomin,tolmom,nfailed(2),'linear momentum') + call checkval(etotin+errmax,etotin,tolen,nfailed(3),'total energy') + do i=1,3 + call update_test_scores(ntests,nfailed(i:i),npass) + enddo + +end subroutine test_SDAR + !----------------------------------------------------------------------- !+ ! Test sink particle surface force, simply that the acceleration From 7eb809bccb0761679edcc62695e4b82c02d79515 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 22 Aug 2024 17:04:36 +0200 Subject: [PATCH 807/814] (subgroups) change initial ds choice using its geometric meaning and add kappa limitation in multiples --- src/main/energies.F90 | 4 +- src/main/initial.F90 | 2 +- src/main/subgroup.f90 | 304 +++++++++++++++++++++++++++--------------- 3 files changed, 202 insertions(+), 108 deletions(-) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 8ab3c8a80..7687b696e 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -83,7 +83,7 @@ subroutine compute_energies(t) use options, only:iexternalforce,calc_erot,alpha,ieos,use_dustfrac use mpiutils, only:reduceall_mpi use ptmass, only:get_accel_sink_gas,use_regnbody - use subgroup, only:get_pot_subsys + use subgroup, only:get_pot_subsys use viscosity, only:irealvisc,shearfunc use nicil, only:nicil_update_nimhd,nicil_get_halldrift,nicil_get_ambidrift, & use_ohm,use_hall,use_ambi,n_data_out,n_warn,eta_constant @@ -644,7 +644,7 @@ subroutine compute_energies(t) erad = reduceall_mpi('+',erad) if (nptmass > 1) then if (use_regnbody) then - call get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + call get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) endif epot = epot + epot_sinksink endif diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 06bee10fc..9ea8fc1a5 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -560,7 +560,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) ! Reduce dt over MPI tasks dtsinkgas = reduceall_mpi('min',dtsinkgas) dtextforce = reduceall_mpi('min',dtextforce) - if (use_regnbody) call update_kappa(xyzmh_ptmass,bin_info,group_info,n_group) + if (use_regnbody) call update_kappa(xyzmh_ptmass,vxyz_ptmass,bin_info,group_info,n_group) endif call init_ptmass(nptmass,logfile) if (gravity .and. icreate_sinks > 0 .and. id==master) then diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 97c1fb214..69517a27c 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -31,10 +31,12 @@ module subgroup ! !-- parameters for group identification ! - real, parameter :: time_error = 2.5e-14 - real, parameter :: max_step = 1000000 - real, parameter :: C_bin = 0.02 - real, public :: r_neigh = 0.001 ! default value assume udist = 1 pc + real, parameter :: time_error = 2.5e-12 + real, parameter :: max_step = 1000000 + real, parameter :: C_bin = 0.02 + real, public :: r_neigh = 0.001 ! default value assume udist = 1 pc + real :: elli_res = 1/128. + real :: hyper_res = 1/256. real :: r_search ! @@ -50,12 +52,7 @@ module subgroup ! !----------------------------------------------- subroutine init_subgroup - use units, only:udist - use physcon, only:pc - - r_neigh = r_neigh*(pc/udist) r_search = 100.*r_neigh - end subroutine init_subgroup !----------------------------------------------- @@ -231,6 +228,8 @@ subroutine get_r2min(xyzmh_ptmass,group_info,r2min_id,start_id,end_id) integer :: i,j,k,l,n real :: dr(3),r2,r2min + r2min_id = 0 + do i=start_id,end_id n = (i-start_id)+1 j = group_info(igarg,i) @@ -513,7 +512,7 @@ end subroutine evolve_groups !------------------------------------------------------------------------------------ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,& bin_info,group_info,fxyz_ptmass,gtgrad) - use part, only: igarg,ikap,iorb + use part, only: igarg,ikap,isemi use io, only: fatal real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & fxyz_ptmass(:,:),gtgrad(:,:),bin_info(:,:) @@ -536,7 +535,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ismultiple = gsize > 2 if (ismultiple) then - call get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,start_id,end_id) + call get_kappa(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsize,start_id,end_id) call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,W,start_id,end_id,ds_init=ds_init) else prim = group_info(igarg,start_id) @@ -548,14 +547,15 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ if (bin_info(ikap,prim) >= 1.) then kappa1 = 1./bin_info(ikap,prim) else + kappa1 = 1. call fatal('subgroup','kappa value bellow 1... something wrong here!',var='kappa',val=bin_info(ikap,prim)) endif call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,W,kappa1,prim,sec,& - ds_init=ds_init,Tij=bin_info(iorb,prim)) + ds_init=ds_init,semiij=bin_info(isemi,prim)) endif - allocate(bdata(gsize*6)) + allocate(bdata(gsize*7)) step_count_int = 0 step_count_tsyn = 0 @@ -566,12 +566,12 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ switch = 1 - do while (.true.) + do while (.true.) if (backup_flag) then - call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bdata) + call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,bdata) else - call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) + call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,tcoord,t_old,W,W_old,bdata) endif t_old = tcoord W_old = W @@ -592,12 +592,14 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ if (step_count_int > max_step) then print*,"MAX STEP NUMBER, ABORT !!!" - print*,step_count_int,step_count_tsyn,tcoord,tnext,ds_init + print*,step_count_int,step_count_tsyn,tcoord,tnext,ds_init,ds(switch) call abort() endif if ((.not.t_end_flag).and.(dt<0.)) then - !print*,"neg dt !!!",tnext,dt + print*,"neg dt !!!",tnext,dt,step_count_int + print*, sqrt(dot_product(xyzmh_ptmass(1:3,3)-xyzmh_ptmass(1:3,2),xyzmh_ptmass(1:3,3)-xyzmh_ptmass(1:3,2))),& + bin_info(1,2),bin_info(3,2) call regularstepfactor((abs(tnext/dt))**(1./6.),step_modif) step_modif = min(max(step_modif,0.0625),0.5) ds(switch) = ds(switch)*step_modif @@ -693,9 +695,9 @@ end subroutine new_ds_sync_sup -subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bdata) - use part, only: igarg - real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:) +subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,bdata) + use part, only: igarg,ikappa + real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:),bin_info(:,:) integer, intent(in) :: group_info(:,:) real, intent(out) ::bdata(:) integer, intent(in) :: start_id,end_id @@ -703,21 +705,22 @@ subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bdata j=0 do k=start_id,end_id i = group_info(igarg,k) - bdata(j*6+1) = xyzmh_ptmass(1,i) - bdata(j*6+2) = xyzmh_ptmass(2,i) - bdata(j*6+3) = xyzmh_ptmass(3,i) - bdata(j*6+4) = vxyz_ptmass(1,i) - bdata(j*6+5) = vxyz_ptmass(2,i) - bdata(j*6+6) = vxyz_ptmass(3,i) + bdata(j*7+1) = xyzmh_ptmass(1,i) + bdata(j*7+2) = xyzmh_ptmass(2,i) + bdata(j*7+3) = xyzmh_ptmass(3,i) + bdata(j*7+4) = vxyz_ptmass(1,i) + bdata(j*7+5) = vxyz_ptmass(2,i) + bdata(j*7+6) = vxyz_ptmass(3,i) + bdata(j*7+7) = bin_info(ikappa,i) j = j + 1 enddo end subroutine backup_data -subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) - use part, only: igarg - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) +subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,tcoord,t_old,W,W_old,bdata) + use part, only: igarg,ikappa + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),bin_info(:,:) integer, intent(in) :: group_info(:,:) real, intent(out) :: tcoord,W real, intent(in) :: t_old,W_old @@ -727,12 +730,13 @@ subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tco j = 0 do k=start_id,end_id i = group_info(igarg,k) - xyzmh_ptmass(1,i) = bdata(j*6+1) - xyzmh_ptmass(2,i) = bdata(j*6+2) - xyzmh_ptmass(3,i) = bdata(j*6+3) - vxyz_ptmass(1,i) = bdata(j*6+4) - vxyz_ptmass(2,i) = bdata(j*6+5) - vxyz_ptmass(3,i) = bdata(j*6+6) + xyzmh_ptmass(1,i) = bdata(j*7+1) + xyzmh_ptmass(2,i) = bdata(j*7+2) + xyzmh_ptmass(3,i) = bdata(j*7+3) + vxyz_ptmass(1,i) = bdata(j*7+4) + vxyz_ptmass(2,i) = bdata(j*7+5) + vxyz_ptmass(3,i) = bdata(j*7+6) + bin_info(ikappa,i) = bdata(j*7+7) j = j + 1 enddo tcoord = t_old @@ -756,7 +760,7 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsi integer, intent(in) :: s_id,e_id,gsize integer, allocatable :: binstack(:) integer :: k,i,compi,n - real :: dtd,vcom(3),m1,m2,mtot,kappai,kappa1i + real :: dtd,vcom(3),kappai,kappa1i allocate(binstack((gsize/4)+1)) binstack = 0 @@ -770,9 +774,6 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsi i = group_info(igarg,k) compi = group_info(icomp,k) if (compi/=i) then ! It's a binary. identify companion and drift binary. - m1 = xyzmh_ptmass(4,i) - m2 = xyzmh_ptmass(4,compi) - mtot = m1+m2 kappai = bin_info(ikap,i) if (kappai >= 1.) then kappa1i = 1./kappai @@ -781,10 +782,8 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsi call fatal('subgroup','kappa value bellow 1... something wrong here!',var='kappai',val=kappai) endif if (any(binstack == i)) cycle! If already treated i will be in binstack - vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,compi))/mtot - vcom(2) = (m1*vxyz_ptmass(2,i)+m2*vxyz_ptmass(2,compi))/mtot - vcom(3) = (m1*vxyz_ptmass(3,i)+m2*vxyz_ptmass(3,compi))/mtot - n = n+1 ! stack level + call get_bin_com(i,compi,xyzmh_ptmass,vxyz_ptmass,vcom) + n = n + 1 ! stack level binstack(n) = compi call correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1i,dtd,i,compi) @@ -806,7 +805,7 @@ end subroutine drift_TTL ! !--------------------------------------- subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,s_id,e_id) - use part, only: igarg,ikap + use part, only: igarg,ikap,icomp use io, only: fatal real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) real, intent(inout) :: gtgrad(:,:),bin_info(:,:) @@ -814,16 +813,21 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass real, intent(in) :: h real, intent(inout) :: W integer, intent(in) :: s_id,e_id - real :: om,dw,dtk,kappa1i,kappai,om_old - integer :: i,k,gsize + integer, allocatable :: binstack(:) + real :: om,dw,dtk,kappa1i,kappai,om_old,vcom(3) + integer :: i,k,n,gsize,compi + gsize = (e_id-s_id+1) + allocate(binstack((gsize/4)+1)) + binstack = 0 + n = 0 if (h==0.) then call binaries_in_multiples(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,& gsize,s_id,e_id) call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om_old,s_id,e_id,.true.) - call get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) + call get_kappa(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsize,s_id,e_id) call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id) W = W + (om-om_old) ! correct W after updating kappa... else @@ -840,17 +844,29 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass dw = 0. do k=s_id,e_id - i=group_info(igarg,k) - kappai = bin_info(ikap,i) - if (kappai >= 1.) then - kappa1i = 1./kappai + i = group_info(igarg,k) + compi = group_info(icomp,k) + if(i/=compi) then + + kappai = bin_info(ikap,i) + if (kappai >= 1.) then + kappa1i = 1./kappai + else + kappa1i = 1. + call fatal('subgroup','kappa value bellow 1... something wrong here!',var='kappai',val=kappai) + endif + if (any(binstack == i)) cycle! If already treated i will be in binstack + call get_bin_com(i,compi,xyzmh_ptmass,vxyz_ptmass,vcom) + n = n+1 ! stack level + binstack(n) = compi + + call correct_W_SD(dw,vxyz_ptmass,gtgrad,vcom,kappa1i,i,compi) + else - kappa1i = 1. - call fatal('subgroup','kappa value bellow 1... something wrong here!',var='kappai',val=kappai) + dw = dw + (vxyz_ptmass(1,i)*gtgrad(1,i) + & + vxyz_ptmass(2,i)*gtgrad(2,i) + & + vxyz_ptmass(3,i)*gtgrad(3,i)) endif - dw = dw + kappa1i*(vxyz_ptmass(1,i)*gtgrad(1,i) + & - vxyz_ptmass(2,i)*gtgrad(2,i) + & - vxyz_ptmass(3,i)*gtgrad(3,i)) enddo W = W + dw*dtk @@ -863,6 +879,8 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass enddo endif + deallocate(binstack) + end subroutine kick_TTL !-------------------------------------------------------------------------- @@ -877,21 +895,16 @@ subroutine oneStep_bin(tcoord,W,ds,kappa1,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,g integer, intent(in) :: i,j integer :: k real :: dtd,dtk,dvel1(3),dvel2(3),dw,om - real :: vcom(3),mtot,m1,m2 + real :: vcom(3) + - m1 = xyzmh_ptmass(4,i) - m2 = xyzmh_ptmass(4,j) - mtot = m1+m2 do k = 1,ck_size dtd = ds*cks(k)/W tcoord = tcoord + dtd time_table(k) = tcoord - vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,j))/mtot - 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 - + call get_bin_com(i,j,xyzmh_ptmass,vxyz_ptmass,vcom) if (kappa1 < 1.0) then call correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,dtd,i,j) @@ -979,6 +992,40 @@ subroutine correct_com_drift(xyzmh_ptmass,vxyz_ptmass,vcom,kappa1,dtd,i,j) end subroutine correct_com_drift + +!------------------------------------------------------------------ +! +! Correction method to compute the new value of W when SD on +! +!------------------------------------------------------------------ +subroutine correct_W_SD(dW,vxyz_ptmass,gtgrad,vcom,kappa1,i,j) + real, intent(inout) :: dW + real, intent(in) :: vxyz_ptmass(:,:),gtgrad(:,:),vcom(3) + real, intent(in) :: kappa1 + integer, intent(in) :: i,j + real :: vrel(3) + + + vrel(1) = vxyz_ptmass(1,i) - vcom(1) + vrel(2) = vxyz_ptmass(2,i) - vcom(2) + vrel(3) = vxyz_ptmass(3,i) - vcom(3) + + dW = dW + (vrel(1)*kappa1 + vcom(1))*gtgrad(1,i) + dW = dW + (vrel(2)*kappa1 + vcom(2))*gtgrad(2,i) + dW = dW + (vrel(3)*kappa1 + vcom(3))*gtgrad(3,i) + + vrel(1) = vxyz_ptmass(1,j) - vcom(1) + vrel(2) = vxyz_ptmass(2,j) - vcom(2) + vrel(3) = vxyz_ptmass(3,j) - vcom(3) + + dW = dW + (vrel(1)*kappa1 + vcom(1))*gtgrad(1,j) + dW = dW + (vrel(2)*kappa1 + vcom(2))*gtgrad(2,j) + dW = dW + (vrel(3)*kappa1 + vcom(3))*gtgrad(3,j) + + + +end subroutine correct_W_SD + !--------------------------------------- ! ! TTL Force routine for multiples only. @@ -987,7 +1034,7 @@ end subroutine correct_com_drift ! !--------------------------------------- subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id,potonly,ds_init) - use part, only: igarg,iorb,ikap,icomp + use part, only: igarg,ikap,icomp,isemi use io, only: fatal real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:),bin_info(:,:) @@ -996,18 +1043,16 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, integer, intent(in) :: s_id,e_id logical, optional, intent(in) :: potonly real, optional, intent(out) :: ds_init - real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3,dt_init,om_init - real :: gravf,gtk,gtki,gravfi(3),gtgradi(3),Ti,kappa1i,kappai + real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3,dsi,mcomp,semii + real :: gravf,gtk,gtki,gravfi(3),gtgradi(3),kappa1i,kappai integer :: i,j,k,l,compi logical :: init om = 0. - dt_init = huge(om) if (present(ds_init)) then init = .true. - ds_init = 0. - om_init = 0. + ds_init = huge(om) else init = .false. endif @@ -1049,7 +1094,6 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, gtk = mj*ddr endif gtki = gtki + gtk - if (init) om_init = om_init + mj*ddr if (.not.present(potonly)) then ddr3 = ddr*ddr*ddr if (j == compi) then @@ -1077,15 +1121,20 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, if (init) then if (compi /=i) then - Ti = bin_info(iorb,i) - dt_init = min(dt_init,0.002*Ti) + semii = bin_info(isemi,i) + mcomp = xyzmh_ptmass(4,compi) + if(semii >= 0) then + dsi = mi*mcomp*sqrt(semii/(mi+mcomp))*elli_res + else + dsi = mi*mcomp*sqrt(-semii/(mi+mcomp))*hyper_res + endif + ds_init = min(ds_init,dsi) endif endif om = om + gtki*mi enddo om = om*0.5 - if (init) ds_init = dt_init*om_init*0.5 end subroutine get_force_TTL @@ -1095,17 +1144,17 @@ end subroutine get_force_TTL ! on outside pertubartions for multiples only ! !-------------------------------------------------------- -subroutine get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) - use part, only:igarg,icomp,ipert,ikap,iapo,iecc,isemi - real , intent(in) :: xyzmh_ptmass(:,:) +subroutine get_kappa(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsize,s_id,e_id) + use part, only:igarg,icomp,ipert,ikap,iapo,iecc,iorb + real , intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real , intent(inout) :: bin_info(:,:) integer, intent(in) :: group_info(:,:) integer, intent(in) :: s_id,e_id,gsize integer, allocatable :: binstack(:) integer :: k,l,i,j,compi,n - real :: pouti,r2,dx,dy,dz,ddr,ddr3,xi,yi,zi,m1,m2,mj,mu - real :: kappa,rapo,rapo3 - + real :: pouti,r2,dr(3),dv(3),ddr,ddr3,m1,m2,mj,mu + real :: kappa,kappa_max,rapo,rapo3,Ti + real :: vcom(3),xcom(3),rm(3),vm(3),rmn,vmn allocate(binstack(gsize)) binstack = 0 n = 0 @@ -1117,40 +1166,57 @@ subroutine get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,s_id,e_id) bin_info(ikap,i) = 1. else if (any(binstack == i)) cycle + call get_bin_com(i,compi,xyzmh_ptmass,vxyz_ptmass,vcom,xcom) n = n+1 ! level of the stack binstack(n) = compi pouti = bin_info(ipert,i) - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) + Ti = bin_info(iorb,i) m1 = xyzmh_ptmass(4,i) m2 = xyzmh_ptmass(4,compi) + rm = 0. + vm = 0. do l=s_id,e_id if (k == l) cycle j = group_info(igarg,l) if (j == compi) cycle - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - r2 = dx**2+dy**2+dz**2 + mj = xyzmh_ptmass(4,j) + + dr(1) = xcom(1) - xyzmh_ptmass(1,j) + dr(2) = xcom(2) - xyzmh_ptmass(2,j) + dr(3) = xcom(3) - xyzmh_ptmass(3,j) + dv(1) = vcom(1) - vxyz_ptmass(1,j) + dv(2) = vcom(2) - vxyz_ptmass(2,j) + dv(3) = vcom(3) - vxyz_ptmass(3,j) + r2 = dr(1)**2+dr(2)**2+dr(3)**2 + vm = vm - dv*mj ddr = 1./sqrt(r2) + rm = rm - dr*mj ddr3 = ddr*ddr*ddr - mj = xyzmh_ptmass(4,j) + pouti = pouti + mj*ddr3 + enddo - mu = (m1*m2)/(m1+m2) - rapo = bin_info(iapo,i) + mu = (m1*m2)/(m1+m2) + rapo = bin_info(iapo,i) rapo3 = rapo*rapo*rapo - kappa = kref/((rapo3/mu)*pouti) - !print*,pouti,kappa,rapo,bin_info(isemi,i),bin_info(iecc,i),i + rmn = sqrt(rm(1)**2+rm(2)**2+rm(3)**2) + vmn = sqrt(vm(1)**2+vm(2)**2+vm(3)**2) + + kappa = kref/((rapo3/mu)*pouti) + kappa_max = (rmn/vmn)*(0.033/(Ti*kappa)) + + if (kappa_max<1. .or. kappa<1.) then + kappa = 1. + kappa_max = 1. + endif - if (kappa>1.) then + if (kappa= 0) then + ds_init = mi*mj*sqrt(semiij/(mi+mj))*elli_res + else + ds_init = mi*mj*sqrt(-semiij/(mi+mj))*hyper_res + endif endif @@ -1273,9 +1343,9 @@ end subroutine get_kappa_bin ! for each subgroups in the simulation ! !-------------------------------------------------------- -subroutine update_kappa(xyzmh_ptmass,bin_info,group_info,n_group) +subroutine update_kappa(xyzmh_ptmass,vxyz_ptmass,bin_info,group_info,n_group) use part, only:igcum,igarg - real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(inout) :: bin_info(:,:) integer, intent(in) :: group_info(:,:) integer, intent(in) :: n_group @@ -1286,7 +1356,7 @@ subroutine update_kappa(xyzmh_ptmass,bin_info,group_info,n_group) end_id = group_info(igcum,i+1) gsize = (end_id - start_id) + 1 if (gsize>2) then - call get_kappa(xyzmh_ptmass,group_info,bin_info,gsize,start_id,end_id) + call get_kappa(xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,gsize,start_id,end_id) else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) @@ -1295,24 +1365,48 @@ subroutine update_kappa(xyzmh_ptmass,bin_info,group_info,n_group) enddo end subroutine update_kappa +subroutine get_bin_com(i,j,xyzmh_ptmass,vxyz_ptmass,vcom,xcom) + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(out) :: vcom(3) + integer, intent(in) :: i,j + real, intent(out),optional :: xcom(3) + real :: mtot,m1,m2 + + m1 = xyzmh_ptmass(4,i) + m2 = xyzmh_ptmass(4,j) + mtot = m1 + m2 + + vcom(1) = (m1*vxyz_ptmass(1,i)+m2*vxyz_ptmass(1,j))/mtot + 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 + 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 + endif + +end subroutine get_bin_com + !-------------------------------------------------------- ! ! Routine to compute potential energy in subgroups ! !-------------------------------------------------------- -subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) +subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,& + gtgrad,epot_sinksink) use part, only: igarg,igcum,ikap use io, only: id,master,fatal integer, intent(in) :: n_group real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) - real, intent(inout) :: bin_info(:,:) + real, intent(inout) :: bin_info(:,:),vxyz_ptmass(:,:) integer, intent(in) :: group_info(:,:) real, intent(inout) :: epot_sinksink integer :: i,start_id,end_id,gsize,prim,sec real :: phitot,phigroup,kappa1 phitot = 0. - call update_kappa(xyzmh_ptmass,bin_info,group_info,n_group) + call update_kappa(xyzmh_ptmass,vxyz_ptmass,bin_info,group_info,n_group) if (n_group>0) then if (id==master) then From 69242f90ade1dcb33e07e19f62c676dde9db0528 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 22 Aug 2024 17:07:52 +0200 Subject: [PATCH 808/814] (test_ptmass) remove compilation warning --- src/tests/test_ptmass.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 5dcd5672a..bbe4c1b63 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -1292,9 +1292,9 @@ subroutine test_SDAR(ntests,npass) get_accel_sink_gas,f_acc,use_fourthorder,use_regnbody use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fext,& npart,npartoftype,massoftype,xyzh,vxyzu,fxyzu,& - hfact,igas,epot_sinksink,init_part,iJ2,ispinx,ispiny,ispinz,iReff,istar + igas,epot_sinksink,init_part,iJ2,ispinx,ispiny,ispinz,iReff,istar use part, only:group_info,bin_info,n_group,n_ingroup,n_sing,nmatrix - use energies, only:angtot,etot,totmom,compute_energies,hp,hx + use energies, only:angtot,etot,totmom,compute_energies use timestep, only:dtmax,C_force,tolv use kdtree, only:tree_accuracy use eos, only:ieos @@ -1311,7 +1311,7 @@ subroutine test_SDAR(ntests,npass) use centreofmass, only:reset_centreofmass integer, intent(inout) :: ntests,npass integer :: i,ierr,nfailed(3),nerr,nwarn - integer :: merge_ij(3),merge_n,nparttot + integer :: merge_ij(3),merge_n real :: m1,m2,a,ecc,incl,hacc1,hacc2,dt,dtext,t,dtnew,tolen,tolmom,tolang real :: angmomin,etotin,totmomin,dum,dum2,omega,errmax,dtsinksink,tmax real :: fxyz_sinksink(4,3),dsdt_sinksink(3,3) ! we only use 3 sink particles in the tests here From 6d5e58f97f1cf2f8bfd58862854fd60c706327b7 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 22 Aug 2024 17:11:19 +0200 Subject: [PATCH 809/814] (subgroups) cleaning... --- src/main/subgroup.f90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 69517a27c..7533b54ff 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -597,9 +597,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ endif if ((.not.t_end_flag).and.(dt<0.)) then - print*,"neg dt !!!",tnext,dt,step_count_int - print*, sqrt(dot_product(xyzmh_ptmass(1:3,3)-xyzmh_ptmass(1:3,2),xyzmh_ptmass(1:3,3)-xyzmh_ptmass(1:3,2))),& - bin_info(1,2),bin_info(3,2) + !print*,"neg dt !!!",tnext,dt,step_count_int call regularstepfactor((abs(tnext/dt))**(1./6.),step_modif) step_modif = min(max(step_modif,0.0625),0.5) ds(switch) = ds(switch)*step_modif From 2116152cfb4af73601c3a347a8872ca7b298837b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 22 Aug 2024 21:18:43 +0200 Subject: [PATCH 810/814] (subgroups) kozai test done --- src/main/subgroup.f90 | 20 +++++++++------ src/tests/test_ptmass.f90 | 51 +++++++++++++++------------------------ 2 files changed, 32 insertions(+), 39 deletions(-) diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 7533b54ff..16d7a7b26 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -1031,7 +1031,7 @@ end subroutine correct_W_SD ! computed here as well. ! !--------------------------------------- -subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id,potonly,ds_init) +subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om,s_id,e_id,potonly,energ,ds_init) use part, only: igarg,ikap,icomp,isemi use io, only: fatal real, intent(in) :: xyzmh_ptmass(:,:) @@ -1040,6 +1040,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, real, intent(out) :: om integer, intent(in) :: s_id,e_id logical, optional, intent(in) :: potonly + logical, optional, intent(in) :: energ real, optional, intent(out) :: ds_init real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3,dsi,mcomp,semii real :: gravf,gtk,gtki,gravfi(3),gtgradi(3),kappa1i,kappai @@ -1087,7 +1088,11 @@ 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 - gtk = mj*ddr*kappa1i + if(present(potonly) .and. present(energ)) then + gtk = mj*ddr + else + gtk = mj*ddr*kappa1i + endif else gtk = mj*ddr endif @@ -1107,8 +1112,8 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, gtgradi(3) = gtgradi(3) + dz*gravf*mi endif enddo - fxyz_ptmass(4,i) = -gtki if (.not.present(potonly)) then + fxyz_ptmass(4,i) = -gtki fxyz_ptmass(1,i) = gravfi(1) fxyz_ptmass(2,i) = gravfi(2) fxyz_ptmass(3,i) = gravfi(3) @@ -1252,7 +1257,7 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,poton ddr = 1./sqrt(r2) ddr3 = ddr*ddr*ddr - if (kappa1<1.0) then + if (kappa1<1.0 .and. .not.present(potonly)) then gravfi = kappa1*mj*ddr3 gravfj = kappa1*mi*ddr3 gtki = kappa1*mj*ddr @@ -1265,8 +1270,7 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,poton endif - fxyz_ptmass(4,i) = -gtki - fxyz_ptmass(4,j) = -gtkj + if (.not.present(potonly)) then fxi = -dx*gravfi fyi = -dy*gravfi @@ -1274,6 +1278,8 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,poton fxj = dx*gravfj fyj = dy*gravfj fzj = dz*gravfj + fxyz_ptmass(4,i) = -gtki + fxyz_ptmass(4,j) = -gtkj fxyz_ptmass(1,i) = fxi fxyz_ptmass(2,i) = fyi fxyz_ptmass(3,i) = fzi @@ -1418,7 +1424,7 @@ subroutine get_pot_subsys(n_group,group_info,bin_info,xyzmh_ptmass,vxyz_ptmass,f end_id = group_info(igcum,i+1) gsize = (end_id - start_id) + 1 if (gsize>2) then - call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,phigroup,start_id,end_id,.true.) + call get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,phigroup,start_id,end_id,.true.,.true.) else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index bbe4c1b63..bb0c28d4b 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -137,9 +137,10 @@ subroutine test_ptmass(ntests,npass,string) ! if (do_test_createsink .or. testall) call test_createsink(ntests,npass) + if (do_test_SDAR .or. testall) call test_SDAR(ntests,npass) + if (do_test_HII) call test_HIIregion(ntests,npass) - if (do_test_SDAR) call test_SDAR(ntests,npass) !reset stuff and clean up temporary files itmp = 201 @@ -1291,7 +1292,7 @@ subroutine test_SDAR(ntests,npass) use ptmass, only:get_accel_sink_sink,h_soft_sinksink, & get_accel_sink_gas,f_acc,use_fourthorder,use_regnbody use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fext,& - npart,npartoftype,massoftype,xyzh,vxyzu,fxyzu,& + npart,npartoftype,massoftype,xyzh,vxyzu,& igas,epot_sinksink,init_part,iJ2,ispinx,ispiny,ispinz,iReff,istar use part, only:group_info,bin_info,n_group,n_ingroup,n_sing,nmatrix use energies, only:angtot,etot,totmom,compute_energies @@ -1312,8 +1313,8 @@ subroutine test_SDAR(ntests,npass) integer, intent(inout) :: ntests,npass integer :: i,ierr,nfailed(3),nerr,nwarn integer :: merge_ij(3),merge_n - real :: m1,m2,a,ecc,incl,hacc1,hacc2,dt,dtext,t,dtnew,tolen,tolmom,tolang - real :: angmomin,etotin,totmomin,dum,dum2,omega,errmax,dtsinksink,tmax + real :: m1,m2,a,ecc,incl,hacc1,hacc2,dt,dtext,t,dtnew,tolen,tolmom,tolang,tolecc + real :: angmomin,etotin,totmomin,dum,dum2,omega,errmax,dtsinksink,tmax,eccfin,decc 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 @@ -1385,7 +1386,7 @@ subroutine test_SDAR(ntests,npass) ! nfailed = 0 call check_setup(nerr,nwarn) - call checkval(nerr,0,0,nfailed(1),'no errors during disc setup') + call checkval(nerr,0,0,nfailed(1),'no errors during setup') call update_test_scores(ntests,nfailed,npass) tolv = 1.e-2 @@ -1418,19 +1419,12 @@ subroutine test_SDAR(ntests,npass) call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) - ! - !--take the sink-sink timestep specified by the get_forces routine - ! + dt = 0.01 dtmax = dt ! required prior to derivs call, as used to set ibin - ! - !--compute SPH forces - ! - if (npart > 0) then - fxyzu(:,:) = 0. - call get_derivs_global() - endif + + ! !--evolve this for a number of orbits ! @@ -1438,20 +1432,10 @@ subroutine test_SDAR(ntests,npass) etotin = etot totmomin = totmom angmomin = angtot - ! - !--check that initial potential on the two sinks is correct - ! -! nfailed(:) = 0 -! if (itest==1) then -! call checkval(epot_sinksink,-m1*m2/a,epsilon(0.),nfailed(1),'potential energy') -! call update_test_scores(ntests,nfailed,npass) -! ! -! !--check initial angular momentum on the two sinks is correct -! ! -! call checkval(angtot,m1*m2*sqrt(a/(m1 + m2)),1e6*epsilon(0.),nfailed(1),'angular momentum') -! call update_test_scores(ntests,nfailed,npass) -! endif - tmax = 45.*3 + ecc = bin_info(2,2) + decc = 0.09618 + + tmax = 7.*3.63 ! 7 out binary periods t = 0. errmax = 0. f_acc = 1. @@ -1463,7 +1447,6 @@ subroutine test_SDAR(ntests,npass) do while (t < tmax) dtext = dt call step(npart,npart,t,dt,dtext,dtnew) - write(1,*) t+dt,bin_info(:,2) call compute_energies(t) errmax = max(errmax,abs(etot - etotin)) t = t + dt @@ -1473,14 +1456,18 @@ subroutine test_SDAR(ntests,npass) if (id==master) call printused(t1) nfailed(:) = 0 - tolmom = 2.e-14 - tolang = 2.e-14 + eccfin = 0.99617740539553523 + tolecc = 3e-5 + tolmom = 2.e-11 + tolang = 2.e-11 + tolen = 5.e-6 ! !--check energy conservation ! call checkval(angtot,angmomin,tolang,nfailed(1),'angular momentum') call checkval(totmom,totmomin,tolmom,nfailed(2),'linear momentum') call checkval(etotin+errmax,etotin,tolen,nfailed(3),'total energy') + call checkval(eccfin-ecc,decc,tolecc,nfailed(3),'eccentricity') do i=1,3 call update_test_scores(ntests,nfailed(i:i),npass) enddo From 50fe88885f62e76410011157e42ecf9f1388406c Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 22 Aug 2024 21:26:00 +0200 Subject: [PATCH 811/814] disable regnboby after SDAR tests --- src/tests/test_ptmass.f90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index bb0c28d4b..910402a13 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -1472,6 +1472,9 @@ subroutine test_SDAR(ntests,npass) call update_test_scores(ntests,nfailed(i:i),npass) enddo + use_regnbody = .false. + use_fourthorder = .false. + end subroutine test_SDAR !----------------------------------------------------------------------- From 626aca81754551f26cf3a9dbf86b02fbcb0b2e0f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 22 Aug 2024 23:29:02 +0200 Subject: [PATCH 812/814] reset all arrays after SDAR test --- src/tests/test_ptmass.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index 910402a13..eca5bd74b 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -1473,7 +1473,7 @@ subroutine test_SDAR(ntests,npass) enddo use_regnbody = .false. - use_fourthorder = .false. + call init_part() end subroutine test_SDAR From 147568c2582438f59ed76be221c52c7d1a2007f9 Mon Sep 17 00:00:00 2001 From: Christopher Russell Date: Wed, 28 Aug 2024 12:39:55 -0400 Subject: [PATCH 813/814] fix potentially and inadvertently shutting off accretion of gas particles onto sinks for ntypes=1 --- 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 b6eda445a..8ab859be4 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -685,7 +685,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, is_accretion = .false. endif - itype = iphase(igas) + itype = igas pmassi = massoftype(igas) dkdt = dki*dt From c8e42163101dc5918b59af17f64dc916b35bb71a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Sat, 31 Aug 2024 11:45:28 +0200 Subject: [PATCH 814/814] (substepping) reverse 0e0cc6d patch on the particle type sent to ptmass_accrete --- src/main/substepping.F90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 8ab859be4..6c37b140f 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -773,10 +773,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, fxi = fext(1,i) fyi = fext(2,i) fzi = fext(3,i) - if (ind_timesteps) then - ibin_wakei = ibin_wake(i) - itype = iphase(i) - endif + if (ind_timesteps) ibin_wakei = ibin_wake(i) call ptmass_accrete(1,nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& vxyzu(1,i),vxyzu(2,i),vxyzu(3,i),fxi,fyi,fzi,&